module Language.Grammars.SyntaxMacros where
import Language.AbstractSyntax.TTTAS
import Control.Arrow
import UU.Parsing hiding (Symbol,parse,Ok)
import qualified UU.Parsing as UU
import Language.Grammars.SyntaxMacros.Scanner
import Language.Grammars.Grammar
import Language.Grammars.Transformations.LeftCorner
import Language.Grammars.Transformations.LeftFact
type GramTrafo = Trafo Unit Productions
type ExtGram env nts
= GramTrafo env () (nts env)
type SyntaxMacro env nts nts'
= GramTrafo env (nts env) (nts' env)
data Export start nts env = Export (Symbol start env) (nts env)
addNT :: GramTrafo env [Prod a env] (Symbol a env)
addNT = proc p -> do
r <- newSRef -< PS p
returnA -< Nont r
addProds :: GramTrafo env
(Symbol a env, [Prod a env]) ()
addProds = proc (Nont nt, prds) -> do
updateFinalEnv -<
updateEnv (\(PS ps) -> PS $ prds ++ ps) nt
closeGram :: (forall env. ExtGram env (Export a nts))
-> Grammar a
closeGram prds = case runTrafo prds Unit () of
Result _ (Export (Nont r) _) gram
-> (leftfactoring . leftcorner) $ Grammar r gram
extendGram :: (NTRecord (nts env), NTRecord (nts' env))
=> ExtGram env (Export start nts)
-> SyntaxMacro env (Export start nts) (Export start' nts')
-> ExtGram env (Export start' nts')
extendGram g sm = g >>> sm
exportNTs :: NTRecord (nts env) => GramTrafo env (Export start nts env) (Export start nts env)
exportNTs = returnA
newtype NTField nt a env = NTField { symbolNTField :: (Symbol a env) }
labelNTField :: NTField nt a env -> nt
labelNTField _ = undefined
data NTCons nt v l env = NTCons (NTField nt v 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)
instance NotDuplicated nt1 (l env) => NotDuplicated nt1 (NTCons nt2 v l env)
ntNil = NTNil
infixr 4 ^=
(^=) :: nt -> (Symbol a env) -> NTField nt a env
(^=) _ = NTField
infixr 2 ^|
(^|) :: NTRecord (NTCons nt a l env) => NTField nt a 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 env) where
getNT _ (NTCons f _) = symbolNTField f
instance GetNT nt1 (l env) r => GetNT nt1 (NTCons nt2 v l env) r where
getNT nt (NTCons _ l) = getNT nt l
pInt :: Parser Token Int
pChr :: Parser Token Char
pCon :: Parser Token String
pVar :: Parser Token String
pOp :: Parser Token String
pChr = head <$> pChar
pInt = read <$> pInteger
pCon = id <$> pConid
pVar = id <$> pVarid
pOp = id <$> pVarsym
pTerm t = const DTerm <$> (pKey t)
newtype Const f a s = C {unC :: f a}
compile :: Grammar a -> Parser Token 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 t env -> Parser Token t
comp (End x) = pLow x
comp (Seq (Term t) ss)
= flip ($) <$> pTerm t <*> comp ss
comp (Seq (Nont n) ss)
= flip ($) <$> unC (lookupEnv n result)
<*> comp ss
comp (Seq (NontInt) ss)
= flip ($) <$> pInt <*> comp ss
comp (Seq (NontChar) ss)
= flip ($) <$> pChr <*> comp ss
comp (Seq (NontVarid) ss)
= flip ($) <$> pVar <*> comp ss
comp (Seq (NontConid) ss)
= flip ($) <$> pCon <*> comp ss
comp (Seq (NontOp) ss)
= flip ($) <$> pOp <*> comp ss
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)
type ParseMsg = Message Token (Maybe Token)
data ParseResult a = Ok a
| Rep a [ParseMsg]
deriving Show
parse :: Parser Token a -> [Token] -> ParseResult a
parse p input = case rparse p input of
(a,[] ) -> Ok a
(a,msgs) -> Rep a msgs
rparse :: Parser Token a -> [Token] -> (a, [ParseMsg])
rparse p input = let ((Pair a _),msgs) = eval (UU.parse p input)
in (a,msgs)
where eval :: Steps a Token (Maybe Token) -> (a, [ParseMsg])
eval (OkVal v r) = let (a,msgs) = v `seq` eval r
in (v a,msgs)
eval (UU.Ok r) = eval r
eval (Cost _ r) = eval r
eval (StRepair _ msg r) = let (v,msgs) = eval r
in (v,msg:msgs)
eval (Best _ r _) = eval r
eval (NoMoreSteps v ) = (v,[])