git.iko.soy/elk
on 1be6293 help sign in
elk/src/Type/Unify.hs
776 lines 22 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings, Rank2Types #-}
3module Type.Unify (unify) where
5import Control.Monad (foldM, liftM2, zipWithM_)
6import Control.Monad.Trans (liftIO)
7import qualified Data.Map.Strict as Map
9import qualified AST.Module.Name as ModuleName
10import qualified Elm.Name as N
11import qualified Reporting.Region as R
12import qualified Reporting.Error.Type as Error
13import qualified Type.Occurs as Occurs
14import qualified Type.State as TS
15import Type.Type as Type
16import qualified Type.UnionFind as UF
20-- UNIFY
23unify :: R.Region -> Variable -> Variable -> TS.Solver ()
24unify region actual expected =
25 do answer <- run (guardedUnify ActualExpected actual expected)
26 case answer of
27 Ok ->
28 return ()
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
40 Infinite ->
41 Error.InfiniteType actualSrcType
44data Answer = Ok | Err Problem
47run :: Unify () -> TS.Solver Answer
48run (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
58-- CPS UNIFIER
61newtype Unify a =
62 Unify (forall r.
63 [Variable]
64 -> ([Variable] -> a -> IO r)
65 -> ([Variable] -> Problem -> IO r)
66 -> IO r
67 )
70instance Functor Unify where
71 fmap func (Unify kv) =
72 Unify $ \vars ok err ->
73 let
74 ok1 vars1 value =
75 ok vars1 (func value)
76 in
77 kv vars ok1 err
80instance Applicative Unify where
81 pure a =
82 Unify $ \vars ok _ ->
83 ok vars a
85 (<*>) (Unify kf) (Unify kv) =
86 Unify $ \vars ok err ->
87 let
88 ok1 vars1 func =
89 let
90 ok2 vars2 value =
91 ok vars2 (func value)
92 in
93 kv vars1 ok2 err
94 in
95 kf vars ok1 err
98instance Monad Unify where
99 return a =
100 Unify $ \vars ok _ ->
101 ok vars a
103 (>>=) (Unify ka) callback =
104 Unify $ \vars ok err ->
105 let
106 ok1 vars1 a =
107 case callback a of
108 Unify kb -> kb vars1 ok err
109 in
110 ka vars ok1 err
113register :: IO Variable -> Unify Variable
114register mkVar =
115 Unify $ \vars ok _ ->
116 do var <- mkVar
117 ok (var:vars) var
121-- UNIFICATION HELPERS
124data Context =
125 Context
126 { _orientation :: Orientation
127 , _first :: Variable
128 , _firstDesc :: Descriptor
129 , _second :: Variable
130 , _secondDesc :: Descriptor
131 }
134data Orientation
135 = ExpectedActual
136 | ActualExpected
139reorient :: Context -> Context
140reorient (Context orientation var1 desc1 var2 desc2) =
141 let
142 otherOrientation =
143 case orientation of
144 ExpectedActual -> ActualExpected
145 ActualExpected -> ExpectedActual
146 in
147 Context otherOrientation var2 desc2 var1 desc1
151-- ERROR MESSAGES
154data Problem
155 = Reason Bool (Maybe Error.Reason)
156 | Infinite
159mismatch :: Context -> Maybe Error.Reason -> Unify a
160mismatch context@(Context orientation var1 _ var2 _) maybeReason =
161 Unify $ \vars _ err ->
162 do anyInfinite <- liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
163 if anyInfinite
164 then err vars Infinite
165 else
166 do args1 <- collectArgs [] var1
167 args2 <- collectArgs [] var2
169 hasDecoder <-
170 or <$> traverse detectDecoder (args1 ++ args2)
172 if length args1 /= length args2
173 then
174 do newVars <- foldM (subUnifyAnyway context) vars (zip args1 args2)
175 err newVars $ Reason hasDecoder $ Just $
176 Error.MissingArgs (abs (length args2 - length args1))
177 else
178 err vars $ Reason hasDecoder $
179 case orientation of
180 ExpectedActual ->
181 maybeReason
183 ActualExpected ->
184 fmap Error.flipReason maybeReason
187subUnifyAnyway :: Context -> [Variable] -> (Variable, Variable) -> IO [Variable]
188subUnifyAnyway context vars (arg1, arg2) =
189 case subUnify context arg1 arg2 of
190 Unify k ->
191 k vars (\vs _ -> return vs) (\vs _ -> return vs)
194collectArgs :: [Variable] -> Variable -> IO [Variable]
195collectArgs revArgs variable =
196 do (Descriptor content _ _ _) <- UF.descriptor variable
197 case content of
198 Structure (Fun1 arg returnType) ->
199 collectArgs (arg : revArgs) returnType
201 _ ->
202 return $ variable : revArgs
205detectDecoder :: Variable -> IO Bool
206detectDecoder variable =
207 do (Descriptor content _ _ _) <- UF.descriptor variable
208 case content of
209 Structure (App1 home name [_]) ->
210 return (home == ModuleName.jsonDecode && name == "Decoder")
212 _ ->
213 return False
217-- MERGE
220merge :: Context -> Content -> Unify ()
221merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
222 Unify $ \vars ok _ ->
223 ok vars =<< mergeHelp var1 var2 content (min rank1 rank2)
226mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
227mergeHelp var1 var2 newContent newRank =
228 UF.union var1 var2 $
229 Descriptor newContent newRank noMark Nothing
232fresh :: Context -> Content -> Unify Variable
233fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
234 register $ UF.fresh $
235 Descriptor content (min rank1 rank2) noMark Nothing
239-- ACTUALLY UNIFY THINGS
242guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
243guardedUnify orientation left right =
244 Unify $ \vars ok err ->
245 do equivalent <- UF.equivalent left right
246 if equivalent
247 then ok vars ()
248 else
249 do leftDesc <- UF.descriptor left
250 rightDesc <- UF.descriptor right
251 case actuallyUnify (Context orientation left leftDesc right rightDesc) of
252 Unify k ->
253 k vars ok err
256subUnify :: Context -> Variable -> Variable -> Unify ()
257subUnify context var1 var2 =
258 guardedUnify (_orientation context) var1 var2
261actuallyUnify :: Context -> Unify ()
262actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
263 case firstContent of
264 FlexVar _ ->
265 unifyFlex context secondContent
267 FlexSuper super _ ->
268 unifyFlexSuper context super firstContent secondContent
270 RigidVar name ->
271 unifyRigid context Nothing name firstContent secondContent
273 RigidSuper super name ->
274 unifyRigid context (Just super) name firstContent secondContent
276 Alias home name args realVar ->
277 unifyAlias context home name args realVar secondContent
279 Structure flatType ->
280 unifyStructure context flatType firstContent secondContent
282 Error _ ->
283 -- If there was an error, just pretend it is okay. This lets us avoid
284 -- "cascading" errors where one problem manifests as multiple message.
285 return ()
289-- UNIFY FLEXIBLE VARIABLES
292unifyFlex :: Context -> Content -> Unify ()
293unifyFlex context otherContent =
294 case otherContent of
295 Error _ ->
296 return ()
298 -- TODO see if wildcarding makes a noticable perf difference
300 FlexVar _ ->
301 merge context otherContent
303 FlexSuper _ _ ->
304 merge context otherContent
306 RigidVar _ ->
307 merge context otherContent
309 RigidSuper _ _ ->
310 merge context otherContent
312 Alias _ _ _ _ ->
313 merge context otherContent
315 Structure _ ->
316 merge context otherContent
320-- UNIFY RIGID VARIABLES
323unifyRigid :: Context -> Maybe SuperType -> N.Name -> Content -> Content -> Unify ()
324unifyRigid context maybeSuper name content otherContent =
325 case otherContent of
326 FlexVar _ ->
327 merge context content
329 FlexSuper otherSuper _ ->
330 case maybeSuper of
331 Just super ->
332 if combineRigidSupers super otherSuper then
333 merge context content
334 else
335 mismatch context $ Just $
336 Error.RigidSuperTooGeneric super name $ Error.SpecificSuper otherSuper
338 Nothing ->
339 mismatch context $ Just $
340 Error.RigidVarTooGeneric name $ Error.SpecificSuper otherSuper
342 RigidVar otherName ->
343 mismatch context $ Just $
344 Error.RigidClash name otherName
346 RigidSuper _ otherName ->
347 mismatch context $ Just $
348 Error.RigidClash name otherName
350 Alias _ otherName _ _ ->
351 mismatch context $ Just $
352 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
353 Error.SpecificType otherName
355 Structure flatType ->
356 mismatch context $ Just $
357 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
358 flatTypeToSpecificThing flatType
360 Error _ ->
361 return ()
364flatTypeToSpecificThing :: FlatType -> Error.SpecificThing
365flatTypeToSpecificThing flatType =
366 case flatType of
367 App1 _ name _ ->
368 Error.SpecificType name
370 Fun1 _ _ ->
371 Error.SpecificFunction
373 EmptyRecord1 ->
374 Error.SpecificRecord
376 Record1 _ _ ->
377 Error.SpecificRecord
379 Unit1 ->
380 Error.SpecificUnit
382 Tuple1 _ _ _ ->
383 Error.SpecificTuple
387-- UNIFY SUPER VARIABLES
390unifyFlexSuper :: Context -> SuperType -> Content -> Content -> Unify ()
391unifyFlexSuper context super content otherContent =
392 case otherContent of
393 Structure flatType ->
394 unifyFlexSuperStructure context super flatType
396 RigidVar name ->
397 mismatch context $ Just $
398 Error.RigidVarTooGeneric name (Error.SpecificSuper super)
400 RigidSuper otherSuper name ->
401 if combineRigidSupers otherSuper super then
402 merge context otherContent
403 else
404 mismatch context $ Just $
405 Error.RigidSuperTooGeneric otherSuper name (Error.SpecificSuper super)
407 FlexVar _ ->
408 merge context content
410 FlexSuper otherSuper _ ->
411 case super of
412 Number ->
413 case otherSuper of
414 Number -> merge context content
415 Comparable -> merge context content
416 _ -> mismatch context Nothing -- Error.NumberAppendableClash
418 Comparable ->
419 case otherSuper of
420 Comparable -> merge context otherContent
421 Number -> merge context otherContent
422 Appendable -> merge context (Type.unnamedFlexSuper CompAppend)
423 CompAppend -> merge context otherContent
425 Appendable ->
426 case otherSuper of
427 Appendable -> merge context otherContent
428 Comparable -> merge context (Type.unnamedFlexSuper CompAppend)
429 CompAppend -> merge context otherContent
430 Number -> mismatch context Nothing -- Error.NumberAppendableClash
432 CompAppend ->
433 case otherSuper of
434 Comparable -> merge context content
435 Appendable -> merge context content
436 CompAppend -> merge context content
437 Number -> mismatch context Nothing -- Error.NumberAppendableClash
439 Alias _ _ _ realVar ->
440 subUnify context (_first context) realVar
442 Error _ ->
443 return ()
446combineRigidSupers :: SuperType -> SuperType -> Bool
447combineRigidSupers rigid flex =
448 rigid == flex
449 || (rigid == Number && flex == Comparable)
450 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
453atomMatchesSuper :: SuperType -> ModuleName.Canonical -> N.Name -> Bool
454atomMatchesSuper super home name =
455 home == ModuleName.basics
456 &&
457 case super of
458 Number ->
459 name == N.int
460 || name == N.float
462 Comparable ->
463 name == N.int
464 || name == N.float
465 || name == N.string
466 || name == N.char
468 Appendable ->
469 name == N.string
471 CompAppend ->
472 name == N.string
475unifyFlexSuperStructure :: Context -> SuperType -> FlatType -> Unify ()
476unifyFlexSuperStructure context super flatType =
477 case flatType of
478 App1 home name [] ->
479 if atomMatchesSuper super home name then
480 merge context (Structure flatType)
481 else
482 mismatch context $ Just $ Error.NotPartOfSuper super
484 App1 home name [variable] | home == ModuleName.list && name == N.list ->
485 case super of
486 Number ->
487 mismatch context $ Just $ Error.NotPartOfSuper super
489 Appendable ->
490 merge context (Structure flatType)
492 Comparable ->
493 do comparableOccursCheck context
494 merge context (Structure flatType)
495 unifyComparableRecursive (_orientation context) variable
497 CompAppend ->
498 do comparableOccursCheck context
499 merge context (Structure flatType)
500 unifyComparableRecursive (_orientation context) variable
502 Tuple1 a b maybeC ->
503 case super of
504 Number ->
505 mismatch context $ Just $ Error.NotPartOfSuper super
507 Appendable ->
508 mismatch context $ Just $ Error.NotPartOfSuper super
510 Comparable ->
511 do comparableOccursCheck context
512 merge context (Structure flatType)
513 let orientation = _orientation context
514 unifyComparableRecursive orientation a
515 unifyComparableRecursive orientation b
516 case maybeC of
517 Nothing ->
518 return ()
520 Just c ->
521 unifyComparableRecursive orientation c
523 CompAppend ->
524 mismatch context $ Just $ Error.NotPartOfSuper super
526 _ ->
527 mismatch context $ Just $ Error.NotPartOfSuper super
530-- TODO: is there some way to avoid doing this?
531-- Do type classes require occurs checks?
532comparableOccursCheck :: Context -> Unify ()
533comparableOccursCheck (Context _ _ _ var _) =
534 Unify $ \vars ok err ->
535 do hasOccurred <- Occurs.occurs var
536 if hasOccurred
537 then err vars Infinite
538 else ok vars ()
541unifyComparableRecursive :: Orientation -> Variable -> Unify ()
542unifyComparableRecursive orientation var =
543 do compVar <- register $
544 do (Descriptor _ rank _ _) <- UF.descriptor var
545 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
546 guardedUnify orientation compVar var
550-- UNIFY ALIASES
553unifyAlias :: Context -> ModuleName.Canonical -> N.Name -> [(N.Name, Variable)] -> Variable -> Content -> Unify ()
554unifyAlias context home name args realVar otherContent =
555 case otherContent of
556 FlexVar _ ->
557 merge context (Alias home name args realVar)
559 FlexSuper _ _ ->
560 subUnify context realVar (_second context)
562 RigidVar _ ->
563 subUnify context realVar (_second context)
565 RigidSuper _ _ ->
566 subUnify context realVar (_second context)
568 Alias otherHome otherName otherArgs otherRealVar ->
569 if name == otherName && home == otherHome then
570 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
571 merge context otherContent
573 else
574 subUnify context realVar otherRealVar
576 Structure _ ->
577 subUnify context realVar (_second context)
579 Error _ ->
580 return ()
584-- UNIFY STRUCTURES
587unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
588unifyStructure context flatType content otherContent =
589 case otherContent of
590 FlexVar _ ->
591 merge context content
593 FlexSuper super _ ->
594 unifyFlexSuperStructure (reorient context) super flatType
596 RigidVar name ->
597 mismatch context $ Just $ Error.RigidVarTooGeneric name (flatTypeToSpecificThing flatType)
599 RigidSuper super name ->
600 mismatch context $ Just $ Error.RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
602 Alias _ _ _ realVar ->
603 subUnify context (_first context) realVar
605 Structure otherTerm ->
606 case (flatType, otherTerm) of
607 (App1 home name args, App1 otherHome otherName otherArgs) ->
608 if home == otherHome && name == otherName then
609 do zipWithM_ (subUnify context) args otherArgs
610 merge context otherContent
612 else if isIntFloat home name otherHome otherName then
613 mismatch context (Just Error.IntFloat)
615 else
616 mismatch context Nothing
618 (Fun1 arg result, Fun1 otherArg otherResult) ->
619 do subUnify context arg otherArg
620 subUnify context result otherResult
621 merge context otherContent
623 (EmptyRecord1, EmptyRecord1) ->
624 merge context otherContent
626 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
627 subUnify context ext (_second context)
629 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
630 subUnify context (_first context) ext
632 (Record1 fields extension, Record1 otherFields otherExtension) ->
633 Unify $ \vars ok err ->
634 do firstStructure <- gatherFields context fields extension
635 secondStructure <- gatherFields context otherFields otherExtension
636 case unifyRecord context firstStructure secondStructure of
637 Unify k ->
638 k vars ok err
640 _ ->
641 mismatch context Nothing
643 Error _ ->
644 return ()
648isIntFloat :: ModuleName.Canonical -> N.Name -> ModuleName.Canonical -> N.Name -> Bool
649isIntFloat home name otherHome otherName =
650 otherHome == ModuleName.basics
651 && home == ModuleName.basics
652 && (
653 (name == N.int && otherName == N.float)
654 ||
655 (name == N.float && otherName == N.int)
656 )
660-- UNIFY RECORDS
663unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
664unifyRecord context firstStructure secondStructure =
665 do let (RecordStructure expFields expVar expStruct) = firstStructure
666 let (RecordStructure actFields actVar actStruct) = secondStructure
668 let sharedFields = Map.intersectionWith (,) expFields actFields
670 -- call after unifying extension, make sure record shape matches before
671 -- looking into whether the particular field types match.
672 let unifySharedFields otherFields ext =
673 do unifySharedFieldsHelp context sharedFields
674 let allFields = Map.union (Map.map fst sharedFields) otherFields
675 merge context (Structure (Record1 allFields ext))
677 let uniqueExpFields = Map.difference expFields actFields
678 let uniqueActFields = Map.difference actFields expFields
680 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
681 (_, True, _, True) ->
682 do subUnify context expVar actVar
683 unifySharedFields Map.empty expVar
685 (Empty, _, _, False) ->
686 mismatch context $ Just $
687 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
689 (_, False, Empty, _) ->
690 mismatch context $ Just $
691 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
693 (_, False, _, True) ->
694 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
695 subUnify context subRecord actVar
696 unifySharedFields Map.empty subRecord
698 (_, True, _, False) ->
699 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
700 subUnify context expVar subRecord
701 unifySharedFields Map.empty subRecord
703 (Extension, False, Extension, False) ->
704 do let subFields = Map.union uniqueExpFields uniqueActFields
705 subExt <- fresh context Type.unnamedFlexVar
706 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
707 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
708 subUnify context expVar expRecord
709 subUnify context actRecord actVar
710 unifySharedFields subFields subExt
714unifySharedFieldsHelp :: Context -> Map.Map N.Name (Variable, Variable) -> Unify ()
715unifySharedFieldsHelp context sharedFields =
716 do badFields <- Map.traverseMaybeWithKey (unifyField context) sharedFields
717 case Map.toList badFields of
718 [] ->
719 return ()
721 badFieldPairs ->
722 mismatch context (Just (Error.BadFields badFieldPairs))
725unifyField :: Context -> N.Name -> (Variable, Variable) -> Unify (Maybe (Maybe Error.Reason))
726unifyField context _ (actual, expected) =
727 Unify $ \vars ok _ ->
728 case subUnify context actual expected of
729 Unify k ->
730 k vars
731 (\vs () -> ok vs Nothing)
732 (\vs problem ->
733 ok vs $ Just $
734 case problem of
735 Reason _ reason ->
736 reason
738 Infinite ->
739 Nothing
740 )
744-- GATHER RECORD STRUCTURE
747data RecordStructure =
748 RecordStructure
749 { _fields :: Map.Map N.Name Variable
750 , _extVar :: Variable
751 , _extStruct :: ExtensionStructure
752 }
755data ExtensionStructure
756 = Empty
757 | Extension
760gatherFields :: Context -> Map.Map N.Name Variable -> Variable -> IO RecordStructure
761gatherFields context fields variable =
762 do (Descriptor content _ _ _) <- UF.descriptor variable
763 case content of
764 Structure (Record1 subFields subExt) ->
765 gatherFields context (Map.union fields subFields) subExt
767 Structure EmptyRecord1 ->
768 return (RecordStructure fields variable Empty)
770 Alias _ _ _ var ->
771 -- TODO may be dropping useful alias info here
772 gatherFields context fields var
774 _ ->
775 return (RecordStructure fields variable Extension)