dd2feec · elk · git.iko.soy

git.iko.soy/elk

Create Type.Error module and simplify Error type a bit

commitdd2feec1575a41bdff028e80387b077bda8990df authorEvan Czaplicki <evancz@users.noreply.github.com> dateFri 9 Feb 2018, 17:19 (9 years ago) parent5149923

7 files changed+290−197

compare with master

unifiedsplit

elm-compiler.cabal+1 src/Reporting/Error/Type.hs+91−143 src/Type/Constrain/Expression.hs+6−6 src/Type/Error.hs+157 src/Type/Solve.hs+6−9 src/Type/Type.hs+28−38 src/Type/Unify.hs+1−1

elm-compiler.cabal+1

@@ -134,6 +134,7 @@ Library

134134 Type.Constrain.Expression,

135135 Type.Constrain.Module,

136136 Type.Constrain.Pattern,

137+ Type.Error,

137138 Type.Instantiate,

138139 Type.Occurs,

139140 Type.Solve,

src/Reporting/Error/Type.hs+91−143

@@ -3,7 +3,6 @@

33module Reporting.Error.Type

44 ( Error(..)

55 -- expectations

6− , Origin(..)

76 , Expected(..)

87 , Context(..)

98 , SubContext(..)

@@ -14,10 +13,6 @@ module Reporting.Error.Type

1413 , PCategory(..)

1514 , typeReplace

1615 , ptypeReplace

17− -- error types

18− , Type(..)

19− , Extension(..)

20− , Localizer

2116 -- make reports

2217 , toReport

2318 )

@@ -29,12 +24,12 @@ import Data.Monoid ((<>))

2924

3025import qualified AST.Module.Name as ModuleName

3126import qualified Data.Index as Index

32−import qualified Data.Map as Map

3327import qualified Elm.Name as N

3428import qualified Reporting.Helpers as H

3529import qualified Reporting.Region as R

3630import qualified Reporting.Render.Code as Code

3731import qualified Reporting.Report as Report

32+import qualified Type.Error as T

3833

3934

4035

@@ -42,21 +37,15 @@ import qualified Reporting.Report as Report

4237

4338

4439data Error

45− = Mismatch Origin (Expected Type)

46− | BadPattern R.Region PCategory Type (PExpected Type)

47− | InfiniteType Type

40+ = Mismatch R.Region Category T.Type (Expected T.Type)

41+ | BadPattern R.Region PCategory T.Type (PExpected T.Type)

42+ | InfiniteType T.Type

4843

4944

5045

5146-- EXPRESSION EXPECTATIONS

5247

5348

54−data Origin

55− = BadExpr R.Region Category Type

56− | BadLocal R.Region N.Name Type

57− | BadForeign R.Region N.Name Type

58−

59−

6049data Expected tipe

6150 = NoExpectation tipe

6251 | FromContext R.Region Context tipe

@@ -100,14 +89,16 @@ data Category

10089 | If

10190 | Case

10291 | CallResult MaybeName

103− | LambdaExpr

92+ | Lambda

10493 | Accessor N.Name

10594 | Access N.Name

106− | RecordExpr

107− | TupleExpr

108− | UnitExpr

95+ | Record

96+ | Tuple

97+ | Unit

10998 | Shader

11099 | Effects

100+ | Local N.Name

101+ | Foreign N.Name

111102

112103

113104

@@ -166,47 +157,14 @@ ptypeReplace expectation tipe =

166157

167158

168159

169−-- ERROR TYPES

170−

171−

172−data Type

173− = Lambda Type [Type]

174− | Infinite

175− | Error

176− | FlexVar N.Name

177− | FlexSuper N.Name

178− | RigidVar N.Name

179− | RigidSuper N.Name

180− | Type ModuleName.Canonical N.Name [Type]

181− | Record (Map.Map N.Name Type) Extension

182− | Unit

183− | Tuple Type Type (Maybe Type)

184− | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type

185−

186−

187−data Extension

188− = Closed

189− | FlexOpen N.Name

190− | RigidOpen N.Name

191−

192−

193−

194160-- TO REPORT

195161

196162

197−toReport :: Code.Source -> Localizer -> Error -> Report.Report

163+toReport :: Code.Source -> T.Localizer -> Error -> Report.Report

198164toReport source localizer err =

199165 case err of

200− Mismatch origin expected ->

201− case origin of

202− BadForeign region name tipe ->

203− toMismatchReport source localizer region (Var name) tipe expected

204−

205− BadLocal region name tipe ->

206− toMismatchReport source localizer region (Var name) tipe expected

207−

208− BadExpr region category tipe ->

209− toMismatchReport source localizer region (Category category) tipe expected

166+ Mismatch region category actualType expected ->

167+ toMismatchReport source localizer region category actualType expected

210168

211169 BadPattern region category tipe expected ->

