git.iko.soy/elk
on fbff9ce help sign in
elk/src/Type/Unify.hs
683 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 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-- KICK OFF UNIFICATION
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 Typical ->
40 Error.Mismatch $
41 Error.MismatchInfo hint expectedSrcType actualSrcType Nothing
43 Special reason ->
44 Error.Mismatch $
45 Error.MismatchInfo hint expectedSrcType actualSrcType (Just reason)
47 Infinite ->
48 Error.InfiniteType (Left hint) expectedSrcType
52-- UNIFICATION HELPERS
55type Unify =
56 ExceptT Problem TS.Solver
59data Context =
60 Context
61 { _orientation :: Orientation
62 , _first :: Variable
63 , _firstDesc :: Descriptor
64 , _second :: Variable
65 , _secondDesc :: Descriptor
66 }
69data Orientation = ExpectedActual | ActualExpected
72reorient :: Context -> Context
73reorient (Context orientation var1 desc1 var2 desc2) =
74 let
75 otherOrientation =
76 case orientation of
77 ExpectedActual -> ActualExpected
78 ActualExpected -> ExpectedActual
79 in
80 Context otherOrientation var2 desc2 var1 desc1
84-- ERROR MESSAGES
87data Problem
88 = Typical
89 | Special Error.Reason
90 | Infinite
93mismatch :: Context -> Maybe Error.Reason -> Unify a
94mismatch context@(Context orientation var1 _ var2 _) maybeReason =
95 do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
96 when anyInfinite $ throwError Infinite
98 args1 <- liftIO $ collectArgs var1
99 args2 <- liftIO $ collectArgs var2
101 let numArgs1 = length args1
102 let numArgs2 = length args2
104 if numArgs1 == numArgs2
105 then
106 throwError $ reasonToProblem orientation maybeReason
107 else
108 do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2
109 throwError $ reasonToProblem orientation $ Just $
110 Error.MissingArgs $ abs (numArgs2 - numArgs1)
113reasonToProblem :: Orientation -> Maybe Error.Reason -> Problem
114reasonToProblem orientation maybeReason =
115 case maybeReason of
116 Nothing ->
117 Typical
119 Just reason ->
120 case orientation of
121 ExpectedActual ->
122 Special reason
124 ActualExpected ->
125 Special (Error.flipReason reason)
129-- MERGE
132merge :: Context -> Content -> Unify ()
133merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
134 liftIO $ mergeHelp var1 var2 content (min rank1 rank2)
137mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
138mergeHelp var1 var2 newContent newRank =
139 UF.union var1 var2 $
140 Descriptor newContent newRank noMark Nothing
143fresh :: Context -> Content -> Unify Variable
144fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
145 do freshVariable <-
146 liftIO $ UF.fresh $
147 Descriptor content (min rank1 rank2) noMark Nothing
149 lift $ TS.register freshVariable
151 return freshVariable
155-- ACTUALLY UNIFY THINGS
158guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
159guardedUnify orientation left right =
160 do equivalent <- liftIO $ UF.equivalent left right
161 if equivalent
162 then return ()
163 else
164 do leftDesc <- liftIO $ UF.descriptor left
165 rightDesc <- liftIO $ UF.descriptor right
166 actuallyUnify (Context orientation left leftDesc right rightDesc)
169subUnify :: Context -> Variable -> Variable -> Unify ()
170subUnify context var1 var2 =
171 guardedUnify (_orientation context) var1 var2
174actuallyUnify :: Context -> Unify ()
175actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
176 case firstContent of
177 FlexVar _ ->
178 unifyFlex context secondContent
180 FlexSuper super _ ->
181 unifyFlexSuper context super firstContent secondContent
183 RigidVar name ->
184 unifyRigid context Nothing name firstContent secondContent
186 RigidSuper super name ->
187 unifyRigid context (Just super) name firstContent secondContent
189 Alias name args realVar ->
190 unifyAlias context name args realVar secondContent
192 Structure flatType ->
193 unifyStructure context flatType firstContent secondContent
195 Error _ ->
196 -- If there was an error, just pretend it is okay. This lets us avoid
197 -- "cascading" errors where one problem manifests as multiple message.
198 return ()
202-- UNIFY FLEXIBLE VARIABLES
205unifyFlex :: Context -> Content -> Unify ()
206unifyFlex context otherContent =
207 case otherContent of
208 Error _ ->
209 return ()
211 -- TODO see if wildcarding makes a noticable perf difference
213 FlexVar _ ->
214 merge context otherContent
216 FlexSuper _ _ ->
217 merge context otherContent
219 RigidVar _ ->
220 merge context otherContent
222 RigidSuper _ _ ->
223 merge context otherContent
225 Alias _ _ _ ->
226 merge context otherContent
228 Structure _ ->
229 merge context otherContent
233-- UNIFY RIGID VARIABLES
236unifyRigid :: Context -> Maybe Super -> Text -> Content -> Content -> Unify ()
237unifyRigid context maybeSuper name content otherContent =
238 case otherContent of
239 FlexVar _ ->
240 merge context content
242 FlexSuper otherSuper _ ->
243 case maybeSuper of
244 Just super ->
245 if combineRigidSupers super otherSuper then
246 merge context content
247 else
248 mismatch context $ Just $
249 Error.RigidSuperTooGeneric super name $ Error.SpecificSuper otherSuper
251 Nothing ->
252 mismatch context $ Just $
253 Error.RigidVarTooGeneric name $ Error.SpecificSuper otherSuper
255 RigidVar otherName ->
256 mismatch context $ Just $
257 Error.RigidClash name otherName
259 RigidSuper _ otherName ->
260 mismatch context $ Just $
261 Error.RigidClash name otherName
263 Alias otherName _ _ ->
264 mismatch context $ Just $
265 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
266 Error.SpecificType otherName
268 Structure flatType ->
269 mismatch context $ Just $
270 maybe Error.RigidVarTooGeneric Error.RigidSuperTooGeneric maybeSuper name $
271 flatTypeToSpecificThing flatType
273 Error _ ->
274 return ()
277flatTypeToSpecificThing :: FlatType -> Error.SpecificThing
278flatTypeToSpecificThing flatType =
279 case flatType of
280 App1 name _ ->
281 Error.SpecificType name
283 Fun1 _ _ ->
284 Error.SpecificFunction
286 EmptyRecord1 ->
287 Error.SpecificRecord
289 Record1 _ _ ->
290 Error.SpecificRecord
294-- UNIFY SUPER VARIABLES
297unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
298unifyFlexSuper context super content otherContent =
299 case otherContent of
300 Structure flatType ->
301 unifyFlexSuperStructure context super flatType
303 RigidVar name ->
304 mismatch context $ Just $
305 Error.RigidVarTooGeneric name (Error.SpecificSuper super)
307 RigidSuper otherSuper name ->
308 if combineRigidSupers otherSuper super then
309 merge context otherContent
310 else
311 mismatch context $ Just $
312 Error.RigidSuperTooGeneric otherSuper name (Error.SpecificSuper super)
314 FlexVar _ ->
315 merge context content
317 FlexSuper otherSuper _ ->
318 case super of
319 Number ->
320 case otherSuper of
321 Number -> merge context content
322 Comparable -> merge context content
323 _ -> mismatch context Nothing -- Error.NumberAppendableClash
325 Comparable ->
326 case otherSuper of
327 Comparable -> merge context otherContent
328 Number -> merge context otherContent
329 Appendable -> merge context (Type.unnamedFlexSuper CompAppend)
330 CompAppend -> merge context otherContent
332 Appendable ->
333 case otherSuper of
334 Appendable -> merge context otherContent
335 Comparable -> merge context (Type.unnamedFlexSuper CompAppend)
336 CompAppend -> merge context otherContent
337 Number -> mismatch context Nothing -- Error.NumberAppendableClash
339 CompAppend ->
340 case otherSuper of
341 Comparable -> merge context content
342 Appendable -> merge context content
343 CompAppend -> merge context content
344 Number -> mismatch context Nothing -- Error.NumberAppendableClash
346 Alias _ _ realVar ->
347 subUnify context (_first context) realVar
349 Error _ ->
350 return ()
353combineRigidSupers :: Super -> Super -> Bool
354combineRigidSupers rigid flex =
355 rigid == flex
356 || (rigid == Number && flex == Comparable)
357 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
360atomMatchesSuper :: Super -> Var.Canonical -> Bool
361atomMatchesSuper super name =
362 case super of
363 Number ->
364 elem name [ Var.int, Var.float ]
366 Comparable ->
367 elem name [ Var.string, Var.int, Var.float, Var.char]
369 Appendable ->
370 name == Var.string
372 CompAppend ->
373 name == Var.string
376unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
377unifyFlexSuperStructure context super flatType =
378 case flatType of
379 App1 name [] ->
380 if atomMatchesSuper super name then
381 merge context (Structure flatType)
382 else
383 mismatch context $ Just $ Error.NotPartOfSuper super
385 App1 name [variable] | name == Var.list ->
386 case super of
387 Number ->
388 mismatch context $ Just $ Error.NotPartOfSuper super
390 Appendable ->
391 merge context (Structure flatType)
393 Comparable ->
394 do comparableOccursCheck context
395 merge context (Structure flatType)
396 unifyComparableRecursive (_orientation context) variable
398 CompAppend ->
399 do comparableOccursCheck context
400 merge context (Structure flatType)
401 unifyComparableRecursive (_orientation context) variable
403 App1 name args | Var.isTuple name ->
404 case super of
405 Number ->
406 mismatch context $ Just $ Error.NotPartOfSuper super
408 Appendable ->
409 mismatch context $ Just $ Error.NotPartOfSuper super
411 Comparable ->
412 if length args > 6 then
413 mismatch context (Just (Error.TooLongComparableTuple (length args)))
415 else
416 do comparableOccursCheck context
417 merge context (Structure flatType)
418 mapM_ (unifyComparableRecursive (_orientation context)) args
420 CompAppend ->
421 mismatch context $ Just $ Error.NotPartOfSuper super
423 _ ->
424 mismatch context $ Just $ Error.NotPartOfSuper super
427-- TODO: is there some way to avoid doing this?
428-- Do type classes require occurs checks?
429comparableOccursCheck :: Context -> Unify ()
430comparableOccursCheck (Context _ _ _ var _) =
431 do hasOccurred <- liftIO $ Occurs.occurs var
432 if hasOccurred
433 then throwError Infinite
434 else return ()
437unifyComparableRecursive :: Orientation -> Variable -> Unify ()
438unifyComparableRecursive orientation var =
439 do compVar <- liftIO $
440 do (Descriptor _ rank _ _) <- UF.descriptor var
441 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
443 lift $ TS.register compVar
445 guardedUnify orientation compVar var
448collectArgs :: Variable -> IO [Variable]
449collectArgs variable =
450 collectArgsHelp [] variable
453collectArgsHelp :: [Variable] -> Variable -> IO [Variable]
454collectArgsHelp revArgs variable =
455 do (Descriptor content _ _ _) <- UF.descriptor variable
456 case content of
457 Structure (Fun1 arg returnType) ->
458 collectArgsHelp (arg : revArgs) returnType
460 _ ->
461 return $ variable : revArgs
465-- UNIFY ALIASES
468unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()
469unifyAlias context name args realVar otherContent =
470 case otherContent of
471 FlexVar _ ->
472 merge context (Alias name args realVar)
474 FlexSuper _ _ ->
475 subUnify context realVar (_second context)
477 RigidVar _ ->
478 subUnify context realVar (_second context)
480 RigidSuper _ _ ->
481 subUnify context realVar (_second context)
483 Alias otherName otherArgs otherRealVar ->
484 if name == otherName then
485 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
486 merge context otherContent
488 else
489 subUnify context realVar otherRealVar
491 Structure _ ->
492 subUnify context realVar (_second context)
494 Error _ ->
495 return ()
499-- UNIFY STRUCTURES
502unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
503unifyStructure context flatType content otherContent =
504 case otherContent of
505 FlexVar _ ->
506 merge context content
508 FlexSuper super _ ->
509 unifyFlexSuperStructure (reorient context) super flatType
511 RigidVar name ->
512 mismatch context $ Just $ Error.RigidVarTooGeneric name (flatTypeToSpecificThing flatType)
514 RigidSuper super name ->
515 mismatch context $ Just $ Error.RigidSuperTooGeneric super name (flatTypeToSpecificThing flatType)
517 Alias _ _ realVar ->
518 subUnify context (_first context) realVar
520 Structure otherTerm ->
521 case (flatType, otherTerm) of
522 (App1 name args, App1 otherName otherArgs) ->
523 if name == otherName then
524 do zipWithM_ (subUnify context) args otherArgs
525 merge context otherContent
527 else if isIntFloat name otherName || isIntFloat otherName name then
528 mismatch context (Just Error.IntFloat)
530 else
531 mismatch context Nothing
533 (Fun1 arg result, Fun1 otherArg otherResult) ->
534 do subUnify context arg otherArg
535 subUnify context result otherResult
536 merge context otherContent
538 (EmptyRecord1, EmptyRecord1) ->
539 merge context otherContent
541 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
542 subUnify context ext (_second context)
544 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
545 subUnify context (_first context) ext
547 (Record1 fields extension, Record1 otherFields otherExtension) ->
548 do firstStructure <- liftIO $ gatherFields context fields extension
549 secondStructure <- liftIO $ gatherFields context otherFields otherExtension
550 unifyRecord context firstStructure secondStructure
552 _ ->
553 mismatch context Nothing
555 Error _ ->
556 return ()
560isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
561isIntFloat name otherName =
562 Var.isPrim "Int" name && Var.isPrim "Float" otherName
566-- UNIFY RECORDS
569unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
570unifyRecord context firstStructure secondStructure =
571 do let (RecordStructure expFields expVar expStruct) = firstStructure
572 let (RecordStructure actFields actVar actStruct) = secondStructure
574 let sharedFields = Map.intersectionWith (,) expFields actFields
576 -- call after unifying extension, make sure record shape matches before
577 -- looking into whether the particular field types match.
578 let unifySharedFields otherFields ext =
579 do unifySharedFieldsHelp context sharedFields
580 let allFields = Map.union (Map.map fst sharedFields) otherFields
581 merge context (Structure (Record1 allFields ext))
583 let uniqueExpFields = Map.difference expFields actFields
584 let uniqueActFields = Map.difference actFields expFields
586 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
587 (_, True, _, True) ->
588 do subUnify context expVar actVar
589 unifySharedFields Map.empty expVar
591 (Empty, _, _, False) ->
592 mismatch context $ Just $
593 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
595 (_, False, Empty, _) ->
596 mismatch context $ Just $
597 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
599 (_, False, _, True) ->
600 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
601 subUnify context subRecord actVar
602 unifySharedFields Map.empty subRecord
604 (_, True, _, False) ->
605 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
606 subUnify context expVar subRecord
607 unifySharedFields Map.empty subRecord
609 (Extension, False, Extension, False) ->
610 do let subFields = Map.union uniqueExpFields uniqueActFields
611 subExt <- fresh context Type.unnamedFlexVar
612 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
613 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
614 subUnify context expVar expRecord
615 subUnify context actRecord actVar
616 unifySharedFields subFields subExt
620unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()
621unifySharedFieldsHelp context sharedFields =
622 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
623 case Maybe.catMaybes maybeBadFields of
624 [] ->
625 return ()
627 badFields ->
628 mismatch context (Just (Error.BadFields (reverse badFields)))
631unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))
632unifyField context (field, (expected, actual)) =
633 do result <- lift $ runExceptT $ subUnify context expected actual
634 case result of
635 Right () ->
636 return $ Nothing
638 Left problem ->
639 return $ Just $ (,) field $
640 case problem of
641 Typical ->
642 Nothing
644 Special reason ->
645 Just reason
647 Infinite ->
648 Nothing
652-- GATHER RECORD STRUCTURE
655data RecordStructure = RecordStructure
656 { _fields :: Map.Map Text Variable
657 , _extVar :: Variable
658 , _extStruct :: ExtensionStructure
659 }
662data ExtensionStructure
663 = Empty
664 | Extension
667gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure
668gatherFields context fields variable =
669 do (Descriptor content _ _ _) <- UF.descriptor variable
670 case content of
671 Structure (Record1 subFields subExt) ->
672 gatherFields context (Map.union fields subFields) subExt
674 Structure EmptyRecord1 ->
675 return (RecordStructure fields variable Empty)
677 Alias _ _ var ->
678 -- TODO may be dropping useful alias info here
679 gatherFields context fields var
681 _ ->
682 return (RecordStructure fields variable Extension)