git.iko.soy/elk
on e83bdc3 help sign in
elk/src/Type/Unify.hs
643 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 subExpected subActual 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) =
82 case orientation of
83 ExpectedActual ->
84 (first, second)
86 ActualExpected ->
87 (second, first)
88 in
89 throwError (Mismatch expected actual maybeReason)
92rigidityError :: Context -> Maybe String -> Unify ()
93rigidityError context maybeName =
94 mismatch context (Just (Error.Rigid maybeName))
98-- MERGE
101merge :: Context -> Content -> Unify ()
102merge (Context _ first _ second _) content =
103 liftIO $ mergeHelp first second content
106mergeHelp :: Variable -> Variable -> Content -> IO ()
107mergeHelp first second content =
108 UF.union' first second $ \desc1 desc2 ->
109 return $
110 Descriptor
111 { _content = content
112 , _rank = min (_rank desc1) (_rank desc2)
113 , _mark = noMark
114 , _copy = Nothing
115 }
118fresh :: Context -> Content -> Unify Variable
119fresh (Context _ _ desc1 _ desc2) content =
120 do freshVariable <-
121 liftIO $ UF.fresh $
122 Descriptor
123 { _content = content
124 , _rank = min (_rank desc1) (_rank desc2)
125 , _mark = noMark
126 , _copy = Nothing
127 }
128 lift (TS.register freshVariable)
132-- ACTUALLY UNIFY THINGS
135guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
136guardedUnify orientation left right =
137 do equivalent <- liftIO $ UF.equivalent left right
138 if equivalent
139 then return ()
140 else
141 do leftDesc <- liftIO $ UF.descriptor left
142 rightDesc <- liftIO $ UF.descriptor right
143 actuallyUnify (Context orientation left leftDesc right rightDesc)
146subUnify :: Context -> Variable -> Variable -> Unify ()
147subUnify context var1 var2 =
148 guardedUnify (_orientation context) var1 var2
151actuallyUnify :: Context -> Unify ()
152actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =
153 let
154 secondContent = _content secondDesc
155 in
156 case _content firstDesc of
157 Error ->
158 -- If there was an error, just pretend it is okay. This lets us avoid
159 -- "cascading" errors where one problem manifests as multiple message.
160 return ()
162 Var Flex Nothing _ ->
163 unifyFlex context secondContent
165 Var Flex (Just super) _ ->
166 unifySuper context super secondContent
168 Var Rigid maybeSuper maybeName ->
169 unifyRigid context maybeSuper maybeName secondContent
171 Atom name ->
172 unifyAtom context name secondContent
174 Alias name args realVar ->
175 unifyAlias context name args realVar secondContent
177 Structure term ->
178 unifyStructure context term secondContent
182-- UNIFY FLEXIBLE VARIABLES
185unifyFlex :: Context -> Content -> Unify ()
186unifyFlex context otherContent =
187 case otherContent of
188 Error ->
189 return ()
191 Var Flex _ _ ->
192 merge context otherContent
194 Var Rigid _ _ ->
195 merge context otherContent
197 Atom _ ->
198 merge context otherContent
200 Alias _ _ _ ->
201 merge context otherContent
203 Structure _ ->
204 merge context otherContent
208-- UNIFY RIGID VARIABLES
211unifyRigid :: Context -> Maybe Super -> Maybe String -> Content -> Unify ()
212unifyRigid context maybeSuper maybeName otherContent =
213 case otherContent of
214 Error ->
215 return ()
217 Var Flex otherMaybeSuper _ ->
218 if maybeSuper == otherMaybeSuper then
219 merge context (Var Rigid maybeSuper maybeName)
220 else
221 rigidityError context maybeName
223 Var Rigid _ _ ->
224 mismatch context (Just Error.DoubleRigid)
226 Atom _ ->
227 rigidityError context maybeName
229 Alias _ _ _ ->
230 rigidityError context maybeName
232 Structure _ ->
233 rigidityError context maybeName
236-- UNIFY SUPER VARIABLES
239unifySuper :: Context -> Super -> Content -> Unify ()
240unifySuper context super otherContent =
241 case otherContent of
242 Structure term ->
243 unifySuperStructure context super term
245 Atom name ->
246 if atomMatchesSuper super name then
247 merge context otherContent
248 else
249 mismatch context (Just (superReason super))
251 Var Rigid Nothing maybeName ->
252 rigidityError context maybeName
254 Var Rigid (Just otherSuper) maybeName ->
255 if super == otherSuper then
256 merge context otherContent
257 else
258 rigidityError context maybeName
260 Var Flex Nothing _ ->
261 merge context (Var Flex (Just super) Nothing)
263 Var Flex (Just otherSuper) _ ->
264 case combineSupers super otherSuper of
265 Nothing ->
266 mismatch context Nothing
268 Just newSuper ->
269 merge context (Var Flex (Just newSuper) Nothing)
271 Alias _ _ realVar ->
272 subUnify context (_first context) realVar
274 Error ->
275 return ()
278combineSupers :: Super -> Super -> Maybe Super
279combineSupers firstSuper secondSuper =
280 case (firstSuper, secondSuper) of
281 (Number , Number ) -> Just Number
282 (Comparable, Number ) -> Just Number
283 (Number , Comparable) -> Just Number
285 (Comparable, Comparable) -> Just Comparable
286 (Appendable, Appendable) -> Just Appendable
288 (Appendable, Comparable) -> Just CompAppend
289 (Comparable, Appendable) -> Just CompAppend
291 (CompAppend, CompAppend) -> Just CompAppend
292 (CompAppend, Comparable) -> Just CompAppend
293 (Comparable, CompAppend) -> Just CompAppend
294 (CompAppend, Appendable) -> Just CompAppend
295 (Appendable, CompAppend) -> Just CompAppend
297 (_ , _ ) -> Nothing
300superReason :: Super -> Error.Reason
301superReason super =
302 case super of
303 Number ->
304 Error.NotNumber
306 Comparable ->
307 Error.NotComparable
309 Appendable ->
310 Error.NotAppendable
312 CompAppend ->
313 Error.NotCompAppend
316isPrimitiveFrom :: [String] -> Var.Canonical -> Bool
317isPrimitiveFrom prims var =
318 any (\p -> Var.isPrim p var) prims
321atomMatchesSuper :: Super -> Var.Canonical -> Bool
322atomMatchesSuper super name =
323 case super of
324 Number ->
325 isPrimitiveFrom ["Int", "Float"] name
327 Comparable ->
328 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
330 Appendable ->
331 Var.isPrim "String" name || Var.isText name
333 CompAppend ->
334 Var.isPrim "String" name
337unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()
338unifySuperStructure context super term =
339 do appStructure <- liftIO (collectApps (Structure term))
340 case appStructure of
341 Other ->
342 mismatch context (Just (superReason super))
344 List variable ->
345 case super of
346 Number ->
347 mismatch context (Just Error.NotNumber)
349 Appendable ->
350 merge context (Structure term)
352 Comparable ->
353 do merge context (Structure term)
354 unifyComparableRecursive (_orientation context) variable
356 CompAppend ->
357 do merge context (Structure term)
358 unifyComparableRecursive (_orientation context) variable
360 Tuple entries ->
361 case super of
362 Number ->
363 mismatch context (Just Error.NotNumber)
365 Appendable ->
366 mismatch context (Just Error.NotAppendable)
368 Comparable ->
369 if length entries > 6 then
370 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
372 else
373 do merge context (Structure term)
374 mapM_ (unifyComparableRecursive (_orientation context)) entries
376 CompAppend ->
377 mismatch context (Just Error.NotCompAppend)
380unifyComparableRecursive :: Orientation -> Variable -> Unify ()
381unifyComparableRecursive orientation var =
382 do compVar <-
383 liftIO $
384 do desc <- UF.descriptor var
385 UF.fresh $
386 Descriptor
387 { _content = Var Flex (Just Comparable) Nothing
388 , _rank = _rank desc
389 , _mark = noMark
390 , _copy = Nothing
391 }
393 guardedUnify orientation compVar var
396data AppStructure
397 = List Variable
398 | Tuple [Variable]
399 | Other
402collectApps :: Content -> IO AppStructure
403collectApps content =
404 collectAppsHelp [] content
407collectAppsHelp :: [Variable] -> Content -> IO AppStructure
408collectAppsHelp args content =
409 case (content, args) of
410 (Structure (App1 func arg), _) ->
411 collectAppsHelp (args ++ [arg]) =<< getContent func
413 (Atom name, [arg]) | Var.isList name ->
414 return (List arg)
416 (Atom name, _) | Var.isTuple name ->
417 return (Tuple args)
419 _ ->
420 return Other
423getContent :: Variable -> IO Content
424getContent variable =
425 _content <$> UF.descriptor variable
429-- UNIFY ATOMS
432unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
433unifyAtom context name otherContent =
434 case otherContent of
435 Error ->
436 return ()
438 Var Flex Nothing _ ->
439 merge context (Atom name)
441 Var Flex (Just super) _ ->
442 if atomMatchesSuper super name then
443 merge context (Atom name)
445 else
446 mismatch context (Just (superReason super))
448 Var Rigid _ maybeName ->
449 rigidityError context maybeName
451 Atom otherName ->
452 if name == otherName then
453 merge context otherContent
455 else
456 mismatch context $
457 if isIntFloat name otherName || isIntFloat otherName name then
458 Just Error.IntFloat
459 else
460 Nothing
462 Alias _ _ realVar ->
463 subUnify context (_first context) realVar
465 Structure _ ->
466 mismatch context Nothing
469isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
470isIntFloat name otherName =
471 Var.isPrim "Int" name && Var.isPrim "Float" otherName
474-- UNIFY ALIASES
477unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
478unifyAlias context name args realVar otherContent =
479 case otherContent of
480 Error ->
481 return ()
483 Var Flex Nothing _ ->
484 merge context (Alias name args realVar)
486 Var _ _ _ ->
487 subUnify context realVar (_second context)
489 Atom _ ->
490 subUnify context realVar (_second context)
493 Alias otherName otherArgs otherRealVar ->
494 if name == otherName then
495 do merge context otherContent
496 zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
498 else
499 subUnify context realVar otherRealVar
501 Structure _ ->
502 subUnify context realVar (_second context)
506-- UNIFY STRUCTURES
509unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
510unifyStructure context term otherContent =
511 case otherContent of
512 Error ->
513 return ()
515 Var Flex Nothing _ ->
516 merge context (Structure term)
518 Var Flex (Just super) _ ->
519 unifySuper (reorient context) super (Structure term)
521 Var Rigid _ maybeName ->
522 rigidityError context maybeName
524 Atom _ ->
525 mismatch context Nothing
527 Alias _ _ realVar ->
528 subUnify context (_first context) realVar
530 Structure otherTerm ->
531 case (term, otherTerm) of
532 (App1 func arg, App1 otherFunc otherArg) ->
533 do merge context otherContent
534 subUnify context func otherFunc
535 subUnify context arg otherArg
537 (Fun1 arg result, Fun1 otherArg otherResult) ->
538 do merge context otherContent
539 subUnify context arg otherArg
540 subUnify context result otherResult
542 (EmptyRecord1, EmptyRecord1) ->
543 merge context otherContent
545 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
546 subUnify context ext (_second context)
548 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
549 subUnify context (_first context) ext
551 (Record1 fields extension, Record1 otherFields otherExtension) ->
552 do firstStructure <- gatherFields context fields extension
553 secondStructure <- gatherFields context otherFields otherExtension
554 unifyRecord context firstStructure secondStructure
556 _ ->
557 mismatch context Nothing
561-- UNIFY RECORDS
564unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
565unifyRecord context firstStructure secondStructure =
566 do let (RecordStructure expFields expVar expStruct) = firstStructure
567 let (RecordStructure actFields actVar actStruct) = secondStructure
569 -- call after unifying extension, make sure record shape matches before
570 -- looking into whether the particular field types match.
571 let unifySharedFields otherFields ext =
572 do let sharedFields = Map.intersectionWith (,) expFields actFields
573 _ <- traverse (uncurry (subUnify context)) sharedFields
574 let allFields = Map.union (Map.map fst sharedFields) otherFields
575 merge context (Structure (Record1 allFields ext))
577 let uniqueExpFields = Map.difference expFields actFields
578 let uniqueActFields = Map.difference actFields expFields
580 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
581 (_, True, _, True) ->
582 do subUnify context expVar actVar
583 unifySharedFields Map.empty expVar
585 (Empty, _, _, False) ->
586 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
588 (_, False, Empty, _) ->
589 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
591 (_, False, _, True) ->
592 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
593 subUnify context subRecord actVar
594 unifySharedFields Map.empty subRecord
596 (_, True, _, False) ->
597 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
598 subUnify context expVar subRecord
599 unifySharedFields Map.empty subRecord
601 (Extension, False, Extension, False) ->
602 do let subFields = Map.union uniqueExpFields uniqueActFields
603 subExt <- fresh context (Var Flex Nothing Nothing)
604 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
605 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
606 subUnify context expVar expRecord
607 subUnify context actRecord actVar
608 unifySharedFields subFields subExt
612-- GATHER RECORD STRUCTURE
615data RecordStructure = RecordStructure
616 { _fields :: Map.Map String Variable
617 , _extVar :: Variable
618 , _extStruct :: ExtensionStructure
619 }
622data ExtensionStructure
623 = Empty
624 | Extension
627gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
628gatherFields context fields variable =
629 do desc <- liftIO (UF.descriptor variable)
630 case _content desc of
631 Structure (Record1 subFields subExt) ->
632 gatherFields context (Map.union fields subFields) subExt
634 Structure EmptyRecord1 ->
635 return (RecordStructure fields variable Empty)
637 Alias _ _ var ->
638 -- TODO may be dropping useful alias info here
639 gatherFields context fields var
641 _ ->
642 return (RecordStructure fields variable Extension)