module Language.Haskell.ParseExp
( parseExp
, parsePat
) where
import Control.Monad
import Data.Char
import Language.Haskell.TH
import Text.ParserCombinators.ReadP
skipSpace :: ReadP ()
skipSpace = void $ munch isSpace
nameChar :: Char -> Bool
nameChar c = isAlphaNum c || elem c ['\'','_']
name :: ReadP Name
name = do
skipSpace
h <- get
guard ('a' <= h && h <= 'z')
rest <- munch nameChar
return $ mkName (h:rest)
variable :: ReadP Exp
variable = fmap VarE name
constructor :: ReadP Exp
constructor = do
skipSpace
h <- get
guard ('A' <= h && h <= 'Z')
rest <- munch nameChar
return $ ConE $ mkName (h:rest)
integer :: Bool -> ReadP Integer
integer first = do
c:_ <- look
guard (first || isNumber c)
readS_to_P reads
literal :: Bool -> ReadP Exp
literal first
= fmap (LitE . IntegerL) (integer first)
<++ fmap (LitE . CharL) (readS_to_P reads)
<++ fmap (LitE . StringL) (readS_to_P reads)
expressionList :: ReadP [Exp]
expressionList = expression `sepBy` char ','
list :: ReadP Exp
list = fmap ListE $ between (char '[') (char ']') expressionList
tuple :: ReadP Exp
tuple = do
es <- between (char '(') (char ')') (skipSpace >> expressionList)
case es of
[] -> return $ ConE $ mkName "()"
[e] -> return e
_ -> return $ TupE es
expPart :: Bool -> ReadP Exp
expPart first = do
skipSpace
pfail <++ variable
<++ constructor
<++ list
<++ literal first
<++ tuple
expression :: ReadP Exp
expression = do
skipSpace
f <- expPart True
args <- many (expPart False)
let expr = foldl AppE f args
skipSpace
return expr
parseExp :: String -> Either String Exp
parseExp str = case [expr | (expr,"") <- readP_to_S expression str] of
[expr] -> return expr
_ -> fail $ "parseExp: cannot parse '" ++ str ++ "'"
++ " (parseExp only supports a limited subset of Haskell)"
parsePat :: String -> Either String Pat
parsePat str = case [pat | (pat,"") <- readP_to_S name str] of
[pat] -> return (VarP pat)
_ -> fail $ "parsePat: cannot parse '" ++ str ++ "'"
++ " (parsePat only supports a limited subset of Haskell)"