1b95db0 · elk · git.iko.soy

elm-compiler.cabal+16−3

compare with master

unifiedsplit

@@ -47,10 +47,10 @@ Library

47

48 other-modules:

49 AST.Declaration,

50+ AST.Expression.Canonical,

50 AST.Expression.General,

51 AST.Expression.General,

51 AST.Expression.Source,

52 AST.Expression.Source,

52 AST.Expression.Valid,

53 AST.Expression.Valid,

53− AST.Expression.Canonical,

54 AST.Helpers,

55 AST.Literal,

56 AST.Module,

@@ -58,22 +58,24 @@ Library

58 AST.Type,

59 AST.Variable,

60 Canonicalize,

61+ Canonicalize.Declaration,

61 Canonicalize.Environment,

62 Canonicalize.Environment,

62 Canonicalize.Port,

63 Canonicalize.Port,

64+ Canonicalize.Result,

63 Canonicalize.Setup,

65 Canonicalize.Setup,

64 Canonicalize.Sort,

66 Canonicalize.Sort,

65 Canonicalize.Type,

67 Canonicalize.Type,

66 Canonicalize.Variable,

68 Canonicalize.Variable,

67 Compile,

69 Compile,

70+ Elm.Compiler.Imports,

68 Elm.Compiler.Type.Extract,

71 Elm.Compiler.Type.Extract,

69 Elm.Compiler.Version,

72 Elm.Compiler.Version,

73+ Generate.Cases,

70 Generate.JavaScript,

74 Generate.JavaScript,

71 Generate.JavaScript.Helpers,

75 Generate.JavaScript.Helpers,

72 Generate.JavaScript.Port,

76 Generate.JavaScript.Port,

73 Generate.JavaScript.Variable,

77 Generate.JavaScript.Variable,

74− Generate.Cases,

75 Generate.Substitute,

78 Generate.Substitute,

76− Transform.AddDefaultImports,

77 Parse.Binop,

79 Parse.Binop,

78 Parse.Declaration,

80 Parse.Declaration,

79 Parse.Expression,

81 Parse.Expression,

@@ -83,6 +85,16 @@ Library

83 Parse.Parse,

85 Parse.Parse,

84 Parse.Pattern,

86 Parse.Pattern,

85 Parse.Type,

87 Parse.Type,

88+ Reporting.Annotation,

89+ Reporting.Error,

90+ Reporting.Error.Canonicalize,

91+ Reporting.Error.Syntax,

92+ Reporting.Error.Type,

93+ Reporting.PrettyPrint,

94+ Reporting.Region,

95+ Reporting.Report,

96+ Reporting.Result,

97+ Reporting.Warning,

86 Type.Constrain.Expression,

98 Type.Constrain.Expression,

87 Type.Constrain.Literal,

99 Type.Constrain.Literal,

88 Type.Constrain.Pattern,

100 Type.Constrain.Pattern,

@@ -95,6 +107,7 @@ Library

95 Type.State,

107 Type.State,

96 Type.Type,

108 Type.Type,

97 Type.Unify,

109 Type.Unify,

110+ Validate,

98 Paths_elm_compiler

111 Paths_elm_compiler

99

112

100 Build-depends:

113 Build-depends:

src/AST/Pattern.hs+8

@@ -48,6 +48,14 @@ list end patterns =

48 A.at start end (Data (Var.Raw "::") [pattern, list end rest])

49

50

51+consMany :: R.Position -> [RawPattern] -> RawPattern

52+consMany end patterns =

53+ let cons hd@(A.A (R.Region start _) _) tl =

54+ A.at start end (Data (Var.Raw "::") [hd, tl])

55+ in

56+ foldr1 cons patterns

57+

58+

51tuple :: [RawPattern] -> RawPattern'

59tuple :: [RawPattern] -> RawPattern'

52tuple patterns =

60tuple patterns =

53 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns

61 Data (Var.Raw ("_Tuple" ++ show (length patterns))) patterns

src/Canonicalize.hs+2−2

@@ -23,6 +23,7 @@ import qualified Reporting.Error as Error

23import qualified Reporting.Error.Canonicalize as CError

24import qualified Reporting.Result as R

25import qualified Reporting.Warning as Warning

26+import qualified Canonicalize.Declaration as Decls

26import qualified Canonicalize.Environment as Env

27import qualified Canonicalize.Environment as Env

27import qualified Canonicalize.Port as Port

28import qualified Canonicalize.Port as Port

28import qualified Canonicalize.Result as Result

29import qualified Canonicalize.Result as Result

@@ -30,7 +31,6 @@ import qualified Canonicalize.Setup as Setup

30import qualified Canonicalize.Sort as Sort

31import qualified Canonicalize.Sort as Sort

31import qualified Canonicalize.Type as Canonicalize

32import qualified Canonicalize.Type as Canonicalize

32import qualified Canonicalize.Variable as Canonicalize

33import qualified Canonicalize.Variable as Canonicalize

33−import qualified Transform.Declaration as Transform

34

35

36-- MODULES

