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, Stmt(NoBindS), uInfixE, bindS,
varE, varP, conE, Pat, Exp(AppE, DoE), lamE, recC, varStrictType)
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))
| RSeqTerm (Seq t)
| ROptional (Rule t)
| RMany (Rule t)
| RMany1 (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
:: String
-> 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
RSeqTerm _ -> Seq.singleton n
ROptional _ -> Seq.singleton n
RMany _ -> Seq.singleton n
RMany1 _ -> Seq.singleton n
RWrap _ -> Seq.singleton n
RRecord _ -> Seq.singleton n
addDataConNames :: Rule t -> Pinchot t ()
addDataConNames = mapM_ addDataConName . ruleConstructorNames
union
:: RuleName
-> Seq (AlternativeName, Rule t)
-> Pinchot t (Rule t)
union name = nonTerminal name . fmap (\(n, r) -> (n, Seq.singleton r))
record
:: RuleName
-> Seq (Rule t)
-> Pinchot t (Rule t)
record name sq = newRule name (RRecord sq)
list
:: RuleName
-> Rule t
-> Pinchot t (Rule t)
list name r = newRule name (RMany r)
list1
:: RuleName
-> Rule t
-> Pinchot t (Rule t)
list1 name r = newRule name (RMany1 r)
option
:: RuleName
-> Rule t
-> Pinchot t (Rule t)
option name r = newRule name (ROptional r)
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
RSeqTerm _ -> return (Seq.singleton r)
ROptional c -> do
cs <- getAncestors c
return $ r <| cs
RMany c -> do
cs <- getAncestors c
return $ r <| cs
RMany1 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
RSeqTerm _ -> results
ROptional r -> checkRule r results
RMany r -> addHelper $ checkRule r results
RMany1 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
thRule
:: Bool
-> Name
-> Seq Name
-> Rule t
-> TH.Q [TH.Dec]
thRule doLenses typeName derives (Rule nm _ ruleType) = do
ty <- makeType typeName derives nm ruleType
return (ty : lenses)
where
lenses
| doLenses = ruleToOptics typeName nm ruleType
| otherwise = []
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)
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)))]
RMany (Rule inner _ _) -> newtypeD (cxt []) name [] newtypeCon derives
where
newtypeCon = normalC name
[strictType notStrict (appT [t| Seq |]
(conT (mkName inner)))]
RMany1 (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 = "f'" ++ par ++ "'" ++ show idx ++ "'" ++ inn
thAllRules
:: 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
terminalToOptics
:: Name
-> String
-> TH.Dec
terminalToOptics terminalName = makeWrapped term
where
term = TH.ConT terminalName
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 : toList (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")
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
:: Name
-> String
-> RuleType t
-> [TH.Dec]
ruleToOptics terminalName nm ty = case ty of
RTerminal _ -> [terminalToOptics terminalName nm]
RBranch (b1, bs) -> branchesToOptics nm b1 bs
RSeqTerm _ -> [terminalSeqToOptics terminalName nm]
ROptional (Rule inner _ _) -> [optionalToOptics inner nm]
RMany (Rule inner _ _) -> [manyToOptics inner nm]
RMany1 (Rule inner _ _) -> [many1ToOptics inner nm]
RWrap (Rule inner _ _) -> [wrapToOptics inner nm]
RRecord recs -> recordsToOptics nm recs
type MakeOptics = Bool
makeOptics :: MakeOptics
makeOptics = True
noOptics :: MakeOptics
noOptics = False
allRulesToTypes
:: 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
:: 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)
ruleToParser
:: Syntax.Lift t
=> String
-> Rule t
-> Q [Stmt]
ruleToParser prefix (Rule nm mayDescription rt) = case rt of
RTerminal ivls -> do
topRule <- makeRule expression
return [topRule]
where
expression = [| fmap $constructor (satisfy (inIntervals ivls)) |]
RBranch (b1, bs) -> do
topRule <- makeRule expression
return [topRule]
where
expression = foldl addBranch (branchToParser prefix b1) bs
where
addBranch tree branch =
[| $tree <|> $(branchToParser prefix branch) |]
RSeqTerm sq -> do
let nestRule = bindS (varP helper) [| rule $(foldl addTerm start sq) |]
where
start = [|pure Seq.empty|]
addTerm acc x = [| liftA2 (<|) (symbol x) $acc |]
nest <- nestRule
topRule <- makeRule (wrapper helper)
return [nest, topRule]
ROptional (Rule innerNm _ _) -> fmap (:[]) (makeRule expression)
where
expression = [| fmap $constructor (pure Nothing <|> $(just)) |]
where
just = [| fmap Just $(varE (ruleName innerNm)) |]
RMany (Rule innerNm _ _) -> do
let nestRule = bindS (varP helper) ([|rule|] `appE` parseSeq)
where
parseSeq = uInfixE [|pure Seq.empty|] [|(<|>)|] pSeq
where
pSeq = [|liftA2 (<|) $(varE (ruleName innerNm)) $(varE helper) |]
nest <- nestRule
top <- makeRule $ wrapper helper
return [nest, top]
RMany1 (Rule innerNm _ _) -> do
let nestRule = bindS (varP helper) [|rule $(parseSeq)|]
where
parseSeq = [| pure Seq.empty <|> $pSeq |]
where
pSeq = [| (<|) <$> $(varE (ruleName innerNm))
<*> $(varE helper) |]
nest <- nestRule
let topExpn = [| $constructor <$> ( (,) <$> $(varE (ruleName innerNm))
<*> $(varE helper)
) |]
top <- makeRule topExpn
return [nest, top]
RWrap (Rule innerNm _ _) -> fmap (:[]) (makeRule expression)
where
expression = [|fmap $constructor $(varE (ruleName innerNm)) |]
RRecord sq -> fmap (:[]) (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 ("_r'" ++ suffix)
helperName :: String -> Name
helperName suffix = mkName ("_h'" ++ 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@(Rule top _ _) -> do
let neededRules = ruleAndAncestors r
otherNames = rulesDemandedBeforeDefined neededRules
lamb = lamE [lazyPattern otherNames] expression
expression = do
stmts <- fmap concat . mapM (ruleToParser prefix)
. toList $ neededRules
result <- bigTuple (ruleName top) otherNames
rtn <- [|return|]
let returner = rtn `AppE` result
return $ DoE (stmts ++ [NoBindS returner])
[| fmap fst (mfix $lamb) |]
where
(ei, _) = runState (runExceptT (runPinchot pinc))
(Names Set.empty Set.empty 0 M.empty)