Fix bugs in parser. Also adds pattern matching in anonymous functions. Still need to work on error messages though.
This commit is contained in:
parent
c6a5ef4a4d
commit
110944c454
4 changed files with 55 additions and 49 deletions
|
@ -2,12 +2,12 @@
|
|||
module ParseLib where
|
||||
|
||||
import Ast
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative ((<$>),(<*>))
|
||||
import Control.Monad
|
||||
import Data.Char (isSymbol)
|
||||
import Text.Parsec hiding (newline,spaces)
|
||||
|
||||
reserved = [ "if", "then", "else"
|
||||
reserveds = [ "if", "then", "else"
|
||||
, "case", "of", "data"
|
||||
, "let", "in" ]
|
||||
|
||||
|
@ -25,18 +25,22 @@ lowVar = makeVar (lower <?> "lower case variable")
|
|||
capVar :: (Monad m) => ParsecT [Char] u m String
|
||||
capVar = makeVar (upper <?> "upper case variable")
|
||||
|
||||
makeVar p = do
|
||||
c <- p
|
||||
cs <- many (alphaNum <|> char '_' <|> char '\'' <?> "")
|
||||
guard $ c:cs `notElem` reserved
|
||||
return $ c:cs
|
||||
innerVarChar :: (Monad m) => ParsecT [Char] u m Char
|
||||
innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
|
||||
|
||||
makeVar p = do v <- (:) <$> p <*> many innerVarChar
|
||||
guard (v `notElem` reserveds)
|
||||
return v
|
||||
|
||||
reserved word =
|
||||
try (string word >> notFollowedBy innerVarChar) >> return word
|
||||
<?> "reserved word '" ++ word ++ "'"
|
||||
|
||||
anyOp :: (Monad m) => ParsecT [Char] u m String
|
||||
anyOp = betwixt '`' '`' var <|>
|
||||
(do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
|
||||
guard (op `notElem` [ "=", "..", "->", "--" ])
|
||||
return op) <?> "infix operator"
|
||||
return op) <?> "infix operator (e.g. x + y)"
|
||||
|
||||
arrow :: (Monad m) => ParsecT [Char] u m String
|
||||
arrow = string "->" <|> string "\8594" <?> "arrow (->)"
|
||||
|
@ -45,20 +49,32 @@ commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
|||
commaSep p = do
|
||||
x <- optionMaybe p
|
||||
case x of
|
||||
Just a -> (a:) <$> many (try (whitespace >> char ',' >> whitespace >> p))
|
||||
Just a -> (a:) <$> many (try (whitespace >> (char ',' <?> "comma ','")) >>
|
||||
whitespace >> p)
|
||||
Nothing -> return []
|
||||
|
||||
semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
||||
semiSep1 p = do a <- p
|
||||
(a:) <$> many (try (whitespace >> char ';' >> whitespace >> p))
|
||||
semiSep1 p = do
|
||||
a <- p
|
||||
(a:) <$> many (try (whitespace >> (char ';' <?> "semicolon ';'")) >>
|
||||
whitespace >> p)
|
||||
|
||||
pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
||||
pipeSep1 p = do a <- p
|
||||
(a:) <$> many (try (whitespace >> char '|' >> whitespace >> p))
|
||||
pipeSep1 p = do
|
||||
a <- p
|
||||
(a:) <$> many (try (whitespace >> (char '|' <?> "type divider '|'")) >>
|
||||
whitespace >> p)
|
||||
|
||||
consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
||||
consSep1 p = do
|
||||
a <- p
|
||||
(a:) <$> many (try (whitespace >> (char ':' <?> "cons operator ':'")) >>
|
||||
whitespace >> p)
|
||||
|
||||
spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
||||
spaceSep1 p = do a <- p
|
||||
(a:) <$> many (try (forcedWS >> p))
|
||||
spaceSep1 p = (:) <$> p <*> spacePrefix p
|
||||
|
||||
spacePrefix p = many (try (whitespace >> p))
|
||||
|
||||
betwixt a b c = do char a ; out <- c
|
||||
char b <?> "closing '" ++ [b] ++ "'" ; return out
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
module ParseTypes where
|
||||
|
||||
import Ast
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative ((<$>),(<*>))
|
||||
import Control.Monad (liftM)
|
||||
import Data.Char (isUpper,isLower)
|
||||
import Data.Maybe (fromMaybe)
|
||||
|
@ -37,7 +37,7 @@ typeSimple = VarPT <$> var
|
|||
|
||||
typeApp :: (Monad m) => ParsecT [Char] u m ParseType
|
||||
typeApp = do name <- capVar
|
||||
args <- many (typeSimple <|> typeUnambiguous)
|
||||
args <- spacePrefix (typeUnambiguous <|> typeSimple)
|
||||
return $ case args of
|
||||
[] -> VarPT name
|
||||
_ -> ADTPT name args
|
||||
|
@ -45,20 +45,17 @@ typeApp = do name <- capVar
|
|||
typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
|
||||
typeExpr = do
|
||||
t1 <- typeVar <|> typeApp <|> typeUnambiguous
|
||||
whitespace ; arrow <- optionMaybe arrow ; whitespace
|
||||
case arrow of Just _ -> LambdaPT t1 <$> typeExpr
|
||||
Nothing -> return t1
|
||||
whitespace ; arr <- optionMaybe arrow ; whitespace
|
||||
case arr of Just _ -> LambdaPT t1 <$> typeExpr
|
||||
Nothing -> return t1
|
||||
|
||||
typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
|
||||
typeConstructor = do
|
||||
name <- capVar
|
||||
args <- many (try (forcedWS >> (typeSimple <|> typeUnambiguous)))
|
||||
return $ (,) name args
|
||||
typeConstructor = (,) <$> capVar <*> spacePrefix (typeSimple <|> typeUnambiguous)
|
||||
|
||||
datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
|
||||
datatype = do
|
||||
string "data" <?> "datatype definition (data T = A | B | ...)"
|
||||
forcedWS ; name <- capVar ; args <- many (try (forcedWS >> lowVar))
|
||||
reserved "data" <?> "datatype definition (data T = A | B | ...)"
|
||||
forcedWS ; name <- capVar ; args <- spacePrefix lowVar
|
||||
whitespace ; string "=" ; whitespace
|
||||
tcs <- pipeSep1 typeConstructor
|
||||
return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
|
||||
|
|
|
@ -32,7 +32,8 @@ toVar v = case v of "True" -> Boolean True
|
|||
_ -> Var v
|
||||
|
||||
chrTerm :: (Monad m) => ParsecT [Char] u m Expr
|
||||
chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) <?> "character"
|
||||
chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
|
||||
<?> "character"
|
||||
|
||||
|
||||
-------- Complex Terms --------
|
||||
|
@ -67,9 +68,9 @@ appExpr = do
|
|||
|
||||
binaryExpr = binops appExpr anyOp
|
||||
|
||||
ifExpr = do string "if" ; forcedWS ; e1 <- expr ; forcedWS
|
||||
string "then" ; forcedWS ; e2 <- expr ; (forcedWS <?> "an 'else' branch")
|
||||
string "else" <?> "an 'else' branch" ; forcedWS ; If e1 e2 <$> expr
|
||||
ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace
|
||||
reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
|
||||
reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
|
||||
|
||||
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
||||
whitespace
|
||||
|
@ -87,24 +88,24 @@ assignExpr = do
|
|||
fail "matching tuples is not yet supported in this context"
|
||||
else fail $ "Only tuples can be matched in this context, " ++
|
||||
"not other abstract data types such as lists."
|
||||
_ -> fail $ "Variables in assign statement are not acceptable: " ++
|
||||
_ -> fail $ "Left-hand side of assign statement is not acceptable: " ++
|
||||
"only named variables, named functions, and tuples are okay."
|
||||
|
||||
letExpr = do
|
||||
string "let"
|
||||
reserved "let"
|
||||
brace <- optionMaybe . try $ do
|
||||
whitespace
|
||||
char '{' <?> "a set of definitions { x = ... ; y = ... }"
|
||||
case brace of
|
||||
Nothing -> do forcedWS; f <- assignExpr; forcedWS; string "in"; forcedWS;
|
||||
Nothing -> do whitespace; f <- assignExpr; whitespace; reserved "in"; whitespace
|
||||
Let [f] <$> expr
|
||||
Just '{' -> do whitespace ; fs <- semiSep1 assignExpr ; whitespace
|
||||
string "}" <?> "closing bracket '}'"
|
||||
whitespace; string "in"; forcedWS; e <- expr
|
||||
whitespace; reserved "in"; whitespace; e <- expr
|
||||
return (Let fs e)
|
||||
|
||||
caseExpr = do
|
||||
string "case"; forcedWS; e <- expr; forcedWS; string "of"; whitespace
|
||||
reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
|
||||
Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
|
||||
where case_ = do p <- patternExpr; whitespace; arrow; whitespace
|
||||
(,) p <$> expr
|
||||
|
@ -117,14 +118,14 @@ def = do (f,e) <- assignExpr
|
|||
|
||||
defs1 = do optional freshLine
|
||||
d <- datatype <|> def
|
||||
(d:) <$> many (try (freshLine >> (datatype <|> def)))
|
||||
(d:) <$> many (try (try freshLine >> (datatype <|> def)))
|
||||
|
||||
defs = do
|
||||
(fss,ess,tss) <- unzip3 <$> defs1
|
||||
let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
|
||||
optional freshLine ; optional whitespace ; eof
|
||||
optional freshLine ; optional spaces ; eof
|
||||
return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
|
||||
|
||||
toDefs source = case parse defs "Elm code" source of
|
||||
toDefs source = case parse defs "" source of
|
||||
Right result -> Right result
|
||||
Left err -> Left $ show err
|
||||
Left err -> Left $ "Parse error at " ++ show err
|
||||
|
|
|
@ -16,7 +16,7 @@ patternBasic :: Monad m => ParsecT [Char] u m Pattern
|
|||
patternBasic =
|
||||
choice [ char '_' >> return PAnything
|
||||
, do x@(c:_) <- var
|
||||
if isUpper c then PData x <$> patternTerm `endBy` whitespace
|
||||
if isUpper c then PData x <$> spacePrefix patternTerm
|
||||
else return $ PVar x
|
||||
]
|
||||
|
||||
|
@ -24,14 +24,6 @@ patternTuple :: Monad m => ParsecT [Char] u m Pattern
|
|||
patternTuple = do ps <- parens (commaSep patternExpr)
|
||||
return $ case ps of { [p] -> p; _ -> ptuple ps }
|
||||
|
||||
patternCons :: Monad m => ParsecT [Char] u m Pattern
|
||||
patternCons = do
|
||||
p <- patternTerm
|
||||
colon <- optionMaybe (char ':' <?> "more complicated pattern")
|
||||
case colon of
|
||||
Just ':' -> pcons p <$> patternExpr
|
||||
Nothing -> return p
|
||||
|
||||
patternList :: Monad m => ParsecT [Char] u m Pattern
|
||||
patternList = plist <$> braces (commaSep patternExpr)
|
||||
|
||||
|
@ -39,4 +31,4 @@ patternTerm :: Monad m => ParsecT [Char] u m Pattern
|
|||
patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
|
||||
|
||||
patternExpr :: Monad m => ParsecT [Char] u m Pattern
|
||||
patternExpr = patternTuple <|> patternList <|> patternCons <?> "pattern"
|
||||
patternExpr = foldl1 pcons <$> consSep1 patternTerm <?> "pattern"
|
||||
|
|
Loading…
Reference in a new issue