Merge branch 'main' into rory-inferno-ml-server-types

inferno-core/CHANGELOG.md

@@ -1,6 +1,12 @@
 # Revision History for inferno-core
 *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH)
 
+## 0.10.1.0 -- 2024-01-30
+* Fix `ToValue` instances for functions and `ImplicitCast`
+
+## 0.10.0.0 -- 2024-01-29
+* Modify `TermEnv` to defer evaluating prelude `Expr` definitions till runtime. Should reduce memory consumption
+
 ## 0.9.0.0 -- 2023-11-21
 * Breaking change: Fix Array primitive type signatures. Add Option.join
 

inferno-core/app/Main.hs

@@ -22,7 +22,7 @@ main = do
     Left err -> do
       hPutStrLn stderr $ show err
       exitFailure
-    Right ast ->
+    Right ast -> do
       evalExpr defaultEnv Map.empty ast >>= \case
         Left err -> do
           hPutStrLn stderr $ show err

inferno-core/inferno-core.cabal

@@ -1,6 +1,6 @@
 cabal-version:       2.4
 name:                inferno-core
-version:             0.9.0.0
+version:             0.10.1.0
 synopsis:            A statically-typed functional scripting language
 description:         Parser, type inference, and interpreter for a statically-typed functional scripting language
 category:            DSL,Scripting

inferno-core/src/Inferno/Core.hs

@@ -13,7 +13,7 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Text (Text)
-import Inferno.Eval (TermEnv, eval, runEvalM)
+import Inferno.Eval (TermEnv, runEvalM)
 import Inferno.Eval.Error (EvalError)
 import Inferno.Infer (TypeError, inferExpr, inferTypeReps)
 import Inferno.Infer.Error (Location)
@@ -24,11 +24,11 @@ import Inferno.Module.Prelude (ModuleMap, baseOpsTable, builtinModulesOpsTable,
 import Inferno.Parse (InfernoParsingError, parseExpr)
 import Inferno.Types.Syntax (Comment, CustomType, Expr (App, TypeRep), ExtIdent, ModuleName, Namespace, SourcePos, TypeClass, TypeMetadata, collectArrs)
 import Inferno.Types.Type (ImplType (ImplType), TCScheme (ForallTC))
-import Inferno.Types.Value (ImplEnvM, Value, runImplEnvM)
+import Inferno.Types.Value (ImplEnvM, Value)
 import Inferno.Types.VersionControl (Pinned, VCObjectHash, pinnedToMaybe)
 import Inferno.VersionControl.Types (VCObject (VCFunction))
 import Prettyprinter (Pretty)
-import Text.Megaparsec (ParseError, initialPos)
+import Text.Megaparsec (ParseError)
 
 data InfernoError
   = ParseError (NonEmpty (ParseError Text InfernoParsingError, SourcePos))
@@ -45,24 +45,24 @@ data Interpreter m c = Interpreter
     -- @mkEnvFromClosure@.
     evalExpr ::
       forall a.
-      TermEnv VCObjectHash c (ImplEnvM m c) ->
+      TermEnv VCObjectHash c (ImplEnvM m c) a ->
       Map.Map ExtIdent (Value c (ImplEnvM m c)) ->
       Expr (Maybe VCObjectHash) a ->
       m (Either EvalError (Value c (ImplEnvM m c))),
     parseAndInferTypeReps ::
       Text ->
-      Either InfernoError (Expr (Maybe VCObjectHash) SourcePos),
+      Either InfernoError (Expr (Maybe VCObjectHash) ()),
     parseAndInfer ::
       Text ->
       Either InfernoError (Expr (Pinned VCObjectHash) SourcePos, TCScheme, Map.Map (Location SourcePos) (TypeMetadata TCScheme), [Comment SourcePos]),
     -- | Evaluates all functions in given closure and creates a pinned env containing them
     mkEnvFromClosure ::
       Map.Map ExtIdent (Value c (ImplEnvM m c)) ->
       Map.Map VCObjectHash VCObject ->
-      ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)),
+      ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c) ()),
     -- | The default pinned env containing only the prelude
     defaultEnv ::
