@@ -3,12 +3,10 @@
33module Type.Unify
44 ( Answer(..)
55 , unify
6− , Problem(..)
76 )
87 where
98
109
11−import Control.Monad (foldM, liftM2, zipWithM_)
1210import qualified Data.Map.Strict as Map
1311
1412import qualified AST.Canonical as Can
@@ -25,18 +23,18 @@ import qualified Type.UnionFind as UF
2523
2624data Answer
2725 = Ok [Variable]
28− | Err [Variable] Problem Can.Type Can.Type
26+ | Err [Variable] Can.Type Can.Type
2927
3028
3129unify :: Variable -> Variable -> IO Answer
3230unify v1 v2 =
33− case guardedUnify ActualExpected v1 v2 of
31+ case guardedUnify v1 v2 of
3432 Unify k ->
35− k [] onSuccess $ \vars problem ->
33+ k [] onSuccess $ \vars () ->
3634 do t1 <- Type.toSrcType v1
3735 t2 <- Type.toSrcType v2
3836 UF.union v1 v2 errorDescriptor
39− return (Err vars problem t1 t2)
37+ return (Err vars t1 t2)
4038
4139
4240onSuccess :: [Variable] -> () -> IO Answer
@@ -51,58 +49,6 @@ errorDescriptor =
5149
5250
5351
54−-- PROBLEM
55−
56−
57−data Reason
58− = BadFields [(N.Name, Maybe Reason)]
59− | MessyFields [N.Name] [N.Name] [N.Name]
60− | IntFloat
61− | MissingArgs Int
62− | RigidClash N.Name N.Name
63− | NotPartOfSuper Type.SuperType
64− | RigidVarTooGeneric N.Name SpecificThing
65− | RigidSuperTooGeneric Type.SuperType N.Name SpecificThing
66−
67−
68−data SpecificThing
69− = SpecificSuper Type.SuperType
70− | SpecificType N.Name
71− | SpecificFunction
72− | SpecificRecord
73− | SpecificUnit
74− | SpecificTuple
75−
76−
77−flipReason :: Reason -> Reason
78−flipReason reason =
79− case reason of
80− BadFields fields ->
81− BadFields (map (fmap (fmap flipReason)) fields)
82−
83− MessyFields both left right ->
84− MessyFields both right left
85−
86− IntFloat ->
87− IntFloat
88−
89− MissingArgs num ->
90− MissingArgs num
91−
92− RigidClash a b ->
93− RigidClash b a
94−
95− NotPartOfSuper super ->
96− NotPartOfSuper super
97−
98− RigidVarTooGeneric name specific ->
99− RigidVarTooGeneric name specific
100−
101− RigidSuperTooGeneric super name specific ->
102− RigidSuperTooGeneric super name specific
103−
104−
105−
10652-- CPS UNIFIER
10753
10854
@@ -110,7 +56,7 @@ newtype Unify a =
11056 Unify (forall r.
11157 [Variable]
11258 -> ([Variable] -> a -> IO r)
113− -> ([Variable] -> Problem -> IO r)
59+ -> ([Variable] -> () -> IO r)
11460 -> IO r
11561 )
11662
@@ -167,100 +113,44 @@ register mkVar =
167113 ok (var:vars) var
168114
169115
116+mismatch :: Unify a
117+mismatch =
118+ Unify $ \vars _ err ->
119+ err vars ()
120+
121+
122+try2 :: Unify () -> Unify () -> Unify ()
123+try2 (Unify k1) (Unify k2) =
124+ Unify $ \vars ok err ->
125+ let
126+ ok1 vars1 () = k2 vars1 ok err
127+ err1 vars1 () = k2 vars1 err err
128+ in
129+ k1 vars ok1 err1
130+
131+
132+{-# INLINE try3 #-}
133+try3 :: Unify () -> Unify () -> Unify () -> Unify ()
134+try3 u1 u2 u3 =
135+ try2 u1 (try2 u2 u3)
136+
137+
170138
171139-- UNIFICATION HELPERS
172140
173141
174142data Context =
175143 Context
176− { _orientation :: Orientation
177− , _first :: Variable
144+ { _first :: Variable
178145 , _firstDesc :: Descriptor
179146 , _second :: Variable
180147 , _secondDesc :: Descriptor
181148 }
182149
183150
184−data Orientation
185− = ExpectedActual
186− | ActualExpected
187−
188−
189151reorient :: Context -> Context
190−reorient (Context orientation var1 desc1 var2 desc2) =
191− let
192− otherOrientation =
193− case orientation of
194− ExpectedActual -> ActualExpected
195− ActualExpected -> ExpectedActual
196− in
197− Context otherOrientation var2 desc2 var1 desc1
198−
199−
200−
201−-- ERROR MESSAGES
202−
203−
204−data Problem
205− = Reason Bool (Maybe Reason)
206− | Infinite
207−
208−
209−mismatch :: Context -> Maybe Reason -> Unify a
210−mismatch context@(Context orientation var1 _ var2 _) maybeReason =
211− Unify $ \vars _ err ->
212− do anyInfinite <- liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
213− if anyInfinite
214− then err vars Infinite
215− else
216− do args1 <- collectArgs [] var1
217− args2 <- collectArgs [] var2
218−
219− hasDecoder <-
220− or <$> traverse detectDecoder (args1 ++ args2)
221−
222− if length args1 /= length args2
223− then
224− do newVars <- foldM (subUnifyAnyway context) vars (zip args1 args2)
225− err newVars $ Reason hasDecoder $ Just $
226− MissingArgs (abs (length args2 - length args1))
227− else
228− err vars $ Reason hasDecoder $
229− case orientation of
230− ExpectedActual ->
231− maybeReason
232−
233− ActualExpected ->
234− fmap flipReason maybeReason
235−
236−
237−subUnifyAnyway :: Context -> [Variable] -> (Variable, Variable) -> IO [Variable]
238−subUnifyAnyway context vars (arg1, arg2) =
239− case subUnify context arg1 arg2 of
240− Unify k ->
241− k vars (\vs _ -> return vs) (\vs _ -> return vs)
242−
243−
244−collectArgs :: [Variable] -> Variable -> IO [Variable]
245−collectArgs revArgs variable =
246− do (Descriptor content _ _ _) <- UF.get variable
247− case content of
248− Structure (Fun1 arg returnType) ->
249− collectArgs (arg : revArgs) returnType
250−
251− _ ->
252− return $ variable : revArgs
253−
254−
255−detectDecoder :: Variable -> IO Bool
256−detectDecoder variable =
257− do (Descriptor content _ _ _) <- UF.get variable
258− case content of
259− Structure (App1 home name [_]) ->
260− return (home == ModuleName.jsonDecode && name == "Decoder")
261−
262− _ ->
263− return False
152+reorient (Context var1 desc1 var2 desc2) =
153+ Context var2 desc2 var1 desc1
264154
265155
266156
@@ -268,14 +158,14 @@ detectDecoder variable =
268158
269159
270160merge :: Context -> Content -> Unify ()
271−merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
161+merge (Context var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
272162 Unify $ \vars ok _ ->
273163 ok vars =<<
274164 UF.union var1 var2 (Descriptor content (min rank1 rank2) noMark Nothing)
275165
276166
277167fresh :: Context -> Content -> Unify Variable
278−fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
168+fresh (Context _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
279169 register $ UF.fresh $
280170 Descriptor content (min rank1 rank2) noMark Nothing
281171
@@ -284,8 +174,8 @@ fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content
284174-- ACTUALLY UNIFY THINGS
285175
286176
287−guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
288−guardedUnify orientation left right =
177+guardedUnify :: Variable -> Variable -> Unify ()
178+guardedUnify left right =
289179 Unify $ \vars ok err ->
290180 do equivalent <- UF.equivalent left right
291181 if equivalent
@@ -293,31 +183,18 @@ guardedUnify orientation left right =
293183 else
294184 do leftDesc <- UF.get left
295185 rightDesc <- UF.get right
296− putStrLn (toString leftDesc ++ " vs " ++ toString rightDesc)
297− case actuallyUnify (Context orientation left leftDesc right rightDesc) of
186+ case actuallyUnify (Context left leftDesc right rightDesc) of
298187 Unify k ->
299188 k vars ok err
300189
301190
302−toString :: Descriptor -> String
303−toString (Descriptor content _ _ _) =
304− case content of
305− FlexVar _ -> "FlexVar"
306− FlexSuper _ _ -> "FlexSuper"
307− RigidVar _ -> "RigidVar"
308− RigidSuper _ _ -> "RigidSuper"
309− Alias _ _ _ _ -> "Alias"
310− Structure _ -> "Structure"
311− Error _ -> "Error"
312−
313−
314−subUnify :: Context -> Variable -> Variable -> Unify ()
315−subUnify context var1 var2 =
316− guardedUnify (_orientation context) var1 var2
191+subUnify :: Variable -> Variable -> Unify ()
192+subUnify var1 var2 =
193+ guardedUnify var1 var2
317194
318195
319196actuallyUnify :: Context -> Unify ()
320−actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
197+actuallyUnify context@(Context _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
321198 case firstContent of
322199 FlexVar _ ->
323200 unifyFlex context firstContent secondContent
@@ -325,11 +202,11 @@ actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor
325202 FlexSuper super _ ->
326203 unifyFlexSuper context super firstContent secondContent
327204
328− RigidVar name ->
329− unifyRigid context Nothing name firstContent secondContent
205+ RigidVar _ ->
206+ unifyRigid context Nothing firstContent secondContent
330207
331− RigidSuper super name ->
332− unifyRigid context (Just super) name firstContent secondContent
208+ RigidSuper super _ ->
209+ unifyRigid context (Just super) firstContent secondContent
333210
334211 Alias home name args realVar ->
335212 unifyAlias context home name args realVar secondContent
@@ -384,8 +261,8 @@ unifyFlex context content otherContent =
384261-- UNIFY RIGID VARIABLES
385262
386263
387−unifyRigid :: Context -> Maybe SuperType -> N.Name -> Content -> Content -> Unify ()
388−unifyRigid context maybeSuper name content otherContent =
264+unifyRigid :: Context -> Maybe SuperType -> Content -> Content -> Unify ()
265+unifyRigid context maybeSuper content otherContent =
389266 case otherContent of
390267 FlexVar _ ->
391268 merge context content
@@ -396,57 +273,27 @@ unifyRigid context maybeSuper name content otherContent =
396273 if combineRigidSupers super otherSuper then
397274 merge context content
398275 else
399− mismatch context $ Just $
400− RigidSuperTooGeneric super name $ SpecificSuper otherSuper
276+ mismatch
401277
402278 Nothing ->
403− mismatch context $ Just $
404− RigidVarTooGeneric name $ SpecificSuper otherSuper
279+ mismatch
405280
406− RigidVar otherName ->
407− mismatch context $ Just $
408− RigidClash name otherName
281+ RigidVar _ ->
282+ mismatch
409283
410− RigidSuper _ otherName ->
411− mismatch context $ Just $
412− RigidClash name otherName
284+ RigidSuper _ _ ->
285+ mismatch
413286
414− Alias _ otherName _ _ ->
415− mismatch context $ Just $
416− maybe RigidVarTooGeneric RigidSuperTooGeneric maybeSuper name $
417− SpecificType otherName
287+ Alias _ _ _ _ ->
288+ mismatch
418289
419− Structure flatType ->
420− mismatch context $ Just $
421− maybe RigidVarTooGeneric RigidSuperTooGeneric maybeSuper name $
422− flatTypeToSpecificThing flatType
290+ Structure _ ->
291+ mismatch
423292
424293 Error _ ->
425294 return ()
426295
427296
428−flatTypeToSpecificThing :: FlatType -> SpecificThing
429−flatTypeToSpecificThing flatType =
430− case flatType of
431− App1 _ name _ ->
432− SpecificType name
433−
434− Fun1 _ _ ->
435− SpecificFunction
436−
437− EmptyRecord1 ->
438− SpecificRecord
439−
440− Record1 _ _ ->
441− SpecificRecord
442−
443− Unit1 ->
444− SpecificUnit
445−
446− Tuple1 _ _ _ ->
447− SpecificTuple
448−
449−
450297
451298-- UNIFY SUPER VARIABLES
452299
@@ -457,16 +304,14 @@ unifyFlexSuper context super content otherContent =
457304 Structure flatType ->
458305 unifyFlexSuperStructure context super flatType
459306
460− RigidVar name ->
461− mismatch context $ Just $
462− RigidVarTooGeneric name (SpecificSuper super)
307+ RigidVar _ ->
308+ mismatch
463309
464− RigidSuper otherSuper name ->
310+ RigidSuper otherSuper _ ->
465311 if combineRigidSupers otherSuper super then
466312 merge context otherContent
467313 else
468− mismatch context $ Just $
469− RigidSuperTooGeneric otherSuper name (SpecificSuper super)
314+ mismatch
470315
471316 FlexVar _ ->
472317 merge context content
@@ -477,7 +322,7 @@ unifyFlexSuper context super content otherContent =
477322 case otherSuper of
478323 Number -> merge context content
479324 Comparable -> merge context content
480− _ -> mismatch context Nothing -- NumberAppendableClash
325+ _ -> mismatch
481326
482327 Comparable ->
483328 case otherSuper of
@@ -491,17 +336,17 @@ unifyFlexSuper context super content otherContent =
491336 Appendable -> merge context otherContent
492337 Comparable -> merge context (Type.unnamedFlexSuper CompAppend)
493338 CompAppend -> merge context otherContent
494− Number -> mismatch context Nothing -- NumberAppendableClash
339+ Number -> mismatch
495340
496341 CompAppend ->
497342 case otherSuper of
498343 Comparable -> merge context content
499344 Appendable -> merge context content
500345 CompAppend -> merge context content
501− Number -> mismatch context Nothing -- NumberAppendableClash
346+ Number -> mismatch
502347
503348 Alias _ _ _ realVar ->
504− subUnify context (_first context) realVar
349+ subUnify (_first context) realVar
505350
506351 Error _ ->
507352 return ()
@@ -543,12 +388,12 @@ unifyFlexSuperStructure context super flatType =
543388 if atomMatchesSuper super home name then
544389 merge context (Structure flatType)
545390 else
546− mismatch context $ Just $ NotPartOfSuper super
391+ mismatch
547392
548393 App1 home name [variable] | home == ModuleName.list && name == N.list ->
549394 case super of
550395 Number ->
551− mismatch context $ Just $ NotPartOfSuper super
396+ mismatch
552397
553398 Appendable ->
554399 merge context (Structure flatType)
@@ -556,58 +401,57 @@ unifyFlexSuperStructure context super flatType =
556401 Comparable ->
557402 do comparableOccursCheck context
558403 merge context (Structure flatType)
559− unifyComparableRecursive (_orientation context) variable
404+ unifyComparableRecursive variable
560405
561406 CompAppend ->
562407 do comparableOccursCheck context
563408 merge context (Structure flatType)
564− unifyComparableRecursive (_orientation context) variable
409+ unifyComparableRecursive variable
565410
566411 Tuple1 a b maybeC ->
567412 case super of
568413 Number ->
569− mismatch context $ Just $ NotPartOfSuper super
414+ mismatch
570415
571416 Appendable ->
572− mismatch context $ Just $ NotPartOfSuper super
417+ mismatch
573418
574419 Comparable ->
575420 do comparableOccursCheck context
576421 merge context (Structure flatType)
577− let orientation = _orientation context
578− unifyComparableRecursive orientation a
579− unifyComparableRecursive orientation b
422+ unifyComparableRecursive a
423+ unifyComparableRecursive b
580424 case maybeC of
581425 Nothing ->
582426 return ()
583427
584428 Just c ->
585− unifyComparableRecursive orientation c
429+ unifyComparableRecursive c
586430
587431 CompAppend ->
588− mismatch context $ Just $ NotPartOfSuper super
432+ mismatch
589433
590434 _ ->
591− mismatch context $ Just $ NotPartOfSuper super
435+ mismatch
592436
593437
594438-- TODO: is there some way to avoid doing this?
595439-- Do type classes require occurs checks?
596440comparableOccursCheck :: Context -> Unify ()
597−comparableOccursCheck (Context _ _ _ var _) =
441+comparableOccursCheck (Context _ _ var _) =
598442 Unify $ \vars ok err ->
599443 do hasOccurred <- Occurs.occurs var
600444 if hasOccurred
601− then err vars Infinite
445+ then err vars ()
602446 else ok vars ()
603447
604448
605−unifyComparableRecursive :: Orientation -> Variable -> Unify ()
606−unifyComparableRecursive orientation var =
449+unifyComparableRecursive :: Variable -> Unify ()
450+unifyComparableRecursive var =
607451 do compVar <- register $
608452 do (Descriptor _ rank _ _) <- UF.get var
609453 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
610− guardedUnify orientation compVar var
454+ guardedUnify compVar var
611455
612456
613457
@@ -618,30 +462,60 @@ unifyAlias :: Context -> ModuleName.Canonical -> N.Name -> [(N.Name, Variable)]
618462unifyAlias context home name args realVar otherContent =
619463 case otherContent of
620464 FlexVar _ ->
621− merge context (Alias home name args realVar)
465+ merge context (Alias home name args realVar)
622466
623467 FlexSuper _ _ ->
624− subUnify context realVar (_second context)
468+ subUnify realVar (_second context)
625469
626470 RigidVar _ ->
627− subUnify context realVar (_second context)
471+ subUnify realVar (_second context)
628472
629473 RigidSuper _ _ ->
630− subUnify context realVar (_second context)
474+ subUnify realVar (_second context)
631475
632476 Alias otherHome otherName otherArgs otherRealVar ->
633− if name == otherName && home == otherHome then
634− do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
635− merge context otherContent
477+ if name == otherName && home == otherHome then
478+ Unify $ \vars ok err ->
479+ let
480+ ok1 vars1 () =
481+ case merge context otherContent of
482+ Unify k ->
483+ k vars1 ok err
484+ in
485+ unifyAliasArgs vars context args otherArgs ok1 err
636486
637− else
638− subUnify context realVar otherRealVar
487+ else
488+ subUnify realVar otherRealVar
639489
640490 Structure _ ->
641− subUnify context realVar (_second context)
491+ subUnify realVar (_second context)
642492
643493 Error _ ->
644− return ()
494+ return ()
495+
496+
497+unifyAliasArgs :: [Variable] -> Context -> [(N.Name,Variable)] -> [(N.Name,Variable)] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r
498+unifyAliasArgs vars context args1 args2 ok err =
499+ case args1 of
500+ (_,arg1):others1 ->
501+ case args2 of
502+ (_,arg2):others2 ->
503+ case subUnify arg1 arg2 of
504+ Unify k ->
505+ k vars
506+ (\vs () -> unifyAliasArgs vs context others1 others2 ok err)
507+ (\vs () -> unifyAliasArgs vs context others1 others2 err err)
508+
509+ _ ->
510+ err vars ()
511+
512+ [] ->
513+ case args2 of
514+ [] ->
515+ ok vars ()
516+
517+ _ ->
518+ err vars ()
645519
646520
647521
@@ -657,159 +531,161 @@ unifyStructure context flatType content otherContent =
657531 FlexSuper super _ ->
658532 unifyFlexSuperStructure (reorient context) super flatType
659533
660− RigidVar name ->
661− mismatch context $ Just $ RigidVarTooGeneric name (flatTypeToSpecificThing flatType)
534+ RigidVar _ ->
535+ mismatch
662536
663− RigidSuper super name ->
664− mismatch context $ Just $ RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
537+ RigidSuper _ _ ->
538+ mismatch
665539
666540 Alias _ _ _ realVar ->
667− subUnify context (_first context) realVar
541+ subUnify (_first context) realVar
668542
669543 Structure otherFlatType ->
670544 case (flatType, otherFlatType) of
671545 (App1 home name args, App1 otherHome otherName otherArgs) ->
672546 if home == otherHome && name == otherName then
673− do zipWithM_ (subUnify context) args otherArgs
674− merge context otherContent
675−
676− else if isIntFloat home name otherHome otherName then
677− mismatch context (Just IntFloat)
547+ Unify $ \vars ok err ->
548+ let
549+ ok1 vars1 () =
550+ case merge context otherContent of
551+ Unify k ->
552+ k vars1 ok err
553+ in
554+ unifyArgs vars context args otherArgs ok1 err
678555
679556 else
680− mismatch context Nothing
557+ mismatch
681558
682− (Fun1 arg result, Fun1 otherArg otherResult) ->
683− do subUnify context arg otherArg
684− subUnify context result otherResult
559+ (Fun1 arg1 res1, Fun1 arg2 res2) ->
560+ do try2
561+ (subUnify arg1 arg2)
562+ (subUnify res1 res2)
685563 merge context otherContent
686564
687565 (EmptyRecord1, EmptyRecord1) ->
688566 merge context otherContent
689567
690568 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
691− subUnify context ext (_second context)
569+ subUnify ext (_second context)
692570
693571 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
694− subUnify context (_first context) ext
572+ subUnify (_first context) ext
695573
696− (Record1 fields extension, Record1 otherFields otherExtension) ->
574+ (Record1 fields1 ext1, Record1 fields2 ext2) ->
697575 Unify $ \vars ok err ->
698− do firstStructure <- gatherFields context fields extension
699− secondStructure <- gatherFields context otherFields otherExtension
700− case unifyRecord context firstStructure secondStructure of
576+ do structure1 <- gatherFields fields1 ext1
577+ structure2 <- gatherFields fields2 ext2
578+ case unifyRecord context structure1 structure2 of
701579 Unify k ->
702580 k vars ok err
703581
704582 (Tuple1 a b Nothing, Tuple1 x y Nothing) ->
705− do subUnify context a x
706− subUnify context b y
583+ do try2
584+ (subUnify a x)
585+ (subUnify b y)
586+ merge context otherContent
707587
708588 (Tuple1 a b (Just c), Tuple1 x y (Just z)) ->
709− do subUnify context a x
710− subUnify context b y
711− subUnify context c z
589+ do try3
590+ (subUnify a x)
591+ (subUnify b y)
592+ (subUnify c z)
593+ merge context otherContent
712594
713595 _ ->
714− mismatch context Nothing
596+ mismatch
715597
716598 Error _ ->
717599 return ()
718600
719601
720−isIntFloat :: ModuleName.Canonical -> N.Name -> ModuleName.Canonical -> N.Name -> Bool
721−isIntFloat home name otherHome otherName =
722− otherHome == ModuleName.basics
723− && home == ModuleName.basics
724− && (
725− (name == N.int && otherName == N.float)
726− ||
727− (name == N.float && otherName == N.int)
728− )
729602
603+-- UNIFY ARGS
730604
731605
732−-- UNIFY RECORDS
606+unifyArgs :: [Variable] -> Context -> [Variable] -> [Variable] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r
607+unifyArgs vars context args1 args2 ok err =
608+ case args1 of
609+ arg1:others1 ->
610+ case args2 of
611+ arg2:others2 ->
612+ case subUnify arg1 arg2 of
613+ Unify k ->
614+ k vars
615+ (\vs () -> unifyArgs vs context others1 others2 ok err)
616+ (\vs () -> unifyArgs vs context others1 others2 err err)
733617
618+ _ ->
619+ err vars ()
734620
735−unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
736−unifyRecord context firstStructure secondStructure =
737− do let (RecordStructure expFields expVar expStruct) = firstStructure
738− let (RecordStructure actFields actVar actStruct) = secondStructure
739−
740− let sharedFields = Map.intersectionWith (,) expFields actFields
741−
742− -- call after unifying extension, make sure record shape matches before
743− -- looking into whether the particular field types match.
744− let unifySharedFields otherFields ext =
745− do unifySharedFieldsHelp context sharedFields
746− let allFields = Map.union (Map.map fst sharedFields) otherFields
747− merge context (Structure (Record1 allFields ext))
748−
749− let uniqueExpFields = Map.difference expFields actFields
750− let uniqueActFields = Map.difference actFields expFields
751−
752− case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
753− (_, True, _, True) ->
754− do subUnify context expVar actVar
755− unifySharedFields Map.empty expVar
756−
757− (Empty, _, _, False) ->
758− mismatch context $ Just $
759− MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
760−
761− (_, False, Empty, _) ->
762− mismatch context $ Just $
763− MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
764−
765− (_, False, _, True) ->
766− do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
767− subUnify context subRecord actVar
768− unifySharedFields Map.empty subRecord
769−
770− (_, True, _, False) ->
771− do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
772− subUnify context expVar subRecord
773− unifySharedFields Map.empty subRecord
774−
775− (Extension, False, Extension, False) ->
776− do let subFields = Map.union uniqueExpFields uniqueActFields
777− subExt <- fresh context Type.unnamedFlexVar
778− expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
779− actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
780− subUnify context expVar expRecord
781− subUnify context actRecord actVar
782− unifySharedFields subFields subExt
783−
784−
785−
786−unifySharedFieldsHelp :: Context -> Map.Map N.Name (Variable, Variable) -> Unify ()
787−unifySharedFieldsHelp context sharedFields =
788− do badFields <- Map.traverseMaybeWithKey (unifyField context) sharedFields
789− case Map.toList badFields of
621+ [] ->
622+ case args2 of
790623 [] ->
791− return ()
624+ ok vars ()
625+
626+ _ ->
627+ err vars ()
628+
792629
793− badFieldPairs ->
794− mismatch context (Just (BadFields badFieldPairs))
630+
631+-- UNIFY RECORDS
795632
796633
797−unifyField :: Context -> N.Name -> (Variable, Variable) -> Unify (Maybe (Maybe Reason))
798−unifyField context _ (actual, expected) =
634+unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
635+unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2) =
636+ let
637+ sharedFields = Map.intersectionWith (,) fields1 fields2
638+ uniqueFields1 = Map.difference fields1 fields2
639+ uniqueFields2 = Map.difference fields2 fields1
640+ in
641+ if Map.null uniqueFields1 then
642+
643+ if Map.null uniqueFields2 then
644+ try2
645+ (subUnify ext1 ext2)
646+ (unifySharedFields context sharedFields Map.empty ext1)
647+
648+ else
649+ do subRecord <- fresh context (Structure (Record1 uniqueFields1 ext1))
650+ try2
651+ (subUnify subRecord ext2)
652+ (unifySharedFields context sharedFields Map.empty subRecord)
653+
654+ else
655+
656+ if Map.null uniqueFields2 then
657+ do subRecord <- fresh context (Structure (Record1 uniqueFields2 ext2))
658+ try2
659+ (subUnify ext1 subRecord)
660+ (unifySharedFields context sharedFields Map.empty subRecord)
661+
662+ else
663+ do let otherFields = Map.union uniqueFields1 uniqueFields2
664+ ext <- fresh context Type.unnamedFlexVar
665+ sub1 <- fresh context (Structure (Record1 uniqueFields1 ext))
666+ sub2 <- fresh context (Structure (Record1 uniqueFields2 ext))
667+ try3
668+ (subUnify ext1 sub2)
669+ (subUnify sub1 ext2)
670+ (unifySharedFields context sharedFields otherFields ext)
671+
672+
673+unifySharedFields :: Context -> Map.Map N.Name (Variable, Variable) -> Map.Map N.Name Variable -> Variable -> Unify ()
674+unifySharedFields context sharedFields otherFields ext =
675+ do matchingFields <- Map.traverseMaybeWithKey unifyField sharedFields
676+ if Map.size sharedFields == Map.size matchingFields
677+ then merge context (Structure (Record1 (Map.union matchingFields otherFields) ext))
678+ else mismatch
679+
680+
681+unifyField :: N.Name -> (Variable, Variable) -> Unify (Maybe Variable)
682+unifyField _ (actual, expected) =
799683 Unify $ \vars ok _ ->
800− case subUnify context actual expected of
684+ case subUnify actual expected of
801685 Unify k ->
802686 k vars
687+ (\vs () -> ok vs (Just actual))
803688 (\vs () -> ok vs Nothing)
804− (\vs problem ->
805− ok vs $ Just $
806− case problem of
807− Reason _ reason ->
808− reason
809−
810− Infinite ->
811− Nothing
812− )
813689
814690
815691
@@ -819,30 +695,21 @@ unifyField context _ (actual, expected) =
819695data RecordStructure =
820696 RecordStructure
821697 { _fields :: Map.Map N.Name Variable
822− , _extVar :: Variable
823− , _extStruct :: ExtensionStructure
698+ , _extension :: Variable
824699 }
825700
826701
827−data ExtensionStructure
828− = Empty
829− | Extension
830−
831−
832−gatherFields :: Context -> Map.Map N.Name Variable -> Variable -> IO RecordStructure
833−gatherFields context fields variable =
702+gatherFields :: Map.Map N.Name Variable -> Variable -> IO RecordStructure
703+gatherFields fields variable =
834704 do (Descriptor content _ _ _) <- UF.get variable
835705 case content of
836706 Structure (Record1 subFields subExt) ->
837− gatherFields context (Map.union fields subFields) subExt
838−
839− Structure EmptyRecord1 ->
840− return (RecordStructure fields variable Empty)
707+ gatherFields (Map.union fields subFields) subExt
841708
842709 Alias _ _ _ var ->
843710 -- TODO may be dropping useful alias info here
844− gatherFields context fields var
711+ gatherFields fields var
845712
846713 _ ->
847− return (RecordStructure fields variable Extension)
714+ return (RecordStructure fields variable)
848715