@@ -85,7 +85,7 @@ moduleHelp interfaces modul@(Module.Module _ _ exports (defaults, imports) decls

85 in

86 Module.CanonicalBody

87 { program =

88− let expr = Transform.toExpr (Module.names modul) decls

88+ let expr = Decls.toExpr (Module.names modul) decls

89 in

90 Sort.definitions (dummyLet expr)

91

src/Transform/Declaration.hs → src/Canonicalize/Declaration.hsrenamed+1−1

@@ -1,5 +1,5 @@

1{-# OPTIONS_GHC -Wall #-}

2−module Transform.Declaration (toExpr) where

2+module Canonicalize.Declaration (toExpr) where

3

4import qualified AST.Declaration as D

5import qualified AST.Expression.General as E

src/Canonicalize/Port.hs+5−5

@@ -90,7 +90,7 @@ validForeignType name isInbound rootType tipe =

90 T.Type v ->

91 case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of

92 True -> Result.ok ()

93− False -> err "an unsupported type"

93+ False -> err Nothing

94

95 T.App t [] ->

96 valid t

@@ -105,16 +105,16 @@ validForeignType name isInbound rootType tipe =

105 Foldable.traverse_ valid ts

106

107 T.App _ _ ->

108− err "an unsupported type"

108+ err Nothing

109

110 T.Var _ ->

111− err "a free type variable"

111+ err (Just "a free type variable")

112

113 T.Lambda _ _ ->

114− err "functions"

114+ err (Just "a function")

115

116 T.Record _ (Just _) ->

117− err "extended records with free type variables"

117+ err (Just "an extended record")

118

119 T.Record fields Nothing ->

120 Foldable.traverse_ (\(k,v) -> (,) k <$> valid v) fields

src/Canonicalize/Variable.hs+22−14

@@ -128,7 +128,7 @@ preferLocals' region env extract kind possibilities var =

128 name == Env._home env

129

130 ambiguous possibleVars =

131− Result.err (A.A region (Error.var kind var (Error.Ambiguous vars)))

131+ Result.err (A.A region (Error.variable kind var Error.Ambiguous vars))

132 where

133 vars = map (Var.toString . extract) possibleVars

134

@@ -173,7 +173,7 @@ notFound region kind possibilities var =

173 possibleNames =

174 map toVarName possibilities

175

176− problem =

176+ (problem, suggestions) =

177 case name of

178 Left _ ->

179 exposedProblem name possibleNames

@@ -181,10 +181,10 @@ notFound region kind possibilities var =

181 Right (modul, varName) ->

182 qualifiedProblem modul varName (Either.rights possibleNames)

183 in

184− Result.err (A.A region (Error.var kind var problem))

184+ Result.err (A.A region (Error.variable kind var problem suggestions))

185

186

187−exposedProblem :: VarName -> [VarName] -> Error.VarProblem

187+exposedProblem :: VarName -> [VarName] -> (Error.VarProblem, [String])

188exposedProblem name possibleNames =

189 let (exposed, qualified) =

190 possibleNames

@@ -192,27 +192,35 @@ exposedProblem name possibleNames =

192 |> Error.nearbyNames noQualifier name

193 |> Either.partitionEithers

194 in

195+ ( Error.ExposedUnknown

195− Error.ExposedUnknown exposed (map qualifiedToString qualified)

196+ , exposed ++ map qualifiedToString qualified

197+ )

196

198

197

199

198qualifiedProblem

200qualifiedProblem

199 :: Module.Name

201 :: Module.Name

200 -> String

202 -> String

201 -> [(Module.Name, String)]

203 -> [(Module.Name, String)]

202− -> Error.VarProblem

204+ -> (Error.VarProblem, [String])

203qualifiedProblem moduleName name allQualified =

205qualifiedProblem moduleName name allQualified =

204 let availableModules =

206 let availableModules =

205 Set.fromList (map fst allQualified)

207 Set.fromList (map fst allQualified)

208+

209+ moduleNameString =

210+ Module.nameToString moduleName

206 in

211 in

207 case Set.member moduleName availableModules of

212 case Set.member moduleName availableModules of

208 True ->

213 True ->

214+ ( Error.QualifiedUnknown moduleNameString

209− allQualified

215+ , allQualified

210− |> filter ((==) moduleName . fst)

216+ |> filter ((==) moduleName . fst)

211− |> map snd

217+ |> map snd

212− |> Error.nearbyNames id name

218+ |> Error.nearbyNames id name

213− |> Error.QualifiedUnknown

219+ )

214

220

215 False ->

221 False ->

222+ ( Error.UnknownQualifier moduleNameString

216− Set.toList availableModules

223+ , Set.toList availableModules

217− |> Error.nearbyNames Module.nameToString moduleName

224+ |> map Module.nameToString

218− |> Error.UnknownQualifier

225+ |> Error.nearbyNames id moduleNameString

226+ )

src/Elm/Compiler.hs+5−22

@@ -3,8 +3,8 @@

3module Elm.Compiler

4 ( version, rawVersion

5 , parseDependencies, compile

6− , Error, errorToString, errorToJson

6+ , Error, errorToString

7− , Warning, warningToString, warningToJson

7+ , Warning

8 ) where

9

10import Control.Monad.Error.Class (MonadError, throwError)

@@ -83,28 +83,11 @@ compile user packageName source interfaces =

83newtype Error = Error (A.Located Error.Error)

84

85

86−errorToString :: Error -> String

86+errorToString :: String -> String -> Error -> String

87−errorToString (Error err) =

87+errorToString location source (Error err) =

88− Error.toString err

88+ Error.toString location source err

89−

90−

91−errorToJson :: Error -> String

92−errorToJson (Error err) =

93− Error.toJson err

94

89

95

90

96-- WARNINGS

91-- WARNINGS

97

92

98newtype Warning = Warning (A.Located Warning.Warning)

93newtype Warning = Warning (A.Located Warning.Warning)

99−

100−

101−warningToString :: Warning -> String

102−warningToString (Warning warning) =

103− Warning.toString warning

104−

105−

106−warningToJson :: Warning -> String

107−warningToJson (Warning warning) =

108− Warning.toJson warning

109−

110−

src/Transform/AddDefaultImports.hs → src/Elm/Compiler/Imports.hsrenamed+4−19

@@ -1,17 +1,17 @@

1−module Transform.AddDefaultImports (add, defaultImports) where

1+module Elm.Compiler.Imports (defaults) where

2

3import qualified AST.Module as Module

4import qualified AST.Variable as Var

5

6

7−-- DESCRIPTION OF DEFAULT IMPORTS

7+-- DEFAULT IMPORTS

8

9(==>) :: a -> b -> (a,b)

10(==>) = (,)

11

12

13−defaultImports :: [Module.DefaultImport]

13+defaults :: [Module.DefaultImport]

14−defaultImports =

14+defaults =

15 [ ["Basics"] ==> Module.ImportMethod Nothing Var.openListing

16 , ["List"] ==> exposing [Var.Value "::"]

17 , ["Maybe"] ==> exposing [Var.Union "Maybe" Var.openListing]

@@ -23,18 +23,3 @@ defaultImports =

23exposing :: [Var.Value] -> Module.ImportMethod

24exposing vars =

25 Module.ImportMethod Nothing (Var.listing vars)

26−

27−

28−-- ADDING DEFAULT IMPORTS TO A MODULE

29−

30−add

31− :: Bool

32− -> [Module.UserImport]

33− -> ([Module.DefaultImport], [Module.UserImport])

34−add needsDefaults imports =

35− (defaults, imports)

36− where

37− defaults =

38− if needsDefaults

39− then defaultImports

40− else []

src/Elm/Compiler/Module.hs+2−2

@@ -18,7 +18,7 @@ import qualified Data.Text as Text

18import System.FilePath ((</>))

19

20import qualified AST.Module as Module

21−import qualified Transform.AddDefaultImports as Defaults

21+import qualified Elm.Compiler.Imports as Imports

22import qualified Elm.Compiler.Type as Type

23import qualified Elm.Compiler.Type.Extract as Extract

24

@@ -34,7 +34,7 @@ newtype Name = Name [String]

34

35defaultImports :: [Name]

36defaultImports =

37− map (Name . fst) Defaults.defaultImports

37+ map (Name . fst) Imports.defaults

38

39

40-- POKING AROUND INTERFACES

src/Parse/Parse.hs+2−2

@@ -9,13 +9,13 @@ import qualified Text.Parsec.Error as Parsec

9

10import qualified AST.Declaration as D

11import qualified AST.Module as M

12+import qualified Elm.Compiler.Imports as Imports

12import Parse.Helpers

13import Parse.Helpers

13import qualified Parse.Module as Module

14import qualified Parse.Module as Module

14import qualified Parse.Declaration as Decl

15import qualified Parse.Declaration as Decl

15import qualified Reporting.Region as R

16import qualified Reporting.Region as R

16import qualified Reporting.Error.Syntax as Error

17import qualified Reporting.Error.Syntax as Error

17import qualified Reporting.Result as Result

18import qualified Reporting.Result as Result

18−import qualified Transform.AddDefaultImports as DefaultImports

19import qualified Validate

20

21

@@ -31,7 +31,7 @@ program needsDefaults table src =

31 validDecls <- Validate.declarations sourceDecls

32

33 let ammendedImports =

34− DefaultImports.add needsDefaults imports

34+ (if needsDefaults then Imports.defaults else [], imports)

35

36 return (M.Module names filePath exports ammendedImports validDecls)

37

src/Parse/Pattern.hs+6−1

@@ -104,4 +104,9 @@ patternConstructor =

104

105expr :: IParser P.RawPattern

106expr =

107+ asPattern subPattern <?> "pattern"

108+ where

109+ subPattern =

107− asPattern (patternConstructor <|> term) <?> "pattern"

110+ do patterns <- consSep1 (patternConstructor <|> term)

111+ end <- getMyPosition

112+ return (P.consMany end patterns)

src/Reporting/Error.hs+15−36

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

1{-# LANGUAGE OverloadedStrings #-}

2module Reporting.Error where

3

4−import Data.Aeson ((.=))

5−import qualified Data.Aeson as Json

6−import qualified Data.ByteString.Lazy.Char8 as BS

7−

8import qualified Reporting.Annotation as A

4import qualified Reporting.Annotation as A

9import qualified Reporting.Error.Canonicalize as Canonicalize

5import qualified Reporting.Error.Canonicalize as Canonicalize

10import qualified Reporting.Error.Syntax as Syntax

6import qualified Reporting.Error.Syntax as Syntax

11import qualified Reporting.Error.Type as Type

7import qualified Reporting.Error.Type as Type

12import qualified Reporting.Error.CheckMatch as CheckMatch

8import qualified Reporting.Error.CheckMatch as CheckMatch

9+import qualified Reporting.Report as Report

13

10

14

11

15-- ALL POSSIBLE ERRORS

12-- ALL POSSIBLE ERRORS

@@ -23,42 +20,24 @@ data Error

23

20

24-- TO STRING

21-- TO STRING

25

22

26−toString :: A.Located Error -> String

27−toString (A.A region err) =

28− case err of

29− Syntax syntaxError ->

30− Syntax.toString region syntaxError

31−

32− Canonicalize canonicalizeError ->

33− Canonicalize.toString region canonicalizeError

34−

35− Type typeError ->

36− Type.toString region typeError

37−

38− CheckMatch matchError ->

39− CheckMatch.toString region matchError

40−

41−-- JSON

42−

43−toJson :: A.Located Error -> String

23+toString :: String -> String -> A.Located Error -> String

44−toJson (A.A region err) =

24+toString location source (A.A region err) =

45− let json =

25+ let

26+ (tag, report) =

46 case err of

27 case err of

47 Syntax syntaxError ->

28 Syntax syntaxError ->

29+ ( "SYNTAX ERROR"

48− Syntax.toJson syntaxError

30+ , Syntax.toReport syntaxError

31+ )

49

32

50 Canonicalize canonicalizeError ->

33 Canonicalize canonicalizeError ->

34+ ( "NAMING ERROR"

51− Canonicalize.toJson canonicalizeError

35+ , Canonicalize.toReport canonicalizeError

36+ )

52

37

53 Type typeError ->

38 Type typeError ->

39+ ( "TYPE ERROR"

54− Type.toJson typeError

40+ , Type.toReport typeError

55−

41+ )

56− CheckMatch matchError ->

57− CheckMatch.toJson matchError

58 in

42 in

59− BS.unpack $ Json.encode $

43+ Report.toString tag location region report source

60− Json.object

61− [ "tag" .= ("error" :: String)

62− , "region" .= region

63− , "error" .= json

64− ]

src/Reporting/Error/Canonicalize.hs+133−144

@@ -2,18 +2,18 @@

2{-# LANGUAGE OverloadedStrings #-}

3module Reporting.Error.Canonicalize where

4

5−--import Data.Aeson ((.=))

6−import qualified Data.Aeson as Json

7−--import qualified Data.Aeson.Types as Json

8import Data.Function (on)

5import Data.Function (on)

9import qualified Data.List as List

6import qualified Data.List as List

10import qualified Text.EditDistance as Dist

7import qualified Text.EditDistance as Dist

8+import qualified Text.PrettyPrint as P

11

9

12import qualified AST.Module as Module

10import qualified AST.Module as Module

13import qualified AST.Type as Type

11import qualified AST.Type as Type

14import qualified AST.Variable as Var

12import qualified AST.Variable as Var

15import Elm.Utils ((|>))

13import Elm.Utils ((|>))

16−import qualified Reporting.Region as R

14+import qualified Reporting.PrettyPrint as P

15+import qualified Reporting.Region as Region

16+import qualified Reporting.Report as Report

17

18

19data Error

@@ -31,19 +31,20 @@ data VarError = VarError

31 { varKind :: String

32 , varName :: String

33 , varProblem :: VarProblem

34+ , varSuggestions :: [String]

34 }

35 }

35

36

37

37data VarProblem

38data VarProblem

38− = Ambiguous [String]

39+ = Ambiguous

39− | UnknownQualifier [Module.Name]

40+ | UnknownQualifier String

40− | QualifiedUnknown [String]

41+ | QualifiedUnknown String

41− | ExposedUnknown { closeExposed :: [String], closeQualified :: [String] }

42+ | ExposedUnknown

42

43

44

44−var :: String -> String -> VarProblem -> Error

45+variable :: String -> String -> VarProblem -> [String] -> Error

45−var kind name problem =

46+variable kind name problem suggestions =

46− Var (VarError kind name problem)

47+ Var (VarError kind name problem suggestions)

47

48

49

49-- PATTERN

50-- PATTERN

@@ -79,7 +80,7 @@ valueNotFound name value possibilities =

79data AliasError

80data AliasError

80 = ArgMismatch Var.Canonical Int Int

81 = ArgMismatch Var.Canonical Int Int

81 | SelfRecursive String [String] Type.Raw

82 | SelfRecursive String [String] Type.Raw

82− | MutuallyRecursive [(R.Region, String, [String], Type.Raw)]

83+ | MutuallyRecursive [(Region.Region, String, [String], Type.Raw)]

83

84

85

85alias :: Var.Canonical -> Int -> Int -> Error

86alias :: Var.Canonical -> Int -> Int -> Error

@@ -94,7 +95,7 @@ data PortError = PortError

94 , portIsInbound :: Bool

95 , portIsInbound :: Bool

95 , portRootType :: Type.Canonical

96 , portRootType :: Type.Canonical

96 , portLocalType :: Type.Canonical

97 , portLocalType :: Type.Canonical

97− , portMessage :: String

98+ , portMessage :: Maybe String

98 }

99 }

99

100

101

@@ -103,10 +104,10 @@ port

103 -> Bool

104 -> Bool

104 -> Type.Canonical

105 -> Type.Canonical

106 -> Type.Canonical

106− -> String

107+ -> Maybe String

107 -> Error

108 -> Error

108−port name isInbound rootType localType message =

109+port name isInbound rootType localType maybeMessage =

109− Port (PortError name isInbound rootType localType message)

110+ Port (PortError name isInbound rootType localType maybeMessage)

110

111

112

112-- NEARBY NAMES

113-- NEARBY NAMES

@@ -128,138 +129,126 @@ distance x y =

128 Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y

129 Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y

129

130

131

131−-- TO STRING

132+-- TO REPORT

132

133

133−toString :: R.Region -> Error -> String

134+toReport :: Error -> Report.Report

134−toString region err =

135+toReport err =

135 case err of

136 case err of

136− _ -> error "Canonicalize.toString" region

137−

138−

139−-- TO JSON

140−

141−toJson :: Error -> Json.Value

142−toJson err =

143− case err of

144− _ -> error "Canonicalize.toJson"

145−

146−{--

147−(.=.) key value =

148− key .= (value :: String)

149−

150−

151−errorToJson :: LError -> Json.Value

152−errorToJson (A.A region err) =

153− Json.object (generals ++ specifics)

154− where

155− generals =

156− [ "category" .=. "canonicalization"

157− , "region" .= region

158− ]

159−

160− specifics =

161− case err of

162− Var (VarError kind name varProblem) ->

137+ Var (VarError kind name problem suggestions) ->

163− [ "kind" .= kind

138+ let var = kind ++ " '" ++ name ++ "'"

164− , "name" .= name

139+ in

165− ]

140+ case problem of

166− ++ varProblemToJson varProblem

141+ Ambiguous ->

167−

142+ Report.simple

143+ ("This usage of " ++ var ++ " is ambiguous.")

144+ (maybeYouWant suggestions)

145+

146+ UnknownQualifier qualifier ->

147+ Report.simple

148+ ("Cannot find " ++ var ++ ", qualifier '" ++ qualifier ++ "' is not in scope.")

149+ (maybeYouWant suggestions)

150+

151+ QualifiedUnknown qualifier ->

152+ Report.simple

153+ ("Cannot find " ++ var ++ ", module '" ++ qualifier ++ "' does not expose that value.")

154+ (maybeYouWant suggestions)

155+

156+ ExposedUnknown ->

157+ Report.simple

158+ ("Cannot find " ++ var)

159+ (maybeYouWant suggestions)

160+

161+ Pattern patternError ->

162+ case patternError of

163+ PatternArgMismatch var expected actual ->

164+ argMismatchReport "Pattern" var expected actual

165+

168− Alias aliasError ->

166+ Alias aliasError ->

169− case aliasError of

167+ case aliasError of

170− ArgMismatch name expected actual ->

168+ ArgMismatch var expected actual ->

171− [ "tag" .=. "alias-args"

169+ argMismatchReport "Type" var expected actual

172− , "name" .= Var.toString name

170+

173− , "expected-args" .= expected

171+ SelfRecursive name tvars tipe ->

174− , "actual-args" .= actual

172+ Report.simple "This type alias is recursive, forming an infinite type!" $

175− ]

173+ "Type aliases are just names for more fundamental types, so I go through\n"

176−

174+ ++ "and expand them all to know the real underlying type. The problem is that\n"

177− Recursive [(name, tvars, tipe)] ->

175+ ++ "when I expand a recursive type alias, it keeps getting bigger and bigger.\n"

178− [ "tag" .=. "recursive-alias"

176+ ++ "Dealiasing results in an infinitely large type! Try this instead:\n\n"

179− ]

177+ ++ " type " ++ name ++ concatMap (' ':) tvars ++ " ="

180−

178+ ++ P.render (P.nest 8 (P.hang (P.text name) 2 (P.pretty True tipe)))

181− Recursive aliases ->

179+ ++ "\n\nThis creates a brand new type that cannot be expanded. It is similar types\n"

182− [ "tag" .=. "mutually-recursive-aliases"

180+ ++ "like List which are recursive, but do not get expanded into infinite types."

183− ]

181+

184−

182+ MutuallyRecursive aliases ->

183+ Report.simple "This type alias is part of a mutually recursive set of type aliases." $

184+ "The following type aliases all depend on each other in some way:\n"

185+ ++ concatMap showName aliases ++ "\n\n"

186+ ++ "The problem is that when you try to expand any of these type aliases, they\n"

187+ ++ "expand infinitely! To fix, first try to centralize them into one alias."

188+ where

189+ showName (Region.Region start _, name, _, _) =

190+ "\n " ++ name ++ replicate (65 - length name) ' '

191+ ++ "line " ++ show (Region.line start)

192+

185− Import moduleName importError ->

193+ Import name importError ->

194+ let moduleName = Module.nameToString name

195+ in

186− case importError of

196+ case importError of

187− ModuleNotFound suggestions ->

197+ ModuleNotFound suggestions ->

188− [ "tag" .=. "unknown-import"

198+ Report.simple

189− , "name" .= moduleName

199+ ("Could not find a module named '" ++ moduleName ++ "'")

190− , "suggestions" .= suggestions

200+ (maybeYouWant (map Module.nameToString suggestions))

191− ]

201+

192− ValueNotFound name suggestions ->

202+ ValueNotFound value suggestions ->

193− []

203+ Report.simple

194−

204+ ("Module '" ++ moduleName ++ "' does not expose '" ++ value ++ "'")

205+ (maybeYouWant suggestions)

206+

195− Export name suggestions ->

207+ Export name suggestions ->

196− []

208+ Report.simple

197−

209+ ("Could not export '" ++ name ++ "' which is not defined in this module.")

198− Port portError ->

210+ (maybeYouWant suggestions)

199− []

211+

200−

212+ Port (PortError name isInbound _rootType localType maybeMessage) ->

201−

213+ let

202−varProblemToJson :: VarProblem -> [Json.Pair]

214+ boundPort =

203−varProblemToJson varProblem =

215+ if isInbound then "inbound port" else "outbound port"

204− let details tag suggestions =

216+

205− [ "tag" .=. tag

217+ preHint =

206− , "suggestions" .= suggestions

218+ "Trying to send " ++ maybe "an unsupported type" id maybeMessage

207− ]

219+ ++ " through " ++ boundPort ++ " '" ++ name ++ "'"

220+

221+ postHint =

222+ "The specific unsupported type is:\n\n"

223+ ++ P.render (P.nest 4 (P.pretty False localType)) ++ "\n\n"

224+ ++ "The types of values that can flow through " ++ boundPort ++ "s include:\n"

225+ ++ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples,\n"

226+ ++ "Json.Values, and concrete records."

227+ in

228+ Report.simple preHint postHint

229+

230+

231+argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report

232+argMismatchReport kind var expected actual =

233+ let

234+ preHint =

235+ kind ++ " " ++ Var.toString var ++ " has too "

236+ ++ (if actual < expected then "few" else "many")

237+ ++ "arguments."

238+

239+ postHint =

240+ "Expecting " ++ show expected ++ ", but got " ++ show actual ++ "."

208 in

241 in

209− case varProblem of

242+ Report.Report Nothing preHint postHint

210− Ambiguous possibilities ->

211− details "ambiguous" possibilities

212−

213− UnknownQualifier possibleModules ->

214− details

215− "unknown-qualifier"

216− (map Module.nameToString possibleModules)

217−

218− QualifiedUnknown possibilities ->

219− details "qualified-unknown" possibilities

220−

221− ExposedUnknown closeExposed closeQualified ->

222− details "exposed-unknown" (closeExposed ++ closeQualified)

223−--}

224−

225−{-- TO STRING

226−

227−mutuallyRecursiveMessage :: String

228−mutuallyRecursiveMessage =

229− "The following type aliases are mutually recursive, forming an \

230− \infinite type. When you expand them, they just keep getting bigger:"

231−

232−

233−typeAliasErrorSegue :: String

234−typeAliasErrorSegue =

235− "Try this instead:"

236−

237−

238−typeAliasErrorExplanation :: String

239−typeAliasErrorExplanation =

240− "It looks very similar, but the 'type' keyword creates a brand new type, \

241− \not just an alias for an existing one. This lets us avoid infinitely \

242− \expanding it during type inference."

243−

244−

245−typeAlias

246− :: (String, [String], Type.Type var)

247− -> D.Declaration' pk def var expr

248−typeAlias (n,ts,t) =

249− D.TypeAlias n ts t

250−

251

243

252−datatype

253− :: (String, [String], Type.Type var)

254− -> D.Declaration' pk def var expr

255−datatype (n,ts,t) =

256− D.Datatype n ts [(n,[t])]

257

244

245+maybeYouWant :: [String] -> String

246+maybeYouWant suggestions =

247+ case suggestions of

248+ [] ->

249+ ""

258

250

259−indented :: [D.ValidDecl] -> Doc

251+ _:_ ->

260−indented decls =

252+ "Maybe you want one of the following?\n"

261− P.vcat (map prty decls) <> P.text "\n"

253+ ++ concatMap ("\n "++) suggestions

262− where

263− prty decl = P.text "\n " <> pretty decl

264

254

265−--}

src/Reporting/Error/Syntax.hs+126−12

@@ -1,10 +1,16 @@

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Syntax where

3

4−import qualified Data.Aeson as Json

4+import qualified Data.List as List

5import qualified Text.Parsec.Error as Parsec

6+import qualified Text.PrettyPrint as P

7+import Text.PrettyPrint ((<+>))

6

8

7−import qualified Reporting.Region as R

9+import qualified AST.Helpers as Help

10+import qualified AST.Type as Type

11+import Elm.Utils ((|>))

12+import qualified Reporting.PrettyPrint as P

13+import qualified Reporting.Report as Report

8

14

9

15

10data Error

16data Error

@@ -15,21 +21,129 @@ data Error

15 | DuplicateValueDeclaration String

21 | DuplicateValueDeclaration String

16 | DuplicateTypeDeclaration String

22 | DuplicateTypeDeclaration String

17 | DuplicateDefinition String

23 | DuplicateDefinition String

18− | UnboundTypeVar String String

24+ | UnboundTypeVarsInAlias String [String] String [String] Type.Raw

25+ | UnboundTypeVarsInUnion String [String] String [String] [(String, [Type.Raw])]

19

26

20

27

21−-- TO STRING

28+-- TO REPORT

22

29

23−toString :: R.Region -> Error -> String

30+toReport :: Error -> Report.Report

24−toString region err =

31+toReport err =

25 case err of

32 case err of

26− _ -> error "Syntax.toString" region

33+ Parse messages ->

34+ Report.simple

35+ "Problem when parsing your code!"

36+ (unlines (map parseErrorHint messages))

27

37

38+ InfixDuplicate opName ->

39+ Report.simple

40+ ("The infix declarations for " ++ operator ++ " must be removed.")

41+ ("The precedence and associativity can only be set in one place, and\n"

42+ ++ "this information has already been set somewhere else."

43+ )

44+ where

45+ operator =

46+ if Help.isOp opName

47+ then "(" ++ opName ++ ")"

48+ else "`" ++ opName ++ "`"

28

49

29−-- TO JSON

50+ TypeWithoutDefinition valueName ->

51+ Report.simple

52+ ("There is a type annotation for '" ++ valueName ++ "' but there"

53+ ++ "is no corresponding definition!"

54+ )

55+ ("Directly below the type annotation, put a definition like:\n\n"

56+ ++ " " ++ valueName ++ " = 42"

57+ )

30

58

31−toJson :: Error -> Json.Value

59+ PortWithoutAnnotation portName ->

32−toJson err =

60+ Report.simple

61+ ("Port '" ++ portName ++ "' does not have a type annotation!")

62+ ("Directly above the port definition, I need something like this:\n\n"

63+ ++ " port " ++ portName ++ " : Signal Int"

64+ )

65+

66+ DuplicateValueDeclaration name ->

67+ Report.simple

68+ ("Naming multiple top-level values '" ++ name ++ "' makes things\n"

69+ ++ "ambiguous. When you say '" ++ name ++ "' which one do you want?!"

70+ )

71+ ("Find all the top-level values named '" ++ name ++ "' and\n"

72+ ++ "do some renaming. Make sure the names are distinct!"

73+ )

74+

75+ DuplicateTypeDeclaration name ->

76+ Report.simple

77+ ("Naming multiple types '" ++ name ++ "' makes things ambiguous\n"

78+ ++ "When you say '" ++ name ++ "' which one do you want?!"

79+ )

80+ ("Find all the types named '" ++ name ++ "' and\n"

81+ ++ "do some renaming. Make sure the names are distinct!"

82+ )

83+

84+ DuplicateDefinition name ->

85+ Report.simple

86+ ("Naming multiple values '" ++ name ++ "' in a single let-expression makes\n"

87+ ++ "things ambiguous. When you say '" ++ name ++ "' which one do you want?!"

88+ )

89+ ("Find all the values named '" ++ name ++ "' in this let-expression and\n"

90+ ++ "do some renaming. Make sure the names are distinct!"

91+ )

92+

93+ UnboundTypeVarsInAlias typeName givenVars tvar tvars tipe ->

94+ unboundTypeVars typeName tvar tvars $ P.render $

95+ P.hang

96+ (P.text "type alias" <+> P.text typeName <+> P.hsep vars <+> P.equals)

97+ 4

98+ (P.pretty False tipe)

99+ where

100+ vars = map P.text (givenVars ++ tvar : tvars)

101+

102+

103+ UnboundTypeVarsInUnion typeName givenVars tvar tvars ctors ->

104+ unboundTypeVars typeName tvar tvars $ P.render $

105+ P.vcat

106+ [ P.text "type" <+> P.text typeName <+> P.hsep vars

107+ , map toDoc ctors

108+ |> zipWith (<+>) (P.text "=" : repeat (P.text "|"))

109+ |> P.vcat

110+ |> P.nest 4

111+ ]

112+ where

113+ vars = map P.text (givenVars ++ tvar : tvars)

114+ toDoc (ctor, args) =

115+ P.text ctor <+> P.hsep (map (P.pretty True) args)

116+

117+

118+unboundTypeVars :: String -> String -> [String] -> String -> Report.Report

119+unboundTypeVars typeName tvar tvars revisedDeclaration =

120+ let

121+ s = if null tvars then "" else "s"

122+ in

123+ Report.simple

124+ ("Type '" ++ typeName ++ "' uses unbound type variable" ++ s ++ ": "

125+ ++ List.intercalate ", " (tvar:tvars)

126+ )

127+ ("All type variables must be listed to avoid sneaky type errors.\n"

128+ ++ "Imagine one '" ++ typeName ++ "' where '" ++ tvar ++ "' is an Int and\n"

129+ ++ "another where it is a Bool. They both look like a '" ++ typeName ++ "'\n"

130+ ++ "to the type checker, but they are actually different types!\n\n"

131+ ++ "Maybe you want a definition like this?\n"

132+ ++ concatMap ("\n "++) (lines revisedDeclaration)

133+ )

134+

135+

136+parseErrorHint :: Parsec.Message -> String

137+parseErrorHint message =

33− case err of

138+ case message of

34− _ -> error "Syntax.toJson"

139+ Parsec.SysUnExpect msg ->

140+ "SysUnExpect: " ++ msg

141+

142+ Parsec.UnExpect msg ->

143+ "UnExpect: " ++ msg

144+

145+ Parsec.Expect msg ->

146+ "UnExpect: " ++ msg

35

147

148+ Parsec.Message msg ->

149+ "UnExpect: " ++ msg

src/Reporting/Error/Type.hs+101−17

@@ -1,39 +1,123 @@

1{-# OPTIONS_GHC -Wall #-}

2module Reporting.Error.Type where

3

4−--import Data.Aeson ((.=))

5−import qualified Data.Aeson as Json

4+import qualified Text.PrettyPrint as P

6

5

7import qualified AST.Type as T

6import qualified AST.Type as T

8−import qualified Reporting.Region as R

7+import qualified Reporting.PrettyPrint as P

8+import qualified Reporting.Region as Region

9+import qualified Reporting.Report as Report

9

10

11

11data Error

12data Error

12 = Mismatch Mismatch

13 = Mismatch Mismatch

13− | InfiniteType R.Region

14+ | InfiniteType String T.Canonical

14 | BadMain T.Canonical

15 | BadMain T.Canonical

15− | ProblemWithInferenceAlgorithm String

16

17

18data Mismatch = MismatchInfo

19− { hint :: Maybe String

19+ { _hint :: Hint

20− , leftType :: T.Canonical

20+ , _leftType :: T.Canonical

21− , rightType :: T.Canonical

21+ , _rightType :: T.Canonical

22+ , _note :: Note

22 }

23 }

23

24

25

25−-- TO STRING

26+data Hint

27+ = None

28+ | CaseBranch Int Region.Region

29+ | Case

30+ | IfBranches

31+ | MultiIfBranch Int Region.Region

32+ | If

26

33

27−toString :: R.Region -> Error -> String

34+

28−toString region err =

35+data Note

29− case err of

36+ = PreNote String

30− _ -> error "Type.toString" region

37+ | NoNote

38+ | PostNote String

31

39

32

40

33−-- TO JSON

41+-- TO REPORT

34

42

35−toJson :: Error -> Json.Value

43+toReport :: Error -> Report.Report

36−toJson err =

44+toReport err =

37 case err of

45 case err of

38− _ -> error "Type.toJson"

46+ Mismatch (MismatchInfo hint leftType rightType note) ->

47+ let

48+ (subRegion, preHint) = hintToString hint

49+

50+ postHint =

51+ "To be more specific, as I infer all the types, I am seeing a conflict between\n"

52+ ++ "this type:\n\n"

53+ ++ P.render (P.nest 4 (P.pretty False leftType))

54+ ++ "\n\nand this type:\n\n"

55+ ++ P.render (P.nest 4 (P.pretty False rightType))

56+ in

57+ case note of

58+ PreNote msg ->

59+ Report.Report subRegion (preHint ++ "\n\n" ++ msg) postHint

60+

61+ NoNote ->

62+ Report.Report subRegion preHint postHint

63+

64+ PostNote msg ->

65+ Report.Report subRegion preHint (postHint ++ "\n\n" ++ msg)

66+

67+

68+

69+ InfiniteType var tipe ->

70+ Report.simple "This expression is leading me to infer an infinite type." $

71+ "Maybe you are trying to do some tricky recursion? Try breaking the expression\n"

72+ ++ "into smaller pieces. Give each piece a name and try to write down its type.\n\n"

73+ ++ "Type inference got stuck when type '" ++ var ++ "' needed equal to:\n\n"

74+ ++ P.render (P.nest 4 (P.pretty False tipe))

75+ ++ "\n\nNotice that type variable '" ++ var ++ "' appears there too, so if we\n"

76+ ++ "expanded this type, it would just keep getting bigger and bigger."

77+

78+ BadMain tipe ->

79+ Report.simple "The 'main' value has an unsupported type." $

80+ "I need an Element, Html, (Signal Element), or (Signal Html) so I can render it\n"

81+ ++ "on screen, but you gave me:\n\n"

82+ ++ P.render (P.nest 4 (P.pretty False tipe))

83+

84+

85+hintToString :: Hint -> (Maybe Region.Region, String)

86+hintToString hint =

87+ case hint of

88+ None ->

89+ ( Nothing

90+ , "This expression is triggering a type mismatch."

91+ )

92+

93+ CaseBranch branchNumber region ->

94+ ( Just region

95+ , "The branches of this case-expression return different types of values.\n\n"

96+ ++ "I noticed the mismatch in branch #" ++ show branchNumber ++ ", but go through and make sure every\n"

97+ ++ "branch returns the same type of value."

98+ )

99+

100+ Case ->

101+ ( Nothing

102+ , "All the branches of this case-expression are consistent, but the overall\n"

103+ ++ "type does not match how it is used elsewhere."

104+ )

105+

106+ IfBranches ->

107+ ( Nothing

108+ , "The branches of this if-expression return different types of values.\n"

109+ ++ "All branches must have the same return type!"

110+ )

111+

112+ MultiIfBranch branchNumber region ->

113+ ( Just region

114+ , "The branches of this if-expression return different types of values.\n\n"

115+ ++ "I noticed the mismatch in branch #" ++ show branchNumber ++ ", but go through and make sure every\n"

116+ ++ "branch returns the same type of value."

117+ )

39

118

119+ If ->

120+ ( Nothing

121+ , "All the branches of this if-expression are consistent, but the overall\n"

122+ ++ "type does not match how it is used elsewhere."

123+ )

src/Reporting/PrettyPrint.hs−12

@@ -32,15 +32,3 @@ parensIf bool doc =

32variable :: String -> Doc

33variable x =

34 if Help.isOp x then parens (text x) else text x

35−

36−

37−eightyCharLines :: Int -> String -> String

38−eightyCharLines indent message = answer

39− where

40− (answer,_,_) = foldl step (spaces, indent-1, "") chunks

41−

42− chunks = map (\w -> (w, length w)) (words message)

43− spaces = replicate indent ' '

44− step (sentence, slen, space) (word, wlen)

45− | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")

46− | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")

src/Reporting/Region.hs−9

@@ -36,15 +36,6 @@ merge (Region start _) (Region _ end) =

36

37toString :: Region -> String

38toString (Region start end) =

39− let posToString pos =

40− "(line " ++ show (line pos) ++

41− ", column " ++ show (column pos) ++ ")"

42− in

43− posToString start ++ " to " ++ posToString end

44−

45−

46−toPrettyString :: Region -> String

47−toPrettyString (Region start end) =

48 case line start == line end of

39 case line start == line end of

49 False ->

40 False ->

50 "between lines " ++ show (line start)

41 "between lines " ++ show (line start)

src/Reporting/Report.hsnew file+114

@@ -0,0 +1,114 @@

1+module Reporting.Report

2+ ( Report(Report)

3+ , simple

4+ , toString

5+ ) where

6+

7+import Elm.Utils ((|>))

8+import qualified Reporting.Region as R

9+

10+

11+data Report = Report

12+ { highlight :: Maybe R.Region

13+ , preHint :: String

14+ , postHint :: String

15+ }

16+

17+

18+simple :: String -> String -> Report

19+simple pre post =

20+ Report Nothing pre post

21+

22+

23+toString :: String -> String -> R.Region -> Report -> String -> String

24+toString tag location region report source =

25+ concat

26+ [ messageBar tag location

27+ , preHint report ++ "\n\n"

28+ , grabRegion (highlight report) region source ++ "\n"

29+ , postHint report ++ "\n\n\n"

30+ ]

31+

32+

33+-- REPORT HEADER

34+

35+messageBar :: String -> String -> String

36+messageBar tag location =

37+ let usedSpace = 4 + length tag + 1 + length location

38+ in

39+ "-- " ++ tag ++ " "

40+ ++ replicate (max 1 (80 - usedSpace)) '-'

41+ ++ " " ++ location ++ "\n\n"

42+

43+

44+-- REGIONS

45+

46+grabRegion :: Maybe R.Region -> R.Region -> String -> String

47+grabRegion maybeSubRegion (R.Region start end) source =

48+ let

49+ (R.Position startLine startColumn) = start

50+ (R.Position endLine endColumn) = end

51+

52+ relevantLines =

53+ lines source

54+ |> drop (startLine - 1)

55+ |> take (endLine - startLine + 1)

56+ in

57+ case relevantLines of

58+ [] ->

59+ error "something has gone badly wrong with reporting source locations"

60+

61+ [theLine] ->

62+ let

63+ n = startLine

64+ w = length (show (n + 1))

65+ underline =

66+ replicate (startColumn - 1) ' '

67+ ++ replicate (max 1 (endColumn - startColumn)) '^'

68+ number =

69+ addLineNumber Nothing w

70+ in

71+ unlines

72+ [ number (n-1) ""

73+ , number n theLine

74+ , number (n+1) underline

75+ ]

76+

77+ firstLine : rest ->

78+ let

79+ filteredFirstLine =

80+ replicate (startColumn - 1) ' '

81+ ++ drop (startColumn - 1) firstLine

82+

83+ filteredLastLine =

84+ take (endColumn) (last rest)

85+

86+ focusedRelevantLines =

87+ filteredFirstLine : init rest ++ [filteredLastLine]

88+

89+ lineNumbersWidth =

90+ length (show (endLine + 1))

91+

92+ numberedLines =

93+ zipWith

94+ (addLineNumber maybeSubRegion lineNumbersWidth)

95+ [startLine - 1 .. endLine + 1]

96+ ("" : focusedRelevantLines ++ [""])

97+ in

98+ unlines numberedLines

99+

100+

101+addLineNumber :: Maybe R.Region -> Int -> Int -> String -> String

102+addLineNumber maybeSubRegion width n line =

103+ let

104+ number =

105+ if n < 0 then " " else show n

106+

107+ spacer (R.Region start end) =

108+ if R.line start <= n && n <= R.line end

109+ then ">"

110+ else " "

111+ in

112+ replicate (width - length number) ' ' ++ number

113+ ++ "|" ++ maybe " " spacer maybeSubRegion

114+ ++ line

src/Transform/Definition.hsdeleted−40

@@ -1,40 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.Definition where

3−

4−import Control.Applicative ((<$>))

5−import qualified AST.Pattern as P

6−import qualified AST.Expression.Source as Source

7−import qualified AST.Expression.Valid as Valid

8−import qualified Transform.Expression as Expr

9−

10−combineAnnotations :: [Source.Def] -> Either String [Valid.Def]

11−combineAnnotations =

12− go

13− where

14− errorMessage x =

15− "Syntax Error: The type annotation for '" ++ x ++

16− "' must be directly above its definition."

17−

18− exprCombineAnnotations =

19− Expr.crawlLet combineAnnotations

20−

21− go defs =

22− case defs of

23− Source.TypeAnnotation name tipe : rest ->

24− case rest of

25− Source.Definition pat@(P.Var name') expr : rest'

26− | name == name' ->

27− do expr' <- exprCombineAnnotations expr

28− let def = Valid.Definition pat expr' (Just tipe)

29− (:) def <$> go rest'

30−

31− _ ->

32− Left (errorMessage name)

33−

34− Source.Definition pat expr : rest ->

35− do expr' <- exprCombineAnnotations expr

36− let def = Valid.Definition pat expr' Nothing

37− (:) def <$> go rest

38−

39− [] ->

40− return []

src/Type/Constrain/Expression.hs+151−52

@@ -13,6 +13,8 @@ import qualified AST.Pattern as P

13import qualified AST.Type as ST

14import qualified AST.Variable as V

15import qualified Reporting.Annotation as A

16+import qualified Reporting.Error.Type as Error

17+import qualified Reporting.Region as R

16import qualified Type.Constrain.Literal as Literal

18import qualified Type.Constrain.Literal as Literal

17import qualified Type.Constrain.Pattern as Pattern

19import qualified Type.Constrain.Pattern as Pattern

18import qualified Type.Environment as Env

20import qualified Type.Environment as Env

@@ -27,7 +29,7 @@ constrain

27 -> IO TypeConstraint

29 -> IO TypeConstraint

28constrain env (A.A region expression) tipe =

30constrain env (A.A region expression) tipe =

29 let list t = Env.get env Env.types "List" <| t

31 let list t = Env.get env Env.types "List" <| t

30− (===) = CEqual region

32+ (===) = CEqual Error.None region

31 (<?) = CInstance region

33 (<?) = CInstance region

32 in

34 in

33 case expression of

35 case expression of

@@ -62,60 +64,51 @@ constrain env (A.A region expression) tipe =

62 in

64 in

63 return (if name == E.saveEnvName then CSaveEnv else name <? tipe)

65 return (if name == E.saveEnvName then CSaveEnv else name <? tipe)

64

66

65− E.Range lo hi ->

67+ E.Range lowExpr highExpr ->

66 existsNumber $ \n ->

68 existsNumber $ \n ->

67− do clo <- constrain env lo n

69+ do lowCon <- constrain env lowExpr n

68− chi <- constrain env hi n

70+ highCon <- constrain env highExpr n

69− return $ CAnd [clo, chi, list n === tipe]

71+ return $ CAnd [lowCon, highCon, list n === tipe]

70

72

71 E.ExplicitList exprs ->

73 E.ExplicitList exprs ->

72 exists $ \x ->

74 exists $ \x ->

73 do constraints <- mapM (\e -> constrain env e x) exprs

75 do constraints <- mapM (\e -> constrain env e x) exprs

74 return $ CAnd (list x === tipe : constraints)

76 return $ CAnd (list x === tipe : constraints)

75

77

76− E.Binop op e1 e2 ->

78+ E.Binop op leftExpr rightExpr ->

77− exists $ \t1 ->

79+ exists $ \leftType ->

78− exists $ \t2 ->

80+ exists $ \rightType ->

79− do c1 <- constrain env e1 t1

81+ do leftCon <- constrain env leftExpr leftType

80− c2 <- constrain env e2 t2

82+ rightCon <- constrain env rightExpr rightType

81− return $ CAnd [ c1, c2, V.toString op <? (t1 ==> t2 ==> tipe) ]

83+ return $ CAnd

84+ [ leftCon

85+ , rightCon

86+ , V.toString op <? (leftType ==> rightType ==> tipe)

87+ ]

82

88

83 E.Lambda pattern body ->

89 E.Lambda pattern body ->

84− exists $ \t1 ->

90+ exists $ \argType ->

85− exists $ \t2 ->

91+ exists $ \resType ->

86− do fragment <- Pattern.constrain env pattern t1

92+ do fragment <- Pattern.constrain env pattern argType

87− c2 <- constrain env body t2

93+ bodyCon <- constrain env body resType

94+ let con =

88− let c = ex (Fragment.vars fragment)

95+ ex (Fragment.vars fragment)

89− (CLet [monoscheme (Fragment.typeEnv fragment)]

96+ (CLet [monoscheme (Fragment.typeEnv fragment)]

90− (Fragment.typeConstraint fragment /\ c2)

97+ (Fragment.typeConstraint fragment /\ bodyCon)

91− )

98+ )

92− return $ c /\ tipe === (t1 ==> t2)

99+ return $ con /\ tipe === (argType ==> resType)

93−

100+

94− E.App e1 e2 ->

101+ E.App func arg ->

95 exists $ \t ->

102 exists $ \t ->

96− do c1 <- constrain env e1 (t ==> tipe)

103+ do funcCon <- constrain env func (t ==> tipe)

97− c2 <- constrain env e2 t

104+ argCon <- constrain env arg t

98− return $ c1 /\ c2

105+ return (funcCon /\ argCon)

99

106

100 E.MultiIf branches ->

107 E.MultiIf branches ->

101− CAnd <$> mapM constrain' branches

108+ constrainIf env region branches tipe

102− where

103− bool = Env.get env Env.types "Bool"

104−

105− constrain' (cond, expr) =

106− do cb <- constrain env cond bool

107− ce <- constrain env expr tipe

108− return (cb /\ ce)

109

110 E.Case expr branches ->

111− exists $ \t ->

111+ constrainCase env region expr branches tipe

112− do exprConstraint <- constrain env expr t

113− branchConstraints <- mapM (branch t) branches

114− return (CAnd (exprConstraint : branchConstraints))

115− where

116− branch t (pattern, branchExpr) =

117− do fragment <- Pattern.constrain env pattern t

118− CLet [Fragment.toScheme fragment] <$> constrain env branchExpr tipe

119

112

120 E.Data name exprs ->

113 E.Data name exprs ->

121 do vars <- Monad.forM exprs $ \_ -> variable Flexible

114 do vars <- Monad.forM exprs $ \_ -> variable Flexible

@@ -136,12 +129,13 @@ constrain env (A.A region expression) tipe =

136 constrain env expr (record (Map.singleton label [t]) tipe)

129 constrain env expr (record (Map.singleton label [t]) tipe)

137

130

138 E.Insert expr label value ->

131 E.Insert expr label value ->

139− exists $ \tVal ->

132+ exists $ \valueType ->

140− exists $ \tRec ->

133+ exists $ \recordType ->

141− do cVal <- constrain env value tVal

134+ do valueCon <- constrain env value valueType

142− cRec <- constrain env expr tRec

135+ recordCon <- constrain env expr recordType

136+ let newRecordType =

143− let c = tipe === record (Map.singleton label [tVal]) tRec

137+ record (Map.singleton label [valueType]) recordType

144− return (CAnd [cVal, cRec, c])

138+ return (CAnd [valueCon, recordCon, tipe === newRecordType])

145

139

146 E.Modify expr fields ->

140 E.Modify expr fields ->

147 exists $ \t ->

141 exists $ \t ->

@@ -158,14 +152,18 @@ constrain env (A.A region expression) tipe =

158 return $ cOld /\ ex newVars (CAnd (cNew : cs))

152 return $ cOld /\ ex newVars (CAnd (cNew : cs))

159

153

160 E.Record fields ->

154 E.Record fields ->

161− do vars <- Monad.forM fields $ \_ -> variable Flexible

155+ do vars <- Monad.forM fields (\_ -> variable Flexible)

156+ fieldCons <-

162− cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN vars)

157+ Monad.zipWithM

158+ (constrain env)

159+ (map snd fields)

160+ (map varN vars)

163 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

161 let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

164 let recordType = record fields' (termN EmptyRecord1)

162 let recordType = record fields' (termN EmptyRecord1)

165− return . ex vars . CAnd $ tipe === recordType : cs

163+ return (ex vars (CAnd (fieldCons ++ [tipe === recordType])))

166

164

167 E.Let defs body ->

165 E.Let defs body ->

168− do c <- constrain env body tipe

166+ do bodyCon <- constrain env body tipe

169

167

170 (Info schemes rqs fqs headers c2 c1) <-

168 (Info schemes rqs fqs headers c2 c1) <-

171 Monad.foldM

169 Monad.foldM

@@ -175,7 +173,7 @@ constrain env (A.A region expression) tipe =

175

173

176 let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]

174 let letScheme = [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]

177

175

178− return $ CLet schemes (CLet letScheme (c1 /\ c))

176+ return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))

179

177

180 E.Port impl ->

178 E.Port impl ->

181 case impl of

179 case impl of

@@ -189,6 +187,107 @@ constrain env (A.A region expression) tipe =

189 constrain env expr tipe

187 constrain env expr tipe

190

188

191

189

190+-- CONSTRAIN IF EXPRESSIONS

191+

192+constrainIf

193+ :: Env.Environment

194+ -> R.Region

195+ -> [(Canonical.Expr, Canonical.Expr)]

196+ -> Type

197+ -> IO TypeConstraint

198+constrainIf env region branches tipe =

199+ do (branchInfo, branchExprCons) <-

200+ unzip <$> mapM constrainBranch branches

201+

202+ return $

203+ ex (map fst branchInfo)

204+ (CAnd (branchExprCons ++ branchCons branchInfo))

205+ where

206+ bool = Env.get env Env.types "Bool"

207+

208+ constrainBranch (cond, expr@(A.A branchRegion _)) =

209+ do branchVar <- variable Flexible

210+ condCon <- constrain env cond bool

211+ exprCon <- constrain env expr (varN branchVar)

212+ return

213+ ( (branchVar, branchRegion)

214+ , condCon /\ exprCon

215+ )

216+

217+ branchCons branchInfo =

218+ case branchInfo of

219+ [(thenVar, _), (elseVar, _)] ->

220+ [ CEqual Error.IfBranches region (varN thenVar) (varN elseVar)

221+ , CEqual Error.If region tipe (varN thenVar)

222+ ]

223+

224+ _ ->

225+ buildBranchCons 2 branchInfo

226+

227+ buildBranchCons n branchInfo =

228+ case branchInfo of

229+ [] ->

230+ []

231+

232+ (var,_) : [] ->

233+ [ CEqual Error.If region tipe (varN var) ]

234+

235+ (var,_) : (var',region') : rest ->

236+ let

237+ hint = Error.MultiIfBranch n region'

238+ con = CEqual hint region (varN var) (varN var')

239+ in

240+ con : buildBranchCons (n+1) ((var', region') : rest)

241+

242+

243+-- CONSTRAIN CASE EXPRESSIONS

244+

245+constrainCase

246+ :: Env.Environment

247+ -> R.Region

248+ -> Canonical.Expr

249+ -> [(P.CanonicalPattern, Canonical.Expr)]

250+ -> Type

251+ -> IO TypeConstraint

252+constrainCase env region expr branches tipe =

253+ do exprVar <- variable Flexible

254+

255+ exprCon <- constrain env expr (varN exprVar)

256+

257+ (branchInfo, branchExprCons) <-

258+ unzip <$> mapM (branch (varN exprVar)) branches

259+

260+ return $

261+ ex (exprVar : map fst branchInfo)

262+ (CAnd (exprCon : branchExprCons ++ branchCons 2 branchInfo))

263+ where

264+ branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

265+ do branchVar <- variable Flexible

266+ fragment <- Pattern.constrain env pattern patternType

267+ branchCon <- constrain env branchExpr (varN branchVar)

268+ return

269+ ( (branchVar, branchRegion)

270+ , CLet [Fragment.toScheme fragment] branchCon

271+ )

272+

273+ branchCons n branchInfo =

274+ case branchInfo of

275+ [] ->

276+ []

277+

278+ (var,_) : [] ->

279+ [ CEqual Error.Case region tipe (varN var) ]

280+

281+ (var,_) : (var',region') : rest ->

282+ let

283+ hint = Error.CaseBranch n region'

284+ con = CEqual hint region (varN var) (varN var')

285+ in

286+ con : branchCons (n+1) ((var', region') : rest)

287+

288+

289+-- EXPAND PATTERNS

290+

192expandPattern :: Canonical.Def -> [Canonical.Def]

291expandPattern :: Canonical.Def -> [Canonical.Def]

193expandPattern def@(Canonical.Definition lpattern expr maybeType) =

292expandPattern def@(Canonical.Definition lpattern expr maybeType) =

194 let (A.A patternRegion pattern) = lpattern

293 let (A.A patternRegion pattern) = lpattern

src/Type/Constrain/Literal.hs+2−1

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

1module Type.Constrain.Literal where

2

3import qualified AST.Literal as L

4+import qualified Reporting.Error.Type as Error

4import qualified Reporting.Region as R

5import qualified Reporting.Region as R

5import qualified Type.Type as T

6import qualified Type.Type as T

6import qualified Type.Environment as Env

7import qualified Type.Environment as Env

@@ -14,7 +15,7 @@ constrain

14 -> IO T.TypeConstraint

15 -> IO T.TypeConstraint

15constrain env region literal tipe =

16constrain env region literal tipe =

16 do tipe' <- litType

17 do tipe' <- litType

17− return (T.CEqual region tipe tipe')

18+ return (T.CEqual Error.None region tipe tipe')

18 where

19 where

19 prim name =

20 prim name =

20 return (Env.get env Env.types name)

21 return (Env.get env Env.types name)

src/Type/Constrain/Pattern.hs+2−1

@@ -9,6 +9,7 @@ import qualified Data.Map as Map

9import qualified AST.Pattern as P

10import qualified AST.Variable as V

11import qualified Reporting.Annotation as A

12+import qualified Reporting.Error.Type as Error

12import qualified Type.Constrain.Literal as Literal

13import qualified Type.Constrain.Literal as Literal

13import qualified Type.Environment as Env

14import qualified Type.Environment as Env

14import Type.Fragment

15import Type.Fragment

@@ -21,7 +22,7 @@ constrain

21 -> Type

22 -> Type

22 -> IO Fragment

23 -> IO Fragment

23constrain env (A.A region pattern) tipe =

24constrain env (A.A region pattern) tipe =

24− let (===) = CEqual region

25+ let (===) = CEqual Error.None region

25 in

26 in

26 case pattern of

27 case pattern of

27 P.Anything ->

28 P.Anything ->

src/Type/Solve.hs+20−11

@@ -133,10 +133,10 @@ actuallySolve constraint =

133 CSaveEnv ->

134 TS.saveLocalEnv

135

136− CEqual region term1 term2 ->

136+ CEqual hint region term1 term2 ->

137 do t1 <- TS.flatten term1

138 t2 <- TS.flatten term2

139− unify region t1 t2

139+ unify hint region t1 t2

140

141 CAnd cs ->

142 mapM_ actuallySolve cs

@@ -167,7 +167,7 @@ actuallySolve constraint =

167 else error ("Could not find '" ++ name ++ "' when solving type constraints.")

168

169 t <- TS.flatten term

170− unify region freshCopy t

170+ unify Error.None region freshCopy t

171

172

173solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)

@@ -208,12 +208,12 @@ allDistinct vars =

208 do desc <- liftIO $ UF.descriptor var

209 case structure desc of

210 Just _ ->

211− TS.addError (error "Cannot generalize something that is not a type variable.") undefined

211+ crash "Cannot generalize something that is not a type variable."

212

213 Nothing ->

214− do when (mark desc == seen) $

214+ if mark desc == seen

215− TS.addError (error "Duplicate variable during generalization.") undefined

215+ then crash "Duplicate variable during generalization."

216− liftIO $ UF.setDescriptor var (desc { mark = seen })

216+ else liftIO (UF.setDescriptor var (desc { mark = seen }))

217

218

219-- Check that a variable has rank == noRank, meaning that it can be generalized.

@@ -222,8 +222,16 @@ isGeneric var =

222 do desc <- liftIO $ UF.descriptor var

223 if rank desc == noRank

224 then return ()

225− else

226− TS.addError (error "Unable to generalize a type variable. It is not unranked.") undefined

225+ else crash "Unable to generalize a type variable. It is not unranked."

226+

227+

228+crash :: String -> a

229+crash msg =

230+ error $

231+ "It looks like something went wrong with the type inference algorithm.\n"

232+ ++ msg ++ "\n"

233+ ++ "Please create a minimal example that triggers this problem and report it to\n"

234+ ++ "<https://github.com/elm-lang/elm-compiler/issues>"

227

235

228

236

229occurs :: (String, Variable) -> StateT TS.SolverState IO ()

237occurs :: (String, Variable) -> StateT TS.SolverState IO ()

@@ -235,12 +243,13 @@ occurs (_name, variable) =

235

243

236 var : _ ->

244 var : _ ->

237 do desc <- liftIO $ UF.descriptor var

245 do desc <- liftIO $ UF.descriptor var

246+ let region = error "TODO:occurs"

238 case structure desc of

247 case structure desc of

239 Nothing ->

248 Nothing ->

240− error "occurs check triggered"

249+ TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))

241

250

242 Just _ ->

251 Just _ ->

243− error "occurs check triggered"

252+ TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))

