git.iko.soy/elk
on 22bbeae help sign in
elk/src/Type/Unify.hs
689 lines 19 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.UnionFind.IO as UF
9import qualified AST.Variable as Var
10import qualified Reporting.Region as R
11import qualified Reporting.Error.Type as Error
12import qualified Type.State as TS
13import Type.Type as Type
17-- KICK OFF UNIFICATION
20unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
21unify hint region expected actual =
22 do result <- runExceptT (guardedUnify ExpectedActual expected actual)
23 case result of
24 Right () ->
25 return ()
27 Left (Mismatch maybeReason) ->
28 let
29 mkError =
30 do expectedSrcType <- Type.toSrcType expected
31 actualSrcType <- Type.toSrcType actual
32 mergeHelp expected actual Error
33 let info = Error.MismatchInfo hint expectedSrcType actualSrcType maybeReason
34 return (Error.Mismatch info)
35 in
36 TS.addError region =<< liftIO mkError
40-- UNIFICATION HELPERS
43type Unify =
44 ExceptT Mismatch TS.Solver
47data Context = Context
48 { _orientation :: Orientation
49 , _first :: Variable
50 , _firstDesc :: Descriptor
51 , _second :: Variable
52 , _secondDesc :: Descriptor
53 }
56data Orientation = ExpectedActual | ActualExpected
59reorient :: Context -> Context
60reorient (Context orientation var1 desc1 var2 desc2) =
61 let
62 otherOrientation =
63 case orientation of
64 ExpectedActual -> ActualExpected
65 ActualExpected -> ExpectedActual
66 in
67 Context otherOrientation var2 desc2 var1 desc1
71-- ERROR MESSAGES
74newtype Mismatch =
75 Mismatch (Maybe Error.Reason)
78mismatch :: Context -> Maybe Error.Reason -> Unify a
79mismatch (Context orientation var1 _ var2 _) maybeReason =
80 do numArgs1 <- liftIO $ countArgs var1
81 numArgs2 <- liftIO $ countArgs var2
82 mismatchHelp orientation $
83 if numArgs1 == numArgs2 then
84 maybeReason
85 else
86 Just (Error.MissingArgs (abs (numArgs2 - numArgs1)))
89mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
90mismatchHelp orientation maybeReason =
91 throwError $ Mismatch $
92 case orientation of
93 ExpectedActual ->
94 maybeReason
96 ActualExpected ->
97 Error.flipReason <$> maybeReason
100badRigid :: Maybe String -> Error.Reason
101badRigid maybeName =
102 Error.BadVar (Just (Error.Rigid maybeName)) Nothing
105badSuper :: Super -> Error.Reason
106badSuper super =
107 Error.BadVar (Just (errorSuper super)) Nothing
110doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
111doubleBad vt1 vt2 =
112 Error.BadVar (Just vt1) (Just vt2)
115errorSuper :: Super -> Error.VarType
116errorSuper super =
117 case super of
118 Number ->
119 Error.Number
121 Comparable ->
122 Error.Comparable
124 Appendable ->
125 Error.Appendable
127 CompAppend ->
128 Error.CompAppend
132-- MERGE
135merge :: Context -> Content -> Unify ()
136merge (Context _ first _ second _) content =
137 liftIO $ mergeHelp first second content
140mergeHelp :: Variable -> Variable -> Content -> IO ()
141mergeHelp first second content =
142 UF.union' first second $ \desc1 desc2 ->
143 return $
144 Descriptor
145 { _content = content
146 , _rank = min (_rank desc1) (_rank desc2)
147 , _mark = noMark
148 , _copy = Nothing
149 }
152fresh :: Context -> Content -> Unify Variable
153fresh (Context _ _ desc1 _ desc2) content =
154 do freshVariable <-
155 liftIO $ UF.fresh $
156 Descriptor
157 { _content = content
158 , _rank = min (_rank desc1) (_rank desc2)
159 , _mark = noMark
160 , _copy = Nothing
161 }
162 lift (TS.register freshVariable)
166-- ACTUALLY UNIFY THINGS
169guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
170guardedUnify orientation left right =
171 do equivalent <- liftIO $ UF.equivalent left right
172 if equivalent
173 then return ()
174 else
175 do leftDesc <- liftIO $ UF.descriptor left
176 rightDesc <- liftIO $ UF.descriptor right
177 actuallyUnify (Context orientation left leftDesc right rightDesc)
180subUnify :: Context -> Variable -> Variable -> Unify ()
181subUnify context var1 var2 =
182 guardedUnify (_orientation context) var1 var2
185actuallyUnify :: Context -> Unify ()
186actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
187 let
188 secondContent = _content secondDesc
189 in
190 case _content firstDesc of
191 Error ->
192 -- If there was an error, just pretend it is okay. This lets us avoid
193 -- "cascading" errors where one problem manifests as multiple message.
194 return ()
196 Var Flex Nothing _ ->
197 unifyFlex context secondContent
199 Var Flex (Just super) _ ->
200 unifySuper context super secondContent
202 Var Rigid maybeSuper maybeName ->
203 unifyRigid context maybeSuper maybeName secondContent
205 Atom name ->
206 unifyAtom context name secondContent
208 Alias name args realVar ->
209 unifyAlias context name args realVar secondContent
211 Structure term ->
212 unifyStructure context term secondContent
216-- UNIFY FLEXIBLE VARIABLES
219unifyFlex :: Context -> Content -> Unify ()
220unifyFlex context otherContent =
221 case otherContent of
222 Error ->
223 return ()
225 Var Flex _ _ ->
226 merge context otherContent
228 Var Rigid _ _ ->
229 merge context otherContent
231 Atom _ ->
232 merge context otherContent
234 Alias _ _ _ ->
235 merge context otherContent
237 Structure _ ->
238 merge context otherContent
242-- UNIFY RIGID VARIABLES
245unifyRigid :: Context -> Maybe Super -> Maybe String -> Content -> Unify ()
246unifyRigid context maybeSuper maybeName otherContent =
247 case otherContent of
248 Error ->
249 return ()
251 Var Flex otherMaybeSuper _ ->
252 case (maybeSuper, otherMaybeSuper) of
253 (_, Nothing) ->
254 merge context (Var Rigid maybeSuper maybeName)
256 (Nothing, Just _) ->
257 mismatch context (Just (badRigid maybeName))
259 (Just super, Just otherSuper) ->
260 case combineSupers super otherSuper of
261 Right newSuper | newSuper == otherSuper ->
262 merge context otherContent
264 _ ->
265 mismatch context (Just (badRigid maybeName))
267 Var Rigid _ otherMaybeName ->
268 mismatch context $ Just $
269 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
271 Atom _ ->
272 mismatch context (Just (badRigid maybeName))
274 Alias _ _ _ ->
275 mismatch context (Just (badRigid maybeName))
277 Structure _ ->
278 mismatch context (Just (badRigid maybeName))
282-- UNIFY SUPER VARIABLES
285unifySuper :: Context -> Super -> Content -> Unify ()
286unifySuper context super otherContent =
287 case otherContent of
288 Structure term ->
289 unifySuperStructure context super term
291 Atom name ->
292 if atomMatchesSuper super name then
293 merge context otherContent
294 else
295 mismatch context (Just (badSuper super))
297 Var Rigid Nothing maybeName ->
298 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
300 Var Rigid (Just otherSuper) maybeName ->
301 case combineSupers super otherSuper of
302 Right newSuper | newSuper == super ->
303 merge context otherContent
305 _ ->
306 mismatch context $ Just $
307 doubleBad (errorSuper super) (Error.Rigid maybeName)
309 Var Flex Nothing _ ->
310 merge context (Var Flex (Just super) Nothing)
312 Var Flex (Just otherSuper) _ ->
313 case combineSupers super otherSuper of
314 Left reason ->
315 mismatch context (Just reason)
317 Right newSuper ->
318 merge context (Var Flex (Just newSuper) Nothing)
320 Alias _ _ realVar ->
321 subUnify context (_first context) realVar
323 Error ->
324 return ()
327combineSupers :: Super -> Super -> Either Error.Reason Super
328combineSupers firstSuper secondSuper =
329 case (firstSuper, secondSuper) of
330 (Number , Number ) -> Right Number
331 (Comparable, Number ) -> Right Number
332 (Number , Comparable) -> Right Number
334 (Comparable, Comparable) -> Right Comparable
335 (Appendable, Appendable) -> Right Appendable
337 (Appendable, Comparable) -> Right CompAppend
338 (Comparable, Appendable) -> Right CompAppend
340 (CompAppend, CompAppend) -> Right CompAppend
341 (CompAppend, Comparable) -> Right CompAppend
342 (Comparable, CompAppend) -> Right CompAppend
343 (CompAppend, Appendable) -> Right CompAppend
344 (Appendable, CompAppend) -> Right CompAppend
346 (_ , _ ) ->
347 Left $ doubleBad (errorSuper firstSuper) (errorSuper secondSuper)
350isPrimitiveFrom :: [String] -> Var.Canonical -> Bool
351isPrimitiveFrom prims var =
352 any (\p -> Var.isPrim p var) prims
355atomMatchesSuper :: Super -> Var.Canonical -> Bool
356atomMatchesSuper super name =
357 case super of
358 Number ->
359 isPrimitiveFrom ["Int", "Float"] name
361 Comparable ->
362 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
364 Appendable ->
365 Var.isPrim "String" name
367 CompAppend ->
368 Var.isPrim "String" name
371unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()
372unifySuperStructure context super term =
373 do appStructure <- liftIO (collectApps (Structure term))
374 case appStructure of
375 Other ->
376 mismatch context (Just (badSuper super))
378 List variable ->
379 case super of
380 Number ->
381 mismatch context (Just (badSuper super))
383 Appendable ->
384 merge context (Structure term)
386 Comparable ->
387 do merge context (Structure term)
388 unifyComparableRecursive (_orientation context) variable
390 CompAppend ->
391 do merge context (Structure term)
392 unifyComparableRecursive (_orientation context) variable
394 Tuple entries ->
395 case super of
396 Number ->
397 mismatch context (Just (badSuper super))
399 Appendable ->
400 mismatch context (Just (badSuper super))
402 Comparable ->
403 if length entries > 6 then
404 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
406 else
407 do merge context (Structure term)
408 mapM_ (unifyComparableRecursive (_orientation context)) entries
410 CompAppend ->
411 mismatch context (Just (badSuper super))
414unifyComparableRecursive :: Orientation -> Variable -> Unify ()
415unifyComparableRecursive orientation var =
416 do compVar <-
417 liftIO $
418 do desc <- UF.descriptor var
419 UF.fresh $
420 Descriptor
421 { _content = Var Flex (Just Comparable) Nothing
422 , _rank = _rank desc
423 , _mark = noMark
424 , _copy = Nothing
425 }
427 guardedUnify orientation compVar var
430data AppStructure
431 = List Variable
432 | Tuple [Variable]
433 | Other
436collectApps :: Content -> IO AppStructure
437collectApps content =
438 collectAppsHelp [] content
441collectAppsHelp :: [Variable] -> Content -> IO AppStructure
442collectAppsHelp args content =
443 case (content, args) of
444 (Structure (App1 func arg), _) ->
445 collectAppsHelp (args ++ [arg]) =<< getContent func
447 (Atom name, [arg]) | Var.isList name ->
448 return (List arg)
450 (Atom name, _) | Var.isTuple name ->
451 return (Tuple args)
453 _ ->
454 return Other
457countArgs :: Variable -> IO Int
458countArgs variable =
459 do content <- getContent variable
460 case content of
461 Structure (Fun1 _ returnType) ->
462 (+1) <$> countArgs returnType
464 _ ->
465 return 0
468getContent :: Variable -> IO Content
469getContent variable =
470 _content <$> UF.descriptor variable
474-- UNIFY ATOMS
477unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
478unifyAtom context name otherContent =
479 case otherContent of
480 Error ->
481 return ()
483 Var Flex Nothing _ ->
484 merge context (Atom name)
486 Var Flex (Just super) _ ->
487 if atomMatchesSuper super name then
488 merge context (Atom name)
490 else
491 mismatch context (Just ((Error.flipReason (badSuper super))))
493 Var Rigid _ maybeName ->
494 mismatch context (Just (Error.flipReason (badRigid maybeName)))
496 Atom otherName ->
497 if name == otherName then
498 merge context otherContent
500 else
501 mismatch context $
502 if isIntFloat name otherName || isIntFloat otherName name then
503 Just Error.IntFloat
504 else
505 Nothing
507 Alias _ _ realVar ->
508 subUnify context (_first context) realVar
510 Structure _ ->
511 mismatch context Nothing
514isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
515isIntFloat name otherName =
516 Var.isPrim "Int" name && Var.isPrim "Float" otherName
520-- UNIFY ALIASES
523unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
524unifyAlias context name args realVar otherContent =
525 case otherContent of
526 Error ->
527 return ()
529 Var Flex Nothing _ ->
530 merge context (Alias name args realVar)
532 Var _ _ _ ->
533 subUnify context realVar (_second context)
535 Atom _ ->
536 subUnify context realVar (_second context)
539 Alias otherName otherArgs otherRealVar ->
540 if name == otherName then
541 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
542 merge context otherContent
544 else
545 subUnify context realVar otherRealVar
547 Structure _ ->
548 subUnify context realVar (_second context)
552-- UNIFY STRUCTURES
555unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
556unifyStructure context term otherContent =
557 case otherContent of
558 Error ->
559 return ()
561 Var Flex Nothing _ ->
562 merge context (Structure term)
564 Var Flex (Just super) _ ->
565 unifySuper (reorient context) super (Structure term)
567 Var Rigid _ maybeName ->
568 mismatch context (Just (Error.flipReason (badRigid maybeName)))
570 Atom _ ->
571 mismatch context Nothing
573 Alias _ _ realVar ->
574 subUnify context (_first context) realVar
576 Structure otherTerm ->
577 case (term, otherTerm) of
578 (App1 func arg, App1 otherFunc otherArg) ->
579 do subUnify context func otherFunc
580 subUnify context arg otherArg
581 merge context otherContent
583 (Fun1 arg result, Fun1 otherArg otherResult) ->
584 do subUnify context arg otherArg
585 subUnify context result otherResult
586 merge context otherContent
588 (EmptyRecord1, EmptyRecord1) ->
589 merge context otherContent
591 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
592 subUnify context ext (_second context)
594 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
595 subUnify context (_first context) ext
597 (Record1 fields extension, Record1 otherFields otherExtension) ->
598 do firstStructure <- gatherFields context fields extension
599 secondStructure <- gatherFields context otherFields otherExtension
600 unifyRecord context firstStructure secondStructure
602 _ ->
603 mismatch context Nothing
607-- UNIFY RECORDS
610unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
611unifyRecord context firstStructure secondStructure =
612 do let (RecordStructure expFields expVar expStruct) = firstStructure
613 let (RecordStructure actFields actVar actStruct) = secondStructure
615 -- call after unifying extension, make sure record shape matches before
616 -- looking into whether the particular field types match.
617 let unifySharedFields otherFields ext =
618 do let sharedFields = Map.intersectionWith (,) expFields actFields
619 _ <- traverse (uncurry (subUnify context)) sharedFields
620 let allFields = Map.union (Map.map fst sharedFields) otherFields
621 merge context (Structure (Record1 allFields ext))
623 let uniqueExpFields = Map.difference expFields actFields
624 let uniqueActFields = Map.difference actFields expFields
626 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
627 (_, True, _, True) ->
628 do subUnify context expVar actVar
629 unifySharedFields Map.empty expVar
631 (Empty, _, _, False) ->
632 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
634 (_, False, Empty, _) ->
635 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
637 (_, False, _, True) ->
638 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
639 subUnify context subRecord actVar
640 unifySharedFields Map.empty subRecord
642 (_, True, _, False) ->
643 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
644 subUnify context expVar subRecord
645 unifySharedFields Map.empty subRecord
647 (Extension, False, Extension, False) ->
648 do let subFields = Map.union uniqueExpFields uniqueActFields
649 subExt <- fresh context (Var Flex Nothing Nothing)
650 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
651 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
652 subUnify context expVar expRecord
653 subUnify context actRecord actVar
654 unifySharedFields subFields subExt
658-- GATHER RECORD STRUCTURE
661data RecordStructure = RecordStructure
662 { _fields :: Map.Map String Variable
663 , _extVar :: Variable
664 , _extStruct :: ExtensionStructure
665 }
668data ExtensionStructure
669 = Empty
670 | Extension
673gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
674gatherFields context fields variable =
675 do desc <- liftIO (UF.descriptor variable)
676 case _content desc of
677 Structure (Record1 subFields subExt) ->
678 gatherFields context (Map.union fields subFields) subExt
680 Structure EmptyRecord1 ->
681 return (RecordStructure fields variable Empty)
683 Alias _ _ var ->
684 -- TODO may be dropping useful alias info here
685 gatherFields context fields var
687 _ ->
688 return (RecordStructure fields variable Extension)