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
|
module ParseLib where
|
||||||
|
|
||||||
import Ast
|
import Ast
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>),(<*>))
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Char (isSymbol)
|
import Data.Char (isSymbol)
|
||||||
import Text.Parsec hiding (newline,spaces)
|
import Text.Parsec hiding (newline,spaces)
|
||||||
|
|
||||||
reserved = [ "if", "then", "else"
|
reserveds = [ "if", "then", "else"
|
||||||
, "case", "of", "data"
|
, "case", "of", "data"
|
||||||
, "let", "in" ]
|
, "let", "in" ]
|
||||||
|
|
||||||
|
@ -25,18 +25,22 @@ lowVar = makeVar (lower <?> "lower case variable")
|
||||||
capVar :: (Monad m) => ParsecT [Char] u m String
|
capVar :: (Monad m) => ParsecT [Char] u m String
|
||||||
capVar = makeVar (upper <?> "upper case variable")
|
capVar = makeVar (upper <?> "upper case variable")
|
||||||
|
|
||||||
makeVar p = do
|
innerVarChar :: (Monad m) => ParsecT [Char] u m Char
|
||||||
c <- p
|
innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
|
||||||
cs <- many (alphaNum <|> char '_' <|> char '\'' <?> "")
|
|
||||||
guard $ c:cs `notElem` reserved
|
|
||||||
return $ c:cs
|
|
||||||
|
|
||||||
|
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 :: (Monad m) => ParsecT [Char] u m String
|
||||||
anyOp = betwixt '`' '`' var <|>
|
anyOp = betwixt '`' '`' var <|>
|
||||||
(do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
|
(do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
|
||||||
guard (op `notElem` [ "=", "..", "->", "--" ])
|
guard (op `notElem` [ "=", "..", "->", "--" ])
|
||||||
return op) <?> "infix operator"
|
return op) <?> "infix operator (e.g. x + y)"
|
||||||
|
|
||||||
arrow :: (Monad m) => ParsecT [Char] u m String
|
arrow :: (Monad m) => ParsecT [Char] u m String
|
||||||
arrow = string "->" <|> string "\8594" <?> "arrow (->)"
|
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
|
commaSep p = do
|
||||||
x <- optionMaybe p
|
x <- optionMaybe p
|
||||||
case x of
|
case x of
|
||||||
Just a -> (a:) <$> many (try (whitespace >> char ',' >> whitespace >> p))
|
Just a -> (a:) <$> many (try (whitespace >> (char ',' <?> "comma ','")) >>
|
||||||
|
whitespace >> p)
|
||||||
Nothing -> return []
|
Nothing -> return []
|
||||||
|
|
||||||
semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
||||||
semiSep1 p = do a <- p
|
semiSep1 p = do
|
||||||
(a:) <$> many (try (whitespace >> char ';' >> whitespace >> p))
|
a <- p
|
||||||
|
(a:) <$> many (try (whitespace >> (char ';' <?> "semicolon ';'")) >>
|
||||||
|
whitespace >> p)
|
||||||
|
|
||||||
pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
||||||
pipeSep1 p = do a <- p
|
pipeSep1 p = do
|
||||||
(a:) <$> many (try (whitespace >> char '|' >> whitespace >> p))
|
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 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
|
||||||
spaceSep1 p = do a <- p
|
spaceSep1 p = (:) <$> p <*> spacePrefix p
|
||||||
(a:) <$> many (try (forcedWS >> p))
|
|
||||||
|
spacePrefix p = many (try (whitespace >> p))
|
||||||
|
|
||||||
betwixt a b c = do char a ; out <- c
|
betwixt a b c = do char a ; out <- c
|
||||||
char b <?> "closing '" ++ [b] ++ "'" ; return out
|
char b <?> "closing '" ++ [b] ++ "'" ; return out
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
module ParseTypes where
|
module ParseTypes where
|
||||||
|
|
||||||
import Ast
|
import Ast
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>),(<*>))
|
||||||
import Control.Monad (liftM)
|
import Control.Monad (liftM)
|
||||||
import Data.Char (isUpper,isLower)
|
import Data.Char (isUpper,isLower)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
|
@ -37,7 +37,7 @@ typeSimple = VarPT <$> var
|
||||||
|
|
||||||
typeApp :: (Monad m) => ParsecT [Char] u m ParseType
|
typeApp :: (Monad m) => ParsecT [Char] u m ParseType
|
||||||
typeApp = do name <- capVar
|
typeApp = do name <- capVar
|
||||||
args <- many (typeSimple <|> typeUnambiguous)
|
args <- spacePrefix (typeUnambiguous <|> typeSimple)
|
||||||
return $ case args of
|
return $ case args of
|
||||||
[] -> VarPT name
|
[] -> VarPT name
|
||||||
_ -> ADTPT name args
|
_ -> ADTPT name args
|
||||||
|
@ -45,20 +45,17 @@ typeApp = do name <- capVar
|
||||||
typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
|
typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
|
||||||
typeExpr = do
|
typeExpr = do
|
||||||
t1 <- typeVar <|> typeApp <|> typeUnambiguous
|
t1 <- typeVar <|> typeApp <|> typeUnambiguous
|
||||||
whitespace ; arrow <- optionMaybe arrow ; whitespace
|
whitespace ; arr <- optionMaybe arrow ; whitespace
|
||||||
case arrow of Just _ -> LambdaPT t1 <$> typeExpr
|
case arr of Just _ -> LambdaPT t1 <$> typeExpr
|
||||||
Nothing -> return t1
|
Nothing -> return t1
|
||||||
|
|
||||||
typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
|
typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
|
||||||
typeConstructor = do
|
typeConstructor = (,) <$> capVar <*> spacePrefix (typeSimple <|> typeUnambiguous)
|
||||||
name <- capVar
|
|
||||||
args <- many (try (forcedWS >> (typeSimple <|> typeUnambiguous)))
|
|
||||||
return $ (,) name args
|
|
||||||
|
|
||||||
datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
|
datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
|
||||||
datatype = do
|
datatype = do
|
||||||
string "data" <?> "datatype definition (data T = A | B | ...)"
|
reserved "data" <?> "datatype definition (data T = A | B | ...)"
|
||||||
forcedWS ; name <- capVar ; args <- many (try (forcedWS >> lowVar))
|
forcedWS ; name <- capVar ; args <- spacePrefix lowVar
|
||||||
whitespace ; string "=" ; whitespace
|
whitespace ; string "=" ; whitespace
|
||||||
tcs <- pipeSep1 typeConstructor
|
tcs <- pipeSep1 typeConstructor
|
||||||
return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
|
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
|
_ -> Var v
|
||||||
|
|
||||||
chrTerm :: (Monad m) => ParsecT [Char] u m Expr
|
chrTerm :: (Monad m) => ParsecT [Char] u m Expr
|
||||||
chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) <?> "character"
|
chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
|
||||||
|
<?> "character"
|
||||||
|
|
||||||
|
|
||||||
-------- Complex Terms --------
|
-------- Complex Terms --------
|
||||||
|
@ -67,9 +68,9 @@ appExpr = do
|
||||||
|
|
||||||
binaryExpr = binops appExpr anyOp
|
binaryExpr = binops appExpr anyOp
|
||||||
|
|
||||||
ifExpr = do string "if" ; forcedWS ; e1 <- expr ; forcedWS
|
ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace
|
||||||
string "then" ; forcedWS ; e2 <- expr ; (forcedWS <?> "an 'else' branch")
|
reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
|
||||||
string "else" <?> "an 'else' branch" ; forcedWS ; If e1 e2 <$> expr
|
reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
|
||||||
|
|
||||||
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
||||||
whitespace
|
whitespace
|
||||||
|
@ -87,24 +88,24 @@ assignExpr = do
|
||||||
fail "matching tuples is not yet supported in this context"
|
fail "matching tuples is not yet supported in this context"
|
||||||
else fail $ "Only tuples can be matched in this context, " ++
|
else fail $ "Only tuples can be matched in this context, " ++
|
||||||
"not other abstract data types such as lists."
|
"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."
|
"only named variables, named functions, and tuples are okay."
|
||||||
|
|
||||||
letExpr = do
|
letExpr = do
|
||||||
string "let"
|
reserved "let"
|
||||||
brace <- optionMaybe . try $ do
|
brace <- optionMaybe . try $ do
|
||||||
whitespace
|
whitespace
|
||||||
char '{' <?> "a set of definitions { x = ... ; y = ... }"
|
char '{' <?> "a set of definitions { x = ... ; y = ... }"
|
||||||
case brace of
|
case brace of
|
||||||
Nothing -> do forcedWS; f <- assignExpr; forcedWS; string "in"; forcedWS;
|
Nothing -> do whitespace; f <- assignExpr; whitespace; reserved "in"; whitespace
|
||||||
Let [f] <$> expr
|
Let [f] <$> expr
|
||||||
Just '{' -> do whitespace ; fs <- semiSep1 assignExpr ; whitespace
|
Just '{' -> do whitespace ; fs <- semiSep1 assignExpr ; whitespace
|
||||||
string "}" <?> "closing bracket '}'"
|
string "}" <?> "closing bracket '}'"
|
||||||
whitespace; string "in"; forcedWS; e <- expr
|
whitespace; reserved "in"; whitespace; e <- expr
|
||||||
return (Let fs e)
|
return (Let fs e)
|
||||||
|
|
||||||
caseExpr = do
|
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 -> ... }"))
|
Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
|
||||||
where case_ = do p <- patternExpr; whitespace; arrow; whitespace
|
where case_ = do p <- patternExpr; whitespace; arrow; whitespace
|
||||||
(,) p <$> expr
|
(,) p <$> expr
|
||||||
|
@ -117,14 +118,14 @@ def = do (f,e) <- assignExpr
|
||||||
|
|
||||||
defs1 = do optional freshLine
|
defs1 = do optional freshLine
|
||||||
d <- datatype <|> def
|
d <- datatype <|> def
|
||||||
(d:) <$> many (try (freshLine >> (datatype <|> def)))
|
(d:) <$> many (try (try freshLine >> (datatype <|> def)))
|
||||||
|
|
||||||
defs = do
|
defs = do
|
||||||
(fss,ess,tss) <- unzip3 <$> defs1
|
(fss,ess,tss) <- unzip3 <$> defs1
|
||||||
let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
|
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)
|
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
|
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 =
|
patternBasic =
|
||||||
choice [ char '_' >> return PAnything
|
choice [ char '_' >> return PAnything
|
||||||
, do x@(c:_) <- var
|
, 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
|
else return $ PVar x
|
||||||
]
|
]
|
||||||
|
|
||||||
|
@ -24,14 +24,6 @@ patternTuple :: Monad m => ParsecT [Char] u m Pattern
|
||||||
patternTuple = do ps <- parens (commaSep patternExpr)
|
patternTuple = do ps <- parens (commaSep patternExpr)
|
||||||
return $ case ps of { [p] -> p; _ -> ptuple ps }
|
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 :: Monad m => ParsecT [Char] u m Pattern
|
||||||
patternList = plist <$> braces (commaSep patternExpr)
|
patternList = plist <$> braces (commaSep patternExpr)
|
||||||
|
|
||||||
|
@ -39,4 +31,4 @@ patternTerm :: Monad m => ParsecT [Char] u m Pattern
|
||||||
patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
|
patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
|
||||||
|
|
||||||
patternExpr :: Monad m => ParsecT [Char] u m 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