Begin getting the parser to match the new SourceSyntax modules.

compiler/Model/Ast.hs

@@ -1,156 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-module Ast where
-
-import Located
-import Data.Char (isDigit, isSymbol)
-import Data.List (intercalate)
-import Types.Types
-import qualified Text.Pandoc as Pandoc
-import Data.Data
-
-data Module = Module [String] Exports Imports [Statement]
-              deriving (Show)
-
-type Exports = [String]
-
-type Imports = [(String, ImportMethod)]
-data ImportMethod = As String | Importing [String] | Hiding [String]
-                    deriving (Eq, Ord, Show, Data, Typeable)
-
-
-data Pattern = PData String [Pattern]
-             | PRecord [String]
-             | PAsVar String Pattern
-             | PVar String
-             | PAnything
-               deriving (Eq, Data, Typeable)
-
-type CExpr = Located Expr
-data Expr = IntNum Int
-          | FloatNum Float
-          | Chr Char
-          | Str String
-          | Boolean Bool
-          | Range CExpr CExpr
-          | Access CExpr String
-          | Remove CExpr String
-          | Insert CExpr String CExpr
-          | Modify CExpr [(String,CExpr)]
-          | Record [(String,[String],CExpr)]
-          | Binop String CExpr CExpr
-          | Lambda String CExpr
-          | App CExpr CExpr
-          | MultiIf [(CExpr,CExpr)]
-          | Let [Def] CExpr
-          | Var String
-          | Case CExpr [(Pattern,CExpr)]
-          | Data String [CExpr]
-          | Markdown Pandoc.Pandoc
-            deriving (Eq, Data, Typeable)
-
-data Def = FnDef String [String] CExpr
-         | OpDef String String String CExpr
-         | TypeAnnotation String Type
-           deriving (Eq, Data, Typeable)
-
-data Statement = Definition Def
-               | Datatype String [X] [(String,[Type])]
-               | TypeAlias String [X] Type
-               | ImportEvent String CExpr String Type
-               | ExportEvent String String Type
-                 deriving (Eq, Show, Data, Typeable)
-
-cons h t = epos h t (Data "Cons" [h,t])
-nil      = L (Just "[]") NoSpan (Data "Nil" [])
-list     = foldr cons nil
-tuple es = Data ("Tuple" ++ show (length es)) es
-
-delist (L _ _ (Data "Cons" [h,t])) = h : delist t
-delist _ = []
-
-
-pcons h t = PData "Cons" [h,t]
-pnil      = PData "Nil" []
-plist     = foldr pcons pnil
-ptuple es = PData ("Tuple" ++ show (length es)) es
-
-brkt s = "{ " ++ s ++ " }"
-parensIf b s = if b then parens s else s
-isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
-
-instance Show Pattern where
-  show p =
-   case p of
-     PRecord fs -> brkt (intercalate ", " fs)
-     PVar x -> x
-     PAsVar x p -> show p ++ " as " ++ x
-     PAnything -> "_"
-     PData "Cons" [hd@(PData "Cons" _),tl] ->
-        parens (show hd) ++ " :: " ++ show tl
-     PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl
-     PData "Nil" [] -> "[]"
-     PData name ps ->
-        if take 5 name == "Tuple" && all isDigit (drop 5 name) then
-            parens . intercalate ", " $ map show ps
-        else parensIf (not (null ps)) $ unwords (name : map show ps)
-
-instance Show Expr where
-  show e =
-   let show' (L _ _ e) = parensIf (needsParens e) (show e) in
-   case e of
-     IntNum n -> show n
-     FloatNum n -> show n
-     Chr c -> show c
-     Str s -> show s
-     Boolean b -> show b
-     Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
-     Access e x -> show' e ++ "." ++ x
-     Remove e x -> brkt (show e ++ " - " ++ x)
-     Insert (L _ _ (Remove e y)) x v ->
-         brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
-     Insert e x v -> brkt (show e ++ " | " ++ x ++ " = " ++ show v)
-     Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))
-         where field (x,e) = x ++ " <- " ++ show e
-     Record r -> brkt (intercalate ", " (map fields r))
-         where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
-     Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
-     Lambda x e -> let (xs,e') = getLambdas (notLocated $ Lambda x e) in
-                      concat [ "\\", intercalate " " xs, " -> ", show e' ]
-     App e1 e2 -> show' e1 ++ " " ++ show' e2
-     MultiIf (p:ps) -> concat [ "if | ", iff p, sep (map iff ps) ]
-         where iff (b,e) = show b ++ " -> " ++ show e
-               sep = concatMap ("\n   | " ++)
-     Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
-     Var (c:cs) -> if isOp c then parens (c:cs) else c:cs
-     Case e pats -> "case "++ show e ++" of " ++ brkt (intercalate " ; " pats')
-         where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
-     Data name es
-          | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
-                              delist (notLocated $ Data "Cons" es)
-          | name == "Nil"  -> "[]"
-          | otherwise      -> name ++ " " ++ intercalate " " (map show' es)
-     Markdown _ -> "[markdown| ... |]"
-
-
-instance Show Def where
-  show e =
-   case e of
-     FnDef v [] e     -> v ++ " = " ++ show e
-     FnDef f args e   -> f ++ concatMap (' ':) args ++ " = " ++ show e
-     OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
-     TypeAnnotation n t -> n ++ " : " ++ show t
-
-getLambdas (L _ _ (Lambda x e)) = (x:xs,e')
-    where (xs,e') = getLambdas e
-getLambdas e = ([],e)
-
-needsParens e =
-  case e of
-    Binop _ _ _ -> True
-    Lambda _ _  -> True
-    App _ _     -> True
-    MultiIf _   -> True
-    Let _ _     -> True
-    Case _ _    -> True
-    Data name (x:xs) -> name /= "Cons"
-    _ -> False

compiler/Parse/Binops.hs

@@ -1,18 +1,14 @@
 module Parse.Binops (binops, infixStmt, OpTable) where
 
-import Ast
-import Control.Monad (liftM,guard)
 import Control.Monad.Error
-import Data.List (foldl',splitAt,elemIndices
+import Data.List (intercalate)
-                 ,group,groupBy,sortBy,find,intercalate)
 import qualified Data.Map as Map
-import Data.Maybe (mapMaybe)
 
-import Located (epos)
+import SourceSyntax.Location (merge)
+import SourceSyntax.Expression (LExpr, Expr(Binop))
+import SourceSyntax.Declaration (Assoc(..))
 import Text.Parsec
-import Parse.Library
+import Parse.Helpers
-
-data Assoc = L | N | R deriving (Eq,Show)
 
 type OpTable = [(Int, Assoc, String)]
 
@@ -39,10 +35,10 @@ opAssoc :: OpTable -> String -> Assoc
 opAssoc table op = Map.findWithDefault R op dict
     where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)
 
-hasLevel :: OpTable -> Int -> (String,CExpr) -> Bool
+hasLevel :: OpTable -> Int -> (String,LExpr) -> Bool
 hasLevel table n (op,_) = opLevel table op == n
 
-binops :: OpTable -> IParser CExpr -> IParser String -> IParser CExpr
+binops :: OpTable -> IParser LExpr -> IParser String -> IParser LExpr
 binops table term anyOp =
     do e <- term
        split (table ++ preludeTable) 0 e =<< many nextOp
@@ -52,7 +48,7 @@ binops table term anyOp =
                  whitespace ; e <- term
                  return (op,e)
 
-split :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> IParser CExpr
+split :: OpTable -> Int -> LExpr -> [(String, LExpr)] -> IParser LExpr
 split _ _ e []  = return e
 split table n e eops = do
   assoc <- getAssoc table n eops
@@ -61,25 +57,25 @@ split table n e eops = do
   case assoc of R -> joinR es ops
                 _ -> joinL es ops
 
-splitLevel :: OpTable -> Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]
+splitLevel :: OpTable -> Int -> LExpr -> [(String, LExpr)] -> [IParser LExpr]
 splitLevel table n e eops =
     case break (hasLevel table n) eops of
       (lops, (op,e'):rops) ->
           split table (n+1) e lops : splitLevel table n e' rops
       (lops, []) -> [ split table (n+1) e lops ]
 
-joinL :: [CExpr] -> [String] -> IParser CExpr
+joinL :: [LExpr] -> [String] -> IParser LExpr
 joinL [e] [] = return e
-joinL (a:b:es) (op:ops) = joinL (epos a b (Binop op a b) : es) ops
+joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops
 joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."
 
-joinR :: [CExpr] -> [String] -> IParser CExpr
+joinR :: [LExpr] -> [String] -> IParser LExpr
 joinR [e] [] = return e
 joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
-                             return (epos a e (Binop op a e))
+                             return (merge a e (Binop op a e))
 joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."
 
-getAssoc :: OpTable -> Int -> [(String,CExpr)] -> IParser Assoc
+getAssoc :: OpTable -> Int -> [(String,LExpr)] -> IParser Assoc
 getAssoc table n eops
     | all (==L) assocs = return L
     | all (==R) assocs = return R 

compiler/Parse/Expr.hs

@@ -1,7 +1,5 @@
 module Parse.Expr (def,term) where
 
-import Ast
-import Located
 import Control.Applicative ((<$>), (<*>))
 import Control.Monad
 import Data.Char (isSymbol, isDigit)
@@ -15,6 +13,9 @@ import Parse.Patterns
 import Parse.Binops
 import Parse.Types
 
+import Ast
+import Located
+
 import Guid
 import Types.Types (Type (VarT), Scheme (Forall))
 
@@ -70,7 +71,7 @@ listTerm =
             return e
        ])
 
-parensTerm :: IParser CExpr
+parensTerm :: IParser LExpr
 parensTerm = parens $ choice
              [ do start <- getPosition
                   op <- try anyOp
@@ -93,7 +94,7 @@ parensTerm = parens $ choice
                                       _   -> pos start end (tuple es)
              ]
 
-recordTerm :: IParser CExpr
+recordTerm :: IParser LExpr
 recordTerm = brackets $ choice [ misc, addLocation record ]
     where field = do
               fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm
@@ -125,14 +126,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]
               Nothing -> try (insert record) <|> try (modify record)
                         
 
-term :: IParser CExpr
+term :: IParser LExpr
 term =  addLocation (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])
     <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
     <?> "basic term (4, x, 'c', etc.)"
 
 --------  Applications  --------
 
-appExpr :: IParser CExpr
+appExpr :: IParser LExpr
 appExpr = do
   tlist <- spaceSep1 term
   return $ case tlist of
@@ -141,7 +142,7 @@ appExpr = do
 
 --------  Normal Expressions  --------
 
-binaryExpr :: IParser CExpr
+binaryExpr :: IParser LExpr
 binaryExpr = binops [] appExpr anyOp
 
 ifExpr :: IParser Expr
@@ -159,7 +160,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
                          b <- expr ; whitespace ; string "->" ; whitespace
                          (,) b <$> expr
 
-lambdaExpr :: IParser CExpr
+lambdaExpr :: IParser LExpr
 lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
                 whitespace
                 pats <- spaceSep1 patternTerm

compiler/Parse/Helpers.hs

@@ -1,13 +1,13 @@
+module Parse.Helpers where
 
-module Parse.Library where
-
-import Ast
-import Located
 import Control.Applicative ((<$>),(<*>))
 import Control.Monad
 import Control.Monad.State
 import Data.Char (isUpper)
-import Rename (deprime)
+import SourceSyntax.Helpers (isOp)
+import SourceSyntax.Location as Location
+import SourceSyntax.Expression
+import SourceSyntax.Rename (deprime)
 import Text.Parsec hiding (newline,spaces,State)
 import Text.Parsec.Indent
 
@@ -124,14 +124,14 @@ parens   = surround '(' ')' "paren"
 brackets :: IParser a -> IParser a
 brackets = surround '{' '}' "bracket"
 
-addLocation :: IParser Expr -> IParser CExpr
+addLocation :: IParser Expr -> IParser LExpr
 addLocation expr = do
   start <- getPosition
   e <- expr
   end <- getPosition
-  return (pos start end e)
+  return (Location.at start end e)
 
-accessible :: IParser CExpr -> IParser CExpr
+accessible :: IParser LExpr -> IParser LExpr
 accessible expr = do
   start <- getPosition
   ce@(L s t e) <- expr
@@ -143,7 +143,7 @@ accessible expr = do
           Just _  -> accessible $ do
                        v <- var <?> "field access (e.g. List.map)"
                        end <- getPosition
-                       return (pos start end (f v))
+                       return (Location.at start end (f v))
   case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
                        | otherwise -> rest (Access ce)
             _ -> rest (Access ce)

compiler/Parse/Patterns.hs

@@ -1,5 +1,5 @@
 
-module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
+module Parse.Pattern (patternTerm, patternExpr, makeLambda, flattenPatterns) where
 
 import Ast
 import Located

compiler/Parse/Types.hs

@@ -1,6 +1,5 @@
 module Parse.Types where
 
-import Ast
 import Control.Applicative ((<$>),(<*>))
 import Control.Monad (liftM,mapM)
 import Data.Char (isUpper,isLower)
@@ -9,8 +8,10 @@ import Data.List (lookup,intercalate)
 import Text.Parsec
 import Text.Parsec.Indent
 
-import Located
+import SourceSyntax.Location as Located
-import Parse.Library
+import SourceSyntax.Expression
+import SourceSyntax.Declaration
+import Parse.Helpers
 import Types.Types hiding (parens,string)
 import Guid
 
@@ -69,7 +70,7 @@ typeConstructor :: IParser (String, [ParseType])
 typeConstructor = (,) <$> (capVar <?> "another type constructor")
                       <*> spacePrefix (typeSimple <|> typeUnambiguous)
 
-typeAlias :: IParser [Statement]
+typeAlias :: IParser [Declaration]
 typeAlias = do
   start <- getPosition
   reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
@@ -91,13 +92,13 @@ typeAlias = do
 toConstructor start end alias Nothing kvs =
     Definition (FnDef alias args (loc (Record rec)))
   where
-    loc = pos start end
+    loc = Located.at start end
     args = map fst kvs
     rec = map (\a -> (a, [], loc (Var a))) args
 toConstructor start end alias (Just _) kvs =
     Definition (FnDef alias (args++["_ext_"]) (loc rec))
   where
-    loc = pos start end
+    loc = Located.at start end
     args = map fst kvs
     rec = foldl insert (Var "_ext_") (zip args (map (loc . Var) args))
     insert e (k,v) = Insert (loc e) k v
@@ -107,7 +108,7 @@ typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
     where start = do v <- lowVar <|> parens symOp
                      whitespace ; hasType ; whitespace ; return v
 
-datatype :: IParser Statement
+datatype :: IParser Declaration
 datatype = do
   reserved "data" <?> "datatype definition (data T = A | B | ...)"
   forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar

compiler/SourceSyntax/Declaration.hs

@@ -11,5 +11,8 @@ data Declaration
     | TypeAlias String [X] Type
     | ImportEvent String Expr.LExpr String Type
     | ExportEvent String String Type
-    | Fixity Int String
+    | Fixity Assoc Int String
       deriving (Eq, Show, Data, Typeable)
+
+data Assoc = L | N | R
+             deriving (Eq, Show, Data, Typeable)

compiler/SourceSyntax/Rename.hs

@@ -1,13 +1,16 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Rename (renameModule, derename, deprime) where
+module SourceSyntax.Rename (renameModule, derename, deprime) where
 
-import Ast
-import Located
 import Control.Arrow (first)
 import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
 import Control.Monad.State (evalState, State, get, put)
 import Data.Char (isLower,isDigit)
 import Guid
+import SourceSyntax.Location
+import SourceSyntax.Pattern
+import SourceSyntax.Expression
+import SourceSyntax.Declaration hiding (Assoc(..))
+import SourceSyntax.Module
 
 derename var
     | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var
@@ -33,7 +36,7 @@ instance Rename Def where
   rename env (TypeAnnotation n t) = return (TypeAnnotation (env n) t)
 
 
-instance Rename Statement where
+instance Rename Declaration where
   rename env stmt =
     case stmt of
       Definition def -> Definition `liftM` rename env def
@@ -126,10 +129,10 @@ patternExtend pattern env =
     case pattern of
       PAnything -> return (PAnything, env)
       PVar x -> first PVar `liftM` extend env x
-      PAsVar x p -> do
+      PAlias x p -> do
         (x', env') <- extend env x
         (p', env'') <- patternExtend p env'
-        return (PAsVar x' p', env'')
+        return (PAlias x' p', env'')
       PData name ps ->
           first (PData name . reverse) `liftM` foldM f ([], env) ps
                  where f (rps,env') p = do (rp,env'') <- patternExtend p env'
@@ -137,7 +140,9 @@ patternExtend pattern env =
       PRecord fs ->
           return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)
 
-patternRename :: (String -> String) -> (Pattern, CExpr) -> GuidCounter (Pattern, CExpr)
+patternRename :: (String -> String)
+              -> (Pattern, LExpr)
+              -> GuidCounter (Pattern, LExpr)
 patternRename env (p,e) = do
   (rp,env') <- patternExtend p env
   re <- rename env' e

compiler/Types/Solver.hs

@@ -14,6 +14,8 @@ import Types.Types
 import Types.Substitutions
 import Types.Alias (dealias)
 
+import System.IO.Unsafe
+
 isSolved ss (L _ _ (t1 :=: t2)) = t1 == t2
 isSolved ss (L _ _ (x :<<: _)) = isJust (lookup x ss)
 isSolved ss c = False
@@ -21,12 +23,15 @@ isSolved ss c = False
 type Aliases = Map.Map String ([X],Type)
 
 crush :: Aliases -> Scheme -> GuidCounter (Either String Scheme)
-crush aliases (Forall xs cs t) =
+crush aliases forall@(Forall xs cs t) =
     do subs <- solver aliases Map.empty cs
        return $ do ss' <- subs
                    let ss  = Map.toList ss'
                        cs' = filter (not . isSolved ss) (subst ss cs)
-                   return $ Forall xs cs' (subst ss t)
+                       f x = (unsafePerformIO $ do
+                                print forall  >> putStrLn "-------"
+                                print x >> putStrLn "~~~~~~~") `seq` x
+                   return . f $ Forall xs cs' (subst ss t)
 
 schemeSubHelp txt span x s t1 rltn t2 = do
   (t1',cs1) <- sub t1
@@ -36,11 +41,10 @@ schemeSubHelp txt span x s t1 rltn t2 = do
                   | otherwise = do (st, cs) <- concretize s
                                    return (subst [(x,st)] t, cs)
 
-schemeSub aliases x s c =
+schemeSub x s' c =
-    do s' <- crush aliases s
+    case s' of
-       case s' of
+      Right s'' -> Right `liftM` schemeSub' x s'' c
-         Right s'' -> Right `liftM` schemeSub' x s'' c
+      Left err  -> return $ Left err
-         Left err  -> return $ Left err
 
 schemeSub' x s c@(L txt span constraint) =
   case constraint of
@@ -170,7 +174,8 @@ solver aliases subs (L txt span c : cs) =
 
       x :<<: s
           | any (occurs x) cs ->
-              do css <- mapM (schemeSub aliases x s) cs
+              do s' <- crush aliases s
+                 css <- mapM (schemeSub x s') cs
                  case lefts css of
                    err : _ -> return $ Left err
                    [] -> solv (concat (rights css))

compiler/Types/Types.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module Types.Types where
 
-import Located
+import SourceSyntax.Location
 import Data.Char (isDigit)
 import Data.List (intercalate,isPrefixOf)
 import qualified Data.Set as Set

compiler/Types/Unify.hs

@@ -19,7 +19,9 @@ unify hints modul@(Module _ _ _ stmts) = run $ do
   case result of
     Left err -> return (Left err)
     Right (schemes, constraints) ->
-        do subs <- Solver.solver (Alias.get stmts) Map.empty constraints
+        do subs <- unsafePerformIO (mapM print constraints) `seq`
+                   Solver.solver (Alias.get stmts) Map.empty constraints
            let ss = either (const []) Map.toList subs
-           unsafePerformIO (mapM print . map (second (Subst.subst ss)) $ concatMap Map.toList schemes) `seq` return subs
+           -- unsafePerformIO (mapM print . map (second (Subst.subst ss)) $ concatMap Map.toList schemes) `seq`
+           return subs