git.iko.soy/elk
on 445ea07 help sign in
elk/src/Type/Unify.hs
690 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 qualified AST.Variable as Var
12import qualified Reporting.Region as R
13import qualified Reporting.Error.Type as Error
14import qualified Type.Occurs as Occurs
15import qualified Type.State as TS
16import Type.Type as Type
17import qualified Type.UnionFind as UF
21-- KICK OFF UNIFICATION
24unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
25unify hint region expected actual =
26 {-# SCC elm_compiler_type_unify #-}
27 do result <- runExceptT (guardedUnify ExpectedActual expected actual)
28 case result of
29 Right () ->
30 return ()
32 Left problem ->
33 do expectedSrcType <- liftIO $ Type.toSrcType expected
34 actualSrcType <- liftIO $ Type.toSrcType actual
35 liftIO $ mergeHelp expected actual (Error "?") noRank
36 TS.addError region $
37 case problem of
38 Typical ->
39 Error.Mismatch $
40 Error.MismatchInfo hint expectedSrcType actualSrcType Nothing
42 Special reason ->
43 Error.Mismatch $
44 Error.MismatchInfo hint expectedSrcType actualSrcType (Just reason)
46 Infinite ->
47 Error.InfiniteType (Left hint) expectedSrcType
51-- UNIFICATION HELPERS
54type Unify =
55 ExceptT Problem TS.Solver
58data Context =
59 Context
60 { _orientation :: Orientation
61 , _first :: Variable
62 , _firstDesc :: Descriptor
63 , _second :: Variable
64 , _secondDesc :: Descriptor
65 }
68data Orientation = ExpectedActual | 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 = Typical
88 | Special Error.Reason
89 | Infinite
92mismatch :: Context -> Maybe Error.Reason -> Unify a
93mismatch context@(Context orientation var1 _ var2 _) maybeReason =
94 do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
95 when anyInfinite $ throwError Infinite
97 args1 <- liftIO $ collectArgs var1
98 args2 <- liftIO $ collectArgs var2
100 let numArgs1 = length args1
101 let numArgs2 = length args2
103 if numArgs1 == numArgs2
104 then
105 throwError $ reasonToProblem orientation maybeReason
106 else
107 do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2
108 throwError $ reasonToProblem orientation $ Just $
109 Error.MissingArgs $ abs (numArgs2 - numArgs1)
112reasonToProblem :: Orientation -> Maybe Error.Reason -> Problem
113reasonToProblem orientation maybeReason =
114 case maybeReason of
115 Nothing ->
116 Typical
118 Just reason ->
119 case orientation of
120 ExpectedActual ->
121 Special reason
123 ActualExpected ->
124 Special (Error.flipReason reason)
127badRigid :: Maybe Text -> Error.Reason
128badRigid maybeName =
129 Error.BadVar (Just (Error.Rigid maybeName)) Nothing
132badSuper :: Super -> Error.Reason
133badSuper super =
134 Error.BadVar (Just (errorSuper super)) Nothing
137badSupers :: Super -> Super -> Error.Reason
138badSupers super1 super2 =
139 Error.BadVar (Just (errorSuper super1)) (Just (errorSuper super2))
142doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
143doubleBad vt1 vt2 =
144 Error.BadVar (Just vt1) (Just vt2)
147errorSuper :: Super -> Error.VarType
148errorSuper super =
149 case super of
150 Number ->
151 Error.Number
153 Comparable ->
154 Error.Comparable
156 Appendable ->
157 Error.Appendable
159 CompAppend ->
160 Error.CompAppend
164-- MERGE
167merge :: Context -> Content -> Unify ()
168merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
169 liftIO $ mergeHelp var1 var2 content (min rank1 rank2)
172mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
173mergeHelp var1 var2 newContent newRank =
174 UF.union var1 var2 $
175 Descriptor
176 { _content = newContent
177 , _rank = newRank
178 , _mark = noMark
179 , _copy = Nothing
180 }
183fresh :: Context -> Content -> Unify Variable
184fresh (Context _ _ desc1 _ desc2) content =
185 do freshVariable <-
186 liftIO $ UF.fresh $
187 Descriptor
188 { _content = content
189 , _rank = min (_rank desc1) (_rank desc2)
190 , _mark = noMark
191 , _copy = Nothing
192 }
193 lift (TS.register freshVariable)
197-- ACTUALLY UNIFY THINGS
200guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
201guardedUnify orientation left right =
202 do equivalent <- liftIO $ UF.equivalent left right
203 if equivalent
204 then return ()
205 else
206 do leftDesc <- liftIO $ UF.descriptor left
207 rightDesc <- liftIO $ UF.descriptor right
208 actuallyUnify (Context orientation left leftDesc right rightDesc)
211subUnify :: Context -> Variable -> Variable -> Unify ()
212subUnify context var1 var2 =
213 guardedUnify (_orientation context) var1 var2
216actuallyUnify :: Context -> Unify ()
217actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
218 let
219 firstContent = _content firstDesc
220 secondContent = _content secondDesc
221 in
222 case firstContent of
223 Error _ ->
224 -- If there was an error, just pretend it is okay. This lets us avoid
225 -- "cascading" errors where one problem manifests as multiple message.
226 return ()
228 Var Flex Nothing _ ->
229 unifyFlex context secondContent
231 Var Flex (Just super) _ ->
232 unifyFlexSuper context super firstContent secondContent
234 Var Rigid maybeSuper maybeName ->
235 unifyRigid context maybeSuper maybeName firstContent secondContent
237 Alias name args realVar ->
238 unifyAlias context name args realVar secondContent
240 Structure term ->
241 unifyStructure context term firstContent secondContent
245-- UNIFY FLEXIBLE VARIABLES
248unifyFlex :: Context -> Content -> Unify ()
249unifyFlex context otherContent =
250 case otherContent of
251 Error _ ->
252 return ()
254 Var Flex _ _ ->
255 merge context otherContent
257 Var Rigid _ _ ->
258 merge context otherContent
260 Alias _ _ _ ->
261 merge context otherContent
263 Structure _ ->
264 merge context otherContent
268-- UNIFY RIGID VARIABLES
271unifyRigid :: Context -> Maybe Super -> Maybe Text -> Content -> Content -> Unify ()
272unifyRigid context maybeSuper maybeName content otherContent =
273 case otherContent of
274 Error _ ->
275 return ()
277 Var Flex otherMaybeSuper _ ->
278 case (maybeSuper, otherMaybeSuper) of
279 (_, Nothing) ->
280 merge context content
282 (Nothing, Just _) ->
283 mismatch context (Just (badRigid maybeName))
285 (Just super, Just otherSuper) ->
286 if combineRigidSupers super otherSuper then
287 merge context content
288 else
289 mismatch context (Just (badRigid maybeName))
291 Var Rigid _ otherMaybeName ->
292 mismatch context $ Just $
293 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
295 Alias _ _ _ ->
296 mismatch context (Just (badRigid maybeName))
298 Structure _ ->
299 mismatch context (Just (badRigid maybeName))
303-- UNIFY SUPER VARIABLES
306unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
307unifyFlexSuper context super content otherContent =
308 case otherContent of
309 Structure term ->
310 unifyFlexSuperStructure context super term
312 Var Rigid Nothing maybeName ->
313 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
315 Var Rigid (Just otherSuper) maybeName ->
316 if combineRigidSupers otherSuper super then
317 merge context otherContent
318 else
319 mismatch context $ Just $ badRigid maybeName
321 Var Flex Nothing _ ->
322 merge context content
324 Var Flex (Just otherSuper) _ ->
325 case super of
326 Number ->
327 case otherSuper of
328 Number -> merge context content
329 Comparable -> merge context content
330 _ -> mismatch context $ Just $ badSupers super otherSuper
332 Comparable ->
333 case otherSuper of
334 Comparable -> merge context otherContent
335 Number -> merge context otherContent
336 Appendable -> merge context (Var Flex (Just CompAppend) Nothing)
337 CompAppend -> merge context otherContent
339 Appendable ->
340 case otherSuper of
341 Appendable -> merge context otherContent
342 Comparable -> merge context (Var Flex (Just CompAppend) Nothing)
343 CompAppend -> merge context otherContent
344 Number -> mismatch context $ Just $ badSupers super otherSuper
346 CompAppend ->
347 case otherSuper of
348 Comparable -> merge context content
349 Appendable -> merge context content
350 CompAppend -> merge context content
351 Number -> mismatch context $ Just $ badSupers super otherSuper
353 Alias _ _ realVar ->
354 subUnify context (_first context) realVar
356 Error _ ->
357 return ()
360combineRigidSupers :: Super -> Super -> Bool
361combineRigidSupers rigid flex =
362 rigid == flex
363 || (rigid == Number && flex == Comparable)
364 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
367atomMatchesSuper :: Super -> Var.Canonical -> Bool
368atomMatchesSuper super name =
369 case super of
370 Number ->
371 elem name [ Var.int, Var.float ]
373 Comparable ->
374 elem name [ Var.string, Var.int, Var.float, Var.char]
376 Appendable ->
377 name == Var.string
379 CompAppend ->
380 name == Var.string
383unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
384unifyFlexSuperStructure context super term =
385 do case term of
386 App1 name [] ->
387 if atomMatchesSuper super name then
388 merge context (Structure term)
389 else
390 mismatch context (Just (badSuper super))
392 App1 name [variable] | name == Var.list ->
393 case super of
394 Number ->
395 mismatch context (Just (badSuper super))
397 Appendable ->
398 merge context (Structure term)
400 Comparable ->
401 do comparableOccursCheck context
402 merge context (Structure term)
403 unifyComparableRecursive (_orientation context) variable
405 CompAppend ->
406 do comparableOccursCheck context
407 merge context (Structure term)
408 unifyComparableRecursive (_orientation context) variable
410 App1 name args | Var.isTuple name ->
411 case super of
412 Number ->
413 mismatch context (Just (badSuper super))
415 Appendable ->
416 mismatch context (Just (badSuper super))
418 Comparable ->
419 if length args > 6 then
420 mismatch context (Just (Error.TooLongComparableTuple (length args)))
422 else
423 do comparableOccursCheck context
424 merge context (Structure term)
425 mapM_ (unifyComparableRecursive (_orientation context)) args
427 CompAppend ->
428 mismatch context (Just (badSuper super))
430 _ ->
431 mismatch context (Just (badSuper super))
434-- TODO: is there some way to avoid doing this?
435-- Do type classes require occurs checks?
436comparableOccursCheck :: Context -> Unify ()
437comparableOccursCheck (Context _ _ _ var _) =
438 do hasOccurred <- liftIO $ Occurs.occurs var
439 if hasOccurred
440 then throwError Infinite
441 else return ()
444unifyComparableRecursive :: Orientation -> Variable -> Unify ()
445unifyComparableRecursive orientation var =
446 do compVar <-
447 liftIO $
448 do desc <- UF.descriptor var
449 UF.fresh $
450 Descriptor
451 { _content = Var Flex (Just Comparable) Nothing
452 , _rank = _rank desc
453 , _mark = noMark
454 , _copy = Nothing
455 }
457 guardedUnify orientation compVar var
460collectArgs :: Variable -> IO [Variable]
461collectArgs variable =
462 collectArgsHelp [] variable
465collectArgsHelp :: [Variable] -> Variable -> IO [Variable]
466collectArgsHelp revArgs variable =
467 do content <- getContent variable
468 case content of
469 Structure (Fun1 arg returnType) ->
470 collectArgsHelp (arg : revArgs) returnType
472 _ ->
473 return $ variable : revArgs
476getContent :: Variable -> IO Content
477getContent variable =
478 _content <$> UF.descriptor variable
482-- UNIFY ALIASES
485unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()
486unifyAlias context name args realVar otherContent =
487 case otherContent of
488 Error _ ->
489 return ()
491 Var Flex Nothing _ ->
492 merge context (Alias name args realVar)
494 Var _ _ _ ->
495 subUnify context realVar (_second context)
497 Alias otherName otherArgs otherRealVar ->
498 if name == otherName then
499 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
500 merge context otherContent
502 else
503 subUnify context realVar otherRealVar
505 Structure _ ->
506 subUnify context realVar (_second context)
510-- UNIFY STRUCTURES
513unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
514unifyStructure context term content otherContent =
515 case otherContent of
516 Error _ ->
517 return ()
519 Var Flex Nothing _ ->
520 merge context content
522 Var Flex (Just super) _ ->
523 unifyFlexSuperStructure (reorient context) super term
525 Var Rigid _ maybeName ->
526 mismatch context (Just (Error.flipReason (badRigid maybeName)))
528 Alias _ _ realVar ->
529 subUnify context (_first context) realVar
531 Structure otherTerm ->
532 case (term, otherTerm) of
533 (App1 name args, App1 otherName otherArgs) ->
534 if name == otherName then
535 do zipWithM_ (subUnify context) args otherArgs
536 merge context otherContent
538 else if isIntFloat name otherName || isIntFloat otherName name then
539 mismatch context (Just Error.IntFloat)
541 else
542 mismatch context Nothing
544 (Fun1 arg result, Fun1 otherArg otherResult) ->
545 do subUnify context arg otherArg
546 subUnify context result otherResult
547 merge context otherContent
549 (EmptyRecord1, EmptyRecord1) ->
550 merge context otherContent
552 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
553 subUnify context ext (_second context)
555 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
556 subUnify context (_first context) ext
558 (Record1 fields extension, Record1 otherFields otherExtension) ->
559 do firstStructure <- liftIO $ gatherFields context fields extension
560 secondStructure <- liftIO $ gatherFields context otherFields otherExtension
561 unifyRecord context firstStructure secondStructure
563 _ ->
564 mismatch context Nothing
567isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
568isIntFloat name otherName =
569 Var.isPrim "Int" name && Var.isPrim "Float" otherName
573-- UNIFY RECORDS
576unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
577unifyRecord context firstStructure secondStructure =
578 do let (RecordStructure expFields expVar expStruct) = firstStructure
579 let (RecordStructure actFields actVar actStruct) = secondStructure
581 let sharedFields = Map.intersectionWith (,) expFields actFields
583 -- call after unifying extension, make sure record shape matches before
584 -- looking into whether the particular field types match.
585 let unifySharedFields otherFields ext =
586 do unifySharedFieldsHelp context sharedFields
587 let allFields = Map.union (Map.map fst sharedFields) otherFields
588 merge context (Structure (Record1 allFields ext))
590 let uniqueExpFields = Map.difference expFields actFields
591 let uniqueActFields = Map.difference actFields expFields
593 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
594 (_, True, _, True) ->
595 do subUnify context expVar actVar
596 unifySharedFields Map.empty expVar
598 (Empty, _, _, False) ->
599 mismatch context $ Just $
600 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
602 (_, False, Empty, _) ->
603 mismatch context $ Just $
604 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
606 (_, False, _, True) ->
607 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
608 subUnify context subRecord actVar
609 unifySharedFields Map.empty subRecord
611 (_, True, _, False) ->
612 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
613 subUnify context expVar subRecord
614 unifySharedFields Map.empty subRecord
616 (Extension, False, Extension, False) ->
617 do let subFields = Map.union uniqueExpFields uniqueActFields
618 subExt <- fresh context (Var Flex Nothing Nothing)
619 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
620 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
621 subUnify context expVar expRecord
622 subUnify context actRecord actVar
623 unifySharedFields subFields subExt
627unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()
628unifySharedFieldsHelp context sharedFields =
629 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
630 case Maybe.catMaybes maybeBadFields of
631 [] ->
632 return ()
634 badFields ->
635 mismatch context (Just (Error.BadFields (reverse badFields)))
638unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))
639unifyField context (field, (expected, actual)) =
640 do result <- lift $ runExceptT $ subUnify context expected actual
641 case result of
642 Right () ->
643 return $ Nothing
645 Left problem ->
646 return $ Just $ (,) field $
647 case problem of
648 Typical ->
649 Nothing
651 Special reason ->
652 Just reason
654 Infinite ->
655 Nothing
659-- GATHER RECORD STRUCTURE
662data RecordStructure = RecordStructure
663 { _fields :: Map.Map Text Variable
664 , _extVar :: Variable
665 , _extStruct :: ExtensionStructure
666 }
669data ExtensionStructure
670 = Empty
671 | Extension
674gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure
675gatherFields context fields variable =
676 do desc <- UF.descriptor variable
677 case _content desc of
678 Structure (Record1 subFields subExt) ->
679 gatherFields context (Map.union fields subFields) subExt
681 Structure EmptyRecord1 ->
682 return (RecordStructure fields variable Empty)
684 Alias _ _ var ->
685 -- TODO may be dropping useful alias info here
686 gatherFields context fields var
688 _ ->
689 return (RecordStructure fields variable Extension)