6cc617b · elk · git.iko.soy

git.iko.soy/elk

Add line and column number for type errors and "non-exhaustive" errors.

Add support for the basics of records: r = { x = 3, f x = x + 1 } r.x == 3 map .x [r,r,r] == [3,3,3]

commit6cc617b0abfc8c78c81d5d351315293c31b4f7c5 authorevancz <info@elm-lang.org> dateTue 25 Dec 2012, 02:39 (14 years ago) parent6443ed9

18 files changed+867−587

compare with master

unifiedsplit

elm/src/Ast.hs+55−53 elm/src/Context.hs+43 elm/src/Gen/Cases.hs+16−13 elm/src/Gen/CompileToJS.hs+66−40 elm/src/Gen/ExtractNoscript.hs+11−7 elm/src/Optimize.hs+90−71 elm/src/Parse/Binops.hs+59−41 elm/src/Parse/Expr.hs+86−46 elm/src/Parse/Library.hs+18−5 elm/src/Parse/Patterns.hs+18−12 elm/src/Rename.hs+6−11 elm/src/Substitute.hs+4−8 elm/src/Types/Constrain.hs+161−123 elm/src/Types/Hints.hs+11−10 elm/src/Types/Solver.hs+164−117 elm/src/Types/Substitutions.hs+30−15 elm/src/Types/Types.hs+21−14 elm/src/Types/Unify.hs+8−1

elm/src/Ast.hs+55−53

@@ -1,6 +1,7 @@

22module Ast where

4+import Context

45import Data.Char (isDigit)

56import Data.List (intercalate)

67import Types.Types

@@ -18,45 +19,43 @@ data ImportMethod = As String | Hiding [String] | Importing [String]

1819data Pattern = PData String [Pattern] | PVar String | PAnything

1920 deriving (Eq)

2021

22+type CExpr = Context Expr

2123data Expr = IntNum Int

2224 | FloatNum Float

2325 | Chr Char

2426 | Str String

2527 | Boolean Bool

26− | Range Expr Expr

27− | Access Expr String

28− | Binop String Expr Expr

29− | Lambda String Expr

30− | App Expr Expr

31− | If Expr Expr Expr

32− | Guard [(Expr,Expr)]

33− | Lift Expr [Expr]

34− | Fold Expr Expr Expr

35− | Async Expr

36− | Input String

37− | Let [Def] Expr

28+ | Range CExpr CExpr

29+ | Access CExpr String

30+ | Record [(String,[String],CExpr)]

31+ | Binop String CExpr CExpr

32+ | Lambda String CExpr

33+ | App CExpr CExpr

34+ | If CExpr CExpr CExpr

35+ | MultiIf [(CExpr,CExpr)]

36+ | Let [Def] CExpr

3837 | Var String

39− | Case Expr [(Pattern,Expr)]

40− | Data String [Expr]

38+ | Case CExpr [(Pattern,CExpr)]

39+ | Data String [CExpr]

4140 | Markdown Pandoc.Pandoc

4241 deriving (Eq)

4342

44−data Def = FnDef String [String] Expr

45− | OpDef String String String Expr

46− deriving (Eq)

43+data Def = FnDef String [String] CExpr

44+ | OpDef String String String CExpr

45+ deriving (Eq)

4746

4847data Statement = Definition Def

4948 | Datatype String [X] [(String,[Type])]

50− | ImportEvent String Expr String Type

49+ | ImportEvent String CExpr String Type

5150 | ExportEvent String String Type

5251 deriving (Eq,Show)

5352

54−cons h t = Data "Cons" [h,t]

55−nil = Data "Nil" []

53+cons h t = epos h t (Data "Cons" [h,t])

54+nil = C (Just "[]") NoSpan (Data "Nil" [])

5655list = foldr cons nil

5756tuple es = Data ("Tuple" ++ show (length es)) es

5857

59−delist (Data "Cons" [h,t]) = h : delist t

58+delist (C _ _ (Data "Cons" [h,t])) = h : delist t

6059delist _ = []

6160

6261

@@ -80,43 +79,49 @@ instance Show Pattern where

8079 where parens s = "(" ++ s ++ ")"

8180

8281instance Show Expr where

83− show (IntNum n) = show n

84− show (FloatNum n) = show n

85− show (Chr c) = show c

86− show (Str s) = show s

87− show (Boolean b) = show b

88− show (Range e1 e2) = "[" ++ show e1 ++ ".." ++ show e2 ++ "]"

89− show (Access e x) = show' e ++ "." ++ x

90− show (Binop op e1 e2) = show' e1 ++ " " ++ op ++ " " ++ show' e2

91− show (Lambda x e) = let (xs,e') = getLambdas (Lambda x e) in

82+ show e =

83+ case e of

84+ IntNum n -> show n

85+ FloatNum n -> show n

86+ Chr c -> show c

87+ Str s -> show s

88+ Boolean b -> show b

89+ Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"

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

93+ Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2

94+ Lambda x e -> let (xs,e') = getLambdas (noContext $ Lambda x e) in

9295 concat [ "\\", intercalate " " xs, " -> ", show e' ]

93− show (App e1 e2) = show' e1 ++ " " ++ show' e2

94− show (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

96− show (Let defs e) = "let { " ++ intercalate " ; " (map show defs) ++ " } in " ++ show e

97− show (Var x) = x

98− show (Case e pats) = "case " ++ show e ++ " of { " ++ intercalate " ; " (map (\(p,e) -> show p ++ " -> " ++ show e) pats) ++ " }"

99− show (Data name es)

100− | name == "Cons" = ("["++) . (++"]") . intercalate "," . map show $ delist (Data "Cons" es)

101− | name == "Nil" = "[]"

102− | 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| ... |]"

96+ App e1 e2 -> show' e1 ++ " " ++ show' e2

97+ If e1 e2 e3 -> concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]

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 | " ++)

101+ Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e

102+ Var x -> x

103+ Case e pats -> "case "++ show e ++" of { "++ intercalate " ; " pats' ++" }"

104+ where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats

105+ Data name es

106+ | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $

107+ delist (noContext $ Data "Cons" es)

108+ | name == "Nil" -> "[]"

109+ | otherwise -> name ++ " " ++ intercalate " " (map show' es)

110+ Markdown _ -> "[markdown| ... |]"

108111

109112

110113instance Show Def where

111− show (FnDef v [] e) = v ++ " = " ++ show e

112− show (FnDef f args e) = f ++ " " ++ intercalate " " args ++ " = " ++ show e

113− show (OpDef op a1 a2 e) = intercalate " " [a1,op,a2] ++ " = " ++ show e

114+ show e =

115+ case e of

116+ FnDef v [] e -> v ++ " = " ++ show e

117+ FnDef f args e -> f ++ " " ++ intercalate " " args ++ " = " ++ show e

118+ OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e

114119

115−getLambdas (Lambda x e) = (x:xs,e')

120+getLambdas (C _ _ (Lambda x e)) = (x:xs,e')

116121 where (xs,e') = getLambdas e

117122getLambdas e = ([],e)

118123

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

120125

121126needsParens (Binop _ _ _) = True

122127needsParens (Lambda _ _) = True

@@ -125,7 +130,4 @@ needsParens (If _ _ _) = True

125130needsParens (Let _ _) = True

126131needsParens (Case _ _) = True

127132needsParens (Data name (x:xs)) = name /= "Cons"

128−needsParens (Lift _ _) = True

129−needsParens (Fold _ _ _) = True

130−needsParens (Async _) = True

131133needsParens _ = False

elm/src/Context.hsnew file+43

@@ -0,0 +1,43 @@

2+module Context where

4+import Text.Parsec.Pos

7+data SrcPos = Pos Int Int

8+ deriving (Eq,Ord)

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)

77import Data.Maybe (fromMaybe)

99import Ast

10+import Context

1011import Guid

1112import Substitute

1213

@@ -20,7 +21,7 @@ newVar = do n <- guid

2021data Match = Match String [Clause] Match

2122 | Break

2223 | Fail

23− | Other Expr

24+ | Other CExpr

2425 | Seq [Match]

2526 deriving Show

2627

@@ -31,18 +32,20 @@ matchSubst :: [(String,String)] -> Match -> Match

3132matchSubst _ Break = Break

3233matchSubst _ Fail = Fail

3334matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)

34−matchSubst pairs (Other e) =

35− Other $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs

36−matchSubst pairs (Match n cs m) = 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)

35+matchSubst pairs (Other (C t s e)) =

36+ Other . C t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs

37+matchSubst pairs (Match n cs m) =

38+ Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

39+ where varSubst v = fromMaybe v (lookup v pairs)

40+ clauseSubst (Clause c vs m) =

41+ Clause c (map varSubst vs) (matchSubst pairs m)

3942

4043isCon (PData _ _ : _, _) = True

4144isCon _ = False

4245

4346isVar p = not (isCon p)

4447

45−match :: [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Match

48+match :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

4649match [] [] def = return def

4750match [] [([],e)] Fail = return $ Other e

4851match [] [([],e)] Break = return $ Other e

@@ -52,19 +55,19 @@ match vs cs def

5255 | all isCon cs = matchCon vs cs def

5356 | otherwise = matchMix vs cs def

5457

55−matchVar :: [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Match

58+matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

5659matchVar (v:vs) cs def = match vs (map subVar cs) def

57− where subVar (PVar x : ps, e) = (ps, subst x (Var v) e)

58− subVar (PAnything : ps, e) = (ps, e)

60+ where subVar (PVar x : ps, C t s e) = (ps, C t s $ subst x (Var v) e)

61+ subVar (PAnything : ps, ce) = (ps, ce)

5962

60−matchCon :: [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Match

63+matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

6164matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css

6265 where css = groupBy (withName (==)) $ sortBy (withName compare) cs

6366 withName f (PData n1 _:_,_) (PData n2 _:_,_) = f n1 n2

6467 toClause cs = let (PData name _ : _ , _) = head cs in

6568 matchClause name (v:vs) cs Break

6669

67−matchClause :: String -> [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Clause

70+matchClause :: String -> [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Clause

6871matchClause c (v:vs) cs def =

6972 do vs' <- getVars

7073 Clause c vs' `liftM` match (vs' ++ vs) (map flatten cs) def

@@ -72,6 +75,6 @@ matchClause c (v:vs) cs def =

7275 getVars = let (PData _ ps : _, _) = head cs in

7376 mapM (\_ -> newVar) ps

7477

75−matchMix :: [String] -> [([Pattern],Expr)] -> Match -> GuidCounter Match

78+matchMix :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match

7679matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

7780 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

elm/src/Gen/CompileToJS.hs+66−40

@@ -1,6 +1,7 @@

11module CompileToJS (showErr, jsModule) where

33import Ast

4+import Context

45import Control.Arrow (first)

56import Control.Monad (liftM,(<=<),join,ap)

67import Data.Char (isAlpha,isDigit)

@@ -140,22 +141,22 @@ class ToJS a where

140141 toJS :: a -> GuidCounter String

141142

142143instance ToJS Def where

143− toJS (FnDef x [] e) = assign x `liftM` toJS e

144+ toJS (FnDef x [] e) = assign x `liftM` toJS' e

144145 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)

146147 return $ concat ["\nfunction ",f,parens a, braces . indent $ ret body]

147148 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])

149150 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]

150151

151152instance ToJS Statement where

152153 toJS (Definition d) = toJS d

153154 toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs

154− where toDef (name,args) =

155− Definition . FnDef name vars $ Data (derename name) (map Var vars)

155+ where toDef (name,args) = Definition . FnDef name vars . noContext $

156+ Data (derename name) (map (noContext . Var) vars)

156157 where vars = map (('a':) . show) [1..length args]

157158 toJS (ImportEvent js base elm _) =

158− do v <- toJS base

159+ do v <- toJS' base

159160 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"

160161 , "\nValue.addListener(document, '" ++ js

161162 , "', function(e) { Dispatcher.notify(" ++ elm

@@ -167,6 +168,13 @@ instance ToJS Statement where

167168 , "e.value = v;"

168169 , "document.dispatchEvent(e); return v; })(", elm, ");" ]

169170

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+

170178instance ToJS Expr where

171179 toJS expr =

172180 case expr of

@@ -176,22 +184,38 @@ instance ToJS Expr where

176184 Chr c -> return $ quoted [c]

177185 Str s -> return $ "Value.str" ++ parens (quoted s)

178186 Boolean b -> return $ if b then "true" else "false"

179− Range lo hi -> jsRange `liftM` toJS lo `ap` toJS hi

180− Access e lbl -> (\s -> s ++ "." ++ lbl) `liftM` toJS e

181− Binop op e1 e2 -> binop op `liftM` toJS e1 `ap` toJS e2

182− If eb et ef -> parens `liftM` (iff `liftM` toJS eb `ap` toJS et `ap` toJS ef)

183− Guard ps -> guardToJS ps

184− Lambda v e -> liftM (jsFunc v . ret) (toJS e)

185− App (Var "toText") (Str s) -> return $ "toText" ++ parens (quoted s)

186− App (Var "link") (Str s) -> return $ "link(" ++ quoted s ++ ")"

187− App (Var "plainText") (Str s) -> return $ "plainText(" ++ quoted s ++ ")"

188− App e1 e2 -> (++) `liftM` (toJS e1) `ap` (parens `liftM` toJS e2)

187+ Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi

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+

195+ Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2

196+

197+ If eb et ef ->

198+ parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)

199+

200+ Lambda v e -> liftM (jsFunc v . ret) (toJS' e)

201+

202+ App (C _ _ (Var "toText")) (C _ _ (Str s)) ->

203+ return $ "toText" ++ parens (quoted s)

204+

205+ App (C _ _ (Var "link")) (C _ _ (Str s)) ->

206+ return $ "link(" ++ quoted s ++ ")"

207+

208+ App (C _ _ (Var "plainText")) (C _ _ (Str s)) ->

209+ return $ "plainText(" ++ quoted s ++ ")"

210+

211+ App e1 e2 -> (++) `liftM` (toJS' e1) `ap` (parens `liftM` toJS' e2)

189212 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+

192215 Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"

193− where md = formatMarkdown $ Pan.writeHtmlString Pan.defaultWriterOptions doc

194− pad = "<div style=\"height:0;width:0;\"> </div>"

216+ where pad = "<div style=\"height:0;width:0;\"> </div>"

217+ md = formatMarkdown $

218+ Pan.writeHtmlString Pan.defaultWriterOptions doc

195219

196220formatMarkdown = concatMap f

197221 where f '\'' = "\\'"

@@ -199,15 +223,16 @@ formatMarkdown = concatMap f

199223 f '"' = "\""

200224 f c = [c]

201225

202−guardToJS ps = format `liftM` mapM f ps

226+multiIfToJS span ps = format `liftM` mapM f ps

203227 where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs

204− err = "(function(){throw \"Non-exhaustive guard expression\";}())"

205− f (b,e) = do b' <- toJS b

206− e' <- toJS e

228+ err = concat [ "(function(){throw \"Non-exhaustive "

229+ , "multi-way-if expression (", show span, ")\";}())" ]

230+ f (b,e) = do b' <- toJS' b

231+ e' <- toJS' e

207232 return (b' ++ " ? " ++ e')

208233

209234jsLet defs e' = do

210− body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS e')

235+ body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')

211236 return $ jsFunc "" body ++ "()"

212237

213238jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)

@@ -215,28 +240,29 @@ jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)

