{-# LANGUAGE Arrows, ExistentialQuantification, GADTs, Rank2Types, FlexibleContexts, ScopedTypeVariables , EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, OverlappingInstances, FunctionalDependencies, UndecidableInstances #-} module Language.Grammars.SyntaxMacros where import Language.AbstractSyntax.TTTAS import Control.Arrow import qualified UU.Parsing as UU import Language.Grammars.SyntaxMacros.Scanner import Language.Grammars.Grammar import Language.Grammars.Transformations.RemoveFix import Language.Grammars.Transformations.RemoveEmpties import Language.Grammars.Transformations.LeftCorner type GramTrafo = Trafo Unit (Productions TL) type ExtGram env start nts = GramTrafo env () (Export start nts env) type SyntaxMacro env start nts start' nts' = GramTrafo env (Export start nts env) (Export start' nts' env) data Export start nts env = Export (Symbol start TNonT env) (nts env) -- add a new non-terminal to the grammar addNT :: GramTrafo env (ListProd TL env a) (Symbol a TNonT env) addNT = proc p -> do r <- newSRef -< prod p returnA -< Nont r -- add productions to an existing non-terminal addProds :: GramTrafo env (Symbol a TNonT env, ListProd TL env a) () addProds = proc (nont, prds) -> do updateFinalEnv -< updateEnv (\ps -> PS $ (unPP prds) ++ (unPS ps)) (getRefNT nont) -- close the grammar closeGram :: (forall env. ExtGram env a nts) -> Grammar a closeGram prds = case runTrafo prds Unit () of Result _ (Export (Nont r) _) gram -> (leftCorner . removeEmpties . removeFix) $ Grammar r gram extendGram :: (NTRecord (nts env), NTRecord (nts' env)) => ExtGram env start nts -> SyntaxMacro env start nts start' nts' -> ExtGram env start' nts' extendGram g sm = g >>> sm (<++>) :: (NTRecord (nts env), NTRecord (nts' env)) => ExtGram env start nts -> SyntaxMacro env start nts start' nts' -> ExtGram env start' nts' (<++>) = extendGram exportNTs :: NTRecord (nts env) => GramTrafo env (Export start nts env) (Export start nts env) exportNTs = returnA -- extensible record data NTCons nt v l env = NTCons (LSPair nt v TNonT env) (l env) data NTNil env = NTNil class NTRecord r instance NTRecord (NTNil env) instance (NTRecord (l env), NotDuplicated nt (l env)) => NTRecord (NTCons nt v l env) class Fail err data Duplicated nt class NotDuplicated nt r instance NotDuplicated nt (NTNil env) instance Fail (Duplicated nt) => NotDuplicated nt (NTCons nt v l env) -- using overlapping instance NotDuplicated nt1 (l env) => NotDuplicated nt1 (NTCons nt2 v l env) ntNil :: NTNil env ntNil = NTNil infixr 4 ^| (^|) :: NTRecord (NTCons nt a l env) => LSPair nt a TNonT env -> l env -> NTCons nt a l env (^|) = NTCons class GetNT nt r v | nt r -> v where getNT :: nt -> r -> v data NotFound nt instance Fail (NotFound nt) => GetNT nt (NTNil env) r where getNT = undefined instance GetNT nt (NTCons nt v l env) (Symbol v TNonT env) where -- using overlapping getNT _ (NTCons f _) = symLSPair f instance GetNT nt1 (l env) r => GetNT nt1 (NTCons nt2 v l env) r where getNT nont (NTCons _ l) = getNT nont l instance GetNT nt (nts env) r => GetNT nt (Export start nts env) r where getNT nont (Export _ nts) = getNT nont nts getStart :: Export start nts env -> (Symbol start TNonT env) getStart (Export start _) = start exportList :: Symbol start TNonT env -> (NTNil env -> nts env) -> Export start nts env exportList r l = Export r $ l ntNil export :: (NTRecord (l env), NotDuplicated nt (l env)) => nt -> Symbol a TNonT env -> l env -> NTCons nt a l env export l nont = (^|) (l ^= nont) -- COMPILE -------------------------------------------------------------------- pInt :: UU.Parser Token Int pChr :: UU.Parser Token Char pCon :: UU.Parser Token String pVar :: UU.Parser Token String pOp :: UU.Parser Token String pChr = head UU.<$> pChar pInt = read UU.<$> pInteger pCon = id UU.<$> pConid pVar = id UU.<$> pVarid pOp = id UU.<$> pVarsym pTerm :: (UU.IsParser p Token) => String -> p DTerm pTerm t = pKey t newtype Const f a s = C {unC :: f a} compile :: Grammar a -> UU.Parser Token a compile (Grammar (start :: Ref a env) rules) = unC (lookupEnv start result) where result = mapEnv (\ (PS ps) -> C (foldr1 (UU.<|>) [ comp p | p <- ps])) rules comp :: forall t . Prod TL t env -> UU.Parser Token t comp (Star x y) = comp x UU.<*> comp y comp (FlipStar x y) = comp x UU.<**> comp y comp (Pure x) = UU.pLow x comp (Sym (Term t)) = pTerm t comp (Sym (Nont n)) = unC (lookupEnv n result) comp (Sym TermInt) = pInt comp (Sym TermChar) = pChr comp (Sym TermVarid) = pVar comp (Sym TermConid) = pCon comp (Sym TermOp) = pOp comp (Fix _) = error "This shouldn't be happening!" 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) -- PARSE ---------------------------------------------------------------------- type ParseMsg = UU.Message Token (Maybe Token) data ParseResult a = Ok a | Rep a [ParseMsg] deriving Show parse :: UU.Parser Token a -> [Token] -> ParseResult a parse p input = case rparse p input of (a,[] ) -> Ok a (a,msgs) -> Rep a msgs rparse :: UU.Parser Token a -> [Token] -> (a, [ParseMsg]) rparse p input = let (UU.Pair a _,msgs) = eval (UU.parse p input) in (a,msgs) where eval :: UU.Steps a Token (Maybe Token) -> (a, [ParseMsg]) eval (UU.OkVal v r) = let (a,msgs) = v `seq` eval r in (v a,msgs) eval (UU.Ok r) = eval r eval (UU.Cost _ r) = eval r eval (UU.StRepair _ msg r) = let (v,msgs) = eval r in (v,msg:msgs) eval (UU.Best _ r _) = eval r eval (UU.NoMoreSteps v ) = (v,[])