packages feed

Elm 0.1.2.1 → 0.2.0

raw patch · 17 files changed

+648/−679 lines, 17 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

Elm.cabal view
@@ -1,6 +1,6 @@  Name:                Elm-Version:             0.1.2.1+Version:             0.2.0 Synopsis:            The Elm language module. Description:         Elm aims to make client-side web-development more pleasant.                      It is a statically/strongly typed, functional reactive@@ -31,7 +31,6 @@ Library   exposed-modules:     Language.Elm,                        Language.Elm.Quasi-  ghc-options:         -O2   Hs-Source-Dirs:      src, src/Parse, src/Types   other-modules:       Ast,                        CompileToJS,@@ -40,14 +39,11 @@                        Guid,                        Initialize,                        Rename,-                       Binop,-                       Combinators,-                       Lexer,-                       ParsePatterns,+                       Binops,+                       Patterns,                        Parser,-                       ParserLib,+                       ParseLib,                        ParseTypes,-                       Tokens,                        Types,                        Constrain,                        Hints,@@ -68,7 +64,6 @@  Executable elm   Main-is:             Compiler.hs-  ghc-options:         -O2   Hs-Source-Dirs:      src, src/Parse, src/Types   other-modules:       Ast,                        CompileToJS,@@ -77,14 +72,11 @@                        Guid,                        Initialize,                        Rename,-                       Binop,-                       Combinators,-                       Lexer,-                       ParsePatterns,+                       Binops,+                       Patterns,                        Parser,-                       ParserLib,+                       ParseLib,                        ParseTypes,-                       Tokens,                        Types,                        Constrain,                        Hints,
src/Ast.hs view
@@ -1,8 +1,11 @@ 
 module Ast where
 
+import Data.Char (isDigit)
+import Data.List (intercalate)
+
 data Pattern = PData String [Pattern] | PVar String | PAnything
-               deriving (Show, Eq)
+               deriving (Eq)
 
 data Expr = Number Int
           | Chr Char
@@ -37,3 +40,17 @@ pnil      = PData "Nil" []
 plist     = foldr pcons pnil
 ptuple es = PData ("Tuple" ++ show (length es)) es