215240 valueOf (FnDef _ args _) = min 1 (length args)

216241 valueOf (OpDef _ _ _ _) = 1

217242

218−caseToJS e ps = do

243+caseToJS span e ps = do

219244 match <- caseToMatch ps

220− e' <- toJS e

245+ e' <- toJS' e

221246 (match',stmt) <- case (match,e) of

222− (Match name _ _, Var x) -> return (matchSubst [(name,x)] match, "")

223− (Match name _ _, _ ) -> return (match, assign name e')

224− _ -> liftM (\n -> (match, e')) guid

225− matches <- matchToJS match'

247+ (Match name _ _, C _ _ (Var x)) -> return (matchSubst [(name,x)] match, "")

248+ (Match name _ _, _) -> return (match, assign name e')

249+ _ -> liftM (\n -> (match, e')) guid

250+ matches <- matchToJS span match'

226251 return $ concat [ "function(){", stmt, matches, "}()" ]

227252

228−matchToJS (Match name clauses def) = do

229− cases <- concat `liftM` mapM (clauseToJS name) clauses

230− finally <- matchToJS def

253+matchToJS span (Match name clauses def) = do

254+ cases <- concat `liftM` mapM (clauseToJS span name) clauses

255+ finally <- matchToJS span def

231256 return $ concat [ "\nswitch(", name, "[0]){", indent cases, "\n}", finally ]

232−matchToJS Fail = return "\nthrow \"Non-exhaustive pattern match in case\";"

233−matchToJS Break = return "break;"

234−matchToJS (Other e) = ret `liftM` toJS e

235−matchToJS (Seq ms) = concat `liftM` mapM matchToJS ms

257+matchToJS span Fail = return ("\nthrow \"Non-exhaustive pattern match " ++

258+ "in case expression (" ++ show span ++ ")\";")

259+matchToJS span Break = return "break;"

260+matchToJS span (Other e) = ret `liftM` toJS' e

261+matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms

236262

237−clauseToJS var (Clause name vars e) = do

263+clauseToJS span var (Clause name vars e) = do

238264 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

240266 return $ concat [ "\ncase ", quoted name, ":", s ]

241267

242268jsNil = "[\"Nil\"]"

elm/src/Gen/ExtractNoscript.hs+11−7

@@ -2,6 +2,7 @@

22module ExtractNoscript (extractNoscript) where

44import Ast

5+import Context

56import qualified Text.Pandoc as Pan

78extractNoscript :: Module -> String

@@ -22,6 +23,9 @@ instance Extract Def where

2223 extract (FnDef _ _ e) = extract e

2324 extract (OpDef _ _ _ e) = extract e

2425

26+instance Extract e => Extract (Context e) where

27+ extract (C _ _ e) = extract e

28+

2529instance Extract Expr where

2630 extract expr =

2731 let f = extract in

@@ -31,13 +35,13 @@ instance Extract Expr where

3135 ("++", [s1], [s2]) -> [s1 ++ s2]

3236 (_ , ss1 , ss2 ) -> ss1 ++ ss2

3337 Lambda v e -> f e

34− App (App (Var "link") src) txt -> linkExtract src txt

35− App (App (Var "Graphics.link") src) txt -> linkExtract src txt

36− App (App (Var "Text.link") src) txt -> linkExtract src txt

37− App (Var "header") e -> tag "h1" e

38− App (Var "bold") e -> tag "b" e

39− App (Var "italic") e -> tag "i" e

40− App (Var "monospace") e -> tag "code" e

38+ App (C _ _ (App (C _ _ (Var "link")) src)) txt -> linkExtract src txt

39+ App (C _ _ (App (C _ _ (Var "Graphics.link")) src)) txt -> linkExtract src txt

40+ App (C _ _ (App (C _ _ (Var "Text.link")) src)) txt -> linkExtract src txt

41+ App (C _ _ (Var "header")) e -> tag "h1" e

42+ App (C _ _ (Var "bold")) e -> tag "b" e

43+ App (C _ _ (Var "italic")) e -> tag "i" e

44+ App (C _ _ (Var "monospace")) e -> tag "code" e

4145 App e1 e2 -> f e1 ++ f e2

4246 If eb et ef -> f et ++ f ef

4347 Let defs e -> concatMap extract defs ++ f e

elm/src/Optimize.hs+90−71

@@ -1,6 +1,7 @@

11module Optimize (optimize) where

33import Ast

4+import Context

45import Control.Arrow (second)

56import Data.Char (isAlpha)

67import Substitute

@@ -22,7 +23,9 @@ instance Simplify Statement where

2223instance Simplify Def where

2324 simp (FnDef func args e) = FnDef func args (simp e)

2425 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)

2629

2730instance Simplify Expr where

2831 simp expr =

@@ -31,9 +34,11 @@ instance Simplify Expr where

3134 Range e1 e2 -> Range (f e1) (f e2)

3235 Binop op e1 e2 -> simp_binop op (f e1) (f e2)

3336 Lambda x e -> Lambda x (f e)

34− App (Lambda x e1) e2 ->

35− if isValue e2' then subst x e2' e1' else App (Lambda x e1') e2'

36− where { e1' = f e1 ; e2' = f e2 }

37+ Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)

38+ App (C t s (Lambda x e1)) e2 ->

39+ if isValue e2' then subst x e2' e1' else App (C t s (Lambda x ce1')) ce2'

40+ where ce1'@(C _ _ e1') = f e1

41+ ce2'@(C _ _ e2') = f e2

