papillon 0.0.1 → 0.0.7
raw patch · 4 files changed
+1741/−472 lines, 4 filesdep +transformersdep ~basedep ~template-haskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: transformers
Dependency ranges changed: base, template-haskell
API changes (from Hackage documentation)
- Text.Papillon: StateT :: (s -> m (a, s)) -> StateT s a
- Text.Papillon: newtype StateT s (m :: * -> *) a :: * -> (* -> *) -> * -> *
- Text.Papillon: runStateT :: StateT s a -> s -> m (a, s)
+ Text.Papillon: class Source sl where type family Token sl
+ Text.Papillon: class SourceList c
+ Text.Papillon: classSourceQ :: Bool -> DecsQ
+ Text.Papillon: getToken :: Source sl => sl -> Maybe (Token sl, sl)
+ Text.Papillon: instance SourceList Char
+ Text.Papillon: instance SourceList c => Source [c]
+ Text.Papillon: listToken :: SourceList c => [c] -> Maybe (c, [c])
Files
- papillon.cabal +6/−6
- src/Text/Papillon.hs +241/−94
- src/Text/Papillon/Class.hs +86/−0
- src/Text/Papillon/Parser.hs +1408/−372
papillon.cabal view
@@ -2,11 +2,11 @@ cabal-version: >= 1.8 name: papillon-version: 0.0.1+version: 0.0.7 stability: Experimental author: Yoshikuni Jujo <PAF01143@nifty.ne.jp> maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>-homepage: yet+homepage: https://skami.iocikun.jp/haskell/packages/papillon license: BSD3 license-file: LICENSE@@ -25,17 +25,17 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/papillon.git- tag: 0.0.1+ tag: 0.0.7 library hs-source-dirs: src exposed-modules: Text.Papillon- other-modules: Text.Papillon.Parser- build-depends: base > 3 && < 5, template-haskell, monads-tf+ other-modules: Text.Papillon.Parser, Text.Papillon.Class+ build-depends: base > 3 && < 5, template-haskell, monads-tf, transformers ghc-options: -Wall executable papillon hs-source-dirs: src main-is: papillon.hs- build-depends: base > 3 && < 5, template-haskell, monads-tf+ build-depends: base > 3 && < 5, template-haskell, monads-tf, transformers ghc-options: -Wall
src/Text/Papillon.hs view
@@ -1,30 +1,51 @@-{-# LANGUAGE TemplateHaskell, PackageImports #-}+{-# LANGUAGE TemplateHaskell, PackageImports, TypeFamilies, FlexibleContexts #-} module Text.Papillon ( papillon, papillonStr, papillonStr',- StateT(..),--- flipMaybe+ classSourceQ,+ Source(..),+ SourceList(..) ) where import Language.Haskell.TH.Quote import Language.Haskell.TH import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Control.Monad.Trans.Error (Error(..))+import Data.Maybe import Control.Applicative import Text.Papillon.Parser--- import Parser+import Data.IORef --- dFlipMaybe :: DecsQ--- dFlipMaybe = [d|-flipMaybe :: StateT s Maybe a -> StateT s Maybe ()-flipMaybe action = StateT $ \s -> case runStateT action s of- Nothing -> Just ((), s)- _ -> Nothing--- |]+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,@@ -40,22 +61,38 @@ papillonStr' src = do let (pp, decsQ, atp) = declaration' src decs <- runQ decsQ- return $ pp ++ "\n" ++ show (ppr decs) ++ "\n" ++ atp+ 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, failN, charN, maybeN, stateTN, stringN, putN, stateTN', msumN, getN ::- Bool -> Name+returnN, stateTN, stringN, putN, stateTN', getN,+ eitherN, strMsgN, throwErrorN, runStateTN, justN, mplusN,+ getTokenN :: Bool -> Name returnN True = 'return returnN False = mkName "return"-failN True = 'fail-failN False = mkName "fail"-charN True = ''Char-charN False = mkName "Char"-maybeN True = ''Maybe-maybeN False = mkName "Maybe"+throwErrorN True = 'throwError+throwErrorN False = mkName "throwError"+strMsgN True = 'strMsg+strMsgN False = mkName "strMsg" stateTN True = ''StateT stateTN False = mkName "StateT" stringN True = ''String@@ -64,50 +101,60 @@ putN False = mkName "put" stateTN' True = 'StateT stateTN' False = mkName "StateT"-msumN True = 'msum-msumN False = mkName "msum"+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 src = do+declaration th str = do -- fm <- dFlipMaybe- let parsed = case dv_peg $ parse src of- Just (p, _) -> p+ let (src, tkn, parsed) = case dv_peg $ parse str of+ Right ((s, t, p), _) -> (s, t, p) _ -> error "bad"- decParsed th parsed+ decParsed th src tkn parsed declaration' :: String -> (String, DecsQ, String) declaration' src = case dv_pegFile $ parse src of- Just ((pp, p, atp), _) -> (pp, decParsed False p, atp)+ Right ((pp, (s, t, p), atp), _) ->+ (pp, decParsed False s t p, atp) _ -> error "bad" -decParsed :: Bool -> Peg -> DecsQ-decParsed th parsed = do+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 parsed- pt <- parseT 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+ tdvcm <- typeDvCharsM th tkn dvcm <- dvCharsM th pts <- typeP parsed- ps <- pSomes th parsed -- name expr+ 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 -> Peg -> DecQ-derivs th peg = flip (dataD (cxt []) (mkName "Derivs") []) [] $ [- recC (mkName "Derivs") $ (map derivs1 peg) ++ [+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` conT (charN th)+ conT (mkName "Result") `appT` tkn ]- ]+ ] [] derivs1 :: Definition -> VarStrictTypeQ derivs1 (name, typ, _) =@@ -115,16 +162,18 @@ conT (mkName "Result") `appT` conT typ result :: Bool -> DecQ-result th = tySynD (mkName "Result") [PlainTV $ mkName "v"] $ conT (maybeN th) `appT`- (tupleT 2 `appT` varT (mkName "v") `appT` conT (mkName "Derivs"))+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 (maybeN th)+ conT (mkName "Derivs") `appT`+ (conT (eitherN th) `appT` conT (stringN th)) -parseT :: Bool -> DecQ-parseT th = sigD (mkName "parse") $- arrowT `appT` conT (stringN th) `appT` conT (mkName "Derivs")+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@@ -132,42 +181,55 @@ flip (valD $ varP $ mkName "d") [] $ normalB $ appsE $ conE (mkName "Derivs") : map (varE . mkName) names- ++ [(varE $ mkName "char")]] ++- map parseE1 names ++ [+ ++ [varE (mkName "char")]] +++ map (parseE1 th) names ++ [ flip (valD $ varP $ mkName "char") [] $ normalB $- (varE $ mkName "flip") `appE` (varE $ mkName "runStateT") `appE`- (varE $ mkName "d") `appE` (doE [- bindS (infixP (varP $ mkName "c") (mkName ":")- (varP $ mkName "s'")) $- (varE $ returnN th) `appE`- (varE $ mkName "s"),- noBindS $ (varE $ putN th) `appE`- (varE (mkName "parse") `appE`- varE (mkName "s'")),- noBindS $ (varE $ returnN th) `appE` varE (mkName "c")- ])+ 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 :: String -> DecQ-parseE1 name = flip (valD $ varP $ mkName name) [] $ normalB $- (varE $ mkName "runStateT") `appE` (varE $ mkName $ "p_" ++ name)- `appE` (varE $ mkName "d")+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 = uncurry (zipWithM typeDvM1) . unzip . map (\(n, t, _) -> (n, t))+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) peg+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 -> DecQ-typeDvCharsM th =- sigD (mkName $ "dvCharsM") $ conT (mkName "PackratM") `appT` conT (charN th)+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")@@ -178,34 +240,119 @@ typeP1 :: String -> Name -> DecQ typeP1 f t = sigD (mkName $ "p_" ++ f) $ conT (mkName "PackratM") `appT` conT t -pSomes :: Bool -> Peg -> DecsQ-pSomes th = mapM $ pSomes1 th+pSomes :: IORef Int -> Bool -> Peg -> DecsQ+pSomes g th = mapM $ pSomes1 g th -pSomes1 :: Bool -> Definition -> DecQ-pSomes1 th (name, _, sel) = flip (valD $ varP $ mkName $ "p_" ++ name) [] $ normalB $- varE (msumN th) `appE` listE (map (uncurry $ pSome_ th) sel)+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_ :: Bool -> [NameLeaf] -> ExpQ -> ExpQ-pSome_ th nls ret = doE $- concatMap (transLeaf th) nls ++ [noBindS $ (varE $ returnN th) `appE` ret]+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 :: Bool -> NameLeaf -> [StmtQ]-transLeaf th (n, (Here (Right p))) = [- bindS (varP n) $ varE $ mkName "dvCharsM",- noBindS $ condE (p `appE` varE n)- (varE (returnN th) `appE` conE (mkName "()"))- (varE (failN th) `appE` litE (stringL "not match"))]-transLeaf _ (n, (Here (Left v))) = [- bindS (varP n) $ varE $ mkName $ "dv_" ++ v ++ "M"]-transLeaf th (n, (NotAfter (Right p))) = [- bindS (varP $ mkName "d") $ varE (getN th),- bindS (varP n) $ varE $ mkName "dvCharsM",- noBindS $ condE (p `appE` varE n)- (varE (failN th) `appE` litE (stringL "not match"))- (varE (returnN th) `appE` conE (mkName "()")),- noBindS $ varE (putN th) `appE` (varE $ mkName "d")]-transLeaf th (_, (NotAfter (Left v))) = [- bindS (varP $ mkName "d") $ varE (getN th),- noBindS $ varE (flipMaybeN th) `appE`- varE (mkName $ "dv_" ++ v ++ "M"),- noBindS $ varE (putN th) `appE` (varE $ mkName "d")]+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
+ src/Text/Papillon/Class.hs view
@@ -0,0 +1,86 @@+{-# 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
src/Text/Papillon/Parser.hs view
@@ -1,372 +1,1408 @@-{-# LANGUAGE PackageImports #-}--module Text.Papillon.Parser (- Peg,- Definition,- NameLeaf,- parse,- dv_peg,- dv_pegFile,- Leaf_(..)-) where--import Data.Char-import Control.Monad-import "monads-tf" Control.Monad.State-import Language.Haskell.TH--type Nil = ()-type Leaf = Either String ExR-data Leaf_ = NotAfter Leaf | Here Leaf-notAfter, here :: Leaf -> Leaf_-notAfter = NotAfter-here = Here-type NameLeaf = (Name, Leaf_)-type Expression = [NameLeaf]-type ExpressionHs = (Expression, ExR)-type Selection = [ExpressionHs]-type Typ = Name-type Definition = (String, Typ, Selection)-type Peg = [Definition]--type Ex = ExpQ -> ExpQ-type ExR = ExpQ--left :: b -> Either a b-right :: a -> Either a b-left = Right-right = Left--nil :: Nil-nil = ()--cons :: a -> [a] -> [a]-cons = (:)-mkNameLeaf :: String -> b -> (Name, b)-mkNameLeaf x y = (mkName x, y)-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, Peg, String)-mkPegFile :: a -> b -> c -> (a, b, c)-mkPegFile = (,,)--true :: Bool-true = True--isEqual, isSlash, isSemi,- isColon, isOpenWave, isCloseWave, isLowerU, isNot :: Char -> Bool-isEqual = (== '=')-isSlash = (== '/')-isSemi = (== ';')-isColon = (== ':')-isOpenWave = (== '{')-isCloseWave = (== '}')-isLowerU c = isLower c || c == '_'-isNot = (== '!')--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"--flipMaybe :: StateT s Maybe a -> StateT s Maybe ()-flipMaybe action = StateT $ \s -> case runStateT action s of- Nothing -> Just ((), s)- _ -> Nothing--type PackratM = StateT Derivs Maybe-type Result v = Maybe ((v, Derivs))-data Derivs- = Derivs {dv_pegFile :: (Result PegFile),- dv_prePeg :: (Result String),- dv_afterPeg :: (Result String),- dv_pap :: (Result Nil),- 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_leaf_ :: (Result Leaf_),- 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),- dvChars :: (Result Char)}-parse :: String -> Derivs-parse s = d- where d = Derivs pegFile prePeg afterPeg pap peg definition selection expressionHs expression nameLeaf leaf_ leaf test hsExp typ variable tvtail alpha upper lower digit spaces space char- pegFile = runStateT p_pegFile d- prePeg = runStateT p_prePeg d- afterPeg = runStateT p_afterPeg d- pap = runStateT p_pap 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- leaf_ = runStateT p_leaf_ 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- char = flip runStateT d (do c : s' <- return s- put (parse s')- return c)-dv_pegFileM :: PackratM PegFile-dv_prePegM :: PackratM String-dv_afterPegM :: PackratM String-dv_papM :: PackratM Nil-dv_pegM :: PackratM Peg-dv_definitionM :: PackratM Definition-dv_selectionM :: PackratM Selection-dv_expressionHsM :: PackratM ExpressionHs-dv_expressionM :: PackratM Expression-dv_nameLeafM :: PackratM NameLeaf-dv_leaf_M :: PackratM Leaf_-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_pegFileM = StateT dv_pegFile-dv_prePegM = StateT dv_prePeg-dv_afterPegM = StateT dv_afterPeg-dv_papM = StateT dv_pap-dv_pegM = StateT dv_peg-dv_definitionM = StateT dv_definition-dv_selectionM = StateT dv_selection-dv_expressionHsM = StateT dv_expressionHs-dv_expressionM = StateT dv_expression-dv_nameLeafM = StateT dv_nameLeaf-dv_leaf_M = StateT dv_leaf_-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-dvCharsM :: PackratM Char-dvCharsM = StateT dvChars-p_pegFile :: PackratM PegFile-p_prePeg :: PackratM String-p_afterPeg :: PackratM String-p_pap :: PackratM Nil-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_leaf_ :: PackratM Leaf_-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_pegFile = msum [do pp <- dv_prePegM- _ <- dv_papM- p <- dv_pegM- _ <- dv_spacesM- b <- dvCharsM- if id isBar b then return () else fail "not match"- c <- dvCharsM- if id isCloseBr c then return () else fail "not match"- n <- dvCharsM- if id isNL n then return () else fail "not match"- atp <- dv_afterPegM- return (id mkPegFile pp p atp)]-p_prePeg = msum [do d <- get- flipMaybe dv_papM- put d- c <- dvCharsM- if id const true c then return () else fail "not match"- pp <- dv_prePegM- return (id cons c pp),- do return (id empty)]-p_afterPeg = msum [do c <- dvCharsM- if id const true c then return () else fail "not match"- atp <- dv_afterPegM- return (id cons c atp),- do return (id empty)]-p_pap = msum [do nl <- dvCharsM- if id isNL nl then return () else fail "not match"- ob <- dvCharsM- if id isOpenBr ob then return () else fail "not match"- p <- dvCharsM- if id isP p then return () else fail "not match"- a <- dvCharsM- if id isA a then return () else fail "not match"- pp <- dvCharsM- if id isP pp then return () else fail "not match"- i <- dvCharsM- if id isI i then return () else fail "not match"- l <- dvCharsM- if id isL l then return () else fail "not match"- ll <- dvCharsM- if id isL ll then return () else fail "not match"- o <- dvCharsM- if id isO o then return () else fail "not match"- n <- dvCharsM- if id isN n then return () else fail "not match"- b <- dvCharsM- if id isBar b then return () else fail "not match"- nll <- dvCharsM- if id isNL nll then return () else fail "not match"- return (id nil)]-p_peg = msum [do _ <- dv_spacesM- d <- dv_definitionM- p <- dv_pegM- return (id cons d p),- do return (id empty)]-p_definition = msum [do v <- dv_variableM- _ <- dv_spacesM- c <- dvCharsM- if id isColon c then return () else fail "not match"- cc <- dvCharsM- if id isColon cc then return () else fail "not match"- _ <- dv_spacesM- t <- dv_typM- _ <- dv_spacesM- e <- dvCharsM- if id isEqual e then return () else fail "not match"- _ <- dv_spacesM- sel <- dv_selectionM- _ <- dv_spacesM- s <- dvCharsM- if id isSemi s then return () else fail "not match"- return (id mkDef v t sel)]-p_selection = msum [do ex <- dv_expressionHsM- _ <- dv_spacesM- e <- dvCharsM- if id isSlash e then return () else fail "not match"- _ <- dv_spacesM- sel <- dv_selectionM- return (id cons ex sel),- do ex <- dv_expressionHsM- return (id cons ex empty)]-p_expressionHs = msum [do e <- dv_expressionM- _ <- dv_spacesM- o <- dvCharsM- if id isOpenWave o then return () else fail "not match"- _ <- dv_spacesM- h <- dv_hsExpM- _ <- dv_spacesM- c <- dvCharsM- if id isCloseWave c then return () else fail "not match"- return (id mkExpressionHs e h)]-p_expression = msum [do l <- dv_nameLeafM- _ <- dv_spacesM- e <- dv_expressionM- return (id cons l e),- do return (id empty)]-p_nameLeaf = msum [do n <- dv_variableM- c <- dvCharsM- if id isColon c then return () else fail "not match"- l <- dv_leaf_M- return (id mkNameLeaf n l)]-p_leaf_ = msum [do n <- dvCharsM- if id isNot n then return () else fail "not match"- l <- dv_leafM- return (id notAfter l),- do l <- dv_leafM- return (id here l)]-p_leaf = msum [do t <- dv_testM- return (id left t),- do v <- dv_variableM- return (id right v)]-p_test = msum [do o <- dvCharsM- if id isOpenBr o then return () else fail "not match"- h <- dv_hsExpM- c <- dvCharsM- if id isCloseBr c then return () else fail "not match"- return (id getEx h)]-p_hsExp = msum [do v <- dv_variableM- _ <- dv_spacesM- h <- dv_hsExpM- return (id apply v h),- do v <- dv_variableM- return (id toExp v)]-p_typ = msum [do u <- dv_upperM- t <- dv_tvtailM- return (id cons u t)]-p_variable = msum [do l <- dv_lowerM- t <- dv_tvtailM- return (id cons l t)]-p_tvtail = msum [do a <- dv_alphaM- t <- dv_tvtailM- return (id cons a t),- do return (id empty)]-p_alpha = msum [do u <- dv_upperM- return (id u),- do l <- dv_lowerM- return (id l),- do d <- dv_digitM- return (id d)]-p_upper = msum [do u <- dvCharsM- if id isUpper u then return () else fail "not match"- return (id u)]-p_lower = msum [do l <- dvCharsM- if id isLowerU l then return () else fail "not match"- return (id l)]-p_digit = msum [do d <- dvCharsM- if id isDigit d then return () else fail "not match"- return (id d)]-p_spaces = msum [do _ <- dv_spaceM- _ <- dv_spacesM- return (id nil),- do return (id nil)]-p_space = msum [do l <- dvCharsM- if id isSpace l then return () else fail "not match"- return (id nil)]+{-# 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