@@ -21,6 +21,7 @@ import Control.Monad.Freer.TreeTracer
21import Control.Monad.Freer.Writer
21import Control.Monad.Freer.Writer
22import Data.Act
22import Data.Act
23import qualified Data.Aeson as A
23import qualified Data.Aeson as A
24+import Data.Data (Data)
24import Data.Fix
25import Data.Fix
25import Data.Foldable
26import Data.Foldable
26import Data.Functor.Contravariant
27import Data.Functor.Contravariant
@@ -75,6 +76,8 @@ runConstraintEnv =
75 . interpret @SubstituteEnv
76 . interpret @SubstituteEnv
76 ( \(SubstituteEnv x) -> do
77 ( \(SubstituteEnv x) -> do
77 modify @(Seq Constraint) (sub x <$>)
78 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)
78 modify @VariableMap (sub x <$>)
81 modify @VariableMap (sub x <$>)
@@ -194,6 +197,7 @@ instance (Free a, Free b) => Free (a, b) where
195newtype Substitution = Substitution {unSubstitution :: Map TypeVariable Scheme}
198newtype Substitution = Substitution {unSubstitution :: Map TypeVariable Scheme}
196 deriving newtype (Eq, Ord, Show)
199 deriving newtype (Eq, Ord, Show)
200+ deriving stock (Data)
198prettySubstitution :: Substitution -> A.Value
202prettySubstitution :: Substitution -> A.Value
199prettySubstitution = A.toJSON . M.mapKeysMonotonic (TL.pack . show) . fmap renderPretty . unSubstitution
203prettySubstitution = A.toJSON . M.mapKeysMonotonic (TL.pack . show) . fmap renderPretty . unSubstitution
@@ -215,6 +219,9 @@ instance Free Constraint where
215 UnifyM Substitution
219 UnifyM Substitution
216v <<- ([] :=> NTypeVariable x) | v == x = return mempty
220v <<- ([] :=> NTypeVariable x) | v == x = return mempty
217v <<- x | v `occursIn` x = tell (InfinityType x) >> return mempty
221v <<- x | v `occursIn` x = tell (InfinityType x) >> return mempty
223+ occursIn :: Free x => TypeVariable -> x -> Bool
224+ occursIn t u = t `S.member` free u
218v <<- x = return $ Substitution $ M.singleton v x
225v <<- x = return $ Substitution $ M.singleton v x
220unifyWithPriority ::
227unifyWithPriority ::
@@ -272,11 +279,9 @@ solveWithPriority ::
272solveWithPriority _ Empty = return mempty
279solveWithPriority _ Empty = return mempty
273solveWithPriority range (rest :|> c) = do
280solveWithPriority range (rest :|> c) = do
274 s <- unifyWithPriority range c
281 s <- unifyWithPriority range c
282+ -- TODO: This should probably be (s <>)
275 (<> s) <$> solveWithPriority range (fmap (sub s) rest)
283 (<> s) <$> solveWithPriority range (fmap (sub s) rest)
277−occursIn :: Free x => TypeVariable -> x -> Bool
278−occursIn t x = t `S.member` free x
280data Errors
285data Errors
281 = UndefinedVariable VarName
286 = UndefinedVariable VarName
282 | UnexpectedType {expected :: Scheme, got :: Scheme}
287 | UnexpectedType {expected :: Scheme, got :: Scheme}
@@ -583,13 +588,11 @@ renderPretty = renderLazy . layoutPretty defaultLayoutOptions . pretty
583showExpr :: Fix NExprLocF -> Text
588showExpr :: Fix NExprLocF -> Text
584showExpr = TL.toStrict . renderLazy . layoutPretty defaultLayoutOptions . P.group . prettyNix . stripAnnotation
589showExpr = TL.toStrict . renderLazy . layoutPretty defaultLayoutOptions . P.group . prettyNix . stripAnnotation
591+-- TODO: There is no need to solve predicates in types that have already been closed.
586inferGeneral :: NExprLoc -> InferM Scheme
592inferGeneral :: NExprLoc -> InferM Scheme
587inferGeneral x = traceSubtree (showExpr x) $ do
593inferGeneral x = traceSubtree (showExpr x) $ do
588 (((t, subs), cs), range) <-
594 (((t, subs), cs), range) <-
589− traceSubtree "subexpressions" . registerTypeVariables . runConstraintEnv $ do
595+ traceSubtree "subexpressions" . registerTypeVariables . runConstraintEnv $ infer x
590− infer x >>= \(cs :=> t) -> do
591− cs' <- solveConstraints cs
593 traceSubtree "received" $ do
596 traceSubtree "received" $ do
594 traceValue "type" $ renderPretty t
597 traceValue "type" $ renderPretty t
595 traceValue "substitutions" $ prettySubstitution subs
598 traceValue "substitutions" $ prettySubstitution subs