3742 App e1 e2 -> App (f e1) (f e2)

3843 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)

3944 Let defs e -> Let (map simp defs) (f e)

@@ -41,75 +46,89 @@ instance Simplify Expr where

4146 Case e cases -> Case (f e) (map (second f) cases)

4247 _ -> expr

4348

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

4550simp_if a b c = If a b c

4651

47−isValue e = case e of { IntNum _ -> True

48− ; FloatNum _ -> True

49− ; Chr _ -> True

50− ; Str _ -> True

51− ; Boolean _ -> True

52− ; Var _ -> True

53− ; Data _ _ -> True

54− ; _ -> False }

52+isValue e =

53+ case e of { IntNum _ -> True

54+ ; FloatNum _ -> True

55+ ; Chr _ -> True

56+ ; Str _ -> True

57+ ; Boolean _ -> True

58+ ; Var _ -> True

59+ ; Data _ _ -> True

60+ ; _ -> False }

5561

5662simp_binop = binop

5763

58−binop op (IntNum n) (IntNum m) = f n m

59− where f a b = case op of

60− { "+" -> IntNum $ (+) a b

61− ; "-" -> IntNum $ (-) a b

62− ; "*" -> IntNum $ (*) a b

63− ; "div" -> IntNum $ div a b

64− ; "mod" -> IntNum $ mod a b

65− ; "<" -> Boolean $ a < b

66− ; ">" -> Boolean $ a < b

67− ; "<=" -> Boolean $ a <= b

68− ; ">=" -> Boolean $ a >= b

69− ; "==" -> Boolean $ a == b

70− ; "/=" -> Boolean $ a /= b

71− ; _ -> Binop op (IntNum n) (IntNum m) }

72−

73−binop "-" e (IntNum 0) = e

74−binop "+" (IntNum 0) e = e

75−binop "+" e (IntNum 0) = e

76−binop "+" (IntNum n) (Binop "+" (IntNum m) e) = binop "+" (IntNum (n+m)) e

77−binop "+" (IntNum n) (Binop "+" e (IntNum m)) = binop "+" (IntNum (n+m)) e

78−

79−binop "/" e (IntNum 1) = e

80−binop "div" e (IntNum 1) = e

81−binop "*" (IntNum 0) e = IntNum 0

82−binop "*" (IntNum 1) e = e

83−binop "*" (IntNum n) (Binop "*" (IntNum m) e) = binop "*" (IntNum (n*m)) e

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

91− ; "||" -> Boolean $ (||) n m

92− ; _ -> Binop op (Boolean n) (Boolean m) }

93−

94−binop "&&" (Boolean True) e = e

95−binop "&&" (Boolean False) e = Boolean False

96−binop "||" (Boolean True) e = Boolean True

97−binop "||" (Boolean False) e = e

98−

99−binop "&&" e (Boolean n) = binop "&&" (Boolean n) e

100−binop "||" e (Boolean n) = binop "||" (Boolean n) e

101−

102−binop ":" h t = cons h t

103−binop "++" (Str s1) (Str s2) = Str $ s1 ++ s2

104−binop "++" (Str s1) (Binop "++" (Str s2) e) = Binop "++" (Str $ s1 ++ s2) e

105−binop "++" (Binop "++" e (Str s1)) (Str s2) = Binop "++" e (Str $ s1 ++ s2)

106−binop "++" (Data "Nil" []) e = e

107−binop "++" e (Data "Nil" []) = e

108−binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]

109−

110−binop "$" e1 e2 = App e1 e2

111−binop "." e1 e2 = Lambda "x" (App e1 (App e2 (Var "x")))

112−

113−binop op e1 e2

114− | isAlpha (head op) || '_' == head op = App (App (Var op) e1) e2

115− | otherwise = Binop op e1 e2

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

68+ (_, IntNum n, IntNum m) -> case op of

69+ { "+" -> IntNum $ (+) n m

70+ ; "-" -> IntNum $ (-) n m

71+ ; "*" -> IntNum $ (*) n m

72+ ; "^" -> IntNum $ n ^ m

73+ ; "div" -> IntNum $ div n m

74+ ; "mod" -> IntNum $ mod n m

75+ ; "<" -> Boolean $ n < m

76+ ; ">" -> Boolean $ n < m

77+ ; "<=" -> Boolean $ n <= m

78+ ; ">=" -> Boolean $ n >= m

79+ ; "==" -> Boolean $ n == m

80+ ; "/=" -> Boolean $ n /= m

81+ ; _ -> Binop op ce1 ce2 }

82+

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) ->

89+ binop "+" (c1 $ IntNum (n+m)) ce

90+ ("+", Binop "+" (C _ _ (IntNum n)) ce1'

91+ , Binop "+" (C _ _ (IntNum m)) ce2') ->

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'

99+ , Binop "*" (C _ _ (IntNum m)) ce2') ->

100+ binop "*" (noContext $ IntNum (n*m)) (noContext $ Binop "*" ce1' ce2')

101+

102+ ("-", _, IntNum 0) -> e1

103+ ("/", _, IntNum 1) -> e1

104+ ("div", _, IntNum 1) -> e1

105+

106+ (_, Boolean n, Boolean m) -> case op of "&&" -> Boolean $ n && m

107+ "||" -> Boolean $ n || m

108+ _ -> Binop op ce1 ce2

109+

110+ ("&&", Boolean True, _) -> e2

111+ ("&&", Boolean False, _) -> Boolean False

112+ ("||", Boolean True, _) -> Boolean True

113+ ("||", Boolean False, _) -> e2

114+

115+ (":", _, _) -> let (C _ _ e) = cons ce1 ce2 in e

116+

117+ ("++", Str s1, Str s2) -> Str $ s1 ++ s2

118+ ("++", Str s1, Binop "++" (C _ _ (Str s2)) ce) ->

119+ Binop "++" (c1 $ Str $ s1 ++ s2) ce

120+ ("++", Binop "++" e (C _ _ (Str s1)), Str s2) ->

121+ Binop "++" e (c1 $ Str $ s1 ++ s2)

122+

123+ ("++", Data "Nil" [], _) -> e2

124+ ("++", _, Data "Nil" []) -> e1

125+ ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, noContext $ binop "++" t ce2]

126+

127+ ("$", _, _) -> App ce1 ce2

128+ (".", _, _) ->

129+ Lambda "x" (noContext $

130+ App ce1 (noContext $ App ce2 (noContext $ Var "x")))

131+

132+ _ | isAlpha (head op) || '_' == head op ->

133+ App (noContext $ App (noContext $ Var op) ce1) ce2

134+ | otherwise -> Binop op ce1 ce2

elm/src/Parse/Binops.hs+59−41

@@ -1,9 +1,11 @@

11module Parse.Binops (binops) where

33import Ast

4+import Context

45import Control.Monad (liftM,guard)

56import 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)

79import qualified Data.Map as Map

810import Data.Maybe (mapMaybe)

911

@@ -12,6 +14,9 @@ import Parse.Library

1214

1315data Assoc = L | N | R deriving (Eq,Show)

1416

17+type OpTable = [(Int, Assoc, String)]

18+

19+table :: OpTable

1520table = [ (9, R, ".")

1621 , (8, R, "^")

1722 , (7, L, "*"), (7, L, "/"), (7, L, "mod"), (7, L, "div"), (7, L, "rem")

@@ -19,52 +24,65 @@ table = [ (9, R, ".")

1924 , (5, R, ":" ), (5, R, "++")

2025 , (4, N, "<="), (4, N, ">="), (4, N, "<")

2126 , (4, N, "=="), (4, N, "/="), (4, N, ">")

22− , (4, L, "<~"), (4, L, "~")

27+ , (4, L, "~"), (4, L, "<~")

2328 , (3, R, "&&")

2429 , (2, R, "||")

2530 , (0, R, "$")

2631 ]

2732

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

2842sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)

2943

44+binops :: IParser CExpr -> IParser String -> IParser CExpr

3045binops term anyOp = do

3146 e <- term

32− (ops,es) <- liftM unzip $

33− many (commitIf (whitespace >> anyOp) $ do { whitespace ; op <- anyOp

34− ; whitespace ; e <- term

35− ; return (op,e) })

36− case binopOf Map.empty (sortOps table) ops (e:es) of

37− Right e -> return e

38− Left msg -> fail msg

39−

40−binopSplit seen opTable i ops es =

41− case (splitAt i ops, splitAt (i+1) es) of

42− ((befores, op:afters), (pres, posts)) ->

43− do e1 <- binopOf seen opTable befores pres

44− e2 <- binopOf seen opTable afters posts

45− return $ Binop op e1 e2

46−

47−binopOf _ _ _ [e] = return e

48−binopOf seen [] ops es = binopOf seen [(9,L,head ops)] ops es

49−

50−binopOf seen (tbl@((lvl, L, op):rest)) ops es =

51− case elemIndices op ops of

52− [] -> binopOf seen rest ops es

53− is -> case Map.lookup lvl seen of

54− Nothing -> binopSplit (Map.insert lvl (L,op) seen) tbl (last is) ops es

55− Just (L,_) -> binopSplit seen tbl (last is) ops es

