git.iko.soy/elk
on 65aa02a help sign in
elk/src/Type/Unify.hs
753 lines 21 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Unify (unify) where
5import Control.Monad (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 (Mismatch maybeReason) ->
33 let
34 mkError =
35 do expectedSrcType <- Type.toSrcType expected
36 actualSrcType <- Type.toSrcType actual
37 mergeHelp expected actual Error noRank
38 let info = Error.MismatchInfo hint expectedSrcType actualSrcType maybeReason
39 return (Error.Mismatch info)
40 in
41 TS.addError region =<< liftIO mkError
45-- UNIFICATION HELPERS
48type Unify =
49 ExceptT Mismatch TS.Solver
52data Context =
53 Context
54 { _orientation :: Orientation
55 , _first :: Variable
56 , _firstDesc :: Descriptor
57 , _second :: Variable
58 , _secondDesc :: Descriptor
59 }
62data Orientation = ExpectedActual | ActualExpected
65reorient :: Context -> Context
66reorient (Context orientation var1 desc1 var2 desc2) =
67 let
68 otherOrientation =
69 case orientation of
70 ExpectedActual -> ActualExpected
71 ActualExpected -> ExpectedActual
72 in
73 Context otherOrientation var2 desc2 var1 desc1
77-- ERROR MESSAGES
80newtype Mismatch =
81 Mismatch (Maybe Error.Reason)
84mismatch :: Context -> Maybe Error.Reason -> Unify a
85mismatch context@(Context orientation var1 _ var2 _) maybeReason =
86 do args1 <- liftIO $ collectArgs var1
87 args2 <- liftIO $ collectArgs var2
89 let numArgs1 = length args1
90 let numArgs2 = length args2
92 if numArgs1 == numArgs2
93 then
94 mismatchHelp orientation maybeReason
95 else
96 do zipWithM_ (\arg1 arg2 -> lift $ runExceptT $ subUnify context arg1 arg2) args1 args2
97 mismatchHelp orientation $ Just $ Error.MissingArgs $ abs (numArgs2 - numArgs1)
100mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
101mismatchHelp orientation maybeReason =
102 throwError $ Mismatch $
103 case orientation of
104 ExpectedActual ->
105 maybeReason
107 ActualExpected ->
108 Error.flipReason <$> maybeReason
111badRigid :: Maybe Text -> Error.Reason
112badRigid maybeName =
113 Error.BadVar (Just (Error.Rigid maybeName)) Nothing
116badSuper :: Super -> Error.Reason
117badSuper super =
118 Error.BadVar (Just (errorSuper super)) Nothing
121badSupers :: Super -> Super -> Error.Reason
122badSupers super1 super2 =
123 Error.BadVar (Just (errorSuper super1)) (Just (errorSuper super2))
126doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
127doubleBad vt1 vt2 =
128 Error.BadVar (Just vt1) (Just vt2)
131errorSuper :: Super -> Error.VarType
132errorSuper super =
133 case super of
134 Number ->
135 Error.Number
137 Comparable ->
138 Error.Comparable
140 Appendable ->
141 Error.Appendable
143 CompAppend ->
144 Error.CompAppend
148-- MERGE
151merge :: Context -> Content -> Unify ()
152merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
153 liftIO $ mergeHelp var1 var2 content (min rank1 rank2)
156mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
157mergeHelp var1 var2 newContent newRank =
158 UF.union var1 var2 $
159 Descriptor
160 { _content = newContent
161 , _rank = newRank
162 , _mark = noMark
163 , _copy = Nothing
164 }
167fresh :: Context -> Content -> Unify Variable
168fresh (Context _ _ desc1 _ desc2) content =
169 do freshVariable <-
170 liftIO $ UF.fresh $
171 Descriptor
172 { _content = content
173 , _rank = min (_rank desc1) (_rank desc2)
174 , _mark = noMark
175 , _copy = Nothing
176 }
177 lift (TS.register freshVariable)
181-- ACTUALLY UNIFY THINGS
184guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
185guardedUnify orientation left right =
186 do equivalent <- liftIO $ UF.equivalent left right
187 if equivalent
188 then return ()
189 else
190 do leftDesc <- liftIO $ UF.descriptor left
191 rightDesc <- liftIO $ UF.descriptor right
192 actuallyUnify (Context orientation left leftDesc right rightDesc)
195subUnify :: Context -> Variable -> Variable -> Unify ()
196subUnify context var1 var2 =
197 guardedUnify (_orientation context) var1 var2
200actuallyUnify :: Context -> Unify ()
201actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
202 let
203 firstContent = _content firstDesc
204 secondContent = _content secondDesc
205 in
206 case firstContent of
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 ()
212 Var Flex Nothing _ ->
213 unifyFlex context secondContent
215 Var Flex (Just super) _ ->
216 unifyFlexSuper context super firstContent secondContent
218 Var Rigid maybeSuper maybeName ->
219 unifyRigid context maybeSuper maybeName firstContent secondContent
221 Atom name ->
222 unifyAtom context name secondContent
224 Alias name args realVar ->
225 unifyAlias context name args realVar secondContent
227 Structure term ->
228 unifyStructure context term firstContent secondContent
232-- UNIFY FLEXIBLE VARIABLES
235unifyFlex :: Context -> Content -> Unify ()
236unifyFlex context otherContent =
237 case otherContent of
238 Error ->
239 return ()
241 Var Flex _ _ ->
242 merge context otherContent
244 Var Rigid _ _ ->
245 merge context otherContent
247 Atom _ ->
248 merge context otherContent
250 Alias _ _ _ ->
251 merge context otherContent
253 Structure _ ->
254 merge context otherContent
258-- UNIFY RIGID VARIABLES
261unifyRigid :: Context -> Maybe Super -> Maybe Text -> Content -> Content -> Unify ()
262unifyRigid context maybeSuper maybeName content otherContent =
263 case otherContent of
264 Error ->
265 return ()
267 Var Flex otherMaybeSuper _ ->
268 case (maybeSuper, otherMaybeSuper) of
269 (_, Nothing) ->
270 merge context content
272 (Nothing, Just _) ->
273 mismatch context (Just (badRigid maybeName))
275 (Just super, Just otherSuper) ->
276 if combineRigidSupers super otherSuper then
277 merge context content
278 else
279 mismatch context (Just (badRigid maybeName))
281 Var Rigid _ otherMaybeName ->
282 mismatch context $ Just $
283 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
285 Atom _ ->
286 mismatch context (Just (badRigid maybeName))
288 Alias _ _ _ ->
289 mismatch context (Just (badRigid maybeName))
291 Structure _ ->
292 mismatch context (Just (badRigid maybeName))
296-- UNIFY SUPER VARIABLES
299unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
300unifyFlexSuper context super content otherContent =
301 case otherContent of
302 Structure term ->
303 unifyFlexSuperStructure context super term
305 Atom name ->
306 if atomMatchesSuper super name then
307 merge context otherContent
308 else
309 mismatch context (Just (badSuper super))
311 Var Rigid Nothing maybeName ->
312 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
314 Var Rigid (Just otherSuper) maybeName ->
315 if combineRigidSupers otherSuper super then
316 merge context otherContent
317 else
318 mismatch context $ Just $ badRigid maybeName
320 Var Flex Nothing _ ->
321 merge context content
323 Var Flex (Just otherSuper) _ ->
324 case super of
325 Number ->
326 case otherSuper of
327 Number -> merge context content
328 Comparable -> merge context content
329 _ -> mismatch context $ Just $ badSupers super otherSuper
331 Comparable ->
332 case otherSuper of
333 Comparable -> merge context otherContent
334 Number -> merge context otherContent
335 Appendable -> merge context (Var Flex (Just CompAppend) Nothing)
336 CompAppend -> merge context otherContent
338 Appendable ->
339 case otherSuper of
340 Appendable -> merge context otherContent
341 Comparable -> merge context (Var Flex (Just CompAppend) Nothing)
342 CompAppend -> merge context otherContent
343 Number -> mismatch context $ Just $ badSupers super otherSuper
345 CompAppend ->
346 case otherSuper of
347 Comparable -> merge context content
348 Appendable -> merge context content
349 CompAppend -> merge context content
350 Number -> mismatch context $ Just $ badSupers super otherSuper
352 Alias _ _ realVar ->
353 subUnify context (_first context) realVar
355 Error ->
356 return ()
359combineRigidSupers :: Super -> Super -> Bool
360combineRigidSupers rigid flex =
361 rigid == flex
362 || (rigid == Number && flex == Comparable)
363 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
366isPrimitiveFrom :: [Text] -> Var.Canonical -> Bool
367isPrimitiveFrom prims var =
368 any (\p -> Var.isPrim p var) prims
371atomMatchesSuper :: Super -> Var.Canonical -> Bool
372atomMatchesSuper super name =
373 case super of
374 Number ->
375 isPrimitiveFrom ["Int", "Float"] name
377 Comparable ->
378 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
380 Appendable ->
381 Var.isPrim "String" name
383 CompAppend ->
384 Var.isPrim "String" name
387unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
388unifyFlexSuperStructure context super term =
389 do appStructure <- liftIO (collectApps term)
390 case appStructure of
391 Other ->
392 mismatch context (Just (badSuper super))
394 List variable ->
395 case super of
396 Number ->
397 mismatch context (Just (badSuper super))
399 Appendable ->
400 merge context (Structure term)
402 Comparable ->
403 do comparableOccursCheck context
404 merge context (Structure term)
405 unifyComparableRecursive (_orientation context) variable
407 CompAppend ->
408 do comparableOccursCheck context
409 merge context (Structure term)
410 unifyComparableRecursive (_orientation context) variable
412 Tuple entries ->
413 case super of
414 Number ->
415 mismatch context (Just (badSuper super))
417 Appendable ->
418 mismatch context (Just (badSuper super))
420 Comparable ->
421 if length entries > 6 then
422 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
424 else
425 do comparableOccursCheck context
426 merge context (Structure term)
427 mapM_ (unifyComparableRecursive (_orientation context)) entries
429 CompAppend ->
430 mismatch context (Just (badSuper super))
433-- TODO: is there some way to avoid doing this?
434-- Do type classes require occurs checks?
435comparableOccursCheck :: Context -> Unify ()
436comparableOccursCheck (Context _ _ _ var _) =
437 do hasOccurred <- liftIO $ Occurs.occurs var
438 if hasOccurred
439 then throwError (Mismatch Nothing)
440 else return ()
443unifyComparableRecursive :: Orientation -> Variable -> Unify ()
444unifyComparableRecursive orientation var =
445 do compVar <-
446 liftIO $
447 do desc <- UF.descriptor var
448 UF.fresh $
449 Descriptor
450 { _content = Var Flex (Just Comparable) Nothing
451 , _rank = _rank desc
452 , _mark = noMark
453 , _copy = Nothing
454 }
456 guardedUnify orientation compVar var
459data AppStructure
460 = List Variable
461 | Tuple [Variable]
462 | Other
465collectApps :: FlatType -> IO AppStructure
466collectApps term =
467 case term of
468 App1 func arg ->
469 collectAppsHelp [arg] =<< getContent func
471 _ ->
472 return Other
475collectAppsHelp :: [Variable] -> Content -> IO AppStructure
476collectAppsHelp args content =
477 case (content, args) of
478 (Structure (App1 func arg), _) ->
479 collectAppsHelp (arg : args) =<< getContent func
481 (Atom name, [arg]) | Var.isList name ->
482 return (List arg)
484 (Atom name, _) | Var.isTuple name ->
485 return (Tuple (reverse args))
487 _ ->
488 return Other
491collectArgs :: Variable -> IO [Variable]
492collectArgs variable =
493 collectArgsHelp [] variable
496collectArgsHelp :: [Variable] -> Variable -> IO [Variable]
497collectArgsHelp revArgs variable =
498 do content <- getContent variable
499 case content of
500 Structure (Fun1 arg returnType) ->
501 collectArgsHelp (arg : revArgs) returnType
503 _ ->
504 return $ variable : revArgs
507getContent :: Variable -> IO Content
508getContent variable =
509 _content <$> UF.descriptor variable
513-- UNIFY ATOMS
516unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
517unifyAtom context name otherContent =
518 case otherContent of
519 Error ->
520 return ()
522 Var Flex Nothing _ ->
523 merge context (Atom name)
525 Var Flex (Just super) _ ->
526 if atomMatchesSuper super name then
527 merge context (Atom name)
529 else
530 mismatch context (Just ((Error.flipReason (badSuper super))))
532 Var Rigid _ maybeName ->
533 mismatch context (Just (Error.flipReason (badRigid maybeName)))
535 Atom otherName ->
536 if name == otherName then
537 merge context otherContent
539 else
540 mismatch context $
541 if isIntFloat name otherName || isIntFloat otherName name then
542 Just Error.IntFloat
543 else
544 Nothing
546 Alias _ _ realVar ->
547 subUnify context (_first context) realVar
549 Structure _ ->
550 mismatch context Nothing
553isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
554isIntFloat name otherName =
555 Var.isPrim "Int" name && Var.isPrim "Float" otherName
559-- UNIFY ALIASES
562unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()
563unifyAlias context name args realVar otherContent =
564 case otherContent of
565 Error ->
566 return ()
568 Var Flex Nothing _ ->
569 merge context (Alias name args realVar)
571 Var _ _ _ ->
572 subUnify context realVar (_second context)
574 Atom _ ->
575 subUnify context realVar (_second context)
577 Alias otherName otherArgs otherRealVar ->
578 if name == otherName then
579 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
580 merge context otherContent
582 else
583 subUnify context realVar otherRealVar
585 Structure _ ->
586 subUnify context realVar (_second context)
590-- UNIFY STRUCTURES
593unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
594unifyStructure context term content otherContent =
595 case otherContent of
596 Error ->
597 return ()
599 Var Flex Nothing _ ->
600 merge context content
602 Var Flex (Just super) _ ->
603 unifyFlexSuperStructure (reorient context) super term
605 Var Rigid _ maybeName ->
606 mismatch context (Just (Error.flipReason (badRigid maybeName)))
608 Atom _ ->
609 mismatch context Nothing
611 Alias _ _ realVar ->
612 subUnify context (_first context) realVar
614 Structure otherTerm ->
615 case (term, otherTerm) of
616 (App1 func arg, App1 otherFunc otherArg) ->
617 do subUnify context func otherFunc
618 subUnify context arg otherArg
619 merge context otherContent
621 (Fun1 arg result, Fun1 otherArg otherResult) ->
622 do subUnify context arg otherArg
623 subUnify context result otherResult
624 merge context otherContent
626 (EmptyRecord1, EmptyRecord1) ->
627 merge context otherContent
629 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
630 subUnify context ext (_second context)
632 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
633 subUnify context (_first context) ext
635 (Record1 fields extension, Record1 otherFields otherExtension) ->
636 do firstStructure <- liftIO $ gatherFields context fields extension
637 secondStructure <- liftIO $ gatherFields context otherFields otherExtension
638 unifyRecord context firstStructure secondStructure
640 _ ->
641 mismatch context Nothing
645-- UNIFY RECORDS
648unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
649unifyRecord context firstStructure secondStructure =
650 do let (RecordStructure expFields expVar expStruct) = firstStructure
651 let (RecordStructure actFields actVar actStruct) = secondStructure
653 let sharedFields = Map.intersectionWith (,) expFields actFields
655 -- call after unifying extension, make sure record shape matches before
656 -- looking into whether the particular field types match.
657 let unifySharedFields otherFields ext =
658 do unifySharedFieldsHelp context sharedFields
659 let allFields = Map.union (Map.map fst sharedFields) otherFields
660 merge context (Structure (Record1 allFields ext))
662 let uniqueExpFields = Map.difference expFields actFields
663 let uniqueActFields = Map.difference actFields expFields
665 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
666 (_, True, _, True) ->
667 do subUnify context expVar actVar
668 unifySharedFields Map.empty expVar
670 (Empty, _, _, False) ->
671 mismatch context $ Just $
672 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
674 (_, False, Empty, _) ->
675 mismatch context $ Just $
676 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
678 (_, False, _, True) ->
679 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
680 subUnify context subRecord actVar
681 unifySharedFields Map.empty subRecord
683 (_, True, _, False) ->
684 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
685 subUnify context expVar subRecord
686 unifySharedFields Map.empty subRecord
688 (Extension, False, Extension, False) ->
689 do let subFields = Map.union uniqueExpFields uniqueActFields
690 subExt <- fresh context (Var Flex Nothing Nothing)
691 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
692 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
693 subUnify context expVar expRecord
694 subUnify context actRecord actVar
695 unifySharedFields subFields subExt
699unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()
700unifySharedFieldsHelp context sharedFields =
701 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
702 case Maybe.catMaybes maybeBadFields of
703 [] ->
704 return ()
706 badFields ->
707 mismatch context (Just (Error.BadFields (reverse badFields)))
710unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))
711unifyField context (field, (expected, actual)) =
712 do result <- lift $ runExceptT $ subUnify context expected actual
713 case result of
714 Right () ->
715 return $ Nothing
717 Left (Mismatch maybeReason) ->
718 return $ Just (field, maybeReason)
722-- GATHER RECORD STRUCTURE
725data RecordStructure = RecordStructure
726 { _fields :: Map.Map Text Variable
727 , _extVar :: Variable
728 , _extStruct :: ExtensionStructure
729 }
732data ExtensionStructure
733 = Empty
734 | Extension
737gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure
738gatherFields context fields variable =
739 do desc <- UF.descriptor variable
740 case _content desc of
741 Structure (Record1 subFields subExt) ->
742 gatherFields context (Map.union fields subFields) subExt
744 Structure EmptyRecord1 ->
745 return (RecordStructure fields variable Empty)
747 Alias _ _ var ->
748 -- TODO may be dropping useful alias info here
749 gatherFields context fields var
751 _ ->
752 return (RecordStructure fields variable Extension)