git.iko.soy/elk
on 780ee73 help sign in
elk/src/Type/Unify.hs
634 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 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 Nothing
458 Alias _ _ realVar ->
459 subUnify context (_first context) realVar
461 Structure _ ->
462 mismatch context Nothing
466-- UNIFY ALIASES
468unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()
469unifyAlias context name args realVar otherContent =
470 case otherContent of
471 Error ->
472 return ()
474 Var Flex Nothing _ ->
475 merge context (Alias name args realVar)
477 Var _ _ _ ->
478 subUnify context realVar (_second context)
480 Atom _ ->
481 subUnify context realVar (_second context)
484 Alias otherName otherArgs otherRealVar ->
485 if name == otherName then
486 do merge context otherContent
487 zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
489 else
490 subUnify context realVar otherRealVar
492 Structure _ ->
493 subUnify context realVar (_second context)
497-- UNIFY STRUCTURES
500unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()
501unifyStructure context term otherContent =
502 case otherContent of
503 Error ->
504 return ()
506 Var Flex Nothing _ ->
507 merge context (Structure term)
509 Var Flex (Just super) _ ->
510 unifySuper (reorient context) super (Structure term)
512 Var Rigid _ maybeName ->
513 rigidityError context maybeName
515 Atom _ ->
516 mismatch context Nothing
518 Alias _ _ realVar ->
519 subUnify context (_first context) realVar
521 Structure otherTerm ->
522 case (term, otherTerm) of
523 (App1 func arg, App1 otherFunc otherArg) ->
524 do merge context otherContent
525 subUnify context func otherFunc
526 subUnify context arg otherArg
528 (Fun1 arg result, Fun1 otherArg otherResult) ->
529 do merge context otherContent
530 subUnify context arg otherArg
531 subUnify context result otherResult
533 (EmptyRecord1, EmptyRecord1) ->
534 merge context otherContent
536 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
537 subUnify context ext (_second context)
539 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
540 subUnify context (_first context) ext
542 (Record1 fields extension, Record1 otherFields otherExtension) ->
543 do firstStructure <- gatherFields context fields extension
544 secondStructure <- gatherFields context otherFields otherExtension
545 unifyRecord context firstStructure secondStructure
547 _ ->
548 mismatch context Nothing
552-- UNIFY RECORDS
555unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
556unifyRecord context firstStructure secondStructure =
557 do let (RecordStructure expFields expVar expStruct) = firstStructure
558 let (RecordStructure actFields actVar actStruct) = secondStructure
560 -- call after unifying extension, make sure record shape matches before
561 -- looking into whether the particular field types match.
562 let unifySharedFields otherFields ext =
563 do let sharedFields = Map.intersectionWith (,) expFields actFields
564 _ <- traverse (uncurry (subUnify context)) sharedFields
565 let allFields = Map.union (Map.map fst sharedFields) otherFields
566 merge context (Structure (Record1 allFields ext))
568 let uniqueExpFields = Map.difference expFields actFields
569 let uniqueActFields = Map.difference actFields expFields
571 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
572 (_, True, _, True) ->
573 do subUnify context expVar actVar
574 unifySharedFields Map.empty expVar
576 (Empty, _, _, False) ->
577 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
579 (_, False, Empty, _) ->
580 mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))
582 (_, False, _, True) ->
583 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
584 subUnify context subRecord actVar
585 unifySharedFields Map.empty subRecord
587 (_, True, _, False) ->
588 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
589 subUnify context expVar subRecord
590 unifySharedFields Map.empty subRecord
592 (Extension, False, Extension, False) ->
593 do let subFields = Map.union uniqueExpFields uniqueActFields
594 subExt <- fresh context (Var Flex Nothing Nothing)
595 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
596 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
597 subUnify context expVar expRecord
598 subUnify context actRecord actVar
599 unifySharedFields subFields subExt
603-- GATHER RECORD STRUCTURE
606data RecordStructure = RecordStructure
607 { _fields :: Map.Map String Variable
608 , _extVar :: Variable
609 , _extStruct :: ExtensionStructure
610 }
613data ExtensionStructure
614 = Empty
615 | Extension
618gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure
619gatherFields context fields variable =
620 do desc <- liftIO (UF.descriptor variable)
621 case _content desc of
622 Structure (Record1 subFields subExt) ->
623 gatherFields context (Map.union fields subFields) subExt
625 Structure EmptyRecord1 ->
626 return (RecordStructure fields variable Empty)
628 Alias _ _ var ->
629 -- TODO may be dropping useful alias info here
630 gatherFields context fields var
632 _ ->
633 return (RecordStructure fields variable Extension)