git.iko.soy/elk
on master help sign in
Merge branch 'machine-errors'
commitdc0d2213652075839a704e3c142da0b7befa88e7 authorEvan Czaplicki <info@elm-lang.org> dateTue 16 Dec 2014, 15:26 (12 years ago) parent14c55e66398333
15 files changed+467−286
compare with master
unifiedsplit
elm-compiler.cabal+1 src/AST/Annotation.hs+62−24 src/AST/PrettyPrint.hs+4 src/Parse/Declaration.hs+33−23 src/Parse/Expression.hs+72−40 src/Parse/Helpers.hs+4−3 src/Parse/Module.hs+57−49 src/Parse/Parse.hs+49−34 src/Parse/Pattern.hs+10−5 src/Type/ExtraChecks.hs+40−23 src/Type/Hint.hs+35 src/Type/Inference.hs+3−3 src/Type/Solve.hs+22−9 src/Type/State.hs+9−32 src/Type/Unify.hs+66−41
elm-compiler.cabal+1
@@ -98,6 +98,7 @@ Library
9898 Type.Environment,
9999 Type.ExtraChecks,
100100 Type.Fragment,
101+ Type.Hint,
101102 Type.Inference,
102103 Type.PrettyPrint,
103104 Type.Solve,
src/AST/Annotation.hs+62−24
@@ -4,59 +4,97 @@ import qualified Text.Parsec.Pos as Parsec
44import qualified Text.PrettyPrint as P
55import AST.PrettyPrint
66
7−data Annotated annotation expr = A annotation expr
7+
8+data Annotated annotation expr
9+ = A annotation expr
810 deriving (Show)
911
12+
1013data Region
1114 = Span Position Position P.Doc
1215 | None P.Doc
1316 deriving (Show)
1417
18+
1519data Position = Position
1620 { line :: Int
1721 , column :: Int
18− } deriving (Show)
22+ }
23+ deriving (Show)
24+
25+
26+type Located expr =
27+ Annotated Region expr
1928
20−type Located expr = Annotated Region expr
2129
22−none e = A (None (pretty e)) e
23−noneNoDocs e = A (None P.empty) e
30+none :: (Pretty expr) => expr -> Located expr
31+none e =
32+ A (None (pretty e)) e
2433
25−at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr
26− -> Annotated Region expr
34+
35+noneNoDocs :: a -> Located a
36+noneNoDocs e =
37+ A (None P.empty) e
38+
39+
40+at :: (Pretty expr)
41+ => Parsec.SourcePos
42+ -> Parsec.SourcePos
43+ -> expr
44+ -> Annotated Region expr
2745at start end e =
2846 A (Span (position start) (position end) (pretty e)) e
29− where
30− position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
47+ where
48+ position loc =
49+ Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
3150
51+
52+merge :: (Pretty expr) => Located a -> Located b -> expr -> Located expr
3253merge (A s1 _) (A s2 _) e =
3354 A (span (pretty e)) e
34− where
35− span = case (s1,s2) of
36− (Span start _ _, Span _ end _) -> Span start end
37− (Span start end _, _) -> Span start end
38− (_, Span start end _) -> Span start end
39− (_, _) -> None
55+ where
56+ span =
57+ case (s1,s2) of
58+ (Span start _ _, Span _ end _) ->
59+ Span start end
60+
61+ (Span start end _, _) ->
62+ Span start end
4063
64+ (_, Span start end _) ->
65+ Span start end
66+
67+ (_, _) -> None
68+
69+
70+mergeOldDocs :: Located a -> Located b -> c -> Located c
4171mergeOldDocs (A s1 _) (A s2 _) e =
4272 A span e
43− where
44− span = case (s1,s2) of
45− (Span start _ d1, Span _ end d2) ->
46− Span start end (P.vcat [d1, P.text "\n", d2])
73+ where
74+ span =
75+ case (s1,s2) of
76+ (Span start _ d1, Span _ end 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
4784
48− (Span _ _ _, _) -> s1
49− (_, Span _ _ _) -> s2
50− (_, _) -> None P.empty
5185
5286sameAs :: 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+
5490
91+getRegionDocs :: Region -> P.Doc
5592getRegionDocs region =
5693 case region of
5794 Span _ _ doc -> doc
5895 None doc -> doc
5996
97+
6098instance Pretty Region where
6199 pretty span =
62100 case span of
@@ -68,6 +106,6 @@ instance Pretty Region where
68106 True -> "on line " ++ show (line end) ++ ", column " ++
69107 show (column start) ++ " to " ++ show (column end)
70108
109+
71110instance Pretty e => Pretty (Annotated a e) where
72111 pretty (A _ e) = pretty e
73−
src/AST/PrettyPrint.hs+4
@@ -38,5 +38,9 @@ eightyCharLines indent message = answer
3838 | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
3939 | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")
4040
41+instance Error Doc where
42+ noMsg = P.empty
43+ strMsg = P.text
44+
4145instance ErrorList Doc where
4246 listMsg str = [ P.text str ]
src/Parse/Declaration.hs+33−23
@@ -21,29 +21,32 @@ definition = D.Definition <$> Expr.def
2121
2222typeDecl :: IParser D.SourceDecl
2323typeDecl =
24− do reserved "type" <?> "type declaration"
25− forcedWS
26− isAlias <- optionMaybe (string "alias" >> forcedWS)
24+ do try (reserved "type") <?> "type declaration"
25+ forcedWS
26+ isAlias <- optionMaybe (string "alias" >> forcedWS)
2727
28− name <- capVar
29− args <- spacePrefix lowVar
30− padded equals
28+ name <- capVar
29+ args <- spacePrefix lowVar
30+ padded equals
3131
32− case isAlias of
33− Just _ ->
34− do tipe <- Type.expr <?> "a type"
35− return (D.TypeAlias name args tipe)
32+ case isAlias of
33+ Just _ ->
34+ do tipe <- Type.expr <?> "a type"
35+ return (D.TypeAlias name args tipe)
3636
37− Nothing ->
38− do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"
39− return $ D.Datatype name args tcs
37+ Nothing ->
38+ do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"
39+ return $ D.Datatype name args tcs
4040
4141
4242infixDecl :: IParser D.SourceDecl
4343infixDecl = do
44− assoc <- choice [ reserved "infixl" >> return D.L
45− , reserved "infix" >> return D.N
46− , reserved "infixr" >> return D.R ]
44+ assoc <-
45+ choice
46+ [ try (reserved "infixl") >> return D.L
47+ , try (reserved "infixr") >> return D.R
48+ , try (reserved "infix") >> return D.N
49+ ]
4750 forcedWS
4851 n <- digit
4952 forcedWS
@@ -52,10 +55,17 @@ infixDecl = do
5255
5356port :: IParser D.SourceDecl
5457port =
55− do try (reserved "port")
56− whitespace
57− name <- lowVar
58− whitespace
59− let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }
60− D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr
61− , port' equals D.PPDef Expr.expr ]
58+ do try (reserved "port")
59+ whitespace
60+ name <- lowVar
61+ whitespace
62+ let port' op ctor expr =
63+ do try op
64+ whitespace
65+ ctor name <$> expr
66+
67+ D.Port <$>
68+ choice
69+ [ port' hasType D.PPAnnotation Type.expr
70+ , port' equals D.PPDef Expr.expr
71+ ]
src/Parse/Expression.hs+72−40
@@ -139,56 +139,87 @@ appExpr = do
139139-------- Normal Expressions --------
140140
141141binaryExpr :: IParser Source.Expr
142−binaryExpr = Binop.binops appExpr lastExpr anyOp
143− where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
144− <|> lambdaExpr
142+binaryExpr =
143+ Binop.binops appExpr lastExpr anyOp
144+ where
145+ lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
146+ <|> lambdaExpr
147+
145148
146149ifExpr :: IParser Source.Expr'
147−ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
148− where
149− normal = do
150− bool <- expr
151− padded (reserved "then")
152− thenBranch <- expr
153− whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
154− elseBranch <- expr
155− return $ E.MultiIf
156− [ (bool, thenBranch)
157− , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
158− ]
159−
160− multiIf = E.MultiIf <$> spaceSep1 iff
161− where iff = do string "|" ; whitespace
162− b <- expr ; padded arrow
163− (,) b <$> expr
150+ifExpr =
151+ do try (reserved "if")
152+ whitespace
153+ normal <|> multiIf
154+ where
155+ normal = do
156+ bool <- expr
157+ padded (reserved "then")
158+ thenBranch <- expr
159+ whitespace <?> "an 'else' branch"
160+ reserved "else" <?> "an 'else' branch"
161+ whitespace
162+ elseBranch <- expr
163+ return $ E.MultiIf
164+ [ (bool, thenBranch)
165+ , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch)
166+ ]
167+
168+ multiIf =
169+ E.MultiIf <$> spaceSep1 iff
170+ where
171+ iff =
172+ do string "|" ; whitespace
173+ b <- expr ; padded arrow
174+ (,) b <$> expr
175+
164176
165177lambdaExpr :: IParser Source.Expr
166−lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
167− whitespace
168− args <- spaceSep1 Pattern.term
169− padded arrow
170− body <- expr
171− return (makeFunction args body)
178+lambdaExpr =
179+ do char '\\' <|> char '\x03BB' <?> "anonymous function"
180+ whitespace
181+ args <- spaceSep1 Pattern.term
182+ padded arrow
183+ body <- expr
184+ return (makeFunction args body)
185+
172186
173187defSet :: IParser [Source.Def]
174−defSet = block (do d <- def ; whitespace ; return d)
188+defSet =
189+ block $
190+ do d <- def
191+ whitespace
192+ return d
193+
175194
176195letExpr :: IParser Source.Expr'
177−letExpr = do
178− reserved "let" ; whitespace
179− defs <- defSet
180− padded (reserved "in")
181− E.Let defs <$> expr
196+letExpr =
197+ do try (reserved "let")
198+ whitespace
199+ defs <- defSet
200+ padded (reserved "in")
201+ E.Let defs <$> expr
202+
182203
183204caseExpr :: IParser Source.Expr'
184−caseExpr = do
185− reserved "case"; e <- padded expr; reserved "of"; whitespace
186− E.Case e <$> (with <|> without)
187− where case_ = do p <- Pattern.expr
188− padded arrow
189− (,) p <$> expr
190− with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
191− without = block (do c <- case_ ; whitespace ; return c)
205+caseExpr =
206+ do try (reserved "case")
207+ e <- padded expr
208+ reserved "of"
209+ whitespace
210+ E.Case e <$> (with <|> without)
211+ where
212+ case_ =
213+ do p <- Pattern.expr
214+ padded arrow
215+ (,) p <$> expr
216+
217+ with =
218+ brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
219+
220+ without =
221+ block (do c <- case_ ; whitespace ; return c)
222+
192223
193224expr :: IParser Source.Expr
194225expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
@@ -196,6 +227,7 @@ expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
196227 <|> binaryExpr
197228 <?> "an expression"
198229
230+
199231defStart :: IParser [P.RawPattern]
200232defStart =
201233 choice [ do p1 <- try Pattern.term
src/Parse/Helpers.hs+4−3
@@ -95,8 +95,10 @@ makeVar p =
9595
9696reserved :: String -> IParser String
9797reserved word =
98− (try (string word >> notFollowedBy innerVarChar) >> return word)
99− <?> "reserved word '" ++ word ++ "'"
98+ expecting ("reserved word '" ++ word ++ "'") $
99+ do string word
100+ notFollowedBy innerVarChar
101+ return word
100102
101103
102104-- INFIX OPERATORS
@@ -114,7 +116,6 @@ symOp =
114116 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
115117 case op of
116118 "." -> notFollowedBy lower >> return op
117− "\8728" -> return "."
118119 _ -> return op
119120
120121
src/Parse/Module.hs+57−49
@@ -8,49 +8,51 @@ import Parse.Helpers
88import qualified AST.Module as Module
99import qualified AST.Variable as Var
1010
11+
1112getModuleName :: String -> Maybe String
1213getModuleName source =
13− case iParse getModuleName source of
14− Right name -> Just name
15− Left _ -> Nothing
16− where
17− getModuleName = do
18− optional freshLine
19− (names, _) <- header
20− return (intercalate "." names)
14+ case iParse getModuleName source of
15+ Right name -> Just name
16+ Left _ -> Nothing
17+ where
18+ getModuleName =
19+ do optional freshLine
20+ (names, _) <- header
21+ return (intercalate "." names)
22+
2123
2224headerAndImports :: IParser Module.HeaderAndImports
2325headerAndImports =
24− do optional freshLine
25− (names, exports) <-
26− option (["Main"], Var.openListing) (header `followedBy` freshLine)
27− imports' <- commitToImports <|> return []
28− return $ Module.HeaderAndImports names exports imports'
29− where
30− commitToImports =
31− do try (lookAhead $ reserved "import")
32− imports `followedBy` freshLine
26+ do optional freshLine
27+ (names, exports) <-
28+ option (["Main"], Var.openListing) (header `followedBy` freshLine)
29+ imports' <- imports
30+ return $ Module.HeaderAndImports names exports imports'
31+
3332
3433header :: IParser ([String], Var.Listing Var.Value)
35−header = do
36− try (reserved "module")
37− whitespace
38− names <- dotSep1 capVar <?> "name of module"
39− whitespace
40− exports <- option Var.openListing (listing value)
41− whitespace <?> "reserved word 'where'"
42− reserved "where"
43− return (names, exports)
34+header =
35+ do try (reserved "module")
36+ whitespace
37+ names <- dotSep1 capVar <?> "name of module"
38+ whitespace
39+ exports <- option Var.openListing (listing value)
40+ whitespace <?> "reserved word 'where'"
41+ reserved "where"
42+ return (names, exports)
43+
4444
4545imports :: IParser [(Module.Name, Module.ImportMethod)]
46−imports = option [] ((:) <$> import' <*> many (try (freshLine >> import')))
46+imports =
47+ many (import' `followedBy` freshLine)
48+
4749
4850import' :: IParser (Module.Name, Module.ImportMethod)
4951import' =
50− do reserved "import"
51− whitespace
52− names <- dotSep1 capVar
53− (,) names <$> option (Module.As (intercalate "." names)) method
52+ do try (reserved "import")
53+ whitespace
54+ names <- dotSep1 capVar
55+ (,) names <$> option (Module.As (intercalate "." names)) method
5456 where
5557 method :: IParser Module.ImportMethod
5658 method = as' <|> importing'
@@ -64,25 +66,31 @@ import' =
6466 importing' :: IParser Module.ImportMethod
6567 importing' = Module.Open <$> listing value
6668
69+
6770listing :: IParser a -> IParser (Var.Listing a)
6871listing item =
69− do try (whitespace >> char '(')
70− whitespace
71− listing <- choice [ const Var.openListing <$> string ".."
72− , Var.Listing <$> commaSep1 item <*> return False
73− ] <?> "listing of values (x,y,z)"
74− whitespace
75− char ')'
76− return listing
72+ do try (whitespace >> char '(')
73+ whitespace
74+ listing <-
75+ choice
76+ [ const Var.openListing <$> string ".."
77+ , Var.Listing <$> commaSep1 item <*> return False
78+ ] <?> "listing of values (x,y,z)"
79+ whitespace
80+ char ')'
81+ return listing
82+
7783
7884value :: IParser Var.Value
79−value = val <|> tipe
80− where
81− val = Var.Value <$> (lowVar <|> parens symOp)
82−
83− tipe = do
84− name <- capVar
85− maybeCtors <- optionMaybe (listing capVar)
86− case maybeCtors of
87− Nothing -> return (Var.Alias name)
88− Just ctors -> return (Var.Union name ctors)
85+value =
86+ val <|> tipe
87+ where
88+ val =
89+ Var.Value <$> (lowVar <|> parens symOp)
90+
91+ tipe =
92+ do name <- capVar
93+ maybeCtors <- optionMaybe (listing capVar)
94+ case maybeCtors of
95+ Nothing -> return (Var.Alias name)
96+ Just ctors -> return (Var.Union name ctors)
src/Parse/Parse.hs+49−34
@@ -14,51 +14,66 @@ import qualified Parse.Module as Module
1414import qualified Parse.Declaration as Decl
1515import Transform.Declaration (combineAnnotations)
1616
17−freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
18− freshLine
19− Decl.declaration <?> "another datatype or variable definition"
2017
21−decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"
22− (d:) <$> many freshDef
18+freshDef =
19+ commitIf (freshLine >> (letter <|> char '_')) $
20+ do freshLine
21+ Decl.declaration <?> "another datatype or variable definition"
22+
23+
24+decls =
25+ do d <- Decl.declaration <?> "at least one datatype or variable definition"
26+ (d:) <$> many freshDef
27+
2328
2429program :: OpTable -> String -> Either [P.Doc] M.ValidModule
2530program table src =
26− do (M.Module names filePath exs ims sourceDecls) <-
27− setupParserWithTable table programParser src
31+ do (M.Module names filePath exs ims sourceDecls) <-
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
2838
29− decls <-
30− either (\err -> Left [P.text err]) Right (combineAnnotations sourceDecls)
31− return $ M.Module names filePath exs ims decls
3239
3340programParser :: IParser M.SourceModule
3441programParser =
35− do (M.HeaderAndImports names exports imports) <- Module.headerAndImports
36− declarations <- decls
37− optional freshLine ; optional spaces ; eof
38− return $ M.Module names "" exports imports declarations
42+ do (M.HeaderAndImports names exports imports) <- Module.headerAndImports
43+ declarations <- decls
44+ optional freshLine ; optional spaces ; eof
45+ return $ M.Module names "" exports imports declarations
46+
3947
4048setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a
4149setupParserWithTable table p source =
42− do localTable <- setupParser parseFixities source
43− case Map.intersection table localTable of
44− overlap | not (Map.null overlap) -> Left [ msg overlap ]
45− | otherwise ->
46− flip setupParser source $ do
47− putState (Map.union table localTable)
48− p
49− where
50− msg overlap =
51− P.vcat [ P.text "Parse error:"
52− , P.text $ "Overlapping definitions for infix operators: " ++
53− List.intercalate " " (Map.keys overlap)
54− ]
55−
56−parseFixities = do
57− decls <- onFreshLines (:) [] infixDecl
58− return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
59−
50+ do localTable <- setupParser parseFixities source
51+ case Map.intersection table localTable of
52+ overlap | not (Map.null overlap) -> Left [ msg overlap ]
53+ | otherwise ->
54+ flip setupParser source $
55+ do putState (Map.union table localTable)
56+ p
57+ where
58+ msg overlap =
59+ P.vcat
60+ [ P.text "Parse error:"
61+ , P.text $
62+ "Overlapping definitions for infix operators: "
63+ ++ List.intercalate " " (Map.keys overlap)
64+ ]
65+
66+
67+parseFixities =
68+ do decls <- onFreshLines (:) [] infixDecl
69+ return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
70+
71+
6072setupParser :: IParser a -> String -> Either [P.Doc] a
6173setupParser p source =
6274 case iParse p source of
63− Right result -> Right result
64− Left err -> Left [ P.text $ "Parse error at " ++ show err ]
75+ Right result ->
76+ Right result
77+
78+ Left err ->
79+ Left [ P.text $ "Parse error at " ++ show err ]
src/Parse/Pattern.hs+10−5
@@ -25,12 +25,17 @@ basic = choice
2525 c:_ | isUpper c -> P.Data (Var.Raw v) []
2626 _ -> P.Var v
2727
28+
2829asPattern :: P.RawPattern -> IParser P.RawPattern
29−asPattern pattern = do
30− var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
31− return $ case var of
32− Just v -> P.Alias v pattern
33− Nothing -> pattern
30+asPattern pattern =
31+ do var <- optionMaybe (try (whitespace >> reserved "as") >> whitespace >> lowVar)
32+ case var of
33+ Just v ->
34+ return (P.Alias v pattern)
35+
36+ Nothing ->
37+ return pattern
38+
3439
3540record :: IParser P.RawPattern
3641record = P.Record <$> brackets (commaSep1 lowVar)
src/Type/ExtraChecks.hs+40−23
@@ -20,19 +20,24 @@ import qualified AST.PrettyPrint as PP
2020import qualified AST.Type as ST
2121import qualified AST.Variable as V
2222import qualified Transform.Expression as Expr
23+import qualified Type.Hint as Hint
2324import qualified Type.Type as TT
2425import qualified Type.State as TS
2526
27+
2628throw :: [Doc] -> Either [Doc] a
27−throw err = Left [ P.vcat err ]
29+throw err =
30+ Left [ P.vcat err ]
31+
2832
2933mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
3034mainType environment =
31− do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32− mainCheck environment'
35+ do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
36+ mainCheck environment'
3337 where
34− mainCheck :: (Monad m) => Map.Map String ST.CanonicalType
35− -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
38+ mainCheck
39+ :: (Monad m) => Map.Map String ST.CanonicalType
40+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
3641 mainCheck env =
3742 case Map.lookup "main" env of
3843 Nothing -> return env
@@ -40,17 +45,24 @@ mainType environment =
4045 | tipe `elem` acceptable -> return env
4146 | otherwise -> throwError err
4247 where
43− acceptable = [ "Graphics.Element.Element"
44− , "Signal.Signal Graphics.Element.Element" ]
48+ acceptable =
49+ [ "Graphics.Element.Element"
50+ , "Signal.Signal Graphics.Element.Element"
51+ ]
4552
4653 tipe = PP.renderPretty typeOfMain
47− err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
48− , P.text "Instead 'main' has type:\n"
49− , P.nest 4 (PP.pretty typeOfMain)
50− , P.text " " ]
54+
55+ err =
56+ [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
57+ , P.text "Instead 'main' has type:\n"
58+ , P.nest 4 (PP.pretty typeOfMain)
59+ , P.text " "
60+ ]
61+
5162
5263data Direction = In | Out
5364
65+
5466portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()
5567portTypes expr =
5668 case Expr.checkPorts (check In) (check Out) expr of
@@ -120,20 +132,25 @@ portTypes expr =
120132 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
121133 ]
122134
135+
123136occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
124137occurs (name, variable) =
125− do vars <- liftIO $ infiniteVars [] variable
126− case vars of
127− [] -> return ()
128− var:_ -> do
129− desc <- liftIO $ UF.descriptor var
130− case TT.structure desc of
131− Nothing ->
132− modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }
133− Just _ ->
134− do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
135− var' <- liftIO $ UF.fresh desc
136− TS.addError (A.None (P.text name)) (Just msg) var var'
138+ do vars <- liftIO $ infiniteVars [] variable
139+ case vars of
140+ [] ->
141+ return ()
142+
143+ var : _ ->
144+ do desc <- liftIO $ UF.descriptor var
145+ case TT.structure desc of
146+ Nothing ->
147+ TS.addHint (P.text msg)
148+
149+ Just _ ->
150+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
151+ var' <- liftIO $ UF.fresh desc
152+ hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
153+ TS.addHint hint
137154 where
138155 msg = "Infinite types are not allowed"
139156
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 =
2929
3030 state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState
3131
32− () <- case TS.sErrors state of
33− errors@(_:_) -> throwError errors
34− [] -> return ()
32+ () <- case TS.sHint state of
33+ hints@(_:_) -> throwError hints
34+ [] -> return ()
3535
3636 () <- Check.portTypes (program (body modul))
3737
src/Type/Solve.hs+22−9
@@ -9,6 +9,7 @@ import qualified Data.UnionFind.IO as UF
99import Type.Type
1010import Type.Unify
1111import qualified Type.ExtraChecks as Check
12+import qualified Type.Hint as Hint
1213import qualified Type.State as TS
1314import qualified AST.Annotation as A
1415
@@ -169,6 +170,17 @@ solveScheme region scheme =
169170 return header'
170171
171172
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+
172184-- Checks that all of the given variables belong to distinct equivalence classes.
173185-- Also checks that their structure is Nothing, so they represent a variable, not
174186-- a more complex term.
@@ -178,15 +190,16 @@ allDistinct region vars =
178190 forM_ vars $ \var ->
179191 do desc <- liftIO $ UF.descriptor var
180192 case structure desc of
181− Just _ -> TS.addError region (Just msg) var var
182− where msg = "Cannot generalize something that is not a type variable."
193+ Just _ ->
194+ let msg = "Cannot generalize something that is not a type variable."
195+ in
196+ addHint region (Just msg) var var
183197
184− Nothing -> do
185− if mark desc == seen
186− then let msg = "Duplicate variable during generalization."
187− in TS.addError region (Just msg) var var
188− else return ()
189− liftIO $ UF.setDescriptor var (desc { mark = seen })
198+ Nothing ->
199+ do when (mark desc == seen) $
200+ do let msg = "Duplicate variable during generalization."
201+ addHint region (Just msg) var var
202+ liftIO $ UF.setDescriptor var (desc { mark = seen })
190203
191204
192205-- Check that a variable has rank == noRank, meaning that it can be generalized.
@@ -197,4 +210,4 @@ isGeneric region var =
197210 then return ()
198211 else
199212 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
77import qualified Data.Traversable as Traversable
88import qualified Data.UnionFind.IO as UF
99
10−import qualified AST.Annotation as A
11−import AST.PrettyPrint
12−import Text.PrettyPrint as P
10+import qualified Type.Hint as Hint
1311import Type.Type
1412
13+
1514-- Pool
1615-- Holds a bunch of variables
1716-- The rank of each variable is less than or equal to the pool's "maxRank"
@@ -40,7 +39,7 @@ data SolverState = SS
4039 , sSavedEnv :: Env
4140 , sPool :: Pool
4241 , sMark :: Int
43− , sErrors :: [P.Doc]
42+ , sHint :: [Hint.Hint]
4443 }
4544
4645
@@ -51,7 +50,7 @@ initialState =
5150 , sSavedEnv = Map.empty
5251 , sPool = emptyPool
5352 , sMark = noMark + 1 -- The mark must never be equal to noMark!
54− , sErrors = []
53+ , sHint = []
5554 }
5655
5756
@@ -65,31 +64,9 @@ modifyPool f =
6564 modify $ \state -> state { sPool = f (sPool state) }
6665
6766
68−addError
69− :: A.Region
70− -> Maybe String
71− -> UF.Point Descriptor
72− -> UF.Point Descriptor
73− -> StateT SolverState IO ()
74−addError region hint t1 t2 =
75− do err <- liftIO makeError
76− modify $ \state -> state { sErrors = err : sErrors 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− ]
67+addHint :: Hint.Hint -> StateT SolverState IO ()
68+addHint hint =
69+ modify $ \state -> state { sHint = hint : sHint state }
9370
9471
9572switchToPool :: (MonadState SolverState m) => Pool -> m ()
@@ -109,8 +86,8 @@ getEnv =
10986
11087saveLocalEnv :: StateT SolverState IO ()
11188saveLocalEnv =
112− do env <- sEnv <$> get
113− modify $ \state -> state { sSavedEnv = env }
89+ do currentEnv <- getEnv
90+ modify $ \state -> state { sSavedEnv = currentEnv }
11491
11592
11693uniqueMark :: StateT SolverState IO Int
src/Type/Unify.hs+66−41
@@ -1,37 +1,62 @@
11module Type.Unify (unify) where
22
33import Control.Applicative ((<|>))
4−import Control.Monad.State
4+import Control.Monad.Error (ErrorT, throwError, runErrorT)
5+import Control.Monad.State as State
56import qualified Data.List as List
67import qualified Data.Map as Map
78import qualified Data.Maybe as Maybe
89import qualified Data.UnionFind.IO as UF
10+import Text.PrettyPrint (render)
11+
912import qualified AST.Annotation as A
1013import qualified AST.Variable as Var
1114import qualified Type.State as TS
1215import Type.Type
1316import Type.PrettyPrint
14−import Text.PrettyPrint (render)
17+import qualified Type.Hint as Hint
1518import Elm.Utils ((|>))
1619
1720
1821unify :: 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
2045 equivalent <- liftIO $ UF.equivalent variable1 variable2
2146 if equivalent
2247 then return ()
2348 else actuallyUnify region variable1 variable2
2449
2550
26−actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
51+actuallyUnify :: A.Region -> Variable -> Variable -> Unify ()
2752actuallyUnify region variable1 variable2 = do
2853 desc1 <- liftIO $ UF.descriptor variable1
2954 desc2 <- liftIO $ UF.descriptor variable2
30− let unify' = unify region
55+ let unifyHelp' = unifyHelp region
3156
3257 (name', flex', rank', alias') = combinedDescriptors desc1 desc2
3358
34− merge1 :: StateT TS.SolverState IO ()
59+ merge1 :: Unify ()
3560 merge1 = liftIO $ do
3661 if rank desc1 < rank desc2 then UF.union variable2 variable1
3762 else UF.union variable1 variable2
@@ -42,7 +67,7 @@ actuallyUnify region variable1 variable2 = do
4267 , alias = alias'
4368 }
4469
45− merge2 :: StateT TS.SolverState IO ()
70+ merge2 :: Unify ()
4671 merge2 = liftIO $ do
4772 if rank desc1 < rank desc2 then UF.union variable2 variable1
4873 else UF.union variable1 variable2
@@ -55,7 +80,7 @@ actuallyUnify region variable1 variable2 = do
5580
5681 merge = if rank desc1 < rank desc2 then merge1 else merge2
5782
58− fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
83+ fresh :: Maybe (Term1 Variable) -> Unify Variable
5984 fresh structure = do
6085 v <- liftIO . UF.fresh $ Descriptor
6186 { structure = structure
@@ -66,11 +91,11 @@ actuallyUnify region variable1 variable2 = do
6691 , mark = noMark
6792 , alias = alias'
6893 }
69− TS.register v
94+ lift (TS.register v)
7095
7196 flexAndUnify v = do
7297 liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
73− unify' variable1 variable2
98+ unifyHelp' variable1 variable2
7499
75100 unifyNumber svar (Var.Canonical home name) =
76101 case home of
@@ -79,17 +104,17 @@ actuallyUnify region variable1 variable2 = do
79104 _ ->
80105 let hint = "Looks like something besides an Int or Float is being used as a number."
81106 in
82− TS.addError region (Just hint) variable1 variable2
107+ typeError region (Just hint) variable1 variable2
83108
84109 comparableError maybe =
85− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
110+ typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86111 where
87112 msg =
88113 "Looks like you want something comparable, but the only valid comparable\n\
89114 \types are Int, Float, Char, String, lists, or tuples."
90115
91116 appendableError maybe =
92− TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
117+ typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
93118 where
94119 msg =
95120 "Looks like you want something appendable, but the only Strings, Lists,\n\
@@ -106,14 +131,14 @@ actuallyUnify region variable1 variable2 = do
106131 case struct of
107132 Other -> comparableError Nothing
108133 List v -> do flexAndUnify varSuper
109− unify' v =<< liftIO (variable $ Is Comparable)
134+ unifyHelp' v =<< liftIO (variable $ Is Comparable)
110135 Tuple vs
111136 | length vs > 6 ->
112137 comparableError $ Just "Cannot compare a tuple with more than 6 elements."
113138 | otherwise ->
114139 do flexAndUnify varSuper
115140 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)
116− zipWithM_ unify' vs cmpVars
141+ zipWithM_ unifyHelp' vs cmpVars
117142
118143 unifyAppendable varSuper varFlex =
119144 do struct <- liftIO $ collectApps varFlex
@@ -122,7 +147,7 @@ actuallyUnify region variable1 variable2 = do
122147 _ -> appendableError Nothing
123148
124149 rigidError var =
125− TS.addError region (Just hint) variable1 variable2
150+ typeError region (Just hint) variable1 variable2
126151 where
127152 hint =
128153 "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++
@@ -153,15 +178,15 @@ actuallyUnify region variable1 variable2 = do
153178
154179 (Rigid, _, _, _) -> rigidError variable1
155180 (_, Rigid, _, _) -> rigidError variable2
156− _ -> TS.addError region Nothing variable1 variable2
181+ _ -> typeError region Nothing variable1 variable2
157182
158183 case (structure desc1, structure desc2) of
159184 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
160185 (Nothing, _) | flex desc1 == Flexible -> merge2
161186 (_, Nothing) | flex desc2 == Flexible -> merge1
162187
163− (Just (Var1 v), _) -> unify' v variable2
164− (_, Just (Var1 v)) -> unify' v variable1
188+ (Just (Var1 v), _) -> unifyHelp' v variable2
189+ (_, Just (Var1 v)) -> unifyHelp' v variable1
165190
166191 (Nothing, _) -> superUnify
167192 (_, Nothing) -> superUnify
@@ -170,33 +195,33 @@ actuallyUnify region variable1 variable2 = do
170195 case (type1,type2) of
171196 (App1 term1 term2, App1 term1' term2') ->
172197 do merge
173− unify' term1 term1'
174− unify' term2 term2'
198+ unifyHelp' term1 term1'
199+ unifyHelp' term2 term2'
175200 (Fun1 term1 term2, Fun1 term1' term2') ->
176201 do merge
177− unify' term1 term1'
178− unify' term2 term2'
202+ unifyHelp' term1 term1'
203+ unifyHelp' term2 term2'
179204
180205 (EmptyRecord1, EmptyRecord1) ->
181206 return ()
182207
183− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2
184− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1
208+ (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2
209+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' ext variable1
185210
186211 (Record1 _ _, Record1 _ _) ->
187212 recordUnify region fresh variable1 variable2
188213
189− _ -> TS.addError region Nothing variable1 variable2
214+ _ -> typeError region Nothing variable1 variable2
190215
191216
192217-- RECORD UNIFICATION
193218
194219recordUnify
195220 :: A.Region
196− -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)
221+ -> (Maybe (Term1 Variable) -> Unify Variable)
197222 -> Variable
198223 -> Variable
199− -> StateT TS.SolverState IO ()
224+ -> Unify ()
200225recordUnify region fresh variable1 variable2 =
201226 do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)
202227 (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)
@@ -212,57 +237,57 @@ recordUnify region fresh variable1 variable2 =
212237 let addFieldMismatchError missingFields =
213238 let msg = fieldMismatchError missingFields
214239 in
215− TS.addError region (Just msg) variable1 variable2
240+ typeError region (Just msg) variable1 variable2
216241
217242 case (ext1, ext2) of
218243 (Empty _, Empty _) ->
219244 case Map.null uniqueFields1 && Map.null uniqueFields2 of
220245 True -> return ()
221− False -> TS.addError region Nothing variable1 variable2
246+ False -> typeError region Nothing variable1 variable2
222247
223248 (Empty var1, Extension var2) ->
224249 case (Map.null uniqueFields1, Map.null uniqueFields2) of
225250 (_, False) -> addFieldMismatchError uniqueFields2
226− (True, True) -> unify region var1 var2
251+ (True, True) -> unifyHelp region var1 var2
227252 (False, True) ->
228253 do subRecord <- freshRecord uniqueFields1 var1
229− unify region subRecord var2
254+ unifyHelp region subRecord var2
230255
231256 (Extension var1, Empty var2) ->
232257 case (Map.null uniqueFields1, Map.null uniqueFields2) of
233258 (False, _) -> addFieldMismatchError uniqueFields1
234− (True, True) -> unify region var1 var2
259+ (True, True) -> unifyHelp region var1 var2
235260 (True, False) ->
236261 do subRecord <- freshRecord uniqueFields2 var2
237− unify region var1 subRecord
262+ unifyHelp region var1 subRecord
238263
239264 (Extension var1, Extension var2) ->
240265 case (Map.null uniqueFields1, Map.null uniqueFields2) of
241266 (True, True) ->
242− unify region var1 var2
267+ unifyHelp region var1 var2
243268
244269 (True, False) ->
245270 do subRecord <- freshRecord uniqueFields2 var2
246− unify region var1 subRecord
271+ unifyHelp region var1 subRecord
247272
248273 (False, True) ->
249274 do subRecord <- freshRecord uniqueFields1 var1
250− unify region subRecord var2
275+ unifyHelp region subRecord var2
251276
252277 (False, False) ->
253278 do record1' <- freshRecord uniqueFields1 =<< fresh Nothing
254279 record2' <- freshRecord uniqueFields2 =<< fresh Nothing
255− unify region record1' var2
256− unify region var1 record2'
280+ unifyHelp region record1' var2
281+ unifyHelp region var1 record2'
257282
258283
259284unifyOverlappingFields
260285 :: A.Region
261286 -> Map.Map String [Variable]
262287 -> Map.Map String [Variable]
263− -> StateT TS.SolverState IO ()
288+ -> Unify ()
264289unifyOverlappingFields region fields1 fields2 =
265− Map.intersectionWith (zipWith (unify region)) fields1 fields2
290+ Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2
266291 |> Map.elems
267292 |> concat
268293 |> sequence_