module Text.Papillon (
papillon,
papillonStr,
papillonStr',
classSourceQ,
Source(..),
SourceList(..)
) where
import Language.Haskell.TH.Quote
import Language.Haskell.TH
import "monads-tf" Control.Monad.State
import "monads-tf" Control.Monad.Error
import Control.Monad.Trans.Error (Error(..))
import Data.Maybe
import Control.Applicative
import Text.Papillon.Parser
import Data.IORef
import Text.Papillon.Class
classSourceQ True
usingNames :: Peg -> [String]
usingNames = concatMap getNamesFromDefinition
getNamesFromDefinition :: Definition -> [String]
getNamesFromDefinition (_, _, sel) =
concatMap getNamesFromExpressionHs sel
getNamesFromExpressionHs :: ExpressionHs -> [String]
getNamesFromExpressionHs = mapMaybe getLeafName . fst
getLeafName :: NameLeaf_ -> Maybe String
getLeafName (Here (_, Left n)) = Just n
getLeafName (NotAfter (_, Left n)) = Just n
getLeafName _ = Nothing
flipMaybe :: (Error (ErrorType me), MonadError me) =>
StateT s me a -> StateT s me ()
flipMaybe action = do
err <- (action >> return False) `catchError` const (return True)
unless err $ throwError $ strMsg "not error"
papillon :: QuasiQuoter
papillon = QuasiQuoter {
quoteExp = undefined,
quotePat = undefined,
quoteType = undefined,
quoteDec = declaration True
}
papillonStr :: String -> IO String
papillonStr src = show . ppr <$> runQ (declaration False src)
papillonStr' :: String -> IO String
papillonStr' src = do
let (pp, decsQ, atp) = declaration' src
decs <- runQ decsQ
cls <- runQ $ classSourceQ False
return $ pp ++ "\n" ++ flipMaybeS ++ show (ppr decs) ++ "\n" ++ atp ++
"\n" ++ show (ppr cls)
flipMaybeS :: String
flipMaybeS =
"flipMaybe :: (Error (ErrorType me), MonadError me) =>\n" ++
"\tStateT s me a -> StateT s me ()\n" ++
"flipMaybe action = do\n" ++
"\terr <- (action >> return False) `catchError` const (return True)\n" ++
"\tunless err $ throwError $ strMsg \"not error\"\n"
flipMaybeN :: Bool -> Name
flipMaybeN True = 'flipMaybe
flipMaybeN False = mkName "flipMaybe"
returnN, stateTN, stringN, putN, stateTN', getN,
eitherN, strMsgN, throwErrorN, runStateTN, justN, mplusN,
getTokenN :: Bool -> Name
returnN True = 'return
returnN False = mkName "return"
throwErrorN True = 'throwError
throwErrorN False = mkName "throwError"
strMsgN True = 'strMsg
strMsgN False = mkName "strMsg"
stateTN True = ''StateT
stateTN False = mkName "StateT"
stringN True = ''String
stringN False = mkName "String"
putN True = 'put
putN False = mkName "put"
stateTN' True = 'StateT
stateTN' False = mkName "StateT"
mplusN True = 'mplus
mplusN False = mkName "mplus"
getN True = 'get
getN False = mkName "get"
eitherN True = ''Either
eitherN False = mkName "Either"
runStateTN True = 'runStateT
runStateTN False = mkName "runStateT"
justN True = 'Just
justN False = mkName "Just"
getTokenN True = 'getToken
getTokenN False = mkName "getToken"
declaration :: Bool -> String -> DecsQ
declaration th str = do
let (src, tkn, parsed) = case dv_peg $ parse str of
Right ((s, t, p), _) -> (s, t, p)
_ -> error "bad"
decParsed th src tkn parsed
declaration' :: String -> (String, DecsQ, String)
declaration' src = case dv_pegFile $ parse src of
Right ((pp, (s, t, p), atp), _) ->
(pp, decParsed False s t p, atp)
_ -> error "bad"
decParsed :: Bool -> TypeQ -> TypeQ -> Peg -> DecsQ
decParsed th src tkn parsed = do
glb <- runIO $ newIORef 0
r <- result th
pm <- pmonad th
d <- derivs th tkn parsed
pt <- parseT src th
p <- funD (mkName "parse") [parseE th parsed]
tdvm <- typeDvM parsed
dvsm <- dvSomeM th parsed
tdvcm <- typeDvCharsM th tkn
dvcm <- dvCharsM th
pts <- typeP parsed
ps <- pSomes glb th parsed
return $ [pm, r, d, pt, p] ++ tdvm ++ dvsm ++ [tdvcm, dvcm] ++ pts ++ ps
where
derivs :: Bool -> TypeQ -> Peg -> DecQ
derivs _ tkn peg = dataD (cxt []) (mkName "Derivs") [] [
recC (mkName "Derivs") $ map derivs1 peg ++ [
varStrictType (mkName "dvChars") $ strictType notStrict $
conT (mkName "Result") `appT` tkn
]
] []
derivs1 :: Definition -> VarStrictTypeQ
derivs1 (name, typ, _) =
varStrictType (mkName $ "dv_" ++ name) $ strictType notStrict $
conT (mkName "Result") `appT` conT typ
result :: Bool -> DecQ
result th = tySynD (mkName "Result") [PlainTV $ mkName "v"] $
conT (eitherN th) `appT` conT (stringN th) `appT`
(tupleT 2 `appT` varT (mkName "v") `appT` conT (mkName "Derivs"))
pmonad :: Bool -> DecQ
pmonad th = tySynD (mkName "PackratM") [] $ conT (stateTN th) `appT`
conT (mkName "Derivs") `appT`
(conT (eitherN th) `appT` conT (stringN th))
parseT :: TypeQ -> Bool -> DecQ
parseT src _ = sigD (mkName "parse") $
arrowT `appT` src `appT` conT (mkName "Derivs")
parseE :: Bool -> Peg -> ClauseQ
parseE th = parseE' th . map (\(n, _, _) -> n)
parseE' :: Bool -> [String] -> ClauseQ
parseE' th names = clause [varP $ mkName "s"] (normalB $ varE $ mkName "d") $ [
flip (valD $ varP $ mkName "d") [] $ normalB $ appsE $
conE (mkName "Derivs") :
map (varE . mkName) names
++ [varE (mkName "char")]] ++
map (parseE1 th) names ++ [
flip (valD $ varP $ mkName "char") [] $ normalB $
varE (mkName "flip") `appE` varE (runStateTN th) `appE`
varE (mkName "d") `appE` caseE (varE (getTokenN th) `appE`
varE (mkName "s")) [
match (justN th `conP` [
tupP [(varP (mkName "c")),
(varP (mkName "s'"))]])
(normalB $ doE [
noBindS $ varE (putN th)
`appE`
(varE (mkName "parse") `appE` varE (mkName "s'")),
noBindS $ varE (returnN th) `appE`
varE (mkName "c")
])
[],
match wildP
(normalB $ varE (throwErrorN th) `appE`
(varE (strMsgN th) `appE`
litE (stringL "eof")))
[]
]
]
parseE1 :: Bool -> String -> DecQ
parseE1 th name = flip (valD $ varP $ mkName name) [] $ normalB $
varE (runStateTN th) `appE` varE (mkName $ "p_" ++ name)
`appE` varE (mkName "d")
typeDvM :: Peg -> DecsQ
typeDvM peg = let
used = usingNames peg in
uncurry (zipWithM typeDvM1) $ unzip $ filter ((`elem` used) . fst)
$ map (\(n, t, _) -> (n, t)) peg
typeDvM1 :: String -> Name -> DecQ
typeDvM1 f t = sigD (mkName $ "dv_" ++ f ++ "M") $ conT (mkName "PackratM") `appT` conT t
dvSomeM :: Bool -> Peg -> DecsQ
dvSomeM th peg = mapM (dvSomeM1 th) $
filter ((`elem` usingNames peg) . (\(n, _, _) -> n)) peg
dvSomeM1 :: Bool -> Definition -> DecQ
dvSomeM1 th (name, _, _) = flip (valD $ varP $ mkName $ "dv_" ++ name ++ "M") [] $ normalB $
conE (stateTN' th) `appE` varE (mkName $ "dv_" ++ name)
typeDvCharsM :: Bool -> TypeQ -> DecQ
typeDvCharsM _ tkn =
sigD (mkName "dvCharsM") $ conT (mkName "PackratM") `appT` tkn
dvCharsM :: Bool -> DecQ
dvCharsM th = flip (valD $ varP $ mkName "dvCharsM") [] $ normalB $
conE (stateTN' th) `appE` varE (mkName "dvChars")
typeP :: Peg -> DecsQ
typeP = uncurry (zipWithM typeP1) . unzip . map (\(n, t, _) -> (n, t))
typeP1 :: String -> Name -> DecQ
typeP1 f t = sigD (mkName $ "p_" ++ f) $ conT (mkName "PackratM") `appT` conT t
pSomes :: IORef Int -> Bool -> Peg -> DecsQ
pSomes g th = mapM $ pSomes1 g th
pSomes1 :: IORef Int -> Bool -> Definition -> DecQ
pSomes1 g th (name, _, sel) = flip (valD $ varP $ mkName $ "p_" ++ name) [] $ normalB $
varE (mkName "foldl1") `appE` varE (mplusN th) `appE` listE (map (uncurry $ pSome_ g th) sel)
pSome_ :: IORef Int -> Bool -> [NameLeaf_] -> ExpQ -> ExpQ
pSome_ g th nls ret = fmap DoE $ do
x <- mapM (transLeaf g th) nls
r <- noBindS $ varE (returnN th) `appE` ret
return $ concat x ++ [r]
transLeaf :: IORef Int -> Bool -> NameLeaf_ -> Q [Stmt]
transLeaf g th (Here (n, Right p)) = do
gn <- runIO $ readIORef g
runIO $ modifyIORef g succ
t <- newName $ "xx" ++ show gn
nn <- n
case nn of
VarP _ -> sequence [
bindS (varP t) $ varE $ mkName "dvCharsM",
noBindS $ condE (p `appE` varE t)
(varE (returnN th) `appE` conE (mkName "()"))
(varE (throwErrorN th) `appE`
(varE (strMsgN th) `appE`
litE (stringL "not match"))),
noBindS $ caseE (varE t) [
flip (match $ varPToWild n) [] $ normalB $
varE (returnN th) `appE` tupE []
],
letS [flip (valD n) [] $ normalB $ varE t],
noBindS $ varE (returnN th) `appE` tupE []
]
WildP -> sequence [
bindS (varP t) $ varE $ mkName "dvCharsM",
noBindS $ condE (p `appE` varE t)
(varE (returnN th) `appE` conE (mkName "()"))
(varE (throwErrorN th) `appE`
(varE (strMsgN th) `appE`
litE (stringL "not match"))),
noBindS $ caseE (varE t) [
flip (match $ varPToWild n) [] $ normalB $
varE (returnN th) `appE` tupE []
],
letS [flip (valD n) [] $ normalB $ varE t],
noBindS $ varE (returnN th) `appE` tupE []
]
_ -> sequence [
bindS (varP t) $ varE $ mkName "dvCharsM",
noBindS $ condE (p `appE` varE t)
(varE (returnN th) `appE` conE (mkName "()"))
(varE (throwErrorN th) `appE`
(varE (strMsgN th) `appE`
litE (stringL "not match"))),
noBindS $ caseE (varE t) [
flip (match $ varPToWild n) [] $ normalB $
varE (returnN th) `appE` tupE [],
flip (match wildP) [] $ normalB $ varE (throwErrorN th) `appE`
(varE (strMsgN th) `appE` litE (stringL "not match"))
],
letS [flip (valD n) [] $ normalB $ varE t],
noBindS $ varE (returnN th) `appE` tupE []
]
transLeaf g th (Here (n, Left v)) = do
nn <- n
case nn of
VarP _ -> sequence [
bindS n $ varE $ mkName $ "dv_" ++ v ++ "M",
noBindS $ varE (returnN th) `appE` conE (mkName "()")]
WildP -> sequence [
bindS wildP $ varE $ mkName $ "dv_" ++ v ++ "M",
noBindS $ varE (returnN th) `appE` conE (mkName "()")]
_ -> do gn <- runIO $ readIORef g
runIO $ modifyIORef g succ
t <- newName $ "xx" ++ show gn
sequence [
bindS (varP t) $ varE $ mkName $ "dv_" ++ v ++ "M",
noBindS $ caseE (varE t) [
flip (match $ varPToWild n) [] $ normalB $
varE (returnN th) `appE`
tupE [],
flip (match wildP) [] $ normalB $
varE (throwErrorN th) `appE`
(varE (strMsgN th) `appE`
litE (stringL "not match"))
],
bindS n $ varE (returnN th) `appE` varE t
]
transLeaf g th (NotAfter (n, Right p)) = do
d <- newName "d"
sequence [
bindS (varP d) $ varE (getN th),
noBindS $ varE (flipMaybeN th) `appE`
(DoE <$> transLeaf g th (Here (n, Right p))),
noBindS $ varE (putN th) `appE` varE d]
transLeaf g th (NotAfter (n, Left v)) = do
d <- newName "d"
sequence [
bindS (varP d) $ varE (getN th),
noBindS $ varE (flipMaybeN th) `appE`
(DoE <$> transLeaf g th (Here (n, Left v))),
noBindS $ varE (putN th) `appE` varE d]
varPToWild :: PatQ -> PatQ
varPToWild p = do
pp <- p
return $ vpw pp
where
vpw (VarP _) = WildP
vpw (ConP n ps) = ConP n $ map vpw ps
vpw o = o