56− Just (assoc,op') -> Left $ errorMessage lvl op L op' assoc

57−binopOf seen (tbl@((lvl, assoc, op):rest)) ops es =

58− case elemIndices op ops of

59− [] -> binopOf seen rest ops es

60− i:_ -> case Map.lookup lvl seen of

61− Nothing -> binopSplit (Map.insert lvl (assoc,op) seen) tbl i ops es

62− Just (assoc',op') ->

63− if assoc == assoc' && assoc /= N then

64− binopSplit seen tbl i ops es

65− else Left $ errorMessage lvl op assoc op' assoc'

66−

67−errorMessage lvl op1 assoc1 op2 assoc2 =

68− "Cannot have (" ++ op1 ++ ") with [" ++ show assoc1 ++ " " ++

69− show lvl ++ "] and (" ++ op2 ++ ") with [" ++ show assoc2 ++ " " ++

70− show lvl ++ "]"

47+ split 0 e =<< many (commitIf (whitespace >> anyOp) $ do

48+ whitespace ; op <- anyOp

49+ whitespace ; e <- term

50+ return (op,e))

51+

52+split :: Int -> CExpr -> [(String, CExpr)] -> IParser CExpr

53+split _ e [] = return e

54+split n e eops = do

55+ assoc <- getAssoc n eops

56+ es <- sequence (splitLevel n e eops)

57+ let ops = map fst (filter (hasLevel n) eops)

58+ case assoc of R -> joinR es ops

59+ _ -> joinL es ops

60+

61+splitLevel :: Int -> CExpr -> [(String, CExpr)] -> [IParser CExpr]

62+splitLevel n e eops =

63+ case break (hasLevel n) eops of

64+ (lops, (op,e'):rops) -> split (n+1) e lops : splitLevel n e' rops

65+ (lops, []) -> [ split (n+1) e lops ]

66+

67+joinL :: [CExpr] -> [String] -> IParser CExpr

68+joinL [e] [] = return e

69+joinL (a:b:es) (op:ops) = joinL (epos a b (Binop op a b) : es) ops

70+joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."

71+

72+joinR :: [CExpr] -> [String] -> IParser CExpr

73+joinR [e] [] = return e

74+joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

75+ return (epos a e (Binop op a e))

76+joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."

77+

78+getAssoc :: Int -> [(String,CExpr)] -> IParser Assoc

79+getAssoc n eops | all (==L) assocs = return L

80+ | all (==R) assocs = return R

81+ | all (==N) assocs = case assocs of [_] -> return N

82+ _ -> fail msg

83+ where levelOps = filter (hasLevel n) eops

84+ assocs = map (opAssoc . fst) levelOps

85+ msg = concat [ "Conflicting precedence for binary operators ("

86+ , intercalate ", " (map fst eops), "). "

87+ , "Consider adding parentheses to disambiguate." ]

88+

elm/src/Parse/Expr.hs+86−46

@@ -1,6 +1,7 @@

11module Parse.Expr (def,term) where

33import Ast

4+import Context

45import Control.Applicative ((<$>), (<*>))

56import Control.Monad

67import Data.Char (isSymbol, isDigit)

@@ -45,56 +46,107 @@ chrTerm :: IParser Expr

4546chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

4647 <?> "character"

4748

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+

4857

4958-------- Complex Terms --------

5059

5160listTerm :: IParser Expr

52−listTerm = (do { try $ string "[markdown|"

53− ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")

54− ; return . Markdown $ Pan.readMarkdown Pan.defaultParserState md })

55− <|> (braces $ choice

56− [ try $ do { lo <- expr; whitespace; string ".." ; whitespace

57− ; Range lo <$> expr }

58− , list <$> commaSep expr ])

59−

60−parensTerm :: IParser Expr

61+listTerm =

62+ (do { try $ string "[markdown|"

63+ ; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")

64+ ; return . Markdown $ Pan.readMarkdown Pan.defaultParserState md })

65+ <|> (braces $ choice

66+ [ try $ do { lo <- expr; whitespace; string ".." ; whitespace

67+ ; Range lo <$> expr }

68+ , do (C _ _ e) <- list <$> commaSep expr

69+ return e

70+ ])

71+

72+parensTerm :: IParser CExpr

6173parensTerm = parens $ choice

62− [ do op <- anyOp

63− return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")

64− , do let comma = char ',' <?> "comma ','"

74+ [ do start <- getPosition

75+ op <- try anyOp

76+ end <- getPosition

77+ let ctxt = pos start end

78+ return . ctxt . Lambda "x" . ctxt . Lambda "y" . ctxt $

79+ Binop op (ctxt $ Var "x") (ctxt $ Var "y")

80+ , do start <- getPosition

81+ let comma = char ',' <?> "comma ','"

6582 commas <- comma >> many (whitespace >> comma)

83+ end <- getPosition

6684 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]

67− return $ foldr Lambda (tuple $ map Var vars) (vars)

68− , do es <- commaSep expr

69− return $ case es of { [e] -> e; _ -> tuple es }

85+ ctxt = pos start end

86+ return $ foldr (\x e -> ctxt $ Lambda x e)

87+ (ctxt . tuple $ map (ctxt . Var) vars) vars

88+ , do start <- getPosition

89+ es <- commaSep expr

90+ end <- getPosition

91+ return $ case es of [e] -> e

92+ _ -> pos start end (tuple es)

7093 ]

7194

72−term :: IParser Expr

73−term = choice [ numTerm, strTerm, chrTerm

74− , accessible varTerm

75− , listTerm, parensTerm ]

76− <?> "basic term (4, x, 'c', etc.)"

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

119+term = addContext (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])

120+ <|> accessible (addContext varTerm <|> parensTerm <|> addContext recordTerm)

121+ <?> "basic term (4, x, 'c', etc.)"

77122

78123-------- Applications --------

79124

80−appExpr :: IParser Expr

125+appExpr :: IParser CExpr

81126appExpr = do

82127 tlist <- spaceSep1 term

83128 return $ case tlist of

84129 t:[] -> t

85− t:ts -> foldl' App t ts

130+ t:ts -> foldl' (\f x -> epos f x $ App f x) t ts

86131

87132-------- Normal Expressions --------

88133

89−binaryExpr :: IParser Expr

134+binaryExpr :: IParser CExpr

90135binaryExpr = binops appExpr anyOp

91136

92137ifExpr :: IParser Expr

93−ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace

94− reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")

95− reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr

96−

97−lambdaExpr :: IParser Expr

138+ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

139+ where normal = do e1 <- expr ; whitespace

140+ reserved "then" ; whitespace ; e2 <- expr

141+ whitespace <?> "an 'else' branch"

142+ reserved "else" <?> "an 'else' branch" ; whitespace

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+

149+lambdaExpr :: IParser CExpr

98150lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

99151 whitespace

100152 pats <- spaceSep1 patternTerm

@@ -103,16 +155,7 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

103155 return $ makeLambda pats e

104156

105157defSet :: 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)

112− Just "{" -> do dss <- semiSep1 assignExpr

113− whitespace

114− string "}" <?> "closing bracket '}'"

115− return (concat dss)

158+defSet = concat <$> block (do d <- assignExpr ; whitespace ; return d)

116159

117160letExpr :: IParser Expr

118161letExpr = do

@@ -130,8 +173,10 @@ caseExpr = do

130173 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

131174 without = block (do c <- case_ ; whitespace ; return c)

132175

133−expr = choice [ ifExpr, letExpr, caseExpr

134− , lambdaExpr, binaryExpr ] <?> "an expression"

176+expr = addContext (choice [ ifExpr, letExpr, caseExpr ])

177+ <|> lambdaExpr

178+ <|> binaryExpr

179+ <?> "an expression"

135180

136181funcDef = try (do p1 <- try patternTerm ; infics p1 <|> func p1)

137182 <|> ((:[]) <$> patternExpr)

@@ -149,14 +194,9 @@ assignExpr :: IParser [Def]

149194assignExpr = withPos $ do

150195 fDefs <- funcDef

151196 whitespace

152− e <- (string "=" >> whitespace >> expr) <|> guardExpr

197+ e <- string "=" >> whitespace >> expr

153198 flattenPatterns fDefs e

154199

155−guardExpr = (Guard <$> spaceSep1 gExpr)

156− where gExpr = do string "|" ; whitespace

157− b <- expr ; whitespace ; string "=" ; whitespace

158− (,) b <$> expr

159−

160200def = map Definition <$> assignExpr

161201

162202

elm/src/Parse/Library.hs+18−5

@@ -2,6 +2,7 @@

22module Parse.Library where

44import Ast

5+import Context

56import Control.Applicative ((<$>),(<*>))

67import Control.Monad

78import Control.Monad.State

@@ -57,7 +58,9 @@ isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"

5758symOp :: IParser String

5859symOp = do op <- many1 (satisfy isOp)

5960 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594" ])

60− return op

61+ case op of

62+ "." -> notFollowedBy lower >> return op

63+ _ -> return op

6164

6265arrow :: IParser String

6366arrow = string "->" <|> string "\8594" <?> "arrow (->)"

@@ -114,13 +117,23 @@ parens = surround '(' ')' "paren"

114117brackets :: IParser a -> IParser a

115118brackets = surround '{' '}' "bracket"

116119

117−accessible :: IParser Expr -> IParser Expr

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+

127+accessible :: IParser CExpr -> IParser CExpr

118128accessible expr = do

129+ start <- getPosition

119130 e <- expr

120− access <- optionMaybe . try $

121− (do { char '.' ; notFollowedBy (char '.') } <?> "field access (e.g. List.map)")

131+ access <- optionMaybe . try $ (do { char '.' ; notFollowedBy (char '.') }

132+ <?> "field access (e.g. List.map)")

122133 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))

124137 Nothing -> return e

125138

126139

elm/src/Parse/Patterns.hs+18−12

@@ -1,10 +1,11 @@

11module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where

33import Ast

4−import Data.Char (isUpper)

4+import Context

55import Control.Applicative ((<$>),(<*>))

66import Control.Monad

77import Control.Monad.State

8+import Data.Char (isUpper)

89import Text.Parsec hiding (newline,spaces,State)

910import Text.Parsec.Indent

1011import Parse.Library

@@ -32,14 +33,18 @@ patternConstructor = PData <$> capVar <*> spacePrefix patternTerm

3233patternExpr :: IParser Pattern

3334patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?> "pattern"

3435

35−

36−makeLambda pats body = foldr Lambda (makeBody pats body) (map getName pats)

