git.iko.soy/elk
on efb86bc help sign in
elk/src/Type/Unify.hs
655 lines 18 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 if maybeSuper == otherMaybeSuper then
245 merge context (Var Rigid maybeSuper maybeName)
246 else
247 mismatch context (Just (badRigid maybeName))
249 Var Rigid _ otherMaybeName ->
250 mismatch context $ Just $
251 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
253 Atom _ ->
254 mismatch context (Just (badRigid maybeName))
256 Alias _ _ _ ->
257 mismatch context (Just (badRigid maybeName))
259 Structure _ ->
260 mismatch context (Just (badRigid maybeName))
263-- UNIFY SUPER VARIABLES
266unifySuper :: Context -> Super -> Content -> Unify ()
267unifySuper context super otherContent =
268 case otherContent of
269 Structure term ->
270 unifySuperStructure context super term
272 Atom name ->
273 if atomMatchesSuper super name then
274 merge context otherContent
275 else
276 mismatch context (Just (badSuper super))
278 Var Rigid Nothing maybeName ->
279 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
281 Var Rigid (Just otherSuper) maybeName ->
282 if super == otherSuper then
283 merge context otherContent
284 else
285 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
287 Var Flex Nothing _ ->
288 merge context (Var Flex (Just super) Nothing)
290 Var Flex (Just otherSuper) _ ->
291 case combineSupers super otherSuper of
292 Left reason ->
293 mismatch context (Just reason)
295 Right newSuper ->
296 merge context (Var Flex (Just newSuper) Nothing)
298 Alias _ _ realVar ->
299 subUnify context (_first context) realVar
301 Error ->
302 return ()
305combineSupers :: Super -> Super -> Either Error.Reason Super
306combineSupers firstSuper secondSuper =
307 case (firstSuper, secondSuper) of
308 (Number , Number ) -> Right Number
309 (Comparable, Number ) -> Right Number
310 (Number , Comparable) -> Right Number
312 (Comparable, Comparable) -> Right Comparable
313 (Appendable, Appendable) -> Right Appendable
315 (Appendable, Comparable) -> Right CompAppend
316 (Comparable, Appendable) -> Right CompAppend
318 (CompAppend, CompAppend) -> Right CompAppend
319 (CompAppend, Comparable) -> Right CompAppend
320 (Comparable, CompAppend) -> Right CompAppend
321 (CompAppend, Appendable) -> Right CompAppend
322 (Appendable, CompAppend) -> Right CompAppend
324 (_ , _ ) ->
325 Left $ doubleBad (errorSuper firstSuper) (errorSuper secondSuper)
328isPrimitiveFrom :: [String] -> Var.Canonical -> Bool
329isPrimitiveFrom prims var =
330 any (\p -> Var.isPrim p var) prims
333atomMatchesSuper :: Super -> Var.Canonical -> Bool
334atomMatchesSuper super name =
335 case super of
336 Number ->
337 isPrimitiveFrom ["Int", "Float"] name
339 Comparable ->
340 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
342 Appendable ->
343 Var.isPrim "String" name || Var.isText name
345 CompAppend ->
346 Var.isPrim "String" name
349unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()
350unifySuperStructure context super term =
351 do appStructure <- liftIO (collectApps (Structure term))
352 case appStructure of
353 Other ->
354 mismatch context (Just (badSuper super))
356 List variable ->
357 case super of
358 Number ->
359 mismatch context (Just (badSuper super))
361 Appendable ->
362 merge context (Structure term)
364 Comparable ->
365 do merge context (Structure term)
366 unifyComparableRecursive (_orientation context) variable
368 CompAppend ->
369 do merge context (Structure term)
370 unifyComparableRecursive (_orientation context) variable
372 Tuple entries ->
373 case super of
374 Number ->
375 mismatch context (Just (badSuper super))
377 Appendable ->
378 mismatch context (Just (badSuper super))
380 Comparable ->
381 if length entries > 6 then
382 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
384 else
385 do merge context (Structure term)
386 mapM_ (unifyComparableRecursive (_orientation context)) entries
388 CompAppend ->
389 mismatch context (Just (badSuper super))
392unifyComparableRecursive :: Orientation -> Variable -> Unify ()
393unifyComparableRecursive orientation var =
394 do compVar <-
395 liftIO $
396 do desc <- UF.descriptor var
397 UF.fresh $
398 Descriptor
399 { _content = Var Flex (Just Comparable) Nothing
400 , _rank = _rank desc
401 , _mark = noMark
402 , _copy = Nothing
403 }
405 guardedUnify orientation compVar var
408data AppStructure
409 = List Variable
410 | Tuple [Variable]
411 | Other
414collectApps :: Content -> IO AppStructure
415collectApps content =
416 collectAppsHelp [] content
419collectAppsHelp :: [Variable] -> Content -> IO AppStructure
420collectAppsHelp args content =
421 case (content, args) of
422 (Structure (App1 func arg), _) ->
423 collectAppsHelp (args ++ [arg]) =<< getContent func
425 (Atom name, [arg]) | Var.isList name ->
426 return (List arg)
428 (Atom name, _) | Var.isTuple name ->
429 return (Tuple args)
431 _ ->
432 return Other
435getContent :: Variable -> IO Content
436getContent variable =
437 _content <$> UF.descriptor variable
441-- UNIFY ATOMS
444unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
445unifyAtom context name otherContent =
446 case otherContent of
447 Error ->
448 return ()
450 Var Flex Nothing _ ->
451 merge context (Atom name)
453 Var Flex (Just super) _ ->
454 if atomMatchesSuper super name then
455 merge context (Atom name)
457 else
458 mismatch context (Just ((Error.flipReason (badSuper super))))
460 Var Rigid _ maybeName ->
461 mismatch context (Just (Error.flipReason (badRigid maybeName)))
463 Atom otherName ->
464 if name == otherName then
465 merge context otherContent
467 else
468 mismatch context $
469 if isIntFloat name otherName || isIntFloat otherName name then
470 Just Error.IntFloat
471 else
472 Nothing
474 Alias _ _ realVar ->
475 subUnify context (_first context) realVar
477 Structure _ ->
478 mismatch context Nothing
481isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
482isIntFloat name otherName =
483 Var.isPrim "Int" name && Var.isPrim "Float" otherName
486-- UNIFY ALIASES
489unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
490unifyAlias context name args realVar otherContent =
491 case otherContent of
492 Error ->
493 return ()
495 Var Flex Nothing _ ->
496 merge context (Alias name args realVar)
498 Var _ _ _ ->
499 subUnify context realVar (_second context)
501 Atom _ ->
502 subUnify context realVar (_second context)
505 Alias otherName otherArgs otherRealVar ->
506 if name == otherName then
507 do merge context otherContent
508 zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
510 else
511 subUnify context realVar otherRealVar
513 Structure _ ->
514 subUnify context realVar (_second context)
518-- UNIFY STRUCTURES
521unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
522unifyStructure context term otherContent =
523 case otherContent of
524 Error ->
525 return ()
527 Var Flex Nothing _ ->
528 merge context (Structure term)
530 Var Flex (Just super) _ ->
531 unifySuper (reorient context) super (Structure term)
533 Var Rigid _ maybeName ->
534 mismatch context (Just (Error.flipReason (badRigid maybeName)))
536 Atom _ ->
537 mismatch context Nothing
539 Alias _ _ realVar ->
540 subUnify context (_first context) realVar
542 Structure otherTerm ->
543 case (term, otherTerm) of
544 (App1 func arg, App1 otherFunc otherArg) ->
545 do subUnify context func otherFunc
546 subUnify context arg otherArg
547 merge context otherContent
549 (Fun1 arg result, Fun1 otherArg otherResult) ->
550 do subUnify context arg otherArg
551 subUnify context result otherResult
552 merge context otherContent
554 (EmptyRecord1, EmptyRecord1) ->
555 merge context otherContent
557 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
558 subUnify context ext (_second context)
560 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
561 subUnify context (_first context) ext
563 (Record1 fields extension, Record1 otherFields otherExtension) ->
564 do firstStructure <- gatherFields context fields extension
565 secondStructure <- gatherFields context otherFields otherExtension
566 unifyRecord context firstStructure secondStructure
568 _ ->
569 mismatch context Nothing
573-- UNIFY RECORDS
576unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
577unifyRecord context firstStructure secondStructure =
578 do let (RecordStructure expFields expVar expStruct) = firstStructure
579 let (RecordStructure actFields actVar actStruct) = secondStructure
581 -- call after unifying extension, make sure record shape matches before
582 -- looking into whether the particular field types match.
583 let unifySharedFields otherFields ext =
584 do let sharedFields = Map.intersectionWith (,) expFields actFields
585 _ <- traverse (uncurry (subUnify context)) sharedFields
586 let allFields = Map.union (Map.map fst sharedFields) otherFields
587 merge context (Structure (Record1 allFields ext))
589 let uniqueExpFields = Map.difference expFields actFields
590 let uniqueActFields = Map.difference actFields expFields
592 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
593 (_, True, _, True) ->
594 do subUnify context expVar actVar
595 unifySharedFields Map.empty expVar
597 (Empty, _, _, False) ->
598 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
600 (_, False, Empty, _) ->
601 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
603 (_, False, _, True) ->
604 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
605 subUnify context subRecord actVar
606 unifySharedFields Map.empty subRecord
608 (_, True, _, False) ->
609 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
610 subUnify context expVar subRecord
611 unifySharedFields Map.empty subRecord
613 (Extension, False, Extension, False) ->
614 do let subFields = Map.union uniqueExpFields uniqueActFields
615 subExt <- fresh context (Var Flex Nothing Nothing)
616 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
617 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
618 subUnify context expVar expRecord
619 subUnify context actRecord actVar
620 unifySharedFields subFields subExt
624-- GATHER RECORD STRUCTURE
627data RecordStructure = RecordStructure
628 { _fields :: Map.Map String Variable
629 , _extVar :: Variable
630 , _extStruct :: ExtensionStructure
631 }
634data ExtensionStructure
635 = Empty
636 | Extension
639gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
640gatherFields context fields variable =
641 do desc <- liftIO (UF.descriptor variable)
642 case _content desc of
643 Structure (Record1 subFields subExt) ->
644 gatherFields context (Map.union fields subFields) subExt
646 Structure EmptyRecord1 ->
647 return (RecordStructure fields variable Empty)
649 Alias _ _ var ->
650 -- TODO may be dropping useful alias info here
651 gatherFields context fields var
653 _ ->
654 return (RecordStructure fields variable Extension)