git.iko.soy/elk
on 20fa5f2 help sign in
elk/src/Type/Unify.hs
733 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.State as TS
15import Type.Type as Type
16import qualified Type.UnionFind as UF
20-- KICK OFF UNIFICATION
23unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
24unify hint region expected actual =
25 {-# SCC elm_compiler_type_unify #-}
26 do result <- runExceptT (guardedUnify ExpectedActual expected actual)
27 case result of
28 Right () ->
29 return ()
31 Left (Mismatch maybeReason) ->
32 let
33 mkError =
34 do expectedSrcType <- Type.toSrcType expected
35 actualSrcType <- Type.toSrcType actual
36 mergeHelp expected actual Error noRank
37 let info = Error.MismatchInfo hint expectedSrcType actualSrcType maybeReason
38 return (Error.Mismatch info)
39 in
40 TS.addError region =<< liftIO mkError
44-- UNIFICATION HELPERS
47type Unify =
48 ExceptT Mismatch TS.Solver
51data Context = Context
52 { _orientation :: Orientation
53 , _first :: Variable
54 , _firstDesc :: Descriptor
55 , _second :: Variable
56 , _secondDesc :: Descriptor
57 }
60data Orientation = ExpectedActual | ActualExpected
63reorient :: Context -> Context
64reorient (Context orientation var1 desc1 var2 desc2) =
65 let
66 otherOrientation =
67 case orientation of
68 ExpectedActual -> ActualExpected
69 ActualExpected -> ExpectedActual
70 in
71 Context otherOrientation var2 desc2 var1 desc1
75-- ERROR MESSAGES
78newtype Mismatch =
79 Mismatch (Maybe Error.Reason)
82mismatch :: Context -> Maybe Error.Reason -> Unify a
83mismatch context@(Context orientation var1 _ var2 _) maybeReason =
84 do args1 <- liftIO $ collectArgs var1
85 args2 <- liftIO $ collectArgs var2
87 let numArgs1 = length args1
88 let numArgs2 = length args2
90 if numArgs1 == numArgs2
91 then
92 mismatchHelp orientation maybeReason
93 else
94 do zipWithM_ (\arg1 arg2 -> lift $ runExceptT $ subUnify context arg1 arg2) args1 args2
95 mismatchHelp orientation $ Just $ Error.MissingArgs $ abs (numArgs2 - numArgs1)
98mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
99mismatchHelp orientation maybeReason =
100 throwError $ Mismatch $
101 case orientation of
102 ExpectedActual ->
103 maybeReason
105 ActualExpected ->
106 Error.flipReason <$> maybeReason
109badRigid :: Maybe Text -> Error.Reason
110badRigid maybeName =
111 Error.BadVar (Just (Error.Rigid maybeName)) Nothing
114badSuper :: Super -> Error.Reason
115badSuper super =
116 Error.BadVar (Just (errorSuper super)) Nothing
119badSupers :: Super -> Super -> Error.Reason
120badSupers super1 super2 =
121 Error.BadVar (Just (errorSuper super1)) (Just (errorSuper super2))
124doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
125doubleBad vt1 vt2 =
126 Error.BadVar (Just vt1) (Just vt2)
129errorSuper :: Super -> Error.VarType
130errorSuper super =
131 case super of
132 Number ->
133 Error.Number
135 Comparable ->
136 Error.Comparable
138 Appendable ->
139 Error.Appendable
141 CompAppend ->
142 Error.CompAppend
146-- MERGE
149merge :: Context -> Content -> Unify ()
150merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
151 liftIO $ mergeHelp var1 var2 content (min rank1 rank2)
154mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
155mergeHelp var1 second newContent newRank =
156 UF.union var1 second $
157 Descriptor
158 { _content = newContent
159 , _rank = newRank
160 , _mark = noMark
161 , _copy = Nothing
162 }
165fresh :: Context -> Content -> Unify Variable
166fresh (Context _ _ desc1 _ desc2) content =
167 do freshVariable <-
168 liftIO $ UF.fresh $
169 Descriptor
170 { _content = content
171 , _rank = min (_rank desc1) (_rank desc2)
172 , _mark = noMark
173 , _copy = Nothing
174 }
175 lift (TS.register freshVariable)
179-- ACTUALLY UNIFY THINGS
182guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
183guardedUnify orientation left right =
184 do equivalent <- liftIO $ UF.equivalent left right
185 if equivalent
186 then return ()
187 else
188 do leftDesc <- liftIO $ UF.descriptor left
189 rightDesc <- liftIO $ UF.descriptor right
190 actuallyUnify (Context orientation left leftDesc right rightDesc)
193subUnify :: Context -> Variable -> Variable -> Unify ()
194subUnify context var1 var2 =
195 guardedUnify (_orientation context) var1 var2
198actuallyUnify :: Context -> Unify ()
199actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
200 let
201 firstContent = _content firstDesc
202 secondContent = _content secondDesc
203 in
204 case firstContent of
205 Error ->
206 -- If there was an error, just pretend it is okay. This lets us avoid
207 -- "cascading" errors where one problem manifests as multiple message.
208 return ()
210 Var Flex Nothing _ ->
211 unifyFlex context secondContent
213 Var Flex (Just super) _ ->
214 unifyFlexSuper context super firstContent secondContent
216 Var Rigid maybeSuper maybeName ->
217 unifyRigid context maybeSuper maybeName firstContent secondContent
219 Atom name ->
220 unifyAtom context name secondContent
222 Alias name args realVar ->
223 unifyAlias context name args realVar secondContent
225 Structure term ->
226 unifyStructure context term firstContent secondContent
230-- UNIFY FLEXIBLE VARIABLES
233unifyFlex :: Context -> Content -> Unify ()
234unifyFlex context otherContent =
235 case otherContent of
236 Error ->
237 return ()
239 Var Flex _ _ ->
240 merge context otherContent
242 Var Rigid _ _ ->
243 merge context otherContent
245 Atom _ ->
246 merge context otherContent
248 Alias _ _ _ ->
249 merge context otherContent
251 Structure _ ->
252 merge context otherContent
256-- UNIFY RIGID VARIABLES
259unifyRigid :: Context -> Maybe Super -> Maybe Text -> Content -> Content -> Unify ()
260unifyRigid context maybeSuper maybeName content otherContent =
261 case otherContent of
262 Error ->
263 return ()
265 Var Flex otherMaybeSuper _ ->
266 case (maybeSuper, otherMaybeSuper) of
267 (_, Nothing) ->
268 merge context content
270 (Nothing, Just _) ->
271 mismatch context (Just (badRigid maybeName))
273 (Just super, Just otherSuper) ->
274 if combineRigidSupers super otherSuper then
275 merge context content
276 else
277 mismatch context (Just (badRigid maybeName))
279 Var Rigid _ otherMaybeName ->
280 mismatch context $ Just $
281 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
283 Atom _ ->
284 mismatch context (Just (badRigid maybeName))
286 Alias _ _ _ ->
287 mismatch context (Just (badRigid maybeName))
289 Structure _ ->
290 mismatch context (Just (badRigid maybeName))
294-- UNIFY SUPER VARIABLES
297unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
298unifyFlexSuper context super content otherContent =
299 case otherContent of
300 Structure term ->
301 unifyFlexSuperStructure context super term
303 Atom name ->
304 if atomMatchesSuper super name then
305 merge context otherContent
306 else
307 mismatch context (Just (badSuper super))
309 Var Rigid Nothing maybeName ->
310 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
312 Var Rigid (Just otherSuper) maybeName ->
313 if combineRigidSupers otherSuper super then
314 merge context otherContent
315 else
316 mismatch context $ Just $ badRigid maybeName
318 Var Flex Nothing _ ->
319 merge context content
321 Var Flex (Just otherSuper) _ ->
322 case super of
323 Number ->
324 case otherSuper of
325 Number -> merge context content
326 Comparable -> merge context content
327 _ -> mismatch context $ Just $ badSupers super otherSuper
329 Comparable ->
330 case otherSuper of
331 Comparable -> merge context otherContent
332 Number -> merge context otherContent
333 Appendable -> merge context (Var Flex (Just CompAppend) Nothing)
334 CompAppend -> merge context otherContent
336 Appendable ->
337 case otherSuper of
338 Appendable -> merge context otherContent
339 Comparable -> merge context (Var Flex (Just CompAppend) Nothing)
340 CompAppend -> merge context otherContent
341 Number -> mismatch context $ Just $ badSupers super otherSuper
343 CompAppend ->
344 case otherSuper of
345 Comparable -> merge context content
346 Appendable -> merge context content
347 CompAppend -> merge context content
348 Number -> mismatch context $ Just $ badSupers super otherSuper
350 Alias _ _ realVar ->
351 subUnify context (_first context) realVar
353 Error ->
354 return ()
357combineRigidSupers :: Super -> Super -> Bool
358combineRigidSupers rigid flex =
359 rigid == flex
360 || (rigid == Number && flex == Comparable)
361 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
364isPrimitiveFrom :: [Text] -> Var.Canonical -> Bool
365isPrimitiveFrom prims var =
366 any (\p -> Var.isPrim p var) prims
369atomMatchesSuper :: Super -> Var.Canonical -> Bool
370atomMatchesSuper super name =
371 case super of
372 Number ->
373 isPrimitiveFrom ["Int", "Float"] name
375 Comparable ->
376 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
378 Appendable ->
379 Var.isPrim "String" name
381 CompAppend ->
382 Var.isPrim "String" name
385unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
386unifyFlexSuperStructure context super term =
387 do appStructure <- liftIO (collectApps (Structure term))
388 case appStructure of
389 Other ->
390 mismatch context (Just (badSuper super))
392 List variable ->
393 case super of
394 Number ->
395 mismatch context (Just (badSuper super))
397 Appendable ->
398 merge context (Structure term)
400 Comparable ->
401 do merge context (Structure term)
402 unifyComparableRecursive (_orientation context) variable
404 CompAppend ->
405 do merge context (Structure term)
406 unifyComparableRecursive (_orientation context) variable
408 Tuple entries ->
409 case super of
410 Number ->
411 mismatch context (Just (badSuper super))
413 Appendable ->
414 mismatch context (Just (badSuper super))
416 Comparable ->
417 if length entries > 6 then
418 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
420 else
421 do merge context (Structure term)
422 mapM_ (unifyComparableRecursive (_orientation context)) entries
424 CompAppend ->
425 mismatch context (Just (badSuper super))
428unifyComparableRecursive :: Orientation -> Variable -> Unify ()
429unifyComparableRecursive orientation var =
430 do compVar <-
431 liftIO $
432 do desc <- UF.descriptor var
433 UF.fresh $
434 Descriptor
435 { _content = Var Flex (Just Comparable) Nothing
436 , _rank = _rank desc
437 , _mark = noMark
438 , _copy = Nothing
439 }
441 guardedUnify orientation compVar var
444data AppStructure
445 = List Variable
446 | Tuple [Variable]
447 | Other
450collectApps :: Content -> IO AppStructure
451collectApps content =
452 collectAppsHelp [] content
455collectAppsHelp :: [Variable] -> Content -> IO AppStructure
456collectAppsHelp args content =
457 case (content, args) of
458 (Structure (App1 func arg), _) ->
459 collectAppsHelp (args ++ [arg]) =<< getContent func
461 (Atom name, [arg]) | Var.isList name ->
462 return (List arg)
464 (Atom name, _) | Var.isTuple name ->
465 return (Tuple args)
467 _ ->
468 return Other
471collectArgs :: Variable -> IO [Variable]
472collectArgs variable =
473 collectArgsHelp [] variable
476collectArgsHelp :: [Variable] -> Variable -> IO [Variable]
477collectArgsHelp revArgs variable =
478 do content <- getContent variable
479 case content of
480 Structure (Fun1 arg returnType) ->
481 collectArgsHelp (arg : revArgs) returnType
483 _ ->
484 return $ variable : revArgs
487getContent :: Variable -> IO Content
488getContent variable =
489 _content <$> UF.descriptor variable
493-- UNIFY ATOMS
496unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
497unifyAtom context name otherContent =
498 case otherContent of
499 Error ->
500 return ()
502 Var Flex Nothing _ ->
503 merge context (Atom name)
505 Var Flex (Just super) _ ->
506 if atomMatchesSuper super name then
507 merge context (Atom name)
509 else
510 mismatch context (Just ((Error.flipReason (badSuper super))))
512 Var Rigid _ maybeName ->
513 mismatch context (Just (Error.flipReason (badRigid maybeName)))
515 Atom otherName ->
516 if name == otherName then
517 merge context otherContent
519 else
520 mismatch context $
521 if isIntFloat name otherName || isIntFloat otherName name then
522 Just Error.IntFloat
523 else
524 Nothing
526 Alias _ _ realVar ->
527 subUnify context (_first context) realVar
529 Structure _ ->
530 mismatch context Nothing
533isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
534isIntFloat name otherName =
535 Var.isPrim "Int" name && Var.isPrim "Float" otherName
539-- UNIFY ALIASES
542unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()
543unifyAlias context name args realVar otherContent =
544 case otherContent of
545 Error ->
546 return ()
548 Var Flex Nothing _ ->
549 merge context (Alias name args realVar)
551 Var _ _ _ ->
552 subUnify context realVar (_second context)
554 Atom _ ->
555 subUnify context realVar (_second context)
557 Alias otherName otherArgs otherRealVar ->
558 if name == otherName then
559 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
560 merge context otherContent
562 else
563 subUnify context realVar otherRealVar
565 Structure _ ->
566 subUnify context realVar (_second context)
570-- UNIFY STRUCTURES
573unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
574unifyStructure context term content otherContent =
575 case otherContent of
576 Error ->
577 return ()
579 Var Flex Nothing _ ->
580 merge context content
582 Var Flex (Just super) _ ->
583 unifyFlexSuperStructure (reorient context) super term
585 Var Rigid _ maybeName ->
586 mismatch context (Just (Error.flipReason (badRigid maybeName)))
588 Atom _ ->
589 mismatch context Nothing
591 Alias _ _ realVar ->
592 subUnify context (_first context) realVar
594 Structure otherTerm ->
595 case (term, otherTerm) of
596 (App1 func arg, App1 otherFunc otherArg) ->
597 do subUnify context func otherFunc
598 subUnify context arg otherArg
599 merge context otherContent
601 (Fun1 arg result, Fun1 otherArg otherResult) ->
602 do subUnify context arg otherArg
603 subUnify context result otherResult
604 merge context otherContent
606 (EmptyRecord1, EmptyRecord1) ->
607 merge context otherContent
609 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
610 subUnify context ext (_second context)
612 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
613 subUnify context (_first context) ext
615 (Record1 fields extension, Record1 otherFields otherExtension) ->
616 do firstStructure <- liftIO $ gatherFields context fields extension
617 secondStructure <- liftIO $ gatherFields context otherFields otherExtension
618 unifyRecord context firstStructure secondStructure
620 _ ->
621 mismatch context Nothing
625-- UNIFY RECORDS
628unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
629unifyRecord context firstStructure secondStructure =
630 do let (RecordStructure expFields expVar expStruct) = firstStructure
631 let (RecordStructure actFields actVar actStruct) = secondStructure
633 let sharedFields = Map.intersectionWith (,) expFields actFields
635 -- call after unifying extension, make sure record shape matches before
636 -- looking into whether the particular field types match.
637 let unifySharedFields otherFields ext =
638 do unifySharedFieldsHelp context sharedFields
639 let allFields = Map.union (Map.map fst sharedFields) otherFields
640 merge context (Structure (Record1 allFields ext))
642 let uniqueExpFields = Map.difference expFields actFields
643 let uniqueActFields = Map.difference actFields expFields
645 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
646 (_, True, _, True) ->
647 do subUnify context expVar actVar
648 unifySharedFields Map.empty expVar
650 (Empty, _, _, False) ->
651 mismatch context $ Just $
652 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
654 (_, False, Empty, _) ->
655 mismatch context $ Just $
656 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
658 (_, False, _, True) ->
659 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
660 subUnify context subRecord actVar
661 unifySharedFields Map.empty subRecord
663 (_, True, _, False) ->
664 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
665 subUnify context expVar subRecord
666 unifySharedFields Map.empty subRecord
668 (Extension, False, Extension, False) ->
669 do let subFields = Map.union uniqueExpFields uniqueActFields
670 subExt <- fresh context (Var Flex Nothing Nothing)
671 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
672 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
673 subUnify context expVar expRecord
674 subUnify context actRecord actVar
675 unifySharedFields subFields subExt
679unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()
680unifySharedFieldsHelp context sharedFields =
681 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
682 case Maybe.catMaybes maybeBadFields of
683 [] ->
684 return ()
686 badFields ->
687 mismatch context (Just (Error.BadFields (reverse badFields)))
690unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))
691unifyField context (field, (expected, actual)) =
692 do result <- lift $ runExceptT $ subUnify context expected actual
693 case result of
694 Right () ->
695 return $ Nothing
697 Left (Mismatch maybeReason) ->
698 return $ Just (field, maybeReason)
702-- GATHER RECORD STRUCTURE
705data RecordStructure = RecordStructure
706 { _fields :: Map.Map Text Variable
707 , _extVar :: Variable
708 , _extStruct :: ExtensionStructure
709 }
712data ExtensionStructure
713 = Empty
714 | Extension
717gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure
718gatherFields context fields variable =
719 do desc <- UF.descriptor variable
720 case _content desc of
721 Structure (Record1 subFields subExt) ->
722 gatherFields context (Map.union fields subFields) subExt
724 Structure EmptyRecord1 ->
725 return (RecordStructure fields variable Empty)
727 Alias _ _ var ->
728 -- TODO may be dropping useful alias info here
729 gatherFields context fields var
731 _ ->
732 return (RecordStructure fields variable Extension)