on master help sign in
Get rid of Type.State and Solver monad

Instead of a custom Solver monad, the new Type.Solve code uses plain IO and threads some state around. This means that some things (env, rank, pools) can just be “environment variables” whereas the data that really is stateful is threaded through. Benefits include: - No need to allocate new State objects when using a new env. Just pass the new env down instead. - State holds three items, not six. Generates less garbage. - No indirection between using IO. No more liftIO anywhere. - When operating on a list, just foldM and accumulate state. No need for traverse_ or mapM_ or whatever other tricks to try to avoid allocating pointless intermediate lists. This change also required some supporting changes in Type.Unify and Type.Constraint to minimize the overall allocations needed on the successful path of unification. Do not want to allocate when solving constraints unless an error occurred. As a final reflection, I find it frustrating that the simpler code (without monad transformers, custom monads, CPS’d monads, etc.) is better in a bunch of ways. It feels like the ecosystem offers you a tool that ultimately makes your code harder to understand and less performant. This is a good lesson.

commit8b03cb751e80940a0b69939174a94321d9a2893c authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 21 Nov 2017, 12:18 (9 years ago) parentd3fa290
6 files changed+789−700
src/Type/Constrain/Expression.hs+69−69 src/Type/Constrain/Pattern.hs+12−12 src/Type/Constraint.hs+53−24 src/Type/Solve.hs+518−141 src/Type/State.hs−369 src/Type/Unify.hs+137−85
src/Type/Constrain/Expression.hs+69−69
@@ -35,73 +35,73 @@ type RTV =
3535 Map.Map N.Name Type
3636
3737
38−constrain :: RTV -> Can.Expr -> Expectation -> IO Constraint
39−constrain rtv (A.At region expression) expectation =
38+constrain :: RTV -> Can.Expr -> Expected Type -> IO Constraint
39+constrain rtv (A.At region expression) expected =
4040 case expression of
4141 Can.VarLocal name ->
42− return (CLookup region name expectation)
42+ return (CLookup region name expected)
4343
4444 Can.VarTopLevel _ name ->
45− return (CLookup region name expectation)
45+ return (CLookup region name expected)
4646
4747 Can.VarKernel _ _ ->
4848 return CTrue
4949
5050 Can.VarForeign _ name annotation ->
51− return $ CInstance region (FuncName name) annotation expectation
51+ return $ CInstance region (FuncName name) annotation expected
5252
5353 Can.VarOperator op _ _ annotation ->
54− return $ CInstance region (OpName op) annotation expectation
54+ return $ CInstance region (OpName op) annotation expected
5555
5656 Can.Str _ ->
57− return $ CEqual region String Type.string expectation
57+ return $ CEqual region String Type.string expected
5858
5959 Can.Chr _ ->
60− return $ CEqual region Char Type.char expectation
60+ return $ CEqual region Char Type.char expected
6161
6262 Can.Int _ ->
6363 do var <- mkFlexNumber
64− return $ exists [var] $ CEqual region C.Number (VarN var) expectation
64+ return $ exists [var] $ CEqual region C.Number (VarN var) expected
6565
6666 Can.Float _ ->
67− return $ CEqual region Float Type.float expectation
67+ return $ CEqual region Float Type.float expected
6868
6969 Can.List elements ->
70− constrainList rtv region elements expectation
70+ constrainList rtv region elements expected
7171
7272 Can.Negate expr ->
7373 do numberVar <- mkFlexNumber
7474 let numberType = VarN numberVar
7575 numberCon <- constrain rtv expr (FromContext region Negate numberType)
76− let negateCon = CEqual region C.Number numberType expectation
76+ let negateCon = CEqual region C.Number numberType expected
7777 return $ exists [numberVar] $ CAnd [ numberCon, negateCon ]
7878
7979 Can.Binop op _ _ annotation leftExpr rightExpr ->
80− constrainBinop rtv region op annotation leftExpr rightExpr expectation
80+ constrainBinop rtv region op annotation leftExpr rightExpr expected
8181
8282 Can.Lambda args _ body ->
83− constrainLambda rtv region args body expectation
83+ constrainLambda rtv region args body expected
8484
8585 Can.Call func args ->
86− constrainCall rtv region func args expectation
86+ constrainCall rtv region func args expected
8787
8888 Can.If branches finally ->
89− constrainIf rtv region branches finally expectation
89+ constrainIf rtv region branches finally expected
9090
9191 Can.Case expr branches ->
92− constrainCase rtv region expr branches expectation
92+ constrainCase rtv region expr branches expected
9393
9494 Can.Let def body ->
9595 constrainDef rtv def
96− =<< constrain rtv body expectation
96+ =<< constrain rtv body expected
9797
9898 Can.LetRec defs body ->
9999 constrainRecursiveDefs rtv defs
100− =<< constrain rtv body expectation
100+ =<< constrain rtv body expected
101101
102102 Can.LetDestruct pattern _ expr body ->
103103 constrainDestruct rtv region pattern expr
104− =<< constrain rtv body expectation
104+ =<< constrain rtv body expected
105105
106106 Can.Accessor field ->
107107 do extVar <- mkFlexVar
@@ -110,7 +110,7 @@ constrain rtv (A.At region expression) expectation =
110110 let fieldType = VarN fieldVar
111111 let recordType = RecordN (Map.singleton field fieldType) extType
112112 return $ exists [ fieldVar, extVar ] $
113− CEqual region (Accessor field) (FunN recordType fieldType) expectation
113+ CEqual region (Accessor field) (FunN recordType fieldType) expected
114114
115115 Can.Access expr field ->
116116 do extVar <- mkFlexVar
@@ -125,31 +125,31 @@ constrain rtv (A.At region expression) expectation =
125125 return $ exists [ fieldVar, extVar ] $
126126 CAnd
127127 [ recordCon
128− , CEqual region (Access field) recordType expectation
128+ , CEqual region (Access field) recordType expected
129129 ]
130130
131131 Can.Update expr fields ->
132− constrainUpdate rtv region expr fields expectation
132+ constrainUpdate rtv region expr fields expected
133133
134134 Can.Record fields ->
135− constrainRecord rtv region fields expectation
135+ constrainRecord rtv region fields expected
136136
137137 Can.Unit ->
138− return $ CEqual region Unit UnitN expectation
138+ return $ CEqual region Unit UnitN expected
139139
140140 Can.Tuple a b maybeC ->
141− constrainTuple rtv region a b maybeC expectation
141+ constrainTuple rtv region a b maybeC expected
142142
143143 Can.Shader _uid _src glType ->
144− constrainShader region glType expectation
144+ constrainShader region glType expected
145145
146146
147147
148148-- CONSTRAIN LAMBDA
149149
150150
151−constrainLambda :: RTV -> R.Region -> [Can.Arg] -> Can.Expr -> Expectation -> IO Constraint
152−constrainLambda rtv region args body expectation =
151+constrainLambda :: RTV -> R.Region -> [Can.Arg] -> Can.Expr -> Expected Type -> IO Constraint
152+constrainLambda rtv region args body expected =
153153 do (Args vars tipe resultType (Pattern.State headers pvars revCons)) <-
154154 constrainArgs args
155155
@@ -165,7 +165,7 @@ constrainLambda rtv region args body expectation =
165165 , _headerCon = CAnd (reverse revCons)
166166 , _bodyCon = bodyCon
167167 }
168− , CEqual region Lambda tipe expectation
168+ , CEqual region Lambda tipe expected
169169 ]
170170
171171
@@ -173,8 +173,8 @@ constrainLambda rtv region args body expectation =
173173-- CONSTRAIN CALL
174174
175175
176−constrainCall :: RTV -> R.Region -> Can.Expr -> [Can.Expr] -> Expectation -> IO Constraint
177−constrainCall rtv region func args expectation =
176+constrainCall :: RTV -> R.Region -> Can.Expr -> [Can.Expr] -> Expected Type -> IO Constraint
177+constrainCall rtv region func args expected =
178178 do let maybeFuncName = getFuncName func
179179
180180 funcVar <- mkFlexVar
@@ -188,7 +188,7 @@ constrainCall rtv region func args expectation =
188188 unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeFuncName) args
189189
190190 let arityType = foldr FunN resultType argTypes
191− let resultCon = CEqual region (CallResult maybeFuncName) resultType expectation
191+ let resultCon = CEqual region (CallResult maybeFuncName) resultType expected
192192
193193 return $ exists (funcVar:resultVar:argVars) $
194194 CAnd
@@ -250,8 +250,8 @@ getFuncName (A.At _ expr) =
250250-- CONSTRAIN BINOP
251251
252252
253−constrainBinop :: RTV -> R.Region -> N.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> Expectation -> IO Constraint
254−constrainBinop rtv region op annotation leftExpr rightExpr expectation =
253+constrainBinop :: RTV -> R.Region -> N.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> Expected Type -> IO Constraint
254+constrainBinop rtv region op annotation leftExpr rightExpr expected =
255255 do leftVar <- mkFlexVar
256256 rightVar <- mkFlexVar
257257 answerVar <- mkFlexVar
@@ -270,7 +270,7 @@ constrainBinop rtv region op annotation leftExpr rightExpr expectation =
270270 [ opCon
271271 , leftCon
272272 , rightCon
273− , CEqual region (CallResult (Just (OpName op))) answerType expectation
273+ , CEqual region (CallResult (Just (OpName op))) answerType expected
274274 ]
275275
276276
@@ -278,8 +278,8 @@ constrainBinop rtv region op annotation leftExpr rightExpr expectation =
278278-- CONSTRAIN LISTS
279279
280280
281−constrainList :: RTV -> R.Region -> [Can.Expr] -> Expectation -> IO Constraint
282−constrainList rtv region entries expectation =
281+constrainList :: RTV -> R.Region -> [Can.Expr] -> Expected Type -> IO Constraint
282+constrainList rtv region entries expected =
283283 do entryVar <- mkFlexVar
284284 let entryType = VarN entryVar
285285 let listType = AppN ModuleName.list N.list [entryType]
@@ -290,7 +290,7 @@ constrainList rtv region entries expectation =
290290 return $ exists [entryVar] $
291291 CAnd
292292 [ CAnd entryCons
293− , CEqual region List listType expectation
293+ , CEqual region List listType expected
294294 ]
295295
296296
@@ -303,15 +303,15 @@ constrainListEntry rtv region tipe index expr =
303303-- CONSTRAIN IF EXPRESSIONS
304304
305305
306−constrainIf :: RTV -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Expectation -> IO Constraint
307−constrainIf rtv region branches final expectation =
306+constrainIf :: RTV -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Expected Type -> IO Constraint
307+constrainIf rtv region branches final expected =
308308 do let boolExpect = FromContext region IfCondition Type.bool
309309 let (conditions, exprs) = foldr (\(c,e) (cs,es) -> (c:cs,e:es)) ([],[final]) branches
310310
311311 condCons <-
312312 traverse (\c -> constrain rtv c boolExpect) conditions
313313
314− case expectation of
314+ case expected of
315315 FromAnnotation name arity _ tipe ->
316316 do branchCons <- Index.indexedForA exprs $ \index expr ->
317317 constrain rtv expr (FromAnnotation name arity (TypedIfBranch index) tipe)
@@ -332,7 +332,7 @@ constrainIf rtv region branches final expectation =
332332 CAnd
333333 [ CAnd condCons
334334 , CAnd branchCons
335− , CEqual region If branchType expectation
335+ , CEqual region If branchType expected
336336 ]
337337
338338
@@ -340,17 +340,17 @@ constrainIf rtv region branches final expectation =
340340-- CONSTRAIN CASE EXPRESSIONS
341341
342342
343−constrainCase :: RTV -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Expectation -> IO Constraint
344−constrainCase rtv region expr branches expectation =
343+constrainCase :: RTV -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Expected Type -> IO Constraint
344+constrainCase rtv region expr branches expected =
345345 do ptrnVar <- mkFlexVar
346346 let ptrnType = VarN ptrnVar
347347 exprCon <- constrain rtv expr (NoExpectation ptrnType)
348348
349− case expectation of
349+ case expected of
350350 FromAnnotation name arity _ tipe ->
351351 do branchCons <- Index.indexedForA branches $ \index branch ->
352352 constrainCaseBranch rtv branch
353− (PatternExpectation region (PCaseMatch index) ptrnType)
353+ (PFromContext region (PCaseMatch index) ptrnType)
354354 (FromAnnotation name arity (TypedCaseBranch index) tipe)
355355
356356 return $ exists [ptrnVar] $ CAnd (exprCon:branchCons)
@@ -361,18 +361,18 @@ constrainCase rtv region expr branches expectation =
361361
362362 branchCons <- Index.indexedForA branches $ \index branch ->
363363 constrainCaseBranch rtv branch
364− (PatternExpectation region (PCaseMatch index) ptrnType)
364+ (PFromContext region (PCaseMatch index) ptrnType)
365365 (FromContext region (CaseBranch index) branchType)
366366
367367 return $ exists [ptrnVar,branchVar] $
368368 CAnd
369369 [ exprCon
370370 , CAnd branchCons
371− , CEqual region Case branchType expectation
371+ , CEqual region Case branchType expected
372372 ]
373373
374374
375−constrainCaseBranch :: RTV -> Can.CaseBranch -> PatternExpectation -> Expectation -> IO Constraint
375+constrainCaseBranch :: RTV -> Can.CaseBranch -> PExpected Type -> Expected Type -> IO Constraint
376376constrainCaseBranch rtv (Can.CaseBranch pattern _ expr) pExpect bExpect =
377377 do (Pattern.State headers pvars revCons) <-
378378 Pattern.add pattern pExpect Pattern.emptyState
@@ -385,13 +385,13 @@ constrainCaseBranch rtv (Can.CaseBranch pattern _ expr) pExpect bExpect =
385385-- CONSTRAIN RECORD
386386
387387
388−constrainRecord :: RTV -> R.Region -> Map.Map N.Name Can.Expr -> Expectation -> IO Constraint
389−constrainRecord rtv region fields expectation =
388+constrainRecord :: RTV -> R.Region -> Map.Map N.Name Can.Expr -> Expected Type -> IO Constraint
389+constrainRecord rtv region fields expected =
390390 do dict <- traverse (constrainField rtv) fields
391391
392392 let getType (_, t, _) = t
393393 let recordType = RecordN (Map.map getType dict) EmptyRecordN
394− let recordCon = CEqual region Record recordType expectation
394+ let recordCon = CEqual region Record recordType expected
395395
396396 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict
397397 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict
@@ -411,8 +411,8 @@ constrainField rtv expr =
411411-- CONSTRAIN RECORD UPDATE
412412
413413
414−constrainUpdate :: RTV -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Expectation -> IO Constraint
415−constrainUpdate rtv region expr fields expectation =
414+constrainUpdate :: RTV -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Expected Type -> IO Constraint
415+constrainUpdate rtv region expr fields expected =
416416 do sharedVar <- mkFlexVar
417417 let sharedType = VarN sharedVar
418418
@@ -425,7 +425,7 @@ constrainUpdate rtv region expr fields expectation =
425425
426426 let getType (_, t, _) = t
427427 let newRecordType = RecordN (Map.map getType newDict) sharedType
428− let newCon = CEqual region Record newRecordType expectation
428+ let newCon = CEqual region Record newRecordType expected
429429
430430 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict
431431 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict
@@ -437,8 +437,8 @@ constrainUpdate rtv region expr fields expectation =
437437-- CONSTRAIN TUPLE
438438
439439
440−constrainTuple :: RTV -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Expectation -> IO Constraint
441−constrainTuple rtv region a b maybeC expectation =
440+constrainTuple :: RTV -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Expected Type -> IO Constraint
441+constrainTuple rtv region a b maybeC expected =
442442 do aVar <- mkFlexVar
443443 bVar <- mkFlexVar
444444 let aType = VarN aVar
@@ -450,7 +450,7 @@ constrainTuple rtv region a b maybeC expectation =
450450 case maybeC of
451451 Nothing ->
452452 do let tupleType = TupleN aType bType Nothing
453− let tupleCon = CEqual region Tuple tupleType expectation
453+ let tupleCon = CEqual region Tuple tupleType expected
454454 return $ exists [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]
455455
456456 Just c ->
@@ -460,7 +460,7 @@ constrainTuple rtv region a b maybeC expectation =
460460 cCon <- constrain rtv c (NoExpectation cType)
461461
462462 let tupleType = TupleN aType bType (Just cType)
463− let tupleCon = CEqual region Tuple tupleType expectation
463+ let tupleCon = CEqual region Tuple tupleType expected
464464
465465 return $ exists [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]
466466
@@ -469,8 +469,8 @@ constrainTuple rtv region a b maybeC expectation =
469469-- CONSTRAIN SHADER
470470
471471
472−constrainShader :: R.Region -> Shader.Shader -> Expectation -> IO Constraint
473−constrainShader region (Shader.Shader attributes uniforms varyings) expectation =
472+constrainShader :: R.Region -> Shader.Shader -> Expected Type -> IO Constraint
473+constrainShader region (Shader.Shader attributes uniforms varyings) expected =
474474 do attrVar <- mkFlexVar
475475 unifVar <- mkFlexVar
476476 let attrType = VarN attrVar
@@ -484,7 +484,7 @@ constrainShader region (Shader.Shader attributes uniforms varyings) expectation
484484 ]
485485
486486 return $ exists [ attrVar, unifVar ] $
487− CEqual region Shader shaderType expectation
487+ CEqual region Shader shaderType expected
488488
489489
490490toShaderRecord :: Map.Map N.Name Shader.Type -> Type -> Type
@@ -517,7 +517,7 @@ constrainDestruct rtv region pattern expr bodyCon =
517517 let patternType = VarN patternVar
518518
519519 (Pattern.State headers pvars revCons) <-
520− Pattern.add pattern (NoPatternExpectation patternType) Pattern.emptyState
520+ Pattern.add pattern (PNoExpectation patternType) Pattern.emptyState
521521
522522 exprCon <-
523523 constrain rtv expr (FromContext region Destructure patternType)
@@ -563,9 +563,9 @@ constrainDef rtv def bodyCon =
563563 (TypedArgs tipe resultType (Pattern.State headers pvars revCons)) <-
564564 constrainTypedArgs newRtv name typedArgs srcResultType
565565
566− let expectation = FromAnnotation name (length typedArgs) TypedBody resultType
566+ let expected = FromAnnotation name (length typedArgs) TypedBody resultType
567567 exprCon <-
568− constrain newRtv expr expectation
568+ constrain newRtv expr expected
569569
570570 return $
571571 CLet
@@ -709,7 +709,7 @@ argsHelp args state =
709709
710710 (Args vars tipe result newState) <-
711711 argsHelp otherArgs =<<
712− Pattern.add pattern (NoPatternExpectation argType) state
712+ Pattern.add pattern (PNoExpectation argType) state
713713
714714 return (Args (argVar:vars) (FunN argType tipe) result newState)
715715
@@ -740,10 +740,10 @@ typedArgsHelp rtv name args resultType state =
740740
741741 (Can.TypedArg index srcType pattern@(A.At region _)) : otherArgs ->
742742 do argType <- Instantiate.fromSrcType rtv srcType
743− let expect = PatternExpectation region (PTypedArg name index) argType
743+ let expected = PFromContext region (PTypedArg name index) argType
744744
745745 (TypedArgs tipe result newState) <-
746746 typedArgsHelp rtv name otherArgs resultType =<<
747− Pattern.add pattern expect state
747+ Pattern.add pattern expected state
748748
749749 return (TypedArgs (FunN argType tipe) result newState)
src/Type/Constrain/Pattern.hs+12−12
@@ -40,7 +40,7 @@ data State =
4040type Header = Map.Map N.Name (A.Located Type)
4141
4242
43−add :: Can.Pattern -> PatternExpectation -> State -> IO State
43+add :: Can.Pattern -> PExpected Type -> State -> IO State
4444add (A.At region pattern) expectation state =
4545 case pattern of
4646 Can.PAnything ->
@@ -80,8 +80,8 @@ add (A.At region pattern) expectation state =
8080 let entryType = VarN entryVar
8181 let listType = AppN ModuleName.list N.list [entryType]
8282
83− let headExpectation = NoPatternExpectation entryType
84− let tailExpectation = PatternExpectation region PTail listType
83+ let headExpectation = PNoExpectation entryType
84+ let tailExpectation = PFromContext region PTail listType
8585
8686 (State headers vars revCons) <-
8787 add headPattern headExpectation =<<
@@ -133,7 +133,7 @@ emptyState =
133133 State Map.empty [] []
134134
135135
136−addToHeaders :: R.Region -> N.Name -> PatternExpectation -> State -> State
136+addToHeaders :: R.Region -> N.Name -> PExpected Type -> State -> State
137137addToHeaders region name expectation (State headers vars revCons) =
138138 let
139139 tipe = getType expectation
@@ -142,11 +142,11 @@ addToHeaders region name expectation (State headers vars revCons) =
142142 State newHeaders vars revCons
143143
144144
145−getType :: PatternExpectation -> Type
145+getType :: PExpected Type -> Type
146146getType expectation =
147147 case expectation of
148− NoPatternExpectation tipe -> tipe
149− PatternExpectation _ _ tipe -> tipe
148+ PNoExpectation tipe -> tipe
149+ PFromContext _ _ tipe -> tipe
150150
151151
152152
@@ -157,7 +157,7 @@ addEntry :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO St
157157addEntry listRegion tipe state (index, pattern) =
158158 let
159159 expectation =
160− PatternExpectation listRegion (PListEntry index) tipe
160+ PFromContext listRegion (PListEntry index) tipe
161161 in
162162 add pattern expectation state
163163
@@ -166,7 +166,7 @@ addEntry listRegion tipe state (index, pattern) =
166166-- CONSTRAIN TUPLE
167167
168168
169−addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> PatternExpectation -> State -> IO State
169+addTuple :: R.Region -> Can.Pattern -> Can.Pattern -> Maybe Can.Pattern -> PExpected Type -> State -> IO State
170170addTuple region a b maybeC expectation state =
171171 do aVar <- mkFlexVar
172172 bVar <- mkFlexVar
@@ -199,14 +199,14 @@ addTuple region a b maybeC expectation state =
199199
200200simpleAdd :: Can.Pattern -> Type -> State -> IO State
201201simpleAdd pattern patternType state =
202− add pattern (NoPatternExpectation patternType) state
202+ add pattern (PNoExpectation patternType) state
203203
204204
205205
206206-- CONSTRAIN CONSTRUCTORS
207207
208208
209−addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> PatternExpectation -> State -> IO State
209+addCtor :: R.Region -> ModuleName.Canonical -> N.Name -> [N.Name] -> N.Name -> [Can.PatternCtorArg] -> PExpected Type -> State -> IO State
210210addCtor region home typeName typeVarNames ctorName args expectation state =
211211 do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames
212212 let typePairs = map (second VarN) varPairs
@@ -229,5 +229,5 @@ addCtor region home typeName typeVarNames ctorName args expectation state =
229229addCtorArg :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State
230230addCtorArg region ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =
231231 do tipe <- Instantiate.fromSrcType freeVarDict srcType
232− let expectation = PatternExpectation region (PCtorArg ctorName index) tipe
232+ let expectation = PFromContext region (PCtorArg ctorName index) tipe
233233 add pattern expectation state
src/Type/Constraint.hs+53−24
@@ -3,14 +3,16 @@
33module Type.Constraint
44 ( Constraint(..)
55 , exists
6− , Expectation(..)
6+ , Expected(..)
77 , Context(..)
88 , SubContext(..)
99 , FuncName(..)
1010 , Category(..)
11− , PatternExpectation(..)
12− , PatternContext(..)
13− , PatternCategory(..)
11+ , PExpected(..)
12+ , PContext(..)
13+ , PCategory(..)
14+ , typeReplace
15+ , ptypeReplace
1416 )
1517 where
1618
@@ -31,12 +33,18 @@ import Type.Type (Type, Variable)
3133
3234data Constraint
3335 = CTrue
34− | CSaveHeaders
35− | CEqual R.Region Category Type Expectation
36− | CLookup R.Region N.Name Expectation
37− | CInstance R.Region FuncName Can.Annotation Expectation
38− | CPattern R.Region PatternCategory Type PatternExpectation
36+ | CSaveTheEnvironment
37+ | CEqual R.Region Category Type (Expected Type)
38+ | CLookup R.Region N.Name (Expected Type)
39+ | CInstance R.Region FuncName Can.Annotation (Expected Type)
40+ | CPattern R.Region PCategory Type (PExpected Type)
3941 | CAnd [Constraint]
42+ | CBranch
43+ { _a :: Type
44+ , _b :: Type
45+ , _eq :: Constraint
46+ , _neq :: IO Constraint
47+ }
4048 | CLet
4149 { _rigidVars :: [Variable]
4250 , _flexVars :: [Variable]
@@ -44,12 +52,6 @@ data Constraint
4452 , _headerCon :: Constraint
4553 , _bodyCon :: Constraint
4654 }
47− | CBranch
48− { _a :: Type
49− , _b :: Type
50− , _eq :: Constraint
51− , _neq :: IO Constraint
52− }
5355
5456
5557exists :: [Variable] -> Constraint -> Constraint
@@ -61,10 +63,10 @@ exists flexVars constraint =
6163-- EXPRESSION EXPECTATIONS
6264
6365
64−data Expectation
65− = NoExpectation Type
66− | FromContext R.Region Context Type
67− | FromAnnotation N.Name Int SubContext Type
66+data Expected tipe
67+ = NoExpectation tipe
68+ | FromContext R.Region Context tipe
69+ | FromAnnotation N.Name Int SubContext tipe
6870
6971
7072data Context
@@ -116,12 +118,12 @@ data Category
116118-- PATTERN EXPECTATIONS
117119
118120
119−data PatternExpectation
120− = NoPatternExpectation Type
121− | PatternExpectation R.Region PatternContext Type
121+data PExpected tipe
122+ = PNoExpectation tipe
123+ | PFromContext R.Region PContext tipe
122124
123125
124−data PatternContext
126+data PContext
125127 = PTypedArg N.Name Index.ZeroBased
126128 | PCaseMatch Index.ZeroBased
127129 | PCtorArg N.Name Index.ZeroBased
@@ -129,7 +131,7 @@ data PatternContext
129131 | PTail
130132
131133
132−data PatternCategory
134+data PCategory
133135 = PRecord
134136 | PUnit
135137 | PTuple
@@ -138,3 +140,30 @@ data PatternCategory
138140 | PInt
139141 | PStr
140142 | PChr
143+
144+
145+
146+-- HELPERS
147+
148+
149+typeReplace :: Expected Type -> Can.Type -> Expected Can.Type
150+typeReplace expectation tipe =
151+ case expectation of
152+ NoExpectation _ ->
153+ NoExpectation tipe
154+
155+ FromContext region context _ ->
156+ FromContext region context tipe
157+
158+ FromAnnotation name arity context _ ->
159+ FromAnnotation name arity context tipe
160+
161+
162+ptypeReplace :: PExpected Type -> Can.Type -> PExpected Can.Type
163+ptypeReplace expectation tipe =
164+ case expectation of
165+ PNoExpectation _ ->
166+ PNoExpectation tipe
167+
168+ PFromContext region context _ ->
169+ PFromContext region context tipe
src/Type/Solve.hs+518−141
@@ -1,155 +1,221 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Type.Solve (solve) where
3+module Type.Solve
4+ ( run
5+ )
6+ where
7+
48
59import Control.Monad
6−import Control.Monad.Except (ExceptT, liftIO, throwError)
710import qualified Data.Map.Strict as Map
8−import qualified Data.Text as Text
11+import Data.Map.Strict ((!))
912import qualified Data.Vector as Vector
1013import qualified Data.Vector.Mutable as MVector
1114
12−import qualified AST.Module.Name as ModuleName
15+import qualified AST.Canonical as Can
16+import qualified Elm.Name as N
1317import qualified Reporting.Annotation as A
1418import qualified Reporting.Error.Type as Error
1519import qualified Type.Occurs as Occurs
16−import qualified Type.State as TS
17−import Type.Constraint (Constraint(..), Scheme(..))
20+import Type.Constraint as Con
1821import Type.Type as Type
19−import Type.Unify
22+import qualified Type.Unify as Unify
2023import qualified Type.UnionFind as UF
2124
2225
2326
24−-- SOLVER
25−
26−
27−solve :: Constraint -> ExceptT [A.Located Error.Error] IO TS.State
28−solve constraint =
29− {-# SCC elm_compiler_type_solve #-}
30− do state <- liftIO (TS.run (actuallySolve constraint))
31− case TS._errors state of
32− [] ->
33− return state
34−
35− errors ->
36− throwError errors
37−
38−
39−actuallySolve :: Constraint -> TS.Solver ()
40−actuallySolve constraint =
41− case constraint of
42− CTrue ->
43− return ()
44−
45− CSaveEnv ->
46− TS.saveLocalEnv
47−
48− CEqual hint region term1 term2 ->
49− do t1 <- TS.flatten term1
50− t2 <- TS.flatten term2
51− unify hint region t1 t2
27+-- RUN
5228
53− CAnd cs ->
54− mapM_ actuallySolve cs
5529
56− CLet [Scheme [] fqs constraint' _] CTrue ->
57− do oldEnv <- TS.getEnv
58− TS.introduce fqs
59− actuallySolve constraint'
60− TS.modifyEnv (\_ -> oldEnv)
30+run :: Constraint -> IO (Either [Error.Error] Env)
31+run constraint =
32+ do pools <- MVector.replicate 16 []
6133
62− CLet schemes constraint' ->
63− do oldEnv <- TS.getEnv
64− headers <- Map.unions <$> mapM solveScheme schemes
65− TS.modifyEnv $ \env -> Map.union headers env
66− actuallySolve constraint'
67− mapM_ occurs $ Map.toList headers
68− TS.modifyEnv (\_ -> oldEnv)
34+ (State env _ errors) <-
35+ solve Map.empty outermostRank pools emptyState constraint
6936
70− CInstance region name term ->
71− do env <- TS.getEnv
72− freshCopy <-
73− case Map.lookup name env of
74− Just (A.A _ tipe) ->
75− TS.copy tipe
76−
77− Nothing ->
78− if ModuleName.isKernel name then
79− liftIO mkFlexVar
37+ case errors of
38+ [] ->
39+ return $ Right env
8040
81− else
82− error ("Could not find `" ++ Text.unpack name ++ "` when solving type constraints.")
41+ _ ->
42+ return $ Left errors
8343
84− t <- TS.flatten term
85− unify (Error.Instance name) region freshCopy t
8644
8745
46+{-# NOINLINE emptyState #-}
47+emptyState :: State
48+emptyState =
49+ State Map.empty (nextMark noMark) []
8850
89−-- SOLVE SCHEMES
9051
9152
92−solveScheme :: Scheme -> TS.Solver TS.Env
93−solveScheme scheme =
94− let
95− flatten (A.A region term) =
96− A.A region <$> TS.flatten term
97− in
98− case scheme of
99− Scheme [] [] constraint header ->
100− do actuallySolve constraint
101− traverse flatten header
102−
103− Scheme rigidQuantifiers flexQuantifiers constraint header ->
104− -- work in the next pool for this scheme's constraints
105− solveSchemeHelp rigidQuantifiers flexQuantifiers $
106− do flatHeader <- traverse flatten header
107− actuallySolve constraint
108− return flatHeader
109−
53+-- SOLVER
11054
11155
112−solveSchemeHelp :: [Variable] -> [Variable] -> TS.Solver a -> TS.Solver a
113−solveSchemeHelp rigidQuantifiers flexQuantifiers (TS.Solver stepState) =
114− TS.Solver $ \state@(TS.SS _ _ rank oldPools _ _) ->
115− do
116− -- push pool
117− let nextRank = rank + 1
118− let poolsLength = MVector.length oldPools
56+type Env =
57+ Map.Map N.Name Variable
11958
120− pools <-
121− if nextRank < poolsLength
122− then return oldPools
123− else MVector.grow oldPools poolsLength
12459
125− -- introduce quantifiers
126− let allQuantifiers = rigidQuantifiers ++ flexQuantifiers
127− forM_ allQuantifiers $ \var ->
128− UF.modifyDescriptor var $ \(Descriptor content _ mark copy) ->
129− Descriptor content nextRank mark copy
130− MVector.write pools nextRank allQuantifiers
60+type Pools =
61+ MVector.IOVector [Variable]
13162
132− -- run solver in next pool
133− (value, TS.SS env savedEnv _ _ mark errors) <- stepState (state { TS._rank = nextRank })
13463
135− -- pop pool
136− let youngMark = mark
137− let visitMark = nextMark mark
138− let finalMark = nextMark visitMark
139− generalize youngMark visitMark nextRank pools
140− MVector.write pools nextRank []
64+data State =
65+ State
66+ { _env :: Env
67+ , _mark :: Mark
68+ , _errors :: [Error.Error]
69+ }
14170
142− -- check that things went well
143− mapM_ isGeneric rigidQuantifiers
14471
145− -- return result with pool popped
146− return ( value, TS.SS env savedEnv rank pools finalMark errors )
72+solve :: Env -> Int -> Pools -> State -> Constraint -> IO State
73+solve env rank pools state constraint =
74+ case constraint of
75+ CTrue ->
76+ return state
77+
78+ CSaveTheEnvironment ->
79+ return (state { _env = env })
80+
81+ CEqual region category tipe expectation ->
82+ do actual <- typeToVariable rank pools tipe
83+ expected <- expectedToVariable rank pools expectation
84+ answer <- Unify.unify actual expected
85+ case answer of
86+ Unify.Ok vars ->
87+ do introduce rank pools vars
88+ return state
89+
90+ Unify.Err vars problem actualType expectedType ->
91+ do introduce rank pools vars
92+ return $ addError state $
93+ Error.Mismatch
94+ (Error.BadExpr region category actualType)
95+ (Con.typeReplace expectation expectedType)
96+ problem
97+
98+ CLookup region name expectation ->
99+ do actual <- makeCopy rank pools (env ! name)
100+ expected <- expectedToVariable rank pools expectation
101+ answer <- Unify.unify actual expected
102+ case answer of
103+ Unify.Ok vars ->
104+ do introduce rank pools vars
105+ return state
106+
107+ Unify.Err vars problem actualType expectedType ->
108+ do introduce rank pools vars
109+ return $ addError state $
110+ Error.Mismatch
111+ (Error.BadLocal region name actualType)
112+ (Con.typeReplace expectation expectedType)
113+ problem
114+
115+ CInstance region funcName (Can.Forall freeVars srcType) expectation ->
116+ do actual <- srcTypeToVariable rank pools freeVars srcType
117+ expected <- expectedToVariable rank pools expectation
118+ answer <- Unify.unify actual expected
119+ case answer of
120+ Unify.Ok vars ->
121+ do introduce rank pools vars
122+ return state
123+
124+ Unify.Err vars problem actualType expectedType ->
125+ do introduce rank pools vars
126+ return $ addError state $
127+ Error.Mismatch
128+ (Error.BadForeign region funcName actualType)
129+ (Con.typeReplace expectation expectedType)
130+ problem
131+
132+ CPattern region category tipe expectation ->
133+ do actual <- typeToVariable rank pools tipe
134+ expected <- patternExpectationToVariable rank pools expectation
135+ answer <- Unify.unify actual expected
136+ case answer of
137+ Unify.Ok vars ->
138+ do introduce rank pools vars
139+ return state
140+
141+ Unify.Err vars problem actualType expectedType ->
142+ do introduce rank pools vars
143+ return $ addError state $
144+ Error.BadPattern region category actualType
145+ (Con.ptypeReplace expectation expectedType)
146+ problem
147+
148+ CAnd constraints ->
149+ foldM (solve env rank pools) state constraints
150+
151+ CBranch a b eqCon makeNotEqCon ->
152+ do aVar <- typeToVariable rank pools a
153+ bVar <- typeToVariable rank pools b
154+ answer <- Unify.unify aVar bVar
155+ case answer of
156+ Unify.Ok vars ->
157+ do introduce rank pools vars
158+ solve env rank pools state eqCon
159+
160+ Unify.Err vars _ _ _ ->
161+ do introduce rank pools vars
162+ solve env rank pools state =<< makeNotEqCon
163+
164+ CLet [] flexs _ headerCon CTrue ->
165+ do introduce rank pools flexs
166+ solve env rank pools state headerCon
167+
168+ CLet [] [] header headerCon subCon ->
169+ do state1 <- solve env rank pools state headerCon
170+ locals <- traverse (A.traverse (typeToVariable rank pools)) header
171+ let newEnv = Map.union env (Map.map A.drop locals)
172+ state2 <- solve newEnv rank pools state1 subCon
173+ foldM occurs state2 $ Map.toList locals
174+
175+ CLet rigids flexs header headerCon subCon ->
176+ do
177+ -- work in the next pool to localize header
178+ let nextRank = rank + 1
179+ let poolsLength = MVector.length pools
180+ nextPools <-
181+ if nextRank < poolsLength
182+ then return pools
183+ else MVector.grow pools poolsLength
184+
185+ -- introduce variables
186+ let vars = rigids ++ flexs
187+ forM_ vars $ \var ->
188+ UF.modify var $ \(Descriptor content _ mark copy) ->
189+ Descriptor content nextRank mark copy
190+ MVector.write nextPools nextRank vars
191+
192+ -- run solver in next pool
193+ locals <- traverse (A.traverse (typeToVariable rank nextPools)) header
194+ (State savedEnv mark errors) <-
195+ solve env nextRank nextPools state headerCon
196+
197+ let youngMark = mark
198+ let visitMark = nextMark youngMark
199+ let finalMark = nextMark visitMark
200+
201+ -- pop pool
202+ generalize youngMark visitMark nextRank nextPools
203+ MVector.write nextPools nextRank []
204+
205+ -- check that things went well
206+ mapM_ isGeneric rigids
207+
208+ let newEnv = Map.union env (Map.map A.drop locals)
209+ let tempState = State savedEnv finalMark errors
210+ newState <- solve newEnv nextRank nextPools tempState subCon
211+
212+ foldM occurs newState (Map.toList locals)
147213
148214
149215-- Check that a variable has rank == noRank, meaning that it can be generalized.
150216isGeneric :: Variable -> IO ()
151217isGeneric var =
152− do (Descriptor _ rank _ _) <- UF.descriptor var
218+ do (Descriptor _ rank _ _) <- UF.get var
153219 if rank == noRank
154220 then return ()
155221 else crash "Unable to generalize a type variable. It is not unranked."
@@ -165,22 +231,58 @@ crash msg =
165231
166232
167233
168−-- OCCURS CHECK
234+-- EXPECTATIONS TO VARIABLE
235+
236+
237+expectedToVariable :: Int -> Pools -> Expected Type -> IO Variable
238+expectedToVariable rank pools expectation =
239+ typeToVariable rank pools $
240+ case expectation of
241+ NoExpectation tipe ->
242+ tipe
243+
244+ FromContext _ _ tipe ->
245+ tipe
246+
247+ FromAnnotation _ _ _ tipe ->
248+ tipe
249+
250+
251+patternExpectationToVariable :: Int -> Pools -> PExpected Type -> IO Variable
252+patternExpectationToVariable rank pools expectation =
253+ typeToVariable rank pools $
254+ case expectation of
255+ PNoExpectation tipe ->
256+ tipe
257+
258+ PFromContext _ _ tipe ->
259+ tipe
260+
261+
169262
263+-- ERROR HELPERS
170264
171−occurs :: (Text.Text, A.Located Variable) -> TS.Solver ()
172−occurs (name, A.A region variable) =
173− {-# SCC elm_compiler_type_occurs #-}
174− do hasOccurred <- liftIO $ Occurs.occurs variable
175− case hasOccurred of
176− False ->
177− return ()
178265
179− True ->
180− do overallType <- liftIO $ Type.toSrcType variable
181− (Descriptor _ rank mark copy) <- liftIO $ UF.descriptor variable
182− liftIO $ UF.setDescriptor variable (Descriptor (Error "∞") rank mark copy)
183− TS.addError region (Error.InfiniteType (Right name) overallType)
266+addError :: State -> Error.Error -> State
267+addError (State savedEnv rank errors) err =
268+ State savedEnv rank (err:errors)
269+
270+
271+
272+-- OCCURS CHECK
273+
274+
275+occurs :: State -> (N.Name, A.Located Variable) -> IO State
276+occurs state (_name, A.At _region variable) =
277+ do hasOccurred <- Occurs.occurs variable
278+ if hasOccurred
279+ then
280+ do overallType <- Type.toSrcType variable
281+ (Descriptor _ rank mark copy) <- UF.get variable
282+ UF.set variable (Descriptor (Error "∞") rank mark copy)
283+ return $ state { _errors = Error.InfiniteType overallType : _errors state }
284+ else
285+ return state
184286
185287
186288
@@ -190,11 +292,9 @@ occurs (name, A.A region variable) =
190292{-| Every variable has rank less than or equal to the maxRank of the pool.
191293This sorts variables into the young and old pools accordingly.
192294-}
193−generalize :: Mark -> Mark -> Int -> TS.Pools -> IO ()
295+generalize :: Mark -> Mark -> Int -> Pools -> IO ()
194296generalize youngMark visitMark youngRank pools =
195− {-# SCC elm_compiler_type_generalize #-}
196− do
197− youngVars <- MVector.read pools youngRank
297+ do youngVars <- MVector.read pools youngRank
198298 rankTable <- poolToRankTable youngMark youngRank youngVars
199299
200300 -- get the ranks right for each entry.
@@ -210,7 +310,7 @@ generalize youngMark visitMark youngRank pools =
210310 if isRedundant
211311 then return ()
212312 else
213− do (Descriptor _ rank _ _) <- UF.descriptor var
313+ do (Descriptor _ rank _ _) <- UF.get var
214314 MVector.modify pools (var:) rank
215315
216316 -- For variables with rank youngRank
@@ -221,12 +321,10 @@ generalize youngMark visitMark youngRank pools =
221321 if isRedundant
222322 then return ()
223323 else
224− do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
324+ do (Descriptor content rank mark copy) <- UF.get var
225325 if rank < youngRank
226− then
227− MVector.modify pools (var:) rank
228− else
229− UF.setDescriptor var $ Descriptor content noRank mark copy
326+ then MVector.modify pools (var:) rank
327+ else UF.set var $ Descriptor content noRank mark copy
230328
231329
232330poolToRankTable :: Mark -> Int -> [Variable] -> IO (Vector.Vector [Variable])
@@ -235,8 +333,8 @@ poolToRankTable youngMark youngRank youngInhabitants =
235333
236334 -- Sort the youngPool variables into buckets by rank.
237335 forM_ youngInhabitants $ \var ->
238− do (Descriptor content rank _ copy) <- UF.descriptor var
239− UF.setDescriptor var (Descriptor content rank youngMark copy)
336+ do (Descriptor content rank _ copy) <- UF.get var
337+ UF.set var (Descriptor content rank youngMark copy)
240338 MVector.modify mutableTable (var:) rank
241339
242340 Vector.unsafeFreeze mutableTable
@@ -252,12 +350,12 @@ poolToRankTable youngMark youngRank youngInhabitants =
252350adjustRank :: Mark -> Mark -> Int -> Variable -> IO Int
253351adjustRank youngMark visitMark groupRank var =
254352 {-# SCC elm_compiler_type_adjust #-}
255− do (Descriptor content rank mark copy) <- UF.descriptor var
353+ do (Descriptor content rank mark copy) <- UF.get var
256354 if mark == youngMark then
257355 do -- Set the variable as marked first because it may be cyclic.
258− UF.setDescriptor var $ Descriptor content rank visitMark copy
356+ UF.set var $ Descriptor content rank visitMark copy
259357 maxRank <- adjustRankContent youngMark visitMark groupRank content
260− UF.setDescriptor var $ Descriptor content maxRank visitMark copy
358+ UF.set var $ Descriptor content maxRank visitMark copy
261359 return maxRank
262360
263361 else if mark == visitMark then
@@ -266,7 +364,7 @@ adjustRank youngMark visitMark groupRank var =
266364 else
267365 do let minRank = min groupRank rank
268366 -- TODO how can minRank ever be groupRank?
269− UF.setDescriptor var $ Descriptor content minRank visitMark copy
367+ UF.set var $ Descriptor content minRank visitMark copy
270368 return minRank
271369
272370
@@ -325,3 +423,282 @@ adjustRankContent youngMark visitMark groupRank content =
325423 Error _ ->
326424 return groupRank
327425
426+
427+
428+-- REGISTER VARIABLES
429+
430+
431+introduce :: Int -> Pools -> [Variable] -> IO ()
432+introduce rank pools variables =
433+ do MVector.modify pools (variables++) rank
434+ forM_ variables $ \var ->
435+ UF.modify var $ \(Descriptor content _ mark copy) ->
436+ Descriptor content rank mark copy
437+
438+
439+
440+-- TYPE TO VARIABLE
441+
442+
443+typeToVariable :: Int -> Pools -> Type -> IO Variable
444+typeToVariable rank pools tipe =
445+ typeToVar rank pools Map.empty tipe
446+
447+
448+typeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Type -> IO Variable
449+typeToVar rank pools aliasDict tipe =
450+ let go = typeToVar rank pools aliasDict in
451+ case tipe of
452+ VarN v ->
453+ return v
454+
455+ AppN home name args ->
456+ do argVars <- traverse go args
457+ register rank pools (Structure (App1 home name argVars))
458+
459+ FunN a b ->
460+ do aVar <- go a
461+ bVar <- go b
462+ register rank pools (Structure (Fun1 aVar bVar))
463+
464+ AliasN home name args aliasType ->
465+ do argVars <- traverse (traverse go) args
466+ aliasVar <- typeToVar rank pools (Map.fromList argVars) aliasType
467+ register rank pools (Alias home name argVars aliasVar)
468+
469+ PlaceHolder name ->
470+ return (aliasDict ! name)
471+
472+ RecordN fields ext ->
473+ do fieldVars <- traverse go fields
474+ extVar <- go ext
475+ register rank pools (Structure (Record1 fieldVars extVar))
476+
477+ EmptyRecordN ->
478+ register rank pools emptyRecord1
479+
480+ UnitN ->
481+ register rank pools unit1
482+
483+ TupleN a b c ->
484+ do aVar <- go a
485+ bVar <- go b
486+ cVar <- traverse go c
487+ register rank pools (Structure (Tuple1 aVar bVar cVar))
488+
489+
490+register :: Int -> Pools -> Content -> IO Variable
491+register rank pools content =
492+ do var <- UF.fresh (Descriptor content rank noMark Nothing)
493+ MVector.modify pools (var:) rank
494+ return var
495+
496+
497+{-# NOINLINE emptyRecord1 #-}
498+emptyRecord1 :: Content
499+emptyRecord1 =
500+ Structure EmptyRecord1
501+
502+
503+{-# NOINLINE unit1 #-}
504+unit1 :: Content
505+unit1 =
506+ Structure Unit1
507+
508+
509+
510+-- SOURCE TYPE TO VARIABLE
511+
512+
513+srcTypeToVariable :: Int -> Pools -> Map.Map N.Name () -> Can.Type -> IO Variable
514+srcTypeToVariable rank pools freeVars srcType =
515+ let
516+ makeVar name _ =
517+ UF.fresh (Descriptor (FlexVar (Just name)) rank noMark Nothing)
518+ in
519+ do flexVars <- Map.traverseWithKey makeVar freeVars
520+ MVector.modify pools (Map.elems flexVars ++) rank
521+ srcTypeToVar rank pools flexVars srcType
522+
523+
524+srcTypeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Can.Type -> IO Variable
525+srcTypeToVar rank pools flexVars srcType =
526+ let go = srcTypeToVar rank pools flexVars in
527+ case srcType of
528+ Can.TLambda argument result ->
529+ do argVar <- go argument
530+ resultVar <- go result
531+ register rank pools (Structure (Fun1 argVar resultVar))
532+
533+ Can.TVar name ->
534+ return (flexVars ! name)
535+
536+ Can.TType home name args ->
537+ do argVars <- traverse go args
538+ register rank pools (Structure (App1 home name argVars))
539+
540+ Can.TRecord fields maybeExt ->
541+ do fieldVars <- traverse go fields
542+ extVar <- maybe (register rank pools emptyRecord1) go maybeExt
543+ register rank pools (Structure (Record1 fieldVars extVar))
544+
545+ Can.TUnit ->
546+ register rank pools unit1
547+
548+ Can.TTuple a b c ->
549+ do aVar <- go a
550+ bVar <- go b
551+ cVar <- traverse go c
552+ register rank pools (Structure (Tuple1 aVar bVar cVar))
553+
554+ Can.TAlias home name args aliasType ->
555+ do argVars <- traverse (traverse go) args
556+ aliasVar <-
557+ case aliasType of
558+ Can.Holey tipe ->
559+ srcTypeToVar rank pools (Map.fromList argVars) tipe
560+
561+ Can.Filled tipe ->
562+ go tipe
563+
564+ register rank pools (Alias home name argVars aliasVar)
565+
566+
567+
568+-- COPY
569+
570+
571+makeCopy :: Int -> Pools -> Variable -> IO Variable
572+makeCopy rank pools var =
573+ do copy <- makeCopyHelp rank pools var
574+ _ <- restore var
575+ return copy
576+
577+
578+makeCopyHelp :: Int -> Pools -> Variable -> IO Variable
579+makeCopyHelp maxRank pools variable =
580+ do (Descriptor content rank _ maybeCopy) <-
581+ UF.get variable
582+
583+ case maybeCopy of
584+ Just copy ->
585+ return copy
586+
587+ Nothing ->
588+ if rank /= noRank then
589+ return variable
590+
591+ else
592+ do let makeDescriptor c = Descriptor c maxRank noMark Nothing
593+ copy <- UF.fresh $ makeDescriptor content
594+ MVector.modify pools (copy:) maxRank
595+
596+ -- Link the original variable to the new variable. This lets us
597+ -- avoid making multiple copies of the variable we are instantiating.
598+ --
599+ -- Need to do this before recursively copying to avoid looping.
600+ UF.set variable $
601+ Descriptor content rank noMark (Just copy)
602+
603+ -- Now we recursively copy the content of the variable.
604+ -- We have already marked the variable as copied, so we
605+ -- will not repeat this work or crawl this variable again.
606+ case content of
607+ Structure term ->
608+ do newTerm <- traverseFlatType (makeCopyHelp maxRank pools) term
609+ UF.set copy $ makeDescriptor (Structure newTerm)
610+ return copy
611+
612+ FlexVar _ ->
613+ return copy
614+
615+ FlexSuper _ _ ->
616+ return copy
617+
618+ RigidVar name ->
619+ do UF.set copy $ makeDescriptor $ FlexVar (Just name)
620+ return copy
621+
622+ RigidSuper super name ->
623+ do UF.set copy $ makeDescriptor $ FlexSuper super (Just name)
624+ return copy
625+
626+ Alias home name args realType ->
627+ do newArgs <- mapM (traverse (makeCopyHelp maxRank pools)) args
628+ newRealType <- makeCopyHelp maxRank pools realType
629+ UF.set copy $ makeDescriptor (Alias home name newArgs newRealType)
630+ return copy
631+
632+ Error _ ->
633+ return copy
634+
635+
636+
637+-- RESTORE
638+
639+
640+restore :: Variable -> IO Variable
641+restore variable =
642+ do (Descriptor content _rank _mark maybeCopy) <- UF.get variable
643+ case maybeCopy of
644+ Nothing ->
645+ return variable
646+
647+ Just _ ->
648+ do restoredContent <- restoreContent content
649+ UF.set variable $
650+ Descriptor restoredContent noRank noMark Nothing
651+ return variable
652+
653+
654+restoreContent :: Content -> IO Content
655+restoreContent content =
656+ case content of
657+ FlexVar _ ->
658+ return content
659+
660+ FlexSuper _ _ ->
661+ return content
662+
663+ RigidVar _ ->
664+ return content
665+
666+ RigidSuper _ _ ->
667+ return content
668+
669+ Structure term ->
670+ Structure <$> traverseFlatType restore term
671+
672+ Alias home name args var ->
673+ Alias home name
674+ <$> mapM (traverse restore) args
675+ <*> restore var
676+
677+ Error _ ->
678+ return content
679+
680+
681+
682+-- TRAVERSE FLAT TYPE
683+
684+
685+traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
686+traverseFlatType f flatType =
687+ case flatType of
688+ App1 home name args ->
689+ liftM (App1 home name) (traverse f args)
690+
691+ Fun1 a b ->
692+ liftM2 Fun1 (f a) (f b)
693+
694+ EmptyRecord1 ->
695+ pure EmptyRecord1
696+
697+ Record1 fields ext ->
698+ liftM2 Record1 (traverse f fields) (f ext)
699+
700+ Unit1 ->
701+ pure Unit1
702+
703+ Tuple1 a b cs ->
704+ liftM3 Tuple1 (f a) (f b) (traverse f cs)
src/Type/State.hsdeleted−369
@@ -1,369 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Type.State
3− ( Solver(..)
4− , run
5− , State(..)
6− , Pools
7− , Env
8− , modifyEnv
9− , addError
10− , getEnv
11− , saveLocalEnv
12− , register
13− , introduce
14− , flatten
15− , copy
16− )
17− where
18−
19−
20−import Control.Monad (forM_, liftM, liftM2, liftM3)
21−import Control.Monad.Trans (MonadIO, liftIO)
22−import qualified Data.Map.Strict as Map
23−import Data.Map.Strict ((!))
24−import qualified Data.Vector.Mutable as MVector
25−
26−import qualified Elm.Name as N
27−import qualified Reporting.Annotation as A
28−import qualified Reporting.Error.Type as Error
29−import qualified Reporting.Region as R
30−import Type.Type as Type
31−import qualified Type.UnionFind as UF
32−
33−
34−
35−-- SOLVER
36−
37−
38−newtype Solver a =
39− Solver { _solve :: State -> IO (a, State) }
40−
41−
42−data State =
43− SS
44− { _env :: Env
45− , _savedEnv :: Env
46− , _rank :: Int
47− , _pools :: Pools
48− , _mark :: Mark
49− , _errors :: [A.Located Error.Error]
50− }
51−
52−
53−type Pools = MVector.IOVector [Variable]
54−
55−
56−type Env = Map.Map N.Name (A.Located Variable)
57−
58−
59−
60−-- RUN SOLVER
61−
62−
63−run :: Solver () -> IO State
64−run (Solver solver) =
65− do pools <- MVector.replicate 8 []
66− (_, state) <- solver (SS Map.empty Map.empty outermostRank pools (Type.nextMark noMark) [])
67− return state
68−
69−
70−
71−-- HELPERS
72−
73−
74−{-# INLINE modifyEnv #-}
75−modifyEnv :: (Env -> Env) -> Solver ()
76−modifyEnv f =
77− Solver $ \state ->
78− return ( (), state { _env = f (_env state) } )
79−
80−
81−{-# INLINE addError #-}
82−addError :: R.Region -> Error.Error -> Solver ()
83−addError region err =
84− Solver $ \state ->
85− return ( (), state { _errors = A.A region err : _errors state } )
86−
87−
88−{-# INLINE getEnv #-}
89−getEnv :: Solver Env
90−getEnv =
91− Solver $ \state ->
92− return ( _env state, state )
93−
94−
95−{-# INLINE saveLocalEnv #-}
96−saveLocalEnv :: Solver ()
97−saveLocalEnv =
98− Solver $ \state ->
99− return ( (), state { _savedEnv = _env state } )
100−
101−
102−
103−-- REGISTER VARIABLES
104−
105−
106−register :: Variable -> Solver ()
107−register var =
108− Solver $ \state@(SS _ _ maxRank pools _ _) ->
109− {-# SCC elm_compiler_type_register #-}
110− do MVector.modify pools (var:) maxRank
111− return ( (), state )
112−
113−
114−introduce :: [Variable] -> Solver ()
115−introduce variables =
116− Solver $ \state@(SS _ _ maxRank pools _ _) ->
117− {-# SCC elm_compiler_type_introduce #-}
118− do
119− forM_ variables $ \var ->
120− UF.modifyDescriptor var $ \(Descriptor content _ mark cp) ->
121− Descriptor content maxRank mark cp
122−
123− MVector.modify pools (variables++) maxRank
124−
125− return ( (), state )
126−
127−
128−
129−-- FLATTEN
130−
131−
132−flatten :: Type -> Solver Variable
133−flatten tipe =
134− Solver $ \state@(SS _ _ maxRank pools _ _) ->
135− {-# SCC elm_compiler_type_flatten #-}
136− do var <- flattenHelp maxRank pools Map.empty tipe
137− return (var, state)
138−
139−
140−flattenHelp :: Int -> Pools -> Map.Map N.Name Variable -> Type -> IO Variable
141−flattenHelp maxRank pools aliasDict tipe =
142− case tipe of
143− PlaceHolder name ->
144− return (aliasDict ! name)
145−
146− AliasN home name args realType ->
147− do flatArgs <- mapM (traverse (flattenHelp maxRank pools aliasDict)) args
148− flatVar <- flattenHelp maxRank pools (Map.fromList flatArgs) realType
149− registerFlatType maxRank pools (Alias home name flatArgs flatVar)
150−
151− VarN v ->
152− return v
153−
154− AppN home name args ->
155− do flatArgs <- traverse (flattenHelp maxRank pools aliasDict) args
156− registerFlatType maxRank pools (Structure (App1 home name flatArgs))
157−
158− FunN a b ->
159− do flatA <- flattenHelp maxRank pools aliasDict a
160− flatB <- flattenHelp maxRank pools aliasDict b
161− registerFlatType maxRank pools (Structure (Fun1 flatA flatB))
162−
163− EmptyRecordN ->
164− registerFlatType maxRank pools (Structure EmptyRecord1)
165−
166− RecordN fields ext ->
167− do flatFields <- traverse (flattenHelp maxRank pools aliasDict) fields
168− flatExt <- flattenHelp maxRank pools aliasDict ext
169− registerFlatType maxRank pools (Structure (Record1 flatFields flatExt))
170−
171− UnitN ->
172− registerFlatType maxRank pools (Structure Unit1)
173−
174− TupleN a b cs ->
175− do flatA <- flattenHelp maxRank pools aliasDict a
176− flatB <- flattenHelp maxRank pools aliasDict b
177− flatCs <- traverse (flattenHelp maxRank pools aliasDict) cs
178− registerFlatType maxRank pools (Structure (Tuple1 flatA flatB flatCs))
179−
180−
181−registerFlatType :: Int -> Pools -> Content -> IO Variable
182−registerFlatType maxRank pools content =
183− do var <- UF.fresh (Descriptor content maxRank noMark Nothing)
184− MVector.modify pools (var:) maxRank
185− return var
186−
187−
188−
189−-- COPY
190−
191−
192−copy :: Variable -> Solver Variable
193−copy var =
194− Solver $ \state@(SS _ _ maxRank pools _ _) ->
195− {-# SCC elm_compiler_type_copy #-}
196− do copyVar <- copyHelp maxRank pools var
197− _ <- restore var
198− return ( copyVar, state )
199−
200−
201−copyHelp :: Int -> Pools -> Variable -> IO Variable
202−copyHelp maxRank pools variable =
203− do (Descriptor content rank _mark maybeCopy) <- UF.descriptor variable
204− case maybeCopy of
205− Just copiedVariable ->
206− return copiedVariable
207−
208− Nothing ->
209− if rank /= noRank then
210− return variable
211−
212− else
213− do let mkCopyDesc cont = Descriptor cont maxRank noMark Nothing
214− newVar <- UF.fresh $ mkCopyDesc content
215− MVector.modify pools (newVar:) maxRank
216−
217− -- Link the original variable to the new variable. This lets us
218− -- avoid making multiple copies of the variable we are instantiating.
219− --
220− -- Need to do this before recursively copying the content of
221− -- the variable to avoid looping on cyclic terms.
222− UF.setDescriptor variable $
223− Descriptor content rank noMark (Just newVar)
224−
225− -- Now we recursively copy the content of the variable.
226− -- We have already marked the variable as copied, so we
227− -- will not repeat this work or crawl this variable again.
228− case content of
229− Structure term ->
230− do newTerm <- traverseFlatType (copyHelp maxRank pools) term
231− UF.setDescriptor newVar $ mkCopyDesc (Structure newTerm)
232−
233− FlexVar _ ->
234− return ()
235−
236− FlexSuper _ _ ->
237− return ()
238−
239− RigidVar name ->
240− UF.setDescriptor newVar $ mkCopyDesc $ FlexVar (Just name)
241−
242− RigidSuper super name ->
243− UF.setDescriptor newVar $ mkCopyDesc $ FlexSuper super (Just name)
244−
245− Alias home name args realType ->
246− do newArgs <- mapM (traverse (copyHelp maxRank pools)) args
247− newRealType <- copyHelp maxRank pools realType
248− UF.setDescriptor newVar $ mkCopyDesc (Alias home name newArgs newRealType)
249−
250− Error _ ->
251− return ()
252−
253− return newVar
254−
255−
256−
257−-- RESTORE
258−
259−
260−restore :: Variable -> IO Variable
261−restore variable =
262− do (Descriptor content _rank _mark maybeCopy) <- UF.descriptor variable
263− case maybeCopy of
264− Nothing ->
265− return variable
266−
267− Just _ ->
268− do restoredContent <- restoreContent content
269− UF.setDescriptor variable $
270− Descriptor restoredContent noRank noMark Nothing
271− return variable
272−
273−
274−restoreContent :: Content -> IO Content
275−restoreContent content =
276− case content of
277− FlexVar _ ->
278− return content
279−
280− FlexSuper _ _ ->
281− return content
282−
283− RigidVar _ ->
284− return content
285−
286− RigidSuper _ _ ->
287− return content
288−
289− Structure term ->
290− Structure <$> traverseFlatType restore term
291−
292− Alias home name args var ->
293− Alias home name
294− <$> mapM (traverse restore) args
295− <*> restore var
296−
297− Error _ ->
298− return content
299−
300−
301−
302−-- TRAVERSE FLAT TYPE
303−
304−
305−traverseFlatType :: (Variable -> IO Variable) -> FlatType -> IO FlatType
306−traverseFlatType f flatType =
307− case flatType of
308− App1 home name args ->
309− liftM (App1 home name) (traverse f args)
310−
311− Fun1 a b ->
312− liftM2 Fun1 (f a) (f b)
313−
314− EmptyRecord1 ->
315− pure EmptyRecord1
316−
317− Record1 fields ext ->
318− liftM2 Record1 (traverse f fields) (f ext)
319−
320− Unit1 ->
321− pure Unit1
322−
323− Tuple1 a b cs ->
324− liftM3 Tuple1 (f a) (f b) (traverse f cs)
325−
326−
327−
328−-- INSTANCES
329−
330−
331−instance Functor Solver where
332− {-# INLINE fmap #-}
333− fmap f (Solver solver) =
334− Solver $ \s1 ->
335− fmap (\(a, s2) -> (f a, s2)) (solver s1)
336−
337−
338−instance Applicative Solver where
339− {-# INLINE pure #-}
340− pure a =
341− Solver $ \s -> return (a, s)
342−
343− {-# INLINE (<*>) #-}
344− Solver solverFunc <*> Solver solverValue =
345− Solver $ \s1 ->
346− do (f, s2) <- solverFunc s1
347− (x, s3) <- solverValue s2
348− return (f x, s3)
349−
350−
351−instance Monad Solver where
352− {-# INLINE (>>=) #-}
353− Solver solver >>= k =
354− Solver $ \s1 ->
355− do (a, s2) <- solver s1
356− (b, s3) <- _solve (k a) s2
357− return (b, s3)
358−
359− {-# INLINE fail #-}
360− fail msg =
361− Solver $ \_ -> fail msg
362−
363−
364−instance MonadIO Solver where
365− {-# INLINE liftIO #-}
366− liftIO io =
367− Solver $ \state ->
368− do a <- io
369− return (a, state)
src/Type/Unify.hs+137−85
@@ -1,17 +1,20 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings, Rank2Types #-}
3−module Type.Unify (unify) where
3+module Type.Unify
4+ ( Answer(..)
5+ , unify
6+ , Problem(..)
7+ )
8+ where
9+
410
511import Control.Monad (foldM, liftM2, zipWithM_)
6−import Control.Monad.Trans (liftIO)
712import qualified Data.Map.Strict as Map
813
14+import qualified AST.Canonical as Can
915import qualified AST.Module.Name as ModuleName
1016import qualified Elm.Name as N
11−import qualified Reporting.Region as R
12−import qualified Reporting.Error.Type as Error
1317import qualified Type.Occurs as Occurs
14−import qualified Type.State as TS
1518import Type.Type as Type
1619import qualified Type.UnionFind as UF
1720
@@ -20,38 +23,84 @@ import qualified Type.UnionFind as UF
2023-- UNIFY
2124
2225
23−unify :: R.Region -> Variable -> Variable -> TS.Solver ()
24−unify region actual expected =
25− do answer <- run (guardedUnify ActualExpected actual expected)
26− case answer of
27− Ok ->
28− return ()
26+data Answer
27+ = Ok [Variable]
28+ | Err [Variable] Problem Can.Type Can.Type
2929
30− Err problem ->
31− do actualSrcType <- liftIO $ Type.toSrcType actual
32− expectedSrcType <- liftIO $ Type.toSrcType expected
33− liftIO $ mergeHelp actual expected (Error "?") noRank
34− TS.addError region $
35− case problem of
36− Reason hasDecoder maybeReason ->
37− Error.MismatchExpr $
38− Error.MismatchInfo actualSrcType expectedSrcType hasDecoder maybeReason
3930
40− Infinite ->
41− Error.InfiniteType actualSrcType
31+unify :: Variable -> Variable -> IO Answer
32+unify v1 v2 =
33+ case guardedUnify ActualExpected v1 v2 of
34+ Unify k ->
35+ k [] onSuccess $ \vars problem ->
36+ do t1 <- Type.toSrcType v1
37+ t2 <- Type.toSrcType v2
38+ UF.union v1 v2 errorDescriptor
39+ return (Err vars problem t1 t2)
40+
41+
42+
43+onSuccess :: [Variable] -> () -> IO Answer
44+onSuccess vars () =
45+ return (Ok vars)
46+
47+
48+{-# NOINLINE errorDescriptor #-}
49+errorDescriptor :: Descriptor
50+errorDescriptor =
51+ Descriptor (Error "?") noRank noMark Nothing
52+
53+
54+
55+-- PROBLEM
56+
4257
58+data Reason
59+ = BadFields [(N.Name, Maybe Reason)]
60+ | MessyFields [N.Name] [N.Name] [N.Name]
61+ | IntFloat
62+ | MissingArgs Int
63+ | RigidClash N.Name N.Name
64+ | NotPartOfSuper Type.SuperType
65+ | RigidVarTooGeneric N.Name SpecificThing
66+ | RigidSuperTooGeneric Type.SuperType N.Name SpecificThing
4367
44−data Answer = Ok | Err Problem
4568
69+data SpecificThing
70+ = SpecificSuper Type.SuperType
71+ | SpecificType N.Name
72+ | SpecificFunction
73+ | SpecificRecord
74+ | SpecificUnit
75+ | SpecificTuple
4676
47−run :: Unify () -> TS.Solver Answer
48−run (Unify k) =
49− do (vars, answer) <-
50− liftIO $ k []
51− (\vars () -> return (vars, Ok))
52− (\vars p -> return (vars, Err p))
53− TS.introduce vars
54− return answer
77+
78+flipReason :: Reason -> Reason
79+flipReason reason =
80+ case reason of
81+ BadFields fields ->
82+ BadFields (map (fmap (fmap flipReason)) fields)
83+
84+ MessyFields both left right ->
85+ MessyFields both right left
86+
87+ IntFloat ->
88+ IntFloat
89+
90+ MissingArgs num ->
91+ MissingArgs num
92+
93+ RigidClash a b ->
94+ RigidClash b a
95+
96+ NotPartOfSuper super ->
97+ NotPartOfSuper super
98+
99+ RigidVarTooGeneric name specific ->
100+ RigidVarTooGeneric name specific
101+
102+ RigidSuperTooGeneric super name specific ->
103+ RigidSuperTooGeneric super name specific
55104
56105
57106
@@ -67,6 +116,8 @@ newtype Unify a =
67116 )
68117
69118
119+-- TODO experiment with INLINE on the Unify instances
120+
70121instance Functor Unify where
71122 fmap func (Unify kv) =
72123 Unify $ \vars ok err ->
@@ -152,11 +203,11 @@ reorient (Context orientation var1 desc1 var2 desc2) =
152203
153204
154205data Problem
155− = Reason Bool (Maybe Error.Reason)
206+ = Reason Bool (Maybe Reason)
156207 | Infinite
157208
158209
159−mismatch :: Context -> Maybe Error.Reason -> Unify a
210+mismatch :: Context -> Maybe Reason -> Unify a
160211mismatch context@(Context orientation var1 _ var2 _) maybeReason =
161212 Unify $ \vars _ err ->
162213 do anyInfinite <- liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
@@ -173,7 +224,7 @@ mismatch context@(Context orientation var1 _ var2 _) maybeReason =
173224 then
174225 do newVars <- foldM (subUnifyAnyway context) vars (zip args1 args2)
175226 err newVars $ Reason hasDecoder $ Just $
176− Error.MissingArgs (abs (length args2 - length args1))
227+ MissingArgs (abs (length args2 - length args1))
177228 else
178229 err vars $ Reason hasDecoder $
179230 case orientation of
@@ -181,7 +232,7 @@ mismatch context@(Context orientation var1 _ var2 _) maybeReason =
181232 maybeReason
182233
183234 ActualExpected ->
184− fmap Error.flipReason maybeReason
235+ fmap flipReason maybeReason
185236
186237
187238subUnifyAnyway :: Context -> [Variable] -> (Variable, Variable) -> IO [Variable]
@@ -193,7 +244,7 @@ subUnifyAnyway context vars (arg1, arg2) =
193244
194245collectArgs :: [Variable] -> Variable -> IO [Variable]
195246collectArgs revArgs variable =
196− do (Descriptor content _ _ _) <- UF.descriptor variable
247+ do (Descriptor content _ _ _) <- UF.get variable
197248 case content of
198249 Structure (Fun1 arg returnType) ->
199250 collectArgs (arg : revArgs) returnType
@@ -204,7 +255,7 @@ collectArgs revArgs variable =
204255
205256detectDecoder :: Variable -> IO Bool
206257detectDecoder variable =
207− do (Descriptor content _ _ _) <- UF.descriptor variable
258+ do (Descriptor content _ _ _) <- UF.get variable
208259 case content of
209260 Structure (App1 home name [_]) ->
210261 return (home == ModuleName.jsonDecode && name == "Decoder")
@@ -220,13 +271,8 @@ detectDecoder variable =
220271merge :: Context -> Content -> Unify ()
221272merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
222273 Unify $ \vars ok _ ->
223− ok vars =<< mergeHelp var1 var2 content (min rank1 rank2)
224−
225−
226−mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
227−mergeHelp var1 var2 newContent newRank =
228− UF.union var1 var2 $
229− Descriptor newContent newRank noMark Nothing
274+ ok vars =<<
275+ UF.union var1 var2 (Descriptor content (min rank1 rank2) noMark Nothing)
230276
231277
232278fresh :: Context -> Content -> Unify Variable
@@ -246,8 +292,8 @@ guardedUnify orientation left right =
246292 if equivalent
247293 then ok vars ()
248294 else
249− do leftDesc <- UF.descriptor left
250− rightDesc <- UF.descriptor right
295+ do leftDesc <- UF.get left
296+ rightDesc <- UF.get right
251297 case actuallyUnify (Context orientation left leftDesc right rightDesc) of
252298 Unify k ->
253299 k vars ok err
@@ -262,7 +308,7 @@ actuallyUnify :: Context -> Unify ()
262308actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
263309 case firstContent of
264310 FlexVar _ ->
265− unifyFlex context secondContent
311+ unifyFlex context firstContent secondContent
266312
267313 FlexSuper super _ ->
268314 unifyFlexSuper context super firstContent secondContent
@@ -289,16 +335,22 @@ actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor
289335-- UNIFY FLEXIBLE VARIABLES
290336
291337
292−unifyFlex :: Context -> Content -> Unify ()
293−unifyFlex context otherContent =
338+unifyFlex :: Context -> Content -> Content -> Unify ()
339+unifyFlex context content otherContent =
294340 case otherContent of
295341 Error _ ->
296342 return ()
297343
298344 -- TODO see if wildcarding makes a noticable perf difference
299345
300− FlexVar _ ->
301− merge context otherContent
346+ FlexVar maybeName ->
347+ merge context $
348+ case maybeName of
349+ Nothing ->
350+ content
351+
352+ Just _ ->
353+ otherContent
302354
303355 FlexSuper _ _ ->
304356 merge context otherContent
@@ -333,54 +385,54 @@ unifyRigid context maybeSuper name content otherContent =
333385 merge context content
334386 else
335387 mismatch context $ Just $
336− Error.RigidSuperTooGeneric super name $ Error.SpecificSuper otherSuper
388+ RigidSuperTooGeneric super name $ SpecificSuper otherSuper
337389
338390 Nothing ->
339391 mismatch context $ Just $
340− Error.RigidVarTooGeneric name $ Error.SpecificSuper otherSuper
392+ RigidVarTooGeneric name $ SpecificSuper otherSuper
341393
342394 RigidVar otherName ->
343395 mismatch context $ Just $
344− Error.RigidClash name otherName
396+ RigidClash name otherName
345397
346398 RigidSuper _ otherName ->
347399 mismatch context $ Just $
348− Error.RigidClash name otherName
400+ RigidClash name otherName
349401
350402 Alias _ otherName _ _ ->
351403 mismatch context $ Just $
352− maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
353− Error.SpecificType otherName
404+ maybe RigidVarTooGeneric RigidSuperTooGeneric maybeSuper name $
405+ SpecificType otherName
354406
355407 Structure flatType ->
356408 mismatch context $ Just $
357− maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
409+ maybe RigidVarTooGeneric RigidSuperTooGeneric maybeSuper name $
358410 flatTypeToSpecificThing flatType
359411
360412 Error _ ->
361413 return ()
362414
363415
364−flatTypeToSpecificThing :: FlatType -> Error.SpecificThing
416+flatTypeToSpecificThing :: FlatType -> SpecificThing
365417flatTypeToSpecificThing flatType =
366418 case flatType of
367419 App1 _ name _ ->
368− Error.SpecificType name
420+ SpecificType name
369421
370422 Fun1 _ _ ->
371− Error.SpecificFunction
423+ SpecificFunction
372424
373425 EmptyRecord1 ->
374− Error.SpecificRecord
426+ SpecificRecord
375427
376428 Record1 _ _ ->
377− Error.SpecificRecord
429+ SpecificRecord
378430
379431 Unit1 ->
380− Error.SpecificUnit
432+ SpecificUnit
381433
382434 Tuple1 _ _ _ ->
383− Error.SpecificTuple
435+ SpecificTuple
384436
385437
386438
@@ -395,14 +447,14 @@ unifyFlexSuper context super content otherContent =
395447
396448 RigidVar name ->
397449 mismatch context $ Just $
398− Error.RigidVarTooGeneric name (Error.SpecificSuper super)
450+ RigidVarTooGeneric name (SpecificSuper super)
399451
400452 RigidSuper otherSuper name ->
401453 if combineRigidSupers otherSuper super then
402454 merge context otherContent
403455 else
404456 mismatch context $ Just $
405− Error.RigidSuperTooGeneric otherSuper name (Error.SpecificSuper super)
457+ RigidSuperTooGeneric otherSuper name (SpecificSuper super)
406458
407459 FlexVar _ ->
408460 merge context content
@@ -413,7 +465,7 @@ unifyFlexSuper context super content otherContent =
413465 case otherSuper of
414466 Number -> merge context content
415467 Comparable -> merge context content
416− _ -> mismatch context Nothing -- Error.NumberAppendableClash
468+ _ -> mismatch context Nothing -- NumberAppendableClash
417469
418470 Comparable ->
419471 case otherSuper of
@@ -427,14 +479,14 @@ unifyFlexSuper context super content otherContent =
427479 Appendable -> merge context otherContent
428480 Comparable -> merge context (Type.unnamedFlexSuper CompAppend)
429481 CompAppend -> merge context otherContent
430− Number -> mismatch context Nothing -- Error.NumberAppendableClash
482+ Number -> mismatch context Nothing -- NumberAppendableClash
431483
432484 CompAppend ->
433485 case otherSuper of
434486 Comparable -> merge context content
435487 Appendable -> merge context content
436488 CompAppend -> merge context content
437− Number -> mismatch context Nothing -- Error.NumberAppendableClash
489+ Number -> mismatch context Nothing -- NumberAppendableClash
438490
439491 Alias _ _ _ realVar ->
440492 subUnify context (_first context) realVar
@@ -479,12 +531,12 @@ unifyFlexSuperStructure context super flatType =
479531 if atomMatchesSuper super home name then
480532 merge context (Structure flatType)
481533 else
482− mismatch context $ Just $ Error.NotPartOfSuper super
534+ mismatch context $ Just $ NotPartOfSuper super
483535
484536 App1 home name [variable] | home == ModuleName.list && name == N.list ->
485537 case super of
486538 Number ->
487− mismatch context $ Just $ Error.NotPartOfSuper super
539+ mismatch context $ Just $ NotPartOfSuper super
488540
489541 Appendable ->
490542 merge context (Structure flatType)
@@ -502,10 +554,10 @@ unifyFlexSuperStructure context super flatType =
502554 Tuple1 a b maybeC ->
503555 case super of
504556 Number ->
505− mismatch context $ Just $ Error.NotPartOfSuper super
557+ mismatch context $ Just $ NotPartOfSuper super
506558
507559 Appendable ->
508− mismatch context $ Just $ Error.NotPartOfSuper super
560+ mismatch context $ Just $ NotPartOfSuper super
509561
510562 Comparable ->
511563 do comparableOccursCheck context
@@ -521,10 +573,10 @@ unifyFlexSuperStructure context super flatType =
521573 unifyComparableRecursive orientation c
522574
523575 CompAppend ->
524− mismatch context $ Just $ Error.NotPartOfSuper super
576+ mismatch context $ Just $ NotPartOfSuper super
525577
526578 _ ->
527− mismatch context $ Just $ Error.NotPartOfSuper super
579+ mismatch context $ Just $ NotPartOfSuper super
528580
529581
530582-- TODO: is there some way to avoid doing this?
@@ -541,7 +593,7 @@ comparableOccursCheck (Context _ _ _ var _) =
541593unifyComparableRecursive :: Orientation -> Variable -> Unify ()
542594unifyComparableRecursive orientation var =
543595 do compVar <- register $
544− do (Descriptor _ rank _ _) <- UF.descriptor var
596+ do (Descriptor _ rank _ _) <- UF.get var
545597 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
546598 guardedUnify orientation compVar var
547599
@@ -594,10 +646,10 @@ unifyStructure context flatType content otherContent =
594646 unifyFlexSuperStructure (reorient context) super flatType
595647
596648 RigidVar name ->
597− mismatch context $ Just $ Error.RigidVarTooGeneric name (flatTypeToSpecificThing flatType)
649+ mismatch context $ Just $ RigidVarTooGeneric name (flatTypeToSpecificThing flatType)
598650
599651 RigidSuper super name ->
600− mismatch context $ Just $ Error.RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
652+ mismatch context $ Just $ RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
601653
602654 Alias _ _ _ realVar ->
603655 subUnify context (_first context) realVar
@@ -610,7 +662,7 @@ unifyStructure context flatType content otherContent =
610662 merge context otherContent
611663
612664 else if isIntFloat home name otherHome otherName then
613− mismatch context (Just Error.IntFloat)
665+ mismatch context (Just IntFloat)
614666
615667 else
616668 mismatch context Nothing
@@ -684,11 +736,11 @@ unifyRecord context firstStructure secondStructure =
684736
685737 (Empty, _, _, False) ->
686738 mismatch context $ Just $
687− Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
739+ MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
688740
689741 (_, False, Empty, _) ->
690742 mismatch context $ Just $
691− Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
743+ MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
692744
693745 (_, False, _, True) ->
694746 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
@@ -719,10 +771,10 @@ unifySharedFieldsHelp context sharedFields =
719771 return ()
720772
721773 badFieldPairs ->
722− mismatch context (Just (Error.BadFields badFieldPairs))
774+ mismatch context (Just (BadFields badFieldPairs))
723775
724776
725−unifyField :: Context -> N.Name -> (Variable, Variable) -> Unify (Maybe (Maybe Error.Reason))
777+unifyField :: Context -> N.Name -> (Variable, Variable) -> Unify (Maybe (Maybe Reason))
726778unifyField context _ (actual, expected) =
727779 Unify $ \vars ok _ ->
728780 case subUnify context actual expected of
@@ -759,7 +811,7 @@ data ExtensionStructure
759811
760812gatherFields :: Context -> Map.Map N.Name Variable -> Variable -> IO RecordStructure
761813gatherFields context fields variable =
762− do (Descriptor content _ _ _) <- UF.descriptor variable
814+ do (Descriptor content _ _ _) <- UF.get variable
763815 case content of
764816 Structure (Record1 subFields subExt) ->
765817 gatherFields context (Map.union fields subFields) subExt