212170 error "TODO" region category tipe expected

@@ -219,48 +177,40 @@ toReport source localizer err =

219177-- HELPERS

220178

221179

222−data Thing

223− = Var N.Name

224− | Category Category

225−

226−

227−toDescription :: Thing -> String -> String

228−toDescription thing thatThingIs =

229− case thing of

230− Var name ->

231− "This `" <> N.toString name <> "` value has type:"

232−

233− Category category ->

234− case category of

235− List -> thatThingIs <> " a list of type:"

236− Number -> thatThingIs <> " a number of type:"

237− Float -> thatThingIs <> " a float of type:"

238− String -> thatThingIs <> " a string of type:"

239− Char -> thatThingIs <> " a character of type:"

240− If -> "This `if` expression produces a value of type:"

241− Case -> "This `case` expression produces a value of type:"

242− LambdaExpr -> thatThingIs <> " an anonymous function of type:"

243− Accessor field -> "This ." <> N.toString field <> " field access function has type:"

244− Access field -> "The value at ." <> N.toString field <> " has type:"

245− RecordExpr -> thatThingIs <> " a record of type:"

246− TupleExpr -> thatThingIs <> " a tuple of type:"

247− UnitExpr -> thatThingIs <> " a unit value:"

248− Shader -> thatThingIs <> " a GLSL shader of type:"

249− Effects -> thatThingIs <> " a thing for CORE LIBRARIES ONLY."

250− CallResult maybeName ->

251− case maybeName of

252− NoName -> thatThingIs <> ":"

253− FuncName name -> "This `" <> N.toString name <> "` call produces:"

254− CtorName name -> "This `" <> N.toString name <> "` call produces:"

255− OpName _ -> thatThingIs <> ":"

180+toDescription :: Category -> String -> String

181+toDescription category thatThingIs =

182+ case category of

183+ Local name -> "This `" <> N.toString name <> "` value has type:"

184+ Foreign name -> "This `" <> N.toString name <> "` value has type:"

185+ Access field -> "The value at ." <> N.toString field <> " has type:"

186+ Accessor field -> "This ." <> N.toString field <> " field access function has type:"

187+ If -> "This `if` expression produces a value of type:"

188+ Case -> "This `case` expression produces a value of type:"

189+ List -> thatThingIs <> " a list of type:"

190+ Number -> thatThingIs <> " a number of type:"

191+ Float -> thatThingIs <> " a float of type:"

192+ String -> thatThingIs <> " a string of type:"

193+ Char -> thatThingIs <> " a character of type:"

194+ Lambda -> thatThingIs <> " an anonymous function of type:"

195+ Record -> thatThingIs <> " a record of type:"

196+ Tuple -> thatThingIs <> " a tuple of type:"

197+ Unit -> thatThingIs <> " a unit value:"

198+ Shader -> thatThingIs <> " a GLSL shader of type:"

199+ Effects -> thatThingIs <> " a thing for CORE LIBRARIES ONLY."

200+ CallResult maybeName ->

201+ case maybeName of

202+ NoName -> thatThingIs <> ":"

203+ FuncName name -> "This `" <> N.toString name <> "` call produces:"

204+ CtorName name -> "This `" <> N.toString name <> "` call produces:"

205+ OpName _ -> thatThingIs <> ":"

256206

257207

258208

259209-- TO MISMATCH REPORT

260210

261211

262−toMismatchReport :: Code.Source -> Localizer -> R.Region -> Thing -> Type -> Expected Type -> Report.Report

263−toMismatchReport source localizer exprRegion thing tipe expected =

212+toMismatchReport :: Code.Source -> T.Localizer -> R.Region -> Category -> T.Type -> Expected T.Type -> Report.Report

213+toMismatchReport source localizer exprRegion category tipe expected =

264214 Report.Report "TYPE MISMATCH" exprRegion [] $

265215 case expected of

266216 NoExpectation expectedType ->

@@ -270,7 +220,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

270220 ,

271221 typeComparison localizer tipe expectedType

