git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Type/Unify.hs
734 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)
10import qualified Data.UnionFind.IO as UF
12import qualified AST.Variable as Var
13import qualified Reporting.Region as R
14import qualified Reporting.Error.Type as Error
15import qualified Type.State as TS
16import Type.Type as Type
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
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 _ first _ second _) content =
151 liftIO $ mergeHelp first second content
154mergeHelp :: Variable -> Variable -> Content -> IO ()
155mergeHelp first second content =
156 UF.union' first second $ \desc1 desc2 ->
157 return $
158 Descriptor
159 { _content = content
160 , _rank = min (_rank desc1) (_rank desc2)
161 , _mark = noMark
162 , _copy = Nothing
163 }
166fresh :: Context -> Content -> Unify Variable
167fresh (Context _ _ desc1 _ desc2) content =
168 do freshVariable <-
169 liftIO $ UF.fresh $
170 Descriptor
171 { _content = content
172 , _rank = min (_rank desc1) (_rank desc2)
173 , _mark = noMark
174 , _copy = Nothing
175 }
176 lift (TS.register freshVariable)
180-- ACTUALLY UNIFY THINGS
183guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
184guardedUnify orientation left right =
185 do equivalent <- liftIO $ UF.equivalent left right
186 if equivalent
187 then return ()
188 else
189 do leftDesc <- liftIO $ UF.descriptor left
190 rightDesc <- liftIO $ UF.descriptor right
191 actuallyUnify (Context orientation left leftDesc right rightDesc)
194subUnify :: Context -> Variable -> Variable -> Unify ()
195subUnify context var1 var2 =
196 guardedUnify (_orientation context) var1 var2
199actuallyUnify :: Context -> Unify ()
200actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
201 let
202 firstContent = _content firstDesc
203 secondContent = _content secondDesc
204 in
205 case firstContent of
206 Error ->
207 -- If there was an error, just pretend it is okay. This lets us avoid
208 -- "cascading" errors where one problem manifests as multiple message.
209 return ()
211 Var Flex Nothing _ ->
212 unifyFlex context secondContent
214 Var Flex (Just super) _ ->
215 unifyFlexSuper context super firstContent secondContent
217 Var Rigid maybeSuper maybeName ->
218 unifyRigid context maybeSuper maybeName firstContent secondContent
220 Atom name ->
221 unifyAtom context name secondContent
223 Alias name args realVar ->
224 unifyAlias context name args realVar secondContent
226 Structure term ->
227 unifyStructure context term firstContent secondContent
231-- UNIFY FLEXIBLE VARIABLES
234unifyFlex :: Context -> Content -> Unify ()
235unifyFlex context otherContent =
236 case otherContent of
237 Error ->
238 return ()
240 Var Flex _ _ ->
241 merge context otherContent
243 Var Rigid _ _ ->
244 merge context otherContent
246 Atom _ ->
247 merge context otherContent
249 Alias _ _ _ ->
250 merge context otherContent
252 Structure _ ->
253 merge context otherContent
257-- UNIFY RIGID VARIABLES
260unifyRigid :: Context -> Maybe Super -> Maybe Text -> Content -> Content -> Unify ()
261unifyRigid context maybeSuper maybeName content otherContent =
262 case otherContent of
263 Error ->
264 return ()
266 Var Flex otherMaybeSuper _ ->
267 case (maybeSuper, otherMaybeSuper) of
268 (_, Nothing) ->
269 merge context content
271 (Nothing, Just _) ->
272 mismatch context (Just (badRigid maybeName))
274 (Just super, Just otherSuper) ->
275 if combineRigidSupers super otherSuper then
276 merge context content
277 else
278 mismatch context (Just (badRigid maybeName))
280 Var Rigid _ otherMaybeName ->
281 mismatch context $ Just $
282 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
284 Atom _ ->
285 mismatch context (Just (badRigid maybeName))
287 Alias _ _ _ ->
288 mismatch context (Just (badRigid maybeName))
290 Structure _ ->
291 mismatch context (Just (badRigid maybeName))
295-- UNIFY SUPER VARIABLES
298unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
299unifyFlexSuper context super content otherContent =
300 case otherContent of
301 Structure term ->
302 unifyFlexSuperStructure context super term
304 Atom name ->
305 if atomMatchesSuper super name then
306 merge context otherContent
307 else
308 mismatch context (Just (badSuper super))
310 Var Rigid Nothing maybeName ->
311 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
313 Var Rigid (Just otherSuper) maybeName ->
314 if combineRigidSupers otherSuper super then
315 merge context otherContent
316 else
317 mismatch context $ Just $ badRigid maybeName
319 Var Flex Nothing _ ->
320 merge context content
322 Var Flex (Just otherSuper) _ ->
323 case super of
324 Number ->
325 case otherSuper of
326 Number -> merge context content
327 Comparable -> merge context content
328 _ -> mismatch context $ Just $ badSupers super otherSuper
330 Comparable ->
331 case otherSuper of
332 Comparable -> merge context otherContent
333 Number -> merge context otherContent
334 Appendable -> merge context (Var Flex (Just CompAppend) Nothing)
335 CompAppend -> merge context otherContent
337 Appendable ->
338 case otherSuper of
339 Appendable -> merge context otherContent
340 Comparable -> merge context (Var Flex (Just CompAppend) Nothing)
341 CompAppend -> merge context otherContent
342 Number -> mismatch context $ Just $ badSupers super otherSuper
344 CompAppend ->
345 case otherSuper of
346 Comparable -> merge context content
347 Appendable -> merge context content
348 CompAppend -> merge context content
349 Number -> mismatch context $ Just $ badSupers super otherSuper
351 Alias _ _ realVar ->
352 subUnify context (_first context) realVar
354 Error ->
355 return ()
358combineRigidSupers :: Super -> Super -> Bool
359combineRigidSupers rigid flex =
360 rigid == flex
361 || (rigid == Number && flex == Comparable)
362 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
365isPrimitiveFrom :: [Text] -> Var.Canonical -> Bool
366isPrimitiveFrom prims var =
367 any (\p -> Var.isPrim p var) prims
370atomMatchesSuper :: Super -> Var.Canonical -> Bool
371atomMatchesSuper super name =
372 case super of
373 Number ->
374 isPrimitiveFrom ["Int", "Float"] name
376 Comparable ->
377 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
379 Appendable ->
380 Var.isPrim "String" name
382 CompAppend ->
383 Var.isPrim "String" name
386unifyFlexSuperStructure :: Context -> Super -> Term1 Variable -> Unify ()
387unifyFlexSuperStructure context super term =
388 do appStructure <- liftIO (collectApps (Structure term))
389 case appStructure of
390 Other ->
391 mismatch context (Just (badSuper super))
393 List variable ->
394 case super of
395 Number ->
396 mismatch context (Just (badSuper super))
398 Appendable ->
399 merge context (Structure term)
401 Comparable ->
402 do merge context (Structure term)
403 unifyComparableRecursive (_orientation context) variable
405 CompAppend ->
406 do merge context (Structure term)
407 unifyComparableRecursive (_orientation context) variable
409 Tuple entries ->
410 case super of
411 Number ->
412 mismatch context (Just (badSuper super))
414 Appendable ->
415 mismatch context (Just (badSuper super))
417 Comparable ->
418 if length entries > 6 then
419 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
421 else
422 do merge context (Structure term)
423 mapM_ (unifyComparableRecursive (_orientation context)) entries
425 CompAppend ->
426 mismatch context (Just (badSuper super))
429unifyComparableRecursive :: Orientation -> Variable -> Unify ()
430unifyComparableRecursive orientation var =
431 do compVar <-
432 liftIO $
433 do desc <- UF.descriptor var
434 UF.fresh $
435 Descriptor
436 { _content = Var Flex (Just Comparable) Nothing
437 , _rank = _rank desc
438 , _mark = noMark
439 , _copy = Nothing
440 }
442 guardedUnify orientation compVar var
445data AppStructure
446 = List Variable
447 | Tuple [Variable]
448 | Other
451collectApps :: Content -> IO AppStructure
452collectApps content =
453 collectAppsHelp [] content
456collectAppsHelp :: [Variable] -> Content -> IO AppStructure
457collectAppsHelp args content =
458 case (content, args) of
459 (Structure (App1 func arg), _) ->
460 collectAppsHelp (args ++ [arg]) =<< getContent func
462 (Atom name, [arg]) | Var.isList name ->
463 return (List arg)
465 (Atom name, _) | Var.isTuple name ->
466 return (Tuple args)
468 _ ->
469 return Other
472collectArgs :: Variable -> IO [Variable]
473collectArgs variable =
474 collectArgsHelp [] variable
477collectArgsHelp :: [Variable] -> Variable -> IO [Variable]
478collectArgsHelp revArgs variable =
479 do content <- getContent variable
480 case content of
481 Structure (Fun1 arg returnType) ->
482 collectArgsHelp (arg : revArgs) returnType
484 _ ->
485 return $ variable : revArgs
488getContent :: Variable -> IO Content
489getContent variable =
490 _content <$> UF.descriptor variable
494-- UNIFY ATOMS
497unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
498unifyAtom context name otherContent =
499 case otherContent of
500 Error ->
501 return ()
503 Var Flex Nothing _ ->
504 merge context (Atom name)
506 Var Flex (Just super) _ ->
507 if atomMatchesSuper super name then
508 merge context (Atom name)
510 else
511 mismatch context (Just ((Error.flipReason (badSuper super))))
513 Var Rigid _ maybeName ->
514 mismatch context (Just (Error.flipReason (badRigid maybeName)))
516 Atom otherName ->
517 if name == otherName then
518 merge context otherContent
520 else
521 mismatch context $
522 if isIntFloat name otherName || isIntFloat otherName name then
523 Just Error.IntFloat
524 else
525 Nothing
527 Alias _ _ realVar ->
528 subUnify context (_first context) realVar
530 Structure _ ->
531 mismatch context Nothing
534isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
535isIntFloat name otherName =
536 Var.isPrim "Int" name && Var.isPrim "Float" otherName
540-- UNIFY ALIASES
543unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()
544unifyAlias context name args realVar otherContent =
545 case otherContent of
546 Error ->
547 return ()
549 Var Flex Nothing _ ->
550 merge context (Alias name args realVar)
552 Var _ _ _ ->
553 subUnify context realVar (_second context)
555 Atom _ ->
556 subUnify context realVar (_second context)
558 Alias otherName otherArgs otherRealVar ->
559 if name == otherName then
560 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
561 merge context otherContent
563 else
564 subUnify context realVar otherRealVar
566 Structure _ ->
567 subUnify context realVar (_second context)
571-- UNIFY STRUCTURES
574unifyStructure :: Context -> Term1 Variable -> Content -> Content -> Unify ()
575unifyStructure context term content otherContent =
576 case otherContent of
577 Error ->
578 return ()
580 Var Flex Nothing _ ->
581 merge context content
583 Var Flex (Just super) _ ->
584 unifyFlexSuperStructure (reorient context) super term
586 Var Rigid _ maybeName ->
587 mismatch context (Just (Error.flipReason (badRigid maybeName)))
589 Atom _ ->
590 mismatch context Nothing
592 Alias _ _ realVar ->
593 subUnify context (_first context) realVar
595 Structure otherTerm ->
596 case (term, otherTerm) of
597 (App1 func arg, App1 otherFunc otherArg) ->
598 do subUnify context func otherFunc
599 subUnify context arg otherArg
600 merge context otherContent
602 (Fun1 arg result, Fun1 otherArg otherResult) ->
603 do subUnify context arg otherArg
604 subUnify context result otherResult
605 merge context otherContent
607 (EmptyRecord1, EmptyRecord1) ->
608 merge context otherContent
610 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
611 subUnify context ext (_second context)
613 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
614 subUnify context (_first context) ext
616 (Record1 fields extension, Record1 otherFields otherExtension) ->
617 do firstStructure <- liftIO $ gatherFields context fields extension
618 secondStructure <- liftIO $ gatherFields context otherFields otherExtension
619 unifyRecord context firstStructure secondStructure
621 _ ->
622 mismatch context Nothing
626-- UNIFY RECORDS
629unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
630unifyRecord context firstStructure secondStructure =
631 do let (RecordStructure expFields expVar expStruct) = firstStructure
632 let (RecordStructure actFields actVar actStruct) = secondStructure
634 let sharedFields = Map.intersectionWith (,) expFields actFields
636 -- call after unifying extension, make sure record shape matches before
637 -- looking into whether the particular field types match.
638 let unifySharedFields otherFields ext =
639 do unifySharedFieldsHelp context sharedFields
640 let allFields = Map.union (Map.map fst sharedFields) otherFields
641 merge context (Structure (Record1 allFields ext))
643 let uniqueExpFields = Map.difference expFields actFields
644 let uniqueActFields = Map.difference actFields expFields
646 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
647 (_, True, _, True) ->
648 do subUnify context expVar actVar
649 unifySharedFields Map.empty expVar
651 (Empty, _, _, False) ->
652 mismatch context $ Just $
653 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
655 (_, False, Empty, _) ->
656 mismatch context $ Just $
657 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
659 (_, False, _, True) ->
660 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
661 subUnify context subRecord actVar
662 unifySharedFields Map.empty subRecord
664 (_, True, _, False) ->
665 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
666 subUnify context expVar subRecord
667 unifySharedFields Map.empty subRecord
669 (Extension, False, Extension, False) ->
670 do let subFields = Map.union uniqueExpFields uniqueActFields
671 subExt <- fresh context (Var Flex Nothing Nothing)
672 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
673 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
674 subUnify context expVar expRecord
675 subUnify context actRecord actVar
676 unifySharedFields subFields subExt
680unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()
681unifySharedFieldsHelp context sharedFields =
682 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
683 case Maybe.catMaybes maybeBadFields of
684 [] ->
685 return ()
687 badFields ->
688 mismatch context (Just (Error.BadFields (reverse badFields)))
691unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))
692unifyField context (field, (expected, actual)) =
693 do result <- lift $ runExceptT $ subUnify context expected actual
694 case result of
695 Right () ->
696 return $ Nothing
698 Left (Mismatch maybeReason) ->
699 return $ Just (field, maybeReason)
703-- GATHER RECORD STRUCTURE
706data RecordStructure = RecordStructure
707 { _fields :: Map.Map Text Variable
708 , _extVar :: Variable
709 , _extStruct :: ExtensionStructure
710 }
713data ExtensionStructure
714 = Empty
715 | Extension
718gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure
719gatherFields context fields variable =
720 do desc <- UF.descriptor variable
721 case _content desc of
722 Structure (Record1 subFields subExt) ->
723 gatherFields context (Map.union fields subFields) subExt
725 Structure EmptyRecord1 ->
726 return (RecordStructure fields variable Empty)
728 Alias _ _ var ->
729 -- TODO may be dropping useful alias info here
730 gatherFields context fields var
732 _ ->
733 return (RecordStructure fields variable Extension)