36+makeLambda :: [Pattern] -> CExpr -> CExpr

37+makeLambda pats body =

38+ foldr (\x e -> noContext $ Lambda x e)

39+ (makeBody pats body)

40+ (map getName pats)

3741

3842makeBody pats body = foldr func body pats

3943 where func PAnything e = e

4044 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)]

4246

47+flattenPatterns :: [Pattern] -> CExpr -> IParser [Def]

4348flattenPatterns (PVar f : args) exp

4449 | isOp (head f) = let [a,b] = (map getName args) in

4550 return [ OpDef f a b (makeBody args exp) ]

@@ -47,19 +52,20 @@ flattenPatterns (PVar f : args) exp

4752

4853

4954flattenPatterns [p] exp = return $ matchSingle p exp p

50−

5155flattenPatterns ps _ =

5256 fail $ "Pattern (" ++ unwords (map show ps) ++

5357 ") cannot be used on the left-hand side of an assign statement."

5458

59+matchSingle :: Pattern -> CExpr -> Pattern -> [Def]

5560matchSingle 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

5762 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)]) ]

5965matchSingle pat exp PAnything = []

6066

61−getName p = f p

62− where f (PData n ps) = n ++ "$" ++ concatMap getName ps

63− f (PAnything) = "_"

64− f (PVar x) = x

65−

67+getName :: Pattern -> String

68+getName p = case p of

69+ PData n ps -> n ++ "$" ++ concatMap getName ps

70+ PAnything -> "_"

71+ PVar x -> x

elm/src/Rename.hs+6−11

@@ -2,6 +2,7 @@

22module Rename (renameModule, derename, deprime) where

44import Ast

5+import Context

56import Control.Arrow (first)

67import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)

78import Control.Monad.State (evalState, State, get, put)

@@ -48,6 +49,9 @@ renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts

4849 ImportEvent _ _ n _ -> [n]

4950 _ -> []

5051

52+instance Rename a => Rename (Context a) where

53+ rename env (C t s e) = C t s `liftM` rename env e

54+

5155instance Rename Expr where

5256 rename env expr =

5357 let rnm = rename env in

@@ -77,19 +81,10 @@ instance Rename Expr where

7781 `ap` rnm e2

7882 `ap` rnm e3

7983

80− Guard ps -> Guard `liftM` mapM grnm ps

84+ MultiIf ps -> MultiIf `liftM` mapM grnm ps

8185 where grnm (b,e) = (,) `liftM` rnm b

8286 `ap` rnm e

8387

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−

9388 Let defs e -> renameLet env defs e

9489

9590 Var x -> return . Var $ env x

@@ -122,7 +117,7 @@ patternExtend pattern env =

122117 where f (rps,env') p = do (rp,env'') <- patternExtend p env'

123118 return (rp:rps, env'')

124119

125−patternRename :: (String -> String) -> (Pattern, Expr) -> GuidCounter (Pattern, Expr)

120+patternRename :: (String -> String) -> (Pattern, CExpr) -> GuidCounter (Pattern, CExpr)

126121patternRename env (p,e) = do

127122 (rp,env') <- patternExtend p env

128123 re <- rename env' e

elm/src/Substitute.hs+4−8

@@ -1,12 +1,12 @@

11module Substitute (subst) where

3−import Control.Arrow (second, (***))

4−

53import Ast

4+import Context

5+import Control.Arrow (second, (***))

77subst :: String -> Expr -> Expr -> Expr

88subst 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

1010 case expr of

1111 Range e1 e2 -> Range (f e1) (f e2)

1212 Access e x -> Access (f e) x

@@ -14,11 +14,7 @@ subst old new expr =

1414 Lambda x e -> if x == old then expr else Lambda x (f e)

1515 App e1 e2 -> App (f e1) (f e2)

1616 If e1 e2 e3 -> If (f e1) (f e2) (f e3)

17− Guard ps -> Guard (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

17+ MultiIf ps -> MultiIf (map (f *** f) ps)

2218 Let defs e -> Let (map substDef defs) (f e)

2319 where substDef (FnDef name vs e) = FnDef name vs (f e)

2420 substDef (OpDef op a1 a2 e) = OpDef op a1 a2 (f e)

elm/src/Types/Constrain.hs+161−123

@@ -1,23 +1,20 @@

22module Types.Constrain (constrain) where

4−import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)

5−import qualified Data.Set as Set

6−import qualified Data.Map as Map

74import Control.Arrow (second)

85import Control.Monad (liftM,mapM,zipWithM,foldM)

96import 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

1010

1111import Ast

12+import Context

1213import Guid

1314

1415import Types.Types

1516import Types.Substitutions

1617

17−--import System.IO.Unsafe

18−

19−prints xs v = v --} unsafePerformIO (putStrLn "~~~~~~~~~~" >> mapM print xs) `seq` v

20−

2118beta = VarT `liftM` guid

2219unionA = Map.unionWith (++)

2320unionsA = Map.unionsWith (++)

@@ -53,114 +50,152 @@ constrain typeHints (Module _ _ imports stmts) = do

5350 allHints = Map.fromList (aliasHints ++ concat schemess)

5451 assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)

5552 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

5754 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions

5855 escapees = Map.keys $ Map.difference assumptions allHints

5956 return . Right . (,) escapees $ cs ++ Set.toList (Set.unions css)

6057

61−gen :: Expr -> GuidCounter (Map.Map String [X],

62− Set.Set (Context String Constraint),

63− Type)

64−

65−gen (Var x) =

66− do b <- guid

67− return (Map.singleton x [b], Set.empty, VarT b)

68−

69−gen e@(App e1 e2) =

70− do (a1,c1,t1) <- gen e1

71− (a2,c2,t2) <- gen e2

72− b <- beta

73− return ( unionA a1 a2

74− , Set.unions [c1,c2,Set.singleton . ctx e $ t1 :=: (LambdaT t2 b)]

75− , b )

76−gen (Lambda x e) =

77− do (a,c,t) <- gen e

78− b <- beta

79− v <- guid

80− return ( Map.delete x a

81− , Set.union c . Set.fromList . map (\x -> ctx e $ VarT x :=: b) $

82− Map.findWithDefault [v] x a

83− , LambdaT b t )

84−gen (Let defs e) =

85− do (as,cs,t) <- gen e

86− (ass, schemes) <- liftM unzip (mapM defScheme defs)

87− let assumptions = unionsA (as:ass)

88− getName (FnDef f _ _) = f

89− getName (OpDef op _ _ _) = op

90− names = map getName defs

91− genCs name s = do

92− v <- guid

93− let vs = Map.findWithDefault [v] name assumptions

94− return $ map (\x -> ctx (Var name) $ x :<<: s) vs

95− cs' <- zipWithM genCs names schemes

