git.iko.soy/elk
on master help sign in
Merge branch 'machine-errors'
dc0d221Evan Czaplicki
elm-compiler.cabal+1
compare with master
unifiedsplit
@@ -98,6 +98,7 @@ Library
98 Type.Environment,
98 Type.Environment,
99 Type.ExtraChecks,
99 Type.ExtraChecks,
100 Type.Fragment,
100 Type.Fragment,
101+ Type.Hint,
101 Type.Inference,
102 Type.Inference,
102 Type.PrettyPrint,
103 Type.PrettyPrint,
103 Type.Solve,
104 Type.Solve,
src/AST/Annotation.hs+62−24
@@ -4,59 +4,97 @@ import qualified Text.Parsec.Pos as Parsec
4import qualified Text.PrettyPrint as P
4import qualified Text.PrettyPrint as P
5import AST.PrettyPrint
5import AST.PrettyPrint
6
6
7+
7−data Annotated annotation expr = A annotation expr
8+data Annotated annotation expr
9+ = A annotation expr
8 deriving (Show)
10 deriving (Show)
9
11
12+
10data Region
13data Region
11 = Span Position Position P.Doc
14 = Span Position Position P.Doc
12 | None P.Doc
15 | None P.Doc
13 deriving (Show)
16 deriving (Show)
14
17
18+
15data Position = Position
19data Position = Position
16 { line :: Int
20 { line :: Int
17 , column :: Int
21 , column :: Int
22+ }
18− } deriving (Show)
23+ deriving (Show)
24+
25+
26+type Located expr =
27+ Annotated Region expr
19
28
20−type Located expr = Annotated Region expr
21
29
30+none :: (Pretty expr) => expr -> Located expr
31+none e =
22−none e = A (None (pretty e)) e
32+ A (None (pretty e)) e
23−noneNoDocs e = A (None P.empty) e
24
33
34+
35+noneNoDocs :: a -> Located a
36+noneNoDocs e =
37+ A (None P.empty) e
38+
39+
40+at :: (Pretty expr)
25−at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr
41+ => Parsec.SourcePos
42+ -> Parsec.SourcePos
43+ -> expr
26− -> Annotated Region expr
44+ -> Annotated Region expr
27at start end e =
45at start end e =
28 A (Span (position start) (position end) (pretty e)) e
46 A (Span (position start) (position end) (pretty e)) e
29− where
47+ where
48+ position loc =
30− position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
49+ Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
31
50
51+
52+merge :: (Pretty expr) => Located a -> Located b -> expr -> Located expr
32merge (A s1 _) (A s2 _) e =
53merge (A s1 _) (A s2 _) e =
33 A (span (pretty e)) e
54 A (span (pretty e)) e
34− where
55+ where
56+ span =
35− span = case (s1,s2) of
57+ case (s1,s2) of
36− (Span start _ _, Span _ end _) -> Span start end
58+ (Span start _ _, Span _ end _) ->
59+ Span start end
60+
37− (Span start end _, _) -> Span start end
61+ (Span start end _, _) ->
38− (_, Span start end _) -> Span start end
62+ Span start end
39− (_, _) -> None
40
63
64+ (_, Span start end _) ->
65+ Span start end
66+
67+ (_, _) -> None
68+
69+
70+mergeOldDocs :: Located a -> Located b -> c -> Located c
41mergeOldDocs (A s1 _) (A s2 _) e =
71mergeOldDocs (A s1 _) (A s2 _) e =
42 A span e
72 A span e
43− where
73+ where
74+ span =
44− span = case (s1,s2) of
75+ case (s1,s2) of
45− (Span start _ d1, Span _ end d2) ->
76+ (Span start _ d1, Span _ end d2) ->
46− Span start end (P.vcat [d1, P.text "\n", d2])
77+ Span start end (P.vcat [d1, P.text "\n", d2])
78+
79+ (Span _ _ _, _) -> s1
80+
81+ (_, Span _ _ _) -> s2
82+
83+ (_, _) -> None P.empty
47
84
48− (Span _ _ _, _) -> s1
49− (_, Span _ _ _) -> s2
50− (_, _) -> None P.empty
51
85
52sameAs :: Annotated a expr -> expr' -> Annotated a expr'
86sameAs :: Annotated a expr -> expr' -> Annotated a expr'
53−sameAs (A annotation _) expr = A annotation expr
87+sameAs (A annotation _) expr =
88+ A annotation expr
89+
54
90
91+getRegionDocs :: Region -> P.Doc
55getRegionDocs region =
92getRegionDocs region =
56 case region of
93 case region of
57 Span _ _ doc -> doc
94 Span _ _ doc -> doc
58 None doc -> doc
95 None doc -> doc
59
96
97+
60instance Pretty Region where
98instance Pretty Region where
61 pretty span =
99 pretty span =
62 case span of
100 case span of
@@ -68,6 +106,6 @@ instance Pretty Region where
68 True -> "on line " ++ show (line end) ++ ", column " ++
106 True -> "on line " ++ show (line end) ++ ", column " ++
69 show (column start) ++ " to " ++ show (column end)
107 show (column start) ++ " to " ++ show (column end)
70
108
109+
71instance Pretty e => Pretty (Annotated a e) where
110instance Pretty e => Pretty (Annotated a e) where
72 pretty (A _ e) = pretty e
111 pretty (A _ e) = pretty e
73−
src/AST/PrettyPrint.hs+4
@@ -38,5 +38,9 @@ eightyCharLines indent message = answer
38 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
38 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
39 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
39 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
40
40
41+instance Error Doc where
42+ noMsg = P.empty
43+ strMsg = P.text
44+
41instance ErrorList Doc where
45instance ErrorList Doc where
42 listMsg str = [ P.text str ]
46 listMsg str = [ P.text str ]
src/Parse/Declaration.hs+33−23
@@ -21,29 +21,32 @@ definition = D.Definition <$> Expr.def
21
21
22typeDecl :: IParser D.SourceDecl
22typeDecl :: IParser D.SourceDecl
23typeDecl =
23typeDecl =
24− do reserved "type" <?> "type declaration"
24+ do try (reserved "type") <?> "type declaration"
25− forcedWS
25+ forcedWS
26− isAlias <- optionMaybe (string "alias" >> forcedWS)
26+ isAlias <- optionMaybe (string "alias" >> forcedWS)
27
27
28− name <- capVar
28+ name <- capVar
29− args <- spacePrefix lowVar
29+ args <- spacePrefix lowVar
30− padded equals
30+ padded equals
31
31
32− case isAlias of
32+ case isAlias of
33− Just _ ->
33+ Just _ ->
34− do tipe <- Type.expr <?> "a type"
34+ do tipe <- Type.expr <?> "a type"
35− return (D.TypeAlias name args tipe)
35+ return (D.TypeAlias name args tipe)
36
36
37− Nothing ->
37+ Nothing ->
38− do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"
38+ do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"
39− return $ D.Datatype name args tcs
39+ return $ D.Datatype name args tcs
40
40
41
41
42infixDecl :: IParser D.SourceDecl
42infixDecl :: IParser D.SourceDecl
43infixDecl = do
43infixDecl = do
44+ assoc <-
45+ choice
44− assoc <- choice [ reserved "infixl" >> return D.L
46+ [ try (reserved "infixl") >> return D.L
45− , reserved "infix" >> return D.N
46− , reserved "infixr" >> return D.R ]
47+ , try (reserved "infixr") >> return D.R
48+ , try (reserved "infix") >> return D.N
49+ ]
47 forcedWS
50 forcedWS
48 n <- digit
51 n <- digit
49 forcedWS
52 forcedWS
@@ -52,10 +55,17 @@ infixDecl = do
52
55
53port :: IParser D.SourceDecl
56port :: IParser D.SourceDecl
54port =
57port =
55− do try (reserved "port")
58+ do try (reserved "port")
56− whitespace
59+ whitespace
57− name <- lowVar
60+ name <- lowVar
58− whitespace
61+ whitespace
59− let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }
62+ let port' op ctor expr =
63+ do try op
64+ whitespace
65+ ctor name <$> expr
66+
67+ D.Port <$>
68+ choice
60− D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr
69+ [ port' hasType D.PPAnnotation Type.expr
61− , port' equals D.PPDef Expr.expr ]
70+ , port' equals D.PPDef Expr.expr
71+ ]
src/Parse/Expression.hs+72−40
@@ -139,56 +139,87 @@ appExpr = do
139-------- Normal Expressions --------
139-------- Normal Expressions --------
140
140
141binaryExpr :: IParser Source.Expr
141binaryExpr :: IParser Source.Expr
142+binaryExpr =
142−binaryExpr = Binop.binops appExpr lastExpr anyOp
143+ Binop.binops appExpr lastExpr anyOp
144+ where
143− where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
145+ lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
144− <|> lambdaExpr
146+ <|> lambdaExpr
147+
145
148
146ifExpr :: IParser Source.Expr'
149ifExpr :: IParser Source.Expr'
150+ifExpr =
151+ do try (reserved "if")
152+ whitespace
147−ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
153+ normal <|> multiIf
148− where
154+ where
149− normal = do
155+ normal = do
150− bool <- expr
156+ bool <- expr
151− padded (reserved "then")
157+ padded (reserved "then")
152− thenBranch <- expr
158+ thenBranch <- expr
159+ whitespace <?> "an 'else' branch"
153− whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
160+ reserved "else" <?> "an 'else' branch"
161+ whitespace
154− elseBranch <- expr
162+ elseBranch <- expr
155− return $ E.MultiIf
163+ return $ E.MultiIf
156− [ (bool, thenBranch)
164+ [ (bool, thenBranch)
157− , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
165+ , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
158− ]
166+ ]
159−
167+
168+ multiIf =
160− multiIf = E.MultiIf <$> spaceSep1 iff
169+ E.MultiIf <$> spaceSep1 iff
170+ where
171+ iff =
161− where iff = do string "|" ; whitespace
172+ do string "|" ; whitespace
162− b <- expr ; padded arrow
173+ b <- expr ; padded arrow
163− (,) b <$> expr
174+ (,) b <$> expr
175+
164
176
165lambdaExpr :: IParser Source.Expr
177lambdaExpr :: IParser Source.Expr
178+lambdaExpr =
166−lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
179+ do char '\\' <|> char '\x03BB' <?> "anonymous function"
167− whitespace
180+ whitespace
168− args <- spaceSep1 Pattern.term
181+ args <- spaceSep1 Pattern.term
169− padded arrow
182+ padded arrow
170− body <- expr
183+ body <- expr
171− return (makeFunction args body)
184+ return (makeFunction args body)
185+
172
186
173defSet :: IParser [Source.Def]
187defSet :: IParser [Source.Def]
188+defSet =
189+ block $
190+ do d <- def
174−defSet = block (do d <- def ; whitespace ; return d)
191+ whitespace
192+ return d
193+
175
194
176letExpr :: IParser Source.Expr'
195letExpr :: IParser Source.Expr'
177−letExpr = do
196+letExpr =
197+ do try (reserved "let")
178− reserved "let" ; whitespace
198+ whitespace
179− defs <- defSet
199+ defs <- defSet
180− padded (reserved "in")
200+ padded (reserved "in")
181− E.Let defs <$> expr
201+ E.Let defs <$> expr
202+
182
203
183caseExpr :: IParser Source.Expr'
204caseExpr :: IParser Source.Expr'
184−caseExpr = do
205+caseExpr =
185− reserved "case"; e <- padded expr; reserved "of"; whitespace
206+ do try (reserved "case")
207+ e <- padded expr
208+ reserved "of"
209+ whitespace
186− E.Case e <$> (with <|> without)
210+ E.Case e <$> (with <|> without)
211+ where
212+ case_ =
187− where case_ = do p <- Pattern.expr
213+ do p <- Pattern.expr
188− padded arrow
214+ padded arrow
189− (,) p <$> expr
215+ (,) p <$> expr
216+
217+ with =
190− with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
218+ brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
219+
220+ without =
191− without = block (do c <- case_ ; whitespace ; return c)
221+ block (do c <- case_ ; whitespace ; return c)
222+
192
223
193expr :: IParser Source.Expr
224expr :: IParser Source.Expr
194expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
225expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
@@ -196,6 +227,7 @@ expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
196 <|> binaryExpr
227 <|> binaryExpr
197 <?> "an expression"
228 <?> "an expression"
198
229
230+
199defStart :: IParser [P.RawPattern]
231defStart :: IParser [P.RawPattern]
200defStart =
232defStart =
201 choice [ do p1 <- try Pattern.term
233 choice [ do p1 <- try Pattern.term
src/Parse/Helpers.hs+4−3
@@ -95,8 +95,10 @@ makeVar p =
95
95
96reserved :: String -> IParser String
96reserved :: String -> IParser String
97reserved word =
97reserved word =
98+ expecting ("reserved word '" ++ word ++ "'") $
99+ do string word
98− (try (string word >> notFollowedBy innerVarChar) >> return word)
100+ notFollowedBy innerVarChar
99− <?> "reserved word '" ++ word ++ "'"
101+ return word
100
102
101
103
102-- INFIX OPERATORS
104-- INFIX OPERATORS
@@ -114,7 +116,6 @@ symOp =
114 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
116 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
115 case op of
117 case op of
116 "." -> notFollowedBy lower >> return op
118 "." -> notFollowedBy lower >> return op
117− "\8728" -> return "."
118 _ -> return op
119 _ -> return op
119
120
120
121
src/Parse/Module.hs+57−49
@@ -8,49 +8,51 @@ import Parse.Helpers
8import qualified AST.Module as Module
8import qualified AST.Module as Module
9import qualified AST.Variable as Var
9import qualified AST.Variable as Var
10
10
11+
11getModuleName :: String -> Maybe String
12getModuleName :: String -> Maybe String
12getModuleName source =
13getModuleName source =
13− case iParse getModuleName source of
14+ case iParse getModuleName source of
14− Right name -> Just name
15+ Right name -> Just name
15− Left _ -> Nothing
16+ Left _ -> Nothing
16− where
17+ where
17− getModuleName = do
18+ getModuleName =
18− optional freshLine
19+ do optional freshLine
19− (names, _) <- header
20+ (names, _) <- header
20− return (intercalate "." names)
21+ return (intercalate "." names)
22+
21
23
22headerAndImports :: IParser Module.HeaderAndImports
24headerAndImports :: IParser Module.HeaderAndImports
23headerAndImports =
25headerAndImports =
24− do optional freshLine
26+ do optional freshLine
25− (names, exports) <-
27+ (names, exports) <-
26− option (["Main"], Var.openListing) (header `followedBy` freshLine)
28+ option (["Main"], Var.openListing) (header `followedBy` freshLine)
27− imports' <- commitToImports <|> return []
29+ imports' <- imports
28− return $ Module.HeaderAndImports names exports imports'
30+ return $ Module.HeaderAndImports names exports imports'
29− where
31+
30− commitToImports =
31− do try (lookAhead $ reserved "import")
32− imports `followedBy` freshLine
33
32
34header :: IParser ([String], Var.Listing Var.Value)
33header :: IParser ([String], Var.Listing Var.Value)
35−header = do
34+header =
36− try (reserved "module")
35+ do try (reserved "module")
37− whitespace
36+ whitespace
38− names <- dotSep1 capVar <?> "name of module"
37+ names <- dotSep1 capVar <?> "name of module"
39− whitespace
38+ whitespace
40− exports <- option Var.openListing (listing value)
39+ exports <- option Var.openListing (listing value)
41− whitespace <?> "reserved word 'where'"
40+ whitespace <?> "reserved word 'where'"
42− reserved "where"
41+ reserved "where"
43− return (names, exports)
42+ return (names, exports)
43+
44
44
45imports :: IParser [(Module.Name, Module.ImportMethod)]
45imports :: IParser [(Module.Name, Module.ImportMethod)]
46−imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
46+imports =
47+ many (import' `followedBy` freshLine)
48+
47
49
48import' :: IParser (Module.Name, Module.ImportMethod)
50import' :: IParser (Module.Name, Module.ImportMethod)
49import' =
51import' =
50− do reserved "import"
52+ do try (reserved "import")
51− whitespace
53+ whitespace
52− names <- dotSep1 capVar
54+ names <- dotSep1 capVar
53− (,) names <$> option (Module.As (intercalate "." names)) method
55+ (,) names <$> option (Module.As (intercalate "." names)) method
54 where
56 where
55 method :: IParser Module.ImportMethod
57 method :: IParser Module.ImportMethod
56 method = as' <|> importing'
58 method = as' <|> importing'
@@ -64,25 +66,31 @@ import' =
64 importing' :: IParser Module.ImportMethod
66 importing' :: IParser Module.ImportMethod
65 importing' = Module.Open <$> listing value
67 importing' = Module.Open <$> listing value
66
68
69+
67listing :: IParser a -> IParser (Var.Listing a)
70listing :: IParser a -> IParser (Var.Listing a)
68listing item =
71listing item =
69− do try (whitespace >> char '(')
72+ do try (whitespace >> char '(')
70− whitespace
73+ whitespace
74+ listing <-
75+ choice
71− listing <- choice [ const Var.openListing <$> string ".."
76+ [ const Var.openListing <$> string ".."
72− , Var.Listing <$> commaSep1 item <*> return False
77+ , Var.Listing <$> commaSep1 item <*> return False
73− ] <?> "listing of values (x,y,z)"
78+ ] <?> "listing of values (x,y,z)"
74− whitespace
79+ whitespace
75− char ')'
80+ char ')'
76− return listing
81+ return listing
82+
77
83
78value :: IParser Var.Value
84value :: IParser Var.Value
85+value =
79−value = val <|> tipe
86+ val <|> tipe
80− where
87+ where
88+ val =
81− val = Var.Value <$> (lowVar <|> parens symOp)
89+ Var.Value <$> (lowVar <|> parens symOp)
82−
90+
83− tipe = do
91+ tipe =
84− name <- capVar
92+ do name <- capVar
85− maybeCtors <- optionMaybe (listing capVar)
93+ maybeCtors <- optionMaybe (listing capVar)
86− case maybeCtors of
94+ case maybeCtors of
87− Nothing -> return (Var.Alias name)
95+ Nothing -> return (Var.Alias name)
88− Just ctors -> return (Var.Union name ctors)
96+ Just ctors -> return (Var.Union name ctors)
src/Parse/Parse.hs+49−34
@@ -14,51 +14,66 @@ import qualified Parse.Module as Module
14import qualified Parse.Declaration as Decl
14import qualified Parse.Declaration as Decl
15import Transform.Declaration (combineAnnotations)
15import Transform.Declaration (combineAnnotations)
16
16
17−freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
18− freshLine
19− Decl.declaration <?> "another datatype or variable definition"
20
17
18+freshDef =
19+ commitIf (freshLine >> (letter <|> char '_')) $
20+ do freshLine
21+ Decl.declaration <?> "another datatype or variable definition"
22+
23+
24+decls =
21−decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"
25+ do d <- Decl.declaration <?> "at least one datatype or variable definition"
22− (d:) <$> many freshDef
26+ (d:) <$> many freshDef
27+
23
28
24program :: OpTable -> String -> Either [P.Doc] M.ValidModule
29program :: OpTable -> String -> Either [P.Doc] M.ValidModule
25program table src =
30program table src =
26− do (M.Module names filePath exs ims sourceDecls) <-
31+ do (M.Module names filePath exs ims sourceDecls) <-
27− setupParserWithTable table programParser src
32+ setupParserWithTable table programParser src
33+
34+ decls <-
35+ either (\err -> Left [P.text err]) Right (combineAnnotations sourceDecls)
36+
37+ return $ M.Module names filePath exs ims decls
28
38
29− decls <-
30− either (\err -> Left [P.text err]) Right (combineAnnotations sourceDecls)
31− return $ M.Module names filePath exs ims decls
32
39
33programParser :: IParser M.SourceModule
40programParser :: IParser M.SourceModule
34programParser =
41programParser =
35− do (M.HeaderAndImports names exports imports) <- Module.headerAndImports
42+ do (M.HeaderAndImports names exports imports) <- Module.headerAndImports
36− declarations <- decls
43+ declarations <- decls
37− optional freshLine ; optional spaces ; eof
44+ optional freshLine ; optional spaces ; eof
38− return $ M.Module names "" exports imports declarations
45+ return $ M.Module names "" exports imports declarations
46+
39
47
40setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a
48setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a
41setupParserWithTable table p source =
49setupParserWithTable table p source =
42− do localTable <- setupParser parseFixities source
50+ do localTable <- setupParser parseFixities source
43− case Map.intersection table localTable of
51+ case Map.intersection table localTable of
44− overlap | not (Map.null overlap) -> Left [ msg overlap ]
52+ overlap | not (Map.null overlap) -> Left [ msg overlap ]
45− | otherwise ->
53+ | otherwise ->
46− flip setupParser source $ do
54+ flip setupParser source $
47− putState (Map.union table localTable)
55+ do putState (Map.union table localTable)
48− p
56+ p
49− where
57+ where
50− msg overlap =
58+ msg overlap =
59+ P.vcat
51− P.vcat [ P.text "Parse error:"
60+ [ P.text "Parse error:"
61+ , P.text $
52− , P.text $ "Overlapping definitions for infix operators: " ++
62+ "Overlapping definitions for infix operators: "
53− List.intercalate " " (Map.keys overlap)
63+ ++ List.intercalate " " (Map.keys overlap)
54− ]
64+ ]
55−
65+
66+
56−parseFixities = do
67+parseFixities =
57− decls <- onFreshLines (:) [] infixDecl
68+ do decls <- onFreshLines (:) [] infixDecl
58− return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
69+ return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
59−
70+
71+
60setupParser :: IParser a -> String -> Either [P.Doc] a
72setupParser :: IParser a -> String -> Either [P.Doc] a
61setupParser p source =
73setupParser p source =
62 case iParse p source of
74 case iParse p source of
63− Right result -> Right result
75+ Right result ->
76+ Right result
77+
78+ Left err ->
64− Left err -> Left [ P.text $ "Parse error at " ++ show err ]
79+ Left [ P.text $ "Parse error at " ++ show err ]
src/Parse/Pattern.hs+10−5
@@ -25,12 +25,17 @@ basic = choice
25 c:_ | isUpper c -> P.Data (Var.Raw v) []
25 c:_ | isUpper c -> P.Data (Var.Raw v) []
26 _ -> P.Var v
26 _ -> P.Var v
27
27
28+
28asPattern :: P.RawPattern -> IParser P.RawPattern
29asPattern :: P.RawPattern -> IParser P.RawPattern
29−asPattern pattern = do
30+asPattern pattern =
30− var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
31+ do var <- optionMaybe (try (whitespace >> reserved "as") >> whitespace >> lowVar)
31− return $ case var of
32+ case var of
33+ Just v ->
32− Just v -> P.Alias v pattern
34+ return (P.Alias v pattern)
35+
33− Nothing -> pattern
36+ Nothing ->
37+ return pattern
38+
34
39
35record :: IParser P.RawPattern
40record :: IParser P.RawPattern
36record = P.Record <$> brackets (commaSep1 lowVar)
41record = P.Record <$> brackets (commaSep1 lowVar)
src/Type/ExtraChecks.hs+40−23
@@ -20,19 +20,24 @@ import qualified AST.PrettyPrint as PP
20import qualified AST.Type as ST
20import qualified AST.Type as ST
21import qualified AST.Variable as V
21import qualified AST.Variable as V
22import qualified Transform.Expression as Expr
22import qualified Transform.Expression as Expr
23+import qualified Type.Hint as Hint
23import qualified Type.Type as TT
24import qualified Type.Type as TT
24import qualified Type.State as TS
25import qualified Type.State as TS
25
26
27+
26throw :: [Doc] -> Either [Doc] a
28throw :: [Doc] -> Either [Doc] a
29+throw err =
27−throw err = Left [ P.vcat err ]
30+ Left [ P.vcat err ]
31+
28
32
29mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
33mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
30mainType environment =
34mainType environment =
31− do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
35+ do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32− mainCheck environment'
36+ mainCheck environment'
33 where
37 where
38+ mainCheck
34− mainCheck :: (Monad m) => Map.Map String ST.CanonicalType
39+ :: (Monad m) => Map.Map String ST.CanonicalType
35− -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
40+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
36 mainCheck env =
41 mainCheck env =
37 case Map.lookup "main" env of
42 case Map.lookup "main" env of
38 Nothing -> return env
43 Nothing -> return env
@@ -40,17 +45,24 @@ mainType environment =
40 | tipe `elem` acceptable -> return env
45 | tipe `elem` acceptable -> return env
41 | otherwise -> throwError err
46 | otherwise -> throwError err
42 where
47 where
48+ acceptable =
43− acceptable = [ "Graphics.Element.Element"
49+ [ "Graphics.Element.Element"
44− , "Signal.Signal Graphics.Element.Element" ]
50+ , "Signal.Signal Graphics.Element.Element"
51+ ]
45
52
46 tipe = PP.renderPretty typeOfMain
53 tipe = PP.renderPretty typeOfMain
54+
55+ err =
47− err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
56+ [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
48− , P.text "Instead 'main' has type:\n"
57+ , P.text "Instead 'main' has type:\n"
49− , P.nest 4 (PP.pretty typeOfMain)
58+ , P.nest 4 (PP.pretty typeOfMain)
50− , P.text " " ]
59+ , P.text " "
60+ ]
61+
51
62
52data Direction = In | Out
63data Direction = In | Out
53
64
65+
54portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
66portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
55portTypes expr =
67portTypes expr =
56 case Expr.checkPorts (check In) (check Out) expr of
68 case Expr.checkPorts (check In) (check Out) expr of
@@ -120,20 +132,25 @@ portTypes expr =
120 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
132 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
121 ]
133 ]
122
134
135+
123occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
136occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
124occurs (name, variable) =
137occurs (name, variable) =
125− do vars <- liftIO $ infiniteVars [] variable
138+ do vars <- liftIO $ infiniteVars [] variable
126− case vars of
139+ case vars of
140+ [] ->
127− [] -> return ()
141+ return ()
142+
128− var:_ -> do
143+ var : _ ->
129− desc <- liftIO $ UF.descriptor var
144+ do desc <- liftIO $ UF.descriptor var
130− case TT.structure desc of
145+ case TT.structure desc of
131− Nothing ->
146+ Nothing ->
132− modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }
147+ TS.addHint (P.text msg)
148+
133− Just _ ->
149+ Just _ ->
134− do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
150+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
135− var' <- liftIO $ UF.fresh desc
151+ var' <- liftIO $ UF.fresh desc
136− TS.addError (A.None (P.text name)) (Just msg) var var'
152+ hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
153+ TS.addHint hint
137 where
154 where
138 msg = "Infinite types are not allowed"
155 msg = "Infinite types are not allowed"
139
156
src/Type/Hint.hsnew file+35
@@ -0,0 +1,35 @@
1+module Type.Hint where
2+
3+import Control.Applicative ( (<$>) )
4+import qualified Data.UnionFind.IO as UF
5+import Text.PrettyPrint as P
6+
7+import qualified AST.Annotation as A
8+import AST.PrettyPrint (pretty)
9+import Type.Type (Descriptor, toSrcType)
10+
11+
12+type Hint = Doc
13+
14+
15+create
16+ :: A.Region
17+ -> Maybe String
18+ -> UF.Point Descriptor
19+ -> UF.Point Descriptor
20+ -> IO Hint
21+create region hint t1 t2 =
22+ do t1' <- pretty <$> toSrcType t1
23+ t2' <- pretty <$> toSrcType t2
24+ return . foldr ($+$) P.empty $
25+ [ P.text "Type mismatch between the following types" <+> pretty region <> P.text ":"
26+ , P.text ""
27+ , P.nest 8 t1'
28+ , P.text ""
29+ , P.nest 8 t2'
30+ , P.text ""
31+ , maybe P.empty (P.nest 4 . P.text) hint
32+ , P.text " It is related to the following expression:"
33+ , P.text ""
34+ , P.nest 8 $ A.getRegionDocs region
35+ ]
src/Type/Inference.hs+3−3
@@ -29,9 +29,9 @@ infer interfaces modul =
29
29
30 state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
30 state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
31
31
32− () <- case TS.sErrors state of
32+ () <- case TS.sHint state of
33− errors@(_:_) -> throwError errors
33+ hints@(_:_) -> throwError hints
34− [] -> return ()
34+ [] -> return ()
35
35
36 () <- Check.portTypes (program (body modul))
36 () <- Check.portTypes (program (body modul))
37
37
src/Type/Solve.hs+22−9
@@ -9,6 +9,7 @@ import qualified Data.UnionFind.IO as UF
9import Type.Type
9import Type.Type
10import Type.Unify
10import Type.Unify
11import qualified Type.ExtraChecks as Check
11import qualified Type.ExtraChecks as Check
12+import qualified Type.Hint as Hint
12import qualified Type.State as TS
13import qualified Type.State as TS
13import qualified AST.Annotation as A
14import qualified AST.Annotation as A
14
15
@@ -169,6 +170,17 @@ solveScheme region scheme =
169 return header'
170 return header'
170
171
171
172
173+addHint
174+ :: A.Region
175+ -> Maybe String
176+ -> UF.Point Descriptor
177+ -> UF.Point Descriptor
178+ -> StateT TS.SolverState IO ()
179+addHint region hint t1 t2 =
180+ do msg <- liftIO (Hint.create region hint t1 t2)
181+ TS.addHint msg
182+
183+
172-- Checks that all of the given variables belong to distinct equivalence classes.
184-- Checks that all of the given variables belong to distinct equivalence classes.
173-- Also checks that their structure is Nothing, so they represent a variable, not
185-- Also checks that their structure is Nothing, so they represent a variable, not
174-- a more complex term.
186-- a more complex term.
@@ -178,15 +190,16 @@ allDistinct region vars =
178 forM_ vars $ \var ->
190 forM_ vars $ \var ->
179 do desc <- liftIO $ UF.descriptor var
191 do desc <- liftIO $ UF.descriptor var
180 case structure desc of
192 case structure desc of
181− Just _ -> TS.addError region (Just msg) var var
193+ Just _ ->
182− where msg = "Cannot generalize something that is not a type variable."
194+ let msg = "Cannot generalize something that is not a type variable."
195+ in
196+ addHint region (Just msg) var var
183
197
184− Nothing -> do
198+ Nothing ->
185− if mark desc == seen
199+ do when (mark desc == seen) $
186− then let msg = "Duplicate variable during generalization."
200+ do let msg = "Duplicate variable during generalization."
187− in TS.addError region (Just msg) var var
201+ addHint region (Just msg) var var
188− else return ()
189− liftIO $ UF.setDescriptor var (desc { mark = seen })
202+ liftIO $ UF.setDescriptor var (desc { mark = seen })
190
203
191
204
192-- Check that a variable has rank == noRank, meaning that it can be generalized.
205-- Check that a variable has rank == noRank, meaning that it can be generalized.
@@ -197,4 +210,4 @@ isGeneric region var =
197 then return ()
210 then return ()
198 else
211 else
199 let msg = "Unable to generalize a type variable. It is not unranked."
212 let msg = "Unable to generalize a type variable. It is not unranked."
200− in TS.addError region (Just msg) var var
213+ in addHint region (Just msg) var var
src/Type/State.hs+9−32
@@ -7,11 +7,10 @@ import qualified Data.Map as Map
7import qualified Data.Traversable as Traversable
7import qualified Data.Traversable as Traversable
8import qualified Data.UnionFind.IO as UF
8import qualified Data.UnionFind.IO as UF
9
9
10−import qualified AST.Annotation as A
10+import qualified Type.Hint as Hint
11−import AST.PrettyPrint
12−import Text.PrettyPrint as P
13import Type.Type
11import Type.Type
14
12
13+
15-- Pool
14-- Pool
16-- Holds a bunch of variables
15-- Holds a bunch of variables
17-- The rank of each variable is less than or equal to the pool's "maxRank"
16-- The rank of each variable is less than or equal to the pool's "maxRank"
@@ -40,7 +39,7 @@ data SolverState = SS
40 , sSavedEnv :: Env
39 , sSavedEnv :: Env
41 , sPool :: Pool
40 , sPool :: Pool
42 , sMark :: Int
41 , sMark :: Int
43− , sErrors :: [P.Doc]
42+ , sHint :: [Hint.Hint]
44 }
43 }
45
44
46
45
@@ -51,7 +50,7 @@ initialState =
51 , sSavedEnv = Map.empty
50 , sSavedEnv = Map.empty
52 , sPool = emptyPool
51 , sPool = emptyPool
53 , sMark = noMark + 1 -- The mark must never be equal to noMark!
52 , sMark = noMark + 1 -- The mark must never be equal to noMark!
54− , sErrors = []
53+ , sHint = []
55 }
54 }
56
55
57
56
@@ -65,31 +64,9 @@ modifyPool f =
65 modify $ \state -> state { sPool = f (sPool state) }
64 modify $ \state -> state { sPool = f (sPool state) }
66
65
67
66
68−addError
69− :: A.Region
70− -> Maybe String
71− -> UF.Point Descriptor
72− -> UF.Point Descriptor
73− -> StateT SolverState IO ()
67+addHint :: Hint.Hint -> StateT SolverState IO ()
74−addError region hint t1 t2 =
68+addHint hint =
75− do err <- liftIO makeError
76− modify $ \state -> state { sErrors = err : sErrors state }
69+ modify $ \state -> state { sHint = hint : sHint state }
77− where
78− makeError = do
79− t1' <- pretty <$> toSrcType t1
80− t2' <- pretty <$> toSrcType t2
81− return . foldr ($+$) P.empty $
82− [ P.text "Type mismatch between the following types" <+> pretty region <> P.text ":"
83− , P.text ""
84− , P.nest 8 t1'
85− , P.text ""
86− , P.nest 8 t2'
87− , P.text ""
88− , maybe P.empty (P.nest 4 . P.text) hint
89− , P.text " It is related to the following expression:"
90− , P.text ""
91− , P.nest 8 $ A.getRegionDocs region
92− ]
93
70
94
71
95switchToPool :: (MonadState SolverState m) => Pool -> m ()
72switchToPool :: (MonadState SolverState m) => Pool -> m ()
@@ -109,8 +86,8 @@ getEnv =
109
86
110saveLocalEnv :: StateT SolverState IO ()
87saveLocalEnv :: StateT SolverState IO ()
111saveLocalEnv =
88saveLocalEnv =
112− do env <- sEnv <$> get
89+ do currentEnv <- getEnv
113− modify $ \state -> state { sSavedEnv = env }
90+ modify $ \state -> state { sSavedEnv = currentEnv }
114
91
115
92
116uniqueMark :: StateT SolverState IO Int
93uniqueMark :: StateT SolverState IO Int
src/Type/Unify.hs+66−41
@@ -1,37 +1,62 @@
1module Type.Unify (unify) where
1module Type.Unify (unify) where
2
2
3import Control.Applicative ((<|>))
3import Control.Applicative ((<|>))
4−import Control.Monad.State
4+import Control.Monad.Error (ErrorT, throwError, runErrorT)
5+import Control.Monad.State as State
5import qualified Data.List as List
6import qualified Data.List as List
6import qualified Data.Map as Map
7import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.Maybe as Maybe
8import qualified Data.UnionFind.IO as UF
9import qualified Data.UnionFind.IO as UF
10+import Text.PrettyPrint (render)
11+
9import qualified AST.Annotation as A
12import qualified AST.Annotation as A
10import qualified AST.Variable as Var
13import qualified AST.Variable as Var
11import qualified Type.State as TS
14import qualified Type.State as TS
12import Type.Type
15import Type.Type
13import Type.PrettyPrint
16import Type.PrettyPrint
14−import Text.PrettyPrint (render)
17+import qualified Type.Hint as Hint
15import Elm.Utils ((|>))
18import Elm.Utils ((|>))
16
19
17
20
18unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
21unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
19−unify region variable1 variable2 = do
22+unify region variable1 variable2 =
23+ do result <- runErrorT (unifyHelp region variable1 variable2)
24+ either TS.addHint return result
25+
26+
27+-- ACTUALLY UNIFY STUFF
28+
29+type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)
30+
31+
32+typeError
33+ :: A.Region
34+ -> Maybe String
35+ -> UF.Point Descriptor
36+ -> UF.Point Descriptor
37+ -> Unify a
38+typeError region hint t1 t2 =
39+ do msg <- liftIO (Hint.create region hint t1 t2)
40+ throwError msg
41+
42+
43+unifyHelp :: A.Region -> Variable -> Variable -> Unify ()
44+unifyHelp region variable1 variable2 = do
20 equivalent <- liftIO $ UF.equivalent variable1 variable2
45 equivalent <- liftIO $ UF.equivalent variable1 variable2
21 if equivalent
46 if equivalent
22 then return ()
47 then return ()
23 else actuallyUnify region variable1 variable2
48 else actuallyUnify region variable1 variable2
24
49
25
50
26−actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
51+actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()
27actuallyUnify region variable1 variable2 = do
52actuallyUnify region variable1 variable2 = do
28 desc1 <- liftIO $ UF.descriptor variable1
53 desc1 <- liftIO $ UF.descriptor variable1
29 desc2 <- liftIO $ UF.descriptor variable2
54 desc2 <- liftIO $ UF.descriptor variable2
30− let unify' = unify region
55+ let unifyHelp' = unifyHelp region
31
56
32 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
57 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
33
58
34− merge1 :: StateT TS.SolverState IO ()
59+ merge1 :: Unify ()
35 merge1 = liftIO $ do
60 merge1 = liftIO $ do
36 if rank desc1 < rank desc2 then UF.union variable2 variable1
61 if rank desc1 < rank desc2 then UF.union variable2 variable1
37 else UF.union variable1 variable2
62 else UF.union variable1 variable2
@@ -42,7 +67,7 @@ actuallyUnify region variable1 variable2 = do
42 , alias = alias'
67 , alias = alias'
43 }
68 }
44
69
45− merge2 :: StateT TS.SolverState IO ()
70+ merge2 :: Unify ()
46 merge2 = liftIO $ do
71 merge2 = liftIO $ do
47 if rank desc1 < rank desc2 then UF.union variable2 variable1
72 if rank desc1 < rank desc2 then UF.union variable2 variable1
48 else UF.union variable1 variable2
73 else UF.union variable1 variable2
@@ -55,7 +80,7 @@ actuallyUnify region variable1 variable2 = do
55
80
56 merge = if rank desc1 < rank desc2 then merge1 else merge2
81 merge = if rank desc1 < rank desc2 then merge1 else merge2
57
82
58− fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
83+ fresh :: Maybe (Term1 Variable) -> Unify Variable
59 fresh structure = do
84 fresh structure = do
60 v <- liftIO . UF.fresh $ Descriptor
85 v <- liftIO . UF.fresh $ Descriptor
61 { structure = structure
86 { structure = structure
@@ -66,11 +91,11 @@ actuallyUnify region variable1 variable2 = do
66 , mark = noMark
91 , mark = noMark
67 , alias = alias'
92 , alias = alias'
68 }
93 }
69− TS.register v
94+ lift (TS.register v)
70
95
71 flexAndUnify v = do
96 flexAndUnify v = do
72 liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
97 liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
73− unify' variable1 variable2
98+ unifyHelp' variable1 variable2
74
99
75 unifyNumber svar (Var.Canonical home name) =
100 unifyNumber svar (Var.Canonical home name) =
76 case home of
101 case home of
@@ -79,17 +104,17 @@ actuallyUnify region variable1 variable2 = do
79 _ ->
104 _ ->
80 let hint = "Looks like something besides an Int or Float is being used as a number."
105 let hint = "Looks like something besides an Int or Float is being used as a number."
81 in
106 in
82− TS.addError region (Just hint) variable1 variable2
107+ typeError region (Just hint) variable1 variable2
83
108
84 comparableError maybe =
109 comparableError maybe =
85− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
110+ typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86 where
111 where
87 msg =
112 msg =
88 "Looks like you want something comparable, but the only valid comparable\n\
113 "Looks like you want something comparable, but the only valid comparable\n\
89 \types are Int, Float, Char, String, lists, or tuples."
114 \types are Int, Float, Char, String, lists, or tuples."
90
115
91 appendableError maybe =
116 appendableError maybe =
92− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
117+ typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
93 where
118 where
94 msg =
119 msg =
95 "Looks like you want something appendable, but the only Strings, Lists,\n\
120 "Looks like you want something appendable, but the only Strings, Lists,\n\
@@ -106,14 +131,14 @@ actuallyUnify region variable1 variable2 = do
106 case struct of
131 case struct of
107 Other -> comparableError Nothing
132 Other -> comparableError Nothing
108 List v -> do flexAndUnify varSuper
133 List v -> do flexAndUnify varSuper
109− unify' v =<< liftIO (variable $ Is Comparable)
134+ unifyHelp' v =<< liftIO (variable $ Is Comparable)
110 Tuple vs
135 Tuple vs
111 | length vs > 6 ->
136 | length vs > 6 ->
112 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
137 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
113 | otherwise ->
138 | otherwise ->
114 do flexAndUnify varSuper
139 do flexAndUnify varSuper
115 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
140 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
116− zipWithM_ unify' vs cmpVars
141+ zipWithM_ unifyHelp' vs cmpVars
117
142
118 unifyAppendable varSuper varFlex =
143 unifyAppendable varSuper varFlex =
119 do struct <- liftIO $ collectApps varFlex
144 do struct <- liftIO $ collectApps varFlex
@@ -122,7 +147,7 @@ actuallyUnify region variable1 variable2 = do
122 _ -> appendableError Nothing
147 _ -> appendableError Nothing
123
148
124 rigidError var =
149 rigidError var =
125− TS.addError region (Just hint) variable1 variable2
150+ typeError region (Just hint) variable1 variable2
126 where
151 where
127 hint =
152 hint =
128 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
153 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
@@ -153,15 +178,15 @@ actuallyUnify region variable1 variable2 = do
153
178
154 (Rigid, _, _, _) -> rigidError variable1
179 (Rigid, _, _, _) -> rigidError variable1
155 (_, Rigid, _, _) -> rigidError variable2
180 (_, Rigid, _, _) -> rigidError variable2
156− _ -> TS.addError region Nothing variable1 variable2
181+ _ -> typeError region Nothing variable1 variable2
157
182
158 case (structure desc1, structure desc2) of
183 case (structure desc1, structure desc2) of
159 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
184 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
160 (Nothing, _) | flex desc1 == Flexible -> merge2
185 (Nothing, _) | flex desc1 == Flexible -> merge2
161 (_, Nothing) | flex desc2 == Flexible -> merge1
186 (_, Nothing) | flex desc2 == Flexible -> merge1
162
187
163− (Just (Var1 v), _) -> unify' v variable2
188+ (Just (Var1 v), _) -> unifyHelp' v variable2
164− (_, Just (Var1 v)) -> unify' v variable1
189+ (_, Just (Var1 v)) -> unifyHelp' v variable1
165
190
166 (Nothing, _) -> superUnify
191 (Nothing, _) -> superUnify
167 (_, Nothing) -> superUnify
192 (_, Nothing) -> superUnify
@@ -170,33 +195,33 @@ actuallyUnify region variable1 variable2 = do
170 case (type1,type2) of
195 case (type1,type2) of
171 (App1 term1 term2, App1 term1' term2') ->
196 (App1 term1 term2, App1 term1' term2') ->
172 do merge
197 do merge
173− unify' term1 term1'
198+ unifyHelp' term1 term1'
174− unify' term2 term2'
199+ unifyHelp' term2 term2'
175 (Fun1 term1 term2, Fun1 term1' term2') ->
200 (Fun1 term1 term2, Fun1 term1' term2') ->
176 do merge
201 do merge
177− unify' term1 term1'
202+ unifyHelp' term1 term1'
178− unify' term2 term2'
203+ unifyHelp' term2 term2'
179
204
180 (EmptyRecord1, EmptyRecord1) ->
205 (EmptyRecord1, EmptyRecord1) ->
181 return ()
206 return ()
182
207
183− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
208+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2
184− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
209+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' ext variable1
185
210
186 (Record1 _ _, Record1 _ _) ->
211 (Record1 _ _, Record1 _ _) ->
187 recordUnify region fresh variable1 variable2
212 recordUnify region fresh variable1 variable2
188
213
189− _ -> TS.addError region Nothing variable1 variable2
214+ _ -> typeError region Nothing variable1 variable2
190
215
191
216
192-- RECORD UNIFICATION
217-- RECORD UNIFICATION
193
218
194recordUnify
219recordUnify
195 :: A.Region
220 :: A.Region
196− -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)
221+ -> (Maybe (Term1 Variable) -> Unify Variable)
197 -> Variable
222 -> Variable
198 -> Variable
223 -> Variable
199− -> StateT TS.SolverState IO ()
224+ -> Unify ()
200recordUnify region fresh variable1 variable2 =
225recordUnify region fresh variable1 variable2 =
201 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
226 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
202 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
227 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
@@ -212,57 +237,57 @@ recordUnify region fresh variable1 variable2 =
212 let addFieldMismatchError missingFields =
237 let addFieldMismatchError missingFields =
213 let msg = fieldMismatchError missingFields
238 let msg = fieldMismatchError missingFields
214 in
239 in
215− TS.addError region (Just msg) variable1 variable2
240+ typeError region (Just msg) variable1 variable2
216
241
217 case (ext1, ext2) of
242 case (ext1, ext2) of
218 (Empty _, Empty _) ->
243 (Empty _, Empty _) ->
219 case Map.null uniqueFields1 && Map.null uniqueFields2 of
244 case Map.null uniqueFields1 && Map.null uniqueFields2 of
220 True -> return ()
245 True -> return ()
221− False -> TS.addError region Nothing variable1 variable2
246+ False -> typeError region Nothing variable1 variable2
222
247
223 (Empty var1, Extension var2) ->
248 (Empty var1, Extension var2) ->
224 case (Map.null uniqueFields1, Map.null uniqueFields2) of
249 case (Map.null uniqueFields1, Map.null uniqueFields2) of
225 (_, False) -> addFieldMismatchError uniqueFields2
250 (_, False) -> addFieldMismatchError uniqueFields2
226− (True, True) -> unify region var1 var2
251+ (True, True) -> unifyHelp region var1 var2
227 (False, True) ->
252 (False, True) ->
228 do subRecord <- freshRecord uniqueFields1 var1
253 do subRecord <- freshRecord uniqueFields1 var1
229− unify region subRecord var2
254+ unifyHelp region subRecord var2
230
255
231 (Extension var1, Empty var2) ->
256 (Extension var1, Empty var2) ->
232 case (Map.null uniqueFields1, Map.null uniqueFields2) of
257 case (Map.null uniqueFields1, Map.null uniqueFields2) of
233 (False, _) -> addFieldMismatchError uniqueFields1
258 (False, _) -> addFieldMismatchError uniqueFields1
234− (True, True) -> unify region var1 var2
259+ (True, True) -> unifyHelp region var1 var2
235 (True, False) ->
260 (True, False) ->
236 do subRecord <- freshRecord uniqueFields2 var2
261 do subRecord <- freshRecord uniqueFields2 var2
237− unify region var1 subRecord
262+ unifyHelp region var1 subRecord
238
263
239 (Extension var1, Extension var2) ->
264 (Extension var1, Extension var2) ->
240 case (Map.null uniqueFields1, Map.null uniqueFields2) of
265 case (Map.null uniqueFields1, Map.null uniqueFields2) of
241 (True, True) ->
266 (True, True) ->
242− unify region var1 var2
267+ unifyHelp region var1 var2
243
268
244 (True, False) ->
269 (True, False) ->
245 do subRecord <- freshRecord uniqueFields2 var2
270 do subRecord <- freshRecord uniqueFields2 var2
246− unify region var1 subRecord
271+ unifyHelp region var1 subRecord
247
272
248 (False, True) ->
273 (False, True) ->
249 do subRecord <- freshRecord uniqueFields1 var1
274 do subRecord <- freshRecord uniqueFields1 var1
250− unify region subRecord var2
275+ unifyHelp region subRecord var2
251
276
252 (False, False) ->
277 (False, False) ->
253 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
278 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
254 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
279 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
255− unify region record1' var2
280+ unifyHelp region record1' var2
256− unify region var1 record2'
281+ unifyHelp region var1 record2'
257
282
258
283
259unifyOverlappingFields
284unifyOverlappingFields
260 :: A.Region
285 :: A.Region
261 -> Map.Map String [Variable]
286 -> Map.Map String [Variable]
262 -> Map.Map String [Variable]
287 -> Map.Map String [Variable]
263− -> StateT TS.SolverState IO ()
288+ -> Unify ()
264unifyOverlappingFields region fields1 fields2 =
289unifyOverlappingFields region fields1 fields2 =
265− Map.intersectionWith (zipWith (unify region)) fields1 fields2
290+ Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2
266 |> Map.elems
291 |> Map.elems
267 |> concat
292 |> concat
268 |> sequence_
293 |> sequence_