-      TermEnv VCObjectHash c (ImplEnvM m c),
+      TermEnv VCObjectHash c (ImplEnvM m c) (),
     -- | The type of each name in this interpreter's prelude
     nameToTypeMap ::
       Map.Map (Maybe ModuleName, Namespace) (TypeMetadata TCScheme),
@@ -75,7 +75,7 @@ mkInferno :: forall m c. (MonadThrow m, MonadCatch m, MonadFix m, Eq c, Pretty c
 mkInferno prelude customTypes = do
   -- We pre-compute envs that only depend on the prelude so that they can be
   -- shared among evaluations of different scripts
-  (preludeIdentEnv, preludePinnedEnv) <- runImplEnvM Map.empty $ builtinModulesTerms prelude
+  let (preludeIdentEnv, preludePinnedEnv) = builtinModulesTerms prelude
   return $
     Interpreter
       { evalExpr = runEvalM,
@@ -116,8 +116,8 @@ mkInferno prelude customTypes = do
                   let finalAst =
                         foldl
                           App
-                          (bimap pinnedToMaybe id pinnedAST')
-                          [TypeRep (initialPos "dummy") ty | ty <- runtimeReps]
+                          (bimap pinnedToMaybe (const ()) pinnedAST')
+                          [TypeRep () ty | ty <- runtimeReps]
                    in Right finalAst
 
     typeClasses = Set.unions $ moduleTypeClasses builtinModule : [cls | Module {moduleTypeClasses = cls} <- Map.elems prelude]
@@ -130,11 +130,8 @@ mkInferno prelude customTypes = do
           foldM
             ( \env (hash, obj) -> case obj of
                 VCFunction expr _ -> do
-                  eval
-                    (localEnv, pinnedEnv')
-                    (bimap pinnedToMaybe id expr)
-                    >>= \val ->
-                      pure $ Map.insert hash val env
+                  let expr' = bimap pinnedToMaybe id expr
+                  pure $ Map.insert hash (Left expr') env
                 _ -> pure env
             )
             preludePinnedEnv

inferno-core/src/Inferno/Eval.hs

@@ -54,12 +54,15 @@ import Prettyprinter
   )
 import Prettyprinter.Render.Text (renderStrict)
 
-type TermEnv hash c m = (Map.Map ExtIdent (Value c m), Map.Map hash (Value c m))
+-- | Evaluation environment: (localEnv, pinnedEnv).
+-- The pinnedEnv contains functions in the prelude, and their definitions are either
+-- inferno expressions or values (wrapped Haskell functions or direct VFun definitions).
+type TermEnv hash c m a = (Map.Map ExtIdent (Value c m), Map.Map hash (Either (Expr (Maybe VCObjectHash) a) (Value c m)))
 
-emptyTmenv :: TermEnv hash c m
+emptyTmenv :: TermEnv hash c m a
 emptyTmenv = (Map.empty, Map.empty)
 
-eval :: (MonadThrow m, Pretty c) => TermEnv VCObjectHash c (ImplEnvM m c) -> Expr (Maybe VCObjectHash) a -> ImplEnvM m c (Value c (ImplEnvM m c))
+eval :: (MonadThrow m, Pretty c) => TermEnv VCObjectHash c (ImplEnvM m c) a -> Expr (Maybe VCObjectHash) a -> ImplEnvM m c (Value c (ImplEnvM m c))
 eval env@(localEnv, pinnedEnv) expr = case expr of
   Lit_ (LInt k) -> return $
     VFun $ \case
@@ -99,7 +102,7 @@ eval env@(localEnv, pinnedEnv) expr = case expr of
                     _ -> throwM $ RuntimeError "failed to match with a bool"
               )
     where
-      sequence' :: (MonadThrow m, Pretty c) => TermEnv VCObjectHash c (ImplEnvM m c) -> NonEmpty (a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a) -> ImplEnvM m c [[(ExtIdent, Value c (ImplEnvM m c))]]
+      sequence' :: (MonadThrow m, Pretty c) => TermEnv VCObjectHash c (ImplEnvM m c) a -> NonEmpty (a, Ident, a, Expr (Maybe VCObjectHash) a, Maybe a) -> ImplEnvM m c [[(ExtIdent, Value c (ImplEnvM m c))]]
       sequence' env'@(localEnv', pinnedEnv') = \case
         (_, Ident x, _, e_s, _) :| [] -> do
           eval env' e_s >>= \case
@@ -118,7 +121,8 @@ eval env@(localEnv, pinnedEnv) expr = case expr of
   Enum_ Nothing _ _ -> throwM $ RuntimeError "All enums must be pinned"
   Var_ (Just hash) _ x ->
     case Map.lookup hash pinnedEnv of
-      Just v -> return v
+      Just (Left e) -> eval env e
+      Just (Right v) -> return v
       Nothing -> throwM $ RuntimeError $ show x <> "(" <> show hash <> ") not found in the pinned env"
   Var_ Nothing _ (Expl x) -> do
     case Map.lookup x localEnv of
@@ -131,7 +135,8 @@ eval env@(localEnv, pinnedEnv) expr = case expr of
       Nothing -> throwM $ RuntimeError $ show x <> " not found in the implicit env"
   OpVar_ (Just hash) _ x ->
     case Map.lookup hash pinnedEnv of
-      Just v -> return v
+      Just (Left e) -> eval env e
+      Just (Right v) -> return v
       Nothing -> throwM $ RuntimeError $ show x <> "(" <> show hash <> ") not found in the pinned env"
   OpVar_ Nothing _ (Ident x) -> do
     case Map.lookup (ExtIdent $ Right x) localEnv of
@@ -142,20 +147,26 @@ eval env@(localEnv, pinnedEnv) expr = case expr of
   Op_ a (Just hash) _ns op b -> do
     a' <- eval env a
     b' <- eval env b
-    case Map.lookup hash pinnedEnv of
+    vF <- case Map.lookup hash pinnedEnv of
       Nothing -> throwM $ RuntimeError $ show op <> "(" <> show hash <> ") not found in the pinned env"
-      Just (VFun f) ->
+      Just (Left e) -> eval env e
+      Just (Right v) -> pure v
+    case vF of
+      VFun f ->
         f a' >>= \case
           VFun f' -> f' b'
           _ -> throwM $ RuntimeError $ show op <> " not bound to a binary function in env"
-      Just _ -> throwM $ RuntimeError $ show op <> " not bound to a function in env"
+      _ -> throwM $ RuntimeError $ show op <> " not bound to a function in env"
   PreOp_ Nothing _ op _ -> throwM $ RuntimeError $ show op <> " should be pinned"
   PreOp_ (Just hash) _ns op a -> do
     a' <- eval env a
-    case Map.lookup hash pinnedEnv of
+    vF <- case Map.lookup hash pinnedEnv of
       Nothing -> throwM $ RuntimeError $ show op <> "(" <> show hash <> ") not found in the pinned env"
-      Just (VFun f) -> f a'
-      Just _ -> throwM $ RuntimeError $ show op <> " not bound to a function in env"
+      Just (Left e) -> eval env e
+      Just (Right v) -> pure v
+    case vF of
+      VFun f -> f a'
+      _ -> throwM $ RuntimeError $ show op <> " not bound to a function in env"
   Lam_ args body -> go localEnv $ toList args
     where
       go nenv = \case
@@ -270,7 +281,7 @@ eval env@(localEnv, pinnedEnv) expr = case expr of
 runEvalM ::
   (MonadThrow m, MonadCatch m, Pretty c) =>
   -- | Environment.
-  TermEnv VCObjectHash c (ImplEnvM m c) ->
+  TermEnv VCObjectHash c (ImplEnvM m c) a ->
   -- | Implicit environment.
   Map.Map ExtIdent (Value c (ImplEnvM m c)) ->
   -- | Expression to evaluate.

inferno-core/src/Inferno/Module.hs

@@ -24,7 +24,7 @@ import Data.Foldable (foldl')
 import qualified Data.IntMap as IntMap
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import Inferno.Eval (TermEnv, eval)
+import Inferno.Eval (TermEnv)
 import Inferno.Infer (inferExpr)
 import Inferno.Infer.Env (Namespace (..), TypeMetadata (..))
 import Inferno.Infer.Pinned (pinExpr)
@@ -64,14 +64,14 @@ import Text.Megaparsec (SourcePos)
 
 combineTermEnvs ::
   MonadThrow m =>
-  Map.Map ModuleName (PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))) ->
-  ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))
+  Map.Map ModuleName (PinnedModule (TermEnv VCObjectHash c (ImplEnvM m c) a)) ->
+  TermEnv VCObjectHash c (ImplEnvM m c) a
 combineTermEnvs modules = foldM (\env m -> (env <>) <$> pinnedModuleTerms m) mempty $ Map.elems modules
 
 buildPinnedQQModules ::
   (MonadThrow m, Pretty c) =>
-  [(ModuleName, OpsTable, [TopLevelDefn (Either (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c))) (Maybe TCScheme, Expr () SourcePos))])] ->
-  Map.Map ModuleName (PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))))
+  [(ModuleName, OpsTable, [TopLevelDefn (Either (TCScheme, Value c (ImplEnvM m c)) (Maybe TCScheme, Expr () SourcePos))])] ->
+  Map.Map ModuleName (PinnedModule (TermEnv VCObjectHash c (ImplEnvM m c) ()))
 buildPinnedQQModules modules =
   snd $
     foldl'
