@@ -9,6 +9,7 @@ module Tix.Typechecker
99 )
1010where
1111
12+import Control.Exception (assert)
1213import Control.Monad
1314import Control.Monad.Freer
1415import Control.Monad.Freer.Fresh
@@ -38,6 +39,7 @@ import Data.Sequences
3839import Data.Set (Set)
3940import qualified Data.Set as S
4041import Data.Text (Text)
42+import qualified Data.Text as T
4143import qualified Data.Text.Lazy as TL
4244import Data.Text.Prettyprint.Doc as P
4345import Data.Text.Prettyprint.Doc.Render.Text
@@ -47,7 +49,7 @@ import Nix.Expr
4749import Nix.Pretty
4850import Tix.Types
4951
50−getType :: NExprLoc -> (NType, [(SrcSpan, Errors)], [UnifyingError], A.Object)
52+getType :: NExprLoc -> (Scheme, [(SrcSpan, Errors)], [UnifyingError], A.Object)
5153getType r =
5254 let ((((((t, traceTree), unifying), errs), srcs), subs), _) =
5355 run
@@ -72,7 +74,7 @@ runConstraintEnv =
7274 . runWriter @Substitution
7375 . interpret @SubstituteEnv
7476 ( \(SubstituteEnv x) -> do
75− modify @(Seq Constraint) (subCon x <$>)
77+ modify @(Seq Constraint) (sub x <$>)
7678 modify @VariableMap (sub x <$>)
7779 tell x
7880 return ()
@@ -84,7 +86,7 @@ data SubstituteEnv a where
8486subEnv :: Member SubstituteEnv r => Substitution -> Eff r ()
8587subEnv = send . SubstituteEnv
8688
87−data Constraint = !NType :~ !NType
89+data Constraint = !Scheme :~ !Scheme
8890 deriving stock (Eq, Ord, Show)
8991
9092instance Pretty Constraint where
@@ -98,7 +100,7 @@ instance Act DeBrujinContext DeBrujin where
98100
99101type TDeBrujinMap = ShiftedMap DeBrujinContext TypeVariable DeBrujin
100102
101−close :: Predicate TypeVariable -> NType -> NType
103+close :: Predicate TypeVariable -> Scheme -> Scheme
102104close (Predicate f) =
103105 run
104106 . evalState @TDeBrujinMap mempty
@@ -107,14 +109,19 @@ close (Predicate f) =
107109 . close'
108110 where
109111 -- State is the sequential number, Reader is the binding context number
110− close' :: NType -> Eff '[State Int, Reader Int, State TDeBrujinMap] NType
112+ close' :: Scheme -> Eff '[State Int, Reader Int, State TDeBrujinMap] Scheme
111113 close' x@(NAtomic _) = return x
112− close' x@(NBrujin _) = return x
113− close' (NTypeVariable tv) | f tv = NBrujin <$> newbrujin tv
114− close' x@(NTypeVariable _) = return x
115− close' (x :-> y) = bndCtx $ (:->) <$> close' x <*> close' y
116− close' (List x) = bndCtx $ List <$> close' x
117− close' (NAttrSet x) = bndCtx $ NAttrSet <$> traverse close' x
114+ close' (preds :=> t) =
115+ (:=>) <$> (closePred `traverse` preds) <*> case t of
116+ x@(NBrujin _) -> return x
117+ (NTypeVariable tv) | f tv -> NBrujin <$> newbrujin tv
118+ x@(NTypeVariable _) -> return x
119+ (x :-> y) -> bndCtx $ (:->) <$> close' x <*> close' y
120+ (List x) -> bndCtx $ List <$> close' x
121+ (NAttrSet x) -> bndCtx $ NAttrSet <$> traverse close' x
122+
123+ closePred :: Pred -> Eff '[State Int, Reader Int, State TDeBrujinMap] Pred
124+ closePred = \case
118125
119126 bndCtx m = do
120127 modify @TDeBrujinMap (SM.shift 1)
@@ -134,22 +141,54 @@ close (Predicate f) =
134141
135142class Free s where
136143 free :: s -> Set TypeVariable
144+ sub :: Substitution -> s -> s
137145
138146instance Free NType where
139147 free (NTypeVariable v) = S.singleton v
140− free (NAtomic _) = S.empty
141148 free (List x) = free x
142149 free (NAttrSet attrs) = foldMap free . M.elems $ attrs
143150 free (x :-> y) = free x <> free y
144151 free (NBrujin _) = S.empty
145152
153+ sub s r = case r of
154+ NBrujin _ -> r
155+ NTypeVariable x -> NTypeVariable x -- it should be substituted higher in Scheme
156+ List x -> List $ sub s x
157+ NAttrSet m -> NAttrSet $ sub s <$> m
158+ x :-> y -> sub s x :-> sub s y
159+
160+instance Free Pred
161+
162+-- free (x `Update` y) = free x <> free y
163+-- free (x `HasField` (_, y)) = free x <> free y
164+
165+-- sub s (x `Update` y) = sub s x `Update` sub s y
166+-- sub s (x `HasField` (t, y)) = sub s x `HasField` (t, sub s y)
167+
168+instance Free Scheme where
169+ free (x :=> y) = free x <> free y
170+ free (NAtomic _) = S.empty
171+ sub s (x :=> NTypeVariable tv) =
172+ case M.lookup tv $ unSubstitution s of
173+ Nothing -> sub s x :=> NTypeVariable tv
174+ Just (newCs :=> new) -> (sub s x <> newCs) :=> new
175+ Just a@(NAtomic _) -> assert (null x) a
176+ sub s (x :=> y) = sub s x :=> sub s y
177+ sub _ x@(NAtomic _) = x
178+
146179instance Free a => Free [a] where
147180 free = foldMap free
181+ sub s = fmap (sub s)
148182
149183instance Free Substitution where
150184 free (Substitution s) = free . M.elems $ s
185+ sub new old = old <> new
186+
187+instance (Free a, Free b) => Free (a, b) where
188+ free (a, b) = free a <> free b
189+ sub s (a, b) = (sub s a, sub s b)
151190
152−newtype Substitution = Substitution {unSubstitution :: Map TypeVariable NType}
191+newtype Substitution = Substitution {unSubstitution :: Map TypeVariable Scheme}
153192 deriving newtype (Eq, Ord, Show)
154193
155194prettySubstitution :: Substitution -> A.Value
@@ -162,31 +201,18 @@ instance Semigroup Substitution where
162201instance Monoid Substitution where
163202 mempty = Substitution mempty
164203
165−sub :: Substitution -> NType -> NType
166−sub s r = case r of
167− NAtomic _ -> r
168− NBrujin _ -> r
169− NTypeVariable x -> subTV x
170− List x -> List $ sub s x
171− NAttrSet m -> NAttrSet $ sub s <$> m
172− x :-> y -> sub s x :-> sub s y
173− where
174− subTV x = M.findWithDefault r x $ unSubstitution s
175−
176−subCon :: Substitution -> Constraint -> Constraint
177−subCon s (x :~ y) = sub s x :~ sub s y
204+instance Free Constraint where
205+ free (x :~ y) = free x <> free y
206+ sub s (x :~ y) = sub s x :~ sub s y
178207
179208(<<-) ::
180209 TypeVariable ->
181− NType ->
210+ Scheme ->
182211 UnifyM Substitution
183−v <<- (NTypeVariable x) | v == x = return mempty
212+v <<- ([] :=> NTypeVariable x) | v == x = return mempty
184213v <<- x | v `occursIn` x = tell (InfinityType x) >> return mempty
185214v <<- x = return $ Substitution $ M.singleton v x
186215
187−unify :: Constraint -> UnifyM Substitution
188−unify = unifyWithPriority RS.empty
189−
190216unifyWithPriority ::
191217 -- | The range of type variables to interpret as being lower
192218 -- priority (try to replace them if possible)
@@ -196,23 +222,37 @@ unifyWithPriority ::
196222unifyWithPriority range (lhs :~ rhs) =
197223 case (lhs, rhs) of
198224 (NAtomic x, NAtomic y) | x == y -> return mempty
199− (NTypeVariable x, NTypeVariable y) ->
200− if y `RS.member` range
201− then x <<- NTypeVariable y
202− else y <<- NTypeVariable x
203− (NTypeVariable t, x) -> t <<- x
204− (x, NTypeVariable t) -> t <<- x
205− (List x, List y) -> unify $ x :~ y
206− (NAttrSet x, NAttrSet y) -> do
207− foldr (\c s -> s >>= \s' -> (<> s') <$> unify (subCon s' c)) (pure mempty)
208− . M.elems
209− $ M.intersectionWith (:~) x y
210− (x1 :-> y1, x2 :-> y2) -> do
211− s <- unify (x1 :~ x2)
212− s' <- unify $ subCon s $ y1 :~ y2
213− return $ s' <> s
225+ (xcs :=> NTypeVariable x, ycs :=> NTypeVariable y) -> do
226+ let ((_lhsCs, lhs'), (rhsCs, rhs')) =
227+ if y `RS.member` range
228+ then ((ycs, y), (xcs, x))
229+ else ((xcs, x), (ycs, y))
230+ lhs' <<- (rhsCs :=> NTypeVariable rhs') -- This might be wrong
231+ (_ :=> NTypeVariable t, x) -> t <<- x
232+ (x, _ :=> NTypeVariable t) -> t <<- x
233+ (xcs :=> List x, ycs :=> List y) -> do
234+ s <- unifyWithPriority range $ x :~ y
235+ s' <- uncurry unifyPred . sub s $ (xcs, ycs)
236+ return $ s <> s'
237+ (xcs :=> NAttrSet x, ycs :=> NAttrSet y) -> do
238+ s <-
239+ foldr (\c s -> s >>= \s' -> (<> s') <$> unifyWithPriority range (sub s' c)) (pure mempty)
240+ . M.elems
241+ $ M.intersectionWith (:~) x y
242+ s' <- uncurry unifyPred . sub s $ (xcs, ycs)
243+ return $ s <> s'
244+ (xcs :=> (x1 :-> y1), ycs :=> (x2 :-> y2)) -> do
245+ s <- unifyWithPriority range (x1 :~ x2)
246+ s' <- unifyWithPriority range $ sub s $ y1 :~ y2
247+ let ss = s' <> s
248+ s'' <- uncurry unifyPred . sub ss $ (xcs, ycs)
249+ return $ s'' <> ss
214250 (x, y) -> tell (CanNotUnify x y) >> return mempty
215251
252+unifyPred :: [Pred] -> [Pred] -> UnifyM Substitution
253+unifyPred [] [] = return mempty
254+unifyPred _ _ = undefined
255+
216256solve :: Seq Constraint -> UnifyM Substitution
217257solve = solveWithPriority RS.empty
218258
@@ -225,14 +265,14 @@ solveWithPriority ::
225265solveWithPriority _ Empty = return mempty
226266solveWithPriority range (rest :|> c) = do
227267 s <- unifyWithPriority range c
228− (<> s) <$> solveWithPriority range (fmap (subCon s) rest)
268+ (<> s) <$> solveWithPriority range (fmap (sub s) rest)
229269
230270occursIn :: Free x => TypeVariable -> x -> Bool
231271occursIn t x = t `S.member` free x
232272
233273data Errors
234274 = UndefinedVariable VarName
235− | UnexpectedType {expected :: NType, got :: NType}
275+ | UnexpectedType {expected :: Scheme, got :: Scheme}
236276 | KeyNotPresent Text
237277 deriving stock (Eq, Ord, Show)
238278
@@ -246,8 +286,8 @@ freshSrc = do
246286 return v
247287
248288data UnifyingError
249− = InfinityType NType
250− | CanNotUnify NType NType
289+ = InfinityType Scheme
290+ | CanNotUnify Scheme Scheme
251291 deriving stock (Eq, Show)
252292
253293type UnifyM x = forall r. Members '[Writer UnifyingError] r => Eff r x
@@ -289,10 +329,13 @@ throwSrcTV e = do
289329 throwSrc e
290330 freshSrc
291331
292−type VariableMap = Map VarName NType
332+type VariableMap = Map VarName Scheme
293333
294334(~~) :: Member (Writer Constraint) r => NType -> NType -> Eff r ()
295−lhs ~~ rhs = tell $ lhs :~ rhs
335+lhs ~~ rhs = ([] :=> lhs) ~~~ ([] :=> rhs)
336+
337+(~~~) :: Member (Writer Constraint) r => Scheme -> Scheme -> Eff r ()
338+lhs ~~~ rhs = tell $ lhs :~ rhs
296339
297340-- TODO: shadowed bindings are not properly restored.
298341withBindings ::
@@ -309,17 +352,25 @@ withBindings bindings m = do
309352instantiate ::
310353 forall effs.
311354 Members '[Fresh, Reader SrcSpan, Writer (TypeVariable, SrcSpan)] effs =>
312− NType ->
313− Eff effs NType
314−instantiate = evalState M.empty . instantiate'
355+ Scheme ->
356+ Eff effs Scheme
357+instantiate = evalState M.empty . instantiateScheme
315358 where
359+ instantiateScheme :: forall. Scheme -> Eff (State (Map DeBrujin TypeVariable) ': effs) Scheme
360+ instantiateScheme (ps :=> t) = (:=>) <$> traverse instantiatePred ps <*> instantiate' t
361+ instantiateScheme x@(NAtomic _) = return x
362+
363+ instantiatePred :: forall. Pred -> Eff (State (Map DeBrujin TypeVariable) ': effs) Pred
364+ instantiatePred = \case
365+ -- instantiatePred (x `Update` y) = Update <$> instantiate' x <*> instantiate' y
366+ -- instantiatePred (x `HasField` (f, y)) = HasField <$> instantiate' x <*> ((f,) <$> instantiate' y)
367+
316368 instantiate' :: forall. NType -> Eff (State (Map DeBrujin TypeVariable) ': effs) NType
317369 instantiate' x@(NTypeVariable _) = return x
318− instantiate' x@(NAtomic _) = return x
319370 instantiate' (NBrujin db) = NTypeVariable <$> freshInst db
320− instantiate' (x :-> y) = (:->) <$> instantiate' x <*> instantiate' y
321− instantiate' (List x) = List <$> instantiate' x
322− instantiate' (NAttrSet xs) = NAttrSet <$> traverse instantiate' xs
371+ instantiate' (x :-> y) = (:->) <$> instantiateScheme x <*> instantiateScheme y
372+ instantiate' (List x) = List <$> instantiateScheme x
373+ instantiate' (NAttrSet xs) = NAttrSet <$> traverse instantiateScheme xs
323374
324375 freshInst :: DeBrujin -> Eff (State (Map DeBrujin TypeVariable) ': effs) TypeVariable
325376 freshInst db = do
@@ -330,7 +381,7 @@ instantiate = evalState M.empty . instantiate'
330381 modify (M.insert db t)
331382 return t
332383
333−infer :: NExprLoc -> InferM NType
384+infer :: NExprLoc -> InferM Scheme
334385infer (Fix (Compose (Ann src x))) = runReader src $ case x of
335386 NConstant a -> return . NAtomic $ case a of
336387 NURI {} -> URI
@@ -343,14 +394,14 @@ infer (Fix (Compose (Ann src x))) = runReader src $ case x of
343394 NStr {} -> return $ NAtomic String
344395 NSym var ->
345396 get @VariableMap
346− >>= maybe (NTypeVariable <$> throwSrcTV (UndefinedVariable var)) return . M.lookup var
397+ >>= maybe (scheme . NTypeVariable <$> throwSrcTV (UndefinedVariable var)) return . M.lookup var
347398 >>= instantiate -- I have no idea if this covers all cases.
348399 NList xs -> do
349400 xs' <- traverse infer xs
350401 traverse_ tell . fmap (uncurry (:~)) $ zip xs' (tail xs')
351402 case xs' of
352− [] -> NTypeVariable <$> freshSrc
353− y : _ -> return $ List y
403+ [] -> scheme . NTypeVariable <$> freshSrc
404+ y : _ -> return . scheme $ List y
354405 NUnary NNeg y -> do
355406 t <- infer y
356407 -- TODO: Infer either Float or Integer
@@ -358,29 +409,29 @@ infer (Fix (Compose (Ann src x))) = runReader src $ case x of
358409 return t
359410 NUnary NNot y -> do
360411 t <- infer y
361− t ~~ NAtomic Bool
412+ t ~~~ NAtomic Bool
362413 return t
363414 NBinary NUpdate lhs rhs -> do
364415 lhsT <- infer lhs
365416 rhsT <- infer rhs
366− lhsT ~~ rhsT
417+ lhsT ~~~ rhsT
367418 lhs' <- expectAttrSet lhsT
368419 rhs' <- expectAttrSet rhsT
369− forM_ (M.toList $ M.intersectionWith (,) lhs' rhs') (\(_, (a, b)) -> a ~~ b)
370− return . NAttrSet $ rhs' <> lhs'
420+ forM_ (M.toList $ M.intersectionWith (,) lhs' rhs') (\(_, (a, b)) -> a ~~~ b)
421+ return . scheme . NAttrSet $ rhs' <> lhs'
371422 NBinary NApp lhs rhs -> do
372423 lhst <- infer lhs
373424 rhst <- infer rhs
374− rest <- NTypeVariable <$> freshSrc
375− lhst ~~ (rhst :-> rest)
425+ rest <- scheme . NTypeVariable <$> freshSrc
426+ lhst ~~~ (scheme $ rhst :-> rest)
376427 return rest
377428 NBinary NConcat lhs rhs -> do
378429 lhst <- infer lhs
379430 rhst <- infer rhs
380− t <- NTypeVariable <$> freshSrc
381− let listt = List t
382− lhst ~~ listt
383− rhst ~~ listt
431+ t <- scheme . NTypeVariable <$> freshSrc
432+ let listt = scheme $ List t
433+ lhst ~~~ listt
434+ rhst ~~~ listt
384435 return $ listt
385436 NBinary NEq lhs rhs -> equality lhs rhs
386437 NBinary NNEq lhs rhs -> equality lhs rhs
@@ -400,14 +451,14 @@ infer (Fix (Compose (Ann src x))) = runReader src $ case x of
400451 path <- getPath path'
401452 resT <- case path of
402453 Just p -> lookupAttrSet p setT
403− Nothing -> NTypeVariable <$> freshSrc
454+ Nothing -> scheme . NTypeVariable <$> freshSrc
404455 case def of
405456 Nothing -> return ()
406457 Just defR -> do
407458 defT <- infer defR
408− defT ~~ resT
459+ defT ~~~ resT
409460 return resT
410− NSet NNonRecursive xs -> NAttrSet <$> inferBinding xs
461+ NSet NNonRecursive xs -> scheme . NAttrSet <$> inferBinding xs
411462 NHasAttr attrSet path -> do
412463 setT <- infer attrSet
413464 expectAttrSet setT
@@ -416,29 +467,29 @@ infer (Fix (Compose (Ann src x))) = runReader src $ case x of
416467 (paramT, varMap :: VariableMap) <- case param of
417468 Param name -> do
418469 t <- freshSrc
419− return (NTypeVariable t, M.singleton name $ NTypeVariable t)
470+ return (scheme $ NTypeVariable t, M.singleton name . scheme $ NTypeVariable t)
420471 ParamSet set variadic binding -> do
421472 setBindings <-
422473 M.fromList <$> set
423474 `for` ( \(name, def) -> do
424475 t <- case def of
425− Nothing -> NTypeVariable <$> freshSrc
476+ Nothing -> scheme . NTypeVariable <$> freshSrc
426477 Just def' -> infer def'
427478 return (name, t)
428479 )
429− let setT = NAttrSet $ setBindings
480+ let setT = scheme . NAttrSet $ setBindings
430481 return (setT, maybe M.empty (`M.singleton` setT) binding <> setBindings)
431482 bodyT <- withBindings varMap $ infer body
432− return $ paramT :-> bodyT
483+ return . scheme $ paramT :-> bodyT
433484 NLet bindings body -> do
434485 bindingsT <- inferBinding bindings
435486 withBindings bindingsT $ infer body
436487 NIf cond t f -> do
437488 condT <- infer cond
438− condT ~~ NAtomic Bool
489+ condT ~~~ NAtomic Bool
439490 tT <- infer t
440491 fT <- infer f
441− tT ~~ fT
492+ tT ~~~ fT
442493 return tT
443494 NWith set body -> do
444495 setT <- infer set
@@ -446,35 +497,35 @@ infer (Fix (Compose (Ann src x))) = runReader src $ case x of
446497 withBindings vars $ infer body
447498 NAssert cond body -> do
448499 condT <- infer cond
449− condT ~~ NAtomic Bool
500+ condT ~~~ NAtomic Bool
450501 infer body
451− NSynHole _ -> NTypeVariable <$> freshSrc
502+ NSynHole _ -> scheme . NTypeVariable <$> freshSrc
452503 where
453504 equality lhs rhs = do
454505 lhst <- infer lhs
455506 rhst <- infer rhs
456− lhst ~~ rhst
507+ lhst ~~~ rhst
457508 return $ NAtomic Bool
458509 comparison lhs rhs = do
459510 lhst <- infer lhs
460511 rhst <- infer rhs
461512 -- TODO: Infer lhst and rhst are either Integer or Double or String
462− lhst ~~ rhst
513+ lhst ~~~ rhst
463514 return $ NAtomic Bool
464515 math lhs rhs = do
465516 lhst <- infer lhs
466517 rhst <- infer rhs
467518 -- TODO: Infer lhst and rhst are either Integer or Double
468− lhst ~~ rhst
519+ lhst ~~~ rhst
469520 return lhst
470521 logic lhs rhs = do
471522 lhst <- infer lhs
472523 rhst <- infer rhs
473− rhst ~~ NAtomic Bool
474− lhst ~~ NAtomic Bool
524+ rhst ~~~ NAtomic Bool
525+ lhst ~~~ NAtomic Bool
475526 return $ NAtomic Bool
476527
477−inferBinding :: [Binding (Fix NExprLocF)] -> InferM' (Map VarName NType)
528+inferBinding :: [Binding (Fix NExprLocF)] -> InferM' (Map VarName Scheme)
478529inferBinding bindings = do
479530 bindings' <-
480531 bindings >>.= \case
@@ -483,7 +534,7 @@ inferBinding bindings = do
483534 Nothing -> return []
484535 Just name -> do
485536 t <- inferGeneral r
486− return $ [stack ((,) <$> name) (NAttrSet . uncurry M.singleton) t]
537+ return $ [stack ((,) <$> name) (scheme . NAttrSet . uncurry M.singleton) t]
487538 Inherit attrSet keys src -> do
488539 vars <- case attrSet of
489540 Just attr -> do
@@ -504,7 +555,7 @@ renderPretty = renderLazy . layoutPretty defaultLayoutOptions . pretty
504555showExpr :: Fix NExprLocF -> Text
505556showExpr = TL.toStrict . renderLazy . layoutPretty defaultLayoutOptions . P.group . prettyNix . stripAnnotation
506557
507−inferGeneral :: NExprLoc -> InferM NType
558+inferGeneral :: NExprLoc -> InferM Scheme
508559inferGeneral x = traceSubtree (showExpr x) $ do
509560 (((t, subs), cs), range) <-
510561 traceSubtree "subexpressions" . registerTypeVariables . runConstraintEnv $ infer x
@@ -512,6 +563,7 @@ inferGeneral x = traceSubtree (showExpr x) $ do
512563 traceValue "type" $ renderPretty t
513564 traceValue "substitutions" $ prettySubstitution subs
514565 traceValue "constraints" $ fmap renderPretty cs
566+ traceValue "range" $ T.pack . show $ range
515567 s' <- solveWithPriority range cs
516568 traceValue "substitutions_after_solving" $ prettySubstitution s'
517569 let s = subs <> s'
@@ -524,12 +576,13 @@ inferGeneral x = traceSubtree (showExpr x) $ do
524576 traceValue "type" $ renderPretty retT
525577 return retT
526578
527−expectAttrSet :: Members '[Reader SrcSpan, Writer (SrcSpan, Errors)] r => NType -> Eff r VariableMap
528−expectAttrSet (NAttrSet x) = return x
579+-- | Deprecated
580+expectAttrSet :: Members '[Reader SrcSpan, Writer (SrcSpan, Errors)] r => Scheme -> Eff r VariableMap
581+expectAttrSet (_ :=> NAttrSet x) = return x
529582expectAttrSet g = do
530583 throwSrc
531584 UnexpectedType
532− { expected = NAttrSet M.empty,
585+ { expected = scheme $ NAttrSet M.empty,
533586 got = g
534587 }
535588 return M.empty
@@ -547,9 +600,10 @@ stack (g :| gs) h x = g $ f gs
547600(>>.=) :: (Applicative f, Monad t, Traversable t) => t a -> (a -> f (t b)) -> f (t b)
548601ta >>.= f = join <$> traverse f ta
549602
550−mergeSetTypes :: NType -> NType -> NType
551−mergeSetTypes (NAttrSet ks) (NAttrSet ks') =
552− NAttrSet $ M.unionWith mergeSetTypes ks ks'
603+-- | Deprecated
604+mergeSetTypes :: Scheme -> Scheme -> Scheme
605+mergeSetTypes (xcs :=> NAttrSet ks) (ycs :=> NAttrSet ks') =
606+ (xcs <> ycs) :=> NAttrSet (M.unionWith mergeSetTypes ks ks')
553607mergeSetTypes _ x = x
554608
555609-- TODO: process variables
@@ -581,6 +635,7 @@ getPath path = sequence <$> traverse getKeyName path
581635
582636type AttrSetPath = NonEmpty Text
583637
638+-- | Deprecated
584639lookupAttrSet ::
585640 Members
586641 '[ Reader SrcSpan,
@@ -590,8 +645,8 @@ lookupAttrSet ::
590645 ]
591646 r =>
592647 AttrSetPath ->
593− NType ->
594− Eff r NType
648+ Scheme ->
649+ Eff r Scheme
595650lookupAttrSet path = go (NE.toList path)
596651 where
597652 go ::
@@ -603,10 +658,10 @@ lookupAttrSet path = go (NE.toList path)
603658 ]
604659 r =>
605660 [VarName] ->
606− NType ->
607− Eff r NType
661+ Scheme ->
662+ Eff r Scheme
608663 go [] x = return x
609664 go (p : ps) x = do
610665 expectAttrSet x <&> M.lookup p >>= \case
611− Nothing -> NTypeVariable <$> throwSrcTV (KeyNotPresent p)
666+ Nothing -> scheme . NTypeVariable <$> throwSrcTV (KeyNotPresent p)
612667 Just t -> go ps t