git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/Type/Unify.hs
701 lines 18 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings, Rank2Types #-}
3module Type.Unify
4 ( Answer(..)
5 , unify
6 )
7 where
10import qualified Data.Map.Strict as Map
11import qualified Data.Name as Name
13import qualified Elm.ModuleName as ModuleName
14import qualified Type.Error as Error
15import qualified Type.Occurs as Occurs
16import Type.Type as Type
17import qualified Type.UnionFind as UF
21-- UNIFY
24data Answer
25 = Ok [Variable]
26 | Err [Variable] Error.Type Error.Type
29unify :: Variable -> Variable -> IO Answer
30unify v1 v2 =
31 case guardedUnify v1 v2 of
32 Unify k ->
33 k [] onSuccess $ \vars () ->
34 do t1 <- Type.toErrorType v1
35 t2 <- Type.toErrorType v2
36 UF.union v1 v2 errorDescriptor
37 return (Err vars t1 t2)
40onSuccess :: [Variable] -> () -> IO Answer
41onSuccess vars () =
42 return (Ok vars)
45{-# NOINLINE errorDescriptor #-}
46errorDescriptor :: Descriptor
47errorDescriptor =
48 Descriptor Error noRank noMark Nothing
52-- CPS UNIFIER
55newtype Unify a =
56 Unify (forall r.
57 [Variable]
58 -> ([Variable] -> a -> IO r)
59 -> ([Variable] -> () -> IO r)
60 -> IO r
61 )
64instance Functor Unify where
65 fmap func (Unify kv) =
66 Unify $ \vars ok err ->
67 let
68 ok1 vars1 value =
69 ok vars1 (func value)
70 in
71 kv vars ok1 err
74instance Applicative Unify where
75 pure a =
76 Unify $ \vars ok _ ->
77 ok vars a
79 (<*>) (Unify kf) (Unify kv) =
80 Unify $ \vars ok err ->
81 let
82 ok1 vars1 func =
83 let
84 ok2 vars2 value =
85 ok vars2 (func value)
86 in
87 kv vars1 ok2 err
88 in
89 kf vars ok1 err
92instance Monad Unify where
93 -- TODO PERF add INLINE here?
94 return a =
95 Unify $ \vars ok _ ->
96 ok vars a
98 (>>=) (Unify ka) callback =
99 Unify $ \vars ok err ->
100 let
101 ok1 vars1 a =
102 case callback a of
103 Unify kb -> kb vars1 ok err
104 in
105 ka vars ok1 err
107 (>>) (Unify ka) (Unify kb) =
108 Unify $ \vars ok err ->
109 let
110 ok1 vars1 _ = kb vars1 ok err
111 in
112 ka vars ok1 err
115register :: IO Variable -> Unify Variable
116register mkVar =
117 Unify $ \vars ok _ ->
118 do var <- mkVar
119 ok (var:vars) var
122mismatch :: Unify a
123mismatch =
124 Unify $ \vars _ err ->
125 err vars ()
129-- UNIFICATION HELPERS
132data Context =
133 Context
134 { _first :: Variable
135 , _firstDesc :: Descriptor
136 , _second :: Variable
137 , _secondDesc :: Descriptor
138 }
141reorient :: Context -> Context
142reorient (Context var1 desc1 var2 desc2) =
143 Context var2 desc2 var1 desc1
147-- MERGE
150merge :: Context -> Content -> Unify ()
151merge (Context var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
152 Unify $ \vars ok _ ->
153 ok vars =<<
154 UF.union var1 var2 (Descriptor content (min rank1 rank2) noMark Nothing)
157fresh :: Context -> Content -> Unify Variable
158fresh (Context _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
159 register $ UF.fresh $
160 Descriptor content (min rank1 rank2) noMark Nothing
164-- ACTUALLY UNIFY THINGS
167guardedUnify :: Variable -> Variable -> Unify ()
168guardedUnify left right =
169 Unify $ \vars ok err ->
170 do equivalent <- UF.equivalent left right
171 if equivalent
172 then ok vars ()
173 else
174 do leftDesc <- UF.get left
175 rightDesc <- UF.get right
176 case actuallyUnify (Context left leftDesc right rightDesc) of
177 Unify k ->
178 k vars ok err
181subUnify :: Variable -> Variable -> Unify ()
182subUnify var1 var2 =
183 guardedUnify var1 var2
186actuallyUnify :: Context -> Unify ()
187actuallyUnify context@(Context _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
188 case firstContent of
189 FlexVar _ ->
190 unifyFlex context firstContent secondContent
192 FlexSuper super _ ->
193 unifyFlexSuper context super firstContent secondContent
195 RigidVar _ ->
196 unifyRigid context Nothing firstContent secondContent
198 RigidSuper super _ ->
199 unifyRigid context (Just super) firstContent secondContent
201 Alias home name args realVar ->
202 unifyAlias context home name args realVar secondContent
204 Structure flatType ->
205 unifyStructure context flatType firstContent secondContent
207 Error ->
208 -- If there was an error, just pretend it is okay. This lets us avoid
209 -- "cascading" errors where one problem manifests as multiple message.
210 merge context Error
214-- UNIFY FLEXIBLE VARIABLES
217unifyFlex :: Context -> Content -> Content -> Unify ()
218unifyFlex context content otherContent =
219 case otherContent of
220 Error ->
221 merge context Error
223 -- TODO see if wildcarding makes a noticable perf difference
225 FlexVar maybeName ->
226 merge context $
227 case maybeName of
228 Nothing ->
229 content
231 Just _ ->
232 otherContent
234 FlexSuper _ _ ->
235 merge context otherContent
237 RigidVar _ ->
238 merge context otherContent
240 RigidSuper _ _ ->
241 merge context otherContent
243 Alias _ _ _ _ ->
244 merge context otherContent
246 Structure _ ->
247 merge context otherContent
251-- UNIFY RIGID VARIABLES
254unifyRigid :: Context -> Maybe SuperType -> Content -> Content -> Unify ()
255unifyRigid context maybeSuper content otherContent =
256 case otherContent of
257 FlexVar _ ->
258 merge context content
260 FlexSuper otherSuper _ ->
261 case maybeSuper of
262 Just super ->
263 if combineRigidSupers super otherSuper then
264 merge context content
265 else
266 mismatch
268 Nothing ->
269 mismatch
271 RigidVar _ ->
272 mismatch
274 RigidSuper _ _ ->
275 mismatch
277 Alias _ _ _ _ ->
278 mismatch
280 Structure _ ->
281 mismatch
283 Error ->
284 merge context Error
288-- UNIFY SUPER VARIABLES
291unifyFlexSuper :: Context -> SuperType -> Content -> Content -> Unify ()
292unifyFlexSuper context super content otherContent =
293 case otherContent of
294 Structure flatType ->
295 unifyFlexSuperStructure context super flatType
297 RigidVar _ ->
298 mismatch
300 RigidSuper otherSuper _ ->
301 if combineRigidSupers otherSuper super then
302 merge context otherContent
303 else
304 mismatch
306 FlexVar _ ->
307 merge context content
309 FlexSuper otherSuper _ ->
310 case super of
311 Number ->
312 case otherSuper of
313 Number -> merge context content
314 Comparable -> merge context content
315 Appendable -> mismatch
316 CompAppend -> mismatch
318 Comparable ->
319 case otherSuper of
320 Comparable -> merge context otherContent
321 Number -> merge context otherContent
322 Appendable -> merge context (Type.unnamedFlexSuper CompAppend)
323 CompAppend -> merge context otherContent
325 Appendable ->
326 case otherSuper of
327 Appendable -> merge context otherContent
328 Comparable -> merge context (Type.unnamedFlexSuper CompAppend)
329 CompAppend -> merge context otherContent
330 Number -> mismatch
332 CompAppend ->
333 case otherSuper of
334 Comparable -> merge context content
335 Appendable -> merge context content
336 CompAppend -> merge context content
337 Number -> mismatch
339 Alias _ _ _ realVar ->
340 subUnify (_first context) realVar
342 Error ->
343 merge context Error
346combineRigidSupers :: SuperType -> SuperType -> Bool
347combineRigidSupers rigid flex =
348 rigid == flex
349 || (rigid == Number && flex == Comparable)
350 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
353atomMatchesSuper :: SuperType -> ModuleName.Canonical -> Name.Name -> Bool
354atomMatchesSuper super home name =
355 case super of
356 Number ->
357 isNumber home name
359 Comparable ->
360 isNumber home name
361 || Error.isString home name
362 || Error.isChar home name
364 Appendable ->
365 Error.isString home name
367 CompAppend ->
368 Error.isString home name
371isNumber :: ModuleName.Canonical -> Name.Name -> Bool
372isNumber home name =
373 home == ModuleName.basics
374 &&
375 (name == Name.int || name == Name.float)
378unifyFlexSuperStructure :: Context -> SuperType -> FlatType -> Unify ()
379unifyFlexSuperStructure context super flatType =
380 case flatType of
381 App1 home name [] ->
382 if atomMatchesSuper super home name then
383 merge context (Structure flatType)
384 else
385 mismatch
387 App1 home name [variable] | home == ModuleName.list && name == Name.list ->
388 case super of
389 Number ->
390 mismatch
392 Appendable ->
393 merge context (Structure flatType)
395 Comparable ->
396 do comparableOccursCheck context
397 merge context (Structure flatType)
398 unifyComparableRecursive variable
400 CompAppend ->
401 do comparableOccursCheck context
402 merge context (Structure flatType)
403 unifyComparableRecursive variable
405 Tuple1 a b maybeC ->
406 case super of
407 Number ->
408 mismatch
410 Appendable ->
411 mismatch
413 Comparable ->
414 do comparableOccursCheck context
415 merge context (Structure flatType)
416 unifyComparableRecursive a
417 unifyComparableRecursive b
418 case maybeC of
419 Nothing ->
420 return ()
422 Just c ->
423 unifyComparableRecursive c
425 CompAppend ->
426 mismatch
428 _ ->
429 mismatch
432-- TODO: is there some way to avoid doing this?
433-- Do type classes require occurs checks?
434comparableOccursCheck :: Context -> Unify ()
435comparableOccursCheck (Context _ _ var _) =
436 Unify $ \vars ok err ->
437 do hasOccurred <- Occurs.occurs var
438 if hasOccurred
439 then err vars ()
440 else ok vars ()
443unifyComparableRecursive :: Variable -> Unify ()
444unifyComparableRecursive var =
445 do compVar <- register $
446 do (Descriptor _ rank _ _) <- UF.get var
447 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
448 guardedUnify compVar var
452-- UNIFY ALIASES
455unifyAlias :: Context -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Variable)] -> Variable -> Content -> Unify ()
456unifyAlias context home name args realVar otherContent =
457 case otherContent of
458 FlexVar _ ->
459 merge context (Alias home name args realVar)
461 FlexSuper _ _ ->
462 subUnify realVar (_second context)
464 RigidVar _ ->
465 subUnify realVar (_second context)
467 RigidSuper _ _ ->
468 subUnify realVar (_second context)
470 Alias otherHome otherName otherArgs otherRealVar ->
471 if name == otherName && home == otherHome then
472 Unify $ \vars ok err ->
473 let
474 ok1 vars1 () =
475 case merge context otherContent of
476 Unify k ->
477 k vars1 ok err
478 in
479 unifyAliasArgs vars context args otherArgs ok1 err
481 else
482 subUnify realVar otherRealVar
484 Structure _ ->
485 subUnify realVar (_second context)
487 Error ->
488 merge context Error
491unifyAliasArgs :: [Variable] -> Context -> [(Name.Name,Variable)] -> [(Name.Name,Variable)] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r
492unifyAliasArgs vars context args1 args2 ok err =
493 case args1 of
494 (_,arg1):others1 ->
495 case args2 of
496 (_,arg2):others2 ->
497 case subUnify arg1 arg2 of
498 Unify k ->
499 k vars
500 (\vs () -> unifyAliasArgs vs context others1 others2 ok err)
501 (\vs () -> unifyAliasArgs vs context others1 others2 err err)
503 _ ->
504 err vars ()
506 [] ->
507 case args2 of
508 [] ->
509 ok vars ()
511 _ ->
512 err vars ()
516-- UNIFY STRUCTURES
519unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
520unifyStructure context flatType content otherContent =
521 case otherContent of
522 FlexVar _ ->
523 merge context content
525 FlexSuper super _ ->
526 unifyFlexSuperStructure (reorient context) super flatType
528 RigidVar _ ->
529 mismatch
531 RigidSuper _ _ ->
532 mismatch
534 Alias _ _ _ realVar ->
535 subUnify (_first context) realVar
537 Structure otherFlatType ->
538 case (flatType, otherFlatType) of
539 (App1 home name args, App1 otherHome otherName otherArgs) | home == otherHome && name == otherName ->
540 Unify $ \vars ok err ->
541 let
542 ok1 vars1 () =
543 case merge context otherContent of
544 Unify k ->
545 k vars1 ok err
546 in
547 unifyArgs vars context args otherArgs ok1 err
549 (Fun1 arg1 res1, Fun1 arg2 res2) ->
550 do subUnify arg1 arg2
551 subUnify res1 res2
552 merge context otherContent
554 (EmptyRecord1, EmptyRecord1) ->
555 merge context otherContent
557 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
558 subUnify ext (_second context)
560 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
561 subUnify (_first context) ext
563 (Record1 fields1 ext1, Record1 fields2 ext2) ->
564 Unify $ \vars ok err ->
565 do structure1 <- gatherFields fields1 ext1
566 structure2 <- gatherFields fields2 ext2
567 case unifyRecord context structure1 structure2 of
568 Unify k ->
569 k vars ok err
571 (Tuple1 a b Nothing, Tuple1 x y Nothing) ->
572 do subUnify a x
573 subUnify b y
574 merge context otherContent
576 (Tuple1 a b (Just c), Tuple1 x y (Just z)) ->
577 do subUnify a x
578 subUnify b y
579 subUnify c z
580 merge context otherContent
582 (Unit1, Unit1) ->
583 merge context otherContent
585 _ ->
586 mismatch
588 Error ->
589 merge context Error
593-- UNIFY ARGS
596unifyArgs :: [Variable] -> Context -> [Variable] -> [Variable] -> ([Variable] -> () -> IO r) -> ([Variable] -> () -> IO r) -> IO r
597unifyArgs vars context args1 args2 ok err =
598 case args1 of
599 arg1:others1 ->
600 case args2 of
601 arg2:others2 ->
602 case subUnify arg1 arg2 of
603 Unify k ->
604 k vars
605 (\vs () -> unifyArgs vs context others1 others2 ok err)
606 (\vs () -> unifyArgs vs context others1 others2 err err)
608 _ ->
609 err vars ()
611 [] ->
612 case args2 of
613 [] ->
614 ok vars ()
616 _ ->
617 err vars ()
621-- UNIFY RECORDS
624unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
625unifyRecord context (RecordStructure fields1 ext1) (RecordStructure fields2 ext2) =
626 let
627 sharedFields = Map.intersectionWith (,) fields1 fields2
628 uniqueFields1 = Map.difference fields1 fields2
629 uniqueFields2 = Map.difference fields2 fields1
630 in
631 if Map.null uniqueFields1 then
633 if Map.null uniqueFields2 then
634 do subUnify ext1 ext2
635 unifySharedFields context sharedFields Map.empty ext1
637 else
638 do subRecord <- fresh context (Structure (Record1 uniqueFields2 ext2))
639 subUnify ext1 subRecord
640 unifySharedFields context sharedFields Map.empty subRecord
642 else
644 if Map.null uniqueFields2 then
645 do subRecord <- fresh context (Structure (Record1 uniqueFields1 ext1))
646 subUnify subRecord ext2
647 unifySharedFields context sharedFields Map.empty subRecord
649 else
650 do let otherFields = Map.union uniqueFields1 uniqueFields2
651 ext <- fresh context Type.unnamedFlexVar
652 sub1 <- fresh context (Structure (Record1 uniqueFields1 ext))
653 sub2 <- fresh context (Structure (Record1 uniqueFields2 ext))
654 subUnify ext1 sub2
655 subUnify sub1 ext2
656 unifySharedFields context sharedFields otherFields ext
659unifySharedFields :: Context -> Map.Map Name.Name (Variable, Variable) -> Map.Map Name.Name Variable -> Variable -> Unify ()
660unifySharedFields context sharedFields otherFields ext =
661 do matchingFields <- Map.traverseMaybeWithKey unifyField sharedFields
662 if Map.size sharedFields == Map.size matchingFields
663 then merge context (Structure (Record1 (Map.union matchingFields otherFields) ext))
664 else mismatch
667unifyField :: Name.Name -> (Variable, Variable) -> Unify (Maybe Variable)
668unifyField _ (actual, expected) =
669 Unify $ \vars ok _ ->
670 case subUnify actual expected of
671 Unify k ->
672 k vars
673 (\vs () -> ok vs (Just actual))
674 (\vs () -> ok vs Nothing)
678-- GATHER RECORD STRUCTURE
681data RecordStructure =
682 RecordStructure
683 { _fields :: Map.Map Name.Name Variable
684 , _extension :: Variable
685 }
688gatherFields :: Map.Map Name.Name Variable -> Variable -> IO RecordStructure
689gatherFields fields variable =
690 do (Descriptor content _ _ _) <- UF.get variable
691 case content of
692 Structure (Record1 subFields subExt) ->
693 gatherFields (Map.union fields subFields) subExt
695 Alias _ _ _ var ->
696 -- TODO may be dropping useful alias info here
697 gatherFields fields var
699 _ ->
700 return (RecordStructure fields variable)