96− return ( foldr Map.delete assumptions names

97− , Set.union (Set.fromList . concat $ cs') cs

98− , t )

99−

100−gen ce@(Case e cases) =

101− do (as,cs,t) <- gen e

102− (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases

103− return ( unionsA $ as:ass

104− , let combine t1 t2 = ctx ce (t1 :=: t2) in

105− Set.unions $ Set.fromList (zipWith combine ts $ tail ts) : cs : css

106− , head ts)

107−

108−gen e@(If e1 e2 e3) =

109− do (a1,c1,t1) <- gen e1

110− (a2,c2,t2) <- gen e2

111− (a3,c3,t3) <- gen e3

112− return ( unionsA [a1,a2,a3]

113− , Set.unions [c1,c2,c3, Set.fromList [ ctx e1 (t1 :=: bool), ctx e (t2 :=: t3) ] ]

114− , t2 )

115−

116−gen (Data name es) = gen $ foldl' App (Var name) es

117−gen (Binop op e1 e2) = gen (Var op `App` e1 `App` e2)

118−

119−gen (Access (Var a) b) = gen . Var $ a ++ "." ++ b

120−gen (Access (Access (Var a) b) c) = gen . Var $ intercalate "." [a, b, c]

121−gen (Access (Access (Access (Var a) b) c) d) = gen . Var $ intercalate "." [a, b, c, d]

122−

123−gen (Range e1 e2) =

124− do (a1,c1,t1) <- gen e1

125− (a2,c2,t2) <- gen e2

126− return ( unionsA [a1,a2]

127− , Set.unions [ c1, c2, Set.fromList [ ctx e1 (t1 :=: int)

128− , ctx e2 (t2 :=: int) ] ]

129− , listOf int )

130−

131−gen e@(Guard ps) = do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps

132− let cs = Set.fromList (map (ctx e . (t :=:)) ts)

133− return (unionsA ass, Set.unions (cs:css), t)

134− where genPair (b,e) = do

135− (a1,c1,t1) <- gen b

136− (a2,c2,t2) <- gen e

137− return ( unionsA [a1,a2]

138− , Set.unions [ c1, c2, Set.singleton (ctx b (t1 :=: bool)) ]

139− , t2 )

140−

141−gen other =

142− case other of

143− IntNum _ -> do t <- beta

144− return (Map.empty, Set.singleton (ctx other $ t :<: number), t)

145− FloatNum _ -> primitive float

146− Chr _ -> primitive char

147− Str _ -> primitive string

148− Boolean _ -> primitive bool

149− Markdown _ -> primitive element

58+type TVarMap = Map.Map String [X]

59+type ConstraintSet = Set.Set (Context Constraint)

60+

61+ctx e span = C (Just $ show e) span

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 ->

68+ do b <- guid

69+ return (Map.singleton x [b], Set.empty, VarT b)

70+

71+ App e1 e2 ->

72+ do (a1,c1,t1) <- gen e1

73+ (a2,c2,t2) <- gen e2

74+ b <- beta

75+ return ( unionA a1 a2

76+ , Set.unions [c1,c2

77+ ,Set.singleton . ctx' $ t1 :=: (LambdaT t2 b)]

78+ , b )

79+

80+ Lambda x e ->

81+ do (a,c,t) <- gen e

82+ b <- beta

83+ v <- guid

84+ return ( Map.delete x a

85+ , Set.union c . Set.fromList .

86+ map (\x -> ctx' $ VarT x :=: b) $

87+ Map.findWithDefault [v] x a

88+ , LambdaT b t )

89+

90+ Let defs e ->

91+ do (as,cs,t) <- gen e

92+ (ass, schemes) <- liftM unzip (mapM defScheme defs)

93+ let assumptions = unionsA (as:ass)

94+ getName d = case d of FnDef f _ _ -> f

95+ OpDef op _ _ _ -> op

96+ names = map getName defs

97+ genCs name s = do

98+ v <- guid

99+ let vs = Map.findWithDefault [v] name assumptions

100+ return $ map (\x -> ctx name span $ x :<<: s) vs

101+ cs' <- zipWithM genCs names schemes

102+ return ( foldr Map.delete assumptions names

103+ , Set.union (Set.fromList . concat $ cs') cs

104+ , t )

105+

106+ Case e cases ->

107+ do (as,cs,t) <- gen e

108+ (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases

109+ return ( unionsA $ as:ass

110+ , let cases' = map snd cases

111+ ctxs = zipWith epos cases' (tail cases')

112+ csts = zipWith (:=:) ts (tail ts)

113+ cs' = Set.fromList (zipWith ($) ctxs csts)

114+ in Set.unions $ cs' : cs : css

115+ , head ts)

116+

117+ If e1 e2 e3 ->

118+ do (a1,c1,t1) <- gen e1

119+ (a2,c2,t2) <- gen e2

120+ (a3,c3,t3) <- gen e3

121+ return ( unionsA [a1,a2,a3]

122+ , let c4 = Set.fromList [ ctx e1 span (t1 :=: bool)

123+ , ctx' (t2 :=: t3) ]

124+ in Set.unions [c1,c2,c3,c4]

125+ , t2 )

126+

127+ Data name es ->

128+ gen $ foldl' (\f x -> epos f x $ App f x) (ctx' $ Var name) es

129+

130+ Binop op e1 e2 ->

131+ gen $ ctx' (App (ctx' $ App (ctx' $ Var op) e1) e2)

132+

133+ Access e label ->

134+ do (as,cs,rtype) <- gen e

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+

151+ Range e1@(C w1 s1 _) e2@(C w2 s2 _) ->

152+ do (a1,c1,t1) <- gen e1

153+ (a2,c2,t2) <- gen e2

154+ return ( unionsA [a1,a2]

155+ , Set.unions [ c1, c2, Set.fromList [ C w1 s1 (t1 :=: int)

156+ , C w1 s2 (t2 :=: int) ] ]

157+ , listOf int )

158+

159+ MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps

160+ let cs = Set.fromList (map (ctx' . (t :=:)) ts)

161+ return (unionsA ass, Set.unions (cs:css), t)

162+ where genPair (b@(C t s _),e) = do

163+ (a1,c1,t1) <- gen b

164+ (a2,c2,t2) <- gen e

165+ return ( unionsA [a1,a2]

166+ , Set.unions [ c1, c2

167+ , Set.singleton (C t s (t1 :=: bool)) ]

168+ , t2 )

169+

170+ IntNum _ -> do t <- beta

171+ return (Map.empty, Set.singleton (ctx' $ t :<: number), t)

172+

173+ FloatNum _ -> primitive float

174+ Chr _ -> primitive char

175+ Str _ -> primitive string

176+ Boolean _ -> primitive bool

177+ Markdown _ -> primitive element

150178 -- _ -> beta >>= primitive

151179

180+primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type)

152181primitive t = return (Map.empty, Set.empty, t)

153182

154−caseGen tipe (p,e) = do

155− (as ,cs , t ) <- gen e

183+caseGen :: Type

184+ -> (Pattern, CExpr)

185+ -> GuidCounter (TVarMap, ConstraintSet, Type)

186+caseGen tipe (p, ce@(C _ span e)) = do

187+ (as ,cs , t ) <- gen ce

156188 (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

158190 return ( as', cs'', t )

159191

192+patternGen :: (TVarMap, ConstraintSet, [Type])

193+ -> Pattern

194+ -> GuidCounter (TVarMap, ConstraintSet, [Type])

160195patternGen (as,cs,ts) PAnything = ((,,) as cs . (\t -> ts++[t])) `liftM` beta

161196patternGen (as,cs,ts) (PVar v) = do

162197 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

164199 return ( Map.delete v as, Set.union cs $ Set.fromList cs', ts ++ [b] )

165200patternGen (as,cs,ts) p@(PData name ps) = do

166201 constr <- guid

@@ -169,11 +204,12 @@ patternGen (as,cs,ts) p@(PData name ps) = do

169204 let t = foldr (==>) output ts'

170205 let getC | isTupleString name = do

171206 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

173208 | otherwise = return Set.empty

174209 cs'' <- getC

175210 return ( unionA as' (Map.singleton name [constr])

176− , Set.unions [cs',cs'', Set.singleton . ctx p $ VarT constr :=: t]

211+ , Set.unions [cs',cs''

212+ , Set.singleton . ctx p NoSpan $ VarT constr :=: t ]

177213 , ts ++ [output] )

178214

179215

@@ -181,21 +217,23 @@ defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)

181217defScheme def = do (as,cs,hint) <- defGen def

182218 return ( as, snd hint )

183219

184−defGen def = case def of FnDef f args e -> defGen' f args e

185− OpDef op a1 a2 e -> defGen' op [a1,a2] e

186− where defGen' name args e = do

187− argDict <- mapM (\a -> liftM ((,) a) guid) args

188− (as,cs,t) <- gen e

189− let as' = foldr Map.delete as args

190− tipe = foldr (==>) t $ map (VarT . snd) argDict

191− genCs (arg,x) = do

192− v <- guid

193− let as' = Map.findWithDefault [v] arg as

194− return $ map (\y -> Context arg $ VarT x :=: VarT y) as'

195− cs' <- concat `liftM` mapM genCs argDict

196− scheme <- generalize (concat $ Map.elems as') $

197− Forall (map snd argDict) (cs' ++ Set.toList cs) tipe

198− return ( as', Set.empty, (name, scheme) )

220+defGen def = case def of

221+ FnDef f args e -> defGenHelp f args e

222+ OpDef op a1 a2 e -> defGenHelp op [a1,a2] e

223+

224+defGenHelp name args e = do

225+ argDict <- mapM (\a -> liftM ((,) a) guid) args

226+ (as,cs,t) <- gen e

227+ let as' = foldr Map.delete as args

228+ tipe = foldr (==>) t $ map (VarT . snd) argDict

229+ genCs (arg,x) = do

230+ v <- guid

231+ let as' = Map.findWithDefault [v] arg as

232+ return $ map (\y -> ctx arg NoSpan $ VarT x :=: VarT y) as'

233+ cs' <- concat `liftM` mapM genCs argDict

234+ scheme <- generalize (concat $ Map.elems as') $

235+ Forall (map snd argDict) (cs' ++ Set.toList cs) tipe

236+ return ( as', Set.empty, (name, scheme) )

199237

200238stmtGen (Definition def) = do (as,cs,hint) <- defGen def

201239 return ( as, cs, [hint] )

@@ -210,7 +248,7 @@ stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'

210248 | n == "Comparable" = vc

211249 rnm t = t

212250 tcs' = map (second (map rnm)) tcs

213− supers t = map (Context name) $

251+ supers t = map (ctx name NoSpan) $

214252 zipWith (:<:) [va,vb,vc] [number,appendable t,comparable]

215253 gen' (n,ts) = do t <- beta

216254 let s = Forall (xs ++ [a,b,c]) (supers t) $

@@ -220,13 +258,13 @@ stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'

220258stmtGen (ExportEvent js elm tipe) = do

221259 x <- guid

222260 return ( Map.singleton elm [x]

223− , Set.singleton . ctx (Var elm) $ VarT x :=: tipe

261+ , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe

224262 , [] )

225263

226−stmtGen (ImportEvent js base elm tipe) = do

227− (as,cs,t) <- gen base

264+stmtGen (ImportEvent js e@(C txt span base) elm tipe) = do

265+ (as,cs,t) <- gen e

228266 return ( as

229− , Set.insert (ctx base (signalOf t :=: tipe)) cs

267+ , Set.insert (C txt span (signalOf t :=: tipe)) cs

230268 , [ (elm, Forall [] [] tipe) ] )

231269

232270getDatatypeInfo (Datatype name args tcs) =

elm/src/Types/Hints.hs+11−10

@@ -1,11 +1,12 @@

11module Types.Hints (hints) where

3−import Control.Monad (liftM,mapM)

3+import Context

44import Control.Arrow (first)

5+import Control.Monad (liftM,mapM)

56import Types.Types

67import Types.Substitutions (rescheme)

8−

9+ctx str = C (Just str) NoSpan

910prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs

1011

1112-------- Text and Elements --------

@@ -243,11 +244,11 @@ dates =

243244

244245binop t = t ==> t ==> t

245246scheme1 super t name =

246− (name, Forall [0] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: super

247+ (name, Forall [0] [ ctx name $ VarT 0 :<: super

247248 ] (t (VarT 0)))

248249scheme2 s1 s2 t name =

249− (name, Forall [0,1] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: s1

250− , Context ("`" ++ name ++ "'") $ VarT 1 :<: s2

250+ (name, Forall [0,1] [ ctx name $ VarT 0 :<: s1

251+ , ctx name $ VarT 1 :<: s2

251252 ] (t (VarT 0) (VarT 1)))

252253numScheme t name = scheme1 number t name

253254twoNums f name = scheme2 number number f name

@@ -271,7 +272,7 @@ bools =

271272 hasType (binop bool) ["&&","||"] ++

272273 map (scheme1 comparable (\t -> t ==> t ==> bool)) ["<",">","<=",">="] ++

273274 [ ( "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) )

275276 ]

276277

277278chars = prefix "Char" (classify ++ convert1 ++ convert2)

@@ -297,7 +298,7 @@ funcs =

297298 , "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)

298299 , "$" -:: (a ==> b) ==> a ==> b

299300 , ":" -:: 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

301302 , "Cons" -:: a ==> listOf a ==> listOf a

302303 , "Nil" -:: listOf a

303304 , "Just" -:: a ==> maybeOf a

@@ -332,11 +333,11 @@ lists = prefix "List"

332333 , "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b

333334 , "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b

334335 , "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) ] $

336337 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) ] $

338339 (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) ] $

340341 VarT 0 ==> listOf (VarT 0) ==> VarT 0

341342 , "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c

342343 ] ++ map (numScheme (\n -> listOf n ==> n)) [ "sum", "product"

elm/src/Types/Solver.hs+164−117

@@ -1,6 +1,7 @@

22module Types.Solver (solver) where

4+import Context

45import Control.Arrow (second)

56import Control.Monad (liftM)

67import Data.Either (lefts,rights)

@@ -13,13 +14,13 @@ import Types.Types

1314import Types.Constrain

1415import Types.Substitutions

1516

17+import System.IO.Unsafe

1618

17−eq ctx t1 t2 = Context ctx (t1 :=: t2)

18−

19−isSolved ss (Context _ (t1 :=: t2)) = t1 == t2

20−isSolved ss (Context _ (x :<<: _)) = isJust (lookup x ss)

19+isSolved ss (C _ _ (t1 :=: t2)) = t1 == t2

20+isSolved ss (C _ _ (x :<<: _)) = isJust (lookup x ss)

2121isSolved ss c = False

2222

23+crush :: Scheme -> GuidCounter (Either String Scheme)

2324crush (Forall xs cs t) =

2425 do subs <- solver cs Map.empty

2526 return $ do ss' <- subs

@@ -27,10 +28,10 @@ crush (Forall xs cs t) =

2728 cs' = filter (not . isSolved ss) (subst ss cs)

2829 return $ Forall xs cs' (subst ss t)

2930

30−schemeSubHelp ctx x s t1 rltn t2 = do

31+schemeSubHelp txt span x s t1 rltn t2 = do

3132 (t1',cs1) <- sub t1

3233 (t2',cs2) <- sub t2

33− return (Context ctx (rltn t1' t2') : cs1 ++ cs2)

34+ return (C txt span (rltn t1' t2') : cs1 ++ cs2)

3435 where sub t | not (occurs x t) = return (t, [])

3536 | otherwise = do (st, cs) <- concretize s

3637 return (subst [(x,st)] t, cs)

@@ -40,118 +41,164 @@ schemeSub x s c = do s' <- crush s

4041 Right s'' -> Right `liftM` schemeSub' x s'' c

4142 Left err -> return $ Left err

4243

43−schemeSub' x s (Context ctx (t1 :=: t2)) = schemeSubHelp ctx x s t1 (:=:) t2

44−schemeSub' x s (Context ctx (t1 :<: t2)) = schemeSubHelp ctx x s t1 (:<:) t2

45−schemeSub' x s c@(Context ctx (y :<<: Forall cxs ccs ctipe))

46− | not (occurs x c) = return [c]

47− | otherwise =

48− do Forall xs cs tipe <- rescheme s

49− let ss = [(x,tipe)]

50− constraints = subst ss (cs ++ ccs)

51− c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)

52− return [ Context ctx c' ]

53−

54−

55−solver :: [Context String Constraint]

44+schemeSub' x s c@(C txt span constraint) =

45+ case constraint of

46+ (t1 :=: t2) -> schemeSubHelp txt span x s t1 (:=:) t2

47+ (t1 :<: t2) -> schemeSubHelp txt span x s t1 (:<:) t2

48+ (y :<<: Forall cxs ccs ctipe)

49+ | not (occurs x c) -> return [c]

50+ | otherwise ->

51+ do Forall xs cs tipe <- rescheme s

52+ let ss = [(x,tipe)]

53+ constraints = subst ss (cs ++ ccs)

54+ c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)

55+ return [ C txt span c' ]

56+

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+

84+solver :: [Context Constraint]

5685 -> Map.Map X Type

5786 -> GuidCounter (Either String (Map.Map X Type))

5887solver [] subs = return $ Right subs

59−

60−-------- Destruct Type-constructors --------

61−

62−solver ((Context ctx (t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2))) : cs) subs =

63− if n1 /= n2 then uniError ctx t1 t2 else

64− solver (zipWith (eq ctx) ts1 ts2 ++ cs) subs

65−solver ((Context ctx (LambdaT t1 t2 :=: LambdaT t1' t2')) : cs) subs =

66− solver ([ eq ctx t1 t1', eq ctx t2 t2' ] ++ cs) subs

67−

68−-------- Type-equality --------

69−

70−solver (Context ctx (VarT x :=: VarT y) : cs) subs

71− | x == y = solver cs subs

72− | otherwise =

73− case (Map.lookup x subs, Map.lookup y subs) of

74− (Just (Super xts), Just (Super yts)) ->

75− let ts = Set.intersection xts yts

76− setXY t = Map.insert x t . Map.insert y t

77− in case Set.toList ts of

78− [] -> unionError ctx xts yts

79− [t] -> let cs1 = subst [(x,t),(y,t)] cs in

80− cs1 `seq` solver cs1 (setXY t subs)

81− _ -> solver cs $ setXY (Super ts) subs

82− (Just (Super xts), _) ->

83− let cs2 = subst [(y,VarT x)] cs in

84− solver cs2 $ Map.insert y (VarT x) subs

85− (_, _) ->

86− let cs3 = subst [(x,VarT y)] cs in

87− solver cs3 $ Map.insert x (VarT y) subs

88−solver (Context ctx (VarT x :=: t) : cs) subs = do

89− if x `occurs` t then occursError ctx (VarT x) t else

90− (case Map.lookup x subs of

91− Nothing -> let cs4 = subst [(x,t)] cs in

92− solver cs4 . Map.map (subst [(x,t)]) $ Map.insert x t subs

93− Just (Super ts) ->

94− let ts' = Set.intersection ts (Set.singleton t) in

95− case Set.toList ts' of

96− [] -> solver (Context ctx (t :<: Super ts) : cs) subs

97− [t'] -> let cs5 = subst [(x,t)] cs in

98− solver cs5 $ Map.insert x t' subs

99− _ -> solver cs $ Map.insert x (Super ts') subs

100− Just t' -> solver (Context ctx (t' :=: t) : cs) subs

101− )

102−solver ((Context ctx (t :=: VarT x)) : cs) subs =

103− solver ((Context ctx (VarT x :=: t)) : cs) subs

104−solver ((Context ctx (t1 :=: t2)) : cs) subs

105− | t1 == t2 = solver cs subs

106− | otherwise = uniError ctx t1 t2

107−

108−

109−-------- subtypes --------

110−

111−solver (Context ctx (VarT x :<: Super ts) : cs) subs =

112− case Map.lookup x subs of

113− Nothing -> solver cs $ Map.insert x (Super ts) subs

114− Just (Super ts') ->

115− case Set.toList $ Set.intersection ts ts' of

116− [] -> unionError ctx ts ts'

117− [t] -> solver (subst [(x,t)] cs) $ Map.insert x t subs

118− ts'' -> solver cs $ Map.insert x (Super $ Set.fromList ts'') subs

119−

120−solver (Context ctx (ADT "List" [t] :<: Super ts) : cs) subs

121− | any f (Set.toList ts) = solver cs subs

122− | otherwise = subtypeError ctx (ADT "List" [t]) (Super ts)

123− where f (ADT "List" [VarT _]) = True

124− f (ADT "List" [t']) = t == t'

125− f _ = False

126−

127−solver (Context ctx (t :<: Super ts) : cs) subs

128− | Set.member t ts = solver cs subs

129− | otherwise = subtypeError ctx t (Super ts)

130−

131−solver (Context ctx (x :<<: s) : cs) subs

132− | any (occurs x) cs =

133− do css <- mapM (schemeSub x s) cs

134− case lefts css of

135− err : _ -> return $ Left err

136− [] -> solver (concat (rights css)) subs

137− | otherwise =

138− do (t,cs7) <- concretize s

139− let cs'' = (cs ++ Context ctx (VarT x :=: t) : map (extendCtx ctx) cs7)

140− solver cs'' subs

141−

142−occursError ctx t1 t2 =

143− return . Left $ "Type error: Occurs check: cannot construct the infinite type: " ++ show t1 ++

144− " = " ++ show t2 ++

145− " in context " ++ ctx

146−uniError ctx t1 t2 =

147− return . Left $ "Type error: " ++ show t1 ++

148− " is not equal to " ++ show t2 ++

149− " in context " ++ ctx

150−unionError ctx ts ts' =

151− return . Left $ concat [ "Type error: There are no types in both "

152− , show (Super ts), " and ", show (Super ts')

153− , " in context ", ctx ]

154−subtypeError ctx t s =

155− return . Left $ concat [ "Type error: ", show t, " is not a ", show s

156− , " in context ", ctx ]

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

92+ -- Destruct Type-constructors

93+ t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->

94+ if n1 /= n2 then uniError txt span t1 t2 else

95+ solver (zipWith eq ts1 ts2 ++ cs) subs

96+

97+ LambdaT t1 t2 :=: LambdaT t1' t2' ->

98+ solver ([ eq t1 t1', eq t2 t2' ] ++ cs) subs

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+

105+ -- Type-equality

106+ VarT x :=: VarT y

107+ | x == y -> solver cs subs

108+ | otherwise ->

109+ case (Map.lookup x subs, Map.lookup y subs) of

110+ (Just (Super xts), Just (Super yts)) ->

111+ let ts = Set.intersection xts yts

112+ setXY t = Map.insert x t . Map.insert y t

113+ in case Set.toList ts of

114+ [] -> unionError txt span xts yts

115+ [t] -> let cs1 = subst [(x,t),(y,t)] cs in

116+ cs1 `seq` solver cs1 (setXY t subs)

117+ _ -> solver cs $ setXY (Super ts) subs

118+ (Just (Super xts), _) ->

119+ let cs2 = subst [(y,VarT x)] cs in

120+ solver cs2 $ Map.insert y (VarT x) subs

121+ (_, _) ->

122+ let cs3 = subst [(x,VarT y)] cs in

123+ solver cs3 $ Map.insert x (VarT y) subs

124+

125+ VarT x :=: t -> do

126+ if x `occurs` t then occursError txt span (VarT x) t else

127+ (case Map.lookup x subs of

128+ Nothing -> let cs4 = subst [(x,t)] cs in

129+ solver cs4 . Map.map (subst [(x,t)]) $

130+ Map.insert x t subs

131+ Just (Super ts) ->

132+ let ts' = Set.intersection ts (Set.singleton t) in

133+ case Set.toList ts' of

134+ [] -> solver (ctx (t :<: Super ts) : cs) subs

135+ [t'] -> let cs5 = subst [(x,t)] cs in

136+ solver cs5 $ Map.insert x t' subs

137+ _ -> solver cs $ Map.insert x (Super ts') subs

138+ Just t' -> solver (ctx (t' :=: t) : cs) subs

139+ )

140+

141+ t :=: VarT x -> solver ((ctx (VarT x :=: t)) : cs) subs

142+

143+ t1 :=: t2 | t1 == t2 -> solver cs subs

144+ | otherwise -> uniError txt span t1 t2

145+

146+ -- subtypes

147+ VarT x :<: Super ts ->

148+ case Map.lookup x subs of

149+ Nothing -> solver cs $ Map.insert x (Super ts) subs

150+ Just (Super ts') ->

151+ case Set.toList $ Set.intersection ts ts' of

152+ [] -> unionError txt span ts ts'

153+ [t] -> solver (subst [(x,t)] cs) $ Map.insert x t subs

154+ ts'' -> solver cs $

155+ Map.insert x (Super $ Set.fromList ts'') subs

156+

157+ ADT "List" [t] :<: Super ts

158+ | any f (Set.toList ts) -> solver cs subs

159+ | otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)

160+ where f (ADT "List" [VarT _]) = True

161+ f (ADT "List" [t']) = t == t'

162+ f _ = False

163+

164+ t :<: Super ts

165+ | Set.member t ts -> solver cs subs

166+ | otherwise -> subtypeError txt span t (Super ts)

167+

168+ x :<<: s

169+ | any (occurs x) cs ->

170+ do css <- mapM (schemeSub x s) cs

171+ case lefts css of

172+ err : _ -> return $ Left err

173+ [] -> solver (concat (rights css)) subs

174+ | otherwise ->

175+ do (t,cs7) <- concretize s

176+ let cs'' = (cs ++ ctx (VarT x :=: t) : cs7)

177+ solver cs'' subs

178+

179+showMsg msg = case msg of

180+ Just str -> "\nIn context: " ++ str

181+ Nothing -> ""

182+

183+occursError msg span t1 t2 =

184+ return . Left $ concat

185+ [ "Type error (" ++ show span ++ "):\n"

186+ , "Occurs check: cannot construct the infinite type:\n"

187+ , show t1, " = ", show t2, showMsg msg ]

188+

189+uniError msg span t1 t2 =

190+ return . Left $ concat

191+ [ "Type error (" ++ show span ++ "):\n"

192+ , show t1, " is not equal to ", show t2, showMsg msg ]

193+

194+unionError msg span ts ts' =

195+ return . Left $ concat

196+ [ "Type error (" ++ show span ++ "):\n"

197+ , "There are no types in both "

198+ , show (Super ts), " and ", show (Super ts'), showMsg msg ]

199+

200+subtypeError msg span t s =

201+ return . Left $ concat

202+ [ "Type error (" ++ show span ++ "):\n"

203+ , show t, " is not a ", show s, showMsg msg ]

157204

elm/src/Types/Substitutions.hs+30−15

@@ -5,25 +5,30 @@ module Types.Substitutions (subst

55 ,rescheme

66 ,generalize) where

8+import Context

89import Control.DeepSeq (NFData (..), deepseq)

910import Control.Monad (liftM)

1011import Data.List (foldl')

1112import qualified Data.Set as Set

13+import qualified Data.Map as Map

1214import Guid

1315import Types.Types

1416

15−

1617class Subst a where

1718 subst :: [(X,Type)] -> a -> a

1819

1920instance Subst Type where

20− subst ss (VarT x) = case lookup x ss of

21− Nothing -> VarT x

22− Just (Super _) -> VarT x

23− Just t -> t

24− subst ss (LambdaT t1 t2) = LambdaT (subst ss t1) (subst ss t2)

25− subst ss (ADT name ts) = ADT name (subst ss ts)

26− subst ss (Super ts) = Super ts

21+ subst ss t =

22+ case t of

23+ VarT x -> case lookup x ss of

24+ Nothing -> VarT x

25+ Just (Super _) -> VarT x

26+ Just t -> t

27+ LambdaT t1 t2 -> LambdaT (subst ss t1) (subst ss t2)

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

31+ Super ts -> Super ts

2732

2833instance Subst Scheme where

2934 subst ss (Forall vs cs t) = Forall vs (subst ss cs) (subst ss t)

@@ -33,8 +38,8 @@ instance Subst Constraint where

3338 subst ss (t :<: super) = subst ss t :<: super

3439 subst ss (x :<<: poly) = x :<<: subst ss poly

3540

36−instance Subst a => Subst (Context c a) where

37− subst ss (Context ctx c) = Context ctx (subst ss c)

41+instance Subst a => Subst (Context a) where

42+ subst ss (C str span c) = C str span (subst ss c)

3843

3944instance Subst a => Subst [a] where

4045 subst ss as = map (subst ss) as

@@ -47,6 +52,9 @@ instance FreeVars Type where

4752 freeVars (VarT v) = [v]

4853 freeVars (LambdaT t1 t2) = freeVars t1 ++ freeVars t2

4954 freeVars (ADT _ ts) = concatMap freeVars ts

55+ freeVars (RecordT fs t) =

56+ freeVars (concat $ Map.elems fs) ++ freeVars t

57+ freeVars EmptyRecord = []

5058 freeVars (Super _ ) = []

5159

5260instance FreeVars Constraint where

@@ -55,9 +63,11 @@ instance FreeVars Constraint where

5563 freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees

5664 where frees = concatMap freeVars cs ++ freeVars t

5765

58−instance FreeVars a => FreeVars (Context c a) where

59− freeVars (Context _ c) = freeVars c

66+instance FreeVars a => FreeVars (Context a) where

67+ freeVars (C _ _ c) = freeVars c

6068

69+instance FreeVars a => FreeVars [a] where

70+ freeVars = concatMap freeVars

6171

6272class Occurs a where

6373 occurs :: X -> a -> Bool

@@ -66,6 +76,8 @@ instance Occurs Type where

6676 occurs v (VarT x) = v == x

6777 occurs v (LambdaT t1 t2) = occurs v t1 || occurs v t2

6878 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

6981 occurs v (Super _ ) = False

7082

7183instance Occurs Constraint where

@@ -74,10 +86,13 @@ instance Occurs Constraint where

7486 occurs x (y :<<: Forall xs cs t) = x == y || occurs x t || inCs

7587 where inCs = x `notElem` xs && any (occurs x) cs

7688

77−instance Occurs a => Occurs (Context c a) where

78− occurs x (Context _ c) = occurs x c

89+instance Occurs a => Occurs (Context a) where

90+ occurs x (C _ _ c) = occurs x c

91+

92+instance Occurs a => Occurs [a] where

93+ occurs v = any (occurs v)

7994

80−concretize :: Scheme -> GuidCounter (Type, [Context String Constraint])

95+concretize :: Scheme -> GuidCounter (Type, [Context Constraint])

8196concretize (Forall xs cs t) = do

8297 ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs

8398 return (subst ss t, subst ss cs)

elm/src/Types/Types.hs+21−14

@@ -1,34 +1,29 @@

22module Types.Types where

4+import Context

45import Data.Char (isDigit)

56import Data.List (intercalate,isPrefixOf)

67import qualified Data.Set as Set

8+import qualified Data.Map as Map

810type X = Int

911

1012data Type = LambdaT Type Type

1113 | VarT X

1214 | ADT String [Type]

15+ | EmptyRecord

16+ | RecordT (Map.Map String [Type]) Type

1317 | Super (Set.Set Type)

1418 deriving (Eq, Ord)

1519

16−data Scheme = Forall [X] [Context String Constraint] Type deriving (Eq, Ord)

20+data Scheme = Forall [X] [Context Constraint] Type deriving (Eq, Ord)

1721

1822data Constraint = Type :=: Type

1923 | Type :<: Type

2024 | X :<<: Scheme

2125 deriving (Eq, Ord, Show)

2226

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−

3227tipe t = ADT t []

3328

3429

@@ -95,13 +90,25 @@ instance Show Type where

9590 ; ADT name cs ->

9691 if isTupleString name

9792 then parens . intercalate "," $ map show cs

98− else case cs of [] -> name

99− _ -> parens $ name ++ " " ++ unwords (map show cs)

93+ else case cs of

94+ [] -> name

95+ _ -> parens $ name ++ " " ++ unwords (map show cs)

10096 ; 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 ++ " | "

101105 }

102106

103107instance Show Scheme where

104− show (Forall xs cs t) = "Forall " ++ show xs ++ cs' ++ "\n " ++ show t

105− where cs' = concatMap (concatMap ("\n "++) . lines . show) cs

108+ show (Forall [] [] t) = show t

109+ show (Forall xs cs t) =

110+ concat [ "Forall ", show xs

111+ , concatMap (("\n "++) . show) cs

112+ , "\n ", parens (show t) ]

106113

107114isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)

elm/src/Types/Unify.hs+8−1

@@ -8,11 +8,18 @@ import Guid

88import Types.Constrain

99import Types.Solver

1010

11+import System.IO.Unsafe

12+

13+prints xs v =

14+ unsafePerformIO (putStrLn "~~~~~~~~~~" >> mapM print xs) `seq` v

15+

1116unify hints modul = run $ do

1217 constraints <- constrain hints modul

1318 case constraints of

1419 Left msg -> return (Left msg)

1520 Right (escapees, cs) ->

21+ prints cs $

1622 do subs <- solver cs Map.empty

17− return ((,) escapees `liftM` subs)

23+ return $ do ss <- subs

24+ prints (Map.toList ss) $ return (escapees, ss)

1825