244 where

253 where

245 infiniteVars :: [Variable] -> Variable -> IO [Variable]

254 infiniteVars :: [Variable] -> Variable -> IO [Variable]

246 infiniteVars seen var =

255 infiniteVars seen var =

src/Type/Type.hs+3−2

@@ -13,6 +13,7 @@ import System.IO.Unsafe

13

14import qualified AST.Type as T

15import qualified AST.Variable as Var

16+import qualified Reporting.Error.Type as Error

16import qualified Reporting.Region as R

17import qualified Reporting.Region as R

17import Type.PrettyPrint

18import Type.PrettyPrint

18

19

@@ -104,7 +105,7 @@ data SuperType

104data Constraint a b

105data Constraint a b

105 = CTrue

106 = CTrue

106 | CSaveEnv

107 | CSaveEnv

107− | CEqual R.Region a a

108+ | CEqual Error.Hint R.Region a a

108 | CAnd [Constraint a b]

109 | CAnd [Constraint a b]

109 | CLet [Scheme a b] (Constraint a b)

110 | CLet [Scheme a b] (Constraint a b)

110 | CInstance R.Region SchemeName a

111 | CInstance R.Region SchemeName a

@@ -307,7 +308,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where

307 CSaveEnv ->

308 CSaveEnv ->

