git.iko.soy/elk
on 17618de help sign in
elk/src/Type/Unify.hs
670 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 state ->
25 return state
27 Left (Mismatch _subExpected _subActual 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
74data Mismatch
75 = Mismatch Variable Variable (Maybe Error.Reason)
78mismatch :: Context -> Maybe Error.Reason -> Unify a
79mismatch (Context orientation first _ second _) maybeReason =
80 let
81 (expected, actual, orientedReason) =
82 case orientation of
83 ExpectedActual ->
84 (first, second, maybeReason)
86 ActualExpected ->
87 (second, first, Error.flipReason <$> maybeReason)
88 in
89 throwError (Mismatch expected actual orientedReason)
92badRigid :: Maybe String -> Error.Reason
93badRigid maybeName =
94 Error.BadVar (Just (Error.Rigid maybeName)) Nothing
97badSuper :: Super -> Error.Reason
98badSuper super =
99 Error.BadVar (Just (errorSuper super)) Nothing
102doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
103doubleBad vt1 vt2 =
104 Error.BadVar (Just vt1) (Just vt2)
107errorSuper :: Super -> Error.VarType
108errorSuper super =
109 case super of
110 Number ->
111 Error.Number
113 Comparable ->
114 Error.Comparable
116 Appendable ->
117 Error.Appendable
119 CompAppend ->
120 Error.CompAppend
124-- MERGE
127merge :: Context -> Content -> Unify ()
128merge (Context _ first _ second _) content =
129 liftIO $ mergeHelp first second content
132mergeHelp :: Variable -> Variable -> Content -> IO ()
133mergeHelp first second content =
134 UF.union' first second $ \desc1 desc2 ->
135 return $
136 Descriptor
137 { _content = content
138 , _rank = min (_rank desc1) (_rank desc2)
139 , _mark = noMark
140 , _copy = Nothing
141 }
144fresh :: Context -> Content -> Unify Variable
145fresh (Context _ _ desc1 _ desc2) content =
146 do freshVariable <-
147 liftIO $ UF.fresh $
148 Descriptor
149 { _content = content
150 , _rank = min (_rank desc1) (_rank desc2)
151 , _mark = noMark
152 , _copy = Nothing
153 }
154 lift (TS.register freshVariable)
158-- ACTUALLY UNIFY THINGS
161guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
162guardedUnify orientation left right =
163 do equivalent <- liftIO $ UF.equivalent left right
164 if equivalent
165 then return ()
166 else
167 do leftDesc <- liftIO $ UF.descriptor left
168 rightDesc <- liftIO $ UF.descriptor right
169 actuallyUnify (Context orientation left leftDesc right rightDesc)
172subUnify :: Context -> Variable -> Variable -> Unify ()
173subUnify context var1 var2 =
174 guardedUnify (_orientation context) var1 var2
177actuallyUnify :: Context -> Unify ()
178actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
179 let
180 secondContent = _content secondDesc
181 in
182 case _content firstDesc of
183 Error ->
184 -- If there was an error, just pretend it is okay. This lets us avoid
185 -- "cascading" errors where one problem manifests as multiple message.
186 return ()
188 Var Flex Nothing _ ->
189 unifyFlex context secondContent
191 Var Flex (Just super) _ ->
192 unifySuper context super secondContent
194 Var Rigid maybeSuper maybeName ->
195 unifyRigid context maybeSuper maybeName secondContent
197 Atom name ->
198 unifyAtom context name secondContent
200 Alias name args realVar ->
201 unifyAlias context name args realVar secondContent
203 Structure term ->
204 unifyStructure context term secondContent
208-- UNIFY FLEXIBLE VARIABLES
211unifyFlex :: Context -> Content -> Unify ()
212unifyFlex context otherContent =
213 case otherContent of
214 Error ->
215 return ()
217 Var Flex _ _ ->
218 merge context otherContent
220 Var Rigid _ _ ->
221 merge context otherContent
223 Atom _ ->
224 merge context otherContent
226 Alias _ _ _ ->
227 merge context otherContent
229 Structure _ ->
230 merge context otherContent
234-- UNIFY RIGID VARIABLES
237unifyRigid :: Context -> Maybe Super -> Maybe String -> Content -> Unify ()
238unifyRigid context maybeSuper maybeName otherContent =
239 case otherContent of
240 Error ->
241 return ()
243 Var Flex otherMaybeSuper _ ->
244 case (maybeSuper, otherMaybeSuper) of
245 (_, Nothing) ->
246 merge context (Var Rigid maybeSuper maybeName)
248 (Nothing, Just _) ->
249 mismatch context (Just (badRigid maybeName))
251 (Just super, Just otherSuper) ->
252 case combineSupers super otherSuper of
253 Right newSuper | newSuper == otherSuper ->
254 merge context otherContent
256 _ ->
257 mismatch context (Just (badRigid maybeName))
259 Var Rigid _ otherMaybeName ->
260 mismatch context $ Just $
261 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
263 Atom _ ->
264 mismatch context (Just (badRigid maybeName))
266 Alias _ _ _ ->
267 mismatch context (Just (badRigid maybeName))
269 Structure _ ->
270 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
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
501-- UNIFY ALIASES
504unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
505unifyAlias context name args realVar otherContent =
506 case otherContent of
507 Error ->
508 return ()
510 Var Flex Nothing _ ->
511 merge context (Alias name args realVar)
513 Var _ _ _ ->
514 subUnify context realVar (_second context)
516 Atom _ ->
517 subUnify context realVar (_second context)
520 Alias otherName otherArgs otherRealVar ->
521 if name == otherName then
522 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
523 merge context otherContent
525 else
526 subUnify context realVar otherRealVar
528 Structure _ ->
529 subUnify context realVar (_second context)
533-- UNIFY STRUCTURES
536unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
537unifyStructure context term otherContent =
538 case otherContent of
539 Error ->
540 return ()
542 Var Flex Nothing _ ->
543 merge context (Structure term)
545 Var Flex (Just super) _ ->
546 unifySuper (reorient context) super (Structure term)
548 Var Rigid _ maybeName ->
549 mismatch context (Just (Error.flipReason (badRigid maybeName)))
551 Atom _ ->
552 mismatch context Nothing
554 Alias _ _ realVar ->
555 subUnify context (_first context) realVar
557 Structure otherTerm ->
558 case (term, otherTerm) of
559 (App1 func arg, App1 otherFunc otherArg) ->
560 do subUnify context func otherFunc
561 subUnify context arg otherArg
562 merge context otherContent
564 (Fun1 arg result, Fun1 otherArg otherResult) ->
565 do subUnify context arg otherArg
566 subUnify context result otherResult
567 merge context otherContent
569 (EmptyRecord1, EmptyRecord1) ->
570 merge context otherContent
572 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
573 subUnify context ext (_second context)
575 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
576 subUnify context (_first context) ext
578 (Record1 fields extension, Record1 otherFields otherExtension) ->
579 do firstStructure <- gatherFields context fields extension
580 secondStructure <- gatherFields context otherFields otherExtension
581 unifyRecord context firstStructure secondStructure
583 _ ->
584 mismatch context Nothing
588-- UNIFY RECORDS
591unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
592unifyRecord context firstStructure secondStructure =
593 do let (RecordStructure expFields expVar expStruct) = firstStructure
594 let (RecordStructure actFields actVar actStruct) = secondStructure
596 -- call after unifying extension, make sure record shape matches before
597 -- looking into whether the particular field types match.
598 let unifySharedFields otherFields ext =
599 do let sharedFields = Map.intersectionWith (,) expFields actFields
600 _ <- traverse (uncurry (subUnify context)) sharedFields
601 let allFields = Map.union (Map.map fst sharedFields) otherFields
602 merge context (Structure (Record1 allFields ext))
604 let uniqueExpFields = Map.difference expFields actFields
605 let uniqueActFields = Map.difference actFields expFields
607 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
608 (_, True, _, True) ->
609 do subUnify context expVar actVar
610 unifySharedFields Map.empty expVar
612 (Empty, _, _, False) ->
613 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
615 (_, False, Empty, _) ->
616 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
618 (_, False, _, True) ->
619 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
620 subUnify context subRecord actVar
621 unifySharedFields Map.empty subRecord
623 (_, True, _, False) ->
624 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
625 subUnify context expVar subRecord
626 unifySharedFields Map.empty subRecord
628 (Extension, False, Extension, False) ->
629 do let subFields = Map.union uniqueExpFields uniqueActFields
630 subExt <- fresh context (Var Flex Nothing Nothing)
631 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
632 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
633 subUnify context expVar expRecord
634 subUnify context actRecord actVar
635 unifySharedFields subFields subExt
639-- GATHER RECORD STRUCTURE
642data RecordStructure = RecordStructure
643 { _fields :: Map.Map String Variable
644 , _extVar :: Variable
645 , _extStruct :: ExtensionStructure
646 }
649data ExtensionStructure
650 = Empty
651 | Extension
654gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
655gatherFields context fields variable =
656 do desc <- liftIO (UF.descriptor variable)
657 case _content desc of
658 Structure (Record1 subFields subExt) ->
659 gatherFields context (Map.union fields subFields) subExt
661 Structure EmptyRecord1 ->
662 return (RecordStructure fields variable Empty)
664 Alias _ _ var ->
665 -- TODO may be dropping useful alias info here
666 gatherFields context fields var
668 _ ->
669 return (RecordStructure fields variable Extension)