+
+instance Show Pattern where
+    show (PVar x)  = x
+    show PAnything = "_"
+    show (PData "Cons" [hd@(PData "Cons" _),tl]) =
+        parens (show hd) ++ " : " ++ show tl
+            where parens s = "(" ++ s ++ ")"
+    show (PData "Cons" [hd,tl]) = show hd ++ " : " ++ show tl
+    show (PData "Nil" []) = "[]"
+    show (PData name ps) =
+        if take 5 name == "Tuple" && all isDigit (drop 5 name) then
+            parens . intercalate ", " $ map show ps
+        else (if null ps then id else parens) $ unwords (name : map show ps)
+            where parens s = "(" ++ s ++ ")"
src/CompileToJS.hs view
@@ -1,92 +1,95 @@-
-module CompileToJS (compile, compileToJS) where
-
-import Ast
-import Control.Monad (liftM,(<=<),join)
-import Data.Char (isAlpha)
-import Data.List (intercalate,sortBy)
-import Data.Map (toList)
-
-import Initialize
-
-
-compile = (return . addMain . toJS) <=< initialize
-compileToJS = addMain . either (\err -> "text('"++err++"')") toJS
-addMain body = "function main(){return " ++ body ++ ";}"
-
-parens = ("("++) . (++")")
-braces = ("{"++) . (++"}")
-jsList = ("["++) . (++"]") . intercalate ","
-jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"
-assign x e = "var " ++ x ++ "=" ++ e ++ ";"
-ret e = "return "++ e ++";"
-iff a b c = a ++ "?" ++ b ++ ":" ++ c
-
-toJS expr =
-    case expr of
-      Number n -> show n
-      Var x -> x
-      Chr c -> show c
-      Str s -> toJS . list $ map Chr s
-      Boolean b -> if b then "true" else "false"
-      Range lo hi -> jsRange (toJS lo) (toJS hi)
-      Access e lbl -> toJS e ++ "." ++ lbl
-      Binop op e1 e2 -> binop op (toJS e1) (toJS e2)
-      If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)
-      Lambda v e -> jsFunc v $ ret (toJS e)
-      App (Var "toText") (Str s) -> show s
-      App (Var "link") (Str s) -> "link(" ++ show s ++ ")"
-      App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"
-      App e1 e2 -> toJS e1 ++ parens (toJS e2)
-      Let defs e -> jsLet defs e
-      Case e cases -> jsCase e cases
-      Data name es -> jsList $ show name : map toJS es
-
-jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()"
-    where defs' = concatMap toDef $ sortBy f defs
-          f a b = compare (isLambda a) (isLambda b)
-          isLambda (_, Lambda _ _) = 1
-          isLambda _ = 0
-          toDef (f, Lambda x e) =
-              "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"
-          toDef (x, e) = assign x (toJS e)
-
-jsCase e  [c]  = jsMatch c ++ parens (toJS e)
-jsCase e cases = "(function(){" ++
-                 assign "v" (toJS e) ++
-                 assign "c" jsCases  ++
-                 "for(var i=c.length;i--;){" ++
-                 assign "r" "c[i](v)" ++
-                 "if(r!==undefined){return r;}}}())"
-    where jsCases = jsList $ map jsMatch (reverse cases)
-
-jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e
-match p v hole =
-    case p of
-      PAnything -> hole
-      PVar x -> assign x v ++ hole
-      PData name ps ->
-          "if(" ++ show name ++ "!==" ++ v ++
-          "[0]){return undefined;}else{"++body++"}"
-              where matches = zipWith match ps vs
-                    vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]
-                    body = foldr ($) hole matches
-
-jsNil         = "[\"Nil\"]"
-jsCons  e1 e2 = jsList [ show "Cons", e1, e2 ]
-jsRange e1 e2 = (++"()") . jsFunc "" $
-                assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
-                "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" ++
-                ret "lst"
-
-binop (o:p) e1 e2
-    | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
-    | otherwise = case o:p of
-                    ":" -> jsCons e1 e2
-                    "++" -> append e1 e2
-                    "$" -> e1 ++ parens e2
-                    "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
-                    "/=" -> e1 ++ "!==" ++ e2
-                    _ -> e1 ++ (o:p) ++ e2
-
++module CompileToJS (compile, compileToJS) where++import Ast+import Control.Monad (liftM,(<=<),join)+import Data.Char (isAlpha)+import Data.List (intercalate,sortBy)+import Data.Map (toList)++import Initialize++showErr :: String -> String+showErr err = "text(monospace(" ++ msg ++ "))"+    where msg = show . concatMap (++"<br>") . lines $ err++compile = (return . addMain . toJS) <=< initialize+compileToJS = addMain . either showErr toJS+addMain body = "function main(){return " ++ body ++ ";}"++parens = ("("++) . (++")")+braces = ("{"++) . (++"}")+jsList = ("["++) . (++"]") . intercalate ","+jsFunc args body = "function(" ++ args ++ "){" ++ body ++ "}"+assign x e = "var " ++ x ++ "=" ++ e ++ ";"+ret e = "return "++ e ++";"+iff a b c = a ++ "?" ++ b ++ ":" ++ c++toJS expr =+    case expr of+      Number n -> show n+      Var x -> x+      Chr c -> show c+      Str s -> toJS . list $ map Chr s+      Boolean b -> if b then "true" else "false"+      Range lo hi -> jsRange (toJS lo) (toJS hi)+      Access e lbl -> toJS e ++ "." ++ lbl+      Binop op e1 e2 -> binop op (toJS e1) (toJS e2)+      If eb et ef -> parens $ iff (toJS eb) (toJS et) (toJS ef)+      Lambda v e -> jsFunc v $ ret (toJS e)+      App (Var "toText") (Str s) -> show s+      App (Var "link") (Str s) -> "link(" ++ show s ++ ")"+      App (Var "plainText") (Str s) -> "plainText(" ++ show s ++ ")"+      App e1 e2 -> toJS e1 ++ parens (toJS e2)+      Let defs e -> jsLet defs e+      Case e cases -> jsCase e cases+      Data name es -> jsList $ show name : map toJS es++jsLet defs e' = jsFunc "" (defs' ++ ret (toJS e')) ++ "()"+    where defs' = concatMap toDef $ sortBy f defs+          f a b = compare (isLambda a) (isLambda b)+          isLambda (_, Lambda _ _) = 1+          isLambda _ = 0+          toDef (f, Lambda x e) =+              "function " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"+          toDef (x, e) = assign x (toJS e)++jsCase e  [c]  = jsMatch c ++ parens (toJS e)+jsCase e cases = "(function(){" +++                 assign "v" (toJS e) +++                 assign "c" jsCases  +++                 "for(var i=c.length;i--;){" +++                 assign "r" "c[i](v)" +++                 "if(r!==undefined){return r;}}}())"+    where jsCases = jsList $ map jsMatch (reverse cases)++jsMatch (p,e) = jsFunc "v" . match p "v" . ret $ toJS e+match p v hole =+    case p of+      PAnything -> hole+      PVar x -> assign x v ++ hole+      PData name ps ->+          "if(" ++ show name ++ "!==" ++ v +++          "[0]){return undefined;}else{"++body++"}"+              where matches = zipWith match ps vs+                    vs = map (\i -> v++"["++show (i+1)++"]") [0..length ps-1]+                    body = foldr ($) hole matches++jsNil         = "[\"Nil\"]"+jsCons  e1 e2 = jsList [ show "Cons", e1, e2 ]+jsRange e1 e2 = (++"()") . jsFunc "" $+                assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil +++                "do{" ++ assign "lst" (jsCons "hi" "lst") ++ "}while(hi-->lo)" +++                ret "lst"++binop (o:p) e1 e2+    | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2+    | otherwise = case o:p of+                    ":" -> jsCons e1 e2+                    "++" -> append e1 e2+                    "$" -> e1 ++ parens e2+                    "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")+                    "/=" -> e1 ++ "!==" ++ e2+                    _ -> e1 ++ (o:p) ++ e2+ append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)
src/Compiler.hs view
@@ -1,49 +1,49 @@-module Main where
-
-import Data.List (isPrefixOf)
-import CompileToJS
-import GenerateHtml
-import System.Environment
-import Text.Blaze.Html.Renderer.String (renderHtml)
-
-main :: IO ()
-main = getArgs >>= parse
-
-parse :: [String] -> IO ()
-parse ("--help":_) = putStrLn usage
-parse ("--version":_) = putStrLn "The Elm Compiler 0.1.2.1"
-parse [loc,file]
-  | "--runtime-location=" `isPrefixOf` loc =
-      produceHtml (tail $ dropWhile (/='=') loc) file
-  | otherwise = putStrLn usageMini
-parse [file] = produceHtml "elm-mini.js" file
-parse _ = putStrLn usageMini
-
-produceHtml :: String -> FilePath -> IO ()
-produceHtml libLoc file = do
-  code <- readFile file
-  let name = takeWhile (/='.') file
-  case compile code of
-    Left err -> putStrLn err
-    Right jsCode -> writeFile (name ++ ".html") . renderHtml $
-                    generateHtml libLoc name code
-
-usageMini :: String
-usageMini =
-  "Usage: elm [OPTIONS] FILE\n\
-  \Try `elm --help' for more information."
-
-usage :: String
-usage =
-  "Usage: elm [OPTIONS] FILE\n\
-  \Compile .elm files to .html files.\n\
-  \Example: elm --runtime-location=../elm-mini.js main.elm\n\
-  \\n\
-  \Resource Locations:\n\
-  \  --runtime-location   set the location of the Elm runtime (elm-mini.js)\n\
-  \\n\
-  \Compiler Information:\n\
-  \  --version            print the version information and exit\n\
-  \  --help               display this help and exit\n\
-  \\n\
+module Main where++import Data.List (isPrefixOf)+import CompileToJS+import GenerateHtml+import System.Environment+import Text.Blaze.Html.Renderer.String (renderHtml)++main :: IO ()+main = getArgs >>= parse++parse :: [String] -> IO ()+parse ("--help":_) = putStrLn usage+parse ("--version":_) = putStrLn "The Elm Compiler 0.2.0"+parse [loc,file]+  | "--runtime-location=" `isPrefixOf` loc =+      produceHtml (tail $ dropWhile (/='=') loc) file+  | otherwise = putStrLn usageMini+parse [file] = produceHtml "elm-mini.js" file+parse _ = putStrLn usageMini++produceHtml :: String -> FilePath -> IO ()+produceHtml libLoc file = do+  code <- readFile file+  let name = takeWhile (/='.') file+  case compile code of+    Left err -> putStrLn err+    Right jsCode -> writeFile (name ++ ".html") . renderHtml $+                    generateHtml libLoc name code++usageMini :: String+usageMini =+  "Usage: elm [OPTIONS] FILE\n\+  \Try `elm --help' for more information."++usage :: String+usage =+  "Usage: elm [OPTIONS] FILE\n\+  \Compile .elm files to .html files.\n\+  \Example: elm --runtime-location=../elm-mini.js main.elm\n\+  \\n\+  \Resource Locations:\n\+  \  --runtime-location   set the location of the Elm runtime (elm-mini.js)\n\+  \\n\+  \Compiler Information:\n\+  \  --version            print the version information and exit\n\+  \  --help               display this help and exit\n\+  \\n\   \Elm home page: <http://elm-lang.org>"
src/Initialize.hs view
@@ -1,107 +1,100 @@-module Initialize (initialize) where
-
-import Ast
-import Control.Arrow (first, second)
-import Control.Monad
-import Data.Char (isAlpha)
-import Data.Maybe (mapMaybe)
-import Data.Either (rights)
-import Lexer
-import Parser (toExpr,toDefs)
-import Rename (rename)
-
-import Unify
-import Hints
-
-{--
-initialize str = do
- (expr, hints') <- toDefs =<< tokenize str
- let expr' = rename expr
- subs <- unify (liftM2 (++) hints hints') expr'
- return (seq subs expr')
---}
-
-initialize str = do
- (expr, hints') <- toDefs =<< tokenize str
- let expr' = rename expr
- subs <- unify (liftM2 (++) hints hints') expr'
- let init = simp_loop expr'
- return (seq subs init)
-
-simp_loop exp = if exp == exp' then exp' else simp_loop exp'
-    where exp' = simp exp
-
-simp expr =
-    let f = simp in
-    case expr of
-      Range e1 e2 -> Range (f e1) (f e2)
-      Binop op e1 e2 -> simp_binop op (f e1) (f e2)
-      Lambda x e -> Lambda x (f e)
-      App e1 e2 -> App (f e1) (f e2)
-      If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
-      Let defs e -> Let (map (second f) defs) (f e)
-      Data name es -> Data name (map f es)
-      Case e cases -> Case (f e) (map (second f) cases)
-      _ -> expr
-
-simp_if (Boolean b) e2 e3 = if b then e2 else e3
-simp_if a b c = If a b c
-
-simp_binop "mod" (Number n) (Number m) = Number (mod n m)
-simp_binop "mod" e1 e2 = Binop "mod" e1 e2
-simp_binop str e1 e2
-    | isAlpha (head str) || '_' == head str = App (App (Var str) e1) e2
-    | otherwise = binop str e1 e2
-
-binop op (Number n) (Number m) = f n m
-    where f a b = case op of
-                    { "+" -> Number $ (+) a b
-                    ; "-" -> Number $ (-) a b
-                    ; "*" -> Number $ (*) a b
-                    --; "/" -> Number $ div a b
-                    ; "<" -> Boolean $ a < b
-                    ; ">" -> Boolean $ a < b
-                    ; "<=" -> Boolean $ a <= b
-                    ; ">=" -> Boolean $ a >= b
-                    ; "==" -> Boolean $ a == b
-                    ; "/=" -> Boolean $ a /= b
-                    ;  _  -> Binop op (Number n) (Number m) }
-
-binop "-" e (Number 0) = e
-binop "+" (Number 0) e = e
-binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e
-binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e
-
-binop "/" e (Number 1) = e
-binop "*" (Number 0) e = Number 0
-binop "*" (Number 1) e = e
-binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e
-binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e
-
-binop "+" e (Number n) = binop "+" (Number n) e
-binop "*" e (Number n) = binop "*" (Number n) e
-
-binop op (Boolean n) (Boolean m) = f n m
-    where f a b = case op of { "&&" -> Boolean $ (&&) n m
-                             ; "||" -> Boolean $ (||) n m
-                             ;  _  -> Binop op (Boolean n) (Boolean m) }
-
-binop "&&" (Boolean  True) e = e
-binop "&&" (Boolean False) e = Boolean False
-binop "||" (Boolean  True) e = Boolean True
-binop "||" (Boolean False) e = e
-
-binop op e (Boolean n) = binop op (Boolean n) e
-
-binop ":" h t = cons h t
-binop "++" (Str s1) (Str s2) = Str $ s1 ++ s2
-binop "++" (Str s1) (Binop "++" (Str s2) e) = Binop "++" (Str $ s1 ++ s2) e
-binop "++" (Binop "++" e (Str s1)) (Str s2) = Binop "++" e (Str $ s1 ++ s2)
-binop "++" (Data "Nil" []) e = e
-binop "++" e (Data "Nil" []) = e
-binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]
-
-binop "$" e1 e2 = App e1 e2
-
-binop op e1 e2 = Binop op e1 e2
+module Initialize (initialize) where++import Ast+import Control.Arrow (first, second)+import Control.Monad+import Data.Char (isAlpha)+import Data.Maybe (mapMaybe)+import Data.Either (rights)++import Parser (toDefs)+import Rename (rename)++import Unify+import Hints+++initialize str = do+ (expr, hints') <- toDefs str+ let expr' = rename expr+ subs <- unify (liftM2 (++) hints hints') expr'+ let init = simp_loop expr'+ return (seq subs init)++simp_loop exp = if exp == exp' then exp' else simp_loop exp'+    where exp' = simp exp++simp expr =+    let f = simp in+    case expr of+      Range e1 e2 -> Range (f e1) (f e2)+      Binop op e1 e2 -> simp_binop op (f e1) (f e2)+      Lambda x e -> Lambda x (f e)+      App e1 e2 -> App (f e1) (f e2)+      If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)+      Let defs e -> Let (map (second f) defs) (f e)+      Data name es -> Data name (map f es)+      Case e cases -> Case (f e) (map (second f) cases)+      _ -> expr++simp_if (Boolean b) e2 e3 = if b then e2 else e3+simp_if a b c = If a b c++simp_binop "mod" (Number n) (Number m) = Number (mod n m)+simp_binop "mod" e1 e2 = Binop "mod" e1 e2+simp_binop str e1 e2+    | isAlpha (head str) || '_' == head str = App (App (Var str) e1) e2+    | otherwise = binop str e1 e2++binop op (Number n) (Number m) = f n m+    where f a b = case op of+                    { "+" -> Number $ (+) a b+                    ; "-" -> Number $ (-) a b+                    ; "*" -> Number $ (*) a b+                    --; "/" -> Number $ div a b+                    ; "<" -> Boolean $ a < b+                    ; ">" -> Boolean $ a < b+                    ; "<=" -> Boolean $ a <= b+                    ; ">=" -> Boolean $ a >= b+                    ; "==" -> Boolean $ a == b+                    ; "/=" -> Boolean $ a /= b+                    ;  _  -> Binop op (Number n) (Number m) }++binop "-" e (Number 0) = e+binop "+" (Number 0) e = e+binop "+" (Number n) (Binop "+" (Number m) e) = binop "+" (Number (n+m)) e+binop "+" (Number n) (Binop "+" e (Number m)) = binop "+" (Number (n+m)) e++binop "/" e (Number 1) = e+binop "*" (Number 0) e = Number 0+binop "*" (Number 1) e = e+binop "*" (Number n) (Binop "*" (Number m) e) = binop "*" (Number (n*m)) e+binop "*" (Number n) (Binop "*" e (Number m)) = binop "*" (Number (n*m)) e++binop "+" e (Number n) = binop "+" (Number n) e+binop "*" e (Number n) = binop "*" (Number n) e++binop op (Boolean n) (Boolean m) = f n m+    where f a b = case op of { "&&" -> Boolean $ (&&) n m+                             ; "||" -> Boolean $ (||) n m+                             ;  _  -> Binop op (Boolean n) (Boolean m) }++binop "&&" (Boolean  True) e = e+binop "&&" (Boolean False) e = Boolean False+binop "||" (Boolean  True) e = Boolean True+binop "||" (Boolean False) e = e++binop op e (Boolean n) = binop op (Boolean n) e++binop ":" h t = cons h t+binop "++" (Str s1) (Str s2) = Str $ s1 ++ s2+binop "++" (Str s1) (Binop "++" (Str s2) e) = Binop "++" (Str $ s1 ++ s2) e+binop "++" (Binop "++" e (Str s1)) (Str s2) = Binop "++" e (Str $ s1 ++ s2)+binop "++" (Data "Nil" []) e = e+binop "++" e (Data "Nil" []) = e+binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]++binop "$" e1 e2 = App e1 e2++binop op e1 e2 = Binop op e1 e2 --}
− src/Parse/Binop.hs 
@@ -1,64 +0,0 @@-module Binop (binops) where
-
-import Ast
-import Combinators
-import Control.Monad (liftM,guard)
-import Control.Monad.Error
-import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find)
-import qualified Data.Map as Map
-import Data.Maybe (mapMaybe)
-
-data Assoc = L | Non | R deriving (Eq,Show)
-
-table = [ (9, R, ".")
-        , (7, L, "*"), (7, L, "/"), (7, L, "mod")
-        , (6, L, "+"), (6, L, "-")
-        , (5, R, ":" ), (5, R, "++")
-        , (4, Non, "<="), (4, Non, ">="), (4, Non, "<")
-        , (4, Non, "=="), (4, Non, "/="), (4, Non, ">")
-        , (3, R, "&&")
-        , (2, R, "||")
-        , (0, R, "$")
-        ]
-
-sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)
-
-binops term anyOp = do
-  e <- term
-  (ops,es) <- liftM unzip $ star (do { op <- anyOp; e <- term; return (op,e) })
-  case binopOf Map.empty (sortOps table) ops (e:es) of
-    Right e -> return e
-    Left msg -> zero
-
-binopSplit seen opTable i ops es =
-    case (splitAt i ops, splitAt (i+1) es) of
-      ((befores, op:afters), (pres, posts)) ->
-          do e1 <- binopOf seen opTable befores pres
-             e2 <- binopOf seen opTable afters posts
-             return $ Binop op e1 e2
-
-binopOf _ _ _ [e] = return e
-binopOf _ [] ops es =
-    return $ foldl' (flip ($)) (head es) $ zipWith Binop ops (tail es)
-
-binopOf seen (tbl@((lvl, L, op):rest)) ops es =
-    case elemIndices op ops of
-      [] -> binopOf seen rest ops es
-      is -> case Map.lookup lvl seen of
-              Nothing -> binopSplit (Map.insert lvl (L,op) seen) tbl (last is) ops es
-              Just (L,_) -> binopSplit seen tbl (last is) ops es
-              Just (assoc,op') -> Left $ errorMessage lvl op L op' assoc
-binopOf seen (tbl@((lvl, assoc, op):rest)) ops es =
-    case elemIndices op ops of
-      [] -> binopOf seen rest ops es
-      i:_ -> case Map.lookup lvl seen of
-               Nothing -> binopSplit (Map.insert lvl (R,op) seen) tbl i ops es
-               Just (assoc',op') ->
-                   if assoc == assoc' && assoc /= Non then
-                       binopSplit seen tbl i ops es
-                   else Left $ errorMessage lvl op assoc op' assoc'
-
-errorMessage lvl op1 assoc1 op2 assoc2 =
-    "Cannot have (" ++ op1 ++ ") with [" ++ show assoc1 ++ " " ++
-    show lvl ++ "] and (" ++ op2 ++ ") with [" ++ show assoc2 ++ " " ++
-    show lvl ++ "]"
+ src/Parse/Binops.hs view
@@ -0,0 +1,69 @@+module Binops (binops) where
+
+import Ast
+import Control.Monad (liftM,guard)
+import Control.Monad.Error
+import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find)
+import qualified Data.Map as Map
+import Data.Maybe (mapMaybe)
+
+import Text.Parsec
+import ParseLib
+
+data Assoc = L | N | R deriving (Eq,Show)
+
+table = [ (9, R, ".")
+        , (7, L, "*"), (7, L, "/"), (7, L, "mod")
+        , (6, L, "+"), (6, L, "-")
+        , (5, R, ":" ), (5, R, "++")
+        , (4, N, "<="), (4, N, ">="), (4, N, "<")
+        , (4, N, "=="), (4, N, "/="), (4, N, ">")
+        , (3, R, "&&")
+        , (2, R, "||")
+        , (0, R, "$")
+        ]
+
+sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)
+
+binops term anyOp = do
+  e <- term
+  (ops,es) <- liftM unzip $
+                    many (try $ do { whitespace
+                                   ; op <- anyOp
+                                   ; whitespace
+                                   ; e <- term; return (op,e) })
+  case binopOf Map.empty (sortOps table) ops (e:es) of
+    Right e -> return e
+    Left msg -> fail msg
+
+binopSplit seen opTable i ops es =
+    case (splitAt i ops, splitAt (i+1) es) of
+      ((befores, op:afters), (pres, posts)) ->
+          do e1 <- binopOf seen opTable befores pres
+             e2 <- binopOf seen opTable afters posts
+             return $ Binop op e1 e2
+
+binopOf _ _ _ [e] = return e
+binopOf seen [] ops es = binopOf seen [(9,L,head ops)] ops es
+
+binopOf seen (tbl@((lvl, L, op):rest)) ops es =
+    case elemIndices op ops of
+      [] -> binopOf seen rest ops es
+      is -> case Map.lookup lvl seen of
+              Nothing -> binopSplit (Map.insert lvl (L,op) seen) tbl (last is) ops es
+              Just (L,_) -> binopSplit seen tbl (last is) ops es
+              Just (assoc,op') -> Left $ errorMessage lvl op L op' assoc
+binopOf seen (tbl@((lvl, assoc, op):rest)) ops es =
+    case elemIndices op ops of
+      [] -> binopOf seen rest ops es
+      i:_ -> case Map.lookup lvl seen of
+               Nothing -> binopSplit (Map.insert lvl (assoc,op) seen) tbl i ops es
+               Just (assoc',op') ->
+                   if assoc == assoc' && assoc /= N then
+                       binopSplit seen tbl i ops es
+                   else Left $ errorMessage lvl op assoc op' assoc'
+
+errorMessage lvl op1 assoc1 op2 assoc2 =
+    "Cannot have (" ++ op1 ++ ") with [" ++ show assoc1 ++ " " ++
+    show lvl ++ "] and (" ++ op2 ++ ") with [" ++ show assoc2 ++ " " ++
+    show lvl ++ "]"
− src/Parse/Combinators.hs 
@@ -1,82 +0,0 @@-module Combinators where
-import Control.Monad
-import Data.Char
-import Data.List (sortBy,foldl',foldl1')
-
-newtype Parser from to = Parser ([from] -> [(to,[from])])
---newtype Parser a = Parser (String -> [(a,String)])
-
-parse (Parser p) = p
-
-instance Monad (Parser from) where
-    return a = Parser (\cs -> [(a,cs)])
-    p >>= f  = Parser (\cs -> concat [parse (f a) cs' | (a,cs') <- parse p cs])
-
-instance MonadPlus (Parser from) where
-   mzero = Parser $ const []
-   mplus p q = Parser (\cs -> parse p cs ++ parse q cs)
-
--- True recursive descent, tries everything.
-p +++ q = mplus p q
-
--- Get the first parse.
-p +|+ q = Parser (\cs -> case parse (mplus p q) cs of
-                           [] -> []
-                           (x:xs) -> [x])
-
-zero = Parser $ const []
-
-item  = Parser (\cs -> case cs of
-                         [] -> []
-                         (c:cs) -> [(c,cs)])
-
-sat p = do {c <- item; if p c then return c else mzero}
-
-char c = sat (c ==)
-
-string ""     = return ""
-string (c:cs) = do {char c; string cs; return (c:cs)}
-
-star p = plus p +++ return []
-plus p = do {a <- p; as <- star p; return (a:as)}
-
-optional p = (Just `liftM` p) +++ return Nothing
-
-nospace = guard . (==0) . length =<< space
-space = star $ sat isSpace
-space1 = plus $ sat isSpace
-newline = do
-  star $ char ' ' +++ char '\t'
-  char '\n'
-  space
-  return ""
-
-digit = do {x <- sat isDigit; return (ord x - ord '0')}
-integer = do {i <- plus digit; return $ foldl' (\a d -> 10 * a + d) 0 i}
-
-variable = do
-  shd <- sat isLower;
-  stl <- star $ sat (\c -> isAlphaNum c || c == '_')
-  return $ shd:stl
-
-sepBy sep p = sepBy1 sep p +++ return []
-
-sepBy1 sep p = do
-  x <- p
-  xs <- star (sep >> p)
-  return $ x:xs
-
-select = foldl1' (+|+)
-
-chainl p op a = chainl1 p op +++ return a
-chainl1 p op = do {a <- p; rest a}
-                where
-                  rest a = (do f <- op
-                               b <- p
-                               rest (f a b)) +++ return a
-
-extractResult err parse =
-    case parse of
-      (r,[]) : _ -> Right r
-      _ : rest -> extractResult err rest
-      [] -> Left err
− src/Parse/Lexer.hs 
@@ -1,84 +0,0 @@-
-module Lexer (tokenize) where
-
-import Control.Applicative ((<|>), (<$>), (<*>))
-import Data.Char (isSymbol)
-import Text.Parsec (Parsec, alphaNum, anyChar, char, choice, digit, eof, letter,
-                    many, many1, manyTill, newline, notFollowedBy, oneOf, parse,
-                    satisfy, string, try, upper)
-import Tokens
-import Control.Monad (liftM)
-
-token :: Parsec String u Token
-token = NUMBER <$> integer
-    <|> whitespace
-    <|> chrs [ ('(',LPAREN)  , (')',RPAREN)
-             , ('{',LBRACE)  , ('}',RBRACE)
-             , ('[',LBRACKET), (']',RBRACKET)
-             , (',',COMMA)   , (';',SEMI), ('_',UNDERSCORE)
-             , ('\\',LAMBDA) , ('\x03BB',LAMBDA) ]
-    <|> reserveds [ ("True",TRUE), ("False",FALSE)
-                  , ("if",IF), ("then",THEN), ("else",ELSE)
-                  , ("case",CASE), ("of",OF), ("data", DATA) 
-                  , ("let",LET), ("in",IN) ]
-    <|> do { char '`'; v <- variable; char '`'; return $ OP v }
-    <|> anyOp
-    <|> do { char '"'; s <- many $ backslashed <|> satisfy (/='"'); char '"'
-           ; return $ STRING s}
-    <|> do { char '\''; c <- backslashed <|> satisfy (/='\''); char '\''
-           ; return $ CHAR c}
-    <|> (ID <$> variable)
-    <|> typeVar
-    <|> do { try $ string "\r\n" <|> string "\n"; return NEWLINE }
-
-chrs :: [(Char, Token)] -> Parsec String u Token
-chrs = choice . map chr
-    where chr (c, t) = char c >> return t
-
-reserveds :: [(String, Token)] -> Parsec String u Token
-reserveds = choice . map reserved
-    where reserved (s, t) = try $ string s >>
-                                  notFollowedBy (alphaNum <|> char '_') >>
-                                  return t
-
-anyOp = do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
-           case op of { ".." -> return DOT2
-                      ; "->" -> return ARROW; "\8594" -> return ARROW
-                      ; _ -> return $ OP op }
-
-backslashed :: Parsec String u Char
-backslashed = do { char '\\'; c <- anyChar
-                 ; return . read $ ['\'','\\',c,'\''] }
-
-integer :: Parsec String u Int
-integer = read <$> many1 digit
-
-variable :: Parsec String u String
-variable = identifier $ letter <|> char '_'
-
-typeVar :: Parsec String u Token
-typeVar = TYPE <$> identifier upper
-
-identifier :: Parsec String u Char -> Parsec String u String
-identifier c = (:) <$> c <*> (many $ alphaNum <|> oneOf "_\'")
-
-----  White Space and comments  ----
-
-whitespace = (lineComment >> return NEWLINE) <|>
-             (many1 (multiComment <|> many1 (char ' ')) >> return SPACES)
-lineComment = do try $ string "--"
-                 manyTill anyChar $ newline <|> (eof >> return '\n')
-
-multiComment = do { try $ string "{-"; closeComment }
-closeComment = manyTill anyChar . choice $
-               [ try $ string "-}"
-               , do { try $ string "{-"; closeComment; closeComment }
-               ]
-
-tokenParser :: Parsec String u [Token]
-tokenParser = many1 token
-
-tokenize :: String -> Either String [Token]
-tokenize s = case parse tokenParser "" s of
-               Right ts -> Right ts
-               Left err -> Left $ "Syntax error: " ++ show err
+ src/Parse/ParseLib.hs view
@@ -0,0 +1,136 @@+
+module ParseLib where
+
+import Ast
+import Control.Applicative ((<$>),(<*>))
+import Control.Monad
+import Data.Char (isSymbol)
+import Text.Parsec hiding (newline,spaces)
+
+reserveds = [ "if", "then", "else"
+           , "case", "of", "data"
+           , "let", "in" ]
+
+expecting = flip (<?>)
+
+backslashed :: (Monad m) => ParsecT [Char] u m Char
+backslashed = do { char '\\'; c <- anyChar
+                 ; return . read $ ['\'','\\',c,'\''] }
+
+var :: (Monad m) => ParsecT [Char] u m String
+var = makeVar (letter <|> char '_' <?> "variable")
+
+lowVar :: (Monad m) => ParsecT [Char] u m String
+lowVar = makeVar (lower <?> "lower case variable")
+capVar :: (Monad m) => ParsecT [Char] u m String
+capVar = makeVar (upper <?> "upper case variable")
+
+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 (e.g. x + y)"
+
+arrow :: (Monad m) => ParsecT [Char] u m String
+arrow = string "->" <|> string "\8594" <?> "arrow (->)"
+
+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 ',' <?> "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 ';' <?> "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 '|' <?> "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 =  (:) <$> p <*> spacePrefix p
+
+spacePrefix p = many (try (whitespace >> p))
+
+betwixt a b c = do char a ; out <- c
+                   char b <?> "closing '" ++ [b] ++ "'" ; return out
+
+surround a z name p = do
+  char a ; whitespace ; a <- p ; whitespace
+  char z <?> unwords ["closing", name, show z]
+  return a
+
+braces   :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
+braces   = surround '[' ']' "brace"
+
+parens   :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
+parens   = surround '(' ')' "paren"
+
+brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
+brackets = surround '{' '}' "bracket"
+
+accessible expr = do
+  e <- expr
+  access <- optionMaybe . try $
+                  (do { char '.' ; notFollowedBy (char '.') } <?> "field access (e.g. List.map)")
+  case access of
+    Just _  -> accessible (Access e `liftM` var <?> "field access (e.g. List.map)")
+    Nothing -> return e
+
+
+spaces :: (Monad m) => ParsecT [Char] u m String
+spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"
+
+forcedWS :: (Monad m) => ParsecT [Char] u m [String]
+forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
+    where nl_space = try $ many1 newline >> spaces
+
+whitespace :: (Monad m) => ParsecT [Char] u m ()
+whitespace = optional forcedWS <?> ""
+
+freshLine :: (Monad m) => ParsecT [Char] u m [[String]]
+freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""
+    where space_nl = try $ spaces >> many1 newline
+
+newline :: (Monad m) => ParsecT [Char] u m String
+newline = simpleNewline <|> lineComment <?> ""
+
+simpleNewline :: (Monad m) => ParsecT [Char] u m String
+simpleNewline = try (string "\r\n") <|> string "\n"
+
+lineComment :: (Monad m) => ParsecT [Char] u m String
+lineComment = do try (string "--")
+                 manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
+
+multiComment :: (Monad m) => ParsecT [Char] u m String
+multiComment = do { try (string "{-"); closeComment }
+
+closeComment :: (Monad m) => ParsecT [Char] u m String
+closeComment = manyTill anyChar . choice $
+               [ try (string "-}") <?> "close comment"
+               , do { try $ string "{-"; closeComment; closeComment }
+               ]
− src/Parse/ParsePatterns.hs 
@@ -1,31 +0,0 @@-module ParsePatterns (patternTerm, patternExpr) where
-
-import Ast
-import Combinators
-import Data.Char (isUpper)
-import ParserLib
-import Tokens
-import Control.Monad (liftM)
-
-patternBasic =
-    (t UNDERSCORE >> return PAnything) +|+
-    (do { x@(c:_) <- var ;
-          if isUpper c then PData x `liftM` star patternTerm
-                       else return $ PVar x })
-
-patternTuple = do
-  t LPAREN; ps <- sepBy1 (t COMMA) patternExpr; t RPAREN
-  return $ case ps of { [p] -> p; _ -> ptuple ps }
-
-patternCons = do
-  p <- patternTerm
-  colon <- optional $ opParser (==":")
-  case colon of
-    Just ":" -> pcons p `liftM` patternExpr
-    Nothing -> return p
-
-patternList = do
-  t LBRACKET; ps <- sepBy (t COMMA) patternExpr; t RBRACKET; return (plist ps)
-
-patternTerm = patternTuple +|+ patternList +|+ patternBasic
-patternExpr = patternTuple +|+ patternList +|+ patternCons
src/Parse/ParseTypes.hs view
@@ -1,15 +1,16 @@ module ParseTypes where
 
 import Ast
-import Combinators
+import Control.Applicative ((<$>),(<*>))
+import Control.Monad (liftM)
 import Data.Char (isUpper,isLower)
 import Data.Maybe (fromMaybe)
 import Data.List (lookup)
-import ParserLib
-import Tokens
-import Types
+import Text.Parsec
+
+import ParseLib
+import Types hiding (string,parens)
 import Guid
-import Control.Monad (liftM)
 
 data ParseType = VarPT String
                | LambdaPT ParseType ParseType
@@ -18,35 +19,48 @@ listPT t = ADTPT "List" [t]
 tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts
 
-typeVar = liftM VarPT lowVar
-typeList  = do t LBRACKET; te <- typeExpr; t RBRACKET; return $ listPT te
-typeTuple = do { t LPAREN; ts <- sepBy (t COMMA) typeExpr; t RPAREN
-               ; return $ case ts of { [t] -> t ; _ -> tuplePT ts } }
-typeUnambiguous = typeList +|+ typeTuple
+typeVar :: (Monad m) => ParsecT [Char] u m ParseType
+typeVar = VarPT <$> lowVar <?> "type variable"
 
-typeSimple = liftM VarPT var
+typeList :: (Monad m) => ParsecT [Char] u m ParseType
+typeList  = listPT <$> braces typeExpr
+
+typeTuple :: (Monad m) => ParsecT [Char] u m ParseType
+typeTuple = do ts <- parens (commaSep typeExpr)
+               return $ case ts of { [t] -> t ; _ -> tuplePT ts }
+
+typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType
+typeUnambiguous = typeList <|> typeTuple
+
+typeSimple :: (Monad m) => ParsecT [Char] u m ParseType
+typeSimple = VarPT <$> var
+
+typeApp :: (Monad m) => ParsecT [Char] u m ParseType
 typeApp = do name <- capVar
-             args <- star (typeSimple +|+ typeUnambiguous)
+             args <- spacePrefix (typeUnambiguous <|> typeSimple)
              return $ case args of
                         [] -> VarPT name
                         _  -> ADTPT name args
-                     
+
+typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
 typeExpr = do
-  t1 <- typeVar +|+ typeApp +|+ typeUnambiguous
-  arrow <- optional $ t ARROW
-  case arrow of Just ARROW -> LambdaPT t1 `liftM` typeExpr
-                Nothing -> return t1
+  t1 <- typeVar <|> typeApp <|> typeUnambiguous
+  whitespace ; arr <- optionMaybe arrow ; whitespace
+  case arr of Just _  -> LambdaPT t1 <$> typeExpr
+              Nothing -> return t1
 
-typeConstructor = do name <- capVar
-                     args <- star (typeSimple +|+ typeUnambiguous)
-                     return $ (,) name args
+typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
+typeConstructor = (,) <$> capVar <*> spacePrefix (typeSimple <|> typeUnambiguous)
 
+datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
 datatype = do
-  t DATA ; name <- capVar ; args <- star lowVar ; assign
-  tcs <- sepBy1 (opParser (=="|")) typeConstructor
+  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)
 
-beta = VarT `liftM` guid
+beta = liftM VarT guid
 
 toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames
     where argNames = map (("a"++) . show) [1..length args]
src/Parse/Parser.hs view
@@ -1,121 +1,129 @@-module Parser where
+module Parser (toDefs) where
 
 import Ast
-import Binop (binops)
-import Combinators
-import Control.Monad (liftM)
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad
+import Data.Char (isSymbol, isDigit)
 import Data.List (foldl')
+import Text.Parsec hiding (newline,spaces)
+
+import ParseLib
+import Patterns
+import Binops
+import ParseTypes
+
 import Guid
-import Lexer
-import ParserLib
-import ParseTypes (datatype)
-import ParsePatterns
-import Tokens
 import Types (Type (VarT))
 
 --------  Basic Terms  --------
 
-numTerm = do { whitespace; t <- item
-             ; case t of { NUMBER n -> return $ Number n; _ -> zero } }
-strTerm = do { whitespace; t <- item
-             ; case t of { STRING cs -> return $ Str cs
-                         ; _ -> zero } }
+numTerm :: (Monad m) => ParsecT [Char] u m Expr
+numTerm = liftM (Number . read) (many1 digit) <?> "number"
 
-varTerm = Var `liftM` var
-chrTerm = Chr `liftM` chr
+strTerm :: (Monad m) => ParsecT [Char] u m Expr
+strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $
+          backslashed <|> satisfy (/='"')
 
-trueTerm = do { t TRUE; return $ Boolean True }
-falseTerm = do { t FALSE; return $ Boolean False }
+varTerm :: (Monad m) => ParsecT [Char] u m Expr
+varTerm = toVar <$> var <?> "variable"
 
+toVar v = case v of "True"  -> Boolean True
+                    "False" -> Boolean False
+                    _       -> Var v
 
+chrTerm :: (Monad m) => ParsecT [Char] u m Expr
+chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
+          <?> "character"
+
+
 --------  Complex Terms  --------
 
-listTerm = (do { t LBRACKET; start <- expr; t DOT2; end <- expr; t RBRACKET
-                ; return $ Range start end }) +|+
-            (do { t LBRACKET; es <- sepBy (t COMMA) expr; t RBRACKET
-                ; return $ list es })
+listTerm = braces $ choice
+           [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
+                      ; Range lo <$> expr }
+           , list <$> commaSep expr
+           ]
 
-parensTerm = (do { t LPAREN; op <- anyOp; t RPAREN
-                  ; return . Lambda "x" . Lambda "y" $
-                           Binop op (Var "x") (Var "y") }) +|+
-              (do { t LPAREN; es <- sepBy (t COMMA) expr; t RPAREN
-                  ; return $ case es of { [e] -> e; _ -> tuple es } })
+parensTerm = parens $ choice
+             [ do op <- anyOp
+                  return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
+             , do es <- commaSep expr
+                  return $ case es of { [e] -> e; _ -> tuple es }
+             ]
 
-term = select [ numTerm
-              , strTerm
+term = choice [ numTerm, strTerm, chrTerm
               , accessible varTerm
-              , chrTerm
-              , trueTerm
-              , falseTerm
-              , listTerm 
-              , accessible parensTerm
-              ]
+              , listTerm, parensTerm ]
+       <?> "basic term (4, x, 'c', etc.)"
 
 --------  Applications  --------
 
 appExpr = do
-  tlist <- plus term
+  tlist <- spaceSep1 term
   return $ case tlist of
              t:[] -> t
              t:ts -> foldl' App t ts
 
-
---------  Expressions with infix operators  --------
+--------  Normal Expressions  --------
 
 binaryExpr = binops appExpr anyOp
 
-
---------  Normal Expressions  --------
-
-ifExpr = do { t IF; e1 <- expr; t THEN; e2 <- expr; t ELSE; e3 <- expr
-             ; return $ If e1 e2 e3 }
+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 { t LAMBDA; vs <- plus var; t ARROW; e <- expr
-                 ; return $ foldr Lambda e vs }
+lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
+                whitespace
+                args <- spaceSep1 patternTerm
+                whitespace ; arrow ; whitespace
+                e <- expr
+                return $ makeFunction args e
 
-assignExpr = whitespace >> assignExprNospace
-assignExprNospace = do
-  p:ps <- plus patternTerm; assign; e <- expr
-  case p:ps of
-    PVar x : _ -> return (x, foldr func e ps)
-        where func PAnything e' = Lambda "_" e'
-              func (PVar x)  e' = Lambda x e'
-              func p' e' = Lambda "_temp" (Case (Var "_temp") [(p', e')])
---    _ : [] -> return $ \hole -> Case e [(p,hole)]
-    _ -> zero
+assignExpr = do
+  patterns <-
+      choice [ try $ do v <- PVar <$> lowVar
+                        notFollowedBy (whitespace >> char ':')
+                        (v:) <$> spacePrefix patternTerm
+             , (:[]) <$> patternExpr
+             ] <?> "the definition of a variable (x = ...)"
+  whitespace; string "="; whitespace; exp <- expr
+  flattenPatterns patterns exp
 
 letExpr = do
-  t LET; brace <- optional $ t LBRACE
+  reserved "let"
+  brace <- optionMaybe . try $ do
+             whitespace
+             char '{' <?> "a set of definitions { x = ... ; y = ... }"
   case brace of
-    Nothing -> do f <- assignExpr; t IN; e <- expr; return (Let [f] e)
-    Just LBRACE -> do fs <- sepBy1 (t SEMI) assignExpr; t RBRACE; t IN;
-                      e <- expr; return (Let fs e)
+    Nothing -> do whitespace; ds <- assignExpr
+                  whitespace; reserved "in"; whitespace; Let ds <$> expr
+    Just '{' -> do whitespace ; dss <- semiSep1 assignExpr ; whitespace
+                   string "}" <?> "closing bracket '}'"
+                   whitespace; reserved "in"; whitespace; e <- expr
+                   return $ Let (concat dss) e
 
 caseExpr = do
-  t CASE; e <- expr; t OF; t LBRACE
-  cases <- sepBy1 (t SEMI)
-           (do { p <- patternExpr; t ARROW; e <- expr; return (p,e) })
-  t RBRACE
-  return $ Case e cases
+  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
 
---------  All Expressions  --------
 
-expr = select [ letExpr
-              , binaryExpr
-              , ifExpr
-              , caseExpr
-              , lambdaExpr
-              ]
+expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ] <?> "expression"
 
-def = do (f,e) <- assignExprNospace
-         return ([f], [e], guid >>= \x -> return [VarT x])
+def = do (fs,es) <- unzip <$> assignExpr
+         return (fs, es, mapM (\_ -> liftM VarT guid) fs)
 
+defs1 = do optional freshLine
+           d <- datatype <|> def
+           (d:) <$> many (try (try freshLine >> (datatype <|> def)))
+
 defs = do
-  (fss,ess,tss) <- unzip3 `liftM` plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype)
+  (fss,ess,tss) <- unzip3 <$> defs1
   let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
-  star $ sat (==NEWLINE) +|+ sat (==SPACES)
+  optional freshLine ; optional spaces ; eof
   return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
 
-err = "Parse Error: Better error messages to come!"
-toExpr = extractResult err . parse expr
-toDefs = extractResult err . parse defs . (NEWLINE:)
+toDefs source = case parse defs "" source of
+                  Right result -> Right result
+                  Left err -> Left $ "Parse error at " ++ show err
− src/Parse/ParserLib.hs 
@@ -1,38 +0,0 @@-module ParserLib where
-
-import Ast
-import Combinators
-import Data.Char (isUpper,isLower)
-import Control.Monad (liftM,guard)
-import Tokens
-
-varNoSpace = do { t <- item; case t of { ID v -> return v; _ -> zero } }
-var = whitespace >> varNoSpace
-capVar = do whitespace; t <- item
-            case t of { ID (v:vs) -> guard (isUpper v) >> return (v:vs) ; _ -> zero }
-lowVar = do whitespace; t <- item
-            case t of { ID (v:vs) -> guard (isLower v) >> return (v:vs) ; _ -> zero }
-
-chr = do { whitespace; t <- item; case t of { CHAR c -> return c; _ -> zero } }
-
-tNoSpace token = sat (==token)
-tWithSpace token = forcedWS >> sat (==token)
-t token = whitespace >> sat (==token)
-
-forcedWS = do { sat (==SPACES); star nl_space } +|+ plus nl_space
-    where nl_space = plus (sat (==NEWLINE)) >> sat (==SPACES)
-whitespace = optional forcedWS
-
-accessible exp = do
-  e <- exp
-  access <- optional $ opParserNospace (==".")
-  case access of
-    Just "." -> accessible (Access e `liftM` var)
-    Nothing -> return e
-
-opParserNospace pred =
-    do { t <- item
-       ; case t of { OP op -> if pred op then return op else zero; _ -> zero } }
-opParser pred = whitespace >> opParserNospace pred
-anyOp  = opParser (const True)
-assign = opParser (=="=")
+ src/Parse/Patterns.hs view
@@ -0,0 +1,53 @@+module Patterns (patternTerm, patternExpr, makeFunction, flattenPatterns) where
+
+import Ast
+import Data.Char (isUpper)
+import Control.Applicative ((<$>))
+import Control.Monad
+import Text.Parsec
+import ParseLib
+
+patternBasic :: Monad m => ParsecT [Char] u m Pattern
+patternBasic =
+    choice [ char '_' >> return PAnything
+           , do x@(c:_) <- var
+                if isUpper c then PData x <$> spacePrefix patternTerm
+                             else return $ PVar x
+           ]
+
+patternTuple :: Monad m => ParsecT [Char] u m Pattern
+patternTuple = do ps <- parens (commaSep patternExpr)
+                  return $ case ps of { [p] -> p; _ -> ptuple ps }
+
+patternList :: Monad m => ParsecT [Char] u m Pattern
+patternList = plist <$> braces (commaSep patternExpr)
+
+patternTerm :: Monad m => ParsecT [Char] u m Pattern
+patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
+
+patternExpr :: Monad m => ParsecT [Char] u m Pattern
+patternExpr = foldl1 pcons <$> consSep1 patternTerm <?> "pattern"
+
+
+
+makeFunction args body = foldr func body args
+    where func PAnything e = Lambda "_" e
+          func (PVar x)  e = Lambda x e
+          func p e = "t" `Lambda` Case (Var "t") [(p,e)]
+
+flattenPatterns (PVar f : args) exp = return [(f, makeFunction args exp)]
+flattenPatterns [p] exp = return $ matchSingle p exp p
+flattenPatterns ps _ = 
+    fail $ "Pattern (" ++ unwords (map show ps) ++
+           ") cannot be used on the left-hand side of an assign statement."
+
+matchSingle pat exp p@(PData _ ps) =
+    (v, exp) : concatMap (matchSingle p $ Var v) ps
+        where v = "'" ++ getName p
+matchSingle pat exp (PVar x)  = [ (x, Case exp [(pat,Var x)]) ]
+matchSingle pat exp PAnything = []
+
+getName (PData n ps) = n ++ concatMap getName ps
+getName (PAnything)  = "_"
+getName (PVar x)     = x
+
− src/Parse/Tokens.hs 
@@ -1,17 +0,0 @@-
-module Tokens where
-
-data Token =
-    NUMBER Int | ID String | TYPE String |
-    CHAR Char | STRING String |
-    LAMBDA | ARROW | OP String | DOT2 | UNDERSCORE |
-    LPAREN | RPAREN |
-    LBRACE | RBRACE |
-    LBRACKET | RBRACKET |
-    COMMA | SEMI |
-    TRUE | FALSE |
-    IF | THEN | ELSE |
-    CASE | OF | LET | IN |
-    SPACES | NEWLINE | DATA
-           deriving (Show, Eq)
-
src/Rename.hs view
@@ -68,7 +68,7 @@ extend :: (String -> String) -> String -> GuidCounter (String, String -> String)
 extend env x = do
   n <- guid
-  let rx = x ++ "_" ++ show n
+  let rx = map (\c -> if c == '\'' then '_' else c) $ x ++ "_" ++ show n
   return (rx, \y -> if y == x then rx else env y)
 
 patternExtend :: Pattern -> (String -> String) -> GuidCounter (Pattern, String -> String)