git.iko.soy/elk
on ea77dcf help sign in
elk/src/Type/Unify.hs
700 lines 21 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Unify (unify) where
5import Control.Monad (liftM2, when, zipWithM_)
6import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)
7import qualified Data.Map.Strict as Map
8import qualified Data.Maybe as Maybe
9import Data.Text (Text)
11import qualified AST.Module.Name as ModuleName
12import AST.Type (Super(..))
13import qualified Elm.Name as N
14import qualified Reporting.Region as R
15import qualified Reporting.Error.Type as Error
16import qualified Type.Occurs as Occurs
17import qualified Type.State as TS
18import Type.Type as Type
19import qualified Type.UnionFind as UF
23-- UNIFY
26unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
27unify hint region expected actual =
28 {-# SCC elm_compiler_type_unify #-}
29 do result <- runExceptT (guardedUnify ExpectedActual expected actual)
30 case result of
31 Right () ->
32 return ()
34 Left problem ->
35 do expectedSrcType <- liftIO $ Type.toSrcType expected
36 actualSrcType <- liftIO $ Type.toSrcType actual
37 liftIO $ mergeHelp expected actual (Error "?") noRank
38 TS.addError region $
39 case problem of
40 Reason hasDecoder maybeReason ->
41 Error.Mismatch $
42 Error.MismatchInfo hint expectedSrcType actualSrcType hasDecoder maybeReason
44 Infinite ->
45 Error.InfiniteType (Left hint) expectedSrcType
49-- UNIFICATION HELPERS
52type Unify =
53 ExceptT Problem TS.Solver
56data Context =
57 Context
58 { _orientation :: Orientation
59 , _first :: Variable
60 , _firstDesc :: Descriptor
61 , _second :: Variable
62 , _secondDesc :: Descriptor
63 }
66data Orientation
67 = ExpectedActual
68 | ActualExpected
71reorient :: Context -> Context
72reorient (Context orientation var1 desc1 var2 desc2) =
73 let
74 otherOrientation =
75 case orientation of
76 ExpectedActual -> ActualExpected
77 ActualExpected -> ExpectedActual
78 in
79 Context otherOrientation var2 desc2 var1 desc1
83-- ERROR MESSAGES
86data Problem
87 = Reason Bool (Maybe Error.Reason)
88 | Infinite
91mismatch :: Context -> Maybe Error.Reason -> Unify a
92mismatch context@(Context orientation var1 _ var2 _) maybeReason =
93 do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
94 when anyInfinite $ throwError Infinite
96 args1 <- liftIO $ collectArgs [] var1
97 args2 <- liftIO $ collectArgs [] var2
99 hasDecoder <- liftIO $ or <$> traverse detectDecoder (args1 ++ args2)
101 if length args1 /= length args2
102 then
103 do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2
104 throwError $ Reason hasDecoder $ Just $
105 Error.MissingArgs (abs (length args2 - length args1))
106 else
107 throwError $ Reason hasDecoder $
108 case orientation of
109 ExpectedActual ->
110 maybeReason
112 ActualExpected ->
113 fmap Error.flipReason maybeReason
119collectArgs :: [Variable] -> Variable -> IO [Variable]
120collectArgs revArgs variable =
121 do (Descriptor content _ _ _) <- UF.descriptor variable
122 case content of
123 Structure (Fun1 arg returnType) ->
124 collectArgs (arg : revArgs) returnType
126 _ ->
127 return $ variable : revArgs
130detectDecoder :: Variable -> IO Bool
131detectDecoder variable =
132 do (Descriptor content _ _ _) <- UF.descriptor variable
133 case content of
134 Structure (App1 home name [_]) ->
135 return (home == ModuleName.jsonDecode && name == "Decoder")
137 _ ->
138 return False
142-- MERGE
145merge :: Context -> Content -> Unify ()
146merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
147 liftIO $ mergeHelp var1 var2 content (min rank1 rank2)
150mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
151mergeHelp var1 var2 newContent newRank =
152 UF.union var1 var2 $
153 Descriptor newContent newRank noMark Nothing
156fresh :: Context -> Content -> Unify Variable
157fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
158 do freshVariable <-
159 liftIO $ UF.fresh $
160 Descriptor content (min rank1 rank2) noMark Nothing
162 lift $ TS.register freshVariable
164 return freshVariable
168-- ACTUALLY UNIFY THINGS
171guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
172guardedUnify orientation left right =
173 do equivalent <- liftIO $ UF.equivalent left right
174 if equivalent
175 then return ()
176 else
177 do leftDesc <- liftIO $ UF.descriptor left
178 rightDesc <- liftIO $ UF.descriptor right
179 actuallyUnify (Context orientation left leftDesc right rightDesc)
182subUnify :: Context -> Variable -> Variable -> Unify ()
183subUnify context var1 var2 =
184 guardedUnify (_orientation context) var1 var2
187actuallyUnify :: Context -> Unify ()
188actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
189 case firstContent of
190 FlexVar _ ->
191 unifyFlex context secondContent
193 FlexSuper super _ ->
194 unifyFlexSuper context super firstContent secondContent
196 RigidVar name ->
197 unifyRigid context Nothing name firstContent secondContent
199 RigidSuper super name ->
200 unifyRigid context (Just super) name firstContent secondContent
202 Alias home name args realVar ->
203 unifyAlias context home name args realVar secondContent
205 Structure flatType ->
206 unifyStructure context flatType firstContent secondContent
208 Error _ ->
209 -- If there was an error, just pretend it is okay. This lets us avoid
210 -- "cascading" errors where one problem manifests as multiple message.
211 return ()
215-- UNIFY FLEXIBLE VARIABLES
218unifyFlex :: Context -> Content -> Unify ()
219unifyFlex context otherContent =
220 case otherContent of
221 Error _ ->
222 return ()
224 -- TODO see if wildcarding makes a noticable perf difference
226 FlexVar _ ->
227 merge context otherContent
229 FlexSuper _ _ ->
230 merge context otherContent
232 RigidVar _ ->
233 merge context otherContent
235 RigidSuper _ _ ->
236 merge context otherContent
238 Alias _ _ _ _ ->
239 merge context otherContent
241 Structure _ ->
242 merge context otherContent
246-- UNIFY RIGID VARIABLES
249unifyRigid :: Context -> Maybe Super -> Text -> Content -> Content -> Unify ()
250unifyRigid context maybeSuper name content otherContent =
251 case otherContent of
252 FlexVar _ ->
253 merge context content
255 FlexSuper otherSuper _ ->
256 case maybeSuper of
257 Just super ->
258 if combineRigidSupers super otherSuper then
259 merge context content
260 else
261 mismatch context $ Just $
262 Error.RigidSuperTooGeneric super name $ Error.SpecificSuper otherSuper
264 Nothing ->
265 mismatch context $ Just $
266 Error.RigidVarTooGeneric name $ Error.SpecificSuper otherSuper
268 RigidVar otherName ->
269 mismatch context $ Just $
270 Error.RigidClash name otherName
272 RigidSuper _ otherName ->
273 mismatch context $ Just $
274 Error.RigidClash name otherName
276 Alias _ otherName _ _ ->
277 mismatch context $ Just $
278 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
279 Error.SpecificType otherName
281 Structure flatType ->
282 mismatch context $ Just $
283 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
284 flatTypeToSpecificThing flatType
286 Error _ ->
287 return ()
290flatTypeToSpecificThing :: FlatType -> Error.SpecificThing
291flatTypeToSpecificThing flatType =
292 case flatType of
293 App1 _ name _ ->
294 Error.SpecificType name
296 Fun1 _ _ ->
297 Error.SpecificFunction
299 EmptyRecord1 ->
300 Error.SpecificRecord
302 Record1 _ _ ->
303 Error.SpecificRecord
305 Unit1 ->
306 Error.SpecificUnit
308 Tuple1 _ _ _ ->
309 Error.SpecificTuple
313-- UNIFY SUPER VARIABLES
316unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
317unifyFlexSuper context super content otherContent =
318 case otherContent of
319 Structure flatType ->
320 unifyFlexSuperStructure context super flatType
322 RigidVar name ->
323 mismatch context $ Just $
324 Error.RigidVarTooGeneric name (Error.SpecificSuper super)
326 RigidSuper otherSuper name ->
327 if combineRigidSupers otherSuper super then
328 merge context otherContent
329 else
330 mismatch context $ Just $
331 Error.RigidSuperTooGeneric otherSuper name (Error.SpecificSuper super)
333 FlexVar _ ->
334 merge context content
336 FlexSuper otherSuper _ ->
337 case super of
338 Number ->
339 case otherSuper of
340 Number -> merge context content
341 Comparable -> merge context content
342 _ -> mismatch context Nothing -- Error.NumberAppendableClash
344 Comparable ->
345 case otherSuper of
346 Comparable -> merge context otherContent
347 Number -> merge context otherContent
348 Appendable -> merge context (Type.unnamedFlexSuper CompAppend)
349 CompAppend -> merge context otherContent
351 Appendable ->
352 case otherSuper of
353 Appendable -> merge context otherContent
354 Comparable -> merge context (Type.unnamedFlexSuper CompAppend)
355 CompAppend -> merge context otherContent
356 Number -> mismatch context Nothing -- Error.NumberAppendableClash
358 CompAppend ->
359 case otherSuper of
360 Comparable -> merge context content
361 Appendable -> merge context content
362 CompAppend -> merge context content
363 Number -> mismatch context Nothing -- Error.NumberAppendableClash
365 Alias _ _ _ realVar ->
366 subUnify context (_first context) realVar
368 Error _ ->
369 return ()
372combineRigidSupers :: Super -> Super -> Bool
373combineRigidSupers rigid flex =
374 rigid == flex
375 || (rigid == Number && flex == Comparable)
376 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
379atomMatchesSuper :: Super -> ModuleName.Canonical -> N.Name -> Bool
380atomMatchesSuper super home name =
381 home == ModuleName.basics
382 &&
383 case super of
384 Number ->
385 name == N.int
386 || name == N.float
388 Comparable ->
389 name == N.int
390 || name == N.float
391 || name == N.string
392 || name == N.char
394 Appendable ->
395 name == N.string
397 CompAppend ->
398 name == N.string
401unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
402unifyFlexSuperStructure context super flatType =
403 case flatType of
404 App1 home name [] ->
405 if atomMatchesSuper super home name then
406 merge context (Structure flatType)
407 else
408 mismatch context $ Just $ Error.NotPartOfSuper super
410 App1 home name [variable] | home == ModuleName.list && name == N.list ->
411 case super of
412 Number ->
413 mismatch context $ Just $ Error.NotPartOfSuper super
415 Appendable ->
416 merge context (Structure flatType)
418 Comparable ->
419 do comparableOccursCheck context
420 merge context (Structure flatType)
421 unifyComparableRecursive (_orientation context) variable
423 CompAppend ->
424 do comparableOccursCheck context
425 merge context (Structure flatType)
426 unifyComparableRecursive (_orientation context) variable
428 Tuple1 a b maybeC ->
429 case super of
430 Number ->
431 mismatch context $ Just $ Error.NotPartOfSuper super
433 Appendable ->
434 mismatch context $ Just $ Error.NotPartOfSuper super
436 Comparable ->
437 do comparableOccursCheck context
438 merge context (Structure flatType)
439 let orientation = _orientation context
440 unifyComparableRecursive orientation a
441 unifyComparableRecursive orientation b
442 case maybeC of
443 Nothing ->
444 return ()
446 Just c ->
447 unifyComparableRecursive orientation c
449 CompAppend ->
450 mismatch context $ Just $ Error.NotPartOfSuper super
452 _ ->
453 mismatch context $ Just $ Error.NotPartOfSuper super
456-- TODO: is there some way to avoid doing this?
457-- Do type classes require occurs checks?
458comparableOccursCheck :: Context -> Unify ()
459comparableOccursCheck (Context _ _ _ var _) =
460 do hasOccurred <- liftIO $ Occurs.occurs var
461 if hasOccurred
462 then throwError Infinite
463 else return ()
466unifyComparableRecursive :: Orientation -> Variable -> Unify ()
467unifyComparableRecursive orientation var =
468 do compVar <- liftIO $
469 do (Descriptor _ rank _ _) <- UF.descriptor var
470 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
472 lift $ TS.register compVar
474 guardedUnify orientation compVar var
478-- UNIFY ALIASES
481unifyAlias :: Context -> ModuleName.Canonical -> N.Name -> [(Text, Variable)] -> Variable -> Content -> Unify ()
482unifyAlias context home name args realVar otherContent =
483 case otherContent of
484 FlexVar _ ->
485 merge context (Alias home name args realVar)
487 FlexSuper _ _ ->
488 subUnify context realVar (_second context)
490 RigidVar _ ->
491 subUnify context realVar (_second context)
493 RigidSuper _ _ ->
494 subUnify context realVar (_second context)
496 Alias otherHome otherName otherArgs otherRealVar ->
497 if name == otherName && home == otherHome then
498 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
499 merge context otherContent
501 else
502 subUnify context realVar otherRealVar
504 Structure _ ->
505 subUnify context realVar (_second context)
507 Error _ ->
508 return ()
512-- UNIFY STRUCTURES
515unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
516unifyStructure context flatType content otherContent =
517 case otherContent of
518 FlexVar _ ->
519 merge context content
521 FlexSuper super _ ->
522 unifyFlexSuperStructure (reorient context) super flatType
524 RigidVar name ->
525 mismatch context $ Just $ Error.RigidVarTooGeneric name (flatTypeToSpecificThing flatType)
527 RigidSuper super name ->
528 mismatch context $ Just $ Error.RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
530 Alias _ _ _ realVar ->
531 subUnify context (_first context) realVar
533 Structure otherTerm ->
534 case (flatType, otherTerm) of
535 (App1 home name args, App1 otherHome otherName otherArgs) ->
536 if home == otherHome && name == otherName then
537 do zipWithM_ (subUnify context) args otherArgs
538 merge context otherContent
540 else if isIntFloat home name otherHome otherName then
541 mismatch context (Just Error.IntFloat)
543 else
544 mismatch context Nothing
546 (Fun1 arg result, Fun1 otherArg otherResult) ->
547 do subUnify context arg otherArg
548 subUnify context result otherResult
549 merge context otherContent
551 (EmptyRecord1, EmptyRecord1) ->
552 merge context otherContent
554 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
555 subUnify context ext (_second context)
557 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
558 subUnify context (_first context) ext
560 (Record1 fields extension, Record1 otherFields otherExtension) ->
561 do firstStructure <- liftIO $ gatherFields context fields extension
562 secondStructure <- liftIO $ gatherFields context otherFields otherExtension
563 unifyRecord context firstStructure secondStructure
565 _ ->
566 mismatch context Nothing
568 Error _ ->
569 return ()
573isIntFloat :: ModuleName.Canonical -> N.Name -> ModuleName.Canonical -> N.Name -> Bool
574isIntFloat home name otherHome otherName =
575 otherHome == ModuleName.basics
576 && home == ModuleName.basics
577 && (
578 (name == N.int && otherName == N.float)
579 ||
580 (name == N.float && otherName == N.int)
581 )
585-- UNIFY RECORDS
588unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
589unifyRecord context firstStructure secondStructure =
590 do let (RecordStructure expFields expVar expStruct) = firstStructure
591 let (RecordStructure actFields actVar actStruct) = secondStructure
593 let sharedFields = Map.intersectionWith (,) expFields actFields
595 -- call after unifying extension, make sure record shape matches before
596 -- looking into whether the particular field types match.
597 let unifySharedFields otherFields ext =
598 do unifySharedFieldsHelp context sharedFields
599 let allFields = Map.union (Map.map fst sharedFields) otherFields
600 merge context (Structure (Record1 allFields ext))
602 let uniqueExpFields = Map.difference expFields actFields
603 let uniqueActFields = Map.difference actFields expFields
605 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
606 (_, True, _, True) ->
607 do subUnify context expVar actVar
608 unifySharedFields Map.empty expVar
610 (Empty, _, _, False) ->
611 mismatch context $ Just $
612 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
614 (_, False, Empty, _) ->
615 mismatch context $ Just $
616 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
618 (_, False, _, True) ->
619 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
620 subUnify context subRecord actVar
621 unifySharedFields Map.empty subRecord
623 (_, True, _, False) ->
624 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
625 subUnify context expVar subRecord
626 unifySharedFields Map.empty subRecord
628 (Extension, False, Extension, False) ->
629 do let subFields = Map.union uniqueExpFields uniqueActFields
630 subExt <- fresh context Type.unnamedFlexVar
631 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
632 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
633 subUnify context expVar expRecord
634 subUnify context actRecord actVar
635 unifySharedFields subFields subExt
639unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()
640unifySharedFieldsHelp context sharedFields =
641 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
642 case Maybe.catMaybes maybeBadFields of
643 [] ->
644 return ()
646 badFields ->
647 mismatch context (Just (Error.BadFields (reverse badFields)))
650unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))
651unifyField context (field, (expected, actual)) =
652 do result <- lift $ runExceptT $ subUnify context expected actual
653 case result of
654 Right () ->
655 return $ Nothing
657 Left problem ->
658 return $ Just $ (,) field $
659 case problem of
660 Reason _ reason ->
661 reason
663 Infinite ->
664 Nothing
668-- GATHER RECORD STRUCTURE
671data RecordStructure =
672 RecordStructure
673 { _fields :: Map.Map Text Variable
674 , _extVar :: Variable
675 , _extStruct :: ExtensionStructure
676 }
679data ExtensionStructure
680 = Empty
681 | Extension
684gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure
685gatherFields context fields variable =
686 do (Descriptor content _ _ _) <- UF.descriptor variable
687 case content of
688 Structure (Record1 subFields subExt) ->
689 gatherFields context (Map.union fields subFields) subExt
691 Structure EmptyRecord1 ->
692 return (RecordStructure fields variable Empty)
694 Alias _ _ _ var ->
695 -- TODO may be dropping useful alias info here
696 gatherFields context fields var
698 _ ->
699 return (RecordStructure fields variable Extension)