272222 (

273− toDescription thing "It is"

223+ toDescription category "It is"

274224 ,

275225 "But you are trying to use it as:"

276226 ,

@@ -296,7 +246,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

296246 ,

297247 typeComparison localizer tipe expectedType

298248 (

299− toDescription thing $

249+ toDescription category $

300250 case subContext of

301251 TypedIfBranch index ->

302252 "The " <> H.ordinalize (Index.toHuman index) <> " branch is"

@@ -328,7 +278,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

328278 ,

329279 typeComparison localizer tipe expectedType

330280 (

331− toDescription thing $

281+ toDescription category $

332282 "The " <> H.ordinalize (Index.toHuman index) <> " element is"

333283 ,

334284 "But all the previous elements in the list are:"

@@ -349,7 +299,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

349299 "I do not know how to negate this type of value:"

350300 ,

351301 H.stack

352− [ H.reflow $ toDescription thing "It is"

302+ [ H.reflow $ toDescription category "It is"

353303 , indentType localizer tipe

354304 , H.fillSep

355305 ["But","I","only","now","how","to","negate"

@@ -361,10 +311,10 @@ toMismatchReport source localizer exprRegion thing tipe expected =

361311

362312 OpLeft op ->

363313 Report.toCodeSnippet source region (Just exprRegion) $

364− opLeftToDocs localizer thing op tipe expectedType

314+ opLeftToDocs localizer category op tipe expectedType

365315

366316 OpRight op ->

367− case opRightToDocs localizer thing op tipe expectedType of

317+ case opRightToDocs localizer category op tipe expectedType of

368318 EmphBoth details ->

369319 Report.toCodeSnippet source region Nothing details

370320

@@ -377,7 +327,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

377327 "This `if` condition does not evaluate to a boolean value, True or False."

378328 ,

379329 H.stack

380− [ H.reflow $ toDescription thing "It is"

330+ [ H.reflow $ toDescription category "It is"

381331 , indentType localizer tipe

382332 , H.fillSep ["But","I","need","this","`if`","condition","to","be","a",H.dullyellow "Bool","value."]

383333 , H.toSimpleHint $

@@ -398,7 +348,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

398348 ,

399349 typeComparison localizer tipe expectedType

400350 (

401− toDescription thing $

351+ toDescription category $

402352 "The " <> H.ordinalize (Index.toHuman index) <> " branch is"

403353 ,

404354 "But all the previous branches result in:"

@@ -424,7 +374,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

424374 ,

425375 typeComparison localizer tipe expectedType

426376 (

427− toDescription thing $

377+ toDescription category $

428378 "The " <> H.ordinalize (Index.toHuman index) <> " branch is"

429379 ,

430380 "But all the previous branches result in:"

@@ -463,7 +413,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

463413 ,

464414 typeComparison localizer tipe expectedType

465415 (

466− toDescription thing "This argument is"

416+ toDescription category "This argument is"

467417 ,

468418 "But " <> thisFunction <> " needs the " <> H.ordinalize (Index.toHuman index)

469419 <> " argument to be:"

@@ -559,7 +509,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

559509 RecordAccess field ->

560510 Report.toCodeSnippet source region (Just exprRegion) $

561511 case error "TODO figure out record things" tipe of

562− Record _ _ ->

512+ T.Record _ _ ->

563513 (

564514 H.reflow $

565515 "This record does not have a `" <> N.toString field <> "` field:"

@@ -593,7 +543,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

593543 ]

594544 )

595545

596− Lambda _ _ ->

546+ T.Lambda _ _ _ ->

597547 (

598548 H.reflow $

599549 "I cannot access field `" <> N.toString field <> "` of this " <> whatever <> ":"

@@ -620,7 +570,7 @@ toMismatchReport source localizer exprRegion thing tipe expected =

620570

621571 RecordUpdate ->

622572 case error "TODO figure out record things" tipe of

623− Record _ _ ->

573+ T.Record _ _ ->

624574 Report.toCodeSnippet source region Nothing

625575 (

626576 H.reflow $

@@ -649,11 +599,11 @@ toMismatchReport source localizer exprRegion thing tipe expected =

649599-- COUNT ARGS

650600

651601

652−countArgs :: Type -> Int

602+countArgs :: T.Type -> Int

653603countArgs tipe =

654604 case tipe of

655− Lambda _ stuff ->

656− length stuff

605+ T.Lambda _ _ stuff ->

606+ 1 + length stuff

657607

658608 _ ->

659609 0

@@ -663,8 +613,8 @@ countArgs tipe =

663613-- OP LEFT

664614

665615

666−opLeftToDocs :: Localizer -> Thing -> N.Name -> Type -> Type -> (H.Doc, H.Doc)

667−opLeftToDocs localizer thing op tipe expectedType =

616+opLeftToDocs :: T.Localizer -> Category -> N.Name -> T.Type -> T.Type -> (H.Doc, H.Doc)

617+opLeftToDocs localizer category op tipe expectedType =

668618 case op of

669619 "+"

670620 | isString tipe -> badStringAdd

@@ -681,10 +631,10 @@ opLeftToDocs localizer thing op tipe expectedType =

681631 "//" -> badIDiv localizer "left" tipe

682632 "&&" -> badBool localizer "&&" "left" tipe

683633 "||" -> badBool localizer "||" "left" tipe

684− "<" -> badCompLeft localizer thing "<" "left" tipe

685− ">" -> badCompLeft localizer thing ">" "left" tipe

686− "<=" -> badCompLeft localizer thing "<=" "left" tipe

687− ">=" -> badCompLeft localizer thing ">=" "left" tipe

634+ "<" -> badCompLeft localizer category "<" "left" tipe

635+ ">" -> badCompLeft localizer category ">" "left" tipe

636+ "<=" -> badCompLeft localizer category "<=" "left" tipe

637+ ">=" -> badCompLeft localizer category ">=" "left" tipe

688638

689639 "<|" ->

690640 ( "The left side of (<|) needs to be a function so I can pipe arguments to it!"

@@ -712,7 +662,7 @@ opLeftToDocs localizer thing op tipe expectedType =

712662 ,

713663 typeComparison localizer tipe expectedType

714664 (

715− toDescription thing "The left argument is"

665+ toDescription category "The left argument is"

716666 ,

717667 "But (" <> N.toString op <> ") needs the left argument to be:"

718668 ,

@@ -730,8 +680,8 @@ data RightDocs

730680 | EmphRight (H.Doc, H.Doc)

731681

732682

733−opRightToDocs :: Localizer -> Thing -> N.Name -> Type -> Type -> RightDocs

734−opRightToDocs localizer thing op tipe expectedType =

683+opRightToDocs :: T.Localizer -> Category -> N.Name -> T.Type -> T.Type -> RightDocs

684+opRightToDocs localizer category op tipe expectedType =

735685 case op of

736686 "+"

737687 | isInt tipe -> badCast op FloatInt

@@ -778,7 +728,7 @@ opRightToDocs localizer thing op tipe expectedType =

778728 ,

779729 typeComparison localizer tipe expectedType

780730 (

781− toDescription thing "You are providing"

731+ toDescription category "You are providing"

782732 ,

783733 "But (<|) is piping it a function that expects:"

784734 ,

@@ -790,9 +740,10 @@ opRightToDocs localizer thing op tipe expectedType =

790740

791741 "|>" ->

792742 case (tipe, expectedType) of

793− (Lambda expectedArgType _, Lambda argType _) ->

743+ (T.Lambda expectedArgType _ _, T.Lambda argType _ _) ->

794744 EmphRight

795745 (

746+ -- TODO try to say the function name instead of "this function"

796747 "I cannot pipe the argument through to this function:"

797748 ,

798749 typeComparison localizer argType expectedArgType

@@ -847,7 +798,7 @@ opRightToDocs localizer thing op tipe expectedType =

847798 ,

848799 typeComparison localizer tipe expectedType

849800 (

850− toDescription thing "The right argument is"

801+ toDescription category "The right argument is"

851802 ,

852803 "But (" <> N.toString op <> ") needs the right argument to be:"

853804 ,

@@ -862,40 +813,40 @@ opRightToDocs localizer thing op tipe expectedType =

862813

863814

864815

865−isInt :: Type -> Bool

816+isInt :: T.Type -> Bool

866817isInt tipe =

867818 case tipe of

868− Type home name [] ->

819+ T.Type home name [] ->

869820 home == ModuleName.basics && name == N.int

870821

871822 _ ->

872823 False

873824

874825

875−isFloat :: Type -> Bool

826+isFloat :: T.Type -> Bool

876827isFloat tipe =

877828 case tipe of

878− Type home name [] ->

829+ T.Type home name [] ->

879830 home == ModuleName.basics && name == N.float

880831

881832 _ ->

882833 False

883834

884835

885−isString :: Type -> Bool

836+isString :: T.Type -> Bool

886837isString tipe =

887838 case tipe of

888− Type home name [] ->

839+ T.Type home name [] ->

889840 home == ModuleName.string && name == N.string

890841

891842 _ ->

892843 False

893844

894845

895−isList :: Type -> Bool

846+isList :: T.Type -> Bool

896847isList tipe =

897848 case tipe of

898− Type home name [_] ->

849+ T.Type home name [_] ->

899850 home == ModuleName.list && name == N.list

900851

901852 _ ->

@@ -969,7 +920,7 @@ badStringAdd =

969920 )

970921

971922

972−badListAdd :: Localizer -> String -> Type -> (H.Doc, H.Doc)

923+badListAdd :: T.Localizer -> String -> T.Type -> (H.Doc, H.Doc)

973924badListAdd localizer direction tipe =

974925 (

975926 "I cannot do addition with lists:"

@@ -988,7 +939,7 @@ badListAdd localizer direction tipe =

988939 )

989940

990941

991−badListMul :: Localizer -> String -> Type -> (H.Doc, H.Doc)

942+badListMul :: T.Localizer -> String -> T.Type -> (H.Doc, H.Doc)

992943badListMul localizer direction tipe =

993944 badMath localizer "Multiplication" direction "*" tipe

994945 [

@@ -1000,7 +951,7 @@ badListMul localizer direction tipe =

1000951 ]

1001952

1002953

1003−badMath :: Localizer -> String -> String -> String -> Type -> [H.Doc] -> (H.Doc, H.Doc)

954+badMath :: T.Localizer -> String -> String -> String -> T.Type -> [H.Doc] -> (H.Doc, H.Doc)

1004955badMath localizer operation direction op tipe otherHints =

1005956 (

1006957 H.reflow $

@@ -1020,7 +971,7 @@ badMath localizer operation direction op tipe otherHints =

1020971 )

1021972

1022973

1023−badFDiv :: Localizer -> H.Doc -> Type -> (H.Doc, H.Doc)

974+badFDiv :: T.Localizer -> H.Doc -> T.Type -> (H.Doc, H.Doc)

1024975badFDiv localizer direction tipe =

1025976 (

1026977 H.reflow $

@@ -1053,7 +1004,7 @@ badFDiv localizer direction tipe =

10531004 )

10541005

10551006

1056−badIDiv :: Localizer -> H.Doc -> Type -> (H.Doc, H.Doc)

1007+badIDiv :: T.Localizer -> H.Doc -> T.Type -> (H.Doc, H.Doc)

10571008badIDiv localizer direction tipe =

10581009 (

10591010 H.reflow $

@@ -1092,7 +1043,7 @@ badIDiv localizer direction tipe =

10921043-- BAD BOOLS

10931044

10941045

1095−badBool :: Localizer -> H.Doc -> H.Doc -> Type -> (H.Doc, H.Doc)

1046+badBool :: T.Localizer -> H.Doc -> H.Doc -> T.Type -> (H.Doc, H.Doc)

10961047badBool localizer op direction tipe =

10971048 (

10981049 H.reflow $

@@ -1115,14 +1066,14 @@ badBool localizer op direction tipe =

11151066-- BAD COMPARISON

11161067

11171068

1118−badCompLeft :: Localizer -> Thing -> String -> String -> Type -> (H.Doc, H.Doc)

1119−badCompLeft localizer thing op direction tipe =

1069+badCompLeft :: T.Localizer -> Category -> String -> String -> T.Type -> (H.Doc, H.Doc)

1070+badCompLeft localizer category op direction tipe =

11201071 (

11211072 H.reflow $

11221073 "I cannot do a comparison with this value:"

11231074 ,

11241075 H.stack

1125− [ H.reflow $ toDescription thing $

1076+ [ H.reflow $ toDescription category $

11261077 "The " <> direction <> " side of (" <> op <> ") is"

11271078 , indentType localizer tipe

11281079 , H.fillSep

@@ -1139,7 +1090,7 @@ badCompLeft localizer thing op direction tipe =

11391090 )

11401091

11411092

1142−badCompRight :: Localizer -> String -> Type -> Type -> RightDocs

1093+badCompRight :: T.Localizer -> String -> T.Type -> T.Type -> RightDocs

11431094badCompRight localizer op tipe expectedType =

11441095 EmphBoth

11451096 (

@@ -1163,7 +1114,7 @@ badCompRight localizer op tipe expectedType =

11631114-- BAD EQUALITY

11641115

11651116

1166−badEquality :: Localizer -> String -> Type -> Type -> RightDocs

1117+badEquality :: T.Localizer -> String -> T.Type -> T.Type -> RightDocs

11671118badEquality localizer op tipe expectedType =

11681119 EmphBoth

11691120 (

@@ -1195,10 +1146,7 @@ badEquality localizer op tipe expectedType =

11951146-- DIFF TYPES

11961147

11971148

1198−type Localizer = Map.Map N.Name ()

1199−

1200−

1201−typeComparison :: Localizer -> Type -> Type -> ( String, String, [H.Doc] ) -> H.Doc

1149+typeComparison :: T.Localizer -> T.Type -> T.Type -> ( String, String, [H.Doc] ) -> H.Doc

12021150typeComparison localizer actual expected ( iAmSeeing, insteadOf, soHereAreSomeThoughts ) =

12031151 let

12041152 (actualDoc, expectedDoc) =

@@ -1213,7 +1161,7 @@ typeComparison localizer actual expected ( iAmSeeing, insteadOf, soHereAreSomeTh

12131161 ++ soHereAreSomeThoughts

12141162

12151163

1216−indentType :: Localizer -> Type -> H.Doc

1164+indentType :: T.Localizer -> T.Type -> H.Doc

12171165indentType localizer tipe =

12181166 H.indent 4 (H.dullyellow (error "TODO Type.toDoc" localizer tipe))

12191167

src/Type/Constrain/Expression.hs+6−6

@@ -144,7 +144,7 @@ constrain rtv (A.At region expression) expected =

144144 constrainRecord rtv region fields expected

145145

146146 Can.Unit ->

147− return $ CEqual region UnitExpr UnitN expected

147+ return $ CEqual region Unit UnitN expected

148148

149149 Can.Tuple a b maybeC ->

150150 constrainTuple rtv region a b maybeC expected

@@ -174,7 +174,7 @@ constrainLambda rtv region args body expected =

174174 , _headerCon = CAnd (reverse revCons)

175175 , _bodyCon = bodyCon

176176 }

177− , CEqual region LambdaExpr tipe expected

177+ , CEqual region Lambda tipe expected

178178 ]

179179

180180

@@ -403,7 +403,7 @@ constrainRecord rtv region fields expected =

403403

404404 let getType (_, t, _) = t

405405 let recordType = RecordN (Map.map getType dict) EmptyRecordN

406− let recordCon = CEqual region RecordExpr recordType expected

406+ let recordCon = CEqual region Record recordType expected

407407

408408 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict

409409 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict

@@ -437,7 +437,7 @@ constrainUpdate rtv region expr fields expected =

437437

438438 let getType (_, t, _) = t

439439 let newRecordType = RecordN (Map.map getType newDict) sharedType

440− let newCon = CEqual region RecordExpr newRecordType expected

440+ let newCon = CEqual region Record newRecordType expected

441441

442442 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict

443443 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict

@@ -462,7 +462,7 @@ constrainTuple rtv region a b maybeC expected =

462462 case maybeC of

463463 Nothing ->

464464 do let tupleType = TupleN aType bType Nothing

465− let tupleCon = CEqual region TupleExpr tupleType expected

465+ let tupleCon = CEqual region Tuple tupleType expected

466466 return $ exists [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]

467467

468468 Just c ->

@@ -472,7 +472,7 @@ constrainTuple rtv region a b maybeC expected =

472472 cCon <- constrain rtv c (NoExpectation cType)

473473

474474 let tupleType = TupleN aType bType (Just cType)

475− let tupleCon = CEqual region TupleExpr tupleType expected

475+ let tupleCon = CEqual region Tuple tupleType expected

476476

477477 return $ exists [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]

478478

src/Type/Error.hsnew file+157

@@ -0,0 +1,157 @@

1+module Type.Error

2+ ( Type(..)

3+ , Extension(..)

4+ , iteratedDealias

5+ , Localizer

6+ )

7+ where

10+import qualified Data.Map as Map

11+

12+import qualified AST.Module.Name as ModuleName

13+import qualified Elm.Name as N

14+

15+

16+

17+-- ERROR TYPES

18+

19+

20+data Type

21+ = Lambda Type Type [Type]

22+ | Infinite

23+ | Error

24+ | FlexVar N.Name

25+ | FlexSuper N.Name

26+ | RigidVar N.Name

27+ | RigidSuper N.Name

28+ | Type ModuleName.Canonical N.Name [Type]

29+ | Record (Map.Map N.Name Type) Extension

30+ | Unit

31+ | Tuple Type Type (Maybe Type)

32+ | Alias ModuleName.Canonical N.Name [(N.Name, Type)] Type

33+

34+

35+data Extension

36+ = Closed

37+ | FlexOpen N.Name

38+ | RigidOpen N.Name

39+

40+

41+iteratedDealias :: Type -> Type

42+iteratedDealias tipe =

43+ case tipe of

44+ Alias _ _ _ realType ->

45+ iteratedDealias realType

46+

47+ _ ->

48+ tipe

49+

50+

51+

52+-- LOCALIZE

53+

54+

55+type Localizer = Map.Map N.Name ()

56+

57+

58+

59+

60+{-- DIFF

61+

62+

63+data Diff

64+ = TooFewArgs

65+ |

66+

67+

68+

69+

70+-- DETECT MISSING ARGS

71+

72+

73+detectMissingArgs :: Type -> Type -> Maybe (Type, [Type])

74+detectMissingArgs actual expected =

75+ detectMissingArgsHelp (reverseArgs actual) (reverseArgs expected)

76+

77+

78+detectMissingArgsHelp :: [Type] -> [Type] -> Maybe (Type, [Type])

79+detectMissingArgsHelp actuals expecteds =

80+ case (actuals, expecteds) of

81+ (x:xs, y:ys) -> if isMatchy x y then detectMissingArgsHelp xs ys else Nothing

82+ (x:xs, []) -> Just (x, xs)

83+ ([], []) -> Nothing

84+ ([], _:_) -> Nothing

85+

86+

87+reverseArgs :: Type -> [Type]

88+reverseArgs tipe =

89+ case tipe of

90+ Lambda a b cs -> reverse (a:b:cs)

91+ Infinite -> [tipe]

92+ Error -> [tipe]

93+ FlexVar _ -> [tipe]

94+ FlexSuper _ -> [tipe]

95+ RigidVar _ -> [tipe]

96+ RigidSuper _ -> [tipe]

97+ Type _ _ _ -> [tipe]

98+ Record _ _ -> [tipe]

99+ Unit -> [tipe]

100+ Tuple _ _ _ -> [tipe]

101+ Alias _ _ _ t -> reverseArgs t

102+

103+

104+isMatchy :: Type -> Type -> Bool

105+isMatchy t1 t2 =

106+ case (t1, t2) of

107+ (Lambda a b cs, Lambda x y zs) ->

108+ isMatchy a x && isMatchy b y && length cs == length zs && and (zipWith isMatchy cs zs)

109+

110+ (Infinite, Infinite) ->

111+ True

112+

113+ (Error, Error) ->

114+ True

115+

116+ (FlexVar _, _) ->

117+ True

118+

119+ (_, FlexVar _) ->

120+ True

121+

122+ (FlexSuper x, FlexSuper y) ->

123+ x == y

124+

125+ (RigidVar x, RigidVar y) ->

126+ x == y

127+

128+ (RigidSuper x, RigidSuper y) ->

129+ x == y

130+

131+ (Type home1 name1 args1, Type home2 name2 args2) ->

132+ home1 == home2 && name1 == name2 && and (zipWith isMatchy args1 args2)

133+

134+ (Record fields1 ext1, Record fields2 ext2) ->

135+ isMatchRecord

136+ (Map.size (Map.difference fields1 fields2))

137+ (Map.intersectionWith isMatchy fields1 fields2)

138+ (Map.size (Map.difference fields2 fields1))

139+

140+ (Unit, Unit) ->

141+ True

142+

143+ (Tuple a b Nothing, Tuple x y Nothing) ->

144+ isMatchy a x && isMatchy b y

145+

146+ (Tuple a b (Just c), Tuple x y (Just z)) ->

147+ isMatchy a x && isMatchy b y && isMatchy c z

148+

149+ (Alias _ _ _ alias1, tipe2) ->

150+ isMatchy alias1 tipe2

151+

152+ (tipe1, Alias _ _ _ alias2) ->

153+ isMatchy tipe1 alias2

154+

155+ (_, _) ->

156+ False

157+-}

src/Type/Solve.hs+6−9

@@ -89,9 +89,8 @@ solve env rank pools state constraint =

8989 Unify.Err vars actualType expectedType ->

9090 do introduce rank pools vars

9191 return $ addError state $

92− Error.Mismatch

93− (Error.BadExpr region category actualType)

94− (Error.typeReplace expectation expectedType)

92+ Error.Mismatch region category actualType $

93+ Error.typeReplace expectation expectedType

9594

9695 CLocal region name expectation ->

9796 do actual <- makeCopy rank pools (env ! name)

@@ -105,9 +104,8 @@ solve env rank pools state constraint =

105104 Unify.Err vars actualType expectedType ->

106105 do introduce rank pools vars

107106 return $ addError state $

108− Error.Mismatch

109− (Error.BadLocal region name actualType)

110− (Error.typeReplace expectation expectedType)

107+ Error.Mismatch region (Error.Local name) actualType $

108+ Error.typeReplace expectation expectedType

111109

112110 CForeign region name (Can.Forall freeVars srcType) expectation ->

113111 do actual <- srcTypeToVariable rank pools freeVars srcType

@@ -121,9 +119,8 @@ solve env rank pools state constraint =

121119 Unify.Err vars actualType expectedType ->

122120 do introduce rank pools vars

123121 return $ addError state $

124− Error.Mismatch

125− (Error.BadForeign region name actualType)

126− (Error.typeReplace expectation expectedType)

122+ Error.Mismatch region (Error.Foreign name) actualType $

123+ Error.typeReplace expectation expectedType

127124

128125 CPattern region category tipe expectation ->

129126 do actual <- typeToVariable rank pools tipe

src/Type/Type.hs+28−38

@@ -42,6 +42,7 @@ import qualified Elm.Name as N

4242import qualified Reporting.Annotation as A

4343import qualified Reporting.Error.Type as E

4444import qualified Reporting.Region as R

45+import qualified Type.Error as ET

4546import qualified Type.UnionFind as UF

4647

4748

@@ -432,19 +433,19 @@ termToCanType term =

432433-- TO ERROR TYPE

433434

434435

435−toErrorType :: Variable -> IO E.Type

436+toErrorType :: Variable -> IO ET.Type

436437toErrorType variable =

437438 do userNames <- getVarNames variable Map.empty

438439 State.evalStateT (variableToErrorType variable) (makeNameState userNames)

439440

440441

441−variableToErrorType :: Variable -> StateT NameState IO E.Type

442+variableToErrorType :: Variable -> StateT NameState IO ET.Type

442443variableToErrorType variable =

443444 do descriptor <- liftIO $ UF.get variable

444445 let mark = _mark descriptor

445446 if mark == occursMark

446447 then

447− return E.Infinite

448+ return ET.Infinite

448449

449450 else

450451 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })

@@ -453,7 +454,7 @@ variableToErrorType variable =

453454 return errType

454455

455456

456−contentToErrorType :: Variable -> Content -> StateT NameState IO E.Type

457+contentToErrorType :: Variable -> Content -> StateT NameState IO ET.Type

457458contentToErrorType variable content =

458459 case content of

459460 Structure term ->

@@ -462,96 +463,85 @@ contentToErrorType variable content =

462463 FlexVar maybeName ->

463464 case maybeName of

464465 Just name ->

465− return (E.FlexVar name)

466+ return (ET.FlexVar name)

466467

467468 Nothing ->

468469 do name <- getFreshVarName

469470 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })

470− return (E.FlexVar name)

471+ return (ET.FlexVar name)

471472

472473 FlexSuper super maybeName ->

473474 case maybeName of

474475 Just name ->

475− return (E.FlexSuper name)

476+ return (ET.FlexSuper name)

476477

477478 Nothing ->

478479 do name <- getFreshSuperName super

479480 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })

480− return (E.FlexSuper name)

481+ return (ET.FlexSuper name)

481482

482483 RigidVar name ->

483− return (E.RigidVar name)

484+ return (ET.RigidVar name)

484485

485486 RigidSuper _ name ->

486− return (E.RigidSuper name)

487+ return (ET.RigidSuper name)

487488

488489 Alias home name args realVariable ->

489490 do errArgs <- traverse (traverse variableToErrorType) args

490491 errType <- variableToErrorType realVariable

491− return (E.Alias home name errArgs errType)

492+ return (ET.Alias home name errArgs errType)

492493

493494 Error ->

494− return E.Error

495+ return ET.Error

495496

496497

497−termToErrorType :: FlatType -> StateT NameState IO E.Type

498+termToErrorType :: FlatType -> StateT NameState IO ET.Type

498499termToErrorType term =

499500 case term of

500501 App1 home name args ->

501− E.Type home name <$> traverse variableToErrorType args

502+ ET.Type home name <$> traverse variableToErrorType args

502503

503504 Fun1 a b ->

504505 do arg <- variableToErrorType a

505506 result <- variableToErrorType b

506507 return $

507508 case result of

508− E.Lambda arg2 others ->

509− E.Lambda arg (arg2:others)

509+ ET.Lambda arg1 arg2 others ->

510+ ET.Lambda arg arg1 (arg2:others)

510511

511512 _ ->

512− E.Lambda arg [result]

513+ ET.Lambda arg result []

513514

514515 EmptyRecord1 ->

515− return $ E.Record Map.empty E.Closed

516+ return $ ET.Record Map.empty ET.Closed

516517

517518 Record1 fields extension ->

518519 do errFields <- traverse variableToErrorType fields

519− errExt <- iteratedErrorTypeDealias <$> variableToErrorType extension

520+ errExt <- ET.iteratedDealias <$> variableToErrorType extension

520521 return $

521522 case errExt of

522− E.Record subFields subExt ->

523− E.Record (Map.union subFields errFields) subExt

523+ ET.Record subFields subExt ->

524+ ET.Record (Map.union subFields errFields) subExt

524525

525− E.FlexVar ext ->

526− E.Record errFields (E.FlexOpen ext)

526+ ET.FlexVar ext ->

527+ ET.Record errFields (ET.FlexOpen ext)

527528

528− E.RigidVar ext ->

529− E.Record errFields (E.RigidOpen ext)

529+ ET.RigidVar ext ->

530+ ET.Record errFields (ET.RigidOpen ext)

530531

531532 _ ->

532533 error "Used toErrorType on a type that is not well-formed"

533534

534535 Unit1 ->

535− return E.Unit

536+ return ET.Unit

536537

537538 Tuple1 a b maybeC ->

538− E.Tuple

539+ ET.Tuple

539540 <$> variableToErrorType a

540541 <*> variableToErrorType b

541542 <*> traverse variableToErrorType maybeC

542543

543544

544−iteratedErrorTypeDealias :: E.Type -> E.Type

545−iteratedErrorTypeDealias tipe =

546− case tipe of

547− E.Alias _ _ _ realType ->

548− iteratedErrorTypeDealias realType

549−

550− _ ->

551− tipe

552−

553−

554−

555545

556546-- MANAGE FRESH VARIABLE NAMES

557547

src/Type/Unify.hs+1−1

@@ -11,7 +11,7 @@ import qualified Data.Map.Strict as Map

1111

1212import qualified AST.Module.Name as ModuleName

1313import qualified Elm.Name as N

14−import qualified Reporting.Error.Type as Error

14+import qualified Type.Error as Error

1515import qualified Type.Occurs as Occurs

1616import Type.Type as Type

1717import qualified Type.UnionFind as UF