git.iko.soy/elk
on ba5bfd2 help sign in
elk/src/Type/Unify.hs
672 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.Set as Set
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 state ->
26 return state
28 Left (Mismatch _subExpected _subActual 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
75data Mismatch
76 = Mismatch Variable Variable (Maybe Error.Reason)
79mismatch :: Context -> Maybe Error.Reason -> Unify a
80mismatch (Context orientation first _ second _) maybeReason =
81 let
82 (expected, actual, orientedReason) =
83 case orientation of
84 ExpectedActual ->
85 (first, second, maybeReason)
87 ActualExpected ->
88 (second, first, Error.flipReason <$> maybeReason)
89 in
90 throwError (Mismatch expected actual orientedReason)
93badRigid :: Maybe String -> Error.Reason
94badRigid maybeName =
95 Error.BadVar (Just (Error.Rigid maybeName)) Nothing
98badSuper :: Super -> Error.Reason
99badSuper super =
100 Error.BadVar (Just (errorSuper super)) Nothing
103doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
104doubleBad vt1 vt2 =
105 Error.BadVar (Just vt1) (Just vt2)
108errorSuper :: Super -> Error.VarType
109errorSuper super =
110 case super of
111 Number ->
112 Error.Number
114 Comparable ->
115 Error.Comparable
117 Appendable ->
118 Error.Appendable
120 CompAppend ->
121 Error.CompAppend
125-- MERGE
128merge :: Context -> Content -> Unify ()
129merge (Context _ first _ second _) content =
130 liftIO $ mergeHelp first second content
133mergeHelp :: Variable -> Variable -> Content -> IO ()
134mergeHelp first second content =
135 UF.union' first second $ \desc1 desc2 ->
136 return $
137 Descriptor
138 { _content = content
139 , _rank = min (_rank desc1) (_rank desc2)
140 , _mark = noMark
141 , _copy = Nothing
142 }
145fresh :: Context -> Content -> Unify Variable
146fresh (Context _ _ desc1 _ desc2) content =
147 do freshVariable <-
148 liftIO $ UF.fresh $
149 Descriptor
150 { _content = content
151 , _rank = min (_rank desc1) (_rank desc2)
152 , _mark = noMark
153 , _copy = Nothing
154 }
155 lift (TS.register freshVariable)
159-- ACTUALLY UNIFY THINGS
162guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
163guardedUnify orientation left right =
164 do equivalent <- liftIO $ UF.equivalent left right
165 if equivalent
166 then return ()
167 else
168 do leftDesc <- liftIO $ UF.descriptor left
169 rightDesc <- liftIO $ UF.descriptor right
170 actuallyUnify (Context orientation left leftDesc right rightDesc)
173subUnify :: Context -> Variable -> Variable -> Unify ()
174subUnify context var1 var2 =
175 guardedUnify (_orientation context) var1 var2
178actuallyUnify :: Context -> Unify ()
179actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
180 let
181 secondContent = _content secondDesc
182 in
183 case _content firstDesc of
184 Error ->
185 -- If there was an error, just pretend it is okay. This lets us avoid
186 -- "cascading" errors where one problem manifests as multiple message.
187 return ()
189 Var Flex Nothing _ ->
190 unifyFlex context secondContent
192 Var Flex (Just super) _ ->
193 unifySuper context super secondContent
195 Var Rigid maybeSuper maybeName ->
196 unifyRigid context maybeSuper maybeName secondContent
198 Atom name ->
199 unifyAtom context name secondContent
201 Alias name args realVar ->
202 unifyAlias context name args realVar secondContent
204 Structure term ->
205 unifyStructure context term secondContent
209-- UNIFY FLEXIBLE VARIABLES
212unifyFlex :: Context -> Content -> Unify ()
213unifyFlex context otherContent =
214 case otherContent of
215 Error ->
216 return ()
218 Var Flex _ _ ->
219 merge context otherContent
221 Var Rigid _ _ ->
222 merge context otherContent
224 Atom _ ->
225 merge context otherContent
227 Alias _ _ _ ->
228 merge context otherContent
230 Structure _ ->
231 merge context otherContent
235-- UNIFY RIGID VARIABLES
238unifyRigid :: Context -> Maybe Super -> Maybe String -> Content -> Unify ()
239unifyRigid context maybeSuper maybeName otherContent =
240 case otherContent of
241 Error ->
242 return ()
244 Var Flex otherMaybeSuper _ ->
245 case (maybeSuper, otherMaybeSuper) of
246 (_, Nothing) ->
247 merge context (Var Rigid maybeSuper maybeName)
249 (Nothing, Just _) ->
250 mismatch context (Just (badRigid maybeName))
252 (Just super, Just otherSuper) ->
253 case combineSupers super otherSuper of
254 Right newSuper | newSuper == otherSuper ->
255 merge context otherContent
257 _ ->
258 mismatch context (Just (badRigid maybeName))
260 Var Rigid _ otherMaybeName ->
261 mismatch context $ Just $
262 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
264 Atom _ ->
265 mismatch context (Just (badRigid maybeName))
267 Alias _ _ _ ->
268 mismatch context (Just (badRigid maybeName))
270 Structure _ ->
271 mismatch context (Just (badRigid maybeName))
274-- UNIFY SUPER VARIABLES
277unifySuper :: Context -> Super -> Content -> Unify ()
278unifySuper context super otherContent =
279 case otherContent of
280 Structure term ->
281 unifySuperStructure context super term
283 Atom name ->
284 if atomMatchesSuper super name then
285 merge context otherContent
286 else
287 mismatch context (Just (badSuper super))
289 Var Rigid Nothing maybeName ->
290 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
292 Var Rigid (Just otherSuper) maybeName ->
293 case combineSupers super otherSuper of
294 Right newSuper | newSuper == super ->
295 merge context otherContent
297 _ ->
298 mismatch context $ Just $
299 doubleBad (errorSuper super) (Error.Rigid maybeName)
301 Var Flex Nothing _ ->
302 merge context (Var Flex (Just super) Nothing)
304 Var Flex (Just otherSuper) _ ->
305 case combineSupers super otherSuper of
306 Left reason ->
307 mismatch context (Just reason)
309 Right newSuper ->
310 merge context (Var Flex (Just newSuper) Nothing)
312 Alias _ _ realVar ->
313 subUnify context (_first context) realVar
315 Error ->
316 return ()
319combineSupers :: Super -> Super -> Either Error.Reason Super
320combineSupers firstSuper secondSuper =
321 case (firstSuper, secondSuper) of
322 (Number , Number ) -> Right Number
323 (Comparable, Number ) -> Right Number
324 (Number , Comparable) -> Right Number
326 (Comparable, Comparable) -> Right Comparable
327 (Appendable, Appendable) -> Right Appendable
329 (Appendable, Comparable) -> Right CompAppend
330 (Comparable, Appendable) -> Right CompAppend
332 (CompAppend, CompAppend) -> Right CompAppend
333 (CompAppend, Comparable) -> Right CompAppend
334 (Comparable, CompAppend) -> Right CompAppend
335 (CompAppend, Appendable) -> Right CompAppend
336 (Appendable, CompAppend) -> Right CompAppend
338 (_ , _ ) ->
339 Left $ doubleBad (errorSuper firstSuper) (errorSuper secondSuper)
342isPrimitiveFrom :: [String] -> Var.Canonical -> Bool
343isPrimitiveFrom prims var =
344 any (\p -> Var.isPrim p var) prims
347atomMatchesSuper :: Super -> Var.Canonical -> Bool
348atomMatchesSuper super name =
349 case super of
350 Number ->
351 isPrimitiveFrom ["Int", "Float"] name
353 Comparable ->
354 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
356 Appendable ->
357 Var.isPrim "String" name || Var.isText name
359 CompAppend ->
360 Var.isPrim "String" name
363unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()
364unifySuperStructure context super term =
365 do appStructure <- liftIO (collectApps (Structure term))
366 case appStructure of
367 Other ->
368 mismatch context (Just (badSuper super))
370 List variable ->
371 case super of
372 Number ->
373 mismatch context (Just (badSuper super))
375 Appendable ->
376 merge context (Structure term)
378 Comparable ->
379 do merge context (Structure term)
380 unifyComparableRecursive (_orientation context) variable
382 CompAppend ->
383 do merge context (Structure term)
384 unifyComparableRecursive (_orientation context) variable
386 Tuple entries ->
387 case super of
388 Number ->
389 mismatch context (Just (badSuper super))
391 Appendable ->
392 mismatch context (Just (badSuper super))
394 Comparable ->
395 if length entries > 6 then
396 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
398 else
399 do merge context (Structure term)
400 mapM_ (unifyComparableRecursive (_orientation context)) entries
402 CompAppend ->
403 mismatch context (Just (badSuper super))
406unifyComparableRecursive :: Orientation -> Variable -> Unify ()
407unifyComparableRecursive orientation var =
408 do compVar <-
409 liftIO $
410 do desc <- UF.descriptor var
411 UF.fresh $
412 Descriptor
413 { _content = Var Flex (Just Comparable) Nothing
414 , _rank = _rank desc
415 , _mark = noMark
416 , _copy = Nothing
417 }
419 guardedUnify orientation compVar var
422data AppStructure
423 = List Variable
424 | Tuple [Variable]
425 | Other
428collectApps :: Content -> IO AppStructure
429collectApps content =
430 collectAppsHelp [] content
433collectAppsHelp :: [Variable] -> Content -> IO AppStructure
434collectAppsHelp args content =
435 case (content, args) of
436 (Structure (App1 func arg), _) ->
437 collectAppsHelp (args ++ [arg]) =<< getContent func
439 (Atom name, [arg]) | Var.isList name ->
440 return (List arg)
442 (Atom name, _) | Var.isTuple name ->
443 return (Tuple args)
445 _ ->
446 return Other
449getContent :: Variable -> IO Content
450getContent variable =
451 _content <$> UF.descriptor variable
455-- UNIFY ATOMS
458unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
459unifyAtom context name otherContent =
460 case otherContent of
461 Error ->
462 return ()
464 Var Flex Nothing _ ->
465 merge context (Atom name)
467 Var Flex (Just super) _ ->
468 if atomMatchesSuper super name then
469 merge context (Atom name)
471 else
472 mismatch context (Just ((Error.flipReason (badSuper super))))
474 Var Rigid _ maybeName ->
475 mismatch context (Just (Error.flipReason (badRigid maybeName)))
477 Atom otherName ->
478 if name == otherName then
479 merge context otherContent
481 else
482 mismatch context $
483 if isIntFloat name otherName || isIntFloat otherName name then
484 Just Error.IntFloat
485 else
486 Nothing
488 Alias _ _ realVar ->
489 subUnify context (_first context) realVar
491 Structure _ ->
492 mismatch context Nothing
495isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
496isIntFloat name otherName =
497 Var.isPrim "Int" name && Var.isPrim "Float" otherName
500-- UNIFY ALIASES
503unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
504unifyAlias context name args realVar otherContent =
505 case otherContent of
506 Error ->
507 return ()
509 Var Flex Nothing _ ->
510 merge context (Alias name args realVar)
512 Var _ _ _ ->
513 subUnify context realVar (_second context)
515 Atom _ ->
516 subUnify context realVar (_second context)
519 Alias otherName otherArgs otherRealVar ->
520 if name == otherName then
521 do merge context otherContent
522 zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
524 else
525 subUnify context realVar otherRealVar
527 Structure _ ->
528 subUnify context realVar (_second context)
532-- UNIFY STRUCTURES
535unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
536unifyStructure context term otherContent =
537 case otherContent of
538 Error ->
539 return ()
541 Var Flex Nothing _ ->
542 merge context (Structure term)
544 Var Flex (Just super) _ ->
545 unifySuper (reorient context) super (Structure term)
547 Var Rigid _ maybeName ->
548 mismatch context (Just (Error.flipReason (badRigid maybeName)))
550 Atom _ ->
551 mismatch context Nothing
553 Alias _ _ realVar ->
554 subUnify context (_first context) realVar
556 Structure otherTerm ->
557 case (term, otherTerm) of
558 (App1 func arg, App1 otherFunc otherArg) ->
559 do subUnify context func otherFunc
560 subUnify context arg otherArg
561 merge context otherContent
563 (Fun1 arg result, Fun1 otherArg otherResult) ->
564 do subUnify context arg otherArg
565 subUnify context result otherResult
566 merge context otherContent
568 (Effects1 names, Effects1 otherNames) ->
569 merge context (Structure (Effects1 (Set.union names otherNames)))
571 (EmptyRecord1, EmptyRecord1) ->
572 merge context otherContent
574 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
575 subUnify context ext (_second context)
577 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
578 subUnify context (_first context) ext
580 (Record1 fields extension, Record1 otherFields otherExtension) ->
581 do firstStructure <- gatherFields context fields extension
582 secondStructure <- gatherFields context otherFields otherExtension
583 unifyRecord context firstStructure secondStructure
585 _ ->
586 mismatch context Nothing
590-- UNIFY RECORDS
593unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
594unifyRecord context firstStructure secondStructure =
595 do let (RecordStructure expFields expVar expStruct) = firstStructure
596 let (RecordStructure actFields actVar actStruct) = secondStructure
598 -- call after unifying extension, make sure record shape matches before
599 -- looking into whether the particular field types match.
600 let unifySharedFields otherFields ext =
601 do let sharedFields = Map.intersectionWith (,) expFields actFields
602 _ <- traverse (uncurry (subUnify context)) sharedFields
603 let allFields = Map.union (Map.map fst sharedFields) otherFields
604 merge context (Structure (Record1 allFields ext))
606 let uniqueExpFields = Map.difference expFields actFields
607 let uniqueActFields = Map.difference actFields expFields
609 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
610 (_, True, _, True) ->
611 do subUnify context expVar actVar
612 unifySharedFields Map.empty expVar
614 (Empty, _, _, False) ->
615 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
617 (_, False, Empty, _) ->
618 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
620 (_, False, _, True) ->
621 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
622 subUnify context subRecord actVar
623 unifySharedFields Map.empty subRecord
625 (_, True, _, False) ->
626 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
627 subUnify context expVar subRecord
628 unifySharedFields Map.empty subRecord
630 (Extension, False, Extension, False) ->
631 do let subFields = Map.union uniqueExpFields uniqueActFields
632 subExt <- fresh context (Var Flex Nothing Nothing)
633 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
634 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
635 subUnify context expVar expRecord
636 subUnify context actRecord actVar
637 unifySharedFields subFields subExt
641-- GATHER RECORD STRUCTURE
644data RecordStructure = RecordStructure
645 { _fields :: Map.Map String Variable
646 , _extVar :: Variable
647 , _extStruct :: ExtensionStructure
648 }
651data ExtensionStructure
652 = Empty
653 | Extension
656gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
657gatherFields context fields variable =
658 do desc <- liftIO (UF.descriptor variable)
659 case _content desc of
660 Structure (Record1 subFields subExt) ->
661 gatherFields context (Map.union fields subFields) subExt
663 Structure EmptyRecord1 ->
664 return (RecordStructure fields variable Empty)
666 Alias _ _ var ->
667 -- TODO may be dropping useful alias info here
668 gatherFields context fields var
670 _ ->
671 return (RecordStructure fields variable Extension)