diff --git a/elm/src/Parse/ParseLib.hs b/elm/src/Parse/ParseLib.hs index c1e2657..dba19e6 100644 --- a/elm/src/Parse/ParseLib.hs +++ b/elm/src/Parse/ParseLib.hs @@ -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 diff --git a/elm/src/Parse/ParseTypes.hs b/elm/src/Parse/ParseTypes.hs index 9ed14ee..794e2b1 100644 --- a/elm/src/Parse/ParseTypes.hs +++ b/elm/src/Parse/ParseTypes.hs @@ -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) diff --git a/elm/src/Parse/Parser.hs b/elm/src/Parse/Parser.hs index 3b239cd..1718bb1 100644 --- a/elm/src/Parse/Parser.hs +++ b/elm/src/Parse/Parser.hs @@ -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 diff --git a/elm/src/Parse/Patterns.hs b/elm/src/Parse/Patterns.hs index d33e7ed..23e9693 100644 --- a/elm/src/Parse/Patterns.hs +++ b/elm/src/Parse/Patterns.hs @@ -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"