diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/bin/Class.hs b/bin/Class.hs new file mode 100644 --- /dev/null +++ b/bin/Class.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE TypeFamilies, TemplateHaskell, PackageImports #-} + +module Class ( + classSourceQ, + pePositionST, + pePositionSD, + instanceErrorParseError, + parseErrorT +) where + +import Language.Haskell.TH +import "monads-tf" Control.Monad.Error +import Control.Monad.Trans.Error (Error(..)) + +errorN, strMsgN :: Bool -> Name +errorN True = ''Error +errorN False = mkName "Error" +strMsgN True = 'strMsg +strMsgN False = mkName "strMsg" + +parseErrorT :: Bool -> DecQ +parseErrorT _ = flip (dataD (cxt []) (mkName "ParseError") + [PlainTV $ mkName "pos", PlainTV $ mkName "drv"]) + [] $ (:[]) $ + recC (mkName "ParseError") [ + varStrictType c $ strictType notStrict $ conT $ mkName "String", + varStrictType m $ strictType notStrict $ conT $ mkName "String", + varStrictType com $ strictType notStrict $ conT $ mkName "String", + varStrictType d $ strictType notStrict $ varT $ mkName "drv", + varStrictType r $ strictType notStrict $ listT `appT` conT (mkName "String"), + varStrictType pos $ strictType notStrict $ varT $ mkName "pos" + ] + where + [c, m, com, r, d, pos] = map mkName [ + "peCode", + "peMessage", + "peComment", + "peReading", + "peDerivs", + "pePosition" + ] + +{- + +pePositionS :: ParseError (Pos String) -> (Int, Int) +pePositionS ParseError{ pePosition = ListPos (CharPos p) } = p + +-} + +{- + +instance Error (ParseError pos) where + strMsg msg = ParseError "" msg "" undefined + +-} + +instanceErrorParseError :: Bool -> DecQ +instanceErrorParseError th = instanceD + (cxt []) + (conT (errorN th) `appT` + (conT (mkName "ParseError") + `appT` varT (mkName "pos") + `appT` varT (mkName "drv"))) + [funD (strMsgN th) $ (: []) $ flip (clause [varP msg]) [] $ normalB ret] + where + msg = mkName "msg" + ret = conE (mkName "ParseError") + `appE` litE (stringL "") + `appE` varE msg + `appE` litE (stringL "") + `appE` varE (mkName "undefined") + `appE` varE (mkName "undefined") + `appE` varE (mkName "undefined") + +infixr 8 `arrT` + +arrT :: TypeQ -> TypeQ -> TypeQ +arrT x y = arrowT `appT` x `appT` y + +tupT :: [TypeQ] -> TypeQ +tupT ts = foldl appT (tupleT $ length ts) ts + +pePositionST :: DecQ +pePositionST = sigD (mkName "pePositionS") $ + forallT [PlainTV $ mkName "drv"] (cxt []) $ + conT (mkName "ParseError") + `appT` (conT (mkName "Pos") `appT` conT (mkName "String")) + `appT` varT (mkName "drv") + `arrT` + tupT [conT $ mkName "Int", conT $ mkName "Int"] +pePositionSD :: DecQ +pePositionSD = funD (mkName "pePositionS") $ (: []) $ clause + [pat] (normalB $ varE $ mkName "p") [] + where + pat = recP (mkName "ParseError") [fieldPat (mkName "pePosition") $ + conP (mkName "ListPos") + [conP (mkName "CharPos") [varP $ mkName "p"]]] + +classSourceQ :: Bool -> DecsQ +classSourceQ th = sequence [classS th, classSL th, instanceSrcStr th, + instanceSLC th] + +maybeN, nothingN, justN, consN, charN :: Bool -> Name +maybeN True = ''Maybe +maybeN False = mkName "Maybe" +nothingN True = 'Nothing +nothingN False = mkName "Nothing" +justN True = 'Just +justN False = mkName "Just" +consN True = '(:) +consN False = mkName ":" +charN True = ''Char +charN False = mkName "Char" + +source, sourceList, listTokenN, tokenN, getTokenN, posN, updatePosN, + listPosN, listUpdatePosN, initialPosN, listInitialPosN + :: Name +sourceList = mkName "SourceList" +listTokenN = mkName "listToken" +source = mkName "Source" +tokenN = mkName "Token" +getTokenN = mkName "getToken" +posN = mkName "Pos" +updatePosN = mkName "updatePos" +listPosN = mkName "ListPos" +listUpdatePosN = mkName "listUpdatePos" +initialPosN = mkName "initialPos" +listInitialPosN = mkName "listInitialPos" + +classS, classSL, instanceSLC, instanceSrcStr :: Bool -> DecQ + +{- +class Source sl where + type Token sl + data Pos sl + getToken :: sl -> Maybe (Token sl, sl) + initialPos :: Pos sl + updatePos :: Token sl -> Pos sl -> Pos sl +-} + +classS th = classD (cxt []) source [PlainTV sl] [] [ + familyNoKindD typeFam tokenN [PlainTV sl], + familyNoKindD dataFam posN [PlainTV sl], + sigD getTokenN $ arrowT `appT` varT sl `appT` + (conT (maybeN th) `appT` tupleBody), + sigD initialPosN $ conT posN `appT` varT sl, + sigD updatePosN $ arrowT + `appT` (conT tokenN `appT` varT sl) + `appT` (arrowT + `appT` (conT posN `appT` varT sl) + `appT` (conT posN `appT` varT sl)) + ] where + sl = mkName "sl" + tupleBody = tupleT 2 + `appT` (conT tokenN `appT` varT sl) + `appT` varT sl + +{- +class SourceList c where + data ListPos c + listToken :: [c] -> Maybe (c, [c]) + listInitialPos :: ListPos c + listUpdatePos :: c -> ListPos c -> ListPos c +-} + +classSL th = classD (cxt []) sourceList [PlainTV c] [] [ + familyNoKindD dataFam listPosN [PlainTV c], + sigD listTokenN $ arrowT `appT` (listT `appT` varT c) `appT` + (conT (maybeN th) `appT` tupleBody), + sigD listInitialPosN $ conT listPosN `appT` varT c, + sigD listUpdatePosN $ arrowT + `appT` varT c + `appT` (arrowT + `appT` (conT listPosN `appT` varT c) + `appT` (conT listPosN `appT` varT c)) + ] where + c = mkName "c" + tupleBody = tupleT 2 `appT` varT c `appT` (listT `appT` varT c) + +{- +instance (SourceList c) => Source [c] where + type Token [c] = c + newtype Pos [c] = ListPos (ListPos c) + getToken = listToken + initialPos = ListPos listInitialPos + updatePos c (ListPos p) = ListPos (listUpdatePos c p) +-} + +instanceSrcStr _ = + instanceD (cxt [classP sourceList [varT c]]) (conT source `appT` listC) [ + tySynInstD tokenN [listC] $ varT c, + flip (newtypeInstD (cxt []) posN [listC]) [] $ + normalC listPosN [strictType notStrict $ + conT listPosN `appT` varT c], + valD (varP getTokenN) (normalB $ varE listTokenN) [], + flip (valD $ varP initialPosN) [] $ normalB $ + conE listPosN `appE` varE listInitialPosN, + funD updatePosN $ (: []) $ flip (clause [pc, lp]) [] $ normalB $ + conE listPosN `appE` + (varE listUpdatePosN `appE` varE c `appE` varE p) + ] + where + c = mkName "c" + p = mkName "p" + pc = varP c + lp = conP listPosN [varP p] + listC = listT `appT` varT c + +{- + +instance Show (ListPos a) => Show (Pos [a]) where + show (ListPos x) = "ListPos " ++ show x + + +instanceShowListPosPos :: DecQ +instanceShowListPosPos = instanceD (cxt [cxtShowListPos]) decType [body] + where + cxtShowListPos = classP (mkName "Show") + [conT (mkName "ListPos") `appT` varT (mkName "a")] + decType = conT (mkName "Show") `appT` + (conT (mkName "Pos") `appT` (listT `appT` varT (mkName "a"))) + body = funD (mkName "show") $ (: []) $ flip (clause [patListPos]) [] $ + normalB $ addParens $ infixApp + (litE $ stringL "ListPos (") + (varE $ mkName "++") $ infixApp + (varE (mkName "show") `appE` varE (mkName "x")) + (varE $ mkName "++") + (litE $ stringL ")") + patListPos = conP (mkName "ListPos") [varP $ mkName "x"] + addParens str = infixApp + (litE $ stringL "(") + (varE $ mkName "++") $ infixApp + str + (varE $ mkName "++") + (litE $ stringL ")") + +-} + +{- +instance SourceList Char where + newtype ListPos Char = CharPos (Int, Int) + listToken (c : s) = Just (c, s) + listToken _ = Nothing + listInitialPos = CharPos (1, 1) + listUpdatePos '\n' (CharPos (y, x)) = CharPos (y + 1, 0) + listUpdatePos '\t' (CharPOs (y, x)) = CharPos (y, x + 8) + listUpdatePos _ (CharPos (y, x)) = CharPos (y, x + 1) +-} + +instanceSLC th = instanceD (cxt []) (conT sourceList `appT` conT (charN th)) [ + newtypeInstD (cxt []) listPosN [conT $ charN th] ( + normalC (mkName "CharPos") [ + strictType notStrict $ tupleT 2 + `appT` conT (mkName "Int") + `appT` conT (mkName "Int")] + ) [mkName "Show"], + funD listTokenN [ + clause [infixP (varP c) (consN th) (varP s)] + (normalB $ conE (justN th) `appE` tupleBody) [], + clause [wildP] (normalB $ conE $ nothingN th) [] + ], + flip (valD $ varP listInitialPosN) [] $ normalB $ + conE (mkName "CharPos") `appE` tupE [one, one], + funD listUpdatePosN [ + flip (clause [litP $ charL '\n', pCharPos [tupP [varP y, wildP]]]) [] $ + normalB $ eCharPos `appE` tupE [ + infixApp (varE y) plus one, zero], + flip (clause [wildP, pCharPos [tupP [varP y, varP x]]]) [] $ + normalB $ eCharPos `appE` tupE [ + varE y, infixApp (varE x) plus one] + ] + ] where + c = mkName "c" + s = mkName "s" + y = mkName "y" + x = mkName "x" + tupleBody = tupE [varE c, varE s] + one = litE $ integerL 1 + zero = litE $ integerL 0 + plus = varE $ mkName "+" + charPosN = mkName "CharPos" + eCharPos = conE charPosN + pCharPos = conP charPosN diff --git a/bin/papillon.hs b/bin/papillon.hs new file mode 100644 --- /dev/null +++ b/bin/papillon.hs @@ -0,0 +1,89 @@ +import Text.PapillonCore +import System.Environment +import System.Directory +import System.FilePath +import Data.List +import Language.Haskell.TH + +import Class + +papillonStr :: String -> IO (String, String, String) +papillonStr src = do + let (prgm, mn, ppp, pp, decsQ, atp, app) = papillonFile src + mName = intercalate "." $ myInit mn ++ ["Papillon"] + importConst = "\nimport " ++ mName ++ "\n" + dir = joinPath $ myInit mn + decs <- runQ decsQ + return (dir, mName, + unlines (map showPragma $ addPragmas $ delPragmas prgm) ++ + (if null mn then "" else "module " ++ intercalate "." mn) ++ + ppp ++ importConst ++ + (if app then "\nimport Control.Applicative\n" else "") ++ + pp ++ "\n" ++ show (ppr decs) ++ "\n" ++ atp ++ "\n") + +showPragma :: PPragma -> String +showPragma (LanguagePragma []) = "" +showPragma (LanguagePragma p) = "{-# LANGUAGE " ++ intercalate ", " p ++ " #-}" +showPragma (OtherPragma p) = "{-# " ++ p ++ " #-}" + +addPragmas :: [PPragma] -> [PPragma] +addPragmas [] = [LanguagePragma additionalPragmas] +addPragmas (LanguagePragma p : ps) = LanguagePragma (p ++ additionalPragmas) : ps +addPragmas (op : ps) = op : addPragmas ps + +delPragmas :: [PPragma] -> [PPragma] +delPragmas [] = [] +delPragmas (LanguagePragma p : ps) = + LanguagePragma (filter (`notElem` ["QuasiQuotes", "TypeFamilies"]) p) : ps +delPragmas (op : ps) = op : delPragmas ps + +additionalPragmas :: [String] +additionalPragmas = [ + "PackageImports", + "TypeFamilies", + "RankNTypes" + ] + +papillonConstant :: String -> IO String +papillonConstant mName = do + src <- runQ $ do + pe <- parseErrorT False + iepe <- instanceErrorParseError False + pepst <- pePositionST + pepsd <- pePositionSD + cls <- classSourceQ False + return $ [pe, iepe, pepst, pepsd] ++ cls + return $ + "{-# LANGUAGE RankNTypes, TypeFamilies #-}\n" ++ + "module " ++ mName ++ " (\n\t" ++ + intercalate ",\n\t" exportList ++ ") where\n" ++ + "import Control.Monad.Trans.Error (Error(..))\n" ++ + show (ppr src) ++ "\n" + +main :: IO () +main = do + args <- getArgs + case args of + [fn, dist] -> do + (d, mName, src) <- papillonStr =<< readFile fn + let dir = dist d + createDirectoryIfMissing True dir + writeFile (dir takeBaseName fn <.> "hs") src + writeFile (dir "Papillon" <.> "hs") + =<< papillonConstant mName + _ -> error "bad arguments" + +exportList :: [String] +exportList = [ + "ParseError(..)", + "Pos(..)", + "pePositionS", + "Source(..)", + "SourceList(..)", + "ListPos(..)" + ] + +myInit :: [a] -> [a] +myInit [] = [] +myInit [_] = [] +myInit (x : xs) = x : myInit xs diff --git a/papillon.cabal b/papillon.cabal --- a/papillon.cabal +++ b/papillon.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: papillon -version: 0.0.7 +version: 0.0.45 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo @@ -25,17 +25,23 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/papillon.git - tag: 0.0.7 + tag: 0.0.45 library hs-source-dirs: src - exposed-modules: Text.Papillon - other-modules: Text.Papillon.Parser, Text.Papillon.Class + exposed-modules: Text.Papillon, Text.PapillonCore + other-modules: + Text.Papillon.Parser, + Text.Papillon.Papillon, + Text.Papillon.Papillon, + Text.Papillon.List, + Text.Papillon.SyntaxTree build-depends: base > 3 && < 5, template-haskell, monads-tf, transformers ghc-options: -Wall executable papillon - hs-source-dirs: src + hs-source-dirs: bin main-is: papillon.hs - build-depends: base > 3 && < 5, template-haskell, monads-tf, transformers + other-modules: Class + build-depends: directory, filepath, base > 3 && < 5, template-haskell, monads-tf, transformers, papillon ghc-options: -Wall diff --git a/src/Text/Papillon.hs b/src/Text/Papillon.hs --- a/src/Text/Papillon.hs +++ b/src/Text/Papillon.hs @@ -1,358 +1,20 @@ -{-# LANGUAGE TemplateHaskell, PackageImports, TypeFamilies, FlexibleContexts #-} - module Text.Papillon ( papillon, - papillonStr, - papillonStr', - classSourceQ, + ParseError(..), Source(..), - SourceList(..) + SourceList(..), + Pos(..), + ListPos(..), + pePositionS, ) where +import Text.PapillonCore 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 + quoteDec = papillonCore } - -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 = -{- - "instance MonadError Maybe where\n" ++ - "\ttype ErrorType Maybe = ()\n" ++ - "\tthrowError () = Nothing\n" ++ - "\tcatchError action recover = recover ()\n\n" ++ --} - - "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 --- fm <- dFlipMaybe - 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 --- debug <- flip (valD $ varP $ mkName "debug") [] $ normalB $ --- appE (varE $ mkName "putStrLn") (litE $ stringL "debug") - 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 -- name expr - return $ {- fm ++ -} [pm, r, d, pt, p] ++ tdvm ++ dvsm ++ [tdvcm, dvcm] ++ pts ++ ps - where --- c = clause [wildP] (normalB $ conE $ mkName "Nothing") [] - -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 (flipMaybeN th) `appE` - varE (mkName $ "dv_" ++ v ++ "M"), --} - 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 diff --git a/src/Text/Papillon/Class.hs b/src/Text/Papillon/Class.hs deleted file mode 100644 --- a/src/Text/Papillon/Class.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE TypeFamilies, TemplateHaskell #-} - -module Text.Papillon.Class ( --- Source(..), - classSourceQ -) where - -import Language.Haskell.TH - -{- -class Source sl where - type Token sl - getToken :: sl -> Maybe (Token sl, sl) - -class SourceList c where - listToken :: [c] -> Maybe (c, [c]) - -instance SourceList Char where - listToken (c : s) = Just (c, s) - listToken _ = Nothing - -instance (SourceList c) => Source [c] where - type Token [c] = c - getToken = listToken --} - -classSourceQ :: Bool -> DecsQ -classSourceQ th = sequence - [classS th, classSL th, instanceSLC th, instanceSrcStr th] - -maybeN, nothingN, justN, consN, charN :: Bool -> Name -maybeN True = ''Maybe -maybeN False = mkName "Maybe" -nothingN True = 'Nothing -nothingN False = mkName "Nothing" -justN True = 'Just -justN False = mkName "Just" -consN True = '(:) -consN False = mkName ":" -charN True = ''Char -charN False = mkName "Char" - -classS, classSL, instanceSLC, instanceSrcStr :: Bool -> DecQ -classS th = classD (cxt []) source [PlainTV sl] [] [ - familyNoKindD typeFam tokenN [PlainTV sl], - sigD getTokenN $ arrowT `appT` varT sl `appT` - (conT (maybeN th) `appT` tupleBody) - ] where - sl = mkName "sl" - tupleBody = tupleT 2 - `appT` (conT tokenN `appT` varT sl) - `appT` varT sl - -classSL th = classD (cxt []) sourceList [PlainTV c] [] [ - sigD listTokenN $ arrowT `appT` (listT `appT` varT c) `appT` - (conT (maybeN th) `appT` tupleBody) - ] where - c = mkName "c" - tupleBody = tupleT 2 `appT` varT c `appT` (listT `appT` varT c) - -source, sourceList, listTokenN, tokenN, getTokenN :: Name -sourceList = mkName "SourceList" -listTokenN = mkName "listToken" -source = mkName "Source" -tokenN = mkName "Token" -getTokenN = mkName "getToken" - -instanceSLC th = instanceD (cxt []) (conT sourceList `appT` conT (charN th)) [ - funD listTokenN [ - clause [infixP (varP c) (consN th) (varP s)] - (normalB $ conE (justN th) `appE` tupleBody) [], - clause [wildP] (normalB $ conE $ nothingN th) [] - ] - ] where - c = mkName "c" - s = mkName "s" - tupleBody = tupE [varE c, varE s] - -instanceSrcStr _ = - instanceD (cxt [classP sourceList [varT c]]) (conT source `appT` listC) [ - tySynInstD tokenN [listC] $ varT c, - valD (varP getTokenN) (normalB $ varE listTokenN) [] - ] - where - c = mkName "c" - listC = listT `appT` varT c diff --git a/src/Text/Papillon/List.hs b/src/Text/Papillon/List.hs new file mode 100644 --- /dev/null +++ b/src/Text/Papillon/List.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TemplateHaskell, PackageImports #-} + +module Text.Papillon.List ( + listDec, + optionalDec +) where + +import Language.Haskell.TH +import Control.Applicative +import Control.Monad + +{- + +list, list1 :: (MonadPlus m, Applicative m) => m a -> m [a] +list p = list1 p `mplus` return [] +list1 p = (:) <$> p <*> list p + +-} + +monadPlusN, mplusN, applicativeN, applyN, applyContN :: Bool -> Name +monadPlusN True = ''MonadPlus +monadPlusN False = mkName "MonadPlus" +applicativeN True = ''Applicative +applicativeN False = mkName "Applicative" +mplusN True = 'mplus +mplusN False = mkName "mplus" +applyN True = '(<$>) +applyN False = mkName "<$>" +applyContN True = '(<*>) +applyContN False = mkName "<*>" + +m, a, p :: Name +m = mkName "m" +a = mkName "a" +p = mkName "p" + +listDec :: Name -> Name -> Bool -> DecsQ +listDec list list1 th = sequence [ + sigD list $ forallT [PlainTV m, PlainTV a] + (cxt [classP (monadPlusN th) [vm], classP (applicativeN th) [vm]]) $ + arrowT `appT` (varT m `appT` varT a) + `appT` (varT m `appT` (listT `appT` varT a)), + sigD list1 $ forallT [PlainTV m, PlainTV a] + (cxt [classP (monadPlusN th) [vm], classP (applicativeN th) [vm]]) $ + arrowT `appT` (varT m `appT` varT a) + `appT` (varT m `appT` (listT `appT` varT a)), + funD list $ (: []) $ flip (clause [varP p]) [] $ normalB $ + infixApp (varE list1 `appE` varE p) (varE $ mplusN th) returnEmpty, + funD list1 $ (: []) $ flip (clause [varP p]) [] $ normalB $ + infixApp (infixApp cons app (varE p)) next (varE list `appE` varE p) + ] where + vm = varT m + returnEmpty = varE (mkName "return") `appE` listE [] + cons = conE $ mkName ":" + app = varE $ applyN th + next = varE $ applyContN th + +{- + +optional :: (MonadPlus m, Applicative m) => m a -> m (Maybe a) +optional p = (Just <$> p) `mplus` return Nothing + +-} + +optionalDec :: Name -> Bool -> DecsQ +optionalDec optionalN th = sequence [ + sigD optionalN $ mplusAndApp $ (varT m `appT` varT a) `arrT` + (varT m `appT` (conT (mkName "Maybe") `appT` varT a)), + funD optionalN $ (: []) $ flip (clause [varP p]) [] $ normalB $ + conE (mkName "Just") `app` varE p `mplusE` returnNothing + ] where + mplusAndApp = forallT [PlainTV m, PlainTV a] $ cxt [ + classP (monadPlusN th) [varT m], + classP (applicativeN th) [varT m] + ] + arrT f x = arrowT `appT` f `appT` x + mplusE x = infixApp x (varE $ mplusN th) + returnNothing = varE (mkName "return") `appE` conE (mkName "Nothing") + app x = infixApp x (varE $ applyN th) diff --git a/src/Text/Papillon/Papillon.hs b/src/Text/Papillon/Papillon.hs new file mode 100644 --- /dev/null +++ b/src/Text/Papillon/Papillon.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE RankNTypes, TypeFamilies #-} +module Text.Papillon.Papillon ( + ParseError(..), + Pos(..), + pePositionS, + Source(..), + SourceList(..), + ListPos(..)) where +import Control.Monad.Trans.Error (Error(..)) +data ParseError pos drv + = ParseError {peCode :: String, + peMessage :: String, + peComment :: String, + peDerivs :: drv, + peReading :: ([String]), + pePosition :: pos} +instance Error (ParseError pos drv) + where strMsg msg = ParseError "" msg "" undefined undefined undefined +pePositionS :: forall drv . ParseError (Pos String) drv -> + (Int, Int) +pePositionS (ParseError {pePosition = ListPos (CharPos p)}) = p +class Source sl + where type Token sl + data Pos sl + getToken :: sl -> Maybe ((Token sl, sl)) + initialPos :: Pos sl + updatePos :: Token sl -> Pos sl -> Pos sl +class SourceList c + where data ListPos c + listToken :: [c] -> Maybe ((c, [c])) + listInitialPos :: ListPos c + listUpdatePos :: c -> ListPos c -> ListPos c +instance SourceList c => Source ([c]) + where type Token ([c]) = c + newtype Pos ([c]) = ListPos (ListPos c) + getToken = listToken + initialPos = ListPos listInitialPos + updatePos c (ListPos p) = ListPos (listUpdatePos c p) +instance SourceList Char + where newtype ListPos Char = CharPos ((Int, Int)) deriving (Show) + listToken (c : s) = Just (c, s) + listToken _ = Nothing + listInitialPos = CharPos (1, 1) + listUpdatePos '\n' (CharPos (y, _)) = CharPos (y + 1, 0) + listUpdatePos _ (CharPos (y, x)) = CharPos (y, x + 1) diff --git a/src/Text/Papillon/Parser.hs b/src/Text/Papillon/Parser.hs --- a/src/Text/Papillon/Parser.hs +++ b/src/Text/Papillon/Parser.hs @@ -1,1408 +1,1829 @@ -{-# LANGUAGE FlexibleContexts, TemplateHaskell , FlexibleContexts, PackageImports, TypeFamilies #-} -module Text.Papillon.Parser ( - Peg, - Definition, - ExpressionHs, - NameLeaf, - NameLeaf_(..), - parse, - dv_peg, - dv_pegFile, -) where -import "monads-tf" Control.Monad.State -import "monads-tf" Control.Monad.Error -import Control.Monad.Trans.Error (Error (..)) - - - -import Data.Char -import Language.Haskell.TH - -type MaybeString = Maybe String - -type Nil = () -type Leaf = Either String ExR -type NameLeaf = (PatQ, Leaf) -data NameLeaf_ = NotAfter NameLeaf | Here NameLeaf -notAfter, here :: NameLeaf -> NameLeaf_ -notAfter = NotAfter -here = Here -type Expression = [NameLeaf_] -type ExpressionHs = (Expression, ExR) -type Selection = [ExpressionHs] -type Typ = Name -type Definition = (String, Typ, Selection) -type Peg = [Definition] -type TTPeg = (TypeQ, TypeQ, Peg) - -type Ex = ExpQ -> ExpQ -type ExR = ExpQ - -ctLeaf :: Leaf -ctLeaf = Right $ varE (mkName "const") `appE` conE (mkName "True") - -left :: b -> Either a b -right :: a -> Either a b -left = Right -right = Left - -just :: a -> Maybe a -just = Just -nothing :: Maybe a -nothing = Nothing - -nil :: Nil -nil = () - -cons :: a -> [a] -> [a] -cons = (:) - -type PatQs = [PatQ] - -mkNameLeaf :: PatQ -> b -> (PatQ, b) -mkNameLeaf = (,) - -strToPatQ :: String -> PatQ -strToPatQ = varP . mkName - -conToPatQ :: String -> [PatQ] -> PatQ -conToPatQ t ps = conP (mkName t) ps - -mkExpressionHs :: a -> Ex -> (a, ExR) -mkExpressionHs x y = (x, getEx y) - -mkDef :: a -> String -> c -> (a, Name, c) -mkDef x y z = (x, mkName y, z) - -toExp :: String -> Ex -toExp v = \f -> f `appE` varE (mkName v) - -apply :: String -> Ex -> Ex -apply f x = \g -> x (toExp f g) - -getEx :: Ex -> ExR -getEx ex = ex (varE $ mkName "id") - -empty :: [a] -empty = [] - -type PegFile = (String, TTPeg, String) -mkPegFile :: Maybe String -> Maybe String -> String -> String -> b -> c -> (String, b, c) -mkPegFile (Just p) (Just md) x y z w = - ("{-#" ++ p ++ addPragmas ++ "module " ++ md ++ " where\n" ++ - addModules ++ - x ++ "\n" ++ y, z, w) -mkPegFile Nothing (Just md) x y z w = - (x ++ "\n" ++ "module " ++ md ++ " where\n" ++ - addModules ++ - x ++ "\n" ++ y, z, w) -mkPegFile (Just p) Nothing x y z w = ( - "{-#" ++ p ++ addPragmas ++ - addModules ++ - x ++ "\n" ++ y - , z, w) -mkPegFile Nothing Nothing x y z w = (addModules ++ x ++ "\n" ++ y, z, w) - -addPragmas, addModules :: String -addPragmas = - ", FlexibleContexts, PackageImports, TypeFamilies #-}\n" -addModules = - "import \"monads-tf\" Control.Monad.State\n" ++ - "import \"monads-tf\" Control.Monad.Error\n" ++ - "import Control.Monad.Trans.Error (Error (..))\n" - -true :: Bool -true = True - -charP :: Char -> PatQ -charP = litP . charL -stringP :: String -> PatQ -stringP = litP . stringL - -isAlphaNumOt, elemNTs :: Char -> Bool -isAlphaNumOt c = isAlphaNum c || c `elem` "{-#.\":}" -elemNTs = (`elem` "nt\\'") - -getNTs :: Char -> Char -getNTs 'n' = '\n' -getNTs 't' = '\t' -getNTs '\\' = '\\' -getNTs '\'' = '\'' -getNTs o = o - -isEqual, isSlash, isSemi, isColon, isOpenWave, isCloseWave, isLowerU, isNot, - isChon, isDQ, isBS :: Char -> Bool -isEqual = (== '=') -isSlash = (== '/') -isSemi = (== ';') -isColon = (== ':') -isOpenWave = (== '{') -isCloseWave = (== '}') -isLowerU c = isLower c || c == '_' -isNot = (== '!') -isChon = (== '\'') -isDQ = (== '"') -isBS = (== '\\') - -isOpenBr, isP, isA, isI, isL, isO, isN, isBar, isCloseBr, isNL :: Char -> Bool -[isOpenBr, isP, isA, isI, isL, isO, isN, isBar, isCloseBr, isNL] = - map (==) "[pailon|]\n" - -{- -tString, tChar :: TypeQ -tString = varT ''String -tChar = varT ''Char --} - -tString :: String -tString = "String" -mkTTPeg :: String -> Peg -> TTPeg -mkTTPeg s p = - (conT $ mkName s, conT (mkName "Token") `appT` conT (mkName s), p) - -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" -type PackratM = StateT Derivs (Either String) -type Result v = Either String ((v, Derivs)) -data Derivs - = Derivs {dv_pegFile :: (Result PegFile), - dv_pragma :: (Result MaybeString), - dv_pragmaStr :: (Result String), - dv_pragmaEnd :: (Result Nil), - dv_moduleDec :: (Result MaybeString), - dv_moduleDecStr :: (Result String), - dv_whr :: (Result Nil), - dv_preImpPap :: (Result String), - dv_prePeg :: (Result String), - dv_afterPeg :: (Result String), - dv_importPapillon :: (Result Nil), - dv_varToken :: (Result String), - dv_typToken :: (Result String), - dv_pap :: (Result Nil), - dv_peg :: (Result TTPeg), - dv_sourceType :: (Result String), - dv_peg_ :: (Result Peg), - dv_definition :: (Result Definition), - dv_selection :: (Result Selection), - dv_expressionHs :: (Result ExpressionHs), - dv_expression :: (Result Expression), - dv_nameLeaf_ :: (Result NameLeaf_), - dv_nameLeaf :: (Result NameLeaf), - dv_pat :: (Result PatQ), - dv_charLit :: (Result Char), - dv_stringLit :: (Result String), - dv_dq :: (Result Nil), - dv_pats :: (Result PatQs), - dv_leaf :: (Result Leaf), - dv_test :: (Result ExR), - dv_hsExp :: (Result Ex), - dv_typ :: (Result String), - dv_variable :: (Result String), - dv_tvtail :: (Result String), - dv_alpha :: (Result Char), - dv_upper :: (Result Char), - dv_lower :: (Result Char), - dv_digit :: (Result Char), - dv_spaces :: (Result Nil), - dv_space :: (Result Nil), - dv_notNLString :: (Result String), - dv_nl :: (Result Nil), - dv_comment :: (Result Nil), - dv_comments :: (Result Nil), - dv_notComStr :: (Result Nil), - dv_comEnd :: (Result Nil), - dvChars :: (Result (Token String))} -parse :: String -> Derivs -parse s = d - where d = Derivs pegFile pragma pragmaStr pragmaEnd moduleDec moduleDecStr whr preImpPap prePeg afterPeg importPapillon varToken typToken pap peg sourceType peg_ definition selection expressionHs expression nameLeaf_ nameLeaf pat charLit stringLit dq pats leaf test hsExp typ variable tvtail alpha upper lower digit spaces space notNLString nl comment comments notComStr comEnd char - pegFile = runStateT p_pegFile d - pragma = runStateT p_pragma d - pragmaStr = runStateT p_pragmaStr d - pragmaEnd = runStateT p_pragmaEnd d - moduleDec = runStateT p_moduleDec d - moduleDecStr = runStateT p_moduleDecStr d - whr = runStateT p_whr d - preImpPap = runStateT p_preImpPap d - prePeg = runStateT p_prePeg d - afterPeg = runStateT p_afterPeg d - importPapillon = runStateT p_importPapillon d - varToken = runStateT p_varToken d - typToken = runStateT p_typToken d - pap = runStateT p_pap d - peg = runStateT p_peg d - sourceType = runStateT p_sourceType d - peg_ = runStateT p_peg_ d - definition = runStateT p_definition d - selection = runStateT p_selection d - expressionHs = runStateT p_expressionHs d - expression = runStateT p_expression d - nameLeaf_ = runStateT p_nameLeaf_ d - nameLeaf = runStateT p_nameLeaf d - pat = runStateT p_pat d - charLit = runStateT p_charLit d - stringLit = runStateT p_stringLit d - dq = runStateT p_dq d - pats = runStateT p_pats d - leaf = runStateT p_leaf d - test = runStateT p_test d - hsExp = runStateT p_hsExp d - typ = runStateT p_typ d - variable = runStateT p_variable d - tvtail = runStateT p_tvtail d - alpha = runStateT p_alpha d - upper = runStateT p_upper d - lower = runStateT p_lower d - digit = runStateT p_digit d - spaces = runStateT p_spaces d - space = runStateT p_space d - notNLString = runStateT p_notNLString d - nl = runStateT p_nl d - comment = runStateT p_comment d - comments = runStateT p_comments d - notComStr = runStateT p_notComStr d - comEnd = runStateT p_comEnd d - char = flip runStateT d (case getToken s of - Just (c, s') -> do put (parse s') - return c - _ -> throwError (strMsg "eof")) -dv_pragmaM :: PackratM MaybeString -dv_pragmaStrM :: PackratM String -dv_pragmaEndM :: PackratM Nil -dv_moduleDecM :: PackratM MaybeString -dv_moduleDecStrM :: PackratM String -dv_whrM :: PackratM Nil -dv_preImpPapM :: PackratM String -dv_prePegM :: PackratM String -dv_afterPegM :: PackratM String -dv_importPapillonM :: PackratM Nil -dv_varTokenM :: PackratM String -dv_typTokenM :: PackratM String -dv_papM :: PackratM Nil -dv_pegM :: PackratM TTPeg -dv_sourceTypeM :: PackratM String -dv_peg_M :: PackratM Peg -dv_definitionM :: PackratM Definition -dv_selectionM :: PackratM Selection -dv_expressionHsM :: PackratM ExpressionHs -dv_expressionM :: PackratM Expression -dv_nameLeaf_M :: PackratM NameLeaf_ -dv_nameLeafM :: PackratM NameLeaf -dv_patM :: PackratM PatQ -dv_charLitM :: PackratM Char -dv_stringLitM :: PackratM String -dv_dqM :: PackratM Nil -dv_patsM :: PackratM PatQs -dv_leafM :: PackratM Leaf -dv_testM :: PackratM ExR -dv_hsExpM :: PackratM Ex -dv_typM :: PackratM String -dv_variableM :: PackratM String -dv_tvtailM :: PackratM String -dv_alphaM :: PackratM Char -dv_upperM :: PackratM Char -dv_lowerM :: PackratM Char -dv_digitM :: PackratM Char -dv_spacesM :: PackratM Nil -dv_spaceM :: PackratM Nil -dv_notNLStringM :: PackratM String -dv_nlM :: PackratM Nil -dv_commentM :: PackratM Nil -dv_commentsM :: PackratM Nil -dv_notComStrM :: PackratM Nil -dv_comEndM :: PackratM Nil -dv_pragmaM = StateT dv_pragma -dv_pragmaStrM = StateT dv_pragmaStr -dv_pragmaEndM = StateT dv_pragmaEnd -dv_moduleDecM = StateT dv_moduleDec -dv_moduleDecStrM = StateT dv_moduleDecStr -dv_whrM = StateT dv_whr -dv_preImpPapM = StateT dv_preImpPap -dv_prePegM = StateT dv_prePeg -dv_afterPegM = StateT dv_afterPeg -dv_importPapillonM = StateT dv_importPapillon -dv_varTokenM = StateT dv_varToken -dv_typTokenM = StateT dv_typToken -dv_papM = StateT dv_pap -dv_pegM = StateT dv_peg -dv_sourceTypeM = StateT dv_sourceType -dv_peg_M = StateT dv_peg_ -dv_definitionM = StateT dv_definition -dv_selectionM = StateT dv_selection -dv_expressionHsM = StateT dv_expressionHs -dv_expressionM = StateT dv_expression -dv_nameLeaf_M = StateT dv_nameLeaf_ -dv_nameLeafM = StateT dv_nameLeaf -dv_patM = StateT dv_pat -dv_charLitM = StateT dv_charLit -dv_stringLitM = StateT dv_stringLit -dv_dqM = StateT dv_dq -dv_patsM = StateT dv_pats -dv_leafM = StateT dv_leaf -dv_testM = StateT dv_test -dv_hsExpM = StateT dv_hsExp -dv_typM = StateT dv_typ -dv_variableM = StateT dv_variable -dv_tvtailM = StateT dv_tvtail -dv_alphaM = StateT dv_alpha -dv_upperM = StateT dv_upper -dv_lowerM = StateT dv_lower -dv_digitM = StateT dv_digit -dv_spacesM = StateT dv_spaces -dv_spaceM = StateT dv_space -dv_notNLStringM = StateT dv_notNLString -dv_nlM = StateT dv_nl -dv_commentM = StateT dv_comment -dv_commentsM = StateT dv_comments -dv_notComStrM = StateT dv_notComStr -dv_comEndM = StateT dv_comEnd -dvCharsM :: PackratM (Token String) -dvCharsM = StateT dvChars -p_pegFile :: PackratM PegFile -p_pragma :: PackratM MaybeString -p_pragmaStr :: PackratM String -p_pragmaEnd :: PackratM Nil -p_moduleDec :: PackratM MaybeString -p_moduleDecStr :: PackratM String -p_whr :: PackratM Nil -p_preImpPap :: PackratM String -p_prePeg :: PackratM String -p_afterPeg :: PackratM String -p_importPapillon :: PackratM Nil -p_varToken :: PackratM String -p_typToken :: PackratM String -p_pap :: PackratM Nil -p_peg :: PackratM TTPeg -p_sourceType :: PackratM String -p_peg_ :: PackratM Peg -p_definition :: PackratM Definition -p_selection :: PackratM Selection -p_expressionHs :: PackratM ExpressionHs -p_expression :: PackratM Expression -p_nameLeaf_ :: PackratM NameLeaf_ -p_nameLeaf :: PackratM NameLeaf -p_pat :: PackratM PatQ -p_charLit :: PackratM Char -p_stringLit :: PackratM String -p_dq :: PackratM Nil -p_pats :: PackratM PatQs -p_leaf :: PackratM Leaf -p_test :: PackratM ExR -p_hsExp :: PackratM Ex -p_typ :: PackratM String -p_variable :: PackratM String -p_tvtail :: PackratM String -p_alpha :: PackratM Char -p_upper :: PackratM Char -p_lower :: PackratM Char -p_digit :: PackratM Char -p_spaces :: PackratM Nil -p_space :: PackratM Nil -p_notNLString :: PackratM String -p_nl :: PackratM Nil -p_comment :: PackratM Nil -p_comments :: PackratM Nil -p_notComStr :: PackratM Nil -p_comEnd :: PackratM Nil -p_pegFile = msum [do pr <- dv_pragmaM - return () - md <- dv_moduleDecM - return () - pip <- dv_preImpPapM - return () - _ <- dv_importPapillonM - return () - pp <- dv_prePegM - return () - _ <- dv_papM - return () - p <- dv_pegM - return () - _ <- dv_spacesM - return () - xx0_0 <- dvCharsM - if id isBar xx0_0 - then return () - else throwError (strMsg "not match") - case xx0_0 of - _ -> return () - let _ = xx0_0 - return () - xx1_1 <- dvCharsM - if id isCloseBr xx1_1 - then return () - else throwError (strMsg "not match") - case xx1_1 of - _ -> return () - let _ = xx1_1 - return () - xx2_2 <- dvCharsM - if id isNL xx2_2 - then return () - else throwError (strMsg "not match") - case xx2_2 of - _ -> return () - let _ = xx2_2 - return () - atp <- dv_afterPegM - return () - return (id mkPegFile pr md pip pp p atp), - do pr <- dv_pragmaM - return () - md <- dv_moduleDecM - return () - pp <- dv_prePegM - return () - _ <- dv_papM - return () - p <- dv_pegM - return () - _ <- dv_spacesM - return () - xx3_3 <- dvCharsM - if id isBar xx3_3 - then return () - else throwError (strMsg "not match") - case xx3_3 of - _ -> return () - let _ = xx3_3 - return () - xx4_4 <- dvCharsM - if id isCloseBr xx4_4 - then return () - else throwError (strMsg "not match") - case xx4_4 of - _ -> return () - let _ = xx4_4 - return () - xx5_5 <- dvCharsM - if id isNL xx5_5 - then return () - else throwError (strMsg "not match") - case xx5_5 of - _ -> return () - let _ = xx5_5 - return () - atp <- dv_afterPegM - return () - return (id mkPegFile pr md empty pp p atp)] -p_pragma = msum [do _ <- dv_spacesM - return () - xx6_6 <- dvCharsM - if const True xx6_6 - then return () - else throwError (strMsg "not match") - case xx6_6 of - '{' -> return () - _ -> throwError (strMsg "not match") - let '{' = xx6_6 - return () - xx7_7 <- dvCharsM - if const True xx7_7 - then return () - else throwError (strMsg "not match") - case xx7_7 of - '-' -> return () - _ -> throwError (strMsg "not match") - let '-' = xx7_7 - return () - xx8_8 <- dvCharsM - if const True xx8_8 - then return () - else throwError (strMsg "not match") - case xx8_8 of - '#' -> return () - _ -> throwError (strMsg "not match") - let '#' = xx8_8 - return () - s <- dv_pragmaStrM - return () - _ <- dv_pragmaEndM - return () - _ <- dv_spacesM - return () - return (id just s), - do _ <- dv_spacesM - return () - return (id nothing)] -p_pragmaStr = msum [do d_9 <- get - flipMaybe (do _ <- dv_pragmaEndM - return ()) - put d_9 - xx9_10 <- dvCharsM - if const True xx9_10 - then return () - else throwError (strMsg "not match") - case xx9_10 of - _ -> return () - let c = xx9_10 - return () - s <- dv_pragmaStrM - return () - return (id cons c s), - do return (id empty)] -p_pragmaEnd = msum [do xx10_11 <- dvCharsM - if const True xx10_11 - then return () - else throwError (strMsg "not match") - case xx10_11 of - '#' -> return () - _ -> throwError (strMsg "not match") - let '#' = xx10_11 - return () - xx11_12 <- dvCharsM - if const True xx11_12 - then return () - else throwError (strMsg "not match") - case xx11_12 of - '-' -> return () - _ -> throwError (strMsg "not match") - let '-' = xx11_12 - return () - xx12_13 <- dvCharsM - if const True xx12_13 - then return () - else throwError (strMsg "not match") - case xx12_13 of - '}' -> return () - _ -> throwError (strMsg "not match") - let '}' = xx12_13 - return () - return (id nil)] -p_moduleDec = msum [do xx13_14 <- dvCharsM - if const True xx13_14 - then return () - else throwError (strMsg "not match") - case xx13_14 of - 'm' -> return () - _ -> throwError (strMsg "not match") - let 'm' = xx13_14 - return () - xx14_15 <- dvCharsM - if const True xx14_15 - then return () - else throwError (strMsg "not match") - case xx14_15 of - 'o' -> return () - _ -> throwError (strMsg "not match") - let 'o' = xx14_15 - return () - xx15_16 <- dvCharsM - if const True xx15_16 - then return () - else throwError (strMsg "not match") - case xx15_16 of - 'd' -> return () - _ -> throwError (strMsg "not match") - let 'd' = xx15_16 - return () - xx16_17 <- dvCharsM - if const True xx16_17 - then return () - else throwError (strMsg "not match") - case xx16_17 of - 'u' -> return () - _ -> throwError (strMsg "not match") - let 'u' = xx16_17 - return () - xx17_18 <- dvCharsM - if const True xx17_18 - then return () - else throwError (strMsg "not match") - case xx17_18 of - 'l' -> return () - _ -> throwError (strMsg "not match") - let 'l' = xx17_18 - return () - xx18_19 <- dvCharsM - if const True xx18_19 - then return () - else throwError (strMsg "not match") - case xx18_19 of - 'e' -> return () - _ -> throwError (strMsg "not match") - let 'e' = xx18_19 - return () - s <- dv_moduleDecStrM - return () - _ <- dv_whrM - return () - return (id just s), - do return (id nothing)] -p_moduleDecStr = msum [do d_20 <- get - flipMaybe (do _ <- dv_whrM - return ()) - put d_20 - xx19_21 <- dvCharsM - if const True xx19_21 - then return () - else throwError (strMsg "not match") - case xx19_21 of - _ -> return () - let c = xx19_21 - return () - s <- dv_moduleDecStrM - return () - return (id cons c s), - do return (id empty)] -p_whr = msum [do xx20_22 <- dvCharsM - if const True xx20_22 - then return () - else throwError (strMsg "not match") - case xx20_22 of - 'w' -> return () - _ -> throwError (strMsg "not match") - let 'w' = xx20_22 - return () - xx21_23 <- dvCharsM - if const True xx21_23 - then return () - else throwError (strMsg "not match") - case xx21_23 of - 'h' -> return () - _ -> throwError (strMsg "not match") - let 'h' = xx21_23 - return () - xx22_24 <- dvCharsM - if const True xx22_24 - then return () - else throwError (strMsg "not match") - case xx22_24 of - 'e' -> return () - _ -> throwError (strMsg "not match") - let 'e' = xx22_24 - return () - xx23_25 <- dvCharsM - if const True xx23_25 - then return () - else throwError (strMsg "not match") - case xx23_25 of - 'r' -> return () - _ -> throwError (strMsg "not match") - let 'r' = xx23_25 - return () - xx24_26 <- dvCharsM - if const True xx24_26 - then return () - else throwError (strMsg "not match") - case xx24_26 of - 'e' -> return () - _ -> throwError (strMsg "not match") - let 'e' = xx24_26 - return () - return (id nil)] -p_preImpPap = msum [do d_27 <- get - flipMaybe (do _ <- dv_importPapillonM - return ()) - put d_27 - d_28 <- get - flipMaybe (do _ <- dv_papM - return ()) - put d_28 - xx25_29 <- dvCharsM - if id const true xx25_29 - then return () - else throwError (strMsg "not match") - case xx25_29 of - _ -> return () - let c = xx25_29 - return () - pip <- dv_preImpPapM - return () - return (id cons c pip), - do return (id empty)] -p_prePeg = msum [do d_30 <- get - flipMaybe (do _ <- dv_papM - return ()) - put d_30 - xx26_31 <- dvCharsM - if id const true xx26_31 - then return () - else throwError (strMsg "not match") - case xx26_31 of - _ -> return () - let c = xx26_31 - return () - pp <- dv_prePegM - return () - return (id cons c pp), - do return (id empty)] -p_afterPeg = msum [do xx27_32 <- dvCharsM - if id const true xx27_32 - then return () - else throwError (strMsg "not match") - case xx27_32 of - _ -> return () - let c = xx27_32 - return () - atp <- dv_afterPegM - return () - return (id cons c atp), - do return (id empty)] -p_importPapillon = msum [do xx28_33 <- dv_varTokenM - case xx28_33 of - "import" -> return () - _ -> throwError (strMsg "not match") - "import" <- return xx28_33 - xx29_34 <- dv_typTokenM - case xx29_34 of - "Text" -> return () - _ -> throwError (strMsg "not match") - "Text" <- return xx29_34 - xx30_35 <- dvCharsM - if const True xx30_35 - then return () - else throwError (strMsg "not match") - case xx30_35 of - '.' -> return () - _ -> throwError (strMsg "not match") - let '.' = xx30_35 - return () - _ <- dv_spacesM - return () - xx31_36 <- dv_typTokenM - case xx31_36 of - "Papillon" -> return () - _ -> throwError (strMsg "not match") - "Papillon" <- return xx31_36 - return (id nil)] -p_varToken = msum [do v <- dv_variableM - return () - _ <- dv_spacesM - return () - return (id v)] -p_typToken = msum [do t <- dv_typM - return () - _ <- dv_spacesM - return () - return (id t)] -p_pap = msum [do xx32_37 <- dvCharsM - if id isNL xx32_37 - then return () - else throwError (strMsg "not match") - case xx32_37 of - _ -> return () - let _ = xx32_37 - return () - xx33_38 <- dvCharsM - if id isOpenBr xx33_38 - then return () - else throwError (strMsg "not match") - case xx33_38 of - _ -> return () - let _ = xx33_38 - return () - xx34_39 <- dvCharsM - if id isP xx34_39 - then return () - else throwError (strMsg "not match") - case xx34_39 of - _ -> return () - let _ = xx34_39 - return () - xx35_40 <- dvCharsM - if id isA xx35_40 - then return () - else throwError (strMsg "not match") - case xx35_40 of - _ -> return () - let _ = xx35_40 - return () - xx36_41 <- dvCharsM - if id isP xx36_41 - then return () - else throwError (strMsg "not match") - case xx36_41 of - _ -> return () - let _ = xx36_41 - return () - xx37_42 <- dvCharsM - if id isI xx37_42 - then return () - else throwError (strMsg "not match") - case xx37_42 of - _ -> return () - let _ = xx37_42 - return () - xx38_43 <- dvCharsM - if id isL xx38_43 - then return () - else throwError (strMsg "not match") - case xx38_43 of - _ -> return () - let _ = xx38_43 - return () - xx39_44 <- dvCharsM - if id isL xx39_44 - then return () - else throwError (strMsg "not match") - case xx39_44 of - _ -> return () - let _ = xx39_44 - return () - xx40_45 <- dvCharsM - if id isO xx40_45 - then return () - else throwError (strMsg "not match") - case xx40_45 of - _ -> return () - let _ = xx40_45 - return () - xx41_46 <- dvCharsM - if id isN xx41_46 - then return () - else throwError (strMsg "not match") - case xx41_46 of - _ -> return () - let _ = xx41_46 - return () - xx42_47 <- dvCharsM - if id isBar xx42_47 - then return () - else throwError (strMsg "not match") - case xx42_47 of - _ -> return () - let _ = xx42_47 - return () - xx43_48 <- dvCharsM - if id isNL xx43_48 - then return () - else throwError (strMsg "not match") - case xx43_48 of - _ -> return () - let _ = xx43_48 - return () - return (id nil)] -p_peg = msum [do _ <- dv_spacesM - return () - s <- dv_sourceTypeM - return () - p <- dv_peg_M - return () - return (id mkTTPeg s p), - do p <- dv_peg_M - return () - return (id mkTTPeg tString p)] -p_sourceType = msum [do xx44_49 <- dv_varTokenM - case xx44_49 of - "source" -> return () - _ -> throwError (strMsg "not match") - "source" <- return xx44_49 - xx45_50 <- dvCharsM - if const True xx45_50 - then return () - else throwError (strMsg "not match") - case xx45_50 of - ':' -> return () - _ -> throwError (strMsg "not match") - let ':' = xx45_50 - return () - _ <- dv_spacesM - return () - v <- dv_typTokenM - return () - return (id v)] -p_peg_ = msum [do _ <- dv_spacesM - return () - d <- dv_definitionM - return () - p <- dv_peg_M - return () - return (id cons d p), - do return (id empty)] -p_definition = msum [do v <- dv_variableM - return () - _ <- dv_spacesM - return () - xx46_51 <- dvCharsM - if id isColon xx46_51 - then return () - else throwError (strMsg "not match") - case xx46_51 of - _ -> return () - let _ = xx46_51 - return () - xx47_52 <- dvCharsM - if id isColon xx47_52 - then return () - else throwError (strMsg "not match") - case xx47_52 of - _ -> return () - let _ = xx47_52 - return () - _ <- dv_spacesM - return () - t <- dv_typM - return () - _ <- dv_spacesM - return () - xx48_53 <- dvCharsM - if id isEqual xx48_53 - then return () - else throwError (strMsg "not match") - case xx48_53 of - _ -> return () - let _ = xx48_53 - return () - _ <- dv_spacesM - return () - sel <- dv_selectionM - return () - _ <- dv_spacesM - return () - xx49_54 <- dvCharsM - if id isSemi xx49_54 - then return () - else throwError (strMsg "not match") - case xx49_54 of - _ -> return () - let _ = xx49_54 - return () - return (id mkDef v t sel)] -p_selection = msum [do ex <- dv_expressionHsM - return () - _ <- dv_spacesM - return () - xx50_55 <- dvCharsM - if id isSlash xx50_55 - then return () - else throwError (strMsg "not match") - case xx50_55 of - _ -> return () - let _ = xx50_55 - return () - _ <- dv_spacesM - return () - sel <- dv_selectionM - return () - return (id cons ex sel), - do ex <- dv_expressionHsM - return () - return (id cons ex empty)] -p_expressionHs = msum [do e <- dv_expressionM - return () - _ <- dv_spacesM - return () - xx51_56 <- dvCharsM - if id isOpenWave xx51_56 - then return () - else throwError (strMsg "not match") - case xx51_56 of - _ -> return () - let _ = xx51_56 - return () - _ <- dv_spacesM - return () - h <- dv_hsExpM - return () - _ <- dv_spacesM - return () - xx52_57 <- dvCharsM - if id isCloseWave xx52_57 - then return () - else throwError (strMsg "not match") - case xx52_57 of - _ -> return () - let _ = xx52_57 - return () - return (id mkExpressionHs e h)] -p_expression = msum [do l <- dv_nameLeaf_M - return () - _ <- dv_spacesM - return () - e <- dv_expressionM - return () - return (id cons l e), - do return (id empty)] -p_nameLeaf_ = msum [do xx53_58 <- dvCharsM - if id isNot xx53_58 - then return () - else throwError (strMsg "not match") - case xx53_58 of - _ -> return () - let _ = xx53_58 - return () - nl <- dv_nameLeafM - return () - return (id notAfter nl), - do nl <- dv_nameLeafM - return () - return (id here nl)] -p_nameLeaf = msum [do n <- dv_patM - return () - xx54_59 <- dvCharsM - if id isColon xx54_59 - then return () - else throwError (strMsg "not match") - case xx54_59 of - _ -> return () - let _ = xx54_59 - return () - l <- dv_leafM - return () - return (id mkNameLeaf n l), - do n <- dv_patM - return () - return (id mkNameLeaf n ctLeaf)] -p_pat = msum [do xx55_60 <- dv_variableM - case xx55_60 of - "_" -> return () - _ -> throwError (strMsg "not match") - "_" <- return xx55_60 - return (id wildP), - do n <- dv_variableM - return () - return (id strToPatQ n), - do t <- dv_typM - return () - _ <- dv_spacesM - return () - ps <- dv_patsM - return () - return (id conToPatQ t ps), - do xx56_61 <- dvCharsM - if id isChon xx56_61 - then return () - else throwError (strMsg "not match") - case xx56_61 of - _ -> return () - let _ = xx56_61 - return () - c <- dv_charLitM - return () - xx57_62 <- dvCharsM - if id isChon xx57_62 - then return () - else throwError (strMsg "not match") - case xx57_62 of - _ -> return () - let _ = xx57_62 - return () - return (id charP c), - do xx58_63 <- dvCharsM - if id isDQ xx58_63 - then return () - else throwError (strMsg "not match") - case xx58_63 of - _ -> return () - let _ = xx58_63 - return () - s <- dv_stringLitM - return () - xx59_64 <- dvCharsM - if id isDQ xx59_64 - then return () - else throwError (strMsg "not match") - case xx59_64 of - _ -> return () - let _ = xx59_64 - return () - return (id stringP s)] -p_charLit = msum [do xx60_65 <- dvCharsM - if id isAlphaNumOt xx60_65 - then return () - else throwError (strMsg "not match") - case xx60_65 of - _ -> return () - let c = xx60_65 - return () - return (id c), - do xx61_66 <- dvCharsM - if id isBS xx61_66 - then return () - else throwError (strMsg "not match") - case xx61_66 of - _ -> return () - let _ = xx61_66 - return () - xx62_67 <- dvCharsM - if id elemNTs xx62_67 - then return () - else throwError (strMsg "not match") - case xx62_67 of - _ -> return () - let c = xx62_67 - return () - return (id getNTs c)] -p_stringLit = msum [do d_68 <- get - flipMaybe (do _ <- dv_dqM - return ()) - put d_68 - xx63_69 <- dvCharsM - if const True xx63_69 - then return () - else throwError (strMsg "not match") - case xx63_69 of - _ -> return () - let c = xx63_69 - return () - s <- dv_stringLitM - return () - return (id cons c s), - do return (id empty)] -p_dq = msum [do xx64_70 <- dvCharsM - if const True xx64_70 - then return () - else throwError (strMsg "not match") - case xx64_70 of - '"' -> return () - _ -> throwError (strMsg "not match") - let '"' = xx64_70 - return () - return (id nil)] -p_pats = msum [do p <- dv_patM - return () - ps <- dv_patsM - return () - return (id cons p ps), - do return (id empty)] -p_leaf = msum [do t <- dv_testM - return () - return (id left t), - do v <- dv_variableM - return () - return (id right v)] -p_test = msum [do xx65_71 <- dvCharsM - if id isOpenBr xx65_71 - then return () - else throwError (strMsg "not match") - case xx65_71 of - _ -> return () - let _ = xx65_71 - return () - h <- dv_hsExpM - return () - xx66_72 <- dvCharsM - if id isCloseBr xx66_72 - then return () - else throwError (strMsg "not match") - case xx66_72 of - _ -> return () - let _ = xx66_72 - return () - return (id getEx h)] -p_hsExp = msum [do v <- dv_variableM - return () - _ <- dv_spacesM - return () - h <- dv_hsExpM - return () - return (id apply v h), - do v <- dv_variableM - return () - return (id toExp v)] -p_typ = msum [do u <- dv_upperM - return () - t <- dv_tvtailM - return () - return (id cons u t)] -p_variable = msum [do l <- dv_lowerM - return () - t <- dv_tvtailM - return () - return (id cons l t)] -p_tvtail = msum [do a <- dv_alphaM - return () - t <- dv_tvtailM - return () - return (id cons a t), - do return (id empty)] -p_alpha = msum [do u <- dv_upperM - return () - return (id u), - do l <- dv_lowerM - return () - return (id l), - do d <- dv_digitM - return () - return (id d)] -p_upper = msum [do xx67_73 <- dvCharsM - if id isUpper xx67_73 - then return () - else throwError (strMsg "not match") - case xx67_73 of - _ -> return () - let u = xx67_73 - return () - return (id u)] -p_lower = msum [do xx68_74 <- dvCharsM - if id isLowerU xx68_74 - then return () - else throwError (strMsg "not match") - case xx68_74 of - _ -> return () - let l = xx68_74 - return () - return (id l)] -p_digit = msum [do xx69_75 <- dvCharsM - if id isDigit xx69_75 - then return () - else throwError (strMsg "not match") - case xx69_75 of - _ -> return () - let d = xx69_75 - return () - return (id d)] -p_spaces = msum [do _ <- dv_spaceM - return () - _ <- dv_spacesM - return () - return (id nil), - do return (id nil)] -p_space = msum [do xx70_76 <- dvCharsM - if id isSpace xx70_76 - then return () - else throwError (strMsg "not match") - case xx70_76 of - _ -> return () - let _ = xx70_76 - return () - return (id nil), - do xx71_77 <- dvCharsM - if const True xx71_77 - then return () - else throwError (strMsg "not match") - case xx71_77 of - '-' -> return () - _ -> throwError (strMsg "not match") - let '-' = xx71_77 - return () - xx72_78 <- dvCharsM - if const True xx72_78 - then return () - else throwError (strMsg "not match") - case xx72_78 of - '-' -> return () - _ -> throwError (strMsg "not match") - let '-' = xx72_78 - return () - _ <- dv_notNLStringM - return () - _ <- dv_nlM - return () - return (id nil), - do _ <- dv_commentM - return () - return (id nil)] -p_notNLString = msum [do d_79 <- get - flipMaybe (do _ <- dv_nlM - return ()) - put d_79 - xx73_80 <- dvCharsM - if const True xx73_80 - then return () - else throwError (strMsg "not match") - case xx73_80 of - _ -> return () - let c = xx73_80 - return () - s <- dv_notNLStringM - return () - return (id cons c s), - do return (id empty)] -p_nl = msum [do xx74_81 <- dvCharsM - if id isNL xx74_81 - then return () - else throwError (strMsg "not match") - case xx74_81 of - _ -> return () - let _ = xx74_81 - return () - return (id nil)] -p_comment = msum [do xx75_82 <- dvCharsM - if const True xx75_82 - then return () - else throwError (strMsg "not match") - case xx75_82 of - '{' -> return () - _ -> throwError (strMsg "not match") - let '{' = xx75_82 - return () - xx76_83 <- dvCharsM - if const True xx76_83 - then return () - else throwError (strMsg "not match") - case xx76_83 of - '-' -> return () - _ -> throwError (strMsg "not match") - let '-' = xx76_83 - return () - d_84 <- get - flipMaybe (do xx77_85 <- dvCharsM - if const True xx77_85 - then return () - else throwError (strMsg "not match") - case xx77_85 of - '#' -> return () - _ -> throwError (strMsg "not match") - let '#' = xx77_85 - return ()) - put d_84 - _ <- dv_commentsM - return () - _ <- dv_comEndM - return () - return (id nil)] -p_comments = msum [do _ <- dv_notComStrM - return () - _ <- dv_commentM - return () - _ <- dv_commentsM - return () - return (id nil), - do _ <- dv_notComStrM - return () - return (id nil)] -p_notComStr = msum [do d_86 <- get - flipMaybe (do _ <- dv_commentM - return ()) - put d_86 - d_87 <- get - flipMaybe (do _ <- dv_comEndM - return ()) - put d_87 - xx78_88 <- dvCharsM - if const True xx78_88 - then return () - else throwError (strMsg "not match") - case xx78_88 of - _ -> return () - let _ = xx78_88 - return () - _ <- dv_notComStrM - return () - return (id nil), - do return (id nil)] -p_comEnd = msum [do xx79_89 <- dvCharsM - if const True xx79_89 - then return () - else throwError (strMsg "not match") - case xx79_89 of - '-' -> return () - _ -> throwError (strMsg "not match") - let '-' = xx79_89 - return () - xx80_90 <- dvCharsM - if const True xx80_90 - then return () - else throwError (strMsg "not match") - case xx80_90 of - '}' -> return () - _ -> throwError (strMsg "not match") - let '}' = xx80_90 - return () - return (id nil)] - -class Source sl - where type Token sl - getToken :: sl -> Maybe ((Token sl, sl)) -class SourceList c - where listToken :: [c] -> Maybe ((c, [c])) -instance SourceList Char - where listToken (c : s) = Just (c, s) - listToken _ = Nothing -instance SourceList c => Source ([c]) - where type Token ([c]) = c - getToken = listToken +{-# LANGUAGE FlexibleContexts, TemplateHaskell, UndecidableInstances, PackageImports, TypeFamilies, RankNTypes #-} +module Text.Papillon.Parser ( + Peg, + Definition, + Selection, + ExpressionHs, + NameLeaf(..), + NameLeaf_(..), + ReadFrom(..), + parse, + showNameLeaf, + nameFromRF, + ParseError(..), + Derivs(peg, pegFile, derivsChars), + Pos(..), + ListPos(..), + pePositionS, + Source(..), + SourceList(..), + + PPragma(..), + ModuleName +) where +import "monads-tf" Control.Monad.State +import "monads-tf" Control.Monad.Error + +import Text.Papillon.Papillon + +import Control.Applicative + + + +import Data.Char +import Language.Haskell.TH +import Text.Papillon.SyntaxTree + +data Derivs + = Derivs {pegFile :: (Either (ParseError (Pos String) Derivs) + ((PegFile, Derivs))), + pragmas :: (Either (ParseError (Pos String) Derivs) + (([PPragma], Derivs))), + pragma :: (Either (ParseError (Pos String) Derivs) + ((PPragma, Derivs))), + pragmaStr2 :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + pragmaItems :: (Either (ParseError (Pos String) Derivs) + (([String], Derivs))), + pragmaEnd :: (Either (ParseError (Pos String) Derivs) + (((), Derivs))), + moduleDec :: (Either (ParseError (Pos String) Derivs) + ((Maybe (([String], String)), Derivs))), + moduleName :: (Either (ParseError (Pos String) Derivs) + (([String], Derivs))), + moduleDecStr :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + whr :: (Either (ParseError (Pos String) Derivs) (((), Derivs))), + preImpPap :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + prePeg :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + afterPeg :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + importPapillon :: (Either (ParseError (Pos String) Derivs) + (((), Derivs))), + varToken :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + typToken :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + pap :: (Either (ParseError (Pos String) Derivs) (((), Derivs))), + peg :: (Either (ParseError (Pos String) Derivs) ((TTPeg, Derivs))), + sourceType :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + peg_ :: (Either (ParseError (Pos String) Derivs) ((Peg, Derivs))), + definition :: (Either (ParseError (Pos String) Derivs) + ((Definition, Derivs))), + selection :: (Either (ParseError (Pos String) Derivs) + ((Selection, Derivs))), + expressionHs :: (Either (ParseError (Pos String) Derivs) + ((ExpressionHs, Derivs))), + expression :: (Either (ParseError (Pos String) Derivs) + ((Expression, Derivs))), + nameLeaf_ :: (Either (ParseError (Pos String) Derivs) + ((NameLeaf_, Derivs))), + nameLeaf :: (Either (ParseError (Pos String) Derivs) + ((NameLeaf, Derivs))), + nameLeafNoCom :: (Either (ParseError (Pos String) Derivs) + ((NameLeaf, Derivs))), + comForErr :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + leaf :: (Either (ParseError (Pos String) Derivs) + (((ReadFrom, Maybe ((ExpQ, String))), Derivs))), + patOp :: (Either (ParseError (Pos String) Derivs) + ((PatQ, Derivs))), + pat :: (Either (ParseError (Pos String) Derivs) ((PatQ, Derivs))), + pat1 :: (Either (ParseError (Pos String) Derivs) ((PatQ, Derivs))), + patList :: (Either (ParseError (Pos String) Derivs) + (([PatQ], Derivs))), + opConName :: (Either (ParseError (Pos String) Derivs) + ((Name, Derivs))), + charLit :: (Either (ParseError (Pos String) Derivs) + ((Char, Derivs))), + stringLit :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + escapeC :: (Either (ParseError (Pos String) Derivs) + ((Char, Derivs))), + pats :: (Either (ParseError (Pos String) Derivs) + ((PatQs, Derivs))), + readFromLs :: (Either (ParseError (Pos String) Derivs) + ((ReadFrom, Derivs))), + readFrom :: (Either (ParseError (Pos String) Derivs) + ((ReadFrom, Derivs))), + test :: (Either (ParseError (Pos String) Derivs) + (((ExR, String), Derivs))), + hsExpLam :: (Either (ParseError (Pos String) Derivs) + ((ExR, Derivs))), + hsExpTyp :: (Either (ParseError (Pos String) Derivs) + ((ExR, Derivs))), + hsExpOp :: (Either (ParseError (Pos String) Derivs) + ((ExR, Derivs))), + hsOp :: (Either (ParseError (Pos String) Derivs) ((ExR, Derivs))), + opTail :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + hsExp :: (Either (ParseError (Pos String) Derivs) ((Ex, Derivs))), + hsExp1 :: (Either (ParseError (Pos String) Derivs) + ((ExR, Derivs))), + hsExpTpl :: (Either (ParseError (Pos String) Derivs) + ((ExRL, Derivs))), + hsTypeArr :: (Either (ParseError (Pos String) Derivs) + ((TypeQ, Derivs))), + hsType :: (Either (ParseError (Pos String) Derivs) + ((Typ, Derivs))), + hsType1 :: (Either (ParseError (Pos String) Derivs) + ((TypeQ, Derivs))), + hsTypeTpl :: (Either (ParseError (Pos String) Derivs) + ((TypeQL, Derivs))), + typ :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + variable :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + tvtail :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + integer :: (Either (ParseError (Pos String) Derivs) + ((Integer, Derivs))), + alpha :: (Either (ParseError (Pos String) Derivs) + ((Char, Derivs))), + upper :: (Either (ParseError (Pos String) Derivs) + ((Char, Derivs))), + lower :: (Either (ParseError (Pos String) Derivs) + ((Char, Derivs))), + digit :: (Either (ParseError (Pos String) Derivs) + ((Char, Derivs))), + spaces :: (Either (ParseError (Pos String) Derivs) (((), Derivs))), + space :: (Either (ParseError (Pos String) Derivs) (((), Derivs))), + notNLString :: (Either (ParseError (Pos String) Derivs) + ((String, Derivs))), + newLine :: (Either (ParseError (Pos String) Derivs) + (((), Derivs))), + comment :: (Either (ParseError (Pos String) Derivs) + (((), Derivs))), + comments :: (Either (ParseError (Pos String) Derivs) + (((), Derivs))), + notComStr :: (Either (ParseError (Pos String) Derivs) + (((), Derivs))), + comEnd :: (Either (ParseError (Pos String) Derivs) (((), Derivs))), + derivsChars :: (Either (ParseError (Pos String) Derivs) + ((Token String, Derivs))), + derivsPosition :: (Pos String)} +parse :: String -> Derivs +parse = parse0_0 initialPos + where parse0_0 pos s = d + where d = Derivs pegFile73_1 pragmas74_2 pragma75_3 pragmaStr276_4 pragmaItems77_5 pragmaEnd78_6 moduleDec79_7 moduleName80_8 moduleDecStr81_9 whr82_10 preImpPap83_11 prePeg84_12 afterPeg85_13 importPapillon86_14 varToken87_15 typToken88_16 pap89_17 peg90_18 sourceType91_19 peg_92_20 definition93_21 selection94_22 expressionHs95_23 expression96_24 nameLeaf_97_25 nameLeaf98_26 nameLeafNoCom99_27 comForErr100_28 leaf101_29 patOp102_30 pat103_31 pat1104_32 patList105_33 opConName106_34 charLit107_35 stringLit108_36 escapeC109_37 pats110_38 readFromLs111_39 readFrom112_40 test113_41 hsExpLam114_42 hsExpTyp115_43 hsExpOp116_44 hsOp117_45 opTail118_46 hsExp119_47 hsExp1120_48 hsExpTpl121_49 hsTypeArr122_50 hsType123_51 hsType1124_52 hsTypeTpl125_53 typ126_54 variable127_55 tvtail128_56 integer129_57 alpha130_58 upper131_59 lower132_60 digit133_61 spaces134_62 space135_63 notNLString136_64 newLine137_65 comment138_66 comments139_67 notComStr140_68 comEnd141_69 chars142_70 pos + pegFile73_1 = runStateT pegFile4_71 d + pragmas74_2 = runStateT pragmas5_72 d + pragma75_3 = runStateT pragma6_73 d + pragmaStr276_4 = runStateT pragmaStr27_74 d + pragmaItems77_5 = runStateT pragmaItems8_75 d + pragmaEnd78_6 = runStateT pragmaEnd9_76 d + moduleDec79_7 = runStateT moduleDec10_77 d + moduleName80_8 = runStateT moduleName11_78 d + moduleDecStr81_9 = runStateT moduleDecStr12_79 d + whr82_10 = runStateT whr13_80 d + preImpPap83_11 = runStateT preImpPap14_81 d + prePeg84_12 = runStateT prePeg15_82 d + afterPeg85_13 = runStateT afterPeg16_83 d + importPapillon86_14 = runStateT importPapillon17_84 d + varToken87_15 = runStateT varToken18_85 d + typToken88_16 = runStateT typToken19_86 d + pap89_17 = runStateT pap20_87 d + peg90_18 = runStateT peg21_88 d + sourceType91_19 = runStateT sourceType22_89 d + peg_92_20 = runStateT peg_23_90 d + definition93_21 = runStateT definition24_91 d + selection94_22 = runStateT selection25_92 d + expressionHs95_23 = runStateT expressionHs26_93 d + expression96_24 = runStateT expression27_94 d + nameLeaf_97_25 = runStateT nameLeaf_28_95 d + nameLeaf98_26 = runStateT nameLeaf29_96 d + nameLeafNoCom99_27 = runStateT nameLeafNoCom30_97 d + comForErr100_28 = runStateT comForErr31_98 d + leaf101_29 = runStateT leaf32_99 d + patOp102_30 = runStateT patOp33_100 d + pat103_31 = runStateT pat34_101 d + pat1104_32 = runStateT pat135_102 d + patList105_33 = runStateT patList36_103 d + opConName106_34 = runStateT opConName37_104 d + charLit107_35 = runStateT charLit38_105 d + stringLit108_36 = runStateT stringLit39_106 d + escapeC109_37 = runStateT escapeC40_107 d + pats110_38 = runStateT pats41_108 d + readFromLs111_39 = runStateT readFromLs42_109 d + readFrom112_40 = runStateT readFrom43_110 d + test113_41 = runStateT test44_111 d + hsExpLam114_42 = runStateT hsExpLam45_112 d + hsExpTyp115_43 = runStateT hsExpTyp46_113 d + hsExpOp116_44 = runStateT hsExpOp47_114 d + hsOp117_45 = runStateT hsOp48_115 d + opTail118_46 = runStateT opTail49_116 d + hsExp119_47 = runStateT hsExp50_117 d + hsExp1120_48 = runStateT hsExp151_118 d + hsExpTpl121_49 = runStateT hsExpTpl52_119 d + hsTypeArr122_50 = runStateT hsTypeArr53_120 d + hsType123_51 = runStateT hsType54_121 d + hsType1124_52 = runStateT hsType155_122 d + hsTypeTpl125_53 = runStateT hsTypeTpl56_123 d + typ126_54 = runStateT typ57_124 d + variable127_55 = runStateT variable58_125 d + tvtail128_56 = runStateT tvtail59_126 d + integer129_57 = runStateT integer60_127 d + alpha130_58 = runStateT alpha61_128 d + upper131_59 = runStateT upper62_129 d + lower132_60 = runStateT lower63_130 d + digit133_61 = runStateT digit64_131 d + spaces134_62 = runStateT spaces65_132 d + space135_63 = runStateT space66_133 d + notNLString136_64 = runStateT notNLString67_134 d + newLine137_65 = runStateT newLine68_135 d + comment138_66 = runStateT comment69_136 d + comments139_67 = runStateT comments70_137 d + notComStr140_68 = runStateT notComStr71_138 d + comEnd141_69 = runStateT comEnd72_139 d + chars142_70 = runStateT (case getToken s of + Just (c, + s') -> do put (parse0_0 (updatePos c pos) s') + return c + _ -> gets derivsPosition >>= (throwError . ParseError "" "end of input" "" undefined [])) d + pegFile4_71 = foldl1 mplus [do pr <- StateT pragmas + md <- StateT moduleDec + pip <- StateT preImpPap + _ <- StateT importPapillon + return () + pp <- StateT prePeg + _ <- StateT pap + return () + p <- StateT peg + _ <- StateT spaces + return () + d160_140 <- get + xx159_141 <- StateT derivsChars + case xx159_141 of + '|' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'|'" "not match pattern: " "" d160_140 ["derivsChars"]) + let '|' = xx159_141 + return () + d162_142 <- get + xx161_143 <- StateT derivsChars + case xx161_143 of + ']' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "']'" "not match pattern: " "" d162_142 ["derivsChars"]) + let ']' = xx161_143 + return () + d164_144 <- get + xx163_145 <- StateT derivsChars + case xx163_145 of + '\n' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\n'" "not match pattern: " "" d164_144 ["derivsChars"]) + let '\n' = xx163_145 + return () + atp <- StateT afterPeg + return (mkPegFile pr md pip pp p atp), + do pr <- StateT pragmas + md <- StateT moduleDec + pp <- StateT prePeg + _ <- StateT pap + return () + p <- StateT peg + _ <- StateT spaces + return () + d180_146 <- get + xx179_147 <- StateT derivsChars + case xx179_147 of + '|' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'|'" "not match pattern: " "" d180_146 ["derivsChars"]) + let '|' = xx179_147 + return () + d182_148 <- get + xx181_149 <- StateT derivsChars + case xx181_149 of + ']' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "']'" "not match pattern: " "" d182_148 ["derivsChars"]) + let ']' = xx181_149 + return () + d184_150 <- get + xx183_151 <- StateT derivsChars + case xx183_151 of + '\n' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\n'" "not match pattern: " "" d184_150 ["derivsChars"]) + let '\n' = xx183_151 + return () + atp <- StateT afterPeg + return (mkPegFile pr md emp pp p atp)] + pragmas5_72 = foldl1 mplus [do _ <- StateT spaces + return () + pr <- StateT pragma + prs <- StateT pragmas + return (pr : prs), + do _ <- StateT spaces + return () + return []] + pragma6_73 = foldl1 mplus [do d196_152 <- get + xx195_153 <- StateT derivsChars + case xx195_153 of + '{' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'{'" "not match pattern: " "" d196_152 ["derivsChars"]) + let '{' = xx195_153 + return () + d198_154 <- get + xx197_155 <- StateT derivsChars + case xx197_155 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d198_154 ["derivsChars"]) + let '-' = xx197_155 + return () + d200_156 <- get + xx199_157 <- StateT derivsChars + case xx199_157 of + '#' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'#'" "not match pattern: " "" d200_156 ["derivsChars"]) + let '#' = xx199_157 + return () + _ <- StateT spaces + return () + d204_158 <- get + xx203_159 <- StateT derivsChars + case xx203_159 of + 'L' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'L'" "not match pattern: " "" d204_158 ["derivsChars"]) + let 'L' = xx203_159 + return () + d206_160 <- get + xx205_161 <- StateT derivsChars + case xx205_161 of + 'A' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'A'" "not match pattern: " "" d206_160 ["derivsChars"]) + let 'A' = xx205_161 + return () + d208_162 <- get + xx207_163 <- StateT derivsChars + case xx207_163 of + 'N' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'N'" "not match pattern: " "" d208_162 ["derivsChars"]) + let 'N' = xx207_163 + return () + d210_164 <- get + xx209_165 <- StateT derivsChars + case xx209_165 of + 'G' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'G'" "not match pattern: " "" d210_164 ["derivsChars"]) + let 'G' = xx209_165 + return () + d212_166 <- get + xx211_167 <- StateT derivsChars + case xx211_167 of + 'U' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'U'" "not match pattern: " "" d212_166 ["derivsChars"]) + let 'U' = xx211_167 + return () + d214_168 <- get + xx213_169 <- StateT derivsChars + case xx213_169 of + 'A' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'A'" "not match pattern: " "" d214_168 ["derivsChars"]) + let 'A' = xx213_169 + return () + d216_170 <- get + xx215_171 <- StateT derivsChars + case xx215_171 of + 'G' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'G'" "not match pattern: " "" d216_170 ["derivsChars"]) + let 'G' = xx215_171 + return () + d218_172 <- get + xx217_173 <- StateT derivsChars + case xx217_173 of + 'E' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'E'" "not match pattern: " "" d218_172 ["derivsChars"]) + let 'E' = xx217_173 + return () + _ <- StateT spaces + return () + s <- StateT pragmaItems + _ <- StateT pragmaEnd + return () + _ <- StateT spaces + return () + return (LanguagePragma s), + do d228_174 <- get + xx227_175 <- StateT derivsChars + case xx227_175 of + '{' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'{'" "not match pattern: " "" d228_174 ["derivsChars"]) + let '{' = xx227_175 + return () + d230_176 <- get + xx229_177 <- StateT derivsChars + case xx229_177 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d230_176 ["derivsChars"]) + let '-' = xx229_177 + return () + d232_178 <- get + xx231_179 <- StateT derivsChars + case xx231_179 of + '#' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'#'" "not match pattern: " "" d232_178 ["derivsChars"]) + let '#' = xx231_179 + return () + _ <- StateT spaces + return () + s <- StateT pragmaStr2 + _ <- StateT pragmaEnd + return () + return (OtherPragma s)] + pragmaStr27_74 = foldl1 mplus [do ddd239_180 <- get + do err <- ((do _ <- StateT pragmaEnd + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "_:pragmaEnd") "not match: " "" ddd239_180 ["pragmaEnd"])) + put ddd239_180 + c <- StateT derivsChars + s <- StateT pragmaStr2 + return (c : s), + return ""] + pragmaItems8_75 = foldl1 mplus [do t <- StateT typToken + d249_181 <- get + xx248_182 <- StateT derivsChars + case xx248_182 of + ',' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "','" "not match pattern: " "" d249_181 ["derivsChars"]) + let ',' = xx248_182 + return () + _ <- StateT spaces + return () + i <- StateT pragmaItems + return (t : i), + do t <- StateT typToken + return [t]] + pragmaEnd9_76 = foldl1 mplus [do _ <- StateT spaces + return () + d259_183 <- get + xx258_184 <- StateT derivsChars + case xx258_184 of + '#' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'#'" "not match pattern: " "" d259_183 ["derivsChars"]) + let '#' = xx258_184 + return () + d261_185 <- get + xx260_186 <- StateT derivsChars + case xx260_186 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d261_185 ["derivsChars"]) + let '-' = xx260_186 + return () + d263_187 <- get + xx262_188 <- StateT derivsChars + case xx262_188 of + '}' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'}'" "not match pattern: " "" d263_187 ["derivsChars"]) + let '}' = xx262_188 + return () + return ()] + moduleDec10_77 = foldl1 mplus [do d265_189 <- get + xx264_190 <- StateT derivsChars + case xx264_190 of + 'm' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'m'" "not match pattern: " "" d265_189 ["derivsChars"]) + let 'm' = xx264_190 + return () + d267_191 <- get + xx266_192 <- StateT derivsChars + case xx266_192 of + 'o' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'o'" "not match pattern: " "" d267_191 ["derivsChars"]) + let 'o' = xx266_192 + return () + d269_193 <- get + xx268_194 <- StateT derivsChars + case xx268_194 of + 'd' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'d'" "not match pattern: " "" d269_193 ["derivsChars"]) + let 'd' = xx268_194 + return () + d271_195 <- get + xx270_196 <- StateT derivsChars + case xx270_196 of + 'u' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'u'" "not match pattern: " "" d271_195 ["derivsChars"]) + let 'u' = xx270_196 + return () + d273_197 <- get + xx272_198 <- StateT derivsChars + case xx272_198 of + 'l' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'l'" "not match pattern: " "" d273_197 ["derivsChars"]) + let 'l' = xx272_198 + return () + d275_199 <- get + xx274_200 <- StateT derivsChars + case xx274_200 of + 'e' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'e'" "not match pattern: " "" d275_199 ["derivsChars"]) + let 'e' = xx274_200 + return () + _ <- StateT spaces + return () + n <- StateT moduleName + s <- StateT moduleDecStr + _ <- StateT whr + return () + return (Just (n, s)), + return Nothing] + moduleName11_78 = foldl1 mplus [do t <- StateT typ + d287_201 <- get + xx286_202 <- StateT derivsChars + case xx286_202 of + '.' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'.'" "not match pattern: " "" d287_201 ["derivsChars"]) + let '.' = xx286_202 + return () + n <- StateT moduleName + return (t : n), + do t <- StateT typ + return [t]] + moduleDecStr12_79 = foldl1 mplus [do ddd292_203 <- get + do err <- ((do _ <- StateT whr + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "_:whr") "not match: " "" ddd292_203 ["whr"])) + put ddd292_203 + c <- StateT derivsChars + s <- StateT moduleDecStr + return (c : s), + return ""] + whr13_80 = foldl1 mplus [do d300_204 <- get + xx299_205 <- StateT derivsChars + case xx299_205 of + 'w' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'w'" "not match pattern: " "" d300_204 ["derivsChars"]) + let 'w' = xx299_205 + return () + d302_206 <- get + xx301_207 <- StateT derivsChars + case xx301_207 of + 'h' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'h'" "not match pattern: " "" d302_206 ["derivsChars"]) + let 'h' = xx301_207 + return () + d304_208 <- get + xx303_209 <- StateT derivsChars + case xx303_209 of + 'e' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'e'" "not match pattern: " "" d304_208 ["derivsChars"]) + let 'e' = xx303_209 + return () + d306_210 <- get + xx305_211 <- StateT derivsChars + case xx305_211 of + 'r' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'r'" "not match pattern: " "" d306_210 ["derivsChars"]) + let 'r' = xx305_211 + return () + d308_212 <- get + xx307_213 <- StateT derivsChars + case xx307_213 of + 'e' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'e'" "not match pattern: " "" d308_212 ["derivsChars"]) + let 'e' = xx307_213 + return () + return ()] + preImpPap14_81 = foldl1 mplus [do ddd309_214 <- get + do err <- ((do _ <- StateT importPapillon + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "_:importPapillon") "not match: " "" ddd309_214 ["importPapillon"])) + put ddd309_214 + ddd312_215 <- get + do err <- ((do _ <- StateT pap + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "_:pap") "not match: " "" ddd312_215 ["pap"])) + put ddd312_215 + c <- StateT derivsChars + pip <- StateT preImpPap + return (cons c pip), + return emp] + prePeg15_82 = foldl1 mplus [do ddd319_216 <- get + do err <- ((do _ <- StateT pap + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "_:pap") "not match: " "" ddd319_216 ["pap"])) + put ddd319_216 + c <- StateT derivsChars + pp <- StateT prePeg + return (cons c pp), + return emp] + afterPeg16_83 = foldl1 mplus [do c <- StateT derivsChars + atp <- StateT afterPeg + return (cons c atp), + return emp] + importPapillon17_84 = foldl1 mplus [do d331_217 <- get + xx330_218 <- StateT varToken + case xx330_218 of + "import" -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "\"import\"" "not match pattern: " "" d331_217 ["varToken"]) + let "import" = xx330_218 + return () + d333_219 <- get + xx332_220 <- StateT typToken + case xx332_220 of + "Text" -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "\"Text\"" "not match pattern: " "" d333_219 ["typToken"]) + let "Text" = xx332_220 + return () + d335_221 <- get + xx334_222 <- StateT derivsChars + case xx334_222 of + '.' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'.'" "not match pattern: " "" d335_221 ["derivsChars"]) + let '.' = xx334_222 + return () + _ <- StateT spaces + return () + d339_223 <- get + xx338_224 <- StateT typToken + case xx338_224 of + "Papillon" -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "\"Papillon\"" "not match pattern: " "" d339_223 ["typToken"]) + let "Papillon" = xx338_224 + return () + ddd340_225 <- get + do err <- ((do d342_226 <- get + xx341_227 <- StateT derivsChars + case xx341_227 of + '.' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'.'" "not match pattern: " "" d342_226 ["derivsChars"]) + let '.' = xx341_227 + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "'.':") "not match: " "" ddd340_225 ["derivsChars"])) + put ddd340_225 + return ()] + varToken18_85 = foldl1 mplus [do v <- StateT variable + _ <- StateT spaces + return () + return v] + typToken19_86 = foldl1 mplus [do t <- StateT typ + _ <- StateT spaces + return () + return t] + pap20_87 = foldl1 mplus [do d352_228 <- get + xx351_229 <- StateT derivsChars + case xx351_229 of + '\n' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\n'" "not match pattern: " "" d352_228 ["derivsChars"]) + let '\n' = xx351_229 + return () + d354_230 <- get + xx353_231 <- StateT derivsChars + case xx353_231 of + '[' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'['" "not match pattern: " "" d354_230 ["derivsChars"]) + let '[' = xx353_231 + return () + d356_232 <- get + xx355_233 <- StateT derivsChars + case xx355_233 of + 'p' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'p'" "not match pattern: " "" d356_232 ["derivsChars"]) + let 'p' = xx355_233 + return () + d358_234 <- get + xx357_235 <- StateT derivsChars + case xx357_235 of + 'a' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'a'" "not match pattern: " "" d358_234 ["derivsChars"]) + let 'a' = xx357_235 + return () + d360_236 <- get + xx359_237 <- StateT derivsChars + case xx359_237 of + 'p' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'p'" "not match pattern: " "" d360_236 ["derivsChars"]) + let 'p' = xx359_237 + return () + d362_238 <- get + xx361_239 <- StateT derivsChars + case xx361_239 of + 'i' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'i'" "not match pattern: " "" d362_238 ["derivsChars"]) + let 'i' = xx361_239 + return () + d364_240 <- get + xx363_241 <- StateT derivsChars + case xx363_241 of + 'l' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'l'" "not match pattern: " "" d364_240 ["derivsChars"]) + let 'l' = xx363_241 + return () + d366_242 <- get + xx365_243 <- StateT derivsChars + case xx365_243 of + 'l' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'l'" "not match pattern: " "" d366_242 ["derivsChars"]) + let 'l' = xx365_243 + return () + d368_244 <- get + xx367_245 <- StateT derivsChars + case xx367_245 of + 'o' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'o'" "not match pattern: " "" d368_244 ["derivsChars"]) + let 'o' = xx367_245 + return () + d370_246 <- get + xx369_247 <- StateT derivsChars + case xx369_247 of + 'n' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'n'" "not match pattern: " "" d370_246 ["derivsChars"]) + let 'n' = xx369_247 + return () + d372_248 <- get + xx371_249 <- StateT derivsChars + case xx371_249 of + '|' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'|'" "not match pattern: " "" d372_248 ["derivsChars"]) + let '|' = xx371_249 + return () + d374_250 <- get + xx373_251 <- StateT derivsChars + case xx373_251 of + '\n' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\n'" "not match pattern: " "" d374_250 ["derivsChars"]) + let '\n' = xx373_251 + return () + return ()] + peg21_88 = foldl1 mplus [do _ <- StateT spaces + return () + s <- StateT sourceType + p <- StateT peg_ + return (mkTTPeg s p), + do p <- StateT peg_ + return (mkTTPeg tString p)] + sourceType22_89 = foldl1 mplus [do d384_252 <- get + xx383_253 <- StateT varToken + case xx383_253 of + "source" -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "\"source\"" "not match pattern: " "" d384_252 ["varToken"]) + let "source" = xx383_253 + return () + d386_254 <- get + xx385_255 <- StateT derivsChars + case xx385_255 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d386_254 ["derivsChars"]) + let ':' = xx385_255 + return () + _ <- StateT spaces + return () + v <- StateT typToken + return v] + peg_23_90 = foldl1 mplus [do _ <- StateT spaces + return () + d <- StateT definition + p <- StateT peg_ + return (cons d p), + return emp] + definition24_91 = foldl1 mplus [do v <- StateT variable + _ <- StateT spaces + return () + d402_256 <- get + xx401_257 <- StateT derivsChars + case xx401_257 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d402_256 ["derivsChars"]) + let ':' = xx401_257 + return () + d404_258 <- get + xx403_259 <- StateT derivsChars + case xx403_259 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d404_258 ["derivsChars"]) + let ':' = xx403_259 + return () + _ <- StateT spaces + return () + t <- StateT hsTypeArr + _ <- StateT spaces + return () + d412_260 <- get + xx411_261 <- StateT derivsChars + case xx411_261 of + '=' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'='" "not match pattern: " "" d412_260 ["derivsChars"]) + let '=' = xx411_261 + return () + _ <- StateT spaces + return () + sel <- StateT selection + _ <- StateT spaces + return () + d420_262 <- get + xx419_263 <- StateT derivsChars + case xx419_263 of + ';' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "';'" "not match pattern: " "" d420_262 ["derivsChars"]) + let ';' = xx419_263 + return () + return (mkDef v t sel)] + selection25_92 = foldl1 mplus [do ex <- StateT expressionHs + _ <- StateT spaces + return () + d426_264 <- get + xx425_265 <- StateT derivsChars + case xx425_265 of + '/' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'/'" "not match pattern: " "" d426_264 ["derivsChars"]) + let '/' = xx425_265 + return () + _ <- StateT spaces + return () + sel <- StateT selection + return (cons ex sel), + do ex <- StateT expressionHs + return (cons ex emp)] + expressionHs26_93 = foldl1 mplus [do e <- StateT expression + _ <- StateT spaces + return () + d438_266 <- get + xx437_267 <- StateT derivsChars + case xx437_267 of + '{' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'{'" "not match pattern: " "" d438_266 ["derivsChars"]) + let '{' = xx437_267 + return () + _ <- StateT spaces + return () + h <- StateT hsExpLam + _ <- StateT spaces + return () + d446_268 <- get + xx445_269 <- StateT derivsChars + case xx445_269 of + '}' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'}'" "not match pattern: " "" d446_268 ["derivsChars"]) + let '}' = xx445_269 + return () + return (mkExpressionHs e h)] + expression27_94 = foldl1 mplus [do l <- StateT nameLeaf_ + _ <- StateT spaces + return () + e <- StateT expression + return (cons l e), + return emp] + nameLeaf_28_95 = foldl1 mplus [do d454_270 <- get + xx453_271 <- StateT derivsChars + case xx453_271 of + '!' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'!'" "not match pattern: " "" d454_270 ["derivsChars"]) + let '!' = xx453_271 + return () + nl <- StateT nameLeafNoCom + _ <- StateT spaces + return () + com <- optional3_272 (StateT comForErr) + return (NotAfter nl $ maybe "" id com), + do d462_273 <- get + xx461_274 <- StateT derivsChars + let c = xx461_274 + unless (isAmp c) (gets derivsPosition >>= (throwError . ParseError "isAmp c" "not match: " "" d462_273 ["derivsChars"])) + nl <- StateT nameLeaf + return (After nl), + do nl <- StateT nameLeaf + return (Here nl)] + nameLeaf29_96 = foldl1 mplus [do n <- StateT pat1 + _ <- StateT spaces + return () + com <- optional3_272 (StateT comForErr) + d474_275 <- get + xx473_276 <- StateT derivsChars + case xx473_276 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d474_275 ["derivsChars"]) + let ':' = xx473_276 + return () + (rf, p) <- StateT leaf + return (NameLeaf (n, maybe "" id com) rf p), + do n <- StateT pat1 + _ <- StateT spaces + return () + com <- optional3_272 (StateT comForErr) + return (NameLeaf (n, + maybe "" id com) FromToken Nothing)] + nameLeafNoCom30_97 = foldl1 mplus [do n <- StateT pat1 + _ <- StateT spaces + return () + com <- optional3_272 (StateT comForErr) + d490_277 <- get + xx489_278 <- StateT derivsChars + case xx489_278 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d490_277 ["derivsChars"]) + let ':' = xx489_278 + return () + (rf, p) <- StateT leaf + return (NameLeaf (n, maybe "" id com) rf p), + do n <- StateT pat1 + _ <- StateT spaces + return () + return (NameLeaf (n, "") FromToken Nothing)] + comForErr31_98 = foldl1 mplus [do d498_279 <- get + xx497_280 <- StateT derivsChars + case xx497_280 of + '{' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'{'" "not match pattern: " "" d498_279 ["derivsChars"]) + let '{' = xx497_280 + return () + d500_281 <- get + xx499_282 <- StateT derivsChars + case xx499_282 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d500_281 ["derivsChars"]) + let '-' = xx499_282 + return () + d502_283 <- get + xx501_284 <- StateT derivsChars + case xx501_284 of + '#' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'#'" "not match pattern: " "" d502_283 ["derivsChars"]) + let '#' = xx501_284 + return () + _ <- StateT spaces + return () + d506_285 <- get + xx505_286 <- StateT derivsChars + case xx505_286 of + '"' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\"'" "not match pattern: " "" d506_285 ["derivsChars"]) + let '"' = xx505_286 + return () + s <- StateT stringLit + d510_287 <- get + xx509_288 <- StateT derivsChars + case xx509_288 of + '"' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\"'" "not match pattern: " "" d510_287 ["derivsChars"]) + let '"' = xx509_288 + return () + _ <- StateT spaces + return () + d514_289 <- get + xx513_290 <- StateT derivsChars + case xx513_290 of + '#' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'#'" "not match pattern: " "" d514_289 ["derivsChars"]) + let '#' = xx513_290 + return () + d516_291 <- get + xx515_292 <- StateT derivsChars + case xx515_292 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d516_291 ["derivsChars"]) + let '-' = xx515_292 + return () + d518_293 <- get + xx517_294 <- StateT derivsChars + case xx517_294 of + '}' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'}'" "not match pattern: " "" d518_293 ["derivsChars"]) + let '}' = xx517_294 + return () + _ <- StateT spaces + return () + return s] + leaf32_99 = foldl1 mplus [do rf <- StateT readFromLs + t <- StateT test + return (rf, Just t), + do rf <- StateT readFromLs + return (rf, Nothing), + do t <- StateT test + return (FromToken, Just t)] + patOp33_100 = foldl1 mplus [do p <- StateT pat + o <- StateT opConName + po <- StateT patOp + return (uInfixP p o po), + do p <- StateT pat + _ <- StateT spaces + return () + d540_295 <- get + xx539_296 <- StateT derivsChars + let q = xx539_296 + unless (isBQ q) (gets derivsPosition >>= (throwError . ParseError "isBQ q" "not match: " "" d540_295 ["derivsChars"])) + t <- StateT typ + d544_297 <- get + xx543_298 <- StateT derivsChars + let q_ = xx543_298 + unless (isBQ q_) (gets derivsPosition >>= (throwError . ParseError "isBQ q_" "not match: " "" d544_297 ["derivsChars"])) + _ <- StateT spaces + return () + po <- StateT patOp + return (uInfixP p (mkName t) po), + do p <- StateT pat + return p] + pat34_101 = foldl1 mplus [do t <- StateT typ + _ <- StateT spaces + return () + ps <- StateT pats + return (conToPatQ t ps), + do d558_299 <- get + xx557_300 <- StateT derivsChars + case xx557_300 of + '(' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'('" "not match pattern: " "" d558_299 ["derivsChars"]) + let '(' = xx557_300 + return () + o <- StateT opConName + d562_301 <- get + xx561_302 <- StateT derivsChars + case xx561_302 of + ')' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "')'" "not match pattern: " "" d562_301 ["derivsChars"]) + let ')' = xx561_302 + return () + _ <- StateT spaces + return () + ps <- StateT pats + return (conP o ps), + do p <- StateT pat1 + return p] + pat135_102 = foldl1 mplus [do t <- StateT typ + return (conToPatQ t emp), + do d572_303 <- get + xx571_304 <- StateT variable + case xx571_304 of + "_" -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "\"_\"" "not match pattern: " "" d572_303 ["variable"]) + let "_" = xx571_304 + return () + return wildP, + do n <- StateT variable + return (strToPatQ n), + do i <- StateT integer + return (litP (integerL i)), + do d578_305 <- get + xx577_306 <- StateT derivsChars + case xx577_306 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d578_305 ["derivsChars"]) + let '-' = xx577_306 + return () + _ <- StateT spaces + return () + i <- StateT integer + return (litP (integerL $ negate i)), + do d584_307 <- get + xx583_308 <- StateT derivsChars + case xx583_308 of + '\'' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\''" "not match pattern: " "" d584_307 ["derivsChars"]) + let '\'' = xx583_308 + return () + c <- StateT charLit + d588_309 <- get + xx587_310 <- StateT derivsChars + case xx587_310 of + '\'' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\''" "not match pattern: " "" d588_309 ["derivsChars"]) + let '\'' = xx587_310 + return () + return (charP c), + do d590_311 <- get + xx589_312 <- StateT derivsChars + case xx589_312 of + '"' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\"'" "not match pattern: " "" d590_311 ["derivsChars"]) + let '"' = xx589_312 + return () + s <- StateT stringLit + d594_313 <- get + xx593_314 <- StateT derivsChars + case xx593_314 of + '"' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\"'" "not match pattern: " "" d594_313 ["derivsChars"]) + let '"' = xx593_314 + return () + return (stringP s), + do d596_315 <- get + xx595_316 <- StateT derivsChars + case xx595_316 of + '(' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'('" "not match pattern: " "" d596_315 ["derivsChars"]) + let '(' = xx595_316 + return () + p <- StateT patList + d600_317 <- get + xx599_318 <- StateT derivsChars + case xx599_318 of + ')' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "')'" "not match pattern: " "" d600_317 ["derivsChars"]) + let ')' = xx599_318 + return () + return (tupP p), + do d602_319 <- get + xx601_320 <- StateT derivsChars + case xx601_320 of + '[' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'['" "not match pattern: " "" d602_319 ["derivsChars"]) + let '[' = xx601_320 + return () + p <- StateT patList + d606_321 <- get + xx605_322 <- StateT derivsChars + case xx605_322 of + ']' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "']'" "not match pattern: " "" d606_321 ["derivsChars"]) + let ']' = xx605_322 + return () + return (listP p)] + patList36_103 = foldl1 mplus [do p <- StateT patOp + _ <- StateT spaces + return () + d612_323 <- get + xx611_324 <- StateT derivsChars + case xx611_324 of + ',' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "','" "not match pattern: " "" d612_323 ["derivsChars"]) + let ',' = xx611_324 + return () + _ <- StateT spaces + return () + ps <- StateT patList + return (p : ps), + do p <- StateT patOp + return [p], + return []] + opConName37_104 = foldl1 mplus [do d620_325 <- get + xx619_326 <- StateT derivsChars + case xx619_326 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d620_325 ["derivsChars"]) + let ':' = xx619_326 + return () + ot <- StateT opTail + return (mkName $ colon : ot)] + charLit38_105 = foldl1 mplus [do d624_327 <- get + xx623_328 <- StateT derivsChars + let c = xx623_328 + unless (isAlphaNumOt c) (gets derivsPosition >>= (throwError . ParseError "isAlphaNumOt c" "not match: " "" d624_327 ["derivsChars"])) + return c, + do d626_329 <- get + xx625_330 <- StateT derivsChars + case xx625_330 of + '\\' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\\\'" "not match pattern: " "" d626_329 ["derivsChars"]) + let '\\' = xx625_330 + return () + c <- StateT escapeC + return c] + stringLit39_106 = foldl1 mplus [do d630_331 <- get + xx629_332 <- StateT derivsChars + let c = xx629_332 + unless (isStrLitC c) (gets derivsPosition >>= (throwError . ParseError "isStrLitC c" "not match: " "" d630_331 ["derivsChars"])) + s <- StateT stringLit + return (cons c s), + do d634_333 <- get + xx633_334 <- StateT derivsChars + case xx633_334 of + '\\' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\\\'" "not match pattern: " "" d634_333 ["derivsChars"]) + let '\\' = xx633_334 + return () + c <- StateT escapeC + s <- StateT stringLit + return (c : s), + return emp] + escapeC40_107 = foldl1 mplus [do d640_335 <- get + xx639_336 <- StateT derivsChars + case xx639_336 of + '"' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\"'" "not match pattern: " "" d640_335 ["derivsChars"]) + let '"' = xx639_336 + return () + return '"', + do d642_337 <- get + xx641_338 <- StateT derivsChars + case xx641_338 of + '\'' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\''" "not match pattern: " "" d642_337 ["derivsChars"]) + let '\'' = xx641_338 + return () + return '\'', + do d644_339 <- get + xx643_340 <- StateT derivsChars + case xx643_340 of + '\\' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\\\'" "not match pattern: " "" d644_339 ["derivsChars"]) + let '\\' = xx643_340 + return () + return '\\', + do d646_341 <- get + xx645_342 <- StateT derivsChars + case xx645_342 of + 'n' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'n'" "not match pattern: " "" d646_341 ["derivsChars"]) + let 'n' = xx645_342 + return () + return '\n', + do d648_343 <- get + xx647_344 <- StateT derivsChars + case xx647_344 of + 't' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'t'" "not match pattern: " "" d648_343 ["derivsChars"]) + let 't' = xx647_344 + return () + return tab] + pats41_108 = foldl1 mplus [do p <- StateT pat + _ <- StateT spaces + return () + ps <- StateT pats + return (cons p ps), + return emp] + readFromLs42_109 = foldl1 mplus [do rf <- StateT readFrom + d658_345 <- get + xx657_346 <- StateT derivsChars + case xx657_346 of + '*' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'*'" "not match pattern: " "" d658_345 ["derivsChars"]) + let '*' = xx657_346 + return () + return (FromList rf), + do rf <- StateT readFrom + d662_347 <- get + xx661_348 <- StateT derivsChars + case xx661_348 of + '+' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'+'" "not match pattern: " "" d662_347 ["derivsChars"]) + let '+' = xx661_348 + return () + return (FromList1 rf), + do rf <- StateT readFrom + d666_349 <- get + xx665_350 <- StateT derivsChars + case xx665_350 of + '?' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'?'" "not match pattern: " "" d666_349 ["derivsChars"]) + let '?' = xx665_350 + return () + return (FromOptional rf), + do rf <- StateT readFrom + return rf] + readFrom43_110 = foldl1 mplus [do v <- StateT variable + return (FromVariable v), + do d672_351 <- get + xx671_352 <- StateT derivsChars + case xx671_352 of + '(' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'('" "not match pattern: " "" d672_351 ["derivsChars"]) + let '(' = xx671_352 + return () + s <- StateT selection + d676_353 <- get + xx675_354 <- StateT derivsChars + case xx675_354 of + ')' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "')'" "not match pattern: " "" d676_353 ["derivsChars"]) + let ')' = xx675_354 + return () + return (FromSelection s)] + test44_111 = foldl1 mplus [do d678_355 <- get + xx677_356 <- StateT derivsChars + case xx677_356 of + '[' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'['" "not match pattern: " "" d678_355 ["derivsChars"]) + let '[' = xx677_356 + return () + h <- StateT hsExpLam + _ <- StateT spaces + return () + com <- optional3_272 (StateT comForErr) + d686_357 <- get + xx685_358 <- StateT derivsChars + case xx685_358 of + ']' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "']'" "not match pattern: " "" d686_357 ["derivsChars"]) + let ']' = xx685_358 + return () + return (h, maybe "" id com)] + hsExpLam45_112 = foldl1 mplus [do d688_359 <- get + xx687_360 <- StateT derivsChars + case xx687_360 of + '\\' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\\\'" "not match pattern: " "" d688_359 ["derivsChars"]) + let '\\' = xx687_360 + return () + _ <- StateT spaces + return () + ps <- StateT pats + _ <- StateT spaces + return () + d696_361 <- get + xx695_362 <- StateT derivsChars + case xx695_362 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d696_361 ["derivsChars"]) + let '-' = xx695_362 + return () + d698_363 <- get + xx697_364 <- StateT derivsChars + let c = xx697_364 + unless (isGt c) (gets derivsPosition >>= (throwError . ParseError "isGt c" "not match: " "" d698_363 ["derivsChars"])) + _ <- StateT spaces + return () + e <- StateT hsExpTyp + return (lamE ps e), + do e <- StateT hsExpTyp + return e] + hsExpTyp46_113 = foldl1 mplus [do eo <- StateT hsExpOp + d708_365 <- get + xx707_366 <- StateT derivsChars + case xx707_366 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d708_365 ["derivsChars"]) + let ':' = xx707_366 + return () + d710_367 <- get + xx709_368 <- StateT derivsChars + case xx709_368 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d710_367 ["derivsChars"]) + let ':' = xx709_368 + return () + _ <- StateT spaces + return () + t <- StateT hsTypeArr + return (sigE eo t), + do eo <- StateT hsExpOp + return eo] + hsExpOp47_114 = foldl1 mplus [do l <- StateT hsExp + _ <- StateT spaces + return () + o <- StateT hsOp + _ <- StateT spaces + return () + r <- StateT hsExpOp + return (uInfixE (getEx l) o r), + do e <- StateT hsExp + return (getEx e)] + hsOp48_115 = foldl1 mplus [do d730_369 <- get + xx729_370 <- StateT derivsChars + let c = xx729_370 + unless (isOpHeadChar c) (gets derivsPosition >>= (throwError . ParseError "isOpHeadChar c" "not match: " "" d730_369 ["derivsChars"])) + o <- StateT opTail + return (varE (mkName (cons c o))), + do d734_371 <- get + xx733_372 <- StateT derivsChars + case xx733_372 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d734_371 ["derivsChars"]) + let ':' = xx733_372 + return () + ddd735_373 <- get + do err <- ((do d737_374 <- get + xx736_375 <- StateT derivsChars + case xx736_375 of + ':' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "':'" "not match pattern: " "" d737_374 ["derivsChars"]) + let ':' = xx736_375 + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "':':") "not match: " "" ddd735_373 ["derivsChars"])) + put ddd735_373 + o <- StateT opTail + return (conE (mkName (':' : o))), + do d741_376 <- get + xx740_377 <- StateT derivsChars + let c = xx740_377 + unless (isBQ c) (gets derivsPosition >>= (throwError . ParseError "isBQ c" "not match: " "" d741_376 ["derivsChars"])) + v <- StateT variable + d745_378 <- get + xx744_379 <- StateT derivsChars + let c_ = xx744_379 + unless (isBQ c_) (gets derivsPosition >>= (throwError . ParseError "isBQ c_" "not match: " "" d745_378 ["derivsChars"])) + return (varE (mkName v)), + do d747_380 <- get + xx746_381 <- StateT derivsChars + let c = xx746_381 + unless (isBQ c) (gets derivsPosition >>= (throwError . ParseError "isBQ c" "not match: " "" d747_380 ["derivsChars"])) + t <- StateT typ + d751_382 <- get + xx750_383 <- StateT derivsChars + let c_ = xx750_383 + unless (isBQ c_) (gets derivsPosition >>= (throwError . ParseError "isBQ c_" "not match: " "" d751_382 ["derivsChars"])) + return (conE (mkName t))] + opTail49_116 = foldl1 mplus [do d753_384 <- get + xx752_385 <- StateT derivsChars + let c = xx752_385 + unless (isOpTailChar c) (gets derivsPosition >>= (throwError . ParseError "isOpTailChar c" "not match: " "" d753_384 ["derivsChars"])) + s <- StateT opTail + return (cons c s), + return emp] + hsExp50_117 = foldl1 mplus [do e <- StateT hsExp1 + _ <- StateT spaces + return () + h <- StateT hsExp + return (applyExR e h), + do e <- StateT hsExp1 + return (toEx e)] + hsExp151_118 = foldl1 mplus [do d765_386 <- get + xx764_387 <- StateT derivsChars + case xx764_387 of + '(' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'('" "not match pattern: " "" d765_386 ["derivsChars"]) + let '(' = xx764_387 + return () + l <- optional3_272 (foldl1 mplus [do e <- StateT hsExpTyp + return e]) + _ <- StateT spaces + return () + o <- StateT hsOp + _ <- StateT spaces + return () + r <- optional3_272 (foldl1 mplus [do e <- StateT hsExpTyp + return e]) + d781_388 <- get + xx780_389 <- StateT derivsChars + case xx780_389 of + ')' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "')'" "not match pattern: " "" d781_388 ["derivsChars"]) + let ')' = xx780_389 + return () + return (infixE l o r), + do d783_390 <- get + xx782_391 <- StateT derivsChars + case xx782_391 of + '(' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'('" "not match pattern: " "" d783_390 ["derivsChars"]) + let '(' = xx782_391 + return () + et <- StateT hsExpTpl + d787_392 <- get + xx786_393 <- StateT derivsChars + case xx786_393 of + ')' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "')'" "not match pattern: " "" d787_392 ["derivsChars"]) + let ')' = xx786_393 + return () + return (tupE et), + do d789_394 <- get + xx788_395 <- StateT derivsChars + case xx788_395 of + '[' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'['" "not match pattern: " "" d789_394 ["derivsChars"]) + let '[' = xx788_395 + return () + et <- StateT hsExpTpl + d793_396 <- get + xx792_397 <- StateT derivsChars + case xx792_397 of + ']' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "']'" "not match pattern: " "" d793_396 ["derivsChars"]) + let ']' = xx792_397 + return () + return (listE et), + do v <- StateT variable + return (varE (mkName v)), + do t <- StateT typ + return (conE (mkName t)), + do i <- StateT integer + _ <- StateT spaces + return () + return (litE (integerL i)), + do d803_398 <- get + xx802_399 <- StateT derivsChars + case xx802_399 of + '\'' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\''" "not match pattern: " "" d803_398 ["derivsChars"]) + let '\'' = xx802_399 + return () + c <- StateT charLit + d807_400 <- get + xx806_401 <- StateT derivsChars + case xx806_401 of + '\'' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\''" "not match pattern: " "" d807_400 ["derivsChars"]) + let '\'' = xx806_401 + return () + return (litE (charL c)), + do d809_402 <- get + xx808_403 <- StateT derivsChars + case xx808_403 of + '"' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\"'" "not match pattern: " "" d809_402 ["derivsChars"]) + let '"' = xx808_403 + return () + s <- StateT stringLit + d813_404 <- get + xx812_405 <- StateT derivsChars + case xx812_405 of + '"' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\"'" "not match pattern: " "" d813_404 ["derivsChars"]) + let '"' = xx812_405 + return () + return (litE (stringL s)), + do d815_406 <- get + xx814_407 <- StateT derivsChars + case xx814_407 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d815_406 ["derivsChars"]) + let '-' = xx814_407 + return () + _ <- StateT spaces + return () + e <- StateT hsExp1 + return (appE (varE $ mkName "negate") e)] + hsExpTpl52_119 = foldl1 mplus [do e <- StateT hsExpLam + _ <- StateT spaces + return () + d825_408 <- get + xx824_409 <- StateT derivsChars + let c = xx824_409 + unless (isComma c) (gets derivsPosition >>= (throwError . ParseError "isComma c" "not match: " "" d825_408 ["derivsChars"])) + _ <- StateT spaces + return () + et <- StateT hsExpTpl + return (cons e et), + do e <- StateT hsExpLam + return (cons e emp), + return emp] + hsTypeArr53_120 = foldl1 mplus [do l <- StateT hsType + d835_410 <- get + xx834_411 <- StateT derivsChars + case xx834_411 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d835_410 ["derivsChars"]) + let '-' = xx834_411 + return () + d837_412 <- get + xx836_413 <- StateT derivsChars + let c = xx836_413 + unless (isGt c) (gets derivsPosition >>= (throwError . ParseError "isGt c" "not match: " "" d837_412 ["derivsChars"])) + _ <- StateT spaces + return () + r <- StateT hsTypeArr + return (appT (appT arrowT (getTyp l)) r), + do t <- StateT hsType + return (getTyp t)] + hsType54_121 = foldl1 mplus [do t <- StateT hsType1 + ts <- StateT hsType + return (applyTyp (toTyp t) ts), + do t <- StateT hsType1 + return (toTyp t)] + hsType155_122 = foldl1 mplus [do d851_414 <- get + xx850_415 <- StateT derivsChars + case xx850_415 of + '[' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'['" "not match pattern: " "" d851_414 ["derivsChars"]) + let '[' = xx850_415 + return () + d853_416 <- get + xx852_417 <- StateT derivsChars + case xx852_417 of + ']' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "']'" "not match pattern: " "" d853_416 ["derivsChars"]) + let ']' = xx852_417 + return () + _ <- StateT spaces + return () + return listT, + do d857_418 <- get + xx856_419 <- StateT derivsChars + case xx856_419 of + '[' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'['" "not match pattern: " "" d857_418 ["derivsChars"]) + let '[' = xx856_419 + return () + t <- StateT hsTypeArr + d861_420 <- get + xx860_421 <- StateT derivsChars + case xx860_421 of + ']' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "']'" "not match pattern: " "" d861_420 ["derivsChars"]) + let ']' = xx860_421 + return () + _ <- StateT spaces + return () + return (appT listT t), + do d865_422 <- get + xx864_423 <- StateT derivsChars + case xx864_423 of + '(' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'('" "not match pattern: " "" d865_422 ["derivsChars"]) + let '(' = xx864_423 + return () + _ <- StateT spaces + return () + tt <- StateT hsTypeTpl + d871_424 <- get + xx870_425 <- StateT derivsChars + case xx870_425 of + ')' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "')'" "not match pattern: " "" d871_424 ["derivsChars"]) + let ')' = xx870_425 + return () + return (tupT tt), + do t <- StateT typToken + return (conT (mkName t)), + do d875_426 <- get + xx874_427 <- StateT derivsChars + case xx874_427 of + '(' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'('" "not match pattern: " "" d875_426 ["derivsChars"]) + let '(' = xx874_427 + return () + d877_428 <- get + xx876_429 <- StateT derivsChars + case xx876_429 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d877_428 ["derivsChars"]) + let '-' = xx876_429 + return () + d879_430 <- get + xx878_431 <- StateT derivsChars + let c = xx878_431 + unless (isGt c) (gets derivsPosition >>= (throwError . ParseError "isGt c" "not match: " "" d879_430 ["derivsChars"])) + d881_432 <- get + xx880_433 <- StateT derivsChars + case xx880_433 of + ')' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "')'" "not match pattern: " "" d881_432 ["derivsChars"]) + let ')' = xx880_433 + return () + _ <- StateT spaces + return () + return arrowT] + hsTypeTpl56_123 = foldl1 mplus [do t <- StateT hsTypeArr + d887_434 <- get + xx886_435 <- StateT derivsChars + let c = xx886_435 + unless (isComma c) (gets derivsPosition >>= (throwError . ParseError "isComma c" "not match: " "" d887_434 ["derivsChars"])) + _ <- StateT spaces + return () + tt <- StateT hsTypeTpl + return (cons t tt), + do t <- StateT hsTypeArr + return (cons t emp), + return emp] + typ57_124 = foldl1 mplus [do u <- StateT upper + t <- StateT tvtail + return (cons u t)] + variable58_125 = foldl1 mplus [do l <- StateT lower + t <- StateT tvtail + return (cons l t)] + tvtail59_126 = foldl1 mplus [do a <- StateT alpha + t <- StateT tvtail + return (cons a t), + return emp] + integer60_127 = foldl1 mplus [do dh <- StateT digit + ds <- list1_436 (foldl1 mplus [do d <- StateT digit + return d]) + return (read (cons dh ds))] + alpha61_128 = foldl1 mplus [do u <- StateT upper + return u, + do l <- StateT lower + return l, + do d <- StateT digit + return d, + do d919_437 <- get + xx918_438 <- StateT derivsChars + case xx918_438 of + '\'' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\''" "not match pattern: " "" d919_437 ["derivsChars"]) + let '\'' = xx918_438 + return () + return '\''] + upper62_129 = foldl1 mplus [do d921_439 <- get + xx920_440 <- StateT derivsChars + let u = xx920_440 + unless (isUpper u) (gets derivsPosition >>= (throwError . ParseError "isUpper u" "not match: " "" d921_439 ["derivsChars"])) + return u] + lower63_130 = foldl1 mplus [do d923_441 <- get + xx922_442 <- StateT derivsChars + let l = xx922_442 + unless (isLowerU l) (gets derivsPosition >>= (throwError . ParseError "isLowerU l" "not match: " "" d923_441 ["derivsChars"])) + return l] + digit64_131 = foldl1 mplus [do d925_443 <- get + xx924_444 <- StateT derivsChars + let d = xx924_444 + unless (isDigit d) (gets derivsPosition >>= (throwError . ParseError "isDigit d" "not match: " "" d925_443 ["derivsChars"])) + return d] + spaces65_132 = foldl1 mplus [do _ <- StateT space + return () + _ <- StateT spaces + return () + return (), + return ()] + space66_133 = foldl1 mplus [do d931_445 <- get + xx930_446 <- StateT derivsChars + let s = xx930_446 + unless (isSpace s) (gets derivsPosition >>= (throwError . ParseError "isSpace s" "not match: " "" d931_445 ["derivsChars"])) + return (), + do d933_447 <- get + xx932_448 <- StateT derivsChars + case xx932_448 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d933_447 ["derivsChars"]) + let '-' = xx932_448 + return () + d935_449 <- get + xx934_450 <- StateT derivsChars + case xx934_450 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d935_449 ["derivsChars"]) + let '-' = xx934_450 + return () + _ <- StateT notNLString + return () + _ <- StateT newLine + return () + return (), + do _ <- StateT comment + return () + return ()] + notNLString67_134 = foldl1 mplus [do ddd942_451 <- get + do err <- ((do _ <- StateT newLine + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "_:newLine") "not match: " "" ddd942_451 ["newLine"])) + put ddd942_451 + c <- StateT derivsChars + s <- StateT notNLString + return (cons c s), + return emp] + newLine68_135 = foldl1 mplus [do d950_452 <- get + xx949_453 <- StateT derivsChars + case xx949_453 of + '\n' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'\\n'" "not match pattern: " "" d950_452 ["derivsChars"]) + let '\n' = xx949_453 + return () + return ()] + comment69_136 = foldl1 mplus [do d952_454 <- get + xx951_455 <- StateT derivsChars + case xx951_455 of + '{' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'{'" "not match pattern: " "" d952_454 ["derivsChars"]) + let '{' = xx951_455 + return () + d954_456 <- get + xx953_457 <- StateT derivsChars + case xx953_457 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d954_456 ["derivsChars"]) + let '-' = xx953_457 + return () + ddd955_458 <- get + do err <- ((do d957_459 <- get + xx956_460 <- StateT derivsChars + case xx956_460 of + '#' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'#'" "not match pattern: " "" d957_459 ["derivsChars"]) + let '#' = xx956_460 + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "'#':") "not match: " "" ddd955_458 ["derivsChars"])) + put ddd955_458 + _ <- StateT comments + return () + _ <- StateT comEnd + return () + return ()] + comments70_137 = foldl1 mplus [do _ <- StateT notComStr + return () + _ <- StateT comment + return () + _ <- StateT comments + return () + return (), + do _ <- StateT notComStr + return () + return ()] + notComStr71_138 = foldl1 mplus [do ddd970_461 <- get + do err <- ((do _ <- StateT comment + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "_:comment") "not match: " "" ddd970_461 ["comment"])) + put ddd970_461 + ddd973_462 <- get + do err <- ((do _ <- StateT comEnd + return ()) >> return False) `catchError` const (return True) + unless err (gets derivsPosition >>= (throwError . ParseError ('!' : "_:comEnd") "not match: " "" ddd973_462 ["comEnd"])) + put ddd973_462 + _ <- StateT derivsChars + return () + _ <- StateT notComStr + return () + return (), + return ()] + comEnd72_139 = foldl1 mplus [do d981_463 <- get + xx980_464 <- StateT derivsChars + case xx980_464 of + '-' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'-'" "not match pattern: " "" d981_463 ["derivsChars"]) + let '-' = xx980_464 + return () + d983_465 <- get + xx982_466 <- StateT derivsChars + case xx982_466 of + '}' -> return () + _ -> gets derivsPosition >>= (throwError . ParseError "'}'" "not match pattern: " "" d983_465 ["derivsChars"]) + let '}' = xx982_466 + return () + return ()] + list1_436 :: forall m a . (MonadPlus m, Applicative m) => + m a -> m ([a]) + list12_467 :: forall m a . (MonadPlus m, Applicative m) => + m a -> m ([a]) + list1_436 p = list12_467 p `mplus` return [] + list12_467 p = ((:) <$> p) <*> list1_436 p + optional3_272 :: forall m a . (MonadPlus m, Applicative m) => + m a -> m (Maybe a) + optional3_272 p = (Just <$> p) `mplus` return Nothing + diff --git a/src/Text/Papillon/SyntaxTree.hs b/src/Text/Papillon/SyntaxTree.hs new file mode 100644 --- /dev/null +++ b/src/Text/Papillon/SyntaxTree.hs @@ -0,0 +1,229 @@ +module Text.Papillon.SyntaxTree where + +import Language.Haskell.TH +import Data.Char +import Control.Applicative +import Data.List + +data ReadFrom + = FromVariable String + | FromSelection Selection + | FromToken + | FromList ReadFrom + | FromList1 ReadFrom + | FromOptional ReadFrom + +nameFromRF :: ReadFrom -> [String] +nameFromRF (FromVariable s) = [s] +nameFromRF FromToken = ["derivsChars"] +nameFromRF (FromList rf) = nameFromRF rf +nameFromRF (FromList1 rf) = nameFromRF rf +nameFromRF (FromOptional rf) = nameFromRF rf +nameFromRF (FromSelection sel) = nameFromSelection sel + +showReadFrom :: ReadFrom -> Q String +showReadFrom FromToken = return "" +showReadFrom (FromVariable v) = return v +showReadFrom (FromList rf) = (++ "*") <$> showReadFrom rf +showReadFrom (FromList1 rf) = (++ "+") <$> showReadFrom rf +showReadFrom (FromOptional rf) = (++ "?") <$> showReadFrom rf +showReadFrom (FromSelection sel) = ('(' :) <$> (++ ")") <$> showSelection sel + +data NameLeaf = NameLeaf (PatQ, String) ReadFrom (Maybe (ExR, String)) + +showNameLeaf :: NameLeaf -> Q String +showNameLeaf (NameLeaf (pat, _) rf (Just (p, _))) = do + patt <- pat + rff <- showReadFrom rf + pp <- p + return $ show (ppr patt) ++ ":" ++ rff ++ "[" ++ show (ppr pp) ++ "]" +showNameLeaf (NameLeaf (pat, _) rf Nothing) = do + patt <- pat + rff <- showReadFrom rf + return $ show (ppr patt) ++ ":" ++ rff + +nameFromNameLeaf :: NameLeaf -> [String] +nameFromNameLeaf (NameLeaf _ rf _) = nameFromRF rf + +data NameLeaf_ + = Here NameLeaf + | After NameLeaf + | NotAfter NameLeaf String + +showNameLeaf_ :: NameLeaf_ -> Q String +showNameLeaf_ (Here nl) = showNameLeaf nl +showNameLeaf_ (After nl) = ('&' :) <$> showNameLeaf nl +showNameLeaf_ (NotAfter nl _) = ('!' :) <$> showNameLeaf nl + +nameFromNameLeaf_ :: NameLeaf_ -> [String] +nameFromNameLeaf_ (Here nl) = nameFromNameLeaf nl +nameFromNameLeaf_ (After nl) = nameFromNameLeaf nl +nameFromNameLeaf_ (NotAfter nl _) = nameFromNameLeaf nl + +type Expression = [NameLeaf_] + +showExpression :: Expression -> Q String +showExpression ex = unwords <$> mapM showNameLeaf_ ex + +nameFromExpression :: Expression -> [String] +nameFromExpression = nameFromNameLeaf_ . head + +type ExpressionHs = (Expression, ExR) + +showExpressionHs :: ExpressionHs -> Q String +showExpressionHs (ex, hs) = do + expp <- showExpression ex + hss <- hs + return $ expp ++ " { " ++ show (ppr hss) ++ " }" + +nameFromExpressionHs :: ExpressionHs -> [String] +nameFromExpressionHs = nameFromExpression . fst + +type Selection = [ExpressionHs] + +showSelection :: Selection -> Q String +showSelection ehss = intercalate " / " <$> mapM showExpressionHs ehss + +nameFromSelection :: Selection -> [String] +nameFromSelection = concatMap nameFromExpressionHs + +type Definition = (String, TypeQ, Selection) +type Peg = [Definition] +type TTPeg = (TypeQ, TypeQ, Peg) + +type Ex = (ExpQ -> ExpQ) -> ExpQ +type ExR = ExpQ +type ExRL = [ExpQ] + +type Typ = (TypeQ -> TypeQ) -> TypeQ +type TypeQL = [TypeQ] + +tupT :: [TypeQ] -> TypeQ +tupT ts = foldl appT (tupleT $ length ts) ts + +getTyp :: Typ -> TypeQ +getTyp t = t id + +toTyp :: TypeQ -> Typ +toTyp tp f = f tp + +ctLeaf_ :: PatQ -> NameLeaf +ctLeaf_ n = NameLeaf (n, "") FromToken Nothing + +true :: ExpQ +true = conE $ mkName "True" + +just :: a -> Maybe a +just = Just +nothing :: Maybe a +nothing = Nothing + +cons :: a -> [a] -> [a] +cons = (:) + +type PatQs = [PatQ] + +strToPatQ :: String -> PatQ +strToPatQ = varP . mkName + +conToPatQ :: String -> [PatQ] -> PatQ +conToPatQ t = conP (mkName t) + +mkExpressionHs :: a -> ExR -> (a, ExR) +mkExpressionHs x y = (x, y) + +mkDef :: a -> TypeQ -> c -> (a, TypeQ, c) +mkDef x y z = (x, y, z) + +isOpTailChar :: Char -> Bool +isOpTailChar = (`elem` ":+*/-!|&.^=<>$") + +colon :: Char +colon = ':' + +isOpHeadChar :: Char -> Bool +isOpHeadChar = (`elem` "+*/-!|&.^=<>$") + +toExp :: String -> Ex +toExp v f = f $ varE (mkName v) + +toEx :: ExR -> Ex +toEx v f = f v + +apply :: String -> Ex -> Ex +apply f x g = x (toExp f g `appE`) + +applyExR :: ExR -> Ex -> Ex +applyExR f x g = x (toEx f g `appE`) + +applyTyp :: Typ -> Typ -> Typ +applyTyp f t g = t (f g `appT`) + +getEx :: Ex -> ExR +getEx ex = ex id + +toExGetEx :: Ex -> Ex +toExGetEx = toEx . getEx + +emp :: [a] +emp = [] + +type PegFile = ([PPragma], ModuleName, String, String, TTPeg, String) +data PPragma = LanguagePragma [String] | OtherPragma String deriving Show +type ModuleName = [String] + +addModules :: String +addModules = + "import \"monads-tf\" Control.Monad.State\n" ++ + "import \"monads-tf\" Control.Monad.Error\n" + +correctMD :: ([String], String) -> String +correctMD (n, o) = intercalate "." n ++ o +mkPegFile :: [PPragma] -> Maybe ([String], String) -> String -> String -> + TTPeg -> String -> PegFile +mkPegFile ps (Just md) x y z w = ( + ps, + fst md, + snd md ++ " where\n" ++ + addModules, + x ++ "\n" ++ y, z, w) +mkPegFile ps Nothing x y z w = + (ps, [], addModules, x ++ "\n" ++ y, z, w) + +charP :: Char -> PatQ +charP = litP . charL +stringP :: String -> PatQ +stringP = litP . stringL + +isStrLitC, isAlphaNumOt, elemNTs :: Char -> Bool +isAlphaNumOt = (`notElem` "\\'") +elemNTs = (`elem` "nt\\'") +isStrLitC = (`notElem` "\"\\") + +tab :: Char +tab = '\t' + +isComma, isKome, isOpen, isClose, isGt, isQuestion, isBQ, isAmp :: Char -> Bool +isComma = (== ',') +isKome = (== '*') +isOpen = (== '(') +isClose = (== ')') +isGt = (== '>') +isQuestion = (== '?') +isBQ = (== '`') +isAmp = (== '&') + +getNTs :: Char -> Char +getNTs 'n' = '\n' +getNTs 't' = '\t' +getNTs '\\' = '\\' +getNTs '\'' = '\'' +getNTs o = o +isLowerU :: Char -> Bool +isLowerU c = isLower c || c == '_' + +tString :: String +tString = "String" +mkTTPeg :: String -> Peg -> TTPeg +mkTTPeg s p = + (conT $ mkName s, conT (mkName "Token") `appT` conT (mkName s), p) diff --git a/src/Text/PapillonCore.hs b/src/Text/PapillonCore.hs new file mode 100644 --- /dev/null +++ b/src/Text/PapillonCore.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE TemplateHaskell, PackageImports, TypeFamilies, FlexibleContexts, + FlexibleInstances #-} + +module Text.PapillonCore ( + papillonCore, + papillonFile, + PPragma(..), + + Source(..), + SourceList(..), + ParseError(..), + Pos(..), + ListPos(..), + pePositionS, +) where + +import Language.Haskell.TH +import "monads-tf" Control.Monad.State +import "monads-tf" Control.Monad.Error + +import Control.Applicative + +import Text.Papillon.Parser +import Data.IORef +-- import Data.List + +import Text.Papillon.List + +isOptionalUsed :: Peg -> Bool +isOptionalUsed = any isOptionalUsedDefinition + +isOptionalUsedDefinition :: Definition -> Bool +isOptionalUsedDefinition (_, _, sel) = any isOptionalUsedSelection sel + +isOptionalUsedSelection :: ExpressionHs -> Bool +isOptionalUsedSelection = any isOptionalUsedLeafName . fst + +isOptionalUsedLeafName :: NameLeaf_ -> Bool +isOptionalUsedLeafName (Here nl) = isOptionalUsedLeafName' nl +isOptionalUsedLeafName (NotAfter nl _) = isOptionalUsedLeafName' nl +isOptionalUsedLeafName (After nl) = isOptionalUsedLeafName' nl + +isOptionalUsedLeafName' :: NameLeaf -> Bool +isOptionalUsedLeafName' (NameLeaf _ rf _) = isOptionalUsedReadFrom rf + +isOptionalUsedReadFrom :: ReadFrom -> Bool +isOptionalUsedReadFrom (FromOptional _) = True +isOptionalUsedReadFrom (FromSelection sel) = any isOptionalUsedSelection sel +isOptionalUsedReadFrom _ = False + +isListUsed :: Peg -> Bool +isListUsed = any isListUsedDefinition + +isListUsedDefinition :: Definition -> Bool +isListUsedDefinition (_, _, sel) = any isListUsedSelection sel + +isListUsedSelection :: ExpressionHs -> Bool +isListUsedSelection = any isListUsedLeafName . fst + +isListUsedLeafName :: NameLeaf_ -> Bool +isListUsedLeafName (Here nl) = isListUsedLeafName' nl +isListUsedLeafName (NotAfter nl _) = isListUsedLeafName' nl +isListUsedLeafName (After nl) = isListUsedLeafName' nl + +isListUsedLeafName' :: NameLeaf -> Bool +isListUsedLeafName' (NameLeaf _ (FromList _) _) = True +isListUsedLeafName' (NameLeaf _ (FromList1 _) _) = True +isListUsedLeafName' _ = False + +catchErrorN, unlessN :: Bool -> Name +catchErrorN True = 'catchError +catchErrorN False = mkName "catchError" +unlessN True = 'unless +unlessN False = mkName "unless" + +smartDoE :: [Stmt] -> Exp +smartDoE [NoBindS ex] = ex +smartDoE stmts = DoE stmts + +flipMaybeBody :: Bool -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ +flipMaybeBody th code com d ns act = doE [ + bindS (varP $ mkName "err") $ infixApp + actionReturnFalse + (varE $ catchErrorN th) + constReturnTrue, + noBindS $ varE (unlessN th) + `appE` varE (mkName "err") + `appE` throwErrorPackratMBody th + (infixApp (litE $ charL '!') (conE $ mkName ":") code) + (stringE "not match: ") com d ns + ] where + actionReturnFalse = infixApp act (varE $ mkName ">>") + (varE (mkName "return") `appE` conE (mkName "False")) + constReturnTrue = varE (mkName "const") `appE` + (varE (mkName "return") `appE` conE (mkName "True")) + +newThrowQ :: Bool -> String -> String -> Name -> [String] -> String -> ExpQ +newThrowQ th code msg d ns com = + throwErrorPackratMBody th (stringE code) (stringE msg) (stringE com) + (varE d) (listE $ map stringE ns) + +returnN, putN, stateTN', getN, + throwErrorN, runStateTN, justN, mplusN, + getsN :: Bool -> Name +returnN True = 'return +returnN False = mkName "return" +throwErrorN True = 'throwError +throwErrorN False = mkName "throwError" +putN True = 'put +putN False = mkName "put" +getsN True = 'gets +getsN False = mkName "gets" +stateTN' True = 'StateT +stateTN' False = mkName "StateT" +mplusN True = 'mplus +mplusN False = mkName "mplus" +getN True = 'get +getN False = mkName "get" +runStateTN True = 'runStateT +runStateTN False = mkName "runStateT" +justN True = 'Just +justN False = mkName "Just" + +eitherN :: Name +eitherN = mkName "Either" + +papillonCore :: String -> DecsQ +papillonCore str = case peg $ parse str of + Right ((src, tkn, parsed), _) -> decParsed True src tkn parsed + Left err -> error $ "parse error: " ++ showParseError err + +papillonFile :: String -> + ([PPragma], ModuleName, String, String, DecsQ, String, Bool) +papillonFile str = case pegFile $ parse str of + Right ((prgm, mn, ppp, pp, (src, tkn, parsed), atp), _) -> + (prgm, mn, ppp, pp, decParsed False src tkn parsed, atp, + needApplicative parsed) + Left err -> error $ "parse error: " ++ showParseError err + where + needApplicative pg = isListUsed pg || isOptionalUsed pg + +showParseError :: ParseError (Pos String) Derivs -> String +showParseError (ParseError c m _ d ns (ListPos (CharPos p))) = + unwords (map (showReading d) ns) ++ (if null ns then "" else " ") ++ + m ++ c ++ " at position: " ++ show p + +showReading :: Derivs -> String -> String +showReading d "derivsChars" = case derivsChars d of + Right (c, _) -> show c + Left _ -> error "bad" +showReading _ n = "yet: " ++ n + +decParsed :: Bool -> TypeQ -> TypeQ -> Peg -> DecsQ +decParsed th src tkn parsed = do + glb <- runIO $ newIORef 0 + d <- derivs th src tkn parsed + pt <- parseT src th + p <- funD (mkName "parse") [parseEE glb th parsed] + return $ d : pt : [p] + +parseEE :: IORef Int -> Bool -> Peg -> ClauseQ +parseEE glb th pg = do + pgn <- newNewName glb "parse" + listN <- newNewName glb "list" + list1N <- newNewName glb "list1" + optionalN <- newNewName glb "optional" + pNames <- mapM (newNewName glb . \(n, _, _) -> n) pg + + pgenE <- varE pgn `appE` varE (mkName "initialPos") + decs <- (:) + <$> funD pgn [parseE glb th pgn pNames pg] + <*> pSomes glb th listN list1N optionalN pNames pg + ld <- listDec listN list1N th + od <- optionalDec optionalN th + return $ Clause [] (NormalB pgenE) $ decs ++ + (if isListUsed pg then ld else []) ++ + (if isOptionalUsed pg then od else []) + +dvCharsN, dvPosN :: Name +dvCharsN = mkName "derivsChars" +dvPosN = mkName "derivsPosition" + +derivs :: Bool -> TypeQ -> TypeQ -> Peg -> DecQ +derivs _ src tkn pegg = dataD (cxt []) (mkName "Derivs") [] [ + recC (mkName "Derivs") $ map (derivs1 src) pegg ++ [ + varStrictType dvCharsN $ strictType notStrict $ + resultT src tkn, + varStrictType dvPosN $ strictType notStrict $ + conT (mkName "Pos") `appT` src + ] + ] [] + +derivs1 :: TypeQ -> Definition -> VarStrictTypeQ +derivs1 src (name, typ, _) = + varStrictType (mkName name) $ strictType notStrict $ resultT src typ + +throwErrorPackratMBody :: Bool -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ -> ExpQ +throwErrorPackratMBody th code msg com d ns = infixApp + (varE (getsN th) `appE` varE dvPosN) + (varE $ mkName ">>=") (infixApp + (varE $ throwErrorN th) + (varE $ mkName ".") + (conE (mkName "ParseError") + `appE` code + `appE` msg + `appE` com + `appE` d + `appE` ns)) + +resultT :: TypeQ -> TypeQ -> TypeQ +resultT src typ = + conT eitherN `appT` pe `appT` + (tupleT 2 `appT` typ `appT` conT (mkName "Derivs")) + where + pe = conT (mkName "ParseError") + `appT` (conT (mkName "Pos") `appT` src) + `appT` conT (mkName "Derivs") + +parseT :: TypeQ -> Bool -> DecQ +parseT src _ = sigD (mkName "parse") $ arrowT + `appT` src + `appT` conT (mkName "Derivs") + +newNewName :: IORef Int -> String -> Q Name +newNewName g base = do + n <- runIO $ readIORef g + runIO $ modifyIORef g succ + newName (base ++ show n) +parseE :: IORef Int -> Bool -> Name -> [Name] -> Peg -> ClauseQ +parseE g th pgn pnames pegg = do + tmps <- mapM (newNewName g) names + parseE' g th pgn tmps pnames + where + names = map (\(n, _, _) -> n) pegg +parseE' :: IORef Int -> Bool -> Name -> [Name] -> [Name] -> ClauseQ +parseE' g th pgn tmps pnames = do + chars <- newNewName g "chars" + clause [varP $ mkName "pos", varP $ mkName "s"] + (normalB $ varE $ mkName "d") $ [ + flip (valD $ varP $ mkName "d") [] $ normalB $ appsE $ + conE (mkName "Derivs") : + map varE tmps ++ [varE chars, varE $ mkName "pos"] + ] ++ zipWith (parseE1 th) tmps pnames ++ [parseChar th pgn chars] + +parseChar :: Bool -> Name -> Name -> DecQ +parseChar th pgn chars = flip (valD $ varP chars) [] $ normalB $ + varE (runStateTN th) `appE` + caseE (varE (mkName "getToken") `appE` varE s) [ + match (justN th `conP` [tupP [varP c, varP s']]) + (normalB $ doE [ + noBindS $ varE (putN th) `appE` + (parseGenE + `appE` newPos + `appE` varE s'), + noBindS $ returnE `appE` varE c]) + [], + match wildP + (normalB $ newThrowQ th "" "end of input" + (mkName "undefined") + [] "") + [] + ] `appE` varE (mkName "d") + where + newPos = varE (mkName "updatePos") + `appE` varE (mkName "c") + `appE` varE pos + pos = mkName "pos" + c = mkName "c" + s = mkName "s" + s' = mkName "s'" + returnE = varE $ returnN th + parseGenE = varE pgn +parseE1 :: Bool -> Name -> Name -> DecQ +parseE1 th tmp name = flip (valD $ varP tmp) [] $ normalB $ + varE (runStateTN th) `appE` varE name + `appE` varE (mkName "d") + +pSomes :: IORef Int -> Bool -> Name -> Name -> Name -> [Name] -> Peg -> DecsQ +pSomes g th lst lst1 opt = zipWithM $ pSomes1 g th lst lst1 opt + +pSomes1 :: IORef Int -> Bool -> Name -> Name -> Name -> Name -> Definition -> DecQ +pSomes1 g th lst lst1 opt pname (_, _, sel) = flip (valD $ varP pname) [] $ + normalB $ pSomes1Sel g th lst lst1 opt sel + +pSomes1Sel :: IORef Int -> Bool -> Name -> Name -> Name -> Selection -> ExpQ +pSomes1Sel g th lst lst1 opt sel = + varE (mkName "foldl1") `appE` varE (mplusN th) `appE` + listE (map (uncurry $ pSome_ g th lst lst1 opt) sel) + +pSome_ :: IORef Int -> Bool -> Name -> Name -> Name -> [NameLeaf_] -> ExpQ -> ExpQ +pSome_ g th lst lst1 opt nls ret = fmap smartDoE $ do + x <- mapM (transLeaf g th lst lst1 opt) nls + r <- noBindS $ varE (returnN th) `appE` ret + return $ concat x ++ [r] + +afterCheck :: Bool -> ExpQ -> Name -> [String] -> String -> StmtQ +afterCheck th p d ns pc = do + pp <- p + noBindS $ varE (unlessN th) `appE` p `appE` + newThrowQ th (show $ ppr pp) "not match: " d ns pc + +beforeMatch :: Bool -> Name -> PatQ -> Name -> [String] -> String -> Q [Stmt] +beforeMatch th t n d ns nc = do + nn <- n + sequence [ + noBindS $ caseE (varE t) [ + flip (match $ varPToWild n) [] $ normalB $ + varE (returnN th) `appE` tupE [], + flip (match wildP) [] $ normalB $ + newThrowQ th (show $ ppr nn) "not match pattern: " + d ns nc + ], + letS [flip (valD n) [] $ normalB $ varE t], + noBindS $ varE (returnN th) `appE` tupE [] + ] + +getNewName :: IORef Int -> String -> Q Name +getNewName g n = do + gn <- runIO $ readIORef g + runIO $ modifyIORef g succ + newName $ n ++ show gn + +{- + +showSelection :: Selection -> Q String = mapM showExpression + +showNameLeaf :: NameLeaf -> Q String +showNameLeaf (NameLeafList pat sel) = + (\ps ss -> sho (ppr ps) ++ ":(" ++ selS ++ ")*") + <$> pat <*> showSelection sel + +-} + +transReadFrom :: IORef Int -> Bool -> Name -> Name -> Name -> ReadFrom -> ExpQ +transReadFrom _ th _ _ _ FromToken = conE (stateTN' th) `appE` varE dvCharsN +transReadFrom _ th _ _ _ (FromVariable var) = conE (stateTN' th) `appE` varE (mkName var) +transReadFrom g th l l1 o (FromSelection sel) = pSomes1Sel g th l l1 o sel +transReadFrom g th l l1 o (FromList rf) = varE l `appE` transReadFrom g th l l1 o rf +transReadFrom g th l l1 o (FromList1 rf) = varE l1 `appE` transReadFrom g th l l1 o rf +transReadFrom g th l l1 o (FromOptional rf) = varE o `appE` transReadFrom g th l l1 o rf + +mkTDNN :: IORef Int -> PatQ -> Q (Name, Name, Pat) +mkTDNN g n = do + t <- getNewName g "xx" + d <- getNewName g "d" + nn <- n + return (t, d, nn) + +transLeaf' :: IORef Int -> Bool -> Name -> Name -> Name -> NameLeaf -> Q [Stmt] +transLeaf' g th lst lst1 opt (NameLeaf (n, nc) rf (Just (p, pc))) = do + (t, d, nn) <- mkTDNN g n + case nn of + WildP -> sequence [ + bindS (varP d) $ varE $ getN th, + bindS wildP $ transReadFrom g th lst lst1 opt rf, + afterCheck th p d (nameFromRF rf) pc + ] + _ | notHaveOthers nn -> do + bd <- bindS (varP d) $ varE $ getN th + s <- bindS (varP t) $ transReadFrom g th lst lst1 opt rf + m <- letS [flip (valD n) [] $ normalB $ varE t] + c <- afterCheck th p d (nameFromRF rf) pc + return $ bd : s : m : [c] + | otherwise -> do + bd <- bindS (varP d) $ varE $ getN th + s <- bindS (varP t) $ + transReadFrom g th lst lst1 opt rf + m <- beforeMatch th t n d (nameFromRF rf) nc + c <- afterCheck th p d (nameFromRF rf) pc + return $ bd : s : m ++ [c] + where + notHaveOthers (VarP _) = True + notHaveOthers (TupP pats) = all notHaveOthers pats + notHaveOthers _ = False +transLeaf' g th lst lst1 opt (NameLeaf (n, nc) rf Nothing) = do + (t, d, nn) <- mkTDNN g n + case nn of + WildP -> sequence [ + bindS wildP $ transReadFrom g th lst lst1 opt rf, + noBindS $ varE (returnN th) `appE` tupE [] + ] + _ | notHaveOthers nn -> (: []) <$> + bindS n (transReadFrom g th lst lst1 opt rf) + | otherwise -> do + bd <- bindS (varP d) $ varE $ getN th + s <- bindS (varP t) $ + transReadFrom g th lst lst1 opt rf + m <- beforeMatch th t n d (nameFromRF rf) nc + return $ bd : s : m + where + notHaveOthers (VarP _) = True + notHaveOthers (TupP pats) = all notHaveOthers pats + notHaveOthers _ = False + +transLeaf :: IORef Int -> Bool -> Name -> Name -> Name -> NameLeaf_ -> Q [Stmt] +transLeaf g th lst lst1 opt (Here nl) = transLeaf' g th lst lst1 opt nl +transLeaf g th lst lst1 opt (After nl) = do + d <- getNewName g "ddd" + sequence [ + bindS (varP d) $ varE (getN th), + noBindS $ smartDoE <$> transLeaf' g th lst lst1 opt nl, + noBindS $ varE (putN th) `appE` varE d] +transLeaf g th lst lst1 opt (NotAfter nl@(NameLeaf _ rf _) com) = do + d <- getNewName g "ddd" + nls <- showNameLeaf nl + sequence [ + bindS (varP d) $ varE (getN th), + noBindS $ flipMaybeBody th + (stringE nls) + (stringE com) + (varE d) + (listE $ map stringE $ nameFromRF rf) + (smartDoE <$> transLeaf' g th lst lst1 opt nl), + 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 (InfixP p1 n p2) = InfixP (vpw p1) n (vpw p2) + vpw (UInfixP p1 n p2) = InfixP (vpw p1) n (vpw p2) + vpw (ListP ps) = ListP $ vpw `map` ps + vpw (TupP ps) = TupP $ vpw `map` ps + vpw o = o diff --git a/src/papillon.hs b/src/papillon.hs deleted file mode 100644 --- a/src/papillon.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Text.Papillon -import System.Environment - -main :: IO () -main = do - fn : _ <- getArgs - putStr =<< papillonStr' =<< readFile fn