git.iko.soy/elk
on 74db13f help sign in
elk/src/Type/Unify.hs
633 lines 17 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 rigidityError context maybeName
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 Nothing
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
300isPrimitiveFrom :: [String] -> Var.Canonical -> Bool
301isPrimitiveFrom prims var =
302 any (\p -> Var.isPrim p var) prims
305atomMatchesSuper :: Super -> Var.Canonical -> Bool
306atomMatchesSuper super name =
307 case super of
308 Number ->
309 isPrimitiveFrom ["Int", "Float"] name
311 Comparable ->
312 isPrimitiveFrom ["Int", "Float", "Char", "String"] name
314 Appendable ->
315 Var.isPrim "String" name || Var.isText name
317 CompAppend ->
318 Var.isPrim "String" name
321unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()
322unifySuperStructure context super term =
323 do appStructure <- liftIO (collectApps (Structure term))
324 case appStructure of
325 Other ->
326 mismatch context Nothing
328 List variable ->
329 case super of
330 Number ->
331 mismatch context Nothing
333 Appendable ->
334 merge context (Structure term)
336 Comparable ->
337 do merge context (Structure term)
338 unifyComparableRecursive (_orientation context) variable
340 CompAppend ->
341 do merge context (Structure term)
342 unifyComparableRecursive (_orientation context) variable
344 Tuple entries ->
345 case super of
346 Number ->
347 mismatch context Nothing
349 Appendable ->
350 mismatch context Nothing
352 Comparable ->
353 if length entries > 6 then
354 mismatch context (Just (Error.TooLongComparableTuple (length entries)))
356 else
357 do merge context (Structure term)
358 mapM_ (unifyComparableRecursive (_orientation context)) entries
360 CompAppend ->
361 mismatch context Nothing
364unifyComparableRecursive :: Orientation -> Variable -> Unify ()
365unifyComparableRecursive orientation var =
366 do compVar <-
367 liftIO $
368 do desc <- UF.descriptor var
369 UF.fresh $
370 Descriptor
371 { _content = Var Flex (Just Comparable) Nothing
372 , _rank = _rank desc
373 , _mark = noMark
374 , _copy = Nothing
375 }
377 guardedUnify orientation compVar var
380data AppStructure
381 = List Variable
382 | Tuple [Variable]
383 | Other
386collectApps :: Content -> IO AppStructure
387collectApps content =
388 collectAppsHelp [] content
391collectAppsHelp :: [Variable] -> Content -> IO AppStructure
392collectAppsHelp args content =
393 case (content, args) of
394 (Structure (App1 func arg), _) ->
395 collectAppsHelp (args ++ [arg]) =<< getContent func
397 (Atom name, [arg]) | Var.isList name ->
398 return (List arg)
400 (Atom name, _) | Var.isTuple name ->
401 return (Tuple args)
403 _ ->
404 return Other
407getContent :: Variable -> IO Content
408getContent variable =
409 _content <$> UF.descriptor variable
413-- UNIFY ATOMS
416unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()
417unifyAtom context name otherContent =
418 case otherContent of
419 Error ->
420 return ()
422 Var Flex Nothing _ ->
423 merge context (Atom name)
425 Var Flex (Just super) _ ->
426 if atomMatchesSuper super name then
427 merge context (Atom name)
429 else
430 mismatch context Nothing
432 Var Rigid _ maybeName ->
433 rigidityError context maybeName
435 Atom otherName ->
436 if name == otherName then
437 merge context otherContent
439 else
440 mismatch context Nothing
442 Alias _ _ realVar ->
443 subUnify context (_first context) realVar
445 Structure _ ->
446 mismatch context Nothing
450-- UNIFY ALIASES
452unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
453unifyAlias context name args realVar otherContent =
454 case otherContent of
455 Error ->
456 return ()
458 Var Flex Nothing _ ->
459 merge context (Alias name args realVar)
461 Var _ _ _ ->
462 subUnify context realVar (_second context)
464 Atom _ ->
465 subUnify context realVar (_second context)
468 Alias otherName otherArgs otherRealVar ->
469 if name == otherName then
470 do merge context otherContent
471 zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
473 else
474 subUnify context realVar otherRealVar
476 Structure _ ->
477 subUnify context realVar (_second context)
481-- UNIFY STRUCTURES
484unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
485unifyStructure context term otherContent =
486 case otherContent of
487 Error ->
488 return ()
490 Var Flex Nothing _ ->
491 merge context (Structure term)
493 Var Flex (Just super) _ ->
494 unifySuper (reorient context) super (Structure term)
496 Var Rigid _ maybeName ->
497 rigidityError context maybeName
499 Atom _ ->
500 mismatch context Nothing
502 Alias _ _ realVar ->
503 subUnify context (_first context) realVar
505 Structure otherTerm ->
506 case (term, otherTerm) of
507 (App1 func arg, App1 otherFunc otherArg) ->
508 do merge context otherContent
509 subUnify context func otherFunc
510 subUnify context arg otherArg
512 (Fun1 arg result, Fun1 otherArg otherResult) ->
513 do merge context otherContent
514 subUnify context arg otherArg
515 subUnify context result otherResult
517 (EmptyRecord1, EmptyRecord1) ->
518 merge context otherContent
520 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
521 subUnify context ext (_second context)
523 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
524 subUnify context (_first context) ext
526 (Record1 fields extension, Record1 otherFields otherExtension) ->
527 do firstStructure <- gatherFields context fields extension
528 secondStructure <- gatherFields context otherFields otherExtension
529 unifyRecord context firstStructure secondStructure
531 _ ->
532 mismatch context Nothing
536-- UNIFY RECORDS
539unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
540unifyRecord context firstStructure secondStructure =
541 do let (RecordStructure expFields expVar expStruct) = firstStructure
542 let (RecordStructure actFields actVar actStruct) = secondStructure
544 -- call after unifying extension, make sure record shape matches before
545 -- looking into whether the particular field types match.
546 let unifySharedFields otherFields ext =
547 do let sharedFields = Map.intersectionWith (,) expFields actFields
548 _ <- traverse (uncurry (subUnify context)) sharedFields
549 let allFields = Map.union (Map.map fst sharedFields) otherFields
550 merge context (Structure (Record1 allFields ext))
552 let uniqueExpFields = Map.difference expFields actFields
553 let uniqueActFields = Map.difference actFields expFields
555 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
556 (_, True, _, True) ->
557 do subUnify context expVar actVar
558 unifySharedFields Map.empty expVar
560 (Empty, _, _, False) ->
561 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
563 (_, False, Empty, _) ->
564 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
566 (_, False, _, True) ->
567 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
568 subUnify context subRecord actVar
569 unifySharedFields Map.empty subRecord
571 (_, True, _, False) ->
572 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
573 subUnify context expVar subRecord
574 unifySharedFields Map.empty subRecord
576 (Extension, False, Extension, False) ->
577 do let subFields = Map.union uniqueExpFields uniqueActFields
578 subExt <- fresh context (Var Flex Nothing Nothing)
579 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
580 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
581 subUnify context expVar expRecord
582 subUnify context actRecord actVar
583 unifySharedFields subFields subExt
587-- GATHER RECORD STRUCTURE
590data RecordStructure = RecordStructure
591 { _fields :: Map.Map String Variable
592 , _extVar :: Variable
593 , _extStruct :: ExtensionStructure
594 }
597data ExtensionStructure
598 = Empty
599 | Extension
602gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
603gatherFields context fields variable =
604 do desc <- liftIO (UF.descriptor variable)
605 case _content desc of
606 Structure (Record1 subFields subExt) ->
607 gatherFields context (Map.union fields subFields) subExt
609 Structure (EmptyRecord1) ->
610 return (RecordStructure fields variable Empty)
612 Structure (App1 _ _) ->
613 mismatch context (Just Error.NotRecord)
615 Structure (Fun1 _ _) ->
616 mismatch context (Just Error.NotRecord)
618 Atom _ ->
619 mismatch context (Just Error.NotRecord)
621 Var _ Nothing _ ->
622 return (RecordStructure fields variable Extension)
624 Var _ (Just _) _ ->
625 mismatch context (Just Error.NotRecord)
627 -- TODO may be dropping useful alias info here
628 Alias _ _ var ->
629 gatherFields context fields var
631 Error ->
632 return (RecordStructure fields variable Extension)