@@ -21,6 +21,7 @@ import Control.Monad.Freer.TreeTracer
2121import Control.Monad.Freer.Writer
2222import Data.Act
2323import qualified Data.Aeson as A
24+import Data.Data (Data)
2425import Data.Fix
2526import Data.Foldable
2627import Data.Functor.Contravariant
@@ -75,6 +76,8 @@ runConstraintEnv =
7576 . interpret @SubstituteEnv
7677 ( \(SubstituteEnv x) -> do
7778 modify @(Seq Constraint) (sub x <$>)
79+ -- TODO: I have a feeling that variables in the env should already be closed over.
80+ -- (aka this is redundant)
7881 modify @VariableMap (sub x <$>)
7982 tell x
8083 return ()
@@ -194,6 +197,7 @@ instance (Free a, Free b) => Free (a, b) where
194197
195198newtype Substitution = Substitution {unSubstitution :: Map TypeVariable Scheme}
196199 deriving newtype (Eq, Ord, Show)
200+ deriving stock (Data)
197201
198202prettySubstitution :: Substitution -> A.Value
199203prettySubstitution = A.toJSON . M.mapKeysMonotonic (TL.pack . show) . fmap renderPretty . unSubstitution
@@ -215,6 +219,9 @@ instance Free Constraint where
215219 UnifyM Substitution
216220v <<- ([] :=> NTypeVariable x) | v == x = return mempty
217221v <<- x | v `occursIn` x = tell (InfinityType x) >> return mempty
222+ where
223+ occursIn :: Free x => TypeVariable -> x -> Bool
224+ occursIn t u = t `S.member` free u
218225v <<- x = return $ Substitution $ M.singleton v x
219226
220227unifyWithPriority ::
@@ -272,11 +279,9 @@ solveWithPriority ::
272279solveWithPriority _ Empty = return mempty
273280solveWithPriority range (rest :|> c) = do
274281 s <- unifyWithPriority range c
282+ -- TODO: This should probably be (s <>)
275283 (<> s) <$> solveWithPriority range (fmap (sub s) rest)
276284
277−occursIn :: Free x => TypeVariable -> x -> Bool
278−occursIn t x = t `S.member` free x
279−
280285data Errors
281286 = UndefinedVariable VarName
282287 | UnexpectedType {expected :: Scheme, got :: Scheme}
@@ -583,13 +588,11 @@ renderPretty = renderLazy . layoutPretty defaultLayoutOptions . pretty
583588showExpr :: Fix NExprLocF -> Text
584589showExpr = TL.toStrict . renderLazy . layoutPretty defaultLayoutOptions . P.group . prettyNix . stripAnnotation
585590
591+-- TODO: There is no need to solve predicates in types that have already been closed.
586592inferGeneral :: NExprLoc -> InferM Scheme
587593inferGeneral x = traceSubtree (showExpr x) $ do
588594 (((t, subs), cs), range) <-
589− traceSubtree "subexpressions" . registerTypeVariables . runConstraintEnv $ do
590− infer x >>= \(cs :=> t) -> do
591− cs' <- solveConstraints cs
592− return $ cs' :=> t
595+ traceSubtree "subexpressions" . registerTypeVariables . runConstraintEnv $ infer x
593596 traceSubtree "received" $ do
594597 traceValue "type" $ renderPretty t
595598 traceValue "substitutions" $ prettySubstitution subs