@@ -96,21 +96,21 @@ buildPinnedQQModules modules =
     buildModule ::
       (MonadThrow m, Pretty c) =>
       Map.Map (Scoped ModuleName) (Map.Map Namespace (Pinned VCObjectHash)) ->
-      Map.Map ModuleName (PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))) ->
-      [TopLevelDefn (Either (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c))) (Maybe TCScheme, Expr () SourcePos))] ->
-      PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c))) ->
-      PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))
+      Map.Map ModuleName (PinnedModule (TermEnv VCObjectHash c (ImplEnvM m c) ())) ->
+      [TopLevelDefn (Either (TCScheme, Value c (ImplEnvM m c)) (Maybe TCScheme, Expr () SourcePos))] ->
+      PinnedModule (TermEnv VCObjectHash c (ImplEnvM m c) ()) ->
+      PinnedModule (TermEnv VCObjectHash c (ImplEnvM m c) ())
     buildModule _ _ [] m = m
     buildModule alreadyPinnedModulesMap alreadyBuiltModules (Signature {..} : xs) m@Module {moduleName, moduleObjects = (nsMap, tyMap, mTrmEnv)} =
       let sigVarToNamespace = \case
             SigVar n -> FunNamespace $ Ident n
             SigOpVar n -> OpNamespace $ Ident n
           (sig, ns, hsh, mTrmEnv') = case def of
-            Left (sig', mVal) ->
+            Left (sig', val) ->
               let ns' = sigVarToNamespace name
                   hsh' = vcHash $ BuiltinFunHash (sigVarToExpr LocalScope name, sig)
-               in (sig', ns', hsh', (\val (local, pinned) -> (local, Map.insert hsh val pinned)) <$> mVal <*> mTrmEnv)
-            Right (_mSig, expr) ->
+               in (sig', ns', hsh', (\(local, pinned) -> (local, Map.insert hsh (Right val) pinned)) mTrmEnv)
+            Right (mSig, expr) ->
               let pinMap =
                     Pinned.openModule moduleName $
                       Pinned.insertHardcodedModule
@@ -125,10 +125,13 @@ buildPinnedQQModules modules =
                         pinnedExpr
                   ns' = sigVarToNamespace name
                   hsh' = vcHash $ BuiltinFunHash (sigVarToExpr LocalScope name, sig)
-                  mVal =
-                    combineTermEnvs alreadyBuiltModules >>= \env ->
-                      mTrmEnv >>= \env' -> eval (env <> env') $ bimap pinnedToMaybe id pinnedExpr'
-               in (sig', ns', hsh', (\val (local, pinned) -> (local, Map.insert hsh val pinned)) <$> mVal <*> mTrmEnv)
+                  finalExpr = (bimap pinnedToMaybe (const ()) pinnedExpr')
+               in case mSig of
+                    Just sig''
+                      | sig' /= sig'' ->
+                          error $ "Type of " <> show name <> " does not matched inferred type " <> show sig'
+                    _ ->
+                      (sig', ns', hsh', (\(local, pinned) -> (local, Map.insert hsh (Left finalExpr) pinned)) mTrmEnv)
        in buildModule alreadyPinnedModulesMap alreadyBuiltModules xs $
             m
               { moduleObjects =