git.iko.soy/elk
on master help sign in
Add line and column number for type errors and "non-exhaustive" errors.
6cc617bevancz
elm/src/Ast.hs+55−53
compare with master
unifiedsplit
@@ -1,6 +1,7 @@
1
1
2module Ast where
2module Ast where
3
3
4+import Context
4import Data.Char (isDigit)
5import Data.Char (isDigit)
5import Data.List (intercalate)
6import Data.List (intercalate)
6import Types.Types
7import Types.Types
@@ -18,45 +19,43 @@ data ImportMethod = As String | Hiding [String] | Importing [String]
18data Pattern = PData String [Pattern] | PVar String | PAnything
19data Pattern = PData String [Pattern] | PVar String | PAnything
19 deriving (Eq)
20 deriving (Eq)
20
21
22+type CExpr = Context Expr
21data Expr = IntNum Int
23data Expr = IntNum Int
22 | FloatNum Float
24 | FloatNum Float
23 | Chr Char
25 | Chr Char
24 | Str String
26 | Str String
25 | Boolean Bool
27 | Boolean Bool
26− | Range Expr Expr
28+ | Range CExpr CExpr
27− | Access Expr String
29+ | Access CExpr String
30+ | Record [(String,[String],CExpr)]
28− | Binop String Expr Expr
31+ | Binop String CExpr CExpr
29− | Lambda String Expr
32+ | Lambda String CExpr
30− | App Expr Expr
33+ | App CExpr CExpr
31− | If Expr Expr Expr
34+ | If CExpr CExpr CExpr
32− | Guard [(Expr,Expr)]
35+ | MultiIf [(CExpr,CExpr)]
33− | Lift Expr [Expr]
34− | Fold Expr Expr Expr
35− | Async Expr
36− | Input String
37− | Let [Def] Expr
36+ | Let [Def] CExpr
38 | Var String
37 | Var String
39− | Case Expr [(Pattern,Expr)]
38+ | Case CExpr [(Pattern,CExpr)]
40− | Data String [Expr]
39+ | Data String [CExpr]
41 | Markdown Pandoc.Pandoc
40 | Markdown Pandoc.Pandoc
42 deriving (Eq)
41 deriving (Eq)
43
42
44−data Def = FnDef String [String] Expr
43+data Def = FnDef String [String] CExpr
45− | OpDef String String String Expr
44+ | OpDef String String String CExpr
46− deriving (Eq)
45+ deriving (Eq)
47
46
48data Statement = Definition Def
47data Statement = Definition Def
49 | Datatype String [X] [(String,[Type])]
48 | Datatype String [X] [(String,[Type])]
50− | ImportEvent String Expr String Type
49+ | ImportEvent String CExpr String Type
51 | ExportEvent String String Type
50 | ExportEvent String String Type
52 deriving (Eq,Show)
51 deriving (Eq,Show)
53
52
54−cons h t = Data "Cons" [h,t]
53+cons h t = epos h t (Data "Cons" [h,t])
55−nil = Data "Nil" []
54+nil = C (Just "[]") NoSpan (Data "Nil" [])
56list = foldr cons nil
55list = foldr cons nil
57tuple es = Data ("Tuple" ++ show (length es)) es
56tuple es = Data ("Tuple" ++ show (length es)) es
58
57
59−delist (Data "Cons" [h,t]) = h : delist t
58+delist (C _ _ (Data "Cons" [h,t])) = h : delist t
60delist _ = []
59delist _ = []
61
60
62
61
@@ -80,43 +79,49 @@ instance Show Pattern where
80 where parens s = "(" ++ s ++ ")"
79 where parens s = "(" ++ s ++ ")"
81
80
82instance Show Expr where
81instance Show Expr where
82+ show e =
83+ case e of
83− show (IntNum n) = show n
84+ IntNum n -> show n
84− show (FloatNum n) = show n
85+ FloatNum n -> show n
85− show (Chr c) = show c
86+ Chr c -> show c
86− show (Str s) = show s
87+ Str s -> show s
87− show (Boolean b) = show b
88+ Boolean b -> show b
88− show (Range e1 e2) = "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
89+ Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
89− show (Access e x) = show' e ++ "." ++ x
90+ Access e x -> show' e ++ "." ++ x
91+ Record r -> "{" ++ intercalate ", " (map fields r) ++ "}"
92+ where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
90− show (Binop op e1 e2) = show' e1 ++ " " ++ op ++ " " ++ show' e2
93+ Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
91− show (Lambda x e) = let (xs,e') = getLambdas (Lambda x e) in
94+ Lambda x e -> let (xs,e') = getLambdas (noContext $ Lambda x e) in
92 concat [ "\\", intercalate " " xs, " -> ", show e' ]
95 concat [ "\\", intercalate " " xs, " -> ", show e' ]
93− show (App e1 e2) = show' e1 ++ " " ++ show' e2
96+ App e1 e2 -> show' e1 ++ " " ++ show' e2
94− show (If e1 e2 e3) = concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]
97+ If e1 e2 e3 -> concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]
95− show (Guard ps) = concatMap (\(b,e) -> concat ["\n | ",show b," = ",show e]) ps
98+ MultiIf (p:ps) -> concat [ "if | ", iff p, sep (map iff ps) ]
99+ where iff (b,e) = show b ++ " -> " ++ show e
100+ sep = concatMap ("\n | " ++)
96− show (Let defs e) = "let { " ++ intercalate " ; " (map show defs) ++ " } in " ++ show e
101+ Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
97− show (Var x) = x
102+ Var x -> x
98− show (Case e pats) = "case " ++ show e ++ " of { " ++ intercalate " ; " (map (\(p,e) -> show p ++ " -> " ++ show e) pats) ++ " }"
103+ Case e pats -> "case "++ show e ++" of { "++ intercalate " ; " pats' ++" }"
104+ where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
99− show (Data name es)
105+ Data name es
100− | name == "Cons" = ("["++) . (++"]") . intercalate "," . map show $ delist (Data "Cons" es)
106+ | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
107+ delist (noContext $ Data "Cons" es)
101− | name == "Nil" = "[]"
108+ | name == "Nil" -> "[]"
102− | otherwise = name ++ " " ++ intercalate " " (map show' es)
109+ | otherwise -> name ++ " " ++ intercalate " " (map show' es)
103− show (Lift f es) = concat [ "lift", show $ length es, " ", show' f, " ", intercalate " " (map show' es) ]
104− show (Fold e1 e2 e3) = concat [ "foldp ", show' e1, " ", show' e2, " ", show' e3 ]
105− show (Async e) = "async " ++ show' e
106− show (Input i) = i
107− show (Markdown _) = "[markdown| ... |]"
110+ Markdown _ -> "[markdown| ... |]"
108
111
109
112
110instance Show Def where
113instance Show Def where
114+ show e =
115+ case e of
111− show (FnDef v [] e) = v ++ " = " ++ show e
116+ FnDef v [] e -> v ++ " = " ++ show e
112− show (FnDef f args e) = f ++ " " ++ intercalate " " args ++ " = " ++ show e
117+ FnDef f args e -> f ++ " " ++ intercalate " " args ++ " = " ++ show e
113− show (OpDef op a1 a2 e) = intercalate " " [a1,op,a2] ++ " = " ++ show e
118+ OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
114
119
115−getLambdas (Lambda x e) = (x:xs,e')
120+getLambdas (C _ _ (Lambda x e)) = (x:xs,e')
116 where (xs,e') = getLambdas e
121 where (xs,e') = getLambdas e
117getLambdas e = ([],e)
122getLambdas e = ([],e)
118
123
119−show' e = if needsParens e then "(" ++ show e ++ ")" else show e
124+show' (C _ _ e) = if needsParens e then "(" ++ show e ++ ")" else show e
120
125
121needsParens (Binop _ _ _) = True
126needsParens (Binop _ _ _) = True
122needsParens (Lambda _ _) = True
127needsParens (Lambda _ _) = True
@@ -125,7 +130,4 @@ needsParens (If _ _ _) = True
125needsParens (Let _ _) = True
130needsParens (Let _ _) = True
126needsParens (Case _ _) = True
131needsParens (Case _ _) = True
127needsParens (Data name (x:xs)) = name /= "Cons"
132needsParens (Data name (x:xs)) = name /= "Cons"
128−needsParens (Lift _ _) = True
129−needsParens (Fold _ _ _) = True
130−needsParens (Async _) = True
131needsParens _ = False
133needsParens _ = False
elm/src/Context.hsnew file+43
@@ -0,0 +1,43 @@
1+
2+module Context where
3+
4+import Text.Parsec.Pos
5+
6+
7+data SrcPos = Pos Int Int
8+ deriving (Eq,Ord)
9+
10+data SrcSpan = Span SrcPos SrcPos | NoSpan
11+ deriving (Eq,Ord)
12+
13+data Context e = C (Maybe String) SrcSpan e deriving (Eq,Ord)
14+
15+
16+instance Show SrcPos where
17+ show (Pos r c) = "Line " ++ show r ++ ", Column " ++ show c
18+
19+instance Show SrcSpan where
20+ show span =
21+ case span of
22+ Span start end -> show start
23+ NoSpan -> ""
24+
25+instance Show e => Show (Context e) where
26+ show (C _ _ e) = show e
27+
28+
29+
30+noContext = C Nothing NoSpan
31+
32+pos start end = C Nothing
33+ (Span (Pos (sourceLine start) (sourceColumn start))
34+ (Pos (sourceLine end ) (sourceColumn end )))
35+
36+epos (C _ s1 _) (C _ s2 _) = C Nothing span
37+ where span = case (s1,s2) of
38+ (Span start _, Span _ end) -> Span start end
39+ (_, NoSpan) -> s1
40+ (NoSpan, _) -> s2
41+
42+addCtx x (C Nothing span e) = C (Just (show x)) span e
43+addCtx x (C txt span e) = C txt span e
elm/src/Gen/Cases.hs+16−13
@@ -7,6 +7,7 @@ import Data.List (groupBy,sortBy,lookup)
7import Data.Maybe (fromMaybe)
7import Data.Maybe (fromMaybe)
8
8
9import Ast
9import Ast
10+import Context
10import Guid
11import Guid
11import Substitute
12import Substitute
12
13
@@ -20,7 +21,7 @@ newVar = do n <- guid
20data Match = Match String [Clause] Match
21data Match = Match String [Clause] Match
21 | Break
22 | Break
22 | Fail
23 | Fail
23− | Other Expr
24+ | Other CExpr
24 | Seq [Match]
25 | Seq [Match]
25 deriving Show
26 deriving Show
26
27
@@ -31,18 +32,20 @@ matchSubst :: [(String,String)] -> Match -> Match
31matchSubst _ Break = Break
32matchSubst _ Break = Break
32matchSubst _ Fail = Fail
33matchSubst _ Fail = Fail
33matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
34matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
34−matchSubst pairs (Other e) =
35+matchSubst pairs (Other (C t s e)) =
35− Other $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
36+ Other . C t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
37+matchSubst pairs (Match n cs m) =
36−matchSubst pairs (Match n cs m) = Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
38+ Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
37− where clauseSubst (Clause c vs m) = Clause c (map varSubst vs) (matchSubst pairs m)
38− varSubst v = fromMaybe v (lookup v pairs)
39+ where varSubst v = fromMaybe v (lookup v pairs)
40+ clauseSubst (Clause c vs m) =
41+ Clause c (map varSubst vs) (matchSubst pairs m)
39
42
40isCon (PData _ _ : _, _) = True
43isCon (PData _ _ : _, _) = True
41isCon _ = False
44isCon _ = False
42
45
43isVar p = not (isCon p)
46isVar p = not (isCon p)
44
47
45−match :: [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Match
48+match :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
46match [] [] def = return def
49match [] [] def = return def
47match [] [([],e)] Fail = return $ Other e
50match [] [([],e)] Fail = return $ Other e
48match [] [([],e)] Break = return $ Other e
51match [] [([],e)] Break = return $ Other e
@@ -52,19 +55,19 @@ match vs cs def
52 | all isCon cs = matchCon vs cs def
55 | all isCon cs = matchCon vs cs def
53 | otherwise = matchMix vs cs def
56 | otherwise = matchMix vs cs def
54
57
55−matchVar :: [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Match
58+matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
56matchVar (v:vs) cs def = match vs (map subVar cs) def
59matchVar (v:vs) cs def = match vs (map subVar cs) def
57− where subVar (PVar x : ps, e) = (ps, subst x (Var v) e)
60+ where subVar (PVar x : ps, C t s e) = (ps, C t s $ subst x (Var v) e)
58− subVar (PAnything : ps, e) = (ps, e)
61+ subVar (PAnything : ps, ce) = (ps, ce)
59
62
60−matchCon :: [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Match
63+matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
61matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css
64matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css
62 where css = groupBy (withName (==)) $ sortBy (withName compare) cs
65 where css = groupBy (withName (==)) $ sortBy (withName compare) cs
63 withName f (PData n1 _:_,_) (PData n2 _:_,_) = f n1 n2
66 withName f (PData n1 _:_,_) (PData n2 _:_,_) = f n1 n2
64 toClause cs = let (PData name _ : _ , _) = head cs in
67 toClause cs = let (PData name _ : _ , _) = head cs in
65 matchClause name (v:vs) cs Break
68 matchClause name (v:vs) cs Break
66
69
67−matchClause :: String -> [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Clause
70+matchClause :: String -> [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Clause
68matchClause c (v:vs) cs def =
71matchClause c (v:vs) cs def =
69 do vs' <- getVars
72 do vs' <- getVars
70 Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def
73 Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def
@@ -72,6 +75,6 @@ matchClause c (v:vs) cs def =
72 getVars = let (PData _ ps : _, _) = head cs in
75 getVars = let (PData _ ps : _, _) = head cs in
73 mapM (\_ -> newVar) ps
76 mapM (\_ -> newVar) ps
74
77
75−matchMix :: [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Match
78+matchMix :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
76matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
79matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
77 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
80 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
elm/src/Gen/CompileToJS.hs+66−40
@@ -1,6 +1,7 @@
1module CompileToJS (showErr, jsModule) where
1module CompileToJS (showErr, jsModule) where
2
2
3import Ast
3import Ast
4+import Context
4import Control.Arrow (first)
5import Control.Arrow (first)
5import Control.Monad (liftM,(<=<),join,ap)
6import Control.Monad (liftM,(<=<),join,ap)
6import Data.Char (isAlpha,isDigit)
7import Data.Char (isAlpha,isDigit)
@@ -140,22 +141,22 @@ class ToJS a where
140 toJS :: a -> GuidCounter String
141 toJS :: a -> GuidCounter String
141
142
142instance ToJS Def where
143instance ToJS Def where
143− toJS (FnDef x [] e) = assign x `liftM` toJS e
144+ toJS (FnDef x [] e) = assign x `liftM` toJS' e
144 toJS (FnDef f (a:as) e) =
145 toJS (FnDef f (a:as) e) =
145− do body <- toJS (foldr Lambda e as)
146+ do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)
146 return $ concat ["\nfunction ",f,parens a, braces . indent $ ret body]
147 return $ concat ["\nfunction ",f,parens a, braces . indent $ ret body]
147 toJS (OpDef op a1 a2 e) =
148 toJS (OpDef op a1 a2 e) =
148− do body <- toJS (foldr Lambda e [a1,a2])
149+ do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])
149 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
150 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
150
151
151instance ToJS Statement where
152instance ToJS Statement where
152 toJS (Definition d) = toJS d
153 toJS (Definition d) = toJS d
153 toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
154 toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
154− where toDef (name,args) =
155+ where toDef (name,args) = Definition . FnDef name vars . noContext $
155− Definition . FnDef name vars $ Data (derename name) (map Var vars)
156+ Data (derename name) (map (noContext . Var) vars)
156 where vars = map (('a':) . show) [1..length args]
157 where vars = map (('a':) . show) [1..length args]
157 toJS (ImportEvent js base elm _) =
158 toJS (ImportEvent js base elm _) =
158− do v <- toJS base
159+ do v <- toJS' base
159 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
160 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
160 , "\nValue.addListener(document, '" ++ js
161 , "\nValue.addListener(document, '" ++ js
161 , "', function(e) { Dispatcher.notify(" ++ elm
162 , "', function(e) { Dispatcher.notify(" ++ elm
@@ -167,6 +168,13 @@ instance ToJS Statement where
167 , "e.value = v;"
168 , "e.value = v;"
168 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
169 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
169
170
171+toJS' :: CExpr -> GuidCounter String
172+toJS' (C txt span expr) =
173+ case expr of
174+ MultiIf ps -> multiIfToJS span ps
175+ Case e cases -> caseToJS span e cases
176+ _ -> toJS expr
177+
170instance ToJS Expr where
178instance ToJS Expr where
171 toJS expr =
179 toJS expr =
172 case expr of
180 case expr of
@@ -176,22 +184,38 @@ instance ToJS Expr where
176 Chr c -> return $ quoted [c]
184 Chr c -> return $ quoted [c]
177 Str s -> return $ "Value.str" ++ parens (quoted s)
185 Str s -> return $ "Value.str" ++ parens (quoted s)
178 Boolean b -> return $ if b then "true" else "false"
186 Boolean b -> return $ if b then "true" else "false"
179− Range lo hi -> jsRange `liftM` toJS lo `ap` toJS hi
187+ Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
180− Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS e
188+ Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS' e
189+
190+ Record fs -> (braces . intercalate ",\n") `liftM` mapM toField fs
191+ where toField (f, as, ce@(C t s e)) =
192+ do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) ce as)
193+ return (f ++ " : " ++ v)
194+
181− Binop op e1 e2 -> binop op `liftM` toJS e1 `ap` toJS e2
195+ Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
196+
197+ If eb et ef ->
182− If eb et ef -> parens `liftM` (iff `liftM` toJS eb `ap` toJS et `ap` toJS ef)
198+ parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
183− Guard ps -> guardToJS ps
199+
184− Lambda v e -> liftM (jsFunc v . ret) (toJS e)
200+ Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
201+
202+ App (C _ _ (Var "toText")) (C _ _ (Str s)) ->
185− App (Var "toText") (Str s) -> return $ "toText" ++ parens (quoted s)
203+ return $ "toText" ++ parens (quoted s)
204+
205+ App (C _ _ (Var "link")) (C _ _ (Str s)) ->
186− App (Var "link") (Str s) -> return $ "link(" ++ quoted s ++ ")"
206+ return $ "link(" ++ quoted s ++ ")"
207+
208+ App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->
187− App (Var "plainText") (Str s) -> return $ "plainText(" ++ quoted s ++ ")"
209+ return $ "plainText(" ++ quoted s ++ ")"
210+
188− App e1 e2 -> (++) `liftM` (toJS e1) `ap` (parens `liftM` toJS e2)
211+ App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)
189 Let defs e -> jsLet defs e
212 Let defs e -> jsLet defs e
190− Case e cases -> caseToJS e cases
191− Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS es
213+ Data name es -> (\ss -> jsList $ quoted name : ss) `liftM` mapM toJS' es
214+
192 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
215 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
193− where md = formatMarkdown $ Pan.writeHtmlString Pan.defaultWriterOptions doc
194− pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
216+ where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
217+ md = formatMarkdown $
218+ Pan.writeHtmlString Pan.defaultWriterOptions doc
195
219
196formatMarkdown = concatMap f
220formatMarkdown = concatMap f
197 where f '\'' = "\\'"
221 where f '\'' = "\\'"
@@ -199,15 +223,16 @@ formatMarkdown = concatMap f
199 f '"' = "\""
223 f '"' = "\""
200 f c = [c]
224 f c = [c]
201
225
202−guardToJS ps = format `liftM` mapM f ps
226+multiIfToJS span ps = format `liftM` mapM f ps
203 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
227 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
204− err = "(function(){throw \"Non-exhaustive guard expression\";}())"
228+ err = concat [ "(function(){throw \"Non-exhaustive "
229+ , "multi-way-if expression (", show span, ")\";}())" ]
205− f (b,e) = do b' <- toJS b
230+ f (b,e) = do b' <- toJS' b
206− e' <- toJS e
231+ e' <- toJS' e
207 return (b' ++ " ? " ++ e')
232 return (b' ++ " ? " ++ e')
208
233
209jsLet defs e' = do
234jsLet defs e' = do
210− body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS e')
235+ body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
211 return $ jsFunc "" body ++ "()"
236 return $ jsFunc "" body ++ "()"
212
237
213jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
238jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
@@ -215,28 +240,29 @@ jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
215 valueOf (FnDef _ args _) = min 1 (length args)
240 valueOf (FnDef _ args _) = min 1 (length args)
216 valueOf (OpDef _ _ _ _) = 1
241 valueOf (OpDef _ _ _ _) = 1
217
242
218−caseToJS e ps = do
243+caseToJS span e ps = do
219 match <- caseToMatch ps
244 match <- caseToMatch ps
220− e' <- toJS e
245+ e' <- toJS' e
221 (match',stmt) <- case (match,e) of
246 (match',stmt) <- case (match,e) of
222− (Match name _ _, Var x) -> return (matchSubst [(name,x)] match, "")
247+ (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")
223− (Match name _ _, _ ) -> return (match, assign name e')
248+ (Match name _ _, _) -> return (match, assign name e')
224− _ -> liftM (\n -> (match, e')) guid
249+ _ -> liftM (\n -> (match, e')) guid
225− matches <- matchToJS match'
250+ matches <- matchToJS span match'
226 return $ concat [ "function(){", stmt, matches, "}()" ]
251 return $ concat [ "function(){", stmt, matches, "}()" ]
227
252
228−matchToJS (Match name clauses def) = do
253+matchToJS span (Match name clauses def) = do
229− cases <- concat `liftM` mapM (clauseToJS name) clauses
254+ cases <- concat `liftM` mapM (clauseToJS span name) clauses
230− finally <- matchToJS def
255+ finally <- matchToJS span def
231 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
256 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]
232−matchToJS Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"
257+matchToJS span Fail = return ("\nthrow \"Non-exhaustive pattern match " ++
258+ "in case expression (" ++ show span ++ ")\";")
233−matchToJS Break = return "break;"
259+matchToJS span Break = return "break;"
234−matchToJS (Other e) = ret `liftM` toJS e
260+matchToJS span (Other e) = ret `liftM` toJS' e
235−matchToJS (Seq ms) = concat `liftM` mapM matchToJS ms
261+matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
236
262
237−clauseToJS var (Clause name vars e) = do
263+clauseToJS span var (Clause name vars e) = do
238 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
264 let vars' = map (\n -> var ++ "[" ++ show n ++ "]") [ 1 .. length vars ]
239− s <- matchToJS $ matchSubst (zip vars vars') e
265+ s <- matchToJS span $ matchSubst (zip vars vars') e
240 return $ concat [ "\ncase ", quoted name, ":", s ]
266 return $ concat [ "\ncase ", quoted name, ":", s ]
241
267
242jsNil = "[\"Nil\"]"
268jsNil = "[\"Nil\"]"
elm/src/Gen/ExtractNoscript.hs+11−7
@@ -2,6 +2,7 @@
2module ExtractNoscript (extractNoscript) where
2module ExtractNoscript (extractNoscript) where
3
3
4import Ast
4import Ast
5+import Context
5import qualified Text.Pandoc as Pan
6import qualified Text.Pandoc as Pan
6
7
7extractNoscript :: Module -> String
8extractNoscript :: Module -> String
@@ -22,6 +23,9 @@ instance Extract Def where
22 extract (FnDef _ _ e) = extract e
23 extract (FnDef _ _ e) = extract e
23 extract (OpDef _ _ _ e) = extract e
24 extract (OpDef _ _ _ e) = extract e
24
25
26+instance Extract e => Extract (Context e) where
27+ extract (C _ _ e) = extract e
28+
25instance Extract Expr where
29instance Extract Expr where
26 extract expr =
30 extract expr =
27 let f = extract in
31 let f = extract in
@@ -31,13 +35,13 @@ instance Extract Expr where
31 ("++", [s1], [s2]) -> [s1 ++ s2]
35 ("++", [s1], [s2]) -> [s1 ++ s2]
32 (_ , ss1 , ss2 ) -> ss1 ++ ss2
36 (_ , ss1 , ss2 ) -> ss1 ++ ss2
33 Lambda v e -> f e
37 Lambda v e -> f e
34− App (App (Var "link") src) txt -> linkExtract src txt
38+ App (C _ _ (App (C _ _ (Var "link")) src)) txt -> linkExtract src txt
35− App (App (Var "Graphics.link") src) txt -> linkExtract src txt
39+ App (C _ _ (App (C _ _ (Var "Graphics.link")) src)) txt -> linkExtract src txt
36− App (App (Var "Text.link") src) txt -> linkExtract src txt
40+ App (C _ _ (App (C _ _ (Var "Text.link")) src)) txt -> linkExtract src txt
37− App (Var "header") e -> tag "h1" e
41+ App (C _ _ (Var "header")) e -> tag "h1" e
38− App (Var "bold") e -> tag "b" e
42+ App (C _ _ (Var "bold")) e -> tag "b" e
39− App (Var "italic") e -> tag "i" e
43+ App (C _ _ (Var "italic")) e -> tag "i" e
40− App (Var "monospace") e -> tag "code" e
44+ App (C _ _ (Var "monospace")) e -> tag "code" e
41 App e1 e2 -> f e1 ++ f e2
45 App e1 e2 -> f e1 ++ f e2
42 If eb et ef -> f et ++ f ef
46 If eb et ef -> f et ++ f ef
43 Let defs e -> concatMap extract defs ++ f e
47 Let defs e -> concatMap extract defs ++ f e
elm/src/Optimize.hs+90−71
@@ -1,6 +1,7 @@
1module Optimize (optimize) where
1module Optimize (optimize) where
2
2
3import Ast
3import Ast
4+import Context
4import Control.Arrow (second)
5import Control.Arrow (second)
5import Data.Char (isAlpha)
6import Data.Char (isAlpha)
6import Substitute
7import Substitute
@@ -22,7 +23,9 @@ instance Simplify Statement where
22instance Simplify Def where
23instance Simplify Def where
23 simp (FnDef func args e) = FnDef func args (simp e)
24 simp (FnDef func args e) = FnDef func args (simp e)
24 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
25 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
25−
26+
27+instance Simplify e => Simplify (Context e) where
28+ simp (C t s e) = C t s (simp e)
26
29
27instance Simplify Expr where
30instance Simplify Expr where
28 simp expr =
31 simp expr =
@@ -31,9 +34,11 @@ instance Simplify Expr where
31 Range e1 e2 -> Range (f e1) (f e2)
34 Range e1 e2 -> Range (f e1) (f e2)
32 Binop op e1 e2 -> simp_binop op (f e1) (f e2)
35 Binop op e1 e2 -> simp_binop op (f e1) (f e2)
33 Lambda x e -> Lambda x (f e)
36 Lambda x e -> Lambda x (f e)
37+ Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)
34− App (Lambda x e1) e2 ->
38+ App (C t s (Lambda x e1)) e2 ->
35− if isValue e2' then subst x e2' e1' else App (Lambda x e1') e2'
39+ if isValue e2' then subst x e2' e1' else App (C t s (Lambda x ce1')) ce2'
36− where { e1' = f e1 ; e2' = f e2 }
40+ where ce1'@(C _ _ e1') = f e1
41+ ce2'@(C _ _ e2') = f e2
37 App e1 e2 -> App (f e1) (f e2)
42 App e1 e2 -> App (f e1) (f e2)
38 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
43 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
39 Let defs e -> Let (map simp defs) (f e)
44 Let defs e -> Let (map simp defs) (f e)
@@ -41,75 +46,89 @@ instance Simplify Expr where
41 Case e cases -> Case (f e) (map (second f) cases)
46 Case e cases -> Case (f e) (map (second f) cases)
42 _ -> expr
47 _ -> expr
43
48
44−simp_if (Boolean b) e2 e3 = if b then e2 else e3
49+simp_if (C _ _ (Boolean b)) (C _ _ e2) (C _ _ e3) = if b then e2 else e3
45simp_if a b c = If a b c
50simp_if a b c = If a b c
46
51
52+isValue e =
47−isValue e = case e of { IntNum _ -> True
53+ case e of { IntNum _ -> True
48− ; FloatNum _ -> True
54+ ; FloatNum _ -> True
49− ; Chr _ -> True
55+ ; Chr _ -> True
50− ; Str _ -> True
56+ ; Str _ -> True
51− ; Boolean _ -> True
57+ ; Boolean _ -> True
52− ; Var _ -> True
58+ ; Var _ -> True
53− ; Data _ _ -> True
59+ ; Data _ _ -> True
54− ; _ -> False }
60+ ; _ -> False }
55
61
56simp_binop = binop
62simp_binop = binop
57
63
58−binop op (IntNum n) (IntNum m) = f n m
64+binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =
65+ let c1 = C t1 s1 in
66+ let c2 = C t2 s2 in
67+ case (op, e1, e2) of
59− where f a b = case op of
68+ (_, IntNum n, IntNum m) -> case op of
60− { "+" -> IntNum $ (+) a b
69+ { "+" -> IntNum $ (+) n m
61− ; "-" -> IntNum $ (-) a b
70+ ; "-" -> IntNum $ (-) n m
62− ; "*" -> IntNum $ (*) a b
71+ ; "*" -> IntNum $ (*) n m
72+ ; "^" -> IntNum $ n ^ m
63− ; "div" -> IntNum $ div a b
73+ ; "div" -> IntNum $ div n m
64− ; "mod" -> IntNum $ mod a b
74+ ; "mod" -> IntNum $ mod n m
65− ; "<" -> Boolean $ a < b
75+ ; "<" -> Boolean $ n < m
66− ; ">" -> Boolean $ a < b
76+ ; ">" -> Boolean $ n < m
67− ; "<=" -> Boolean $ a <= b
77+ ; "<=" -> Boolean $ n <= m
68− ; ">=" -> Boolean $ a >= b
78+ ; ">=" -> Boolean $ n >= m
69− ; "==" -> Boolean $ a == b
79+ ; "==" -> Boolean $ n == m
70− ; "/=" -> Boolean $ a /= b
80+ ; "/=" -> Boolean $ n /= m
71− ; _ -> Binop op (IntNum n) (IntNum m) }
81+ ; _ -> Binop op ce1 ce2 }
72−
82+
73−binop "-" e (IntNum 0) = e
83+ -- flip order to move lone integers to the left
84+ ("+", _, IntNum n) -> binop "+" ce2 ce1
85+ ("*", _, IntNum n) -> binop "*" ce2 ce1
86+
87+ ("+", IntNum 0, _) -> e2
88+ ("+", IntNum n, Binop "+" (C _ _ (IntNum m)) ce) ->
74−binop "+" (IntNum 0) e = e
89+ binop "+" (c1 $ IntNum (n+m)) ce
75−binop "+" e (IntNum 0) = e
90+ ("+", Binop "+" (C _ _ (IntNum n)) ce1'
91+ , Binop "+" (C _ _ (IntNum m)) ce2') ->
76−binop "+" (IntNum n) (Binop "+" (IntNum m) e) = binop "+" (IntNum (n+m)) e
92+ binop "+" (noContext $ IntNum (n+m)) (noContext $ Binop "+" ce1' ce2')
93+
94+ ("*", IntNum 0, _) -> e1
95+ ("*", IntNum 1, _) -> e2
96+ ("*", IntNum n, Binop "*" (C _ _ (IntNum m)) ce) ->
97+ binop "*" (noContext $ IntNum (n*m)) ce
98+ ("*", Binop "*" (C _ _ (IntNum n)) ce1'
77−binop "+" (IntNum n) (Binop "+" e (IntNum m)) = binop "+" (IntNum (n+m)) e
99+ , Binop "*" (C _ _ (IntNum m)) ce2') ->
78−
100+ binop "*" (noContext $ IntNum (n*m)) (noContext $ Binop "*" ce1' ce2')
101+
102+ ("-", _, IntNum 0) -> e1
79−binop "/" e (IntNum 1) = e
103+ ("/", _, IntNum 1) -> e1
80−binop "div" e (IntNum 1) = e
81−binop "*" (IntNum 0) e = IntNum 0
82−binop "*" (IntNum 1) e = e
104+ ("div", _, IntNum 1) -> e1
83−binop "*" (IntNum n) (Binop "*" (IntNum m) e) = binop "*" (IntNum (n*m)) e
105+
84−binop "*" (IntNum n) (Binop "*" e (IntNum m)) = binop "*" (IntNum (n*m)) e
85−
86−binop "+" e (IntNum n) = binop "+" (IntNum n) e
87−binop "*" e (IntNum n) = binop "*" (IntNum n) e
88−
89−binop op (Boolean n) (Boolean m) = f n m
90− where f a b = case op of { "&&" -> Boolean $ (&&) n m
106+ (_, Boolean n, Boolean m) -> case op of "&&" -> Boolean $ n && m
91− ; "||" -> Boolean $ (||) n m
107+ "||" -> Boolean $ n || m
92− ; _ -> Binop op (Boolean n) (Boolean m) }
108+ _ -> Binop op ce1 ce2
93−
109+
94−binop "&&" (Boolean True) e = e
110+ ("&&", Boolean True, _) -> e2
95−binop "&&" (Boolean False) e = Boolean False
111+ ("&&", Boolean False, _) -> Boolean False
96−binop "||" (Boolean True) e = Boolean True
112+ ("||", Boolean True, _) -> Boolean True
97−binop "||" (Boolean False) e = e
113+ ("||", Boolean False, _) -> e2
98−
114+
99−binop "&&" e (Boolean n) = binop "&&" (Boolean n) e
115+ (":", _, _) -> let (C _ _ e) = cons ce1 ce2 in e
100−binop "||" e (Boolean n) = binop "||" (Boolean n) e
116+
101−
102−binop ":" h t = cons h t
103−binop "++" (Str s1) (Str s2) = Str $ s1 ++ s2
117+ ("++", Str s1, Str s2) -> Str $ s1 ++ s2
104−binop "++" (Str s1) (Binop "++" (Str s2) e) = Binop "++" (Str $ s1 ++ s2) e
118+ ("++", Str s1, Binop "++" (C _ _ (Str s2)) ce) ->
119+ Binop "++" (c1 $ Str $ s1 ++ s2) ce
105−binop "++" (Binop "++" e (Str s1)) (Str s2) = Binop "++" e (Str $ s1 ++ s2)
120+ ("++", Binop "++" e (C _ _ (Str s1)), Str s2) ->
121+ Binop "++" e (c1 $ Str $ s1 ++ s2)
122+
106−binop "++" (Data "Nil" []) e = e
123+ ("++", Data "Nil" [], _) -> e2
107−binop "++" e (Data "Nil" []) = e
124+ ("++", _, Data "Nil" []) -> e1
108−binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]
125+ ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, noContext $ binop "++" t ce2]
109−
126+
110−binop "$" e1 e2 = App e1 e2
127+ ("$", _, _) -> App ce1 ce2
111−binop "." e1 e2 = Lambda "x" (App e1 (App e2 (Var "x")))
128+ (".", _, _) ->
112−
129+ Lambda "x" (noContext $
113−binop op e1 e2
130+ App ce1 (noContext $ App ce2 (noContext $ Var "x")))
131+
114− | isAlpha (head op) || '_' == head op = App (App (Var op) e1) e2
132+ _ | isAlpha (head op) || '_' == head op ->
133+ App (noContext $ App (noContext $ Var op) ce1) ce2
115− | otherwise = Binop op e1 e2
134+ | otherwise -> Binop op ce1 ce2
elm/src/Parse/Binops.hs+59−41
@@ -1,9 +1,11 @@
1module Parse.Binops (binops) where
1module Parse.Binops (binops) where
2
2
3import Ast
3import Ast
4+import Context
4import Control.Monad (liftM,guard)
5import Control.Monad (liftM,guard)
5import Control.Monad.Error
6import Control.Monad.Error
6−import Data.List (foldl',splitAt,elemIndices,group,groupBy,sortBy,find)
7+import Data.List (foldl',splitAt,elemIndices
8+ ,group,groupBy,sortBy,find,intercalate)
7import qualified Data.Map as Map
9import qualified Data.Map as Map
8import Data.Maybe (mapMaybe)
10import Data.Maybe (mapMaybe)
9
11
@@ -12,6 +14,9 @@ import Parse.Library
12
14
13data Assoc = L | N | R deriving (Eq,Show)
15data Assoc = L | N | R deriving (Eq,Show)
14
16
17+type OpTable = [(Int, Assoc, String)]
18+
19+table :: OpTable
15table = [ (9, R, ".")
20table = [ (9, R, ".")
16 , (8, R, "^")
21 , (8, R, "^")
17 , (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")
22 , (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")
@@ -19,52 +24,65 @@ table = [ (9, R, ".")
19 , (5, R, ":" ), (5, R, "++")
24 , (5, R, ":" ), (5, R, "++")
20 , (4, N, "<="), (4, N, ">="), (4, N, "<")
25 , (4, N, "<="), (4, N, ">="), (4, N, "<")
21 , (4, N, "=="), (4, N, "/="), (4, N, ">")
26 , (4, N, "=="), (4, N, "/="), (4, N, ">")
22− , (4, L, "<~"), (4, L, "~")
27+ , (4, L, "~"), (4, L, "<~")
23 , (3, R, "&&")
28 , (3, R, "&&")
24 , (2, R, "||")
29 , (2, R, "||")
25 , (0, R, "$")
30 , (0, R, "$")
26 ]
31 ]
27
32
33+opLevel op = Map.findWithDefault 9 op dict
34+ where dict = Map.fromList (map (\(lvl,_,op) -> (op,lvl)) table)
35+
36+opAssoc op = Map.findWithDefault R op dict
37+ where dict = Map.fromList (map (\(_,assoc,op) -> (op,assoc)) table)
38+
39+hasLevel n (op,e) = opLevel op == n
40+
41+sortOps :: OpTable -> OpTable
28sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)
42sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)
29
43
44+binops :: IParser CExpr -> IParser String -> IParser CExpr
30binops term anyOp = do
45binops term anyOp = do
31 e <- term
46 e <- term
32− (ops,es) <- liftM unzip $
33− many (commitIf (whitespace >> anyOp) $ do { whitespace ; op <- anyOp
47+ split 0 e =<< many (commitIf (whitespace >> anyOp) $ do
48+ whitespace ; op <- anyOp
34− ; whitespace ; e <- term
49+ whitespace ; e <- term
35− ; return (op,e) })
50+ return (op,e))
36− case binopOf Map.empty (sortOps table) ops (e:es) of
51+
52+split :: Int -> CExpr -> [(String, CExpr)] -> IParser CExpr
37− Right e -> return e
53+split _ e [] = return e
38− Left msg -> fail msg
54+split n e eops = do
39−
55+ assoc <- getAssoc n eops
40−binopSplit seen opTable i ops es =
56+ es <- sequence (splitLevel n e eops)
41− case (splitAt i ops, splitAt (i+1) es) of
57+ let ops = map fst (filter (hasLevel n) eops)
42− ((befores, op:afters), (pres, posts)) ->
58+ case assoc of R -> joinR es ops
43− do e1 <- binopOf seen opTable befores pres
59+ _ -> joinL es ops
44− e2 <- binopOf seen opTable afters posts
60+
45− return $ Binop op e1 e2
61+splitLevel :: Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]
46−
62+splitLevel n e eops =
47−binopOf _ _ _ [e] = return e
63+ case break (hasLevel n) eops of
48−binopOf seen [] ops es = binopOf seen [(9,L,head ops)] ops es
64+ (lops, (op,e'):rops) -> split (n+1) e lops : splitLevel n e' rops
49−
65+ (lops, []) -> [ split (n+1) e lops ]
50−binopOf seen (tbl@((lvl, L, op):rest)) ops es =
66+
51− case elemIndices op ops of
67+joinL :: [CExpr] -> [String] -> IParser CExpr
52− [] -> binopOf seen rest ops es
68+joinL [e] [] = return e
53− is -> case Map.lookup lvl seen of
69+joinL (a:b:es) (op:ops) = joinL (epos a b (Binop op a b) : es) ops
54− Nothing -> binopSplit (Map.insert lvl (L,op) seen) tbl (last is) ops es
70+joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."
55− Just (L,_) -> binopSplit seen tbl (last is) ops es
71+
56− Just (assoc,op') -> Left $ errorMessage lvl op L op' assoc
72+joinR :: [CExpr] -> [String] -> IParser CExpr
57−binopOf seen (tbl@((lvl, assoc, op):rest)) ops es =
73+joinR [e] [] = return e
58− case elemIndices op ops of
74+joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
59− [] -> binopOf seen rest ops es
75+ return (epos a e (Binop op a e))
60− i:_ -> case Map.lookup lvl seen of
76+joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."
61− Nothing -> binopSplit (Map.insert lvl (assoc,op) seen) tbl i ops es
77+
62− Just (assoc',op') ->
78+getAssoc :: Int -> [(String,CExpr)] -> IParser Assoc
63− if assoc == assoc' && assoc /= N then
79+getAssoc n eops | all (==L) assocs = return L
64− binopSplit seen tbl i ops es
80+ | all (==R) assocs = return R
65− else Left $ errorMessage lvl op assoc op' assoc'
81+ | all (==N) assocs = case assocs of [_] -> return N
66−
82+ _ -> fail msg
67−errorMessage lvl op1 assoc1 op2 assoc2 =
83+ where levelOps = filter (hasLevel n) eops
68− "Cannot have (" ++ op1 ++ ") with [" ++ show assoc1 ++ " " ++
84+ assocs = map (opAssoc . fst) levelOps
69− show lvl ++ "] and (" ++ op2 ++ ") with [" ++ show assoc2 ++ " " ++
85+ msg = concat [ "Conflicting precedence for binary operators ("
70− show lvl ++ "]"
86+ , intercalate ", " (map fst eops), "). "
87+ , "Consider adding parentheses to disambiguate." ]
88+
elm/src/Parse/Expr.hs+86−46
@@ -1,6 +1,7 @@
1module Parse.Expr (def,term) where
1module Parse.Expr (def,term) where
2
2
3import Ast
3import Ast
4+import Context
4import Control.Applicative ((<$>), (<*>))
5import Control.Applicative ((<$>), (<*>))
5import Control.Monad
6import Control.Monad
6import Data.Char (isSymbol, isDigit)
7import Data.Char (isSymbol, isDigit)
@@ -45,56 +46,107 @@ chrTerm :: IParser Expr
45chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
46chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
46 <?> "character"
47 <?> "character"
47
48
49+accessor :: IParser Expr
50+accessor = do
51+ start <- getPosition
52+ label <- try (string "." >> lowVar)
53+ end <- getPosition
54+ let ctx e = addCtx ("." ++ label) (pos start end e)
55+ return (Lambda "r" (ctx $ Access (ctx $ Var "r") label))
56+
48
57
49-------- Complex Terms --------
58-------- Complex Terms --------
50
59
51listTerm :: IParser Expr
60listTerm :: IParser Expr
61+listTerm =
52−listTerm = (do { try $ string "[markdown|"
62+ (do { try $ string "[markdown|"
53− ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")
63+ ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")
54− ; return . Markdown $ Pan.readMarkdown Pan.defaultParserState md })
64+ ; return . Markdown $ Pan.readMarkdown Pan.defaultParserState md })
55− <|> (braces $ choice
65+ <|> (braces $ choice
56− [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
66+ [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
57− ; Range lo <$> expr }
67+ ; Range lo <$> expr }
58− , list <$> commaSep expr ])
68+ , do (C _ _ e) <- list <$> commaSep expr
59−
69+ return e
70+ ])
71+
60−parensTerm :: IParser Expr
72+parensTerm :: IParser CExpr
61parensTerm = parens $ choice
73parensTerm = parens $ choice
74+ [ do start <- getPosition
62− [ do op <- anyOp
75+ op <- try anyOp
76+ end <- getPosition
77+ let ctxt = pos start end
63− return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
78+ return . ctxt . Lambda "x" . ctxt . Lambda "y" . ctxt $
79+ Binop op (ctxt $ Var "x") (ctxt $ Var "y")
80+ , do start <- getPosition
64− , do let comma = char ',' <?> "comma ','"
81+ let comma = char ',' <?> "comma ','"
65 commas <- comma >> many (whitespace >> comma)
82 commas <- comma >> many (whitespace >> comma)
83+ end <- getPosition
66 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
84 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
85+ ctxt = pos start end
86+ return $ foldr (\x e -> ctxt $ Lambda x e)
67− return $ foldr Lambda (tuple $ map Var vars) (vars)
87+ (ctxt . tuple $ map (ctxt . Var) vars) vars
88+ , do start <- getPosition
68− , do es <- commaSep expr
89+ es <- commaSep expr
90+ end <- getPosition
69− return $ case es of { [e] -> e; _ -> tuple es }
91+ return $ case es of [e] -> e
92+ _ -> pos start end (tuple es)
70 ]
93 ]
71
94
72−term :: IParser Expr
95+recordTerm :: IParser Expr
96+recordTerm = brackets $ do
97+ Record <$> (mapM extract =<< commaSep field)
98+ where field = do
99+ fDefs <- (:) <$> (PVar <$> lowVar) <*> spacePrefix patternTerm
100+ whitespace
101+ e <- string "=" >> whitespace >> expr
102+ flattenPatterns fDefs e
103+ extract [ FnDef f args exp ] = return (f,args,exp)
104+ extract _ = fail "Improperly formed record field."
105+{--
106+ record <- expr
107+ whitespace >> string "|" >> whitespace
108+ label <- lowVar
109+ whitespace
110+ op <- (string "<-" <|> string "=")
111+ whitespace
112+ e <- expr
113+ case op of
114+ "<-" ->
115+ "=" ->
116+--}
117+
118+term :: IParser CExpr
73−term = choice [ numTerm, strTerm, chrTerm
119+term = addContext (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])
74− , accessible varTerm
120+ <|> accessible (addContext varTerm <|> parensTerm <|> addContext recordTerm)
75− , listTerm, parensTerm ]
76− <?> "basic term (4, x, 'c', etc.)"
121+ <?> "basic term (4, x, 'c', etc.)"
77
122
78-------- Applications --------
123-------- Applications --------
79
124
80−appExpr :: IParser Expr
125+appExpr :: IParser CExpr
81appExpr = do
126appExpr = do
82 tlist <- spaceSep1 term
127 tlist <- spaceSep1 term
83 return $ case tlist of
128 return $ case tlist of
84 t:[] -> t
129 t:[] -> t
85− t:ts -> foldl' App t ts
130+ t:ts -> foldl' (\f x -> epos f x $ App f x) t ts
86
131
87-------- Normal Expressions --------
132-------- Normal Expressions --------
88
133
89−binaryExpr :: IParser Expr
134+binaryExpr :: IParser CExpr
90binaryExpr = binops appExpr anyOp
135binaryExpr = binops appExpr anyOp
91
136
92ifExpr :: IParser Expr
137ifExpr :: IParser Expr
93−ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace
138+ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
139+ where normal = do e1 <- expr ; whitespace
94− reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
140+ reserved "then" ; whitespace ; e2 <- expr
141+ whitespace <?> "an 'else' branch"
95− reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
142+ reserved "else" <?> "an 'else' branch" ; whitespace
96−
143+ If e1 e2 <$> expr
144+ multiIf = (MultiIf <$> spaceSep1 iff)
145+ where iff = do string "|" ; whitespace
146+ b <- expr ; whitespace ; string "->" ; whitespace
147+ (,) b <$> expr
148+
97−lambdaExpr :: IParser Expr
149+lambdaExpr :: IParser CExpr
98lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
150lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
99 whitespace
151 whitespace
100 pats <- spaceSep1 patternTerm
152 pats <- spaceSep1 patternTerm
@@ -103,16 +155,7 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
103 return $ makeLambda pats e
155 return $ makeLambda pats e
104
156
105defSet :: IParser [Def]
157defSet :: IParser [Def]
106−defSet = do
107− brace <- optionMaybe $ do
108− string "{" <?> "a set of definitions { x = ... ; y = ... }"
109− whitespace >> return "{"
110− case brace of
111− Nothing -> concat <$> block (do d <- assignExpr ; whitespace ; return d)
158+defSet = concat <$> block (do d <- assignExpr ; whitespace ; return d)
112− Just "{" -> do dss <- semiSep1 assignExpr
113− whitespace
114− string "}" <?> "closing bracket '}'"
115− return (concat dss)
116
159
117letExpr :: IParser Expr
160letExpr :: IParser Expr
118letExpr = do
161letExpr = do
@@ -130,8 +173,10 @@ caseExpr = do
130 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
173 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
131 without = block (do c <- case_ ; whitespace ; return c)
174 without = block (do c <- case_ ; whitespace ; return c)
132
175
133−expr = choice [ ifExpr, letExpr, caseExpr
176+expr = addContext (choice [ ifExpr, letExpr, caseExpr ])
177+ <|> lambdaExpr
178+ <|> binaryExpr
134− , lambdaExpr, binaryExpr ] <?> "an expression"
179+ <?> "an expression"
135
180
136funcDef = try (do p1 <- try patternTerm ; infics p1 <|> func p1)
181funcDef = try (do p1 <- try patternTerm ; infics p1 <|> func p1)
137 <|> ((:[]) <$> patternExpr)
182 <|> ((:[]) <$> patternExpr)
@@ -149,14 +194,9 @@ assignExpr :: IParser [Def]
149assignExpr = withPos $ do
194assignExpr = withPos $ do
150 fDefs <- funcDef
195 fDefs <- funcDef
151 whitespace
196 whitespace
152− e <- (string "=" >> whitespace >> expr) <|> guardExpr
197+ e <- string "=" >> whitespace >> expr
153 flattenPatterns fDefs e
198 flattenPatterns fDefs e
154
199
155−guardExpr = (Guard <$> spaceSep1 gExpr)
156− where gExpr = do string "|" ; whitespace
157− b <- expr ; whitespace ; string "=" ; whitespace
158− (,) b <$> expr
159−
160def = map Definition <$> assignExpr
200def = map Definition <$> assignExpr
161
201
162
202
elm/src/Parse/Library.hs+18−5
@@ -2,6 +2,7 @@
2module Parse.Library where
2module Parse.Library where
3
3
4import Ast
4import Ast
5+import Context
5import Control.Applicative ((<$>),(<*>))
6import Control.Applicative ((<$>),(<*>))
6import Control.Monad
7import Control.Monad
7import Control.Monad.State
8import Control.Monad.State
@@ -57,7 +58,9 @@ isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
57symOp :: IParser String
58symOp :: IParser String
58symOp = do op <- many1 (satisfy isOp)
59symOp = do op <- many1 (satisfy isOp)
59 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594" ])
60 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594" ])
61+ case op of
62+ "." -> notFollowedBy lower >> return op
60− return op
63+ _ -> return op
61
64
62arrow :: IParser String
65arrow :: IParser String
63arrow = string "->" <|> string "\8594" <?> "arrow (->)"
66arrow = string "->" <|> string "\8594" <?> "arrow (->)"
@@ -114,13 +117,23 @@ parens = surround '(' ')' "paren"
114brackets :: IParser a -> IParser a
117brackets :: IParser a -> IParser a
115brackets = surround '{' '}' "bracket"
118brackets = surround '{' '}' "bracket"
116
119
120+addContext :: IParser Expr -> IParser CExpr
121+addContext expr = do
122+ start <- getPosition
123+ e <- expr
124+ end <- getPosition
125+ return (pos start end e)
126+
117−accessible :: IParser Expr -> IParser Expr
127+accessible :: IParser CExpr -> IParser CExpr
118accessible expr = do
128accessible expr = do
129+ start <- getPosition
119 e <- expr
130 e <- expr
120− access <- optionMaybe . try $
131+ access <- optionMaybe . try $ (do { char '.' ; notFollowedBy (char '.') }
121− (do { char '.' ; notFollowedBy (char '.') } <?> "field access (e.g. List.map)")
132+ <?> "field access (e.g. List.map)")
122 case access of
133 case access of
123− Just _ -> accessible (Access e `liftM` var <?> "field access (e.g. List.map)")
134+ Just _ -> accessible $ do v <- var <?> "field access (e.g. List.map)"
135+ end <- getPosition
136+ return (pos start end (Access e v))
124 Nothing -> return e
137 Nothing -> return e
125
138
126
139
elm/src/Parse/Patterns.hs+18−12
@@ -1,10 +1,11 @@
1module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
1module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
2
2
3import Ast
3import Ast
4−import Data.Char (isUpper)
4+import Context
5import Control.Applicative ((<$>),(<*>))
5import Control.Applicative ((<$>),(<*>))
6import Control.Monad
6import Control.Monad
7import Control.Monad.State
7import Control.Monad.State
8+import Data.Char (isUpper)
8import Text.Parsec hiding (newline,spaces,State)
9import Text.Parsec hiding (newline,spaces,State)
9import Text.Parsec.Indent
10import Text.Parsec.Indent
10import Parse.Library
11import Parse.Library
@@ -32,14 +33,18 @@ patternConstructor = PData <$> capVar <*> spacePrefix patternTerm
32patternExpr :: IParser Pattern
33patternExpr :: IParser Pattern
33patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"
34patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"
34
35
35−
36+makeLambda :: [Pattern] -> CExpr -> CExpr
36−makeLambda pats body = foldr Lambda (makeBody pats body) (map getName pats)
37+makeLambda pats body =
38+ foldr (\x e -> noContext $ Lambda x e)
39+ (makeBody pats body)
40+ (map getName pats)
37
41
38makeBody pats body = foldr func body pats
42makeBody pats body = foldr func body pats
39 where func PAnything e = e
43 where func PAnything e = e
40 func (PVar x) e = e
44 func (PVar x) e = e
41− func p e = Case (Var $ getName p) [(p,e)]
45+ func p (C t s e) = C t s $ Case (C t s . Var $ getName p) [(p,C t s e)]
42
46
47+flattenPatterns :: [Pattern] -> CExpr -> IParser [Def]
43flattenPatterns (PVar f : args) exp
48flattenPatterns (PVar f : args) exp
44 | isOp (head f) = let [a,b] = (map getName args) in
49 | isOp (head f) = let [a,b] = (map getName args) in
45 return [ OpDef f a b (makeBody args exp) ]
50 return [ OpDef f a b (makeBody args exp) ]
@@ -47,19 +52,20 @@ flattenPatterns (PVar f : args) exp
47
52
48
53
49flattenPatterns [p] exp = return $ matchSingle p exp p
54flattenPatterns [p] exp = return $ matchSingle p exp p
50−
51flattenPatterns ps _ =
55flattenPatterns ps _ =
52 fail $ "Pattern (" ++ unwords (map show ps) ++
56 fail $ "Pattern (" ++ unwords (map show ps) ++
53 ") cannot be used on the left-hand side of an assign statement."
57 ") cannot be used on the left-hand side of an assign statement."
54
58
59+matchSingle :: Pattern -> CExpr -> Pattern -> [Def]
55matchSingle pat exp p@(PData _ ps) =
60matchSingle pat exp p@(PData _ ps) =
56− (FnDef v [] exp) : concatMap (matchSingle p $ Var v) ps
61+ (FnDef v [] exp) : concatMap (matchSingle p $ noContext $ Var v) ps
57 where v = getName p
62 where v = getName p
58−matchSingle pat exp (PVar x) = [ FnDef x [] (Case exp [(pat,Var x)]) ]
63+matchSingle pat exp (PVar x) =
64+ [ FnDef x [] (noContext $ Case exp [(pat, noContext $ Var x)]) ]
59matchSingle pat exp PAnything = []
65matchSingle pat exp PAnything = []
60
66
61−getName p = f p
67+getName :: Pattern -> String
68+getName p = case p of
62− where f (PData n ps) = n ++ "$" ++ concatMap getName ps
69+ PData n ps -> n ++ "$" ++ concatMap getName ps
63− f (PAnything) = "_"
70+ PAnything -> "_"
64− f (PVar x) = x
71+ PVar x -> x
65−
elm/src/Rename.hs+6−11
@@ -2,6 +2,7 @@
2module Rename (renameModule, derename, deprime) where
2module Rename (renameModule, derename, deprime) where
3
3
4import Ast
4import Ast
5+import Context
5import Control.Arrow (first)
6import Control.Arrow (first)
6import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
7import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
7import Control.Monad.State (evalState, State, get, put)
8import Control.Monad.State (evalState, State, get, put)
@@ -48,6 +49,9 @@ renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
48 ImportEvent _ _ n _ -> [n]
49 ImportEvent _ _ n _ -> [n]
49 _ -> []
50 _ -> []
50
51
52+instance Rename a => Rename (Context a) where
53+ rename env (C t s e) = C t s `liftM` rename env e
54+
51instance Rename Expr where
55instance Rename Expr where
52 rename env expr =
56 rename env expr =
53 let rnm = rename env in
57 let rnm = rename env in
@@ -77,19 +81,10 @@ instance Rename Expr where
77 `ap` rnm e2
81 `ap` rnm e2
78 `ap` rnm e3
82 `ap` rnm e3
79
83
80− Guard ps -> Guard `liftM` mapM grnm ps
84+ MultiIf ps -> MultiIf `liftM` mapM grnm ps
81 where grnm (b,e) = (,) `liftM` rnm b
85 where grnm (b,e) = (,) `liftM` rnm b
82 `ap` rnm e
86 `ap` rnm e
83
87
84− Lift e es -> Lift `liftM` rnm e
85− `ap` mapM rnm es
86−
87− Fold e1 e2 e3 -> Fold `liftM` rnm e1
88− `ap` rnm e2
89− `ap` rnm e3
90−
91− Async e -> Async `liftM` rnm e
92−
93 Let defs e -> renameLet env defs e
88 Let defs e -> renameLet env defs e
94
89
95 Var x -> return . Var $ env x
90 Var x -> return . Var $ env x
@@ -122,7 +117,7 @@ patternExtend pattern env =
122 where f (rps,env') p = do (rp,env'') <- patternExtend p env'
117 where f (rps,env') p = do (rp,env'') <- patternExtend p env'
123 return (rp:rps, env'')
118 return (rp:rps, env'')
124
119
125−patternRename :: (String -> String) -> (Pattern, Expr) -> GuidCounter (Pattern, Expr)
120+patternRename :: (String -> String) -> (Pattern, CExpr) -> GuidCounter (Pattern, CExpr)
126patternRename env (p,e) = do
121patternRename env (p,e) = do
127 (rp,env') <- patternExtend p env
122 (rp,env') <- patternExtend p env
128 re <- rename env' e
123 re <- rename env' e
elm/src/Substitute.hs+4−8
@@ -1,12 +1,12 @@
1module Substitute (subst) where
1module Substitute (subst) where
2
2
3−import Control.Arrow (second, (***))
4−
5import Ast
3import Ast
4+import Context
5+import Control.Arrow (second, (***))
6
6
7subst :: String -> Expr -> Expr -> Expr
7subst :: String -> Expr -> Expr -> Expr
8subst old new expr =
8subst old new expr =
9− let f = subst old new in
9+ let f (C t s e) = C t s (subst old new e) in
10 case expr of
10 case expr of
11 Range e1 e2 -> Range (f e1) (f e2)
11 Range e1 e2 -> Range (f e1) (f e2)
12 Access e x -> Access (f e) x
12 Access e x -> Access (f e) x
@@ -14,11 +14,7 @@ subst old new expr =
14 Lambda x e -> if x == old then expr else Lambda x (f e)
14 Lambda x e -> if x == old then expr else Lambda x (f e)
15 App e1 e2 -> App (f e1) (f e2)
15 App e1 e2 -> App (f e1) (f e2)
16 If e1 e2 e3 -> If (f e1) (f e2) (f e3)
16 If e1 e2 e3 -> If (f e1) (f e2) (f e3)
17− Guard ps -> Guard (map (f *** f) ps)
17+ MultiIf ps -> MultiIf (map (f *** f) ps)
18− Lift e es -> Lift (f e) (map f es)
19− Fold e1 e2 e3 -> Fold (f e1) (f e2) (f e3)
20− Async e -> Async (f e)
21− Input _ -> expr
22 Let defs e -> Let (map substDef defs) (f e)
18 Let defs e -> Let (map substDef defs) (f e)
23 where substDef (FnDef name vs e) = FnDef name vs (f e)
19 where substDef (FnDef name vs e) = FnDef name vs (f e)
24 substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)
20 substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)
elm/src/Types/Constrain.hs+161−123
@@ -1,23 +1,20 @@
1
1
2module Types.Constrain (constrain) where
2module Types.Constrain (constrain) where
3
3
4−import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)
5−import qualified Data.Set as Set
6−import qualified Data.Map as Map
7import Control.Arrow (second)
4import Control.Arrow (second)
8import Control.Monad (liftM,mapM,zipWithM,foldM)
5import Control.Monad (liftM,mapM,zipWithM,foldM)
9import Control.Monad.State (evalState)
6import Control.Monad.State (evalState)
7+import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)
8+import qualified Data.Map as Map
9+import qualified Data.Set as Set
10
10
11import Ast
11import Ast
12+import Context
12import Guid
13import Guid
13
14
14import Types.Types
15import Types.Types
15import Types.Substitutions
16import Types.Substitutions
16
17
17−--import System.IO.Unsafe
18−
19−prints xs v = v --} unsafePerformIO (putStrLn "~~~~~~~~~~" >> mapM print xs) `seq` v
20−
21beta = VarT `liftM` guid
18beta = VarT `liftM` guid
22unionA = Map.unionWith (++)
19unionA = Map.unionWith (++)
23unionsA = Map.unionsWith (++)
20unionsA = Map.unionsWith (++)
@@ -53,114 +50,152 @@ constrain typeHints (Module _ _ imports stmts) = do
53 allHints = Map.fromList (aliasHints ++ concat schemess)
50 allHints = Map.fromList (aliasHints ++ concat schemess)
54 assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)
51 assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)
55 findAmbiguous (map fst hints) (map fst aliasHints) assumptions $ do
52 findAmbiguous (map fst hints) (map fst aliasHints) assumptions $ do
56− let f k s vs = map (\v -> Context k $ v :<<: s) vs
53+ let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs
57 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
54 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
58 escapees = Map.keys $ Map.difference assumptions allHints
55 escapees = Map.keys $ Map.difference assumptions allHints
59 return . Right . (,) escapees $ cs ++ Set.toList (Set.unions css)
56 return . Right . (,) escapees $ cs ++ Set.toList (Set.unions css)
60
57
61−gen :: Expr -> GuidCounter (Map.Map String [X],
58+type TVarMap = Map.Map String [X]
62− Set.Set (Context String Constraint),
59+type ConstraintSet = Set.Set (Context Constraint)
63− Type)
60+
64−
61+ctx e span = C (Just $ show e) span
65−gen (Var x) =
62+
63+gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type)
64+gen (C _ span expr) =
65+ let ctx' = C (Just $ show expr) span in
66+ case expr of
67+ Var x ->
66− do b <- guid
68+ do b <- guid
67− return (Map.singleton x [b], Set.empty, VarT b)
69+ return (Map.singleton x [b], Set.empty, VarT b)
68−
70+
69−gen e@(App e1 e2) =
71+ App e1 e2 ->
70− do (a1,c1,t1) <- gen e1
72+ do (a1,c1,t1) <- gen e1
71− (a2,c2,t2) <- gen e2
73+ (a2,c2,t2) <- gen e2
72− b <- beta
74+ b <- beta
73− return ( unionA a1 a2
75+ return ( unionA a1 a2
76+ , Set.unions [c1,c2
74− , Set.unions [c1,c2,Set.singleton . ctx e $ t1 :=: (LambdaT t2 b)]
77+ ,Set.singleton . ctx' $ t1 :=: (LambdaT t2 b)]
75− , b )
78+ , b )
79+
76−gen (Lambda x e) =
80+ Lambda x e ->
77− do (a,c,t) <- gen e
81+ do (a,c,t) <- gen e
78− b <- beta
82+ b <- beta
79− v <- guid
83+ v <- guid
80− return ( Map.delete x a
84+ return ( Map.delete x a
81− , Set.union c . Set.fromList . map (\x -> ctx e $ VarT x :=: b) $
85+ , Set.union c . Set.fromList .
86+ map (\x -> ctx' $ VarT x :=: b) $
82− Map.findWithDefault [v] x a
87+ Map.findWithDefault [v] x a
83− , LambdaT b t )
88+ , LambdaT b t )
89+
84−gen (Let defs e) =
90+ Let defs e ->
85− do (as,cs,t) <- gen e
91+ do (as,cs,t) <- gen e
86− (ass, schemes) <- liftM unzip (mapM defScheme defs)
92+ (ass, schemes) <- liftM unzip (mapM defScheme defs)
87− let assumptions = unionsA (as:ass)
93+ let assumptions = unionsA (as:ass)
88− getName (FnDef f _ _) = f
94+ getName d = case d of FnDef f _ _ -> f
89− getName (OpDef op _ _ _) = op
95+ OpDef op _ _ _ -> op
90− names = map getName defs
96+ names = map getName defs
91− genCs name s = do
97+ genCs name s = do
92− v <- guid
98+ v <- guid
93− let vs = Map.findWithDefault [v] name assumptions
99+ let vs = Map.findWithDefault [v] name assumptions
94− return $ map (\x -> ctx (Var name) $ x :<<: s) vs
100+ return $ map (\x -> ctx name span $ x :<<: s) vs
95− cs' <- zipWithM genCs names schemes
101+ cs' <- zipWithM genCs names schemes
96− return ( foldr Map.delete assumptions names
102+ return ( foldr Map.delete assumptions names
97− , Set.union (Set.fromList . concat $ cs') cs
103+ , Set.union (Set.fromList . concat $ cs') cs
98− , t )
104+ , t )
99−
105+
100−gen ce@(Case e cases) =
106+ Case e cases ->
101− do (as,cs,t) <- gen e
107+ do (as,cs,t) <- gen e
102− (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases
108+ (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases
103− return ( unionsA $ as:ass
109+ return ( unionsA $ as:ass
104− , let combine t1 t2 = ctx ce (t1 :=: t2) in
110+ , let cases' = map snd cases
111+ ctxs = zipWith epos cases' (tail cases')
112+ csts = zipWith (:=:) ts (tail ts)
105− Set.unions $ Set.fromList (zipWith combine ts $ tail ts) : cs : css
113+ cs' = Set.fromList (zipWith ($) ctxs csts)
114+ in Set.unions $ cs' : cs : css
106− , head ts)
115+ , head ts)
107−
116+
108−gen e@(If e1 e2 e3) =
117+ If e1 e2 e3 ->
109− do (a1,c1,t1) <- gen e1
118+ do (a1,c1,t1) <- gen e1
110− (a2,c2,t2) <- gen e2
119+ (a2,c2,t2) <- gen e2
111− (a3,c3,t3) <- gen e3
120+ (a3,c3,t3) <- gen e3
112− return ( unionsA [a1,a2,a3]
121+ return ( unionsA [a1,a2,a3]
113− , Set.unions [c1,c2,c3, Set.fromList [ ctx e1 (t1 :=: bool), ctx e (t2 :=: t3) ] ]
122+ , let c4 = Set.fromList [ ctx e1 span (t1 :=: bool)
123+ , ctx' (t2 :=: t3) ]
124+ in Set.unions [c1,c2,c3,c4]
114− , t2 )
125+ , t2 )
115−
126+
127+ Data name es ->
116−gen (Data name es) = gen $ foldl' App (Var name) es
128+ gen $ foldl' (\f x -> epos f x $ App f x) (ctx' $ Var name) es
129+
117−gen (Binop op e1 e2) = gen (Var op `App` e1 `App` e2)
130+ Binop op e1 e2 ->
118−
131+ gen $ ctx' (App (ctx' $ App (ctx' $ Var op) e1) e2)
119−gen (Access (Var a) b) = gen . Var $ a ++ "." ++ b
132+
120−gen (Access (Access (Var a) b) c) = gen . Var $ intercalate "." [a, b, c]
133+ Access e label ->
121−gen (Access (Access (Access (Var a) b) c) d) = gen . Var $ intercalate "." [a, b, c, d]
134+ do (as,cs,rtype) <- gen e
122−
135+ t <- beta
136+ rtype' <- beta
137+ let fs = Map.singleton label [t]
138+ c = (ctx' (RecordT fs rtype' :=: rtype))
139+ return (as, Set.insert c cs, t)
140+
141+ Record fields ->
142+ let insert label tipe = Map.insertWith (++) label [tipe]
143+ getScheme (f,args,e) = do
144+ (as, _, (label, Forall _ cs tipe)) <- defGenHelp f args e
145+ return (as, cs, insert label tipe)
146+ in do (ass, css, fs) <- unzip3 `liftM` mapM getScheme fields
147+ return ( unionsA ass
148+ , Set.fromList (concat css)
149+ , RecordT (foldr ($) Map.empty fs) EmptyRecord )
150+
123−gen (Range e1 e2) =
151+ Range e1@(C w1 s1 _) e2@(C w2 s2 _) ->
124− do (a1,c1,t1) <- gen e1
152+ do (a1,c1,t1) <- gen e1
125− (a2,c2,t2) <- gen e2
153+ (a2,c2,t2) <- gen e2
126− return ( unionsA [a1,a2]
154+ return ( unionsA [a1,a2]
127− , Set.unions [ c1, c2, Set.fromList [ ctx e1 (t1 :=: int)
155+ , Set.unions [ c1, c2, Set.fromList [ C w1 s1 (t1 :=: int)
128− , ctx e2 (t2 :=: int) ] ]
156+ , C w1 s2 (t2 :=: int) ] ]
129− , listOf int )
157+ , listOf int )
130−
158+
131−gen e@(Guard ps) = do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
159+ MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
132− let cs = Set.fromList (map (ctx e . (t :=:)) ts)
160+ let cs = Set.fromList (map (ctx' . (t :=:)) ts)
133− return (unionsA ass, Set.unions (cs:css), t)
161+ return (unionsA ass, Set.unions (cs:css), t)
134− where genPair (b,e) = do
162+ where genPair (b@(C t s _),e) = do
135− (a1,c1,t1) <- gen b
163+ (a1,c1,t1) <- gen b
136− (a2,c2,t2) <- gen e
164+ (a2,c2,t2) <- gen e
137− return ( unionsA [a1,a2]
165+ return ( unionsA [a1,a2]
166+ , Set.unions [ c1, c2
138− , Set.unions [ c1, c2, Set.singleton (ctx b (t1 :=: bool)) ]
167+ , Set.singleton (C t s (t1 :=: bool)) ]
139− , t2 )
168+ , t2 )
140−
169+
141−gen other =
142− case other of
143− IntNum _ -> do t <- beta
170+ IntNum _ -> do t <- beta
144− return (Map.empty, Set.singleton (ctx other $ t :<: number), t)
171+ return (Map.empty, Set.singleton (ctx' $ t :<: number), t)
172+
145− FloatNum _ -> primitive float
173+ FloatNum _ -> primitive float
146− Chr _ -> primitive char
174+ Chr _ -> primitive char
147− Str _ -> primitive string
175+ Str _ -> primitive string
148− Boolean _ -> primitive bool
176+ Boolean _ -> primitive bool
149− Markdown _ -> primitive element
177+ Markdown _ -> primitive element
150 -- _ -> beta >>= primitive
178 -- _ -> beta >>= primitive
151
179
180+primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type)
152primitive t = return (Map.empty, Set.empty, t)
181primitive t = return (Map.empty, Set.empty, t)
153
182
154−caseGen tipe (p,e) = do
183+caseGen :: Type
184+ -> (Pattern, CExpr)
185+ -> GuidCounter (TVarMap, ConstraintSet, Type)
186+caseGen tipe (p, ce@(C _ span e)) = do
155− (as ,cs , t ) <- gen e
187+ (as ,cs , t ) <- gen ce
156 (as',cs',[t']) <- patternGen (as,cs,[]) p
188 (as',cs',[t']) <- patternGen (as,cs,[]) p
157− let cs'' = Set.union cs' . Set.singleton . ctx p $ t' :=: tipe
189+ let cs'' = Set.union cs' . Set.singleton . ctx p span $ t' :=: tipe
158 return ( as', cs'', t )
190 return ( as', cs'', t )
159
191
192+patternGen :: (TVarMap, ConstraintSet, [Type])
193+ -> Pattern
194+ -> GuidCounter (TVarMap, ConstraintSet, [Type])
160patternGen (as,cs,ts) PAnything = ((,,) as cs . (\t -> ts++[t])) `liftM` beta
195patternGen (as,cs,ts) PAnything = ((,,) as cs . (\t -> ts++[t])) `liftM` beta
161patternGen (as,cs,ts) (PVar v) = do
196patternGen (as,cs,ts) (PVar v) = do
162 b <- beta
197 b <- beta
163− let cs' = map (\x -> ctx (Var v) $ VarT x :=: b) $ Map.findWithDefault [] v as
198+ let cs' = map (\x -> ctx v NoSpan $ VarT x :=: b) $ Map.findWithDefault [] v as
164 return ( Map.delete v as, Set.union cs $ Set.fromList cs', ts ++ [b] )
199 return ( Map.delete v as, Set.union cs $ Set.fromList cs', ts ++ [b] )
165patternGen (as,cs,ts) p@(PData name ps) = do
200patternGen (as,cs,ts) p@(PData name ps) = do
166 constr <- guid
201 constr <- guid
@@ -169,11 +204,12 @@ patternGen (as,cs,ts) p@(PData name ps) = do
169 let t = foldr (==>) output ts'
204 let t = foldr (==>) output ts'
170 let getC | isTupleString name = do
205 let getC | isTupleString name = do
171 vs <- mapM (\_ -> beta) ps
206 vs <- mapM (\_ -> beta) ps
172− return . Set.singleton . ctx p $ output :=: ADT name vs
207+ return . Set.singleton . C (Just $ show p) NoSpan $ output :=: ADT name vs
173 | otherwise = return Set.empty
208 | otherwise = return Set.empty
174 cs'' <- getC
209 cs'' <- getC
175 return ( unionA as' (Map.singleton name [constr])
210 return ( unionA as' (Map.singleton name [constr])
211+ , Set.unions [cs',cs''
176− , Set.unions [cs',cs'', Set.singleton . ctx p $ VarT constr :=: t]
212+ , Set.singleton . ctx p NoSpan $ VarT constr :=: t ]
177 , ts ++ [output] )
213 , ts ++ [output] )
178
214
179
215
@@ -181,21 +217,23 @@ defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)
181defScheme def = do (as,cs,hint) <- defGen def
217defScheme def = do (as,cs,hint) <- defGen def
182 return ( as, snd hint )
218 return ( as, snd hint )
183
219
184−defGen def = case def of FnDef f args e -> defGen' f args e
220+defGen def = case def of
221+ FnDef f args e -> defGenHelp f args e
185− OpDef op a1 a2 e -> defGen' op [a1,a2] e
222+ OpDef op a1 a2 e -> defGenHelp op [a1,a2] e
223+
186− where defGen' name args e = do
224+defGenHelp name args e = do
187− argDict <- mapM (\a -> liftM ((,) a) guid) args
225+ argDict <- mapM (\a -> liftM ((,) a) guid) args
188− (as,cs,t) <- gen e
226+ (as,cs,t) <- gen e
189− let as' = foldr Map.delete as args
227+ let as' = foldr Map.delete as args
190− tipe = foldr (==>) t $ map (VarT . snd) argDict
228+ tipe = foldr (==>) t $ map (VarT . snd) argDict
191− genCs (arg,x) = do
229+ genCs (arg,x) = do
192− v <- guid
230+ v <- guid
193− let as' = Map.findWithDefault [v] arg as
231+ let as' = Map.findWithDefault [v] arg as
194− return $ map (\y -> Context arg $ VarT x :=: VarT y) as'
232+ return $ map (\y -> ctx arg NoSpan $ VarT x :=: VarT y) as'
195− cs' <- concat `liftM` mapM genCs argDict
233+ cs' <- concat `liftM` mapM genCs argDict
196− scheme <- generalize (concat $ Map.elems as') $
234+ scheme <- generalize (concat $ Map.elems as') $
197− Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
235+ Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
198− return ( as', Set.empty, (name, scheme) )
236+ return ( as', Set.empty, (name, scheme) )
199
237
200stmtGen (Definition def) = do (as,cs,hint) <- defGen def
238stmtGen (Definition def) = do (as,cs,hint) <- defGen def
201 return ( as, cs, [hint] )
239 return ( as, cs, [hint] )
@@ -210,7 +248,7 @@ stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'
210 | n == "Comparable" = vc
248 | n == "Comparable" = vc
211 rnm t = t
249 rnm t = t
212 tcs' = map (second (map rnm)) tcs
250 tcs' = map (second (map rnm)) tcs
213− supers t = map (Context name) $
251+ supers t = map (ctx name NoSpan) $
214 zipWith (:<:) [va,vb,vc] [number,appendable t,comparable]
252 zipWith (:<:) [va,vb,vc] [number,appendable t,comparable]
215 gen' (n,ts) = do t <- beta
253 gen' (n,ts) = do t <- beta
216 let s = Forall (xs ++ [a,b,c]) (supers t) $
254 let s = Forall (xs ++ [a,b,c]) (supers t) $
@@ -220,13 +258,13 @@ stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'
220stmtGen (ExportEvent js elm tipe) = do
258stmtGen (ExportEvent js elm tipe) = do
221 x <- guid
259 x <- guid
222 return ( Map.singleton elm [x]
260 return ( Map.singleton elm [x]
223− , Set.singleton . ctx (Var elm) $ VarT x :=: tipe
261+ , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe
224 , [] )
262 , [] )
225
263
226−stmtGen (ImportEvent js base elm tipe) = do
264+stmtGen (ImportEvent js e@(C txt span base) elm tipe) = do
227− (as,cs,t) <- gen base
265+ (as,cs,t) <- gen e
228 return ( as
266 return ( as
229− , Set.insert (ctx base (signalOf t :=: tipe)) cs
267+ , Set.insert (C txt span (signalOf t :=: tipe)) cs
230 , [ (elm, Forall [] [] tipe) ] )
268 , [ (elm, Forall [] [] tipe) ] )
231
269
232getDatatypeInfo (Datatype name args tcs) =
270getDatatypeInfo (Datatype name args tcs) =
elm/src/Types/Hints.hs+11−10
@@ -1,11 +1,12 @@
1module Types.Hints (hints) where
1module Types.Hints (hints) where
2
2
3−import Control.Monad (liftM,mapM)
3+import Context
4import Control.Arrow (first)
4import Control.Arrow (first)
5+import Control.Monad (liftM,mapM)
5import Types.Types
6import Types.Types
6import Types.Substitutions (rescheme)
7import Types.Substitutions (rescheme)
7
8
8−
9+ctx str = C (Just str) NoSpan
9prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs
10prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs
10
11
11-------- Text and Elements --------
12-------- Text and Elements --------
@@ -243,11 +244,11 @@ dates =
243
244
244binop t = t ==> t ==> t
245binop t = t ==> t ==> t
245scheme1 super t name =
246scheme1 super t name =
246− (name, Forall [0] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: super
247+ (name, Forall [0] [ ctx name $ VarT 0 :<: super
247 ] (t (VarT 0)))
248 ] (t (VarT 0)))
248scheme2 s1 s2 t name =
249scheme2 s1 s2 t name =
249− (name, Forall [0,1] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: s1
250+ (name, Forall [0,1] [ ctx name $ VarT 0 :<: s1
250− , Context ("`" ++ name ++ "'") $ VarT 1 :<: s2
251+ , ctx name $ VarT 1 :<: s2
251 ] (t (VarT 0) (VarT 1)))
252 ] (t (VarT 0) (VarT 1)))
252numScheme t name = scheme1 number t name
253numScheme t name = scheme1 number t name
253twoNums f name = scheme2 number number f name
254twoNums f name = scheme2 number number f name
@@ -271,7 +272,7 @@ bools =
271 hasType (binop bool) ["&&","||"] ++
272 hasType (binop bool) ["&&","||"] ++
272 map (scheme1 comparable (\t -> t ==> t ==> bool)) ["<",">","<=",">="] ++
273 map (scheme1 comparable (\t -> t ==> t ==> bool)) ["<",">","<=",">="] ++
273 [ ( "compare"
274 [ ( "compare"
274− , Forall [0,1] [ Context "`compare'" $ VarT 0 :<: comparable ] (VarT 0 ==> VarT 0 ==> VarT 1) )
275+ , Forall [0,1] [ ctx "compare" $ VarT 0 :<: comparable ] (VarT 0 ==> VarT 0 ==> VarT 1) )
275 ]
276 ]
276
277
277chars = prefix "Char" (classify ++ convert1 ++ convert2)
278chars = prefix "Char" (classify ++ convert1 ++ convert2)
@@ -297,7 +298,7 @@ funcs =
297 , "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
298 , "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
298 , "$" -:: (a ==> b) ==> a ==> b
299 , "$" -:: (a ==> b) ==> a ==> b
299 , ":" -:: a ==> listOf a ==> listOf a
300 , ":" -:: a ==> listOf a ==> listOf a
300− , (,) "++" . Forall [0,1] [ Context "`++'" $ VarT 0 :<: appendable (VarT 1) ] $ VarT 0 ==> VarT 0 ==> VarT 0
301+ , (,) "++" . Forall [0,1] [ ctx "++" $ VarT 0 :<: appendable (VarT 1) ] $ VarT 0 ==> VarT 0 ==> VarT 0
301 , "Cons" -:: a ==> listOf a ==> listOf a
302 , "Cons" -:: a ==> listOf a ==> listOf a
302 , "Nil" -:: listOf a
303 , "Nil" -:: listOf a
303 , "Just" -:: a ==> maybeOf a
304 , "Just" -:: a ==> maybeOf a
@@ -332,11 +333,11 @@ lists = prefix "List"
332 , "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
333 , "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
333 , "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
334 , "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
334 , "scanl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> listOf b
335 , "scanl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> listOf b
335− , (,) "concat" . Forall [0,1] [ Context "`concat'" $ VarT 0 :<: appendable (VarT 1) ] $
336+ , (,) "concat" . Forall [0,1] [ ctx "concat" $ VarT 0 :<: appendable (VarT 1) ] $
336 listOf (VarT 0) ==> VarT 0
337 listOf (VarT 0) ==> VarT 0
337− , (,) "concatMap" . Forall [0,1,2] [ Context "`concatMap'" $ VarT 0 :<: appendable (VarT 1) ] $
338+ , (,) "concatMap" . Forall [0,1,2] [ ctx "concatMap" $ VarT 0 :<: appendable (VarT 1) ] $
338 (VarT 2 ==> VarT 0) ==> listOf (VarT 2) ==> VarT 0
339 (VarT 2 ==> VarT 0) ==> listOf (VarT 2) ==> VarT 0
339− , (,) "intercalate" . Forall [0,1] [ Context "`intercalate'" $ VarT 0 :<: appendable (VarT 1) ] $
340+ , (,) "intercalate" . Forall [0,1] [ ctx "intercalate" $ VarT 0 :<: appendable (VarT 1) ] $
340 VarT 0 ==> listOf (VarT 0) ==> VarT 0
341 VarT 0 ==> listOf (VarT 0) ==> VarT 0
341 , "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c
342 , "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c
342 ] ++ map (numScheme (\n -> listOf n ==> n)) [ "sum", "product"
343 ] ++ map (numScheme (\n -> listOf n ==> n)) [ "sum", "product"
elm/src/Types/Solver.hs+164−117
@@ -1,6 +1,7 @@
1
1
2module Types.Solver (solver) where
2module Types.Solver (solver) where
3
3
4+import Context
4import Control.Arrow (second)
5import Control.Arrow (second)
5import Control.Monad (liftM)
6import Control.Monad (liftM)
6import Data.Either (lefts,rights)
7import Data.Either (lefts,rights)
@@ -13,13 +14,13 @@ import Types.Types
13import Types.Constrain
14import Types.Constrain
14import Types.Substitutions
15import Types.Substitutions
15
16
17+import System.IO.Unsafe
16
18
17−eq ctx t1 t2 = Context ctx (t1 :=: t2)
18−
19−isSolved ss (Context _ (t1 :=: t2)) = t1 == t2
19+isSolved ss (C _ _ (t1 :=: t2)) = t1 == t2
20−isSolved ss (Context _ (x :<<: _)) = isJust (lookup x ss)
20+isSolved ss (C _ _ (x :<<: _)) = isJust (lookup x ss)
21isSolved ss c = False
21isSolved ss c = False
22
22
23+crush :: Scheme -> GuidCounter (Either String Scheme)
23crush (Forall xs cs t) =
24crush (Forall xs cs t) =
24 do subs <- solver cs Map.empty
25 do subs <- solver cs Map.empty
25 return $ do ss' <- subs
26 return $ do ss' <- subs
@@ -27,10 +28,10 @@ crush (Forall xs cs t) =
27 cs' = filter (not . isSolved ss) (subst ss cs)
28 cs' = filter (not . isSolved ss) (subst ss cs)
28 return $ Forall xs cs' (subst ss t)
29 return $ Forall xs cs' (subst ss t)
29
30
30−schemeSubHelp ctx x s t1 rltn t2 = do
31+schemeSubHelp txt span x s t1 rltn t2 = do
31 (t1',cs1) <- sub t1
32 (t1',cs1) <- sub t1
32 (t2',cs2) <- sub t2
33 (t2',cs2) <- sub t2
33− return (Context ctx (rltn t1' t2') : cs1 ++ cs2)
34+ return (C txt span (rltn t1' t2') : cs1 ++ cs2)
34 where sub t | not (occurs x t) = return (t, [])
35 where sub t | not (occurs x t) = return (t, [])
35 | otherwise = do (st, cs) <- concretize s
36 | otherwise = do (st, cs) <- concretize s
36 return (subst [(x,st)] t, cs)
37 return (subst [(x,st)] t, cs)
@@ -40,118 +41,164 @@ schemeSub x s c = do s' <- crush s
40 Right s'' -> Right `liftM` schemeSub' x s'' c
41 Right s'' -> Right `liftM` schemeSub' x s'' c
41 Left err -> return $ Left err
42 Left err -> return $ Left err
42
43
43−schemeSub' x s (Context ctx (t1 :=: t2)) = schemeSubHelp ctx x s t1 (:=:) t2
44+schemeSub' x s c@(C txt span constraint) =
44−schemeSub' x s (Context ctx (t1 :<: t2)) = schemeSubHelp ctx x s t1 (:<:) t2
45+ case constraint of
46+ (t1 :=: t2) -> schemeSubHelp txt span x s t1 (:=:) t2
47+ (t1 :<: t2) -> schemeSubHelp txt span x s t1 (:<:) t2
45−schemeSub' x s c@(Context ctx (y :<<: Forall cxs ccs ctipe))
48+ (y :<<: Forall cxs ccs ctipe)
46− | not (occurs x c) = return [c]
49+ | not (occurs x c) -> return [c]
47− | otherwise =
50+ | otherwise ->
48− do Forall xs cs tipe <- rescheme s
51+ do Forall xs cs tipe <- rescheme s
49− let ss = [(x,tipe)]
52+ let ss = [(x,tipe)]
50− constraints = subst ss (cs ++ ccs)
53+ constraints = subst ss (cs ++ ccs)
51− c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)
54+ c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)
52− return [ Context ctx c' ]
55+ return [ C txt span c' ]
53−
56+
54−
57+p x = unsafePerformIO (print x) `seq` x
58+
59+recordConstraints eq fs t fs' t' =
60+ liftM (p . concat) . sequence $
61+ [ constrain fs fs'
62+ , liftM concat . mapM (\(k,ts) -> zipper [] k ts []) . Map.toList $
63+ Map.difference fs fs'
64+ , liftM concat . mapM (\(k,ts) -> zipper [] k [] ts) . Map.toList $
65+ Map.difference fs' fs
66+ ]
67+ where constrain :: Map.Map String [Type] -> Map.Map String [Type]
68+ -> GuidCounter [Context Constraint]
69+ constrain as bs = liftM concat . sequence . Map.elems $
70+ Map.intersectionWithKey (zipper []) as bs
71+ zipper :: [Context Constraint] -> String -> [Type] -> [Type]
72+ -> GuidCounter [Context Constraint]
73+ zipper cs k xs ys =
74+ case (xs,ys) of
75+ (a:as, b:bs) -> zipper (eq a b : cs) k as bs
76+ ([],[]) -> return cs
77+ (as,[]) -> do x <- guid
78+ let tipe = RecordT (Map.singleton k as) (VarT x)
79+ return . p $ (cs ++ [eq t' tipe])
80+ ([],bs) -> do x <- guid
81+ let tipe = RecordT (Map.singleton k bs) (VarT x)
82+ return . p $ (cs ++ [eq t tipe])
83+
55−solver :: [Context String Constraint]
84+solver :: [Context Constraint]
56 -> Map.Map X Type
85 -> Map.Map X Type
57 -> GuidCounter (Either String (Map.Map X Type))
86 -> GuidCounter (Either String (Map.Map X Type))
58solver [] subs = return $ Right subs
87solver [] subs = return $ Right subs
59−
88+solver (C txt span c : cs) subs =
89+ let ctx = C txt span in
90+ let eq t1 t2 = ctx (t1 :=: t2) in
91+ case c of
60−-------- Destruct Type-constructors --------
92+ -- Destruct Type-constructors
61−
62−solver ((Context ctx (t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2))) : cs) subs =
93+ t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->
63− if n1 /= n2 then uniError ctx t1 t2 else
94+ if n1 /= n2 then uniError txt span t1 t2 else
64− solver (zipWith (eq ctx) ts1 ts2 ++ cs) subs
95+ solver (zipWith eq ts1 ts2 ++ cs) subs
96+
65−solver ((Context ctx (LambdaT t1 t2 :=: LambdaT t1' t2')) : cs) subs =
97+ LambdaT t1 t2 :=: LambdaT t1' t2' ->
66− solver ([ eq ctx t1 t1', eq ctx t2 t2' ] ++ cs) subs
98+ solver ([ eq t1 t1', eq t2 t2' ] ++ cs) subs
67−
99+
100+ RecordT fs t :=: RecordT fs' t' ->
101+ unsafePerformIO (print c) `seq`
102+ do cs' <- recordConstraints eq fs t fs' t'
103+ solver (cs' ++ cs) subs
104+
68−-------- Type-equality --------
105+ -- Type-equality
69−
70−solver (Context ctx (VarT x :=: VarT y) : cs) subs
106+ VarT x :=: VarT y
71− | x == y = solver cs subs
107+ | x == y -> solver cs subs
72− | otherwise =
108+ | otherwise ->
73− case (Map.lookup x subs, Map.lookup y subs) of
109+ case (Map.lookup x subs, Map.lookup y subs) of
74− (Just (Super xts), Just (Super yts)) ->
110+ (Just (Super xts), Just (Super yts)) ->
75− let ts = Set.intersection xts yts
111+ let ts = Set.intersection xts yts
76− setXY t = Map.insert x t . Map.insert y t
112+ setXY t = Map.insert x t . Map.insert y t
77− in case Set.toList ts of
113+ in case Set.toList ts of
78− [] -> unionError ctx xts yts
114+ [] -> unionError txt span xts yts
79− [t] -> let cs1 = subst [(x,t),(y,t)] cs in
115+ [t] -> let cs1 = subst [(x,t),(y,t)] cs in
80− cs1 `seq` solver cs1 (setXY t subs)
116+ cs1 `seq` solver cs1 (setXY t subs)
81− _ -> solver cs $ setXY (Super ts) subs
117+ _ -> solver cs $ setXY (Super ts) subs
82− (Just (Super xts), _) ->
118+ (Just (Super xts), _) ->
83− let cs2 = subst [(y,VarT x)] cs in
119+ let cs2 = subst [(y,VarT x)] cs in
84− solver cs2 $ Map.insert y (VarT x) subs
120+ solver cs2 $ Map.insert y (VarT x) subs
85− (_, _) ->
121+ (_, _) ->
86− let cs3 = subst [(x,VarT y)] cs in
122+ let cs3 = subst [(x,VarT y)] cs in
87− solver cs3 $ Map.insert x (VarT y) subs
123+ solver cs3 $ Map.insert x (VarT y) subs
124+
88−solver (Context ctx (VarT x :=: t) : cs) subs = do
125+ VarT x :=: t -> do
89− if x `occurs` t then occursError ctx (VarT x) t else
126+ if x `occurs` t then occursError txt span (VarT x) t else
90− (case Map.lookup x subs of
127+ (case Map.lookup x subs of
91− Nothing -> let cs4 = subst [(x,t)] cs in
128+ Nothing -> let cs4 = subst [(x,t)] cs in
92− solver cs4 . Map.map (subst [(x,t)]) $ Map.insert x t subs
129+ solver cs4 . Map.map (subst [(x,t)]) $
130+ Map.insert x t subs
93− Just (Super ts) ->
131+ Just (Super ts) ->
94− let ts' = Set.intersection ts (Set.singleton t) in
132+ let ts' = Set.intersection ts (Set.singleton t) in
95− case Set.toList ts' of
133+ case Set.toList ts' of
96− [] -> solver (Context ctx (t :<: Super ts) : cs) subs
134+ [] -> solver (ctx (t :<: Super ts) : cs) subs
97− [t'] -> let cs5 = subst [(x,t)] cs in
135+ [t'] -> let cs5 = subst [(x,t)] cs in
98− solver cs5 $ Map.insert x t' subs
136+ solver cs5 $ Map.insert x t' subs
99− _ -> solver cs $ Map.insert x (Super ts') subs
137+ _ -> solver cs $ Map.insert x (Super ts') subs
100− Just t' -> solver (Context ctx (t' :=: t) : cs) subs
138+ Just t' -> solver (ctx (t' :=: t) : cs) subs
101− )
139+ )
102−solver ((Context ctx (t :=: VarT x)) : cs) subs =
140+
103− solver ((Context ctx (VarT x :=: t)) : cs) subs
141+ t :=: VarT x -> solver ((ctx (VarT x :=: t)) : cs) subs
104−solver ((Context ctx (t1 :=: t2)) : cs) subs
142+
105− | t1 == t2 = solver cs subs
143+ t1 :=: t2 | t1 == t2 -> solver cs subs
106− | otherwise = uniError ctx t1 t2
144+ | otherwise -> uniError txt span t1 t2
107−
145+
108−
109−-------- subtypes --------
146+ -- subtypes
110−
111−solver (Context ctx (VarT x :<: Super ts) : cs) subs =
147+ VarT x :<: Super ts ->
112− case Map.lookup x subs of
148+ case Map.lookup x subs of
113− Nothing -> solver cs $ Map.insert x (Super ts) subs
149+ Nothing -> solver cs $ Map.insert x (Super ts) subs
114− Just (Super ts') ->
150+ Just (Super ts') ->
115− case Set.toList $ Set.intersection ts ts' of
151+ case Set.toList $ Set.intersection ts ts' of
116− [] -> unionError ctx ts ts'
152+ [] -> unionError txt span ts ts'
117− [t] -> solver (subst [(x,t)] cs) $ Map.insert x t subs
153+ [t] -> solver (subst [(x,t)] cs) $ Map.insert x t subs
154+ ts'' -> solver cs $
118− ts'' -> solver cs $ Map.insert x (Super $ Set.fromList ts'') subs
155+ Map.insert x (Super $ Set.fromList ts'') subs
119−
156+
120−solver (Context ctx (ADT "List" [t] :<: Super ts) : cs) subs
157+ ADT "List" [t] :<: Super ts
121− | any f (Set.toList ts) = solver cs subs
158+ | any f (Set.toList ts) -> solver cs subs
122− | otherwise = subtypeError ctx (ADT "List" [t]) (Super ts)
159+ | otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)
123− where f (ADT "List" [VarT _]) = True
160+ where f (ADT "List" [VarT _]) = True
124− f (ADT "List" [t']) = t == t'
161+ f (ADT "List" [t']) = t == t'
125− f _ = False
162+ f _ = False
126−
163+
127−solver (Context ctx (t :<: Super ts) : cs) subs
164+ t :<: Super ts
128− | Set.member t ts = solver cs subs
165+ | Set.member t ts -> solver cs subs
129− | otherwise = subtypeError ctx t (Super ts)
166+ | otherwise -> subtypeError txt span t (Super ts)
130−
167+
131−solver (Context ctx (x :<<: s) : cs) subs
168+ x :<<: s
132− | any (occurs x) cs =
169+ | any (occurs x) cs ->
133− do css <- mapM (schemeSub x s) cs
170+ do css <- mapM (schemeSub x s) cs
134− case lefts css of
171+ case lefts css of
135− err : _ -> return $ Left err
172+ err : _ -> return $ Left err
136− [] -> solver (concat (rights css)) subs
173+ [] -> solver (concat (rights css)) subs
137− | otherwise =
174+ | otherwise ->
138− do (t,cs7) <- concretize s
175+ do (t,cs7) <- concretize s
139− let cs'' = (cs ++ Context ctx (VarT x :=: t) : map (extendCtx ctx) cs7)
176+ let cs'' = (cs ++ ctx (VarT x :=: t) : cs7)
140− solver cs'' subs
177+ solver cs'' subs
141−
178+
179+showMsg msg = case msg of
180+ Just str -> "\nIn context: " ++ str
181+ Nothing -> ""
182+
142−occursError ctx t1 t2 =
183+occursError msg span t1 t2 =
184+ return . Left $ concat
185+ [ "Type error (" ++ show span ++ "):\n"
143− return . Left $ "Type error: Occurs check: cannot construct the infinite type: " ++ show t1 ++
186+ , "Occurs check: cannot construct the infinite type:\n"
144− " = " ++ show t2 ++
187+ , show t1, " = ", show t2, showMsg msg ]
145− " in context " ++ ctx
188+
146−uniError ctx t1 t2 =
189+uniError msg span t1 t2 =
190+ return . Left $ concat
147− return . Left $ "Type error: " ++ show t1 ++
191+ [ "Type error (" ++ show span ++ "):\n"
148− " is not equal to " ++ show t2 ++
192+ , show t1, " is not equal to ", show t2, showMsg msg ]
149− " in context " ++ ctx
193+
150−unionError ctx ts ts' =
194+unionError msg span ts ts' =
195+ return . Left $ concat
196+ [ "Type error (" ++ show span ++ "):\n"
151− return . Left $ concat [ "Type error: There are no types in both "
197+ , "There are no types in both "
152− , show (Super ts), " and ", show (Super ts')
198+ , show (Super ts), " and ", show (Super ts'), showMsg msg ]
153− , " in context ", ctx ]
199+
154−subtypeError ctx t s =
200+subtypeError msg span t s =
155− return . Left $ concat [ "Type error: ", show t, " is not a ", show s
201+ return . Left $ concat
156− , " in context ", ctx ]
202+ [ "Type error (" ++ show span ++ "):\n"
203+ , show t, " is not a ", show s, showMsg msg ]
157
204
elm/src/Types/Substitutions.hs+30−15
@@ -5,25 +5,30 @@ module Types.Substitutions (subst
5 ,rescheme
5 ,rescheme
6 ,generalize) where
6 ,generalize) where
7
7
8+import Context
8import Control.DeepSeq (NFData (..), deepseq)
9import Control.DeepSeq (NFData (..), deepseq)
9import Control.Monad (liftM)
10import Control.Monad (liftM)
10import Data.List (foldl')
11import Data.List (foldl')
11import qualified Data.Set as Set
12import qualified Data.Set as Set
13+import qualified Data.Map as Map
12import Guid
14import Guid
13import Types.Types
15import Types.Types
14
16
15−
16class Subst a where
17class Subst a where
17 subst :: [(X,Type)] -> a -> a
18 subst :: [(X,Type)] -> a -> a
18
19
19instance Subst Type where
20instance Subst Type where
21+ subst ss t =
22+ case t of
20− subst ss (VarT x) = case lookup x ss of
23+ VarT x -> case lookup x ss of
21− Nothing -> VarT x
24+ Nothing -> VarT x
22− Just (Super _) -> VarT x
25+ Just (Super _) -> VarT x
23− Just t -> t
26+ Just t -> t
24− subst ss (LambdaT t1 t2) = LambdaT (subst ss t1) (subst ss t2)
27+ LambdaT t1 t2 -> LambdaT (subst ss t1) (subst ss t2)
25− subst ss (ADT name ts) = ADT name (subst ss ts)
28+ ADT name ts -> ADT name (subst ss ts)
29+ RecordT fs t -> RecordT (Map.map (subst ss) fs) (subst ss t)
30+ EmptyRecord -> EmptyRecord
26− subst ss (Super ts) = Super ts
31+ Super ts -> Super ts
27
32
28instance Subst Scheme where
33instance Subst Scheme where
29 subst ss (Forall vs cs t) = Forall vs (subst ss cs) (subst ss t)
34 subst ss (Forall vs cs t) = Forall vs (subst ss cs) (subst ss t)
@@ -33,8 +38,8 @@ instance Subst Constraint where
33 subst ss (t :<: super) = subst ss t :<: super
38 subst ss (t :<: super) = subst ss t :<: super
34 subst ss (x :<<: poly) = x :<<: subst ss poly
39 subst ss (x :<<: poly) = x :<<: subst ss poly
35
40
36−instance Subst a => Subst (Context c a) where
41+instance Subst a => Subst (Context a) where
37− subst ss (Context ctx c) = Context ctx (subst ss c)
42+ subst ss (C str span c) = C str span (subst ss c)
38
43
39instance Subst a => Subst [a] where
44instance Subst a => Subst [a] where
40 subst ss as = map (subst ss) as
45 subst ss as = map (subst ss) as
@@ -47,6 +52,9 @@ instance FreeVars Type where
47 freeVars (VarT v) = [v]
52 freeVars (VarT v) = [v]
48 freeVars (LambdaT t1 t2) = freeVars t1 ++ freeVars t2
53 freeVars (LambdaT t1 t2) = freeVars t1 ++ freeVars t2
49 freeVars (ADT _ ts) = concatMap freeVars ts
54 freeVars (ADT _ ts) = concatMap freeVars ts
55+ freeVars (RecordT fs t) =
56+ freeVars (concat $ Map.elems fs) ++ freeVars t
57+ freeVars EmptyRecord = []
50 freeVars (Super _ ) = []
58 freeVars (Super _ ) = []
51
59
52instance FreeVars Constraint where
60instance FreeVars Constraint where
@@ -55,9 +63,11 @@ instance FreeVars Constraint where
55 freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees
63 freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees
56 where frees = concatMap freeVars cs ++ freeVars t
64 where frees = concatMap freeVars cs ++ freeVars t
57
65
58−instance FreeVars a => FreeVars (Context c a) where
66+instance FreeVars a => FreeVars (Context a) where
59− freeVars (Context _ c) = freeVars c
67+ freeVars (C _ _ c) = freeVars c
60
68
69+instance FreeVars a => FreeVars [a] where
70+ freeVars = concatMap freeVars
61
71
62class Occurs a where
72class Occurs a where
63 occurs :: X -> a -> Bool
73 occurs :: X -> a -> Bool
@@ -66,6 +76,8 @@ instance Occurs Type where
66 occurs v (VarT x) = v == x
76 occurs v (VarT x) = v == x
67 occurs v (LambdaT t1 t2) = occurs v t1 || occurs v t2
77 occurs v (LambdaT t1 t2) = occurs v t1 || occurs v t2
68 occurs v (ADT _ ts) = any (occurs v) ts
78 occurs v (ADT _ ts) = any (occurs v) ts
79+ occurs v (RecordT fs t) = occurs v (concat $ Map.elems fs) || occurs v t
80+ occurs v EmptyRecord = False
69 occurs v (Super _ ) = False
81 occurs v (Super _ ) = False
70
82
71instance Occurs Constraint where
83instance Occurs Constraint where
@@ -74,10 +86,13 @@ instance Occurs Constraint where
74 occurs x (y :<<: Forall xs cs t) = x == y || occurs x t || inCs
86 occurs x (y :<<: Forall xs cs t) = x == y || occurs x t || inCs
75 where inCs = x `notElem` xs && any (occurs x) cs
87 where inCs = x `notElem` xs && any (occurs x) cs
76
88
77−instance Occurs a => Occurs (Context c a) where
89+instance Occurs a => Occurs (Context a) where
78− occurs x (Context _ c) = occurs x c
90+ occurs x (C _ _ c) = occurs x c
91+
92+instance Occurs a => Occurs [a] where
93+ occurs v = any (occurs v)
79
94
80−concretize :: Scheme -> GuidCounter (Type, [Context String Constraint])
95+concretize :: Scheme -> GuidCounter (Type, [Context Constraint])
81concretize (Forall xs cs t) = do
96concretize (Forall xs cs t) = do
82 ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs
97 ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs
83 return (subst ss t, subst ss cs)
98 return (subst ss t, subst ss cs)
elm/src/Types/Types.hs+21−14
@@ -1,34 +1,29 @@
1
1
2module Types.Types where
2module Types.Types where
3
3
4+import Context
4import Data.Char (isDigit)
5import Data.Char (isDigit)
5import Data.List (intercalate,isPrefixOf)
6import Data.List (intercalate,isPrefixOf)
6import qualified Data.Set as Set
7import qualified Data.Set as Set
8+import qualified Data.Map as Map
7
9
8type X = Int
10type X = Int
9
11
10data Type = LambdaT Type Type
12data Type = LambdaT Type Type
11 | VarT X
13 | VarT X
12 | ADT String [Type]
14 | ADT String [Type]
15+ | EmptyRecord
16+ | RecordT (Map.Map String [Type]) Type
13 | Super (Set.Set Type)
17 | Super (Set.Set Type)
14 deriving (Eq, Ord)
18 deriving (Eq, Ord)
15
19
16−data Scheme = Forall [X] [Context String Constraint] Type deriving (Eq, Ord)
20+data Scheme = Forall [X] [Context Constraint] Type deriving (Eq, Ord)
17
21
18data Constraint = Type :=: Type
22data Constraint = Type :=: Type
19 | Type :<: Type
23 | Type :<: Type
20 | X :<<: Scheme
24 | X :<<: Scheme
21 deriving (Eq, Ord, Show)
25 deriving (Eq, Ord, Show)
22
26
23−data Context c v = Context c v deriving (Eq, Show)
24−
25−ctx c = Context ("`" ++ show c ++ "'")
26−extendCtx ctx2 (Context ctx1 c) = Context (ctx1 ++ " in " ++ ctx2) c
27−
28−instance (Ord a, Eq c) => Ord (Context c a) where
29− compare (Context _ x) (Context _ y) = compare x y
30−
31−
32tipe t = ADT t []
27tipe t = ADT t []
33
28
34
29
@@ -95,13 +90,25 @@ instance Show Type where
95 ; ADT name cs ->
90 ; ADT name cs ->
96 if isTupleString name
91 if isTupleString name
97 then parens . intercalate "," $ map show cs
92 then parens . intercalate "," $ map show cs
98− else case cs of [] -> name
93+ else case cs of
94+ [] -> name
99− _ -> parens $ name ++ " " ++ unwords (map show cs)
95+ _ -> parens $ name ++ " " ++ unwords (map show cs)
100 ; Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
96 ; Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
97+ ; EmptyRecord -> "{}"
98+ ; RecordT fs t ->
99+ start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
100+ where field n s = n ++ " :: " ++ show s
101+ fields (n,ss) = map (field n) ss
102+ start = case t of
103+ EmptyRecord -> "{ "
104+ _ -> "{ " ++ show t ++ " | "
101 }
105 }
102
106
103instance Show Scheme where
107instance Show Scheme where
104− show (Forall xs cs t) = "Forall " ++ show xs ++ cs' ++ "\n " ++ show t
108+ show (Forall [] [] t) = show t
105− where cs' = concatMap (concatMap ("\n "++) . lines . show) cs
109+ show (Forall xs cs t) =
110+ concat [ "Forall ", show xs
111+ , concatMap (("\n "++) . show) cs
112+ , "\n ", parens (show t) ]
106
113
107isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)
114isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)
elm/src/Types/Unify.hs+8−1
@@ -8,11 +8,18 @@ import Guid
8import Types.Constrain
8import Types.Constrain
9import Types.Solver
9import Types.Solver
10
10
11+import System.IO.Unsafe
12+
13+prints xs v =
14+ unsafePerformIO (putStrLn "~~~~~~~~~~" >> mapM print xs) `seq` v
15+
11unify hints modul = run $ do
16unify hints modul = run $ do
12 constraints <- constrain hints modul
17 constraints <- constrain hints modul
13 case constraints of
18 case constraints of
14 Left msg -> return (Left msg)
19 Left msg -> return (Left msg)
15 Right (escapees, cs) ->
20 Right (escapees, cs) ->
21+ prints cs $
16 do subs <- solver cs Map.empty
22 do subs <- solver cs Map.empty
17− return ((,) escapees `liftM` subs)
23+ return $ do ss <- subs
24+ prints (Map.toList ss) $ return (escapees, ss)
18
25