git.iko.soy/elk
on 267f708 help sign in
elk/src/Type/Unify.hs
713 lines 20 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Unify (unify) where
4import Control.Monad (zipWithM_)
5import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import qualified Data.UnionFind.IO as UF
10import qualified AST.Variable as Var
11import qualified Reporting.Region as R
12import qualified Reporting.Error.Type as Error
13import qualified Type.State as TS
14import Type.Type as Type
18-- KICK OFF UNIFICATION
21unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
22unify hint region expected actual =
23 do result <- runExceptT (guardedUnify ExpectedActual expected actual)
24 case result of
25 Right () ->
26 return ()
28 Left (Mismatch maybeReason) ->
29 let
30 mkError =
31 do expectedSrcType <- Type.toSrcType expected
32 actualSrcType <- Type.toSrcType actual
33 mergeHelp expected actual Error
34 let info = Error.MismatchInfo hint expectedSrcType actualSrcType maybeReason
35 return (Error.Mismatch info)
36 in
37 TS.addError region =<< liftIO mkError
41-- UNIFICATION HELPERS
44type Unify =
45 ExceptT Mismatch TS.Solver
48data Context = Context
49 { _orientation :: Orientation
50 , _first :: Variable
51 , _firstDesc :: Descriptor
52 , _second :: Variable
53 , _secondDesc :: Descriptor
54 }
57data Orientation = ExpectedActual | ActualExpected
60reorient :: Context -> Context
61reorient (Context orientation var1 desc1 var2 desc2) =
62 let
63 otherOrientation =
64 case orientation of
65 ExpectedActual -> ActualExpected
66 ActualExpected -> ExpectedActual
67 in
68 Context otherOrientation var2 desc2 var1 desc1
72-- ERROR MESSAGES
75newtype Mismatch =
76 Mismatch (Maybe Error.Reason)
79mismatch :: Context -> Maybe Error.Reason -> Unify a
80mismatch (Context orientation var1 _ var2 _) maybeReason =
81 do numArgs1 <- liftIO $ countArgs var1
82 numArgs2 <- liftIO $ countArgs var2
83 mismatchHelp orientation $
84 if numArgs1 == numArgs2 then
85 maybeReason
86 else
87 Just (Error.MissingArgs (abs (numArgs2 - numArgs1)))
90mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
91mismatchHelp orientation maybeReason =
92 throwError $ Mismatch $
93 case orientation of
94 ExpectedActual ->
95 maybeReason
97 ActualExpected ->
98 Error.flipReason <$> maybeReason
101badRigid :: Maybe String -> Error.Reason
102badRigid maybeName =
103 Error.BadVar (Just (Error.Rigid maybeName)) Nothing
106badSuper :: Super -> Error.Reason
107badSuper super =
108 Error.BadVar (Just (errorSuper super)) Nothing
111doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
112doubleBad vt1 vt2 =
113 Error.BadVar (Just vt1) (Just vt2)
116errorSuper :: Super -> Error.VarType
117errorSuper super =
118 case super of
119 Number ->
120 Error.Number
122 Comparable ->
123 Error.Comparable
125 Appendable ->
126 Error.Appendable
128 CompAppend ->
129 Error.CompAppend
133-- MERGE
136merge :: Context -> Content -> Unify ()
137merge (Context _ first _ second _) content =
138 liftIO $ mergeHelp first second content
141mergeHelp :: Variable -> Variable -> Content -> IO ()
142mergeHelp first second content =
143 UF.union' first second $ \desc1 desc2 ->
144 return $
145 Descriptor
146 { _content = content
147 , _rank = min (_rank desc1) (_rank desc2)
148 , _mark = noMark
149 , _copy = Nothing
150 }
153fresh :: Context -> Content -> Unify Variable
154fresh (Context _ _ desc1 _ desc2) content =
155 do freshVariable <-
156 liftIO $ UF.fresh $
157 Descriptor
158 { _content = content
159 , _rank = min (_rank desc1) (_rank desc2)
160 , _mark = noMark
161 , _copy = Nothing
162 }
163 lift (TS.register freshVariable)
167-- ACTUALLY UNIFY THINGS
170guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
171guardedUnify orientation left right =
172 do equivalent <- liftIO $ UF.equivalent left right
173 if equivalent
174 then return ()
175 else
176 do leftDesc <- liftIO $ UF.descriptor left
177 rightDesc <- liftIO $ UF.descriptor right
178 actuallyUnify (Context orientation left leftDesc right rightDesc)
181subUnify :: Context -> Variable -> Variable -> Unify ()
182subUnify context var1 var2 =
183 guardedUnify (_orientation context) var1 var2
186actuallyUnify :: Context -> Unify ()
187actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
188 let
189 secondContent = _content secondDesc
190 in
191 case _content firstDesc of
192 Error ->
193 -- If there was an error, just pretend it is okay. This lets us avoid
194 -- "cascading" errors where one problem manifests as multiple message.
195 return ()
197 Var Flex Nothing _ ->
198 unifyFlex context secondContent
200 Var Flex (Just super) _ ->
201 unifySuper context super secondContent
203 Var Rigid maybeSuper maybeName ->
204 unifyRigid context maybeSuper maybeName secondContent
206 Atom name ->
207 unifyAtom context name secondContent
209 Alias name args realVar ->
210 unifyAlias context name args realVar secondContent
212 Structure term ->
213 unifyStructure context term secondContent
217-- UNIFY FLEXIBLE VARIABLES
220unifyFlex :: Context -> Content -> Unify ()
221unifyFlex context otherContent =
222 case otherContent of
223 Error ->
224 return ()
226 Var Flex _ _ ->
227 merge context otherContent
229 Var Rigid _ _ ->
230 merge context otherContent
232 Atom _ ->
233 merge context otherContent
235 Alias _ _ _ ->
236 merge context otherContent
238 Structure _ ->
239 merge context otherContent
243-- UNIFY RIGID VARIABLES
246unifyRigid :: Context -> Maybe Super -> Maybe String -> Content -> Unify ()
247unifyRigid context maybeSuper maybeName otherContent =
248 case otherContent of
249 Error ->
250 return ()
252 Var Flex otherMaybeSuper _ ->
253 case (maybeSuper, otherMaybeSuper) of
254 (_, Nothing) ->
255 merge context (Var Rigid maybeSuper maybeName)
257 (Nothing, Just _) ->
258 mismatch context (Just (badRigid maybeName))
260 (Just super, Just otherSuper) ->
261 case combineSupers super otherSuper of
262 Right newSuper | newSuper == otherSuper ->
263 merge context otherContent
265 _ ->
266 mismatch context (Just (badRigid maybeName))
268 Var Rigid _ otherMaybeName ->
269 mismatch context $ Just $
270 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
272 Atom _ ->
273 mismatch context (Just (badRigid maybeName))
275 Alias _ _ _ ->
276 mismatch context (Just (badRigid maybeName))
278 Structure _ ->
279 mismatch context (Just (badRigid maybeName))
283-- UNIFY SUPER VARIABLES
286unifySuper :: Context -> Super -> Content -> Unify ()
287unifySuper context super otherContent =
288 case otherContent of
289 Structure term ->
290 unifySuperStructure context super term
292 Atom name ->
293 if atomMatchesSuper super name then
294 merge context otherContent
295 else
296 mismatch context (Just (badSuper super))
298 Var Rigid Nothing maybeName ->
299 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
301 Var Rigid (Just otherSuper) maybeName ->
302 case combineSupers super otherSuper of
303 Right newSuper | newSuper == super ->
304 merge context otherContent
306 _ ->
307 mismatch context $ Just $
308 doubleBad (errorSuper super) (Error.Rigid maybeName)
310 Var Flex Nothing _ ->
311 merge context (Var Flex (Just super) Nothing)
313 Var Flex (Just otherSuper) _ ->
314 case combineSupers super otherSuper of
315 Left reason ->
316 mismatch context (Just reason)
318 Right newSuper ->
319 merge context (Var Flex (Just newSuper) Nothing)
321 Alias _ _ realVar ->
322 subUnify context (_first context) realVar
324 Error ->
325 return ()
328combineSupers :: Super -> Super -> Either Error.Reason Super
329combineSupers firstSuper secondSuper =
330 case (firstSuper, secondSuper) of
331 (Number , Number ) -> Right Number
332 (Comparable, Number ) -> Right Number
333 (Number , Comparable) -> Right Number
335 (Comparable, Comparable) -> Right Comparable
336 (Appendable, Appendable) -> Right Appendable
338 (Appendable, Comparable) -> Right CompAppend
339 (Comparable, Appendable) -> Right CompAppend
341 (CompAppend, CompAppend) -> Right CompAppend
342 (CompAppend, Comparable) -> Right CompAppend
343 (Comparable, CompAppend) -> Right CompAppend
344 (CompAppend, Appendable) -> Right CompAppend
345 (Appendable, CompAppend) -> Right CompAppend
347 (_ , _ ) ->
348 Left $ doubleBad (errorSuper firstSuper) (errorSuper secondSuper)
351isPrimitiveFrom :: [String] -> Var.Canonical -> Bool
352isPrimitiveFrom prims var =
353 any (\p -> Var.isPrim p var) prims
356atomMatchesSuper :: Super -> Var.Canonical -> Bool
357atomMatchesSuper super name =
358 case super of
359 Number ->
360 isPrimitiveFrom ["Int", "Float"] name
362 Comparable ->
363 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
365 Appendable ->
366 Var.isPrim "String" name
368 CompAppend ->
369 Var.isPrim "String" name
372unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()
373unifySuperStructure context super term =
374 do appStructure <- liftIO (collectApps (Structure term))
375 case appStructure of
376 Other ->
377 mismatch context (Just (badSuper super))
379 List variable ->
380 case super of
381 Number ->
382 mismatch context (Just (badSuper super))
384 Appendable ->
385 merge context (Structure term)
387 Comparable ->
388 do merge context (Structure term)
389 unifyComparableRecursive (_orientation context) variable
391 CompAppend ->
392 do merge context (Structure term)
393 unifyComparableRecursive (_orientation context) variable
395 Tuple entries ->
396 case super of
397 Number ->
398 mismatch context (Just (badSuper super))
400 Appendable ->
401 mismatch context (Just (badSuper super))
403 Comparable ->
404 if length entries > 6 then
405 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
407 else
408 do merge context (Structure term)
409 mapM_ (unifyComparableRecursive (_orientation context)) entries
411 CompAppend ->
412 mismatch context (Just (badSuper super))
415unifyComparableRecursive :: Orientation -> Variable -> Unify ()
416unifyComparableRecursive orientation var =
417 do compVar <-
418 liftIO $
419 do desc <- UF.descriptor var
420 UF.fresh $
421 Descriptor
422 { _content = Var Flex (Just Comparable) Nothing
423 , _rank = _rank desc
424 , _mark = noMark
425 , _copy = Nothing
426 }
428 guardedUnify orientation compVar var
431data AppStructure
432 = List Variable
433 | Tuple [Variable]
434 | Other
437collectApps :: Content -> IO AppStructure
438collectApps content =
439 collectAppsHelp [] content
442collectAppsHelp :: [Variable] -> Content -> IO AppStructure
443collectAppsHelp args content =
444 case (content, args) of
445 (Structure (App1 func arg), _) ->
446 collectAppsHelp (args ++ [arg]) =<< getContent func
448 (Atom name, [arg]) | Var.isList name ->
449 return (List arg)
451 (Atom name, _) | Var.isTuple name ->
452 return (Tuple args)
454 _ ->
455 return Other
458countArgs :: Variable -> IO Int
459countArgs variable =
460 do content <- getContent variable
461 case content of
462 Structure (Fun1 _ returnType) ->
463 (+1) <$> countArgs returnType
465 _ ->
466 return 0
469getContent :: Variable -> IO Content
470getContent variable =
471 _content <$> UF.descriptor variable
475-- UNIFY ATOMS
478unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
479unifyAtom context name otherContent =
480 case otherContent of
481 Error ->
482 return ()
484 Var Flex Nothing _ ->
485 merge context (Atom name)
487 Var Flex (Just super) _ ->
488 if atomMatchesSuper super name then
489 merge context (Atom name)
491 else
492 mismatch context (Just ((Error.flipReason (badSuper super))))
494 Var Rigid _ maybeName ->
495 mismatch context (Just (Error.flipReason (badRigid maybeName)))
497 Atom otherName ->
498 if name == otherName then
499 merge context otherContent
501 else
502 mismatch context $
503 if isIntFloat name otherName || isIntFloat otherName name then
504 Just Error.IntFloat
505 else
506 Nothing
508 Alias _ _ realVar ->
509 subUnify context (_first context) realVar
511 Structure _ ->
512 mismatch context Nothing
515isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
516isIntFloat name otherName =
517 Var.isPrim "Int" name && Var.isPrim "Float" otherName
521-- UNIFY ALIASES
524unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
525unifyAlias context name args realVar otherContent =
526 case otherContent of
527 Error ->
528 return ()
530 Var Flex Nothing _ ->
531 merge context (Alias name args realVar)
533 Var _ _ _ ->
534 subUnify context realVar (_second context)
536 Atom _ ->
537 subUnify context realVar (_second context)
540 Alias otherName otherArgs otherRealVar ->
541 if name == otherName then
542 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
543 merge context otherContent
545 else
546 subUnify context realVar otherRealVar
548 Structure _ ->
549 subUnify context realVar (_second context)
553-- UNIFY STRUCTURES
556unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
557unifyStructure context term otherContent =
558 case otherContent of
559 Error ->
560 return ()
562 Var Flex Nothing _ ->
563 merge context (Structure term)
565 Var Flex (Just super) _ ->
566 unifySuper (reorient context) super (Structure term)
568 Var Rigid _ maybeName ->
569 mismatch context (Just (Error.flipReason (badRigid maybeName)))
571 Atom _ ->
572 mismatch context Nothing
574 Alias _ _ realVar ->
575 subUnify context (_first context) realVar
577 Structure otherTerm ->
578 case (term, otherTerm) of
579 (App1 func arg, App1 otherFunc otherArg) ->
580 do subUnify context func otherFunc
581 subUnify context arg otherArg
582 merge context otherContent
584 (Fun1 arg result, Fun1 otherArg otherResult) ->
585 do subUnify context arg otherArg
586 subUnify context result otherResult
587 merge context otherContent
589 (EmptyRecord1, EmptyRecord1) ->
590 merge context otherContent
592 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
593 subUnify context ext (_second context)
595 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
596 subUnify context (_first context) ext
598 (Record1 fields extension, Record1 otherFields otherExtension) ->
599 do firstStructure <- gatherFields context fields extension
600 secondStructure <- gatherFields context otherFields otherExtension
601 unifyRecord context firstStructure secondStructure
603 _ ->
604 mismatch context Nothing
608-- UNIFY RECORDS
611unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
612unifyRecord context firstStructure secondStructure =
613 do let (RecordStructure expFields expVar expStruct) = firstStructure
614 let (RecordStructure actFields actVar actStruct) = secondStructure
616 -- call after unifying extension, make sure record shape matches before
617 -- looking into whether the particular field types match.
618 let unifySharedFields otherFields ext =
619 do let sharedFields = Map.intersectionWith (,) expFields actFields
620 unifySharedFieldsHelp context sharedFields
621 let allFields = Map.union (Map.map fst sharedFields) otherFields
622 merge context (Structure (Record1 allFields ext))
624 let uniqueExpFields = Map.difference expFields actFields
625 let uniqueActFields = Map.difference actFields expFields
627 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
628 (_, True, _, True) ->
629 do subUnify context expVar actVar
630 unifySharedFields Map.empty expVar
632 (Empty, _, _, False) ->
633 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
635 (_, False, Empty, _) ->
636 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
638 (_, False, _, True) ->
639 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
640 subUnify context subRecord actVar
641 unifySharedFields Map.empty subRecord
643 (_, True, _, False) ->
644 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
645 subUnify context expVar subRecord
646 unifySharedFields Map.empty subRecord
648 (Extension, False, Extension, False) ->
649 do let subFields = Map.union uniqueExpFields uniqueActFields
650 subExt <- fresh context (Var Flex Nothing Nothing)
651 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
652 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
653 subUnify context expVar expRecord
654 subUnify context actRecord actVar
655 unifySharedFields subFields subExt
659unifySharedFieldsHelp :: Context -> Map.Map String (Variable, Variable) -> Unify ()
660unifySharedFieldsHelp context sharedFields =
661 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
662 case Maybe.catMaybes maybeBadFields of
663 [] ->
664 return ()
666 badFields ->
667 mismatch context (Just (Error.BadFields (reverse badFields)))
670unifyField :: Context -> (String, (Variable, Variable)) -> Unify (Maybe (String, Maybe Error.Reason))
671unifyField context (field, (expected, actual)) =
672 do result <- lift $ runExceptT $ subUnify context expected actual
673 case result of
674 Right () ->
675 return $ Nothing
677 Left (Mismatch maybeReason) ->
678 return $ Just (field, maybeReason)
682-- GATHER RECORD STRUCTURE
685data RecordStructure = RecordStructure
686 { _fields :: Map.Map String Variable
687 , _extVar :: Variable
688 , _extStruct :: ExtensionStructure
689 }
692data ExtensionStructure
693 = Empty
694 | Extension
697gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
698gatherFields context fields variable =
699 do desc <- liftIO (UF.descriptor variable)
700 case _content desc of
701 Structure (Record1 subFields subExt) ->
702 gatherFields context (Map.union fields subFields) subExt
704 Structure EmptyRecord1 ->
705 return (RecordStructure fields variable Empty)
707 Alias _ _ var ->
708 -- TODO may be dropping useful alias info here
709 gatherFields context fields var
711 _ ->
712 return (RecordStructure fields variable Extension)