@@ -1,15 +1,12 @@
11{-# OPTIONS_GHC -Wall #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings, Rank2Types #-}
33module Type.Unify (unify) where
44
5−import Control.Monad (liftM2, when, zipWithM_)
6−import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)
5+import Control.Monad (foldM, liftM2, zipWithM_)
6+import Control.Monad.Trans (liftIO)
77import qualified Data.Map.Strict as Map
8−import qualified Data.Maybe as Maybe
9−import Data.Text (Text)
108
119import qualified AST.Module.Name as ModuleName
12−import AST.Type (Super(..))
1310import qualified Elm.Name as N
1411import qualified Reporting.Region as R
1512import qualified Reporting.Error.Type as Error
@@ -23,34 +20,105 @@ import qualified Type.UnionFind as UF
2320-- UNIFY
2421
2522
26−unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()
27−unify hint region expected actual =
28− {-# SCC elm_compiler_type_unify #-}
29− do result <- runExceptT (guardedUnify ExpectedActual expected actual)
30− case result of
31− Right () ->
32− return ()
23+unify :: R.Region -> Variable -> Variable -> TS.Solver ()
24+unify region actual expected =
25+ do answer <- run (guardedUnify ActualExpected actual expected)
26+ case answer of
27+ Ok ->
28+ return ()
3329
34− Left problem ->
35− do expectedSrcType <- liftIO $ Type.toSrcType expected
36− actualSrcType <- liftIO $ Type.toSrcType actual
37− liftIO $ mergeHelp expected actual (Error "?") noRank
30+ Err problem ->
31+ do actualSrcType <- liftIO $ Type.toSrcType actual
32+ expectedSrcType <- liftIO $ Type.toSrcType expected
33+ liftIO $ mergeHelp actual expected (Error "?") noRank
3834 TS.addError region $
3935 case problem of
4036 Reason hasDecoder maybeReason ->
41− Error.Mismatch $
42− Error.MismatchInfo hint expectedSrcType actualSrcType hasDecoder maybeReason
37+ Error.MismatchExpr $
38+ Error.MismatchInfo actualSrcType expectedSrcType hasDecoder maybeReason
4339
4440 Infinite ->
45− Error.InfiniteType (Left hint) expectedSrcType
41+ Error.InfiniteType actualSrcType
4642
4743
44+data Answer = Ok | Err Problem
45+
46+
47+run :: Unify () -> TS.Solver Answer
48+run (Unify k) =
49+ do (vars, answer) <-
50+ liftIO $ k []
51+ (\vars () -> return (vars, Ok))
52+ (\vars p -> return (vars, Err p))
53+ TS.introduce vars
54+ return answer
55+
56+
57+
58+-- CPS UNIFIER
59+
60+
61+newtype Unify a =
62+ Unify (forall r.
63+ [Variable]
64+ -> ([Variable] -> a -> IO r)
65+ -> ([Variable] -> Problem -> IO r)
66+ -> IO r
67+ )
4868
49−-- UNIFICATION HELPERS
5069
70+instance Functor Unify where
71+ fmap func (Unify kv) =
72+ Unify $ \vars ok err ->
73+ let
74+ ok1 vars1 value =
75+ ok vars1 (func value)
76+ in
77+ kv vars ok1 err
5178
52−type Unify =
53− ExceptT Problem TS.Solver
79+
80+instance Applicative Unify where
81+ pure a =
82+ Unify $ \vars ok _ ->
83+ ok vars a
84+
85+ (<*>) (Unify kf) (Unify kv) =
86+ Unify $ \vars ok err ->
87+ let
88+ ok1 vars1 func =
89+ let
90+ ok2 vars2 value =
91+ ok vars2 (func value)
92+ in
93+ kv vars1 ok2 err
94+ in
95+ kf vars ok1 err
96+
97+
98+instance Monad Unify where
99+ return a =
100+ Unify $ \vars ok _ ->
101+ ok vars a
102+
103+ (>>=) (Unify ka) callback =
104+ Unify $ \vars ok err ->
105+ let
106+ ok1 vars1 a =
107+ case callback a of
108+ Unify kb -> kb vars1 ok err
109+ in
110+ ka vars ok1 err
111+
112+
113+register :: IO Variable -> Unify Variable
114+register mkVar =
115+ Unify $ \vars ok _ ->
116+ do var <- mkVar
117+ ok (var:vars) var
118+
119+
120+
121+-- UNIFICATION HELPERS
54122
55123
56124data Context =
@@ -90,30 +158,37 @@ data Problem
90158
91159mismatch :: Context -> Maybe Error.Reason -> Unify a
92160mismatch context@(Context orientation var1 _ var2 _) maybeReason =
93− do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
94− when anyInfinite $ throwError Infinite
95−
96− args1 <- liftIO $ collectArgs [] var1
97− args2 <- liftIO $ collectArgs [] var2
98−
99− hasDecoder <- liftIO $ or <$> traverse detectDecoder (args1 ++ args2)
100−
101− if length args1 /= length args2
102− then
103− do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2
104− throwError $ Reason hasDecoder $ Just $
105− Error.MissingArgs (abs (length args2 - length args1))
106− else
107− throwError $ Reason hasDecoder $
108− case orientation of
109− ExpectedActual ->
110− maybeReason
111−
112− ActualExpected ->
113− fmap Error.flipReason maybeReason
114−
115−
116−
161+ Unify $ \vars _ err ->
162+ do anyInfinite <- liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
163+ if anyInfinite
164+ then err vars Infinite
165+ else
166+ do args1 <- collectArgs [] var1
167+ args2 <- collectArgs [] var2
168+
169+ hasDecoder <-
170+ or <$> traverse detectDecoder (args1 ++ args2)
171+
172+ if length args1 /= length args2
173+ then
174+ do newVars <- foldM (subUnifyAnyway context) vars (zip args1 args2)
175+ err newVars $ Reason hasDecoder $ Just $
176+ Error.MissingArgs (abs (length args2 - length args1))
177+ else
178+ err vars $ Reason hasDecoder $
179+ case orientation of
180+ ExpectedActual ->
181+ maybeReason
182+
183+ ActualExpected ->
184+ fmap Error.flipReason maybeReason
185+
186+
187+subUnifyAnyway :: Context -> [Variable] -> (Variable, Variable) -> IO [Variable]
188+subUnifyAnyway context vars (arg1, arg2) =
189+ case subUnify context arg1 arg2 of
190+ Unify k ->
191+ k vars (\vs _ -> return vs) (\vs _ -> return vs)
117192
118193
119194collectArgs :: [Variable] -> Variable -> IO [Variable]
@@ -144,7 +219,8 @@ detectDecoder variable =
144219
145220merge :: Context -> Content -> Unify ()
146221merge (Context _ var1 (Descriptor _ rank1 _ _) var2 (Descriptor _ rank2 _ _)) content =
147− liftIO $ mergeHelp var1 var2 content (min rank1 rank2)
222+ Unify $ \vars ok _ ->
223+ ok vars =<< mergeHelp var1 var2 content (min rank1 rank2)
148224
149225
150226mergeHelp :: Variable -> Variable -> Content -> Int -> IO ()
@@ -155,13 +231,8 @@ mergeHelp var1 var2 newContent newRank =
155231
156232fresh :: Context -> Content -> Unify Variable
157233fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content =
158− do freshVariable <-
159− liftIO $ UF.fresh $
160− Descriptor content (min rank1 rank2) noMark Nothing
161−
162− lift $ TS.register freshVariable
163−
164− return freshVariable
234+ register $ UF.fresh $
235+ Descriptor content (min rank1 rank2) noMark Nothing
165236
166237
167238
@@ -170,13 +241,16 @@ fresh (Context _ _ (Descriptor _ rank1 _ _) _ (Descriptor _ rank2 _ _)) content
170241
171242guardedUnify :: Orientation -> Variable -> Variable -> Unify ()
172243guardedUnify orientation left right =
173− do equivalent <- liftIO $ UF.equivalent left right
174− if equivalent
175− then return ()
176− else
177− do leftDesc <- liftIO $ UF.descriptor left
178− rightDesc <- liftIO $ UF.descriptor right
179− actuallyUnify (Context orientation left leftDesc right rightDesc)
244+ Unify $ \vars ok err ->
245+ do equivalent <- UF.equivalent left right
246+ if equivalent
247+ then ok vars ()
248+ else
249+ do leftDesc <- UF.descriptor left
250+ rightDesc <- UF.descriptor right
251+ case actuallyUnify (Context orientation left leftDesc right rightDesc) of
252+ Unify k ->
253+ k vars ok err
180254
181255
182256subUnify :: Context -> Variable -> Variable -> Unify ()
@@ -246,7 +320,7 @@ unifyFlex context otherContent =
246320-- UNIFY RIGID VARIABLES
247321
248322
249−unifyRigid :: Context -> Maybe Super -> Text -> Content -> Content -> Unify ()
323+unifyRigid :: Context -> Maybe SuperType -> N.Name -> Content -> Content -> Unify ()
250324unifyRigid context maybeSuper name content otherContent =
251325 case otherContent of
252326 FlexVar _ ->
@@ -313,7 +387,7 @@ flatTypeToSpecificThing flatType =
313387-- UNIFY SUPER VARIABLES
314388
315389
316−unifyFlexSuper :: Context -> Super -> Content -> Content -> Unify ()
390+unifyFlexSuper :: Context -> SuperType -> Content -> Content -> Unify ()
317391unifyFlexSuper context super content otherContent =
318392 case otherContent of
319393 Structure flatType ->
@@ -369,14 +443,14 @@ unifyFlexSuper context super content otherContent =
369443 return ()
370444
371445
372−combineRigidSupers :: Super -> Super -> Bool
446+combineRigidSupers :: SuperType -> SuperType -> Bool
373447combineRigidSupers rigid flex =
374448 rigid == flex
375449 || (rigid == Number && flex == Comparable)
376450 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))
377451
378452
379−atomMatchesSuper :: Super -> ModuleName.Canonical -> N.Name -> Bool
453+atomMatchesSuper :: SuperType -> ModuleName.Canonical -> N.Name -> Bool
380454atomMatchesSuper super home name =
381455 home == ModuleName.basics
382456 &&
@@ -398,7 +472,7 @@ atomMatchesSuper super home name =
398472 name == N.string
399473
400474
401−unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()
475+unifyFlexSuperStructure :: Context -> SuperType -> FlatType -> Unify ()
402476unifyFlexSuperStructure context super flatType =
403477 case flatType of
404478 App1 home name [] ->
@@ -457,20 +531,18 @@ unifyFlexSuperStructure context super flatType =
457531-- Do type classes require occurs checks?
458532comparableOccursCheck :: Context -> Unify ()
459533comparableOccursCheck (Context _ _ _ var _) =
460− do hasOccurred <- liftIO $ Occurs.occurs var
461− if hasOccurred
462− then throwError Infinite
463− else return ()
534+ Unify $ \vars ok err ->
535+ do hasOccurred <- Occurs.occurs var
536+ if hasOccurred
537+ then err vars Infinite
538+ else ok vars ()
464539
465540
466541unifyComparableRecursive :: Orientation -> Variable -> Unify ()
467542unifyComparableRecursive orientation var =
468− do compVar <- liftIO $
543+ do compVar <- register $
469544 do (Descriptor _ rank _ _) <- UF.descriptor var
470545 UF.fresh $ Descriptor (Type.unnamedFlexSuper Comparable) rank noMark Nothing
471−
472− lift $ TS.register compVar
473−
474546 guardedUnify orientation compVar var
475547
476548
@@ -478,7 +550,7 @@ unifyComparableRecursive orientation var =
478550-- UNIFY ALIASES
479551
480552
481−unifyAlias :: Context -> ModuleName.Canonical -> N.Name -> [(Text, Variable)] -> Variable -> Content -> Unify ()
553+unifyAlias :: Context -> ModuleName.Canonical -> N.Name -> [(N.Name, Variable)] -> Variable -> Content -> Unify ()
482554unifyAlias context home name args realVar otherContent =
483555 case otherContent of
484556 FlexVar _ ->
@@ -558,9 +630,12 @@ unifyStructure context flatType content otherContent =
558630 subUnify context (_first context) ext
559631
560632 (Record1 fields extension, Record1 otherFields otherExtension) ->
561− do firstStructure <- liftIO $ gatherFields context fields extension
562− secondStructure <- liftIO $ gatherFields context otherFields otherExtension
563− unifyRecord context firstStructure secondStructure
633+ Unify $ \vars ok err ->
634+ do firstStructure <- gatherFields context fields extension
635+ secondStructure <- gatherFields context otherFields otherExtension
636+ case unifyRecord context firstStructure secondStructure of
637+ Unify k ->
638+ k vars ok err
564639
565640 _ ->
566641 mismatch context Nothing
@@ -636,32 +711,33 @@ unifyRecord context firstStructure secondStructure =
636711
637712
638713
639−unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()
714+unifySharedFieldsHelp :: Context -> Map.Map N.Name (Variable, Variable) -> Unify ()
640715unifySharedFieldsHelp context sharedFields =
641− do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)
642− case Maybe.catMaybes maybeBadFields of
716+ do badFields <- Map.traverseMaybeWithKey (unifyField context) sharedFields
717+ case Map.toList badFields of
643718 [] ->
644719 return ()
645720
646− badFields ->
647− mismatch context (Just (Error.BadFields (reverse badFields)))
648−
721+ badFieldPairs ->
722+ mismatch context (Just (Error.BadFields badFieldPairs))
649723
650−unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (Text, Maybe Error.Reason))
651−unifyField context (field, (expected, actual)) =
652− do result <- lift $ runExceptT $ subUnify context expected actual
653− case result of
654− Right () ->
655− return $ Nothing
656724
657− Left problem ->
658− return $ Just $ (,) field $
659− case problem of
660− Reason _ reason ->
661− reason
725+unifyField :: Context -> N.Name -> (Variable, Variable) -> Unify (Maybe (Maybe Error.Reason))
726+unifyField context _ (actual, expected) =
727+ Unify $ \vars ok _ ->
728+ case subUnify context actual expected of
729+ Unify k ->
730+ k vars
731+ (\vs () -> ok vs Nothing)
732+ (\vs problem ->
733+ ok vs $ Just $
734+ case problem of
735+ Reason _ reason ->
736+ reason
662737
663− Infinite ->
664− Nothing
738+ Infinite ->
739+ Nothing
740+ )
665741
666742
667743
@@ -670,7 +746,7 @@ unifyField context (field, (expected, actual)) =
670746
671747data RecordStructure =
672748 RecordStructure
673− { _fields :: Map.Map Text Variable
749+ { _fields :: Map.Map N.Name Variable
674750 , _extVar :: Variable
675751 , _extStruct :: ExtensionStructure
676752 }
@@ -681,7 +757,7 @@ data ExtensionStructure
681757 | Extension
682758
683759
684−gatherFields :: Context -> Map.Map Text Variable -> Variable -> IO RecordStructure
760+gatherFields :: Context -> Map.Map N.Name Variable -> Variable -> IO RecordStructure
685761gatherFields context fields variable =
686762 do (Descriptor content _ _ _) <- UF.descriptor variable
687763 case content of