module Pinchot.Terminalize where
import Control.Monad (join)
import Data.Sequence (Seq)
import Data.Sequence.NonEmpty (NonEmptySeq)
import qualified Data.Sequence.NonEmpty as NonEmpty
import qualified Data.Sequence as Seq
import Data.Foldable (foldlM, toList)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Language.Haskell.TH as T
import Pinchot.Types
import Pinchot.Rules
terminalizers
:: Qualifier
-> Seq (Rule t)
-> T.Q [T.Dec]
terminalizers qual
= fmap concat
. traverse (terminalizer qual)
. toList
. families
terminalizer
:: Qualifier
-> Rule t
-> T.Q [T.Dec]
terminalizer qual rule@(Rule nm _ _) = sequence [sig, expn]
where
declName = "t'" ++ nm
anyType = T.varT (T.mkName "a")
charType = T.varT (T.mkName "t")
sig
| atLeastOne rule = T.sigD (T.mkName declName)
. T.forallT [T.PlainTV (T.mkName "t")
, T.PlainTV (T.mkName "a")] (return [])
$ [t| $(T.conT (quald qual nm)) $(charType) $(anyType)
-> NonEmptySeq ($(charType), $(anyType)) |]
| otherwise = T.sigD (T.mkName declName)
. T.forallT [ T.PlainTV (T.mkName "t")
, T.PlainTV (T.mkName "a")] (return [])
$ [t| $(T.conT (quald qual nm)) $(charType) $(anyType)
-> Seq ($(charType), $(anyType)) |]
expn = T.valD (T.varP $ T.mkName declName)
(T.normalB (terminalizeRuleExp qual rule)) []
terminalizeRuleExp
:: Qualifier
-> Rule t
-> T.Q T.Exp
terminalizeRuleExp qual rule@(Rule nm _ _) = do
let allRules = family rule
lkp <- ruleLookupMap allRules
let mkDec r@(Rule rn _ _) =
let expn = terminalizeSingleRule qual lkp r
decName = lookupName lkp rn
in T.valD (T.varP decName) (T.normalB expn) []
T.letE (fmap mkDec . toList $ allRules) (T.varE (lookupName lkp nm))
ruleLookupMap
:: Foldable c
=> c (Rule t)
-> T.Q (Map RuleName (T.Name))
ruleLookupMap = foldlM f Map.empty
where
f mp (Rule nm _ _) = do
name <- T.newName $ "rule" ++ nm
return $ Map.insert nm name mp
lookupName
:: Map RuleName T.Name
-> RuleName
-> T.Name
lookupName lkp n = case Map.lookup n lkp of
Nothing -> error $ "lookupName: name not found: " ++ n
Just r -> r
terminalizeSingleRule
:: Qualifier
-> Map RuleName T.Name
-> Rule t
-> T.Q T.Exp
terminalizeSingleRule qual lkp rule@(Rule nm _ ty) = case ty of
Terminal _ -> do
x <- T.newName "x"
let pat = T.conP (quald qual nm) [T.varP x]
[| \ $(pat) -> NonEmpty.singleton $(T.varE x) |]
NonTerminal bs -> do
x <- T.newName "x"
let fTzn | atLeastOne rule = terminalizeProductAtLeastOne
| otherwise = terminalizeProductAllowsZero
tzr (Branch name sq)
= fmap (\(pat, expn) -> T.match pat (T.normalB expn) [])
(fTzn qual lkp name sq)
ms <- traverse tzr . toList $ bs
T.lamE [T.varP x] (T.caseE (T.varE x) ms)
Wrap (Rule inner _ _) -> do
x <- T.newName "x"
let pat = T.conP (quald qual nm) [T.varP x]
[| \ $(pat) -> $(T.varE (lookupName lkp inner)) $(T.varE x) |]
Record rs -> do
(pat, expn) <- fTzr qual lkp nm rs
[| \ $(pat) -> $(expn) |]
where
fTzr | atLeastOne rule = terminalizeProductAtLeastOne
| otherwise = terminalizeProductAllowsZero
Opt r@(Rule inner _ _) -> do
x <- T.newName "x"
let pat = T.conP (quald qual nm) [T.varP x]
[| \ $(pat) -> maybe Seq.empty
$(convert (T.varE (lookupName lkp inner))) $(T.varE x) |]
where
convert expn | atLeastOne r = [| NonEmpty.nonEmptySeqToSeq . $(expn) |]
| otherwise = expn
Star r@(Rule inner _ _) -> do
x <- T.newName "x"
let pat = T.conP (quald qual nm) [T.varP x]
convert e | atLeastOne r = [| NonEmpty.nonEmptySeqToSeq . $(e) |]
| otherwise = e
[| \ $(pat) -> join . fmap $(convert (T.varE (lookupName lkp inner)))
$ $(T.varE x) |]
Plus r@(Rule inner _ _)
| atLeastOne r -> do
x <- T.newName "x"
let pat = T.conP (quald qual nm) [T.varP x]
[| \ $(pat) ->
let getTermNonEmpty = $(T.varE (lookupName lkp inner))
getTerms (NonEmpty.NonEmptySeq e1 es)
= join . fmap getTermNonEmpty
$ NonEmpty.NonEmptySeq e1 es
in getTerms $(T.varE x)
|]
| otherwise -> do
x <- T.newName "x"
[| let getTermSeq = $(T.varE (lookupName lkp inner))
getTerms (NonEmpty.NonEmptySeq e1 es) = getTermSeq e1
`mappend` (join (fmap getTermSeq es))
in getTerms $(T.varE x)
|]
terminalizeProductAllowsZero
:: Qualifier
-> Map RuleName T.Name
-> String
-> Seq (Rule t)
-> T.Q (T.PatQ, T.ExpQ)
terminalizeProductAllowsZero qual lkp name bs = do
pairs <- fmap toList . traverse (terminalizeProductRule lkp) $ bs
let pat = T.conP (quald qual name) (fmap (fst . snd) pairs)
body = case pairs of
[] -> [| Seq.empty |]
x:xs -> foldl f start xs
where
f acc trip = [| $(acc) `mappend` $(procTrip trip) |]
start = procTrip x
procTrip (rule, (_, expn))
| atLeastOne rule = [| NonEmpty.nonEmptySeqToSeq $(expn) |]
| otherwise = expn
return (pat, body)
terminalizeProductAtLeastOne
:: Qualifier
-> Map RuleName T.Name
-> String
-> Seq (Rule t)
-> T.Q (T.PatQ, T.ExpQ)
terminalizeProductAtLeastOne qual lkp name bs = do
pairs <- fmap toList . traverse (terminalizeProductRule lkp) $ bs
let pat = T.conP (quald qual name) (fmap (fst . snd) pairs)
body = [| ( $(leadSeq) `NonEmpty.prependSeq` $(firstNonEmpty))
`NonEmpty.appendSeq` $(trailSeq) |]
where
(leadRules, lastRules) = span (not . atLeastOne . fst) pairs
(firstNonEmptyRule, trailRules) = case lastRules of
[] -> error $ "terminalizeProductAtLeastOne: failure 1: " ++ name
x:xs -> (x, xs)
leadSeq = case fmap (snd . snd) leadRules of
[] -> [| Seq.empty |]
x:xs -> foldl f x xs
where
f acc expn = [| $(acc) `mappend` $(expn) |]
firstNonEmpty = [| $(snd . snd $ firstNonEmptyRule) |]
trailSeq = foldl f [| Seq.empty |] trailRules
where
f acc (rule, (_, expn))
| atLeastOne rule =
[| $(acc) `mappend` NonEmpty.nonEmptySeqToSeq $(expn) |]
| otherwise =
[| $(acc) `mappend` $(expn) |]
return (pat, body)
terminalizeProductRule
:: Map RuleName T.Name
-> Rule t
-> T.Q (Rule t, (T.Q T.Pat, T.Q T.Exp))
terminalizeProductRule lkp r@(Rule nm _ _) = do
x <- T.newName $ "terminalizeProductRule'" ++ nm
let getTerms = [| $(T.varE (lookupName lkp nm)) $(T.varE x) |]
return (r, (T.varP x, getTerms))
atLeastOne
:: Rule t
-> Bool
atLeastOne (Rule _ _ ty) = case ty of
Terminal _ -> True
NonTerminal bs -> all branchAtLeastOne bs
where
branchAtLeastOne (Branch _ rs) = any atLeastOne rs
Wrap r -> atLeastOne r
Record rs -> any atLeastOne rs
Opt _ -> False
Star _ -> False
Plus r -> atLeastOne r