module Language.Grammars.SyntaxMacros.UUParsing where
import qualified Text.ParserCombinators.UU.Core as UU
import Text.ParserCombinators.UU
import Text.ParserCombinators.UU.Utils
import Text.ParserCombinators.UU.BasicInstances hiding (Parser,input,msgs)
import Language.Grammars.Grammar
import Language.AbstractSyntax.TTTAS
type Parser a = P (Str Char String LineCol) a
pInt :: Parser Int
pInt = pInteger
pChr :: Parser Char
pChr = pAscii
pVar :: Parser String
pVar = ((:) <$> pLower <*> pList pIdChar `micro` 2) <* spaces
pCon :: Parser String
pCon = ((:) <$> pUpper <*> pList pIdChar `micro` 2) <* spaces
pIdChar :: Parser Char
pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='"
pOp :: Parser String
pOp = (pList1 $ pAnySym ('|':"!#$%&*+./<=>?@\\^-~:") `micro` 2) <* spaces
pTerm :: String -> Parser String
pTerm keyw = pToken keyw `micro` 1 <* spaces
spaces :: Parser String
spaces = pMunch (`elem` " \n")
lc2Pos :: LineCol -> Pos
lc2Pos (LineCol l c) = Pos l c
newtype Const f a s = C {unC :: f a}
compile :: Grammar a -> Parser a
compile (Grammar (start :: Ref a env) rules)
= unC (lookupEnv start result)
where result =
mapEnv
(\ (PS ps) -> C (foldr1 (<|>) [ comp p | p <- ps]))
rules
comp :: forall t . Prod NF t env -> Parser t
comp (Star x y) = comp x <*> comp y
comp (FlipStar x y) = comp x <**> comp y
comp (Pure x) = pure x
comp (Sym (Term t)) = (DTerm . lc2Pos) <$> pPos <*> pTerm t
comp (Sym (Nont n)) = unC (lookupEnv n result)
comp (Sym TermInt) = (DTerm . lc2Pos) <$> pPos <*> pInt
comp (Sym TermChar) = (DTerm . lc2Pos) <$> pPos <*> pChr
comp (Sym TermVarid) = (DTerm . lc2Pos) <$> pPos <*> pVar
comp (Sym TermConid) = (DTerm . lc2Pos) <$> pPos <*> pCon
comp (Sym TermOp) = (DTerm . lc2Pos) <$> pPos <*> pOp
mapEnv :: (forall a . f a s -> g a s)
-> Env f s env -> Env g s env
mapEnv _ Empty = Empty
mapEnv f (Ext r v) = Ext (mapEnv f r) (f v)
data ParseResult a = Ok a
| Rep a [Error LineCol]
deriving Show
parse :: Parser a -> String -> ParseResult a
parse p input = case UU.parse ( (,) <$> p <*> pEnd) (createStr (LineCol 0 0) input) of
(a,[] ) -> Ok a
(a,msgs) -> Rep a msgs