308 P.text "SaveTheEnvironment!!!"

309 P.text "SaveTheEnvironment!!!"

309

310

310− CEqual _region a b ->

311+ CEqual _ _ a b ->

311 prty a <+> P.text "=" <+> prty b

312 prty a <+> P.text "=" <+> prty b

312

313

313 CAnd [] ->

314 CAnd [] ->

src/Type/Unify.hs+48−45

@@ -5,44 +5,55 @@ import Control.Monad.Except (ExceptT, throwError, runExceptT)

5import Control.Monad.State as State

6import qualified Data.List as List

7import qualified Data.Map as Map

8−import qualified Data.Maybe as Maybe

9import qualified Data.UnionFind.IO as UF

8import qualified Data.UnionFind.IO as UF

10import Text.PrettyPrint (render)

9import Text.PrettyPrint (render)

11

10

11+import qualified AST.Type as AstType

12import qualified AST.Variable as Var

13import qualified Reporting.Region as R

14import qualified Reporting.Error.Type as Error

15import qualified Type.State as TS

16−import Type.Type

16+import Type.Type as Type

17import Type.PrettyPrint

18import Elm.Utils ((|>))

19

20

21+unify

22+ :: Error.Hint

23+ -> R.Region

24+ -> Variable

25+ -> Variable

