module Language.Grammars.Murder where
import Language.AbstractSyntax.TTTAS
import Control.Arrow
import Language.Grammars.Grammar
import Language.Grammars.Transformations.RemoveFix
import Language.Grammars.Transformations.RemoveEmpties
import Language.Grammars.Transformations.LeftCorner
type GramTrafo = Trafo Unit (Productions NF)
type PreGramTrafo = Trafo Unit (Productions TL)
type ExtGram env start nts
= PreGramTrafo env () (Export start nts env)
type GramExt env start nts start' nts'
= PreGramTrafo env (Export start nts env) (Export start' nts' env)
data Export start nts env = Export (Symbol start TNonT env) (nts env)
addNT :: PreGramTrafo env (PreProductions TL env a) (Symbol a TNonT env)
addNT = proc p -> do
r <- newSRef -< prod p
returnA -< Nont r
addProds :: PreGramTrafo env
(Symbol a TNonT env, PreProductions TL env a) ()
addProds = proc (nont, prds) -> do
updateFinalEnv -<
updateEnv (\ps -> PS $ (unPP prds) ++ (unPS ps)) (getRefNT nont)
closeGram :: (forall env. ExtGram env a nts)
-> Grammar a
closeGram prds = case runTrafo prds Unit () of
Result _ (Export (Nont r) _) gram
-> (leftCorner . removeEmpties) (removeFix r gram)
extendGram :: (NTRecord (nts env), NTRecord (nts' env))
=> ExtGram env start nts
-> GramExt env start nts start' nts'
-> ExtGram env start' nts'
extendGram g sm = g >>> sm
(+>>) :: (NTRecord (nts env), NTRecord (nts' env))
=> ExtGram env start nts
-> GramExt env start nts start' nts'
-> ExtGram env start' nts'
(+>>) = extendGram
exportNTs :: NTRecord (nts env) => PreGramTrafo env (Export start nts env) (Export start nts env)
exportNTs = returnA
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)
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
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)
extendExport :: Export start t env -> (t env -> nts env) -> Export start nts env
extendExport (Export r nts) ext = Export r (ext nts)