module Pinchot.Internal where
import Pinchot.Intervals
import Control.Applicative ((<|>), liftA2)
import Control.Exception (Exception)
import qualified Control.Lens as Lens
import Control.Monad (join, when)
import Control.Monad.Fix (MonadFix, mfix)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
import Control.Monad.Trans.State (State, runState, get, put)
import Data.Char (isUpper)
import Data.Foldable (toList)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Set (Set)
import Data.Sequence (Seq, ViewL(EmptyL, (:<)), viewl, (<|))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import Language.Haskell.TH
(ExpQ, ConQ, normalC, mkName, strictType, notStrict, newtypeD,
cxt, conT, Name, dataD, appT, DecsQ, appE, Q, uInfixE, bindS,
varE, varP, conE, Pat, Exp, lamE, recC, varStrictType, dyn)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as Syntax
import Text.Earley (satisfy, rule, symbol)
import qualified Text.Earley ((<?>))
type RuleName = String
type AlternativeName = String
data Branch t = Branch String (Seq (Rule t))
deriving (Eq, Ord, Show)
data RuleType t
= RTerminal (Intervals t)
| RBranch (Branch t, Seq (Branch t))
| RUnion (Rule t, Seq (Rule t))
| RSeqTerm (Seq t)
| ROptional (Rule t)
| RList (Rule t)
| RList1 (Rule t)
| RWrap (Rule t)
| RRecord (Seq (Rule t))
deriving (Eq, Ord, Show)
data Rule t = Rule String (Maybe String) (RuleType t)
deriving (Eq, Ord, Show)
label :: String -> Rule t -> Rule t
label s (Rule n _ t) = Rule n (Just s) t
(<?>) :: Pinchot t (Rule t) -> String -> Pinchot t (Rule t)
p <?> s = fmap (label s) p
infixr 0 <?>
data Names t = Names
{ tyConNames :: Set RuleName
, dataConNames :: Set String
, nextIndex :: Int
, allRules :: Map Int (Rule t)
} deriving (Eq, Ord, Show)
data Error
= InvalidName String
| EmptyNonTerminal String
deriving (Show, Typeable)
instance Exception Error
newtype Pinchot t a
= Pinchot { runPinchot :: ExceptT Error (State (Names t)) a }
deriving (Functor, Applicative, Monad, MonadFix)
addRuleName
:: RuleName
-> Pinchot t ()
addRuleName name = Pinchot $ do
old@(Names tyNames _ _ _) <- lift get
case name of
[] -> throw
x:_ -> do
when (not (isUpper x)) throw
when (Set.member name tyNames) throw
lift $ put (old { tyConNames = Set.insert name tyNames })
where
throw = throwE $ InvalidName name
addDataConName
:: AlternativeName
-> Pinchot t ()
addDataConName name = Pinchot $ do
old@(Names _ dcNames _ _) <- lift get
case name of
[] -> throw
x:_ -> do
when (not (isUpper x)) throw
when (Set.member name dcNames) throw
lift $ put (old { dataConNames = Set.insert name dcNames })
where
throw = throwE $ InvalidName name
newRule
:: RuleName
-> RuleType t
-> Pinchot t (Rule t)
newRule name ty = Pinchot $ do
runPinchot (addRuleName name)
st <- lift get
let r = Rule name Nothing ty
newSt = st { nextIndex = succ (nextIndex st)
, allRules = M.insert (nextIndex st) r
(allRules st)
}
lift (put newSt)
runPinchot $ addDataConNames r
return r
terminal
:: RuleName
-> Intervals t
-> Pinchot t (Rule t)
terminal name ivls = newRule name (RTerminal ivls)
splitNonTerminal
:: String
-> Seq (String, Seq (Rule t))
-> Pinchot t ((String, Seq (Rule t)), Seq (String, Seq (Rule t)))
splitNonTerminal n sq = Pinchot $ case viewl sq of
EmptyL -> throwE $ EmptyNonTerminal n
x :< xs -> return (x, xs)
terminalSeq
:: RuleName
-> Seq t
-> Pinchot t (Rule t)
terminalSeq name sq = newRule name (RSeqTerm sq)
nonTerminal
:: RuleName
-> Seq (AlternativeName, Seq (Rule t))
-> Pinchot t (Rule t)
nonTerminal name sq = do
(b1, bs) <- splitNonTerminal name sq
let branches = RBranch (uncurry Branch b1, fmap (uncurry Branch) bs)
newRule name branches
ruleConstructorNames
:: Rule t
-> Seq AlternativeName
ruleConstructorNames (Rule n _ t) = case t of
RTerminal _ -> Seq.singleton n
RBranch (b1, bs) -> branchName b1 <| fmap branchName bs
where
branchName (Branch x _) = x
RUnion (b1, bs) -> branchName b1 <| fmap branchName bs
where
branchName (Rule x _ _) = unionBranchName n x
RSeqTerm _ -> Seq.singleton n
ROptional _ -> Seq.singleton n
RList _ -> Seq.singleton n
RList1 _ -> Seq.singleton n
RWrap _ -> Seq.singleton n
RRecord _ -> Seq.singleton n
unionBranchName
:: RuleName
-> RuleName
-> AlternativeName
unionBranchName p b = p ++ '\'' : b
addDataConNames :: Rule t -> Pinchot t ()
addDataConNames = mapM_ addDataConName . ruleConstructorNames
union
:: RuleName
-> Seq (Rule t)
-> Pinchot t (Rule t)
union name sq = Pinchot $ case viewl sq of
EmptyL -> throwE $ EmptyNonTerminal name
x :< xs -> runPinchot $ newRule name (RUnion (x, xs))
record
:: RuleName
-> Seq (Rule t)
-> Pinchot t (Rule t)
record name sq = newRule name (RRecord sq)
list
:: Rule t
-> Pinchot t (Rule t)
list r@(Rule inner _ _) = newRule name (RList r)
where
name = inner ++ "'Seq"
list1
:: Rule t
-> Pinchot t (Rule t)
list1 r@(Rule inner _ _) = newRule name (RList1 r)
where
name = inner ++ "'Seq1"
option
:: Rule t
-> Pinchot t (Rule t)
option r@(Rule inner _ _) = newRule name (ROptional r)
where
name = inner ++ "'Maybe"
wrap
:: RuleName
-> Rule t
-> Pinchot t (Rule t)
wrap name r = newRule name (RWrap r)
getAncestors
:: Rule t
-> State (Set String) (Seq (Rule t))
getAncestors r@(Rule name _ ei) = do
set <- get
if Set.member name set
then return Seq.empty
else do
put (Set.insert name set)
case ei of
RTerminal _ -> return (Seq.singleton r)
RBranch (b1, bs) -> do
as1 <- branchAncestors b1
ass <- fmap join . mapM branchAncestors $ bs
return $ r <| as1 <> ass
RUnion (b1, bs) -> do
c1 <- getAncestors b1
cs <- fmap join . mapM getAncestors $ bs
return $ r <| c1 <> cs
RSeqTerm _ -> return (Seq.singleton r)
ROptional c -> do
cs <- getAncestors c
return $ r <| cs
RList c -> do
cs <- getAncestors c
return $ r <| cs
RList1 c -> do
cs <- getAncestors c
return $ r <| cs
RWrap c -> do
cs <- getAncestors c
return $ r <| cs
RRecord ls -> do
cs <- fmap join . mapM getAncestors $ ls
return $ r <| cs
where
branchAncestors (Branch _ rs) = fmap join . mapM getAncestors $ rs
ruleAndAncestors
:: Rule t
-> Seq (Rule t)
ruleAndAncestors r = fst $ runState (getAncestors r) Set.empty
rulesDemandedBeforeDefined :: Foldable f => f (Rule t) -> Set Name
rulesDemandedBeforeDefined = snd . foldl f (Set.empty, Set.empty)
where
f (lhsDefined, results) (Rule nm _ ty)
= (Set.insert nm lhsDefined, results')
where
results' = case ty of
RTerminal _ -> results
RBranch (b1, bs) -> foldr checkBranch (checkBranch b1 results) bs
where
checkBranch (Branch _ rls) rslts = foldr checkRule rslts rls
RUnion (b1, bs) -> foldr checkRule (checkRule b1 results) bs
RSeqTerm _ -> results
ROptional r -> checkRule r results
RList r -> addHelper $ checkRule r results
RList1 r -> addHelper $ checkRule r results
RWrap r -> checkRule r results
RRecord sq -> foldr checkRule results $ sq
checkRule (Rule name _ _) rslts
| Set.member name lhsDefined = rslts
| otherwise = Set.insert (ruleName name) rslts
addHelper = Set.insert (helperName nm)
thBranch :: Branch t -> ConQ
thBranch (Branch nm rules) = normalC name fields
where
name = mkName nm
mkField (Rule n _ _) = strictType notStrict (conT (mkName n))
fields = toList . fmap mkField $ rules
thUnionBranch
:: RuleName
-> Rule t
-> ConQ
thUnionBranch parent (Rule child _ _) = normalC name fields
where
name = mkName (unionBranchName parent child)
fields = [strictType notStrict (conT (mkName child))]
thRule
:: Syntax.Lift t
=> Bool
-> Name
-> Seq Name
-> Rule t
-> TH.Q [TH.Dec]
thRule doLenses typeName derives (Rule nm _ ruleType) = do
ty <- makeType typeName derives nm ruleType
lenses <- if doLenses then ruleToOptics typeName nm ruleType
else return []
inst <- productionDecl nm ruleType
return (ty : inst : lenses)
makeType
:: Name
-> Seq Name
-> String
-> RuleType t
-> TH.Q TH.Dec
makeType typeName derivesSeq nm ruleType = case ruleType of
RTerminal _ -> newtypeD (cxt []) name [] newtypeCon derives
where
newtypeCon = normalC name
[strictType notStrict (conT typeName)]
RBranch (b1, bs) -> dataD (cxt []) name [] cons derives
where
cons = thBranch b1 : toList (fmap thBranch bs)
RUnion (b1, bs) -> dataD (cxt []) name [] cons derives
where
cons = thUnionBranch nm b1 : toList (fmap (thUnionBranch nm) bs)
RSeqTerm _ -> newtypeD (cxt []) name [] cons derives
where
cons = normalC name
[strictType notStrict (appT [t| Seq |]
(conT typeName))]
ROptional (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives
where
newtypeCon = normalC name
[strictType notStrict (appT [t| Maybe |]
(conT (mkName inner)))]
RList (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives
where
newtypeCon = normalC name
[strictType notStrict (appT [t| Seq |]
(conT (mkName inner)))]
RList1 (Rule inner _ _) -> newtypeD (cxt []) name [] cons derives
where
cons = normalC name
[ strictType notStrict (TH.tupleT 2 `appT` (conT (mkName inner))
`appT` ([t| Seq |] `appT` (conT (mkName inner)))) ]
RWrap (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives
where
newtypeCon = normalC name
[ strictType notStrict (conT (mkName inner)) ]
RRecord sq -> dataD (cxt []) name [] [ctor] derives
where
ctor = recC name . zipWith mkField [(0 :: Int) ..] . toList $ sq
mkField num (Rule rn _ _) = varStrictType (mkName fldNm)
(strictType notStrict (conT (mkName rn)))
where
fldNm = '_' : fieldName num nm rn
where
name = mkName nm
derives = toList derivesSeq
fieldName
:: Int
-> String
-> String
-> String
fieldName idx par inn = "r'" ++ par ++ "'" ++ show idx ++ "'" ++ inn
thAllRules
:: Syntax.Lift t
=> Bool
-> Name
-> Seq Name
-> Map Int (Rule t)
-> DecsQ
thAllRules doOptics typeName derives
= fmap join
. sequence
. fmap (thRule doOptics typeName derives)
. fmap snd
. M.toAscList
makeWrapped
:: TH.Type
-> String
-> TH.Dec
makeWrapped wrappedType nm = TH.InstanceD [] typ decs
where
name = TH.mkName nm
local = mkName "_x"
typ = (TH.ConT ''Lens.Wrapped) `TH.AppT` (TH.ConT name)
decs = [assocType, wrapper]
where
assocType = TH.TySynInstD ''Lens.Unwrapped
(TH.TySynEqn [TH.ConT name] wrappedType)
wrapper = TH.FunD 'Lens._Wrapped
[TH.Clause [] (TH.NormalB body) []]
where
body = (TH.VarE 'Lens.iso)
`TH.AppE` unwrap
`TH.AppE` doWrap
where
unwrap = TH.LamE [lambPat] (TH.VarE local)
where
lambPat = TH.ConP name [TH.VarP local]
doWrap = TH.LamE [lambPat] expn
where
expn = (TH.ConE name)
`TH.AppE` (TH.VarE local)
lambPat = TH.VarP local
dynP :: String -> TH.PatQ
dynP = TH.varP . TH.mkName
seqTermToOptics
:: Syntax.Lift t
=> Name
-> String
-> Seq t
-> TH.Q [TH.Dec]
seqTermToOptics termName nm sq = do
e1 <- TH.sigD (TH.mkName ('_':nm)) (TH.conT ''Lens.Prism'
`TH.appT` (TH.conT ''Seq `TH.appT` TH.conT termName)
`TH.appT` TH.conT (TH.mkName nm))
e2 <- TH.valD prismName (TH.normalB expn) []
return [e1, e2]
where
prismName = TH.varP (TH.mkName ('_' : nm))
fetchPat = TH.conP (TH.mkName nm) [TH.varP (TH.mkName "_x")]
fetchName = TH.varE (TH.mkName "_x")
ctor = TH.conE (TH.mkName nm)
expn = [| let fetch $fetchPat = $fetchName
store _term
| $(liftSeq sq) == _term = Right ($ctor _term)
| otherwise = Left _term
in Lens.prism fetch store
|]
terminalToOptics
:: Syntax.Lift t
=> Name
-> String
-> Intervals t
-> TH.Q [TH.Dec]
terminalToOptics termName nm ivls = do
e1 <- TH.sigD (TH.mkName ('_':nm)) (TH.conT ''Lens.Prism'
`TH.appT` TH.conT termName
`TH.appT` TH.conT (TH.mkName nm))
e2 <- TH.valD prismName (TH.normalB expn) []
return [e1, e2]
where
prismName = TH.varP (TH.mkName ('_' : nm))
fetchPat = TH.conP (TH.mkName nm) [TH.varP (TH.mkName "_x")]
fetchName = TH.varE (TH.mkName "_x")
ctor = TH.conE (TH.mkName nm)
expn = [| let fetch $fetchPat = $fetchName
store _term
| inIntervals ivls _term = Right ($ctor _term)
| otherwise = Left _term
in Lens.prism fetch store
|]
optionalToOptics
:: String
-> String
-> TH.Dec
optionalToOptics wrappedName = makeWrapped maybeName
where
maybeName = (TH.ConT ''Maybe) `TH.AppT` (TH.ConT (TH.mkName wrappedName))
many1ToOptics
:: String
-> String
-> TH.Dec
many1ToOptics wrappedName = makeWrapped tupName
where
tupName = (TH.TupleT 2)
`TH.AppT` (TH.ConT (TH.mkName wrappedName))
`TH.AppT` ((TH.ConT ''Seq) `TH.AppT` (TH.ConT (TH.mkName wrappedName)))
manyToOptics
:: String
-> String
-> TH.Dec
manyToOptics wrappedName = makeWrapped innerName
where
innerName = (TH.ConT ''Seq) `TH.AppT` (TH.ConT (TH.mkName wrappedName))
wrapToOptics
:: String
-> String
-> TH.Dec
wrapToOptics wrappedName = makeWrapped innerName
where
innerName = TH.ConT (TH.mkName wrappedName)
terminalSeqToOptics
:: Name
-> String
-> TH.Dec
terminalSeqToOptics terminalName = makeWrapped sqType
where
sqType = (TH.ConT ''Seq) `TH.AppT` (TH.ConT terminalName)
branchesToOptics
:: String
-> Branch t
-> Seq (Branch t)
-> [TH.Dec]
branchesToOptics nm b1 bsSeq = concat $ makePrism b1 : fmap makePrism bs
where
bs = toList bsSeq
makePrism (Branch inner rulesSeq) = [ signature, binding ]
where
rules = toList rulesSeq
prismName = TH.mkName ('_' : inner)
signature = TH.SigD prismName
$ (TH.ConT ''Lens.Prism')
`TH.AppT` (TH.ConT (TH.mkName nm))
`TH.AppT` fieldsType
where
fieldsType = case rules of
[] -> TH.TupleT 0
Rule r1 _ _ : [] -> TH.ConT (TH.mkName r1)
rs -> foldl addType (TH.TupleT (length rs)) rs
where
addType soFar (Rule r _ _) = soFar `TH.AppT`
(TH.ConT (TH.mkName r))
binding = TH.ValD (TH.VarP prismName) body []
where
body = TH.NormalB
$ (TH.VarE 'Lens.prism)
`TH.AppE` setter
`TH.AppE` getter
where
setter = TH.LamE [pat] expn
where
(pat, expn) = case rules of
[] -> (TH.TupP [], TH.ConE (TH.mkName inner))
_ : [] -> (TH.VarP local,
TH.ConE (TH.mkName inner)
`TH.AppE` TH.VarE local)
where
local = TH.mkName "_x"
ls -> (TH.TupP pats, set)
where
pats = fmap (\i -> TH.VarP (mkName ("_x" ++ show i)))
. take (length ls) $ [(0 :: Int) ..]
set = foldl addVar start . take (length ls)
$ [(0 :: Int) ..]
where
addVar acc i = acc `TH.AppE`
(TH.VarE (TH.mkName ("_x" ++ show i)))
start = TH.ConE (TH.mkName inner)
getter = TH.LamE [pat] expn
where
local = TH.mkName "_x"
pat = TH.VarP local
expn = TH.CaseE (TH.VarE (TH.mkName "_x")) $
TH.Match patCtor bodyCtor []
: rest
where
patCtor = TH.ConP (TH.mkName inner)
. fmap (\i -> TH.VarP (TH.mkName $ "_y" ++ show i))
. take (length rules)
$ [(0 :: Int) ..]
bodyCtor = TH.NormalB . (TH.ConE 'Right `TH.AppE`)
$ case rules of
[] -> TH.TupE []
_:[] -> TH.VarE (TH.mkName "_y0")
_ -> TH.TupE
. fmap (\i -> TH.VarE (TH.mkName $ "_y" ++ show i))
. take (length rules)
$ [(0 :: Int) ..]
rest = case bs of
[] -> []
_ -> [TH.Match patBlank bodyBlank []]
where
patBlank = TH.VarP (TH.mkName "_z")
bodyBlank = TH.NormalB
$ TH.ConE ('Left)
`TH.AppE` TH.VarE (TH.mkName "_z")
unionToOptics
:: String
-> Rule t
-> Seq (Rule t)
-> TH.DecsQ
unionToOptics parentName r1 rs
= fmap concat . sequence $ optics r1 : fmap optics (toList rs)
where
optics (Rule r _ _) = sequence $ sig : prism : []
where
sig = TH.sigD prismName [t| Lens.Prism' $bigType $innerType |]
prismName = TH.mkName $ "_" ++ parentName ++ "'" ++ r
bigType = TH.conT (TH.mkName parentName)
innerType = TH.conT (TH.mkName r)
prism = TH.valD (TH.varP prismName)
(TH.normalB [| Lens.prism $dataCtor $sToA |] ) []
sToA = TH.lamE [pat] expn
where
pat = dynP "_x"
expn = TH.caseE (dyn "_x")
[ TH.match (TH.conP (TH.mkName (unionBranchName parentName r))
[TH.varP (TH.mkName "_a")])
(TH.normalB [| Right $(dyn "_a") |]) []
, TH.match (dynP "_b")
(TH.normalB [| Left $(dyn "_b") |]) []
]
dataCtor = TH.conE (TH.mkName (unionBranchName parentName r))
recordsToOptics
:: String
-> Seq (Rule t)
-> [TH.Dec]
recordsToOptics nm
= concat . zipWith makeLens [(0 :: Int) ..] . toList
where
makeLens index (Rule inner _ _) = [ signature, function ]
where
fieldNm = fieldName index nm inner
lensName = mkName fieldNm
signature = TH.SigD lensName
$ (TH.ConT ''Lens.Lens')
`TH.AppT` (TH.ConT (TH.mkName nm))
`TH.AppT` (TH.ConT (TH.mkName inner))
function = TH.FunD lensName [TH.Clause [] (TH.NormalB body) []]
where
namedRec = TH.mkName "_namedRec"
namedNewVal = TH.mkName "_namedNewVal"
body = (TH.VarE 'Lens.lens) `TH.AppE` getter `TH.AppE` setter
where
getter = TH.LamE [pat] expn
where
pat = TH.VarP namedRec
expn = (TH.VarE (TH.mkName ('_' : fieldNm)))
`TH.AppE` (TH.VarE namedRec)
setter = TH.LamE [patRec, patNewVal] expn
where
patRec = TH.VarP namedRec
patNewVal = TH.VarP namedNewVal
expn = TH.RecUpdE (TH.VarE namedRec)
[ (TH.mkName ('_' : fieldNm), TH.VarE namedNewVal) ]
ruleToOptics
:: Syntax.Lift t
=> Name
-> String
-> RuleType t
-> TH.DecsQ
ruleToOptics terminalName nm ty = case ty of
RTerminal ivl -> terminalToOptics terminalName nm ivl
RBranch (b1, bs) -> return $ branchesToOptics nm b1 bs
RUnion (r1, rs) -> unionToOptics nm r1 rs
RSeqTerm sq -> seqTermToOptics terminalName nm sq
ROptional (Rule inner _ _) -> return [optionalToOptics inner nm]
RList (Rule inner _ _) -> return [manyToOptics inner nm]
RList1 (Rule inner _ _) -> return [many1ToOptics inner nm]
RWrap (Rule inner _ _) -> return [wrapToOptics inner nm]
RRecord recs -> return $ recordsToOptics nm recs
type MakeOptics = Bool
makeOptics :: MakeOptics
makeOptics = True
noOptics :: MakeOptics
noOptics = False
allRulesToTypes
:: Syntax.Lift t
=> MakeOptics
-> Name
-> Seq Name
-> Pinchot t a
-> DecsQ
allRulesToTypes doOptics typeName derives pinchot = case ei of
Left err -> fail $ "pinchot: bad grammar: " ++ show err
Right _ -> thAllRules doOptics typeName derives (allRules st')
where
(ei, st') = runState (runExceptT (runPinchot pinchot))
(Names Set.empty Set.empty 0 M.empty)
ruleTreeToTypes
:: Syntax.Lift t
=> MakeOptics
-> Name
-> Seq Name
-> Pinchot t (Rule t)
-> DecsQ
ruleTreeToTypes doOptics typeName derives pinchot = case ei of
Left err -> fail $ "pinchot: bad grammar: " ++ show err
Right r -> fmap join . sequence . toList
. fmap (thRule doOptics typeName derives)
. runCalc . getAncestors $ r
where
runCalc stateCalc = fst $ runState stateCalc (Set.empty)
(ei, _) = runState (runExceptT (runPinchot pinchot))
(Names Set.empty Set.empty 0 M.empty)
addPrefix
:: String
-> String
-> String
addPrefix pfx suf
| null pfx = suf
| otherwise = pfx ++ '.':suf
ruleToParser
:: Syntax.Lift t
=> String
-> Rule t
-> [TH.StmtQ]
ruleToParser prefix (Rule nm mayDescription rt) = case rt of
RTerminal ivls -> [makeRule expression]
where
expression = [| fmap $constructor (satisfy (inIntervals ivls)) |]
RBranch (b1, bs) -> [makeRule expression]
where
expression = foldl addBranch (branchToParser prefix b1) bs
where
addBranch tree branch =
[| $tree <|> $(branchToParser prefix branch) |]
RUnion (Rule r1 _ _, rs) -> [makeRule expression]
where
expression = foldl adder start rs
where
branch r = [| $(conE (mkName
(addPrefix prefix . unionBranchName nm $ r))) <$>
$(varE (ruleName r)) |]
start = branch r1
adder soFar (Rule r _ _) = [| $soFar <|> $(branch r) |]
RSeqTerm sq -> [nestRule, topRule]
where
nestRule = bindS (varP helper) [| rule $(foldl addTerm start sq) |]
where
start = [|pure Seq.empty|]
addTerm acc x = [| liftA2 (<|) (symbol x) $acc |]
topRule = makeRule (wrapper helper)
ROptional (Rule innerNm _ _) -> [makeRule expression]
where
expression = [| fmap $constructor (pure Nothing <|> $(just)) |]
where
just = [| fmap Just $(varE (ruleName innerNm)) |]
RList (Rule innerNm _ _) -> [nestRule, makeRule (wrapper helper)]
where
nestRule = bindS (varP helper) ([|rule|] `appE` parseSeq)
where
parseSeq = uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq
where
pSeq = [|liftA2 (<|) $(varE (ruleName innerNm)) $(varE helper) |]
RList1 (Rule innerNm _ _) -> [nestRule, makeRule topExpn]
where
nestRule = bindS (varP helper) [|rule $(parseSeq)|]
where
parseSeq = [| pure Seq.empty <|> $pSeq |]
where
pSeq = [| (<|) <$> $(varE (ruleName innerNm))
<*> $(varE helper) |]
topExpn = [| $constructor <$> ( (,) <$> $(varE (ruleName innerNm))
<*> $(varE helper)
) |]
RWrap (Rule innerNm _ _) -> [makeRule expression]
where
expression = [|fmap $constructor $(varE (ruleName innerNm)) |]
RRecord sq -> [makeRule expression]
where
expression = case viewl sq of
EmptyL -> [| pure $constructor |]
Rule r1 _ _ :< restFields -> foldl addField fstField restFields
where
fstField = [| $constructor <$> $(varE (ruleName r1)) |]
addField soFar (Rule r _ _)
= [| $soFar <*> $(varE (ruleName r)) |]
where
makeRule expression = varP (ruleName nm) `bindS`
[|rule ($expression Text.Earley.<?> $(textToExp desc))|]
desc = maybe nm id mayDescription
textToExp txt = [| $(Syntax.lift txt) |]
constructor = constructorName prefix nm
wrapper wrapRule = [|fmap $constructor $(varE wrapRule) |]
helper = helperName nm
constructorName
:: String
-> String
-> ExpQ
constructorName pfx nm = conE (mkName name)
where
name = pfx' ++ nm
pfx'
| null pfx = ""
| otherwise = pfx ++ "."
ruleName :: String -> Name
ruleName suffix = mkName ("_rule'" ++ suffix)
helperName :: String -> Name
helperName suffix = mkName ("_helper'" ++ suffix)
branchToParser
:: Syntax.Lift t
=> String
-> Branch t
-> ExpQ
branchToParser prefix (Branch name rules) = case viewl rules of
EmptyL -> [| pure $constructor |]
(Rule rule1 _ _) :< xs -> foldl f z xs
where
z = [| $constructor <$> $(varE (ruleName rule1)) |]
f soFar (Rule rule2 _ _) = [| $soFar <*> $(varE (ruleName rule2)) |]
where
constructor = constructorName prefix name
lazyPattern
:: Foldable c
=> c Name
-> Q Pat
lazyPattern = finish . foldr gen [p| () |]
where
gen name rest = [p| ($(varP name), $rest) |]
finish pat = [p| ~(_, $pat) |]
bigTuple
:: Foldable c
=> Name
-> c Name
-> ExpQ
bigTuple top = finish . foldr f [| () |]
where
f n rest = [| ( $(varE n), $rest) |]
finish tup = [| ($(varE top), $tup) |]
earleyGrammar
:: Syntax.Lift t
=> String
-> Pinchot t (Rule t)
-> Q Exp
earleyGrammar prefix pinc = case ei of
Left err -> fail $ "pinchot: bad grammar: " ++ show err
Right r -> earleyGrammarFromRule prefix r
where
(ei, _) = runState (runExceptT (runPinchot pinc))
(Names Set.empty Set.empty 0 M.empty)
earleyGrammarFromRule
:: Syntax.Lift t
=> String
-> Rule t
-> Q Exp
earleyGrammarFromRule prefix r@(Rule top _ _) = [| fmap fst (mfix $lamb) |]
where
neededRules = ruleAndAncestors r
otherNames = rulesDemandedBeforeDefined neededRules
expression =
let stmts = concatMap (ruleToParser prefix)
. toList $ neededRules
result = bigTuple (ruleName top) otherNames
in TH.doE (stmts ++ [TH.noBindS ([|return|] `appE` result)])
lamb = lamE [lazyPattern otherNames] expression
allEarleyGrammars
:: Syntax.Lift t
=> String
-> Pinchot t a
-> DecsQ
allEarleyGrammars prefix pinc = case ei of
Left err -> fail $ "pinchot: bad grammar: " ++ show err
Right _ -> sequence . fmap makeDecl . fmap snd . M.toList . allRules $ st
where
(ei, st) = runState (runExceptT (runPinchot pinc))
(Names Set.empty Set.empty 0 M.empty)
makeDecl rule@(Rule nm _ _) = TH.valD pat body []
where
pat = TH.varP (TH.mkName $ "g'" ++ nm)
body = TH.normalB (earleyGrammarFromRule prefix rule)
prodDeclName :: String -> TH.Name
prodDeclName name = TH.mkName $ "t'" ++ name
prodFn :: String -> TH.ExpQ
prodFn = TH.varE . prodDeclName
addIndices :: Foldable c => c a -> [(Int, a)]
addIndices = zip [0..] . toList
productionDecl
:: String
-> RuleType t
-> TH.DecQ
productionDecl n t = TH.funD (prodDeclName n) clauses
where
clauses = case t of
RTerminal _ -> [TH.clause [pat] bdy []]
where
pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_x")]
bdy = TH.normalB [| Seq.singleton $(TH.varE (TH.mkName "_x")) |]
RBranch (b1, bs) -> branchToClause b1
: fmap branchToClause (toList bs)
RSeqTerm _ -> [TH.clause [pat] bdy []]
where
pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_x")]
bdy = TH.normalB (dyn "_x")
ROptional (Rule inner _ _) -> [justClause, nothingClause]
where
justClause
= TH.clause [TH.conP (TH.mkName n)
[TH.conP 'Just [TH.varP (TH.mkName "_b")]]]
(TH.normalB [| $(prodFn inner)
$(TH.varE (TH.mkName "_b")) |])
[]
nothingClause
= TH.clause [TH.conP (TH.mkName n)
[TH.conP 'Nothing []]]
(TH.normalB [| Seq.empty |]) []
RList (Rule inner _ _) -> [TH.clause [pat] bdy []]
where
pat = TH.conP (TH.mkName n) [TH.varP (TH.mkName "_a")]
bdy = TH.normalB [| join
$ fmap $(prodFn inner) $(TH.varE (TH.mkName "_a")) |]
RList1 (Rule inner _ _) -> [TH.clause [pat] bdy []]
where
pat = TH.conP (TH.mkName n)
[TH.tupP [ dynP "_x1", dynP "_xs" ]]
bdy = TH.normalB
[| $lft `mappend` (join (fmap $(prodFn inner)
$(dyn "_xs"))) |]
where
lft = [| $(prodFn inner) $(dyn "_x1") |]
RWrap (Rule inner _ _) -> [TH.clause [pat] bdy []]
where
pat = TH.conP (TH.mkName n) [dynP "_x"]
bdy = TH.normalB [| $(prodFn inner) $(dyn "_x") |]
RRecord sq -> [TH.clause [pat] (TH.normalB bdy) []]
where
pat = TH.conP (TH.mkName n) . fmap mkPat
. fmap fst . addIndices $ sq
where
mkPat idx = dynP ("_x'" ++ show idx)
bdy = foldr addField [| Seq.empty |] . addIndices $ sq
where
addField (idx, (Rule nm _ _)) acc = [| $this `mappend` $acc |]
where
this = [| $(prodFn nm) $(dyn ("_x'" ++ show idx)) |]
RUnion (r1, rs) -> mkClause r1 : fmap mkClause (toList rs)
where
mkClause (Rule inner _ _) = TH.clause [pat] bdy []
where
pat = TH.conP (TH.mkName (unionBranchName n inner))
[dynP "_x"]
bdy = TH.normalB [| $(prodFn inner) $(dyn "_x") |]
branchToClause :: Branch t -> TH.ClauseQ
branchToClause (Branch n rs) = TH.clause [pat] bdy []
where
pat = TH.conP (TH.mkName n) fields
where
fields = fmap mkField . fmap fst . addIndices $ rs
where
mkField idx = TH.varP (TH.mkName ("_x'" ++ show idx))
bdy = TH.normalB [| join $sq |]
where
sq = foldr addField (TH.varE 'Seq.empty) . addIndices $ rs
where
addField (idx, (Rule inner _ _)) acc = [| $newTerm <| $acc |]
where
newTerm = [| $(prodFn inner) $(TH.varE
(TH.mkName ("_x'" ++ show idx))) |]