git.iko.soy/elk
on 09076eb help sign in
elk/src/Type/Unify.hs
665 lines 20 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Unify (unify) where
5import Control.Monad (liftM2, when, zipWithM_)
6import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
9import Data.Text (Text)
11import AST.Type (Super(..))
12import qualified AST.Variable as Var
13import qualified Reporting.Region as R
14import qualified Reporting.Error.Type as Error
15import qualified Type.Occurs as Occurs
16import qualified Type.State as TS
17import Type.Type as Type
18import qualified Type.UnionFind as UF
22-- KICK OFF UNIFICATION
25unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
26unify hint region expected actual =
27 {-# SCC elm_compiler_type_unify #-}
28 do result <- runExceptT (guardedUnify ExpectedActual expected actual)
29 case result of
30 Right () ->
31 return ()
33 Left problem ->
34 do expectedSrcType <- liftIO $ Type.toSrcType expected
35 actualSrcType <- liftIO $ Type.toSrcType actual
36 liftIO $ mergeHelp expected actual (Error "?") noRank
37 TS.addError region $
38 case problem of
39 Typical ->
40 Error.Mismatch $
41 Error.MismatchInfo hint expectedSrcType actualSrcType Nothing
43 Special reason ->
44 Error.Mismatch $
45 Error.MismatchInfo hint expectedSrcType actualSrcType (Just reason)
47 Infinite ->
48 Error.InfiniteType (Left hint) expectedSrcType
52-- UNIFICATION HELPERS
55type Unify =
56 ExceptT Problem TS.Solver
59data Context =
60 Context
61 { _orientation :: Orientation
62 , _first :: Variable
63 , _firstDesc :: Descriptor
64 , _second :: Variable
65 , _secondDesc :: Descriptor
66 }
69data Orientation = ExpectedActual | ActualExpected
72reorient :: Context -> Context
73reorient (Context orientation var1 desc1 var2 desc2) =
74 let
75 otherOrientation =
76 case orientation of
77 ExpectedActual -> ActualExpected
78 ActualExpected -> ExpectedActual
79 in
80 Context otherOrientation var2 desc2 var1 desc1
84-- ERROR MESSAGES
87data Problem
88 = Typical
89 | Special Error.Reason
90 | Infinite
93mismatch :: Context -> Maybe Error.Reason -> Unify a
94mismatch context@(Context orientation var1 _ var2 _) maybeReason =
95 do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
96 when anyInfinite $ throwError Infinite
98 args1 <- liftIO $ collectArgs var1
99 args2 <- liftIO $ collectArgs var2
101 let numArgs1 = length args1
102 let numArgs2 = length args2
104 if numArgs1 == numArgs2
105 then
106 throwError $ reasonToProblem orientation maybeReason
107 else
108 do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2
109 throwError $ reasonToProblem orientation $ Just $
110 Error.MissingArgs $ abs (numArgs2 - numArgs1)
113reasonToProblem :: Orientation -> Maybe Error.Reason -> Problem
114reasonToProblem orientation maybeReason =
115 case maybeReason of
116 Nothing ->
117 Typical
119 Just reason ->
120 case orientation of
121 ExpectedActual ->
122 Special reason
124 ActualExpected ->
125 Special (Error.flipReason reason)
128badRigid :: Maybe Text -> Error.Reason
129badRigid maybeName =
130 Error.BadVar (Just (Error.Rigid maybeName)) Nothing
133badSuper :: Super -> Error.Reason
134badSuper super =
135 Error.BadVar (Just (errorSuper super)) Nothing
138badSupers :: Super -> Super -> Error.Reason
139badSupers super1 super2 =
140 Error.BadVar (Just (errorSuper super1)) (Just (errorSuper super2))
143doubleBad :: Error.VarType -> Error.VarType -> Error.Reason
144doubleBad vt1 vt2 =
145 Error.BadVar (Just vt1) (Just vt2)
148errorSuper :: Super -> Error.VarType
149errorSuper super =
150 case super of
151 Number ->
152 Error.Number
154 Comparable ->
155 Error.Comparable
157 Appendable ->
158 Error.Appendable
160 CompAppend ->
161 Error.CompAppend
165-- MERGE
168merge :: Context -> Content -> Unify ()
169merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
170 liftIO $ mergeHelp var1 var2 content (min rank1 rank2)
173mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
174mergeHelp var1 var2 newContent newRank =
175 UF.union var1 var2 $
176 Descriptor newContent newRank noMark Nothing
179fresh :: Context -> Content -> Unify Variable
180fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
181 do freshVariable <-
182 liftIO $ UF.fresh $
183 Descriptor content (min rank1 rank2) noMark Nothing
184 lift (TS.register freshVariable)
188-- ACTUALLY UNIFY THINGS
191guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
192guardedUnify orientation left right =
193 do equivalent <- liftIO $ UF.equivalent left right
194 if equivalent
195 then return ()
196 else
197 do leftDesc <- liftIO $ UF.descriptor left
198 rightDesc <- liftIO $ UF.descriptor right
199 actuallyUnify (Context orientation left leftDesc right rightDesc)
202subUnify :: Context -> Variable -> Variable -> Unify ()
203subUnify context var1 var2 =
204 guardedUnify (_orientation context) var1 var2
207actuallyUnify :: Context -> Unify ()
208actuallyUnify context@(Context _ _ (Descriptor firstContent _ _ _) _ (Descriptor secondContent _ _ _)) =
209 case firstContent of
210 Error _ ->
211 -- If there was an error, just pretend it is okay. This lets us avoid
212 -- "cascading" errors where one problem manifests as multiple message.
213 return ()
215 Var Flex Nothing _ ->
216 unifyFlex context secondContent
218 Var Flex (Just super) _ ->
219 unifyFlexSuper context super firstContent secondContent
221 Var Rigid maybeSuper maybeName ->
222 unifyRigid context maybeSuper maybeName firstContent secondContent
224 Alias name args realVar ->
225 unifyAlias context name args realVar secondContent
227 Structure term ->
228 unifyStructure context term firstContent secondContent
232-- UNIFY FLEXIBLE VARIABLES
235unifyFlex :: Context -> Content -> Unify ()
236unifyFlex context otherContent =
237 case otherContent of
238 Error _ ->
239 return ()
241 Var Flex _ _ ->
242 merge context otherContent
244 Var Rigid _ _ ->
245 merge context otherContent
247 Alias _ _ _ ->
248 merge context otherContent
250 Structure _ ->
251 merge context otherContent
255-- UNIFY RIGID VARIABLES
258unifyRigid :: Context -> Maybe Super -> Maybe Text -> Content -> Content -> Unify ()
259unifyRigid context maybeSuper maybeName content otherContent =
260 case otherContent of
261 Error _ ->
262 return ()
264 Var Flex otherMaybeSuper _ ->
265 case (maybeSuper, otherMaybeSuper) of
266 (_, Nothing) ->
267 merge context content
269 (Nothing, Just _) ->
270 mismatch context (Just (badRigid maybeName))
272 (Just super, Just otherSuper) ->
273 if combineRigidSupers super otherSuper then
274 merge context content
275 else
276 mismatch context (Just (badRigid maybeName))
278 Var Rigid _ otherMaybeName ->
279 mismatch context $ Just $
280 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)
282 Alias _ _ _ ->
283 mismatch context (Just (badRigid maybeName))
285 Structure _ ->
286 mismatch context (Just (badRigid maybeName))
290-- UNIFY SUPER VARIABLES
293unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
294unifyFlexSuper context super content otherContent =
295 case otherContent of
296 Structure term ->
297 unifyFlexSuperStructure context super term
299 Var Rigid Nothing maybeName ->
300 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))
302 Var Rigid (Just otherSuper) maybeName ->
303 if combineRigidSupers otherSuper super then
304 merge context otherContent
305 else
306 mismatch context $ Just $ badRigid maybeName
308 Var Flex Nothing _ ->
309 merge context content
311 Var Flex (Just otherSuper) _ ->
312 case super of
313 Number ->
314 case otherSuper of
315 Number -> merge context content
316 Comparable -> merge context content
317 _ -> mismatch context $ Just $ badSupers super otherSuper
319 Comparable ->
320 case otherSuper of
321 Comparable -> merge context otherContent
322 Number -> merge context otherContent
323 Appendable -> merge context (Var Flex (Just CompAppend) Nothing)
324 CompAppend -> merge context otherContent
326 Appendable ->
327 case otherSuper of
328 Appendable -> merge context otherContent
329 Comparable -> merge context (Var Flex (Just CompAppend) Nothing)
330 CompAppend -> merge context otherContent
331 Number -> mismatch context $ Just $ badSupers super otherSuper
333 CompAppend ->
334 case otherSuper of
335 Comparable -> merge context content
336 Appendable -> merge context content
337 CompAppend -> merge context content
338 Number -> mismatch context $ Just $ badSupers super otherSuper
340 Alias _ _ realVar ->
341 subUnify context (_first context) realVar
343 Error _ ->
344 return ()
347combineRigidSupers :: Super -> Super -> Bool
348combineRigidSupers rigid flex =
349 rigid == flex
350 || (rigid == Number && flex == Comparable)
351 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
354atomMatchesSuper :: Super -> Var.Canonical -> Bool
355atomMatchesSuper super name =
356 case super of
357 Number ->
358 elem name [ Var.int, Var.float ]
360 Comparable ->
361 elem name [ Var.string, Var.int, Var.float, Var.char]
363 Appendable ->
364 name == Var.string
366 CompAppend ->
367 name == Var.string
370unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
371unifyFlexSuperStructure context super term =
372 do case term of
373 App1 name [] ->
374 if atomMatchesSuper super name then
375 merge context (Structure term)
376 else
377 mismatch context (Just (badSuper super))
379 App1 name [variable] | name == Var.list ->
380 case super of
381 Number ->
382 mismatch context (Just (badSuper super))
384 Appendable ->
385 merge context (Structure term)
387 Comparable ->
388 do comparableOccursCheck context
389 merge context (Structure term)
390 unifyComparableRecursive (_orientation context) variable
392 CompAppend ->
393 do comparableOccursCheck context
394 merge context (Structure term)
395 unifyComparableRecursive (_orientation context) variable
397 App1 name args | Var.isTuple name ->
398 case super of
399 Number ->
400 mismatch context (Just (badSuper super))
402 Appendable ->
403 mismatch context (Just (badSuper super))
405 Comparable ->
406 if length args > 6 then
407 mismatch context (Just (Error.TooLongComparableTuple (length args)))
409 else
410 do comparableOccursCheck context
411 merge context (Structure term)
412 mapM_ (unifyComparableRecursive (_orientation context)) args
414 CompAppend ->
415 mismatch context (Just (badSuper super))
417 _ ->
418 mismatch context (Just (badSuper super))
421-- TODO: is there some way to avoid doing this?
422-- Do type classes require occurs checks?
423comparableOccursCheck :: Context -> Unify ()
424comparableOccursCheck (Context _ _ _ var _) =
425 do hasOccurred <- liftIO $ Occurs.occurs var
426 if hasOccurred
427 then throwError Infinite
428 else return ()
431unifyComparableRecursive :: Orientation -> Variable -> Unify ()
432unifyComparableRecursive orientation var =
433 do compVar <- liftIO $
434 do (Descriptor _ rank _ _) <- UF.descriptor var
435 UF.fresh $ Descriptor (Var Flex (Just Comparable) Nothing) rank noMark Nothing
437 guardedUnify orientation compVar var
440collectArgs :: Variable -> IO [Variable]
441collectArgs variable =
442 collectArgsHelp [] variable
445collectArgsHelp :: [Variable] -> Variable -> IO [Variable]
446collectArgsHelp revArgs variable =
447 do (Descriptor content _ _ _) <- UF.descriptor variable
448 case content of
449 Structure (Fun1 arg returnType) ->
450 collectArgsHelp (arg : revArgs) returnType
452 _ ->
453 return $ variable : revArgs
457-- UNIFY ALIASES
460unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()
461unifyAlias context name args realVar otherContent =
462 case otherContent of
463 Error _ ->
464 return ()
466 Var Flex Nothing _ ->
467 merge context (Alias name args realVar)
469 Var _ _ _ ->
470 subUnify context realVar (_second context)
472 Alias otherName otherArgs otherRealVar ->
473 if name == otherName then
474 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)
475 merge context otherContent
477 else
478 subUnify context realVar otherRealVar
480 Structure _ ->
481 subUnify context realVar (_second context)
485-- UNIFY STRUCTURES
488unifyStructure :: Context -> FlatType -> Content -> Content -> Unify ()
489unifyStructure context term content otherContent =
490 case otherContent of
491 Error _ ->
492 return ()
494 Var Flex Nothing _ ->
495 merge context content
497 Var Flex (Just super) _ ->
498 unifyFlexSuperStructure (reorient context) super term
500 Var Rigid _ maybeName ->
501 mismatch context (Just (Error.flipReason (badRigid maybeName)))
503 Alias _ _ realVar ->
504 subUnify context (_first context) realVar
506 Structure otherTerm ->
507 case (term, otherTerm) of
508 (App1 name args, App1 otherName otherArgs) ->
509 if name == otherName then
510 do zipWithM_ (subUnify context) args otherArgs
511 merge context otherContent
513 else if isIntFloat name otherName || isIntFloat otherName name then
514 mismatch context (Just Error.IntFloat)
516 else
517 mismatch context Nothing
519 (Fun1 arg result, Fun1 otherArg otherResult) ->
520 do subUnify context arg otherArg
521 subUnify context result otherResult
522 merge context otherContent
524 (EmptyRecord1, EmptyRecord1) ->
525 merge context otherContent
527 (Record1 fields ext, EmptyRecord1) | Map.null fields ->
528 subUnify context ext (_second context)
530 (EmptyRecord1, Record1 fields ext) | Map.null fields ->
531 subUnify context (_first context) ext
533 (Record1 fields extension, Record1 otherFields otherExtension) ->
534 do firstStructure <- liftIO $ gatherFields context fields extension
535 secondStructure <- liftIO $ gatherFields context otherFields otherExtension
536 unifyRecord context firstStructure secondStructure
538 _ ->
539 mismatch context Nothing
542isIntFloat :: Var.Canonical -> Var.Canonical -> Bool
543isIntFloat name otherName =
544 Var.isPrim "Int" name && Var.isPrim "Float" otherName
548-- UNIFY RECORDS
551unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()
552unifyRecord context firstStructure secondStructure =
553 do let (RecordStructure expFields expVar expStruct) = firstStructure
554 let (RecordStructure actFields actVar actStruct) = secondStructure
556 let sharedFields = Map.intersectionWith (,) expFields actFields
558 -- call after unifying extension, make sure record shape matches before
559 -- looking into whether the particular field types match.
560 let unifySharedFields otherFields ext =
561 do unifySharedFieldsHelp context sharedFields
562 let allFields = Map.union (Map.map fst sharedFields) otherFields
563 merge context (Structure (Record1 allFields ext))
565 let uniqueExpFields = Map.difference expFields actFields
566 let uniqueActFields = Map.difference actFields expFields
568 case (expStruct, Map.null uniqueExpFields, actStruct, Map.null uniqueActFields) of
569 (_, True, _, True) ->
570 do subUnify context expVar actVar
571 unifySharedFields Map.empty expVar
573 (Empty, _, _, False) ->
574 mismatch context $ Just $
575 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
577 (_, False, Empty, _) ->
578 mismatch context $ Just $
579 Error.MessyFields (Map.keys sharedFields) (Map.keys uniqueExpFields) (Map.keys uniqueActFields)
581 (_, False, _, True) ->
582 do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))
583 subUnify context subRecord actVar
584 unifySharedFields Map.empty subRecord
586 (_, True, _, False) ->
587 do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))
588 subUnify context expVar subRecord
589 unifySharedFields Map.empty subRecord
591 (Extension, False, Extension, False) ->
592 do let subFields = Map.union uniqueExpFields uniqueActFields
593 subExt <- fresh context (Var Flex Nothing Nothing)
594 expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))
595 actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))
596 subUnify context expVar expRecord
597 subUnify context actRecord actVar
598 unifySharedFields subFields subExt
602unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()
603unifySharedFieldsHelp context sharedFields =
604 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
605 case Maybe.catMaybes maybeBadFields of
606 [] ->
607 return ()
609 badFields ->
610 mismatch context (Just (Error.BadFields (reverse badFields)))
613unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))
614unifyField context (field, (expected, actual)) =
615 do result <- lift $ runExceptT $ subUnify context expected actual
616 case result of
617 Right () ->
618 return $ Nothing
620 Left problem ->
621 return $ Just $ (,) field $
622 case problem of
623 Typical ->
624 Nothing
626 Special reason ->
627 Just reason
629 Infinite ->
630 Nothing
634-- GATHER RECORD STRUCTURE
637data RecordStructure = RecordStructure
638 { _fields :: Map.Map Text Variable
639 , _extVar :: Variable
640 , _extStruct :: ExtensionStructure
641 }
644data ExtensionStructure
645 = Empty
646 | Extension
649gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure
650gatherFields context fields variable =
651 do (Descriptor content _ _ _) <- UF.descriptor variable
652 case content of
653 Structure (Record1 subFields subExt) ->
654 gatherFields context (Map.union fields subFields) subExt
656 Structure EmptyRecord1 ->
657 return (RecordStructure fields variable Empty)
659 Alias _ _ var ->
660 -- TODO may be dropping useful alias info here
661 gatherFields context fields var
663 _ ->
664 return (RecordStructure fields variable Extension)