diff --git a/papillon.cabal b/papillon.cabal --- a/papillon.cabal +++ b/papillon.cabal @@ -2,11 +2,11 @@ cabal-version: >= 1.8 name: papillon -version: 0.0.1 +version: 0.0.7 stability: Experimental author: Yoshikuni Jujo maintainer: Yoshikuni Jujo -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 diff --git a/src/Text/Papillon.hs b/src/Text/Papillon.hs --- a/src/Text/Papillon.hs +++ b/src/Text/Papillon.hs @@ -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 diff --git a/src/Text/Papillon/Class.hs b/src/Text/Papillon/Class.hs new file mode 100644 --- /dev/null +++ b/src/Text/Papillon/Class.hs @@ -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 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,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