{-# LANGUAGE OverloadedStrings #-}

module Example
  ( runExample,
  )
where

import Control.Applicative hiding (many, some)
import Data.Text (Text)
import Data.Void
import System.IO as SIO
import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char (space1, string')
import qualified Text.Megaparsec.Char.Lexer as L
import Text.Megaparsec.Debug
import Text.Pretty.Simple (pPrint)

-- Types

type Parser = Parsec Void Text

data SyntaxAst = Keyword Text | Recurse | Optional SyntaxAst | Many [SyntaxAst]

--  Megaparsec Base Parsers

-- Space consumer - used by other parsers to ignore whitespace
sc :: Parser ()
sc =
  L.space
    space1
    (L.skipLineComment "--")
    (L.skipBlockComment "/*" "*/")

-- Runs a parser, then consumes any left over space with sc
lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc

-- Parses a string, then consumes any left over space with sc
symbol :: Text -> Parser Text
symbol = L.symbol sc

-- Parses something between parentheses
inParens :: Parser a -> Parser a
inParens =
  between
    (symbol "(")
    (symbol ")")

-- Transforms the AST into a parser
transformSyntaxExprToParser :: Parser [Text] -> SyntaxAst -> Parser [Text]
transformSyntaxExprToParser self = go
  where
    go (Many exprs) = dbg "Many" (foldr1 (liftA2 (<>)) (fmap (transformSyntaxExprToParser self) exprs))
    go (Keyword text) = dbg "Keyword" (pure <$> lexeme (string' text))
    go (Optional inner) = dbg "Optional" (option [] (try (inParens (go inner))))
    go Recurse = dbg "Recurse" self

-- Walks over the parser AST and convert it to a parser
createParser :: [SyntaxAst] -> Parser [Text]
createParser expressions = parser
  where
    parser =
      foldr1
        (liftA2 (<>))
        (fmap (transformSyntaxExprToParser parser) expressions)

runExample :: IO ()
runExample = do
  -- To make the example simple, lets cut out the language definition parsing and just define
  -- it literally.
  let languageParser = createParser [Keyword "A", Keyword "B", Keyword "C", Optional (Many [Recurse])]
  let run p = runParser p "" "A B C (A B C (A B C))"
  let result = run languageParser
  case result of
    Left bundle -> SIO.putStrLn (errorBundlePretty bundle)
    Right xs -> pPrint xs