module MonadLab.MLabParser (
mlabParser
) where
import MonadLab.CommonTypes
import MonadLab.MonadLab
import Language.Haskell.TH
import MonadLab.TypeParser
import Text.ParserCombinators.Parsec hiding (State)
import Text.ParserCombinators.Parsec.Token
import Text.ParserCombinators.Parsec.Language
mlabParser :: String -> (MonadName,[Layer])
mlabParser s = case (parse monadSpecParser "" s) of
Left err -> error $ "MonadLab monad spec parser error " ++ show err
Right r -> r
lexer :: TokenParser ()
lexer = makeTokenParser
(emptyDef { reservedNames = ["monad"]
, reservedOpNames = ["=","+"]
});
layerSpecParser :: Parser Layer
layerSpecParser = try (
do{ reserved lexer "List"
; return List
}
)
<|>
try (
do{ reserved lexer "Io"
; return Io
}
)
<|>
try (
do{ reserved lexer "ErrorT"
; t <- parens lexer (many (noneOf ")"))
; n <- identifier lexer
; return (ErrorT n (typeParser t))
}
)
<|>
try (
do{ reserved lexer "StateT"
; t <- parens lexer (many (noneOf ")"))
; n <- identifier lexer
; return (StateT n (typeParser t))
}
)
<|>
try (
do{ reserved lexer "EnvT"
; t <- parens lexer (many (noneOf ")"))
; n <- identifier lexer
; return (EnvT n (typeParser t))
}
)
<|>
try (
do{ reserved lexer "WriterT"
; t <- parens lexer (many (noneOf ")"))
; n <- identifier lexer
; return (WriterT n (typeParser t))
}
)
<|>
try (
do{ reserved lexer "ContT"
; t <- parens lexer (many (noneOf ")"))
; return (ContT (typeParser t))
}
)
<?>
"layer spec"
monadSpecParser :: Parser (MonadName,[Layer])
monadSpecParser = do{ reserved lexer "monad"
; mName <- identifier lexer
; reservedOp lexer "="
; layerSpecs <- sepBy layerSpecParser (reservedOp lexer "+")
; eof
; return (mName,layerSpecs)
}