{-# 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