git.iko.soy/elk
on ebe2bb5 help sign in
elk/src/Type/Unify.hs
668 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))
273-- UNIFY SUPER VARIABLES
276unifySuper :: Context -> Super -> Content -> Unify ()
277unifySuper context super otherContent =
278 case otherContent of
279 Structure term ->
280 unifySuperStructure context super term
282 Atom name ->
283 if atomMatchesSuper super name then
284 merge context otherContent
285 else
286 mismatch context (Just (badSuper super))
288 Var Rigid Nothing maybeName ->
289 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
291 Var Rigid (Just otherSuper) maybeName ->
292 case combineSupers super otherSuper of
293 Right newSuper | newSuper == super ->
294 merge context otherContent
296 _ ->
297 mismatch context $ Just $
298 doubleBad (errorSuper super) (Error.Rigid maybeName)
300 Var Flex Nothing _ ->
301 merge context (Var Flex (Just super) Nothing)
303 Var Flex (Just otherSuper) _ ->
304 case combineSupers super otherSuper of
305 Left reason ->
306 mismatch context (Just reason)
308 Right newSuper ->
309 merge context (Var Flex (Just newSuper) Nothing)
311 Alias _ _ realVar ->
312 subUnify context (_first context) realVar
314 Error ->
315 return ()
318combineSupers :: Super -> Super -> Either Error.Reason Super
319combineSupers firstSuper secondSuper =
320 case (firstSuper, secondSuper) of
321 (Number , Number ) -> Right Number
322 (Comparable, Number ) -> Right Number
323 (Number , Comparable) -> Right Number
325 (Comparable, Comparable) -> Right Comparable
326 (Appendable, Appendable) -> Right Appendable
328 (Appendable, Comparable) -> Right CompAppend
329 (Comparable, Appendable) -> Right CompAppend
331 (CompAppend, CompAppend) -> Right CompAppend
332 (CompAppend, Comparable) -> Right CompAppend
333 (Comparable, CompAppend) -> Right CompAppend
334 (CompAppend, Appendable) -> Right CompAppend
335 (Appendable, CompAppend) -> Right CompAppend
337 (_ , _ ) ->
338 Left $ doubleBad (errorSuper firstSuper) (errorSuper secondSuper)
341isPrimitiveFrom :: [String] -> Var.Canonical -> Bool
342isPrimitiveFrom prims var =
343 any (\p -> Var.isPrim p var) prims
346atomMatchesSuper :: Super -> Var.Canonical -> Bool
347atomMatchesSuper super name =
348 case super of
349 Number ->
350 isPrimitiveFrom ["Int", "Float"] name
352 Comparable ->
353 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
355 Appendable ->
356 Var.isPrim "String" name || Var.isText name
358 CompAppend ->
359 Var.isPrim "String" name
362unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()
363unifySuperStructure context super term =
364 do appStructure <- liftIO (collectApps (Structure term))
365 case appStructure of
366 Other ->
367 mismatch context (Just (badSuper super))
369 List variable ->
370 case super of
371 Number ->
372 mismatch context (Just (badSuper super))
374 Appendable ->
375 merge context (Structure term)
377 Comparable ->
378 do merge context (Structure term)
379 unifyComparableRecursive (_orientation context) variable
381 CompAppend ->
382 do merge context (Structure term)
383 unifyComparableRecursive (_orientation context) variable
385 Tuple entries ->
386 case super of
387 Number ->
388 mismatch context (Just (badSuper super))
390 Appendable ->
391 mismatch context (Just (badSuper super))
393 Comparable ->
394 if length entries > 6 then
395 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
397 else
398 do merge context (Structure term)
399 mapM_ (unifyComparableRecursive (_orientation context)) entries
401 CompAppend ->
402 mismatch context (Just (badSuper super))
405unifyComparableRecursive :: Orientation -> Variable -> Unify ()
406unifyComparableRecursive orientation var =
407 do compVar <-
408 liftIO $
409 do desc <- UF.descriptor var
410 UF.fresh $
411 Descriptor
412 { _content = Var Flex (Just Comparable) Nothing
413 , _rank = _rank desc
414 , _mark = noMark
415 , _copy = Nothing
416 }
418 guardedUnify orientation compVar var
421data AppStructure
422 = List Variable
423 | Tuple [Variable]
424 | Other
427collectApps :: Content -> IO AppStructure
428collectApps content =
429 collectAppsHelp [] content
432collectAppsHelp :: [Variable] -> Content -> IO AppStructure
433collectAppsHelp args content =
434 case (content, args) of
435 (Structure (App1 func arg), _) ->
436 collectAppsHelp (args ++ [arg]) =<< getContent func
438 (Atom name, [arg]) | Var.isList name ->
439 return (List arg)
441 (Atom name, _) | Var.isTuple name ->
442 return (Tuple args)
444 _ ->
445 return Other
448getContent :: Variable -> IO Content
449getContent variable =
450 _content <$> UF.descriptor variable
454-- UNIFY ATOMS
457unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
458unifyAtom context name otherContent =
459 case otherContent of
460 Error ->
461 return ()
463 Var Flex Nothing _ ->
464 merge context (Atom name)
466 Var Flex (Just super) _ ->
467 if atomMatchesSuper super name then
468 merge context (Atom name)
470 else
471 mismatch context (Just ((Error.flipReason (badSuper super))))
473 Var Rigid _ maybeName ->
474 mismatch context (Just (Error.flipReason (badRigid maybeName)))
476 Atom otherName ->
477 if name == otherName then
478 merge context otherContent
480 else
481 mismatch context $
482 if isIntFloat name otherName || isIntFloat otherName name then
483 Just Error.IntFloat
484 else
485 Nothing
487 Alias _ _ realVar ->
488 subUnify context (_first context) realVar
490 Structure _ ->
491 mismatch context Nothing
494isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
495isIntFloat name otherName =
496 Var.isPrim "Int" name && Var.isPrim "Float" otherName
499-- UNIFY ALIASES
502unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
503unifyAlias context name args realVar otherContent =
504 case otherContent of
505 Error ->
506 return ()
508 Var Flex Nothing _ ->
509 merge context (Alias name args realVar)
511 Var _ _ _ ->
512 subUnify context realVar (_second context)
514 Atom _ ->
515 subUnify context realVar (_second context)
518 Alias otherName otherArgs otherRealVar ->
519 if name == otherName then
520 do merge context otherContent
521 zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
523 else
524 subUnify context realVar otherRealVar
526 Structure _ ->
527 subUnify context realVar (_second context)
531-- UNIFY STRUCTURES
534unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
535unifyStructure context term otherContent =
536 case otherContent of
537 Error ->
538 return ()
540 Var Flex Nothing _ ->
541 merge context (Structure term)
543 Var Flex (Just super) _ ->
544 unifySuper (reorient context) super (Structure term)
546 Var Rigid _ maybeName ->
547 mismatch context (Just (Error.flipReason (badRigid maybeName)))
549 Atom _ ->
550 mismatch context Nothing
552 Alias _ _ realVar ->
553 subUnify context (_first context) realVar
555 Structure otherTerm ->
556 case (term, otherTerm) of
557 (App1 func arg, App1 otherFunc otherArg) ->
558 do subUnify context func otherFunc
559 subUnify context arg otherArg
560 merge context otherContent
562 (Fun1 arg result, Fun1 otherArg otherResult) ->
563 do subUnify context arg otherArg
564 subUnify context result otherResult
565 merge context otherContent
567 (EmptyRecord1, EmptyRecord1) ->
568 merge context otherContent
570 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
571 subUnify context ext (_second context)
573 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
574 subUnify context (_first context) ext
576 (Record1 fields extension, Record1 otherFields otherExtension) ->
577 do firstStructure <- gatherFields context fields extension
578 secondStructure <- gatherFields context otherFields otherExtension
579 unifyRecord context firstStructure secondStructure
581 _ ->
582 mismatch context Nothing
586-- UNIFY RECORDS
589unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
590unifyRecord context firstStructure secondStructure =
591 do let (RecordStructure expFields expVar expStruct) = firstStructure
592 let (RecordStructure actFields actVar actStruct) = secondStructure
594 -- call after unifying extension, make sure record shape matches before
595 -- looking into whether the particular field types match.
596 let unifySharedFields otherFields ext =
597 do let sharedFields = Map.intersectionWith (,) expFields actFields
598 _ <- traverse (uncurry (subUnify context)) sharedFields
599 let allFields = Map.union (Map.map fst sharedFields) otherFields
600 merge context (Structure (Record1 allFields ext))
602 let uniqueExpFields = Map.difference expFields actFields
603 let uniqueActFields = Map.difference actFields expFields
605 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
606 (_, True, _, True) ->
607 do subUnify context expVar actVar
608 unifySharedFields Map.empty expVar
610 (Empty, _, _, False) ->
611 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
613 (_, False, Empty, _) ->
614 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
616 (_, False, _, True) ->
617 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
618 subUnify context subRecord actVar
619 unifySharedFields Map.empty subRecord
621 (_, True, _, False) ->
622 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
623 subUnify context expVar subRecord
624 unifySharedFields Map.empty subRecord
626 (Extension, False, Extension, False) ->
627 do let subFields = Map.union uniqueExpFields uniqueActFields
628 subExt <- fresh context (Var Flex Nothing Nothing)
629 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
630 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
631 subUnify context expVar expRecord
632 subUnify context actRecord actVar
633 unifySharedFields subFields subExt
637-- GATHER RECORD STRUCTURE
640data RecordStructure = RecordStructure
641 { _fields :: Map.Map String Variable
642 , _extVar :: Variable
643 , _extStruct :: ExtensionStructure
644 }
647data ExtensionStructure
648 = Empty
649 | Extension
652gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
653gatherFields context fields variable =
654 do desc <- liftIO (UF.descriptor variable)
655 case _content desc of
656 Structure (Record1 subFields subExt) ->
657 gatherFields context (Map.union fields subFields) subExt
659 Structure EmptyRecord1 ->
660 return (RecordStructure fields variable Empty)
662 Alias _ _ var ->
663 -- TODO may be dropping useful alias info here
664 gatherFields context fields var
666 _ ->
667 return (RecordStructure fields variable Extension)