git.iko.soy/elk
on c19392f help sign in
elk/src/Type/Unify.hs
677 lines 20 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 AST.Type (Super(..))
12import qualified AST.Variable as Var
13import qualified Reporting.Region as R
14import qualified Reporting.Error.Type as Error
15import qualified Type.Occurs as Occurs
16import qualified Type.State as TS
17import Type.Type as Type
18import qualified Type.UnionFind as UF
22-- UNIFY
25unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
26unify hint region expected actual =
27 {-# SCC elm_compiler_type_unify #-}
28 do result <- runExceptT (guardedUnify ExpectedActual expected actual)
29 case result of
30 Right () ->
31 return ()
33 Left problem ->
34 do expectedSrcType <- liftIO $ Type.toSrcType expected
35 actualSrcType <- liftIO $ Type.toSrcType actual
36 liftIO $ mergeHelp expected actual (Error "?") noRank
37 TS.addError region $
38 case problem of
39 Reason hasDecoder maybeReason ->
40 Error.Mismatch $
41 Error.MismatchInfo hint expectedSrcType actualSrcType hasDecoder maybeReason
43 Infinite ->
44 Error.InfiniteType (Left hint) expectedSrcType
48-- UNIFICATION HELPERS
51type Unify =
52 ExceptT Problem TS.Solver
55data Context =
56 Context
57 { _orientation :: Orientation
58 , _first :: Variable
59 , _firstDesc :: Descriptor
60 , _second :: Variable
61 , _secondDesc :: Descriptor
62 }
65data Orientation
66 = ExpectedActual
67 | ActualExpected
70reorient :: Context -> Context
71reorient (Context orientation var1 desc1 var2 desc2) =
72 let
73 otherOrientation =
74 case orientation of
75 ExpectedActual -> ActualExpected
76 ActualExpected -> ExpectedActual
77 in
78 Context otherOrientation var2 desc2 var1 desc1
82-- ERROR MESSAGES
85data Problem
86 = Reason Bool (Maybe Error.Reason)
87 | Infinite
90mismatch :: Context -> Maybe Error.Reason -> Unify a
91mismatch context@(Context orientation var1 _ var2 _) maybeReason =
92 do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
93 when anyInfinite $ throwError Infinite
95 args1 <- liftIO $ collectArgs [] var1
96 args2 <- liftIO $ collectArgs [] var2
98 hasDecoder <- liftIO $ or <$> traverse detectDecoder (args1 ++ args2)
100 if length args1 /= length args2
101 then
102 do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2
103 throwError $ Reason hasDecoder $ Just $
104 Error.MissingArgs (abs (length args2 - length args1))
105 else
106 throwError $ Reason hasDecoder $
107 case orientation of
108 ExpectedActual ->
109 maybeReason
111 ActualExpected ->
112 fmap Error.flipReason maybeReason
118collectArgs :: [Variable] -> Variable -> IO [Variable]
119collectArgs revArgs variable =
120 do (Descriptor content _ _ _) <- UF.descriptor variable
121 case content of
122 Structure (Fun1 arg returnType) ->
123 collectArgs (arg : revArgs) returnType
125 _ ->
126 return $ variable : revArgs
129detectDecoder :: Variable -> IO Bool
130detectDecoder variable =
131 do (Descriptor content _ _ _) <- UF.descriptor variable
132 case content of
133 Structure (App1 name [_]) | Var.decoder == name ->
134 return True
136 _ ->
137 return False
141-- MERGE
144merge :: Context -> Content -> Unify ()
145merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
146 liftIO $ mergeHelp var1 var2 content (min rank1 rank2)
149mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
150mergeHelp var1 var2 newContent newRank =
151 UF.union var1 var2 $
152 Descriptor newContent newRank noMark Nothing
155fresh :: Context -> Content -> Unify Variable
156fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
157 do freshVariable <-
158 liftIO $ UF.fresh $
159 Descriptor content (min rank1 rank2) noMark Nothing
161 lift $ TS.register freshVariable
163 return freshVariable
167-- ACTUALLY UNIFY THINGS
170guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
171guardedUnify orientation left right =
172 do equivalent <- liftIO $ UF.equivalent left right
173 if equivalent
174 then return ()
175 else
176 do leftDesc <- liftIO $ UF.descriptor left
177 rightDesc <- liftIO $ UF.descriptor right
178 actuallyUnify (Context orientation left leftDesc right rightDesc)
181subUnify :: Context -> Variable -> Variable -> Unify ()
182subUnify context var1 var2 =
183 guardedUnify (_orientation context) var1 var2
186actuallyUnify :: Context -> Unify ()
187actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
188 case firstContent of
189 FlexVar _ ->
190 unifyFlex context secondContent
192 FlexSuper super _ ->
193 unifyFlexSuper context super firstContent secondContent
195 RigidVar name ->
196 unifyRigid context Nothing name firstContent secondContent
198 RigidSuper super name ->
199 unifyRigid context (Just super) name firstContent secondContent
201 Alias name args realVar ->
202 unifyAlias context 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 return ()
214-- UNIFY FLEXIBLE VARIABLES
217unifyFlex :: Context -> Content -> Unify ()
218unifyFlex context otherContent =
219 case otherContent of
220 Error _ ->
221 return ()
223 -- TODO see if wildcarding makes a noticable perf difference
225 FlexVar _ ->
226 merge context otherContent
228 FlexSuper _ _ ->
229 merge context otherContent
231 RigidVar _ ->
232 merge context otherContent
234 RigidSuper _ _ ->
235 merge context otherContent
237 Alias _ _ _ ->
238 merge context otherContent
240 Structure _ ->
241 merge context otherContent
245-- UNIFY RIGID VARIABLES
248unifyRigid :: Context -> Maybe Super -> Text -> Content -> Content -> Unify ()
249unifyRigid context maybeSuper name content otherContent =
250 case otherContent of
251 FlexVar _ ->
252 merge context content
254 FlexSuper otherSuper _ ->
255 case maybeSuper of
256 Just super ->
257 if combineRigidSupers super otherSuper then
258 merge context content
259 else
260 mismatch context $ Just $
261 Error.RigidSuperTooGeneric super name $ Error.SpecificSuper otherSuper
263 Nothing ->
264 mismatch context $ Just $
265 Error.RigidVarTooGeneric name $ Error.SpecificSuper otherSuper
267 RigidVar otherName ->
268 mismatch context $ Just $
269 Error.RigidClash name otherName
271 RigidSuper _ otherName ->
272 mismatch context $ Just $
273 Error.RigidClash name otherName
275 Alias otherName _ _ ->
276 mismatch context $ Just $
277 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
278 Error.SpecificType otherName
280 Structure flatType ->
281 mismatch context $ Just $
282 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
283 flatTypeToSpecificThing flatType
285 Error _ ->
286 return ()
289flatTypeToSpecificThing :: FlatType -> Error.SpecificThing
290flatTypeToSpecificThing flatType =
291 case flatType of
292 App1 name _ ->
293 Error.SpecificType name
295 Fun1 _ _ ->
296 Error.SpecificFunction
298 EmptyRecord1 ->
299 Error.SpecificRecord
301 Record1 _ _ ->
302 Error.SpecificRecord
306-- UNIFY SUPER VARIABLES
309unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
310unifyFlexSuper context super content otherContent =
311 case otherContent of
312 Structure flatType ->
313 unifyFlexSuperStructure context super flatType
315 RigidVar name ->
316 mismatch context $ Just $
317 Error.RigidVarTooGeneric name (Error.SpecificSuper super)
319 RigidSuper otherSuper name ->
320 if combineRigidSupers otherSuper super then
321 merge context otherContent
322 else
323 mismatch context $ Just $
324 Error.RigidSuperTooGeneric otherSuper name (Error.SpecificSuper super)
326 FlexVar _ ->
327 merge context content
329 FlexSuper otherSuper _ ->
330 case super of
331 Number ->
332 case otherSuper of
333 Number -> merge context content
334 Comparable -> merge context content
335 _ -> mismatch context Nothing -- Error.NumberAppendableClash
337 Comparable ->
338 case otherSuper of
339 Comparable -> merge context otherContent
340 Number -> merge context otherContent
341 Appendable -> merge context (Type.unnamedFlexSuper CompAppend)
342 CompAppend -> merge context otherContent
344 Appendable ->
345 case otherSuper of
346 Appendable -> merge context otherContent
347 Comparable -> merge context (Type.unnamedFlexSuper CompAppend)
348 CompAppend -> merge context otherContent
349 Number -> mismatch context Nothing -- Error.NumberAppendableClash
351 CompAppend ->
352 case otherSuper of
353 Comparable -> merge context content
354 Appendable -> merge context content
355 CompAppend -> merge context content
356 Number -> mismatch context Nothing -- Error.NumberAppendableClash
358 Alias _ _ realVar ->
359 subUnify context (_first context) realVar
361 Error _ ->
362 return ()
365combineRigidSupers :: Super -> Super -> Bool
366combineRigidSupers rigid flex =
367 rigid == flex
368 || (rigid == Number && flex == Comparable)
369 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
372atomMatchesSuper :: Super -> Var.Canonical -> Bool
373atomMatchesSuper super name =
374 case super of
375 Number ->
376 elem name [ Var.int, Var.float ]
378 Comparable ->
379 elem name [ Var.string, Var.int, Var.float, Var.char]
381 Appendable ->
382 name == Var.string
384 CompAppend ->
385 name == Var.string
388unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
389unifyFlexSuperStructure context super flatType =
390 case flatType of
391 App1 name [] ->
392 if atomMatchesSuper super name then
393 merge context (Structure flatType)
394 else
395 mismatch context $ Just $ Error.NotPartOfSuper super
397 App1 name [variable] | name == Var.list ->
398 case super of
399 Number ->
400 mismatch context $ Just $ Error.NotPartOfSuper super
402 Appendable ->
403 merge context (Structure flatType)
405 Comparable ->
406 do comparableOccursCheck context
407 merge context (Structure flatType)
408 unifyComparableRecursive (_orientation context) variable
410 CompAppend ->
411 do comparableOccursCheck context
412 merge context (Structure flatType)
413 unifyComparableRecursive (_orientation context) variable
415 App1 name args | Var.isTuple name ->
416 case super of
417 Number ->
418 mismatch context $ Just $ Error.NotPartOfSuper super
420 Appendable ->
421 mismatch context $ Just $ Error.NotPartOfSuper super
423 Comparable ->
424 if length args > 6 then
425 mismatch context (Just (Error.TooLongComparableTuple (length args)))
427 else
428 do comparableOccursCheck context
429 merge context (Structure flatType)
430 mapM_ (unifyComparableRecursive (_orientation context)) args
432 CompAppend ->
433 mismatch context $ Just $ Error.NotPartOfSuper super
435 _ ->
436 mismatch context $ Just $ Error.NotPartOfSuper super
439-- TODO: is there some way to avoid doing this?
440-- Do type classes require occurs checks?
441comparableOccursCheck :: Context -> Unify ()
442comparableOccursCheck (Context _ _ _ var _) =
443 do hasOccurred <- liftIO $ Occurs.occurs var
444 if hasOccurred
445 then throwError Infinite
446 else return ()
449unifyComparableRecursive :: Orientation -> Variable -> Unify ()
450unifyComparableRecursive orientation var =
451 do compVar <- liftIO $
452 do (Descriptor _ rank _ _) <- UF.descriptor var
453 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
455 lift $ TS.register compVar
457 guardedUnify orientation compVar var
461-- UNIFY ALIASES
464unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()
465unifyAlias context name args realVar otherContent =
466 case otherContent of
467 FlexVar _ ->
468 merge context (Alias name args realVar)
470 FlexSuper _ _ ->
471 subUnify context realVar (_second context)
473 RigidVar _ ->
474 subUnify context realVar (_second context)
476 RigidSuper _ _ ->
477 subUnify context realVar (_second context)
479 Alias otherName otherArgs otherRealVar ->
480 if name == otherName then
481 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
482 merge context otherContent
484 else
485 subUnify context realVar otherRealVar
487 Structure _ ->
488 subUnify context realVar (_second context)
490 Error _ ->
491 return ()
495-- UNIFY STRUCTURES
498unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
499unifyStructure context flatType content otherContent =
500 case otherContent of
501 FlexVar _ ->
502 merge context content
504 FlexSuper super _ ->
505 unifyFlexSuperStructure (reorient context) super flatType
507 RigidVar name ->
508 mismatch context $ Just $ Error.RigidVarTooGeneric name (flatTypeToSpecificThing flatType)
510 RigidSuper super name ->
511 mismatch context $ Just $ Error.RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
513 Alias _ _ realVar ->
514 subUnify context (_first context) realVar
516 Structure otherTerm ->
517 case (flatType, otherTerm) of
518 (App1 name args, App1 otherName otherArgs) ->
519 if name == otherName then
520 do zipWithM_ (subUnify context) args otherArgs
521 merge context otherContent
523 else if isIntFloat name otherName || isIntFloat otherName name then
524 mismatch context (Just Error.IntFloat)
526 else
527 mismatch context Nothing
529 (Fun1 arg result, Fun1 otherArg otherResult) ->
530 do subUnify context arg otherArg
531 subUnify context result otherResult
532 merge context otherContent
534 (EmptyRecord1, EmptyRecord1) ->
535 merge context otherContent
537 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
538 subUnify context ext (_second context)
540 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
541 subUnify context (_first context) ext
543 (Record1 fields extension, Record1 otherFields otherExtension) ->
544 do firstStructure <- liftIO $ gatherFields context fields extension
545 secondStructure <- liftIO $ gatherFields context otherFields otherExtension
546 unifyRecord context firstStructure secondStructure
548 _ ->
549 mismatch context Nothing
551 Error _ ->
552 return ()
556isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
557isIntFloat name otherName =
558 Var.isPrim "Int" name && Var.isPrim "Float" otherName
562-- UNIFY RECORDS
565unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
566unifyRecord context firstStructure secondStructure =
567 do let (RecordStructure expFields expVar expStruct) = firstStructure
568 let (RecordStructure actFields actVar actStruct) = secondStructure
570 let sharedFields = Map.intersectionWith (,) expFields actFields
572 -- call after unifying extension, make sure record shape matches before
573 -- looking into whether the particular field types match.
574 let unifySharedFields otherFields ext =
575 do unifySharedFieldsHelp context sharedFields
576 let allFields = Map.union (Map.map fst sharedFields) otherFields
577 merge context (Structure (Record1 allFields ext))
579 let uniqueExpFields = Map.difference expFields actFields
580 let uniqueActFields = Map.difference actFields expFields
582 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
583 (_, True, _, True) ->
584 do subUnify context expVar actVar
585 unifySharedFields Map.empty expVar
587 (Empty, _, _, False) ->
588 mismatch context $ Just $
589 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
591 (_, False, Empty, _) ->
592 mismatch context $ Just $
593 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
595 (_, False, _, True) ->
596 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
597 subUnify context subRecord actVar
598 unifySharedFields Map.empty subRecord
600 (_, True, _, False) ->
601 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
602 subUnify context expVar subRecord
603 unifySharedFields Map.empty subRecord
605 (Extension, False, Extension, False) ->
606 do let subFields = Map.union uniqueExpFields uniqueActFields
607 subExt <- fresh context Type.unnamedFlexVar
608 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
609 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
610 subUnify context expVar expRecord
611 subUnify context actRecord actVar
612 unifySharedFields subFields subExt
616unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()
617unifySharedFieldsHelp context sharedFields =
618 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
619 case Maybe.catMaybes maybeBadFields of
620 [] ->
621 return ()
623 badFields ->
624 mismatch context (Just (Error.BadFields (reverse badFields)))
627unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))
628unifyField context (field, (expected, actual)) =
629 do result <- lift $ runExceptT $ subUnify context expected actual
630 case result of
631 Right () ->
632 return $ Nothing
634 Left problem ->
635 return $ Just $ (,) field $
636 case problem of
637 Reason _ reason ->
638 reason
640 Infinite ->
641 Nothing
645-- GATHER RECORD STRUCTURE
648data RecordStructure =
649 RecordStructure
650 { _fields :: Map.Map Text Variable
651 , _extVar :: Variable
652 , _extStruct :: ExtensionStructure
653 }
656data ExtensionStructure
657 = Empty
658 | Extension
661gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure
662gatherFields context fields variable =
663 do (Descriptor content _ _ _) <- UF.descriptor variable
664 case content of
665 Structure (Record1 subFields subExt) ->
666 gatherFields context (Map.union fields subFields) subExt
668 Structure EmptyRecord1 ->
669 return (RecordStructure fields variable Empty)
671 Alias _ _ var ->
672 -- TODO may be dropping useful alias info here
673 gatherFields context fields var
675 _ ->
676 return (RecordStructure fields variable Extension)