module Pinchot.Earley where
import Pinchot.NonEmpty
import Pinchot.RecursiveDo
import Pinchot.Rules
import Pinchot.Types
import Pinchot.Intervals
import Control.Applicative ((<|>), liftA2)
import Data.Foldable (toList)
import Data.Sequence ((<|), viewl, ViewL(EmptyL, (:<)), Seq)
import qualified Data.Sequence as Seq
import qualified Language.Haskell.TH as T
import Pinchot.Internal.TemplateHaskellShim (dataD)
import qualified Language.Haskell.TH.Syntax as Syntax
import qualified Text.Earley
ruleToParser
:: Syntax.Lift t
=> String
-> Rule t
-> [(T.Name, T.ExpQ)]
ruleToParser prefix (Rule nm mayDescription rt) = case rt of
Terminal ivls -> [makeRule expression]
where
expression =
[| let f (c, a)
| inIntervals ivls c = Just
($(T.conE (quald prefix nm)) (c, a))
| otherwise = Nothing
in Text.Earley.terminal f |]
NonTerminal b1 bs -> [makeRule expression]
where
expression = foldl addBranch (branchToParser prefix b1) bs
where
addBranch tree branch =
[| $tree <|> $(branchToParser prefix branch) |]
Wrap (Rule innerNm _ _) -> [makeRule expression]
where
expression = [|fmap $constructor $(T.varE (localRuleName innerNm)) |]
Record sq -> [makeRule expression]
where
expression = case viewl sq of
EmptyL -> [| pure $constructor |]
Rule r1 _ _ :< restFields -> foldl addField fstField restFields
where
fstField = [| $constructor <$> $(T.varE (localRuleName r1)) |]
addField soFar (Rule r _ _)
= [| $soFar <*> $(T.varE (localRuleName r)) |]
Opt (Rule innerNm _ _) -> [makeRule expression]
where
expression = [| fmap $constructor (pure Nothing <|> $(just)) |]
where
just = [| fmap Just $(T.varE (localRuleName innerNm)) |]
Star (Rule innerNm _ _) -> [nestRule, makeRule (wrapper helper)]
where
nestRule = (helper, ([|Text.Earley.rule|] `T.appE` parseSeq))
where
parseSeq = T.uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq
where
pSeq = [|liftA2 (<|)
$(T.varE (localRuleName innerNm)) $(T.varE helper) |]
Plus (Rule innerNm _ _) -> [nestRule, makeRule topExpn]
where
nestRule = (helper, [|Text.Earley.rule $(parseSeq)|])
where
parseSeq = [| pure Seq.empty <|> $pSeq |]
where
pSeq = [| (<|) <$> $(T.varE (localRuleName innerNm))
<*> $(T.varE helper) |]
topExpn = [| $constructor <$>
( NonEmpty <$> $(T.varE (localRuleName innerNm))
<*> $(T.varE helper)) |]
where
makeRule expression = (localRuleName nm,
[|Text.Earley.rule ($expression Text.Earley.<?> $(textToExp desc))|])
desc = maybe nm id mayDescription
textToExp txt = [| $(Syntax.lift txt) |]
constructor = T.conE (quald prefix nm)
wrapper wrapRule = [|fmap $constructor $(T.varE wrapRule) |]
helper = helperName nm
localRuleName :: String -> T.Name
localRuleName suffix = T.mkName ("_rule'" ++ suffix)
helperName :: String -> T.Name
helperName suffix = T.mkName ("_helper'" ++ suffix)
branchToParser
:: Syntax.Lift t
=> String
-> Branch t
-> T.ExpQ
branchToParser prefix (Branch name rules) = case viewl rules of
EmptyL -> [| pure $constructor |]
(Rule rule1 _ _) :< xs -> foldl f z xs
where
z = [| $constructor <$> $(T.varE (localRuleName rule1)) |]
f soFar (Rule rule2 _ _) = [| $soFar <*> $(T.varE (localRuleName rule2)) |]
where
constructor = T.conE (quald prefix name)
earleyGrammarFromRule
:: Syntax.Lift t
=> Qualifier
-> Rule t
-> T.Q T.Exp
earleyGrammarFromRule prefix r@(Rule top _ _) = recursiveDo binds final
where
binds = concatMap (ruleToParser prefix) . toList . family $ r
final = [| return $(T.varE $ localRuleName top) |]
allRulesRecord
:: Qualifier
-> Seq (Rule t)
-> T.DecsQ
allRulesRecord prefix ruleSeq
= sequence [dataD (return []) (T.mkName nameStr) tys [con] []]
where
nameStr = "Productions"
tys = [T.PlainTV (T.mkName "r"), T.PlainTV (T.mkName "t"),
T.PlainTV (T.mkName "a")]
con = T.recC (T.mkName nameStr)
(fmap mkRecord . toList . families $ ruleSeq)
mkRecord (Rule ruleNm _ _) = T.varStrictType recName st
where
recName = T.mkName ("a'" ++ ruleNm)
st = T.strictType T.notStrict ty
where
ty = [t| Text.Earley.Prod $(T.varT (T.mkName "r"))
String
( $(T.varT (T.mkName "t")), $(T.varT (T.mkName "a")))
( $(T.conT (T.mkName nameWithPrefix))
$(T.varT (T.mkName "t"))
$(T.varT (T.mkName "a"))) |]
nameWithPrefix = case prefix of
[] -> ruleNm
_ -> prefix ++ '.' : ruleNm
earleyProduct
:: Syntax.Lift t
=> Qualifier
-> Qualifier
-> Seq (Rule t)
-> T.ExpQ
earleyProduct pfxRule pfxRec ruleSeq = do
let binds = concatMap (ruleToParser pfxRule)
. toList . families $ ruleSeq
final = [| return
$(T.recConE (T.mkName rulesRecName)
(fmap mkRec . toList . families $ ruleSeq)) |]
recursiveDo binds final
where
rulesRecName
| null pfxRec = "Productions"
| otherwise = pfxRec ++ ".Productions"
mkRec (Rule n _ _) = return (T.mkName recName, recVal)
where
recName
| null pfxRec = "a'" ++ n
| otherwise = pfxRec ++ ".a'" ++ n
recVal = T.VarE . localRuleName $ n