21−unify :: R.Region -> Variable -> Variable -> StateT TS.SolverState IO ()

26+ -> StateT TS.SolverState IO ()

22−unify region variable1 variable2 =

27+unify hint region variable1 variable2 =

23 do result <- runExceptT (unifyHelp variable1 variable2)

28 do result <- runExceptT (unifyHelp variable1 variable2)

24 case result of

29 case result of

25 Right state ->

30 Right state ->

26 return state

31 return state

27

32

28− Left mismatch ->

33+ Left (RawMismatch (leftType, rightType, note)) ->

29− TS.addError region (Error.Mismatch mismatch)

34+ TS.addError region $ Error.Mismatch $

35+ Error.MismatchInfo hint leftType rightType note

30

36

31

37

32-- ACTUALLY UNIFY STUFF

38-- ACTUALLY UNIFY STUFF

33

39

40+type Unify =

34−type Unify = ExceptT Error.Mismatch (StateT TS.SolverState IO)

41+ ExceptT RawMismatch (StateT TS.SolverState IO)

42+

43+

44+newtype RawMismatch =

45+ RawMismatch (AstType.Canonical, AstType.Canonical, Error.Note)

35

46

36

47

37typeError

48typeError

38− :: Maybe String

39− -> UF.Point Descriptor

49+ :: UF.Point Descriptor

