module Pinchot.SyntaxTree where
import Data.Foldable (toList)
import Data.Sequence (Seq)
import Data.Sequence.NonEmpty (NonEmptySeq)
import qualified Language.Haskell.TH as T
import Pinchot.Rules
import Pinchot.Types
syntaxTrees
:: [T.Name]
-> Seq (Rule t)
-> T.DecsQ
syntaxTrees derives
= traverse (ruleToType derives)
. toList
. families
branchConstructor :: Branch t -> T.ConQ
branchConstructor (Branch nm rules) = T.normalC name fields
where
name = T.mkName nm
mkField (Rule n _ _) = notStrict
[t| $(T.conT (T.mkName n)) $(charTypeVar) $(anyTypeVar) |]
where
notStrict = T.bangType
(T.bang T.noSourceUnpackedness T.noSourceStrictness)
fields = toList . fmap mkField $ rules
anyTypeVar = T.varT (T.mkName "a")
charTypeVar = T.varT (T.mkName "t")
ruleToType
:: [T.Name]
-> Rule t
-> T.Q T.Dec
ruleToType deriveNames (Rule nm _ ruleType) = case ruleType of
Terminal _ ->
T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives
where
newtypeCon = T.normalC name
[notStrict
[t| ( $(charTypeVar), $(anyTypeVar) ) |] ]
NonTerminal bs -> T.dataD (T.cxt []) name [charType, anyType] Nothing cons derives
where
cons = toList (fmap branchConstructor bs)
Wrap (Rule inner _ _) ->
T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives
where
newtypeCon = T.normalC name
[ notStrict
[t| $(T.conT (T.mkName inner)) $(charTypeVar) $(anyTypeVar) |] ]
Record sq -> T.dataD (T.cxt []) name [charType, anyType] Nothing [ctor] derives
where
ctor = T.recC name . zipWith mkField [(0 :: Int) ..] . toList $ sq
mkField num (Rule rn _ _) = T.varBangType (T.mkName fldNm)
(notStrict
[t| $(T.conT (T.mkName rn)) $(charTypeVar) $(anyTypeVar) |])
where
fldNm = '_' : recordFieldName num nm rn
Opt (Rule inner _ _) ->
T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives
where
newtypeCon = T.normalC name
[notStrict
[t| Maybe ( $(T.conT (T.mkName inner)) $(charTypeVar)
$(anyTypeVar)) |]]
Star (Rule inner _ _) ->
T.newtypeD (T.cxt []) name [charType, anyType] Nothing newtypeCon derives
where
newtypeCon = T.normalC name [sq]
where
sq = notStrict
[t| Seq ( $(T.conT (T.mkName inner)) $(charTypeVar)
$(anyTypeVar) ) |]
Plus (Rule inner _ _) ->
T.newtypeD (T.cxt []) name [charType, anyType] Nothing cons derives
where
cons = T.normalC name [ne]
where
ne = notStrict [t| NonEmptySeq $(ins) |]
where
ins = [t| $(T.conT (T.mkName inner))
$(charTypeVar) $(anyTypeVar) |]
where
name = T.mkName nm
anyType = T.PlainTV (T.mkName "a")
anyTypeVar = T.varT (T.mkName "a")
charType = T.PlainTV (T.mkName "t")
charTypeVar = T.varT (T.mkName "t")
derives = mapM T.conT deriveNames
notStrict = T.bangType
(T.bang T.noSourceUnpackedness T.noSourceStrictness)