git.iko.soy/elk
on 60f4e71 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)
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 do result <- runExceptT (guardedUnify ExpectedActual expected actual)
26 case result of
27 Right () ->
28 return ()
30 Left (Mismatch maybeReason) ->
31 let
32 mkError =
33 do expectedSrcType <- Type.toSrcType expected
34 actualSrcType <- Type.toSrcType actual
35 mergeHelp expected actual Error
36 let info = Error.MismatchInfo hint expectedSrcType actualSrcType maybeReason
37 return (Error.Mismatch info)
38 in
39 TS.addError region =<< liftIO mkError
43-- UNIFICATION HELPERS
46type Unify =
47 ExceptT Mismatch TS.Solver
50data Context = Context
51 { _orientation :: Orientation
52 , _first :: Variable
53 , _firstDesc :: Descriptor
54 , _second :: Variable
55 , _secondDesc :: Descriptor
56 }
59data Orientation = ExpectedActual | ActualExpected
62reorient :: Context -> Context
63reorient (Context orientation var1 desc1 var2 desc2) =
64 let
65 otherOrientation =
66 case orientation of
67 ExpectedActual -> ActualExpected
68 ActualExpected -> ExpectedActual
69 in
70 Context otherOrientation var2 desc2 var1 desc1
74-- ERROR MESSAGES
77newtype Mismatch =
78 Mismatch (Maybe Error.Reason)
81mismatch :: Context -> Maybe Error.Reason -> Unify a
82mismatch context@(Context orientation var1 _ var2 _) maybeReason =
83 do args1 <- liftIO $ collectArgs var1
84 args2 <- liftIO $ collectArgs var2
86 let numArgs1 = length args1
87 let numArgs2 = length args2
89 if numArgs1 == numArgs2
90 then
91 mismatchHelp orientation maybeReason
92 else
93 do zipWithM_ (\arg1 arg2 -> lift $ runExceptT $ subUnify context arg1 arg2) args1 args2
94 mismatchHelp orientation $ Just $ Error.MissingArgs $ abs (numArgs2 - numArgs1)
97mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
98mismatchHelp orientation maybeReason =
99 throwError $ Mismatch $
100 case orientation of
101 ExpectedActual ->
102 maybeReason
104 ActualExpected ->
105 Error.flipReason <$> maybeReason
108badRigid :: Maybe Text -> Error.Reason
109badRigid maybeName =
110 Error.BadVar (Just (Error.Rigid maybeName)) Nothing
113badSuper :: Super -> Error.Reason
114badSuper super =
115 Error.BadVar (Just (errorSuper super)) Nothing
118badSupers :: Super -> Super -> Error.Reason
119badSupers super1 super2 =
120 Error.BadVar (Just (errorSuper super1)) (Just (errorSuper super2))
123doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
124doubleBad vt1 vt2 =
125 Error.BadVar (Just vt1) (Just vt2)
128errorSuper :: Super -> Error.VarType
129errorSuper super =
130 case super of
131 Number ->
132 Error.Number
134 Comparable ->
135 Error.Comparable
137 Appendable ->
138 Error.Appendable
140 CompAppend ->
141 Error.CompAppend
145-- MERGE
148merge :: Context -> Content -> Unify ()
149merge (Context _ first _ second _) content =
150 liftIO $ mergeHelp first second content
153mergeHelp :: Variable -> Variable -> Content -> IO ()
154mergeHelp first second content =
155 UF.union' first second $ \desc1 desc2 ->
156 return $
157 Descriptor
158 { _content = content
159 , _rank = min (_rank desc1) (_rank desc2)
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 -> Term1 Variable -> 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 -> Term1 Variable -> 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 unifyFlexSuper (reorient context) super otherContent content
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 <- gatherFields context fields extension
617 secondStructure <- 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 -> Unify RecordStructure
718gatherFields context fields variable =
719 do desc <- liftIO (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)