40 -> UF.Point Descriptor

50 -> UF.Point Descriptor

51+ -> Error.Note

41 -> Unify a

52 -> Unify a

42−typeError hint leftType rightType =

53+typeError leftType rightType note =

43 do leftSrcType <- liftIO (toSrcType leftType)

54 do leftSrcType <- liftIO (toSrcType leftType)

44 rightSrcType <- liftIO (toSrcType rightType)

55 rightSrcType <- liftIO (toSrcType rightType)

45− throwError (Error.MismatchInfo hint leftSrcType rightSrcType)

56+ throwError (RawMismatch (leftSrcType, rightSrcType, note))

46

57

47

58

48unifyHelp :: Variable -> Variable -> Unify ()

59unifyHelp :: Variable -> Variable -> Unify ()

@@ -110,23 +121,16 @@ actuallyUnify variable1 variable2 = do

110 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar

121 Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar

111 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar

122 Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar

112 _ ->

123 _ ->

113− let hint = "Looks like something besides an Int or Float is being used as a number."

114− in

115− typeError (Just hint) variable1 variable2

124+ typeError variable1 variable2 Error.NoNote

116−

125+

117− comparableError maybe =

126+ comparableError maybeHint =

118− typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

127+ typeError variable1 variable2 $ Error.PostNote $

119− where

120− msg =

121− "Looks like you want something comparable, but the only valid comparable\n\

122− \types are Int, Float, Char, String, lists, or tuples."

128+ "Note: comparable types include Int, Float, Char, String, lists, and tuples."

123−

129+ ++ maybe "" ("\n"++) maybeHint

130+

124− appendableError maybe =

131+ appendableError =

125− typeError (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

132+ typeError variable1 variable2 $ Error.PostNote $

126− where

127− msg =

128− "Looks like you want something appendable, but the only Strings, Lists,\n\

133+ "Note: appendable types include only Strings, Lists, and Text."

129− \and Text can be appended with the (++) operator."

130

134

131 unifyComparable v (Var.Canonical home name) =

135 unifyComparable v (Var.Canonical home name) =

132 case home of

136 case home of

@@ -146,7 +150,8 @@ actuallyUnify variable1 variable2 = do

146

150

147 Tuple vs

151 Tuple vs

148 | length vs > 6 ->

152 | length vs > 6 ->

153+ comparableError $ Just $

149− comparableError $ Just "Cannot compare a tuple with more than 6 elements."

154+ "Furthermore, it cannot be a tuple with more than 6 elements."

150 | otherwise ->

155 | otherwise ->

151 do flexAndUnify varSuper

156 do flexAndUnify varSuper

152 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

157 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

@@ -156,15 +161,15 @@ actuallyUnify variable1 variable2 = do

156 do struct <- liftIO $ collectApps varFlex

161 do struct <- liftIO $ collectApps varFlex

157 case struct of

162 case struct of

158 List _ -> flexAndUnify varSuper

163 List _ -> flexAndUnify varSuper

159− _ -> appendableError Nothing

164+ _ -> appendableError

160

165

161 rigidError var =

166 rigidError var =

167+ let v = render (pretty Never var)

168+ in

162− typeError (Just hint) variable1 variable2

169+ typeError variable1 variable2 $ Error.PreNote $

163− where

164− hint =

165− "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++

170+ "Could not unify rigid type variable '" ++ v ++ "'. The problem probably\n"

166− "The problem probably relates to the type variable being shared between a\n\

171+ ++ "relates to the type variable being shared between two type annotations.\n"

167− \top-level type annotation and a related let-bound type annotation."

172+ ++ "Try commenting out some type annotations and see what happens."

168

173

169 superUnify =

174 superUnify =

170 case (flex desc1, flex desc2, name desc1, name desc2) of

175 case (flex desc1, flex desc2, name desc1, name desc2) of

@@ -190,7 +195,7 @@ actuallyUnify variable1 variable2 = do

190

195

191 (Rigid, _, _, _) -> rigidError variable1

196 (Rigid, _, _, _) -> rigidError variable1

192 (_, Rigid, _, _) -> rigidError variable2

197 (_, Rigid, _, _) -> rigidError variable2

193− _ -> typeError Nothing variable1 variable2

198+ _ -> typeError variable1 variable2 Error.NoNote

194

199

195 case (structure desc1, structure desc2) of

200 case (structure desc1, structure desc2) of

196 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->

201 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible ->

@@ -234,7 +239,7 @@ actuallyUnify variable1 variable2 = do

234 (Record1 _ _, Record1 _ _) ->

239 (Record1 _ _, Record1 _ _) ->

235 recordUnify fresh variable1 variable2

240 recordUnify fresh variable1 variable2

236

241

237− _ -> typeError Nothing variable1 variable2

242+ _ -> typeError variable1 variable2 Error.NoNote

238

243

239

244

240-- RECORD UNIFICATION

245-- RECORD UNIFICATION

@@ -257,15 +262,14 @@ recordUnify fresh variable1 variable2 =

257 let uniqueFields2 = diffFields fields2 fields1

262 let uniqueFields2 = diffFields fields2 fields1

258

263

259 let addFieldMismatchError missingFields =

264 let addFieldMismatchError missingFields =

260− let msg = fieldMismatchError missingFields

261− in

262− typeError (Just msg) variable1 variable2

265+ typeError variable1 variable2 $ Error.PreNote $

266+ fieldMismatchError missingFields

263

267

264 case (ext1, ext2) of

268 case (ext1, ext2) of

265 (Empty _, Empty _) ->

269 (Empty _, Empty _) ->

266 case Map.null uniqueFields1 && Map.null uniqueFields2 of

270 case Map.null uniqueFields1 && Map.null uniqueFields2 of

267 True -> return ()

271 True -> return ()

268− False -> typeError Nothing variable1 variable2

272+ False -> typeError variable1 variable2 Error.NoNote

269

273

270 (Empty var1, Extension var2) ->

274 (Empty var1, Extension var2) ->

271 case (Map.null uniqueFields1, Map.null uniqueFields2) of

275 case (Map.null uniqueFields1, Map.null uniqueFields2) of

@@ -352,10 +356,9 @@ fieldMismatchError missingFields =

352 case Map.keys missingFields of

356 case Map.keys missingFields of

353 [] -> ""

357 [] -> ""

354 [key] ->

358 [key] ->

355− "Looks like a record is missing the field '" ++ key ++ "'.\n " ++

359+ "Looks like a record is missing the field '" ++ key ++ "'"

356− "Maybe there is a misspelling in a record access or record update?"

357 keys ->

360 keys ->

358− "Looks like one record is missing fields "

361+ "Looks like a record is missing fields "

359 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys

362 ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys

360

363

361

364

src/Validate.hs+23−10

@@ -340,16 +340,30 @@ extractValues (A.A region decl) =

340-- UNBOUND TYPE VARIABLES

341

342checkDecl :: D.ValidDecl -> Result.Result wrn Error.Error ()

343−checkDecl (A.A _ decl) =

343+checkDecl (A.A region decl) =

344 case decl of

345 D.Definition _ ->

346 return ()

347

348 D.Datatype name boundVars ctors ->

349− F.traverse_ (checkTypeVars name boundVars) (concatMap snd ctors)

349+ let frees = concatMap freeVars (concatMap snd ctors)

350+ in

351+ case findUnbound boundVars frees of

352+ [] ->

353+ return ()

354+

355+ v:vs ->

356+ Result.throw region

357+ (Error.UnboundTypeVarsInUnion name boundVars v vs ctors)

350

358

351 D.TypeAlias name boundVars tipe ->

359 D.TypeAlias name boundVars tipe ->

360+ case findUnbound boundVars (freeVars tipe) of

361+ [] ->

362+ return ()

363+

364+ v:vs ->

365+ Result.throw region

352− checkTypeVars name boundVars tipe

366+ (Error.UnboundTypeVarsInAlias name boundVars v vs tipe)

353

367

354 D.Port _ ->

368 D.Port _ ->

355 return ()

369 return ()

@@ -358,16 +372,15 @@ checkDecl (A.A _ decl) =

358 return ()

372 return ()

359

373

360

374

361−checkTypeVars :: String -> [String] -> Type.Raw -> Result.Result wrn Error.Error ()

375+findUnbound :: [String] -> [A.Located String] -> [String]

362−checkTypeVars name boundVars tipe =

376+findUnbound boundVars frees =

363 let bounds = Set.fromList boundVars

377 let bounds = Set.fromList boundVars

364

378

365− check (A.A region free) =

379+ isUnbound x =

366− if Set.member free bounds

380+ Set.notMember x bounds

367− then return ()

368− else Result.throw region (Error.UnboundTypeVar name free)

369 in

381 in

370− F.traverse_ check (freeVars tipe)

382+ filter isUnbound (map A.drop frees)

383+

371

384

372

385

373freeVars :: Type.Raw -> [A.Located String]

386freeVars :: Type.Raw -> [A.Located String]