From 3e900366ceeba7bd541ae4c0e00306da80f7e765 Mon Sep 17 00:00:00 2001 From: Siddharth Krishna Date: Wed, 8 Nov 2023 10:02:56 +0000 Subject: [PATCH] Chain prelude evaluation so that primitives can depend on each other (#94) This PR allows evaluating a second prelude (like the one in `inferno-ml`) in an environment that already has the first prelude (the core/builtin one), so that the second prelude can use ops and primitives defined in the first one. It creates a new `Prelude` type (that subsumes the type alias `ModuleMap`) and refactors existing code to use it. --- inferno-core/CHANGELOG.md | 3 + inferno-core/app/Main.hs | 4 +- inferno-core/inferno-core.cabal | 4 +- inferno-core/src/Inferno/Core.hs | 18 +-- .../src/Inferno/Instances/Arbitrary.hs | 3 +- inferno-core/src/Inferno/Module.hs | 110 ++++++++++++++---- inferno-core/src/Inferno/Module/Prelude.hs | 53 +-------- inferno-core/src/Inferno/Utils/QQ/Module.hs | 73 +++++++----- inferno-core/src/Inferno/Utils/QQ/Script.hs | 82 ------------- inferno-core/test/Eval/Spec.hs | 30 ++--- inferno-core/test/Infer/Spec.hs | 2 +- inferno-core/test/Parse/Spec.hs | 13 ++- inferno-lsp/CHANGELOG.md | 3 + inferno-lsp/app/Main.hs | 4 +- inferno-lsp/inferno-lsp.cabal | 4 +- inferno-lsp/src/Inferno/LSP/ParseInfer.hs | 8 +- inferno-lsp/src/Inferno/LSP/Server.hs | 6 +- inferno-ml/CHANGELOG.md | 3 + inferno-ml/app/Main.hs | 4 +- inferno-ml/inferno-ml.cabal | 6 +- inferno-ml/lsp/Main.hs | 4 +- inferno-ml/src/Inferno/ML/Module/Prelude.hs | 29 ++--- inferno-ml/src/Inferno/ML/Module/QQ.hs | 39 +++++++ inferno-ml/src/Inferno/ML/Types/Value.hs | 9 +- inferno-ml/test/Spec.hs | 4 +- 25 files changed, 255 insertions(+), 263 deletions(-) delete mode 100644 inferno-core/src/Inferno/Utils/QQ/Script.hs create mode 100644 inferno-ml/src/Inferno/ML/Module/QQ.hs diff --git a/inferno-core/CHANGELOG.md b/inferno-core/CHANGELOG.md index abf912a..6ddcb5f 100644 --- a/inferno-core/CHANGELOG.md +++ b/inferno-core/CHANGELOG.md @@ -1,6 +1,9 @@ # Revision History for inferno-core *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH) +## 0.9.0.0 -- 2023-11-07 +* Breaking change: Chain prelude evaluation. New Prelude type. Interpreter API changes slightly. + ## 0.8.2.0 -- 2023-11-02 * Add median diff --git a/inferno-core/app/Main.hs b/inferno-core/app/Main.hs index 5d21b40..ce3005f 100644 --- a/inferno-core/app/Main.hs +++ b/inferno-core/app/Main.hs @@ -6,7 +6,7 @@ module Main where import qualified Data.Map as Map import qualified Data.Text.IO as Text import Inferno.Core (Interpreter (..), mkInferno) -import Inferno.Module.Prelude (builtinModules) +import Inferno.Module.Prelude (builtinPrelude) import Inferno.Utils.Prettyprinter (showPretty) import System.Environment (getArgs) import System.Exit (exitFailure) @@ -17,7 +17,7 @@ main = do file <- head <$> getArgs src <- Text.readFile file Interpreter {evalExpr, defaultEnv, parseAndInferTypeReps} <- - mkInferno builtinModules [] :: IO (Interpreter IO ()) + mkInferno builtinPrelude [] :: IO (Interpreter IO ()) case parseAndInferTypeReps src of Left err -> do hPutStrLn stderr $ show err diff --git a/inferno-core/inferno-core.cabal b/inferno-core/inferno-core.cabal index 2308837..d64e7c3 100644 --- a/inferno-core/inferno-core.cabal +++ b/inferno-core/inferno-core.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: inferno-core -version: 0.8.2.0 +version: 0.9.0.0 synopsis: A statically-typed functional scripting language description: Parser, type inference, and interpreter for a statically-typed functional scripting language category: DSL,Scripting @@ -38,7 +38,6 @@ library , Inferno.Parse.Commented , Inferno.Parse.Error , Inferno.Instances.Arbitrary - , Inferno.Utils.QQ.Script , Inferno.Utils.QQ.Module other-modules: Inferno.Infer.Error @@ -61,7 +60,6 @@ library , inferno-vc >= 0.3.0 && < 0.4 , inferno-types >= 0.3.0 && < 0.4 , megaparsec >= 9.2.1 && < 9.3 - , memory >= 0.18.0 && < 0.19 , mtl >= 2.2.2 && < 2.3 , parser-combinators >= 1.3.0 && < 1.4 , picosat >= 0.1.6 && < 0.2 diff --git a/inferno-core/src/Inferno/Core.hs b/inferno-core/src/Inferno/Core.hs index 1f98184..5dbb5fb 100644 --- a/inferno-core/src/Inferno/Core.hs +++ b/inferno-core/src/Inferno/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -18,9 +19,8 @@ import Inferno.Eval.Error (EvalError) import Inferno.Infer (TypeError, inferExpr, inferTypeReps) import Inferno.Infer.Error (Location) import Inferno.Infer.Pinned (pinExpr) -import Inferno.Module (Module (..)) +import Inferno.Module (Module (..), Prelude (..), baseOpsTable, moduleOpsTables, preludeNameToTypeMap, preludePinMap, preludeTermEnv) import Inferno.Module.Builtin (builtinModule) -import Inferno.Module.Prelude (ModuleMap, baseOpsTable, builtinModulesOpsTable, builtinModulesPinMap, builtinModulesTerms, preludeNameToTypeMap) 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)) @@ -71,11 +71,11 @@ data Interpreter m c = Interpreter Set.Set TypeClass } -mkInferno :: forall m c. (MonadThrow m, MonadCatch m, MonadFix m, Eq c, Pretty c) => ModuleMap m c -> [CustomType] -> m (Interpreter m c) -mkInferno prelude customTypes = do +mkInferno :: forall m c. (MonadThrow m, MonadCatch m, MonadFix m, Eq c, Pretty c) => Prelude m c -> [CustomType] -> m (Interpreter m c) +mkInferno prelude@(Prelude {moduleMap}) 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 + (preludeIdentEnv, preludePinnedEnv) <- runImplEnvM Map.empty $ preludeTermEnv prelude return $ Interpreter { evalExpr = runEvalM, @@ -89,16 +89,16 @@ mkInferno prelude customTypes = do where parseAndInfer src = -- parse - case parseExpr (baseOpsTable prelude) (builtinModulesOpsTable prelude) customTypes src of + case parseExpr (baseOpsTable prelude) (moduleOpsTables prelude) customTypes src of Left err -> Left $ ParseError err Right (ast, comments) -> -- pin free variables to builtin prelude function hashes - case pinExpr (builtinModulesPinMap prelude) ast of + case pinExpr (preludePinMap prelude) ast of Left err -> Left $ PinError err Right pinnedAST -> -- typecheck - case inferExpr prelude pinnedAST of + case inferExpr moduleMap pinnedAST of Left err -> Left $ InferenceError err Right (pinnedAST', sch, tyMap) -> Right (pinnedAST', sch, tyMap, comments) @@ -120,7 +120,7 @@ mkInferno prelude customTypes = do [TypeRep (initialPos "dummy") ty | ty <- runtimeReps] in Right finalAst - typeClasses = Set.unions $ moduleTypeClasses builtinModule : [cls | Module {moduleTypeClasses = cls} <- Map.elems prelude] + typeClasses = Set.unions $ moduleTypeClasses builtinModule : [cls | Module {moduleTypeClasses = cls} <- Map.elems moduleMap] -- TODO at some point: instead of evaluating closure and putting into pinned env, -- add closure into the expression being evaluated by using let bindings. diff --git a/inferno-core/src/Inferno/Instances/Arbitrary.hs b/inferno-core/src/Inferno/Instances/Arbitrary.hs index d89bdca..1892b5f 100644 --- a/inferno-core/src/Inferno/Instances/Arbitrary.hs +++ b/inferno-core/src/Inferno/Instances/Arbitrary.hs @@ -30,6 +30,7 @@ import qualified Data.Set as Set import qualified Data.Text as Text (Text, all, null, pack) import GHC.Generics (Generic (..), Rep) import Inferno.Infer.Env (closeOver) +import qualified Inferno.Module as Prelude (baseOpsTable) import qualified Inferno.Module.Prelude as Prelude import qualified Inferno.Types.Module as Module (Module) import Inferno.Types.Syntax @@ -102,7 +103,7 @@ instance (Generic a, GArbitrary ga, ga ~ Rep a) => Arbitrary (GenericArbitrary a arbitrary = GenericArbitrary <$> genericArbitrary baseOpsTable :: OpsTable -baseOpsTable = Prelude.baseOpsTable @IO @() $ Prelude.builtinModules @IO @() +baseOpsTable = Prelude.baseOpsTable @() $ Prelude.builtinPrelude @IO @() -- | Arbitrary and ToADTArbitrary instances for Inferno.Types.Module deriving instance Arbitrary objs => ToADTArbitrary (Module.Module objs) diff --git a/inferno-core/src/Inferno/Module.hs b/inferno-core/src/Inferno/Module.hs index fba6287..934a45a 100644 --- a/inferno-core/src/Inferno/Module.hs +++ b/inferno-core/src/Inferno/Module.hs @@ -1,15 +1,24 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} module Inferno.Module ( Module (..), PinnedModule, + Prelude (..), BuiltinModuleHash (..), BuiltinFunHash (..), BuiltinEnumHash (..), + baseOpsTable, + moduleOpsTables, + preludePinMap, + preludeTermEnv, + preludeNameToTypeMap, buildPinnedQQModules, combineTermEnvs, + emptyPrelude, + buildInitPrelude, pinnedModuleNameToHash, pinnedModuleHashToTy, pinnedModuleTerms, @@ -29,6 +38,7 @@ import Inferno.Infer (inferExpr) import Inferno.Infer.Env (Namespace (..), TypeMetadata (..)) import Inferno.Infer.Pinned (pinExpr) import qualified Inferno.Infer.Pinned as Pinned +import Inferno.Module.Builtin (builtinModule) import Inferno.Module.Cast (ToValue (..)) import Inferno.Parse (OpsTable, TopLevelDefn (..)) import Inferno.Types.Module @@ -62,36 +72,94 @@ import Inferno.Types.VersionControl (Pinned (..), VCObjectHash, pinnedToMaybe, v import Prettyprinter (Pretty) import Text.Megaparsec (SourcePos) +data Prelude m c = Prelude + { moduleMap :: Map.Map ModuleName (PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))), + pinnedModuleMap :: Map.Map (Scoped ModuleName) (Map.Map Namespace (Pinned VCObjectHash)) + -- TODO is pinnedModuleMap not the same as the first component of the PinnedModule of moduleMap above? + } + +emptyPrelude :: Prelude m c +emptyPrelude = Prelude mempty mempty + +baseOpsTable :: (Pretty c, Eq c) => Prelude m c -> OpsTable +baseOpsTable Prelude {moduleMap} = + case Map.lookup "Base" moduleMap of + Just (Module {moduleOpsTable = ops, moduleName = modNm}) -> + -- TODO is 'Scope modNm' below correct? or should it be the name of the module '_' below? + IntMap.unionWith (<>) ops (IntMap.map (\xs -> [(fix, Scope modNm, op) | (fix, _, op) <- xs]) ops) + Nothing -> mempty + +moduleOpsTables :: (Pretty c, Eq c) => Prelude m c -> Map.Map ModuleName OpsTable +moduleOpsTables Prelude {moduleMap} = Map.map (\Module {moduleOpsTable} -> moduleOpsTable) moduleMap + +-- | Map from Module.name to the pinned hash for all names in the given prelude. +-- This functions includes the Inferno.Module.Builtin module and also "exports" +-- the Base module so that it can be used without prefix. +preludePinMap :: (MonadThrow m, Pretty c, Eq c) => Prelude m c -> Map.Map (Scoped ModuleName) (Map.Map Namespace (Pinned VCObjectHash)) +preludePinMap prelude = + Pinned.openModule "Base" $ + Pinned.insertBuiltinModule $ + Map.foldrWithKey Pinned.insertHardcodedModule mempty $ + Map.map (Map.map Builtin . pinnedModuleNameToHash) $ + moduleMap prelude + +preludeTermEnv :: (MonadThrow m, Pretty c, Eq c) => Prelude m c -> ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)) +preludeTermEnv = combineTermEnvs . moduleMap + +preludeNameToTypeMap :: (MonadThrow m, Pretty c, Eq c) => Prelude m c -> Map.Map (Maybe ModuleName, Namespace) (TypeMetadata TCScheme) +preludeNameToTypeMap prelude = + let unqualifiedN2h = pinnedModuleNameToHash $ modules Map.! "Base" + n2h = + Map.unions $ + Map.mapKeys (Nothing,) (pinnedModuleNameToHash builtinModule) + : Map.mapKeys (Nothing,) unqualifiedN2h + : [Map.mapKeys (Just nm,) (pinnedModuleNameToHash m `Map.difference` unqualifiedN2h) | (nm, m) <- Map.toList modules] + h2ty = Map.unions $ pinnedModuleHashToTy builtinModule : [pinnedModuleHashToTy m | m <- Map.elems modules] + in Map.mapMaybe (`Map.lookup` h2ty) n2h + where + modules = moduleMap prelude + 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)) combineTermEnvs modules = foldM (\env m -> (env <>) <$> pinnedModuleTerms m) mempty $ Map.elems modules +-- | A specialiazation of @buildPinnedQQModules@ below with an empty initial prelude. +-- This is to be used in the QuasiQuoter to build the initial/core Inferno prelude. +-- We can't use @buildPinnedQQModules emptyPrelude@ in the QuasiQuoter because TH +-- doesn't like that. +buildInitPrelude :: + (MonadThrow m, Pretty c) => + [(ModuleName, OpsTable, [TopLevelDefn (Either (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c))) (Maybe TCScheme, Expr () SourcePos))])] -> + Prelude m c +buildInitPrelude = buildPinnedQQModules emptyPrelude + buildPinnedQQModules :: (MonadThrow m, Pretty c) => + Prelude m 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)))) -buildPinnedQQModules modules = - snd $ - foldl' - ( \(alreadyPinnedModulesMap, alreadyBuiltModules) (moduleNm, opsTable, sigs) -> - -- first build the new module - let newMod = - buildModule alreadyPinnedModulesMap alreadyBuiltModules sigs $ - Module - { moduleName = moduleNm, - moduleOpsTable = opsTable, - moduleTypeClasses = mempty, - moduleObjects = (Map.singleton (ModuleNamespace moduleNm) $ vcHash $ BuiltinModuleHash moduleNm, mempty, pure mempty) - } - in -- then insert it into the temporary module pin map as well as the final module map - ( Pinned.insertHardcodedModule moduleNm (Map.map Builtin $ pinnedModuleNameToHash newMod) alreadyPinnedModulesMap, - Map.insert moduleNm newMod alreadyBuiltModules - ) - ) - mempty - modules + Prelude m c +buildPinnedQQModules initPrelude modules = + foldl' + ( \Prelude {pinnedModuleMap, moduleMap} (moduleNm, opsTable, sigs) -> + -- first build the new module + let newMod = + buildModule pinnedModuleMap moduleMap sigs $ + Module + { moduleName = moduleNm, + moduleOpsTable = opsTable, + moduleTypeClasses = mempty, + moduleObjects = (Map.singleton (ModuleNamespace moduleNm) $ vcHash $ BuiltinModuleHash moduleNm, mempty, pure mempty) + } + in -- then insert it into the temporary module pin map as well as the final module map + Prelude + { pinnedModuleMap = Pinned.insertHardcodedModule moduleNm (Map.map Builtin $ pinnedModuleNameToHash newMod) pinnedModuleMap, + moduleMap = Map.insert moduleNm newMod moduleMap + } + ) + initPrelude + modules where buildModule :: (MonadThrow m, Pretty c) => diff --git a/inferno-core/src/Inferno/Module/Prelude.hs b/inferno-core/src/Inferno/Module/Prelude.hs index 33688e8..a07aa72 100644 --- a/inferno-core/src/Inferno/Module/Prelude.hs +++ b/inferno-core/src/Inferno/Module/Prelude.hs @@ -8,13 +8,8 @@ module Inferno.Module.Prelude where import Control.Monad.Catch (MonadCatch (..), MonadThrow (..)) import Control.Monad.IO.Class (MonadIO) -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import Inferno.Eval (TermEnv) -import qualified Inferno.Infer.Pinned as Pinned -import Inferno.Module (Module (..), PinnedModule, combineTermEnvs, pinnedModuleHashToTy, pinnedModuleNameToHash) -import Inferno.Module.Builtin (builtinModule) -import Inferno.Module.Cast (Kind0 (toType), ToValue (toValue)) +import Inferno.Module (Prelude) +import Inferno.Module.Cast (Kind0 (toType)) import Inferno.Module.Prelude.Defs ( absFun, andFun, @@ -117,45 +112,9 @@ import Inferno.Module.Prelude.Defs zeroFun, zipFun, ) -import Inferno.Parse (OpsTable) -import Inferno.Types.Syntax (ModuleName, Scoped (..)) -import Inferno.Types.Type (Namespace, TCScheme, TypeMetadata) -import Inferno.Types.Value (ImplEnvM) -import Inferno.Types.VersionControl (Pinned (..), VCObjectHash) -import Inferno.Utils.QQ.Module (infernoModules) +import Inferno.Utils.QQ.Module (builtinPreludeQuoter) import Prettyprinter (Pretty) -type ModuleMap m c = Map.Map ModuleName (PinnedModule (ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)))) - -baseOpsTable :: forall m c. (MonadThrow m, Pretty c, Eq c) => ModuleMap m c -> OpsTable -baseOpsTable moduleMap = - let Module {moduleOpsTable = ops, moduleName = modNm} = moduleMap Map.! "Base" - in IntMap.unionWith (<>) ops (IntMap.map (\xs -> [(fix, Scope modNm, op) | (fix, _, op) <- xs]) ops) - -builtinModulesOpsTable :: forall m c. (MonadThrow m, Pretty c, Eq c) => ModuleMap m c -> Map.Map ModuleName OpsTable -builtinModulesOpsTable = Map.map (\Module {moduleOpsTable} -> moduleOpsTable) - -builtinModulesPinMap :: forall m c. (MonadThrow m, Pretty c, Eq c) => ModuleMap m c -> Map.Map (Scoped ModuleName) (Map.Map Namespace (Pinned VCObjectHash)) -builtinModulesPinMap moduleMap = - Pinned.openModule "Base" $ - Pinned.insertBuiltinModule $ - Map.foldrWithKey Pinned.insertHardcodedModule mempty $ - Map.map (Map.map Builtin . pinnedModuleNameToHash) moduleMap - -builtinModulesTerms :: forall m c. (MonadThrow m, Pretty c, Eq c) => ModuleMap m c -> ImplEnvM m c (TermEnv VCObjectHash c (ImplEnvM m c)) -builtinModulesTerms = combineTermEnvs - -preludeNameToTypeMap :: forall m c. (MonadThrow m, Pretty c, Eq c) => ModuleMap m c -> Map.Map (Maybe ModuleName, Namespace) (TypeMetadata TCScheme) -preludeNameToTypeMap moduleMap = - let unqualifiedN2h = pinnedModuleNameToHash $ moduleMap Map.! "Base" - n2h = - Map.unions $ - Map.mapKeys (Nothing,) (pinnedModuleNameToHash builtinModule) - : Map.mapKeys (Nothing,) unqualifiedN2h - : [Map.mapKeys (Just nm,) (pinnedModuleNameToHash m `Map.difference` unqualifiedN2h) | (nm, m) <- Map.toList moduleMap] - h2ty = Map.unions $ pinnedModuleHashToTy builtinModule : [pinnedModuleHashToTy m | m <- Map.elems moduleMap] - in Map.mapMaybe (`Map.lookup` h2ty) n2h - -- In the definitions below, ###!x### is an anti-quotation to a haskell variable `x` of type `Monad m => (Value m)` -- This sort of Value is necessary for polymorphic functions such as `map` or `id` -- The inferno type of this function must be explicitly specified, otherwise a runtime error will occur when typechecking @@ -166,9 +125,9 @@ preludeNameToTypeMap moduleMap = -- as these require an accompanying definition of a typeclass, via the syntax: -- `define typeclass_name on t1 ... tn;`. -builtinModules :: (MonadIO m, MonadThrow m, MonadCatch m, Pretty c, Eq c) => ModuleMap m c -builtinModules = - [infernoModules| +builtinPrelude :: (MonadIO m, MonadThrow m, MonadCatch m, Pretty c, Eq c) => Prelude m c +builtinPrelude = + [builtinPreludeQuoter| module Number diff --git a/inferno-core/src/Inferno/Utils/QQ/Module.hs b/inferno-core/src/Inferno/Utils/QQ/Module.hs index 6405a9b..2c8f6eb 100644 --- a/inferno-core/src/Inferno/Utils/QQ/Module.hs +++ b/inferno-core/src/Inferno/Utils/QQ/Module.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Inferno.Utils.QQ.Module where @@ -10,13 +12,14 @@ import Data.List (intercalate) import qualified Data.List.NonEmpty as NEList import Data.Text (pack) import Inferno.Infer (closeOverType) -import Inferno.Module (buildPinnedQQModules) -import Inferno.Parse - ( QQDefinition (..), - modulesParser, - topLevel, +import Inferno.Module (Prelude (..), baseOpsTable, buildInitPrelude, emptyPrelude, moduleOpsTables) +import Inferno.Module.Cast (ToValue (..)) +import Inferno.Parse (OpsTable, QQDefinition (..), TopLevelDefn (..), modulesParser, topLevel) +import Inferno.Types.Syntax + ( CustomType, + ModuleName, + TCScheme (..), ) -import Inferno.Types.Syntax (CustomType) import qualified Inferno.Types.Type as Type import Inferno.Utils.QQ.Common ( liftText, @@ -25,7 +28,8 @@ import Inferno.Utils.QQ.Common ) import qualified Language.Haskell.TH.Lib as TH import Language.Haskell.TH.Quote (QuasiQuoter (..), dataToExpQ) -import Language.Haskell.TH.Syntax (mkName) +import Language.Haskell.TH.Syntax (Q, mkName) +import Prettyprinter (Pretty) import Text.Megaparsec ( ParseErrorBundle (ParseErrorBundle), PosState (PosState), @@ -49,30 +53,39 @@ metaToValue = \case (sch, InlineDef e) -> Just [|Right ($(dataToExpQ (\a -> liftText <$> cast a) sch), $(dataToExpQ (\a -> liftText <$> cast a) e))|] --- | QuasiQuoter for builtin Inferno modules. TH dictates that QQs have to be imported, --- not defined locally, so this instantiation is done in this module. -infernoModules :: QuasiQuoter -infernoModules = moduleQuoter [] +parseAndMakePrelude :: + (Eq c, Pretty c) => + Prelude m c -> + [CustomType] -> + String -> + Q [(ModuleName, OpsTable, [TopLevelDefn (Maybe TCScheme, QQDefinition)])] +parseAndMakePrelude initPrelude customTypes str = do + l <- location' + let parse = + runParser' $ + runWriterT $ + flip runReaderT (baseOpsTable initPrelude, moduleOpsTables initPrelude, customTypes) $ + topLevel modulesParser + let (_, res) = + parse $ State (pack str) 0 (PosState (pack str) 0 l defaultTabWidth "") [] + case res of + Left (ParseErrorBundle errs pos) -> + let errs' = map mkParseErrorStr $ NEList.toList $ fst $ attachSourcePos errorOffset errs pos + in fail $ intercalate "\n\n" errs' + Right (modules, _comments) -> + pure modules -moduleQuoter :: [CustomType] -> QuasiQuoter -moduleQuoter customTypes = +modulesToExpQ :: [(ModuleName, OpsTable, [TopLevelDefn (Maybe TCScheme, QQDefinition)])] -> TH.ExpQ +modulesToExpQ modules = dataToExpQ ((\a -> liftText <$> cast a) `extQ` metaToValue) modules + +-- | QuasiQuoter for builtin Inferno prelude. +builtinPreludeQuoter :: QuasiQuoter +builtinPreludeQuoter = QuasiQuoter { quoteExp = \str -> do - l <- location' - let (_, res) = - runParser' (runWriterT $ flip runReaderT (mempty, mempty, customTypes) $ topLevel modulesParser) $ - State - (pack str) - 0 - (PosState (pack str) 0 l defaultTabWidth "") - [] - case res of - Left (ParseErrorBundle errs pos) -> - let errs' = map mkParseErrorStr $ NEList.toList $ fst $ attachSourcePos errorOffset errs pos - in fail $ intercalate "\n\n" errs' - Right (modules, _comments) -> - [|buildPinnedQQModules $(dataToExpQ ((\a -> liftText <$> cast a) `extQ` metaToValue) modules)|], - quotePat = error "moduleQuoter: Invalid use of this quasi-quoter in pattern context.", - quoteType = error "moduleQuoter: Invalid use of this quasi-quoter in type context.", - quoteDec = error "moduleQuoter: Invalid use of this quasi-quoter in top-level declaration context." + modules <- parseAndMakePrelude @() emptyPrelude [] str + [|buildInitPrelude $(modulesToExpQ modules)|], + quotePat = error "builtinPreludeQuoter: Invalid use of this quasi-quoter in pattern context.", + quoteType = error "builtinPreludeQuoter: Invalid use of this quasi-quoter in type context.", + quoteDec = error "builtinPreludeQuoter: Invalid use of this quasi-quoter in top-level declaration context." } diff --git a/inferno-core/src/Inferno/Utils/QQ/Script.hs b/inferno-core/src/Inferno/Utils/QQ/Script.hs deleted file mode 100644 index b951823..0000000 --- a/inferno-core/src/Inferno/Utils/QQ/Script.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - -module Inferno.Utils.QQ.Script where - -import Control.Monad.Catch (MonadCatch (..), MonadThrow (..)) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (ReaderT (..)) -import Control.Monad.Writer (WriterT (..), appEndo) -import qualified Crypto.Hash as Crypto -import Data.ByteArray (convert) -import Data.ByteString (ByteString, unpack) -import Data.Data (cast) -import Data.Generics.Aliases (extQ) -import Data.List (intercalate) -import qualified Data.List.NonEmpty as NEList -import qualified Data.Maybe as Maybe -import Data.Text (pack) -import Inferno.Infer (inferExpr) -import Inferno.Infer.Pinned (pinExpr) -import Inferno.Module.Prelude (baseOpsTable, builtinModules, builtinModulesOpsTable, builtinModulesPinMap) -import Inferno.Parse (expr, topLevel) -import Inferno.Parse.Commented (insertCommentsIntoExpr) -import Inferno.Utils.QQ.Common - ( liftText, - location', - mkParseErrorStr, - ) -import qualified Language.Haskell.TH.Lib as TH -import Language.Haskell.TH.Quote (QuasiQuoter (..), dataToExpQ) -import Language.Haskell.TH.Syntax (Exp (AppE, VarE), Lift (lift)) -import Prettyprinter (Pretty) -import Text.Megaparsec - ( ParseErrorBundle (ParseErrorBundle), - PosState (PosState), - State (State), - attachSourcePos, - defaultTabWidth, - errorOffset, - runParser', - ) - -inferno :: forall m c. (MonadIO m, MonadThrow m, MonadCatch m, Pretty c, Eq c) => QuasiQuoter -inferno = - QuasiQuoter - { quoteExp = \str -> do - l <- location' - let (_, res) = - runParser' (runWriterT $ flip runReaderT (baseOpsTable @_ @c builtins, builtinModulesOpsTable @_ @c builtins, []) $ topLevel $ expr) $ - State - (pack str) - 0 - (PosState (pack str) 0 l defaultTabWidth "") - [] - case res of - Left (ParseErrorBundle errs pos) -> - let errs' = map mkParseErrorStr $ NEList.toList $ fst $ attachSourcePos errorOffset errs pos - in fail $ intercalate "\n\n" errs' - Right (ast, comments) -> - case pinExpr (builtinModulesPinMap @_ @c builtins) ast of - Left err -> fail $ "Pinning expression failed:\n" <> show err - Right pinnedAST -> - case inferExpr builtins pinnedAST of - Left err -> fail $ "Inference failed:\n" <> show err - Right (pinnedAST', t, _tyMap) -> do - let final = insertCommentsIntoExpr (appEndo comments []) pinnedAST' - dataToExpQ ((\a -> liftText <$> cast a) `extQ` vcObjectHashToValue) (final, t), - quotePat = error "inferno: Invalid use of this quasi-quoter in pattern context.", - quoteType = error "inferno: Invalid use of this quasi-quoter in type context.", - quoteDec = error "inferno: Invalid use of this quasi-quoter in top-level declaration context." - } - where - builtins = builtinModules @m @c - vcObjectHashToValue :: Crypto.Digest Crypto.SHA256 -> Maybe TH.ExpQ - vcObjectHashToValue h = - let str = (convert h) :: ByteString - in Just $ - ( AppE (VarE 'Maybe.fromJust) - <$> (AppE (VarE 'Crypto.digestFromByteString) <$> lift (unpack str)) - ) diff --git a/inferno-core/test/Eval/Spec.hs b/inferno-core/test/Eval/Spec.hs index 3d0b0a8..9478f25 100644 --- a/inferno-core/test/Eval/Spec.hs +++ b/inferno-core/test/Eval/Spec.hs @@ -13,14 +13,14 @@ import qualified Data.Map as Map import Data.Text (unpack) import Inferno.Core (Interpreter (..), mkInferno) import Inferno.Eval.Error (EvalError (..)) +import Inferno.Module (Prelude (..)) import Inferno.Module.Builtin (enumBoolHash) -import Inferno.Module.Prelude (ModuleMap) -import qualified Inferno.Module.Prelude as Prelude +import Inferno.Module.Prelude (builtinPrelude) import Inferno.Types.Syntax (BaseType (..), Expr (..), ExtIdent (..), Ident (..), InfernoType (..)) import Inferno.Types.Value (ImplEnvM (..), Value (..), liftImplEnvM) import Inferno.Types.VersionControl (pinnedToMaybe) import Inferno.Utils.Prettyprinter (renderPretty) -import Inferno.Utils.QQ.Module (infernoModules) +import Inferno.Utils.QQ.Module (builtinPreludeQuoter) import Test.Hspec (Spec, describe, expectationFailure, it, runIO, shouldBe) type TestCustomValue = () @@ -53,7 +53,7 @@ evalTests :: Spec evalTests = describe "evaluate" $ do inferno@(Interpreter {evalExpr, defaultEnv, parseAndInferTypeReps}) <- - runIO $ (mkInferno Prelude.builtinModules [] :: IO (Interpreter IO TestCustomValue)) + runIO $ (mkInferno builtinPrelude [] :: IO (Interpreter IO TestCustomValue)) let shouldEvaluateInEnvTo implEnv str (v :: Value TestCustomValue IO) = it ("\"" <> unpack str <> "\" should evaluate to " <> (unpack $ renderPretty v)) $ do case parseAndInferTypeReps str of @@ -426,11 +426,16 @@ cachedGet = TestEnv {cache} <- liftImplEnvM $ ask pure $ VInt cache -evalInMonadPrelude :: ModuleMap (ReaderT TestEnv IO) TestCustomValue +-- Since this is a test, we build a prelude from scratch, instead of extending the +-- builtin/core Inferno prelude from Inferno.Module.Prelude. +-- To keep the rest of the code happy, we need to include a dummy Base module. +evalInMonadPrelude :: Prelude (ReaderT TestEnv IO) TestCustomValue evalInMonadPrelude = - [infernoModules| -module EvalInMonad + [builtinPreludeQuoter| +module Base + zero : int := 0; +module EvalInMonad cachedGet : () -> int := ###!cachedGet###; |] @@ -438,13 +443,10 @@ evalInMonadTest :: Spec evalInMonadTest = do let testEnv = TestEnv {cache = 4} - let modules = - Map.unionWith - (error "Duplicate module name in builtinModules") - (Prelude.builtinModules @(ReaderT TestEnv IO) @TestCustomValue) - evalInMonadPrelude Interpreter {evalExpr, defaultEnv, parseAndInferTypeReps} <- - runIO $ flip runReaderT testEnv $ (mkInferno modules [] :: ReaderT TestEnv IO (Interpreter (ReaderT TestEnv IO) TestCustomValue)) + runIO $ + flip runReaderT testEnv $ + (mkInferno evalInMonadPrelude [] :: ReaderT TestEnv IO (Interpreter (ReaderT TestEnv IO) TestCustomValue)) let shouldEvaluateInEnvTo implEnv str (v :: Value TestCustomValue IO) = it ("\"" <> unpack str <> "\" should evaluate to " <> (unpack $ renderPretty v)) $ do @@ -457,5 +459,5 @@ evalInMonadTest = do Right v' -> (renderPretty v') `shouldBe` (renderPretty v) let shouldEvaluateTo = shouldEvaluateInEnvTo Map.empty - describe "TODO" $ do + describe "evaluate in custom monad" $ do shouldEvaluateTo "EvalInMonad.cachedGet ()" $ VInt 4 diff --git a/inferno-core/test/Infer/Spec.hs b/inferno-core/test/Infer/Spec.hs index 76406fa..714fb45 100644 --- a/inferno-core/test/Infer/Spec.hs +++ b/inferno-core/test/Infer/Spec.hs @@ -41,7 +41,7 @@ inferTests = describe "infer" $ let repTC ts = makeTCs "rep" ts let makeType numTypeVars typeClassList t = ForallTC (map (\i -> TV {unTV = i}) [0 .. numTypeVars]) (Set.fromList typeClassList) (ImplType mempty t) - inferno <- runIO $ (mkInferno Prelude.builtinModules [] :: IO (Interpreter IO ())) + inferno <- runIO $ (mkInferno Prelude.builtinPrelude [] :: IO (Interpreter IO ())) let shouldInferTypeFor str t = it ("should infer type of \"" <> unpack str <> "\"") $ case parseAndInfer inferno str of diff --git a/inferno-core/test/Parse/Spec.hs b/inferno-core/test/Parse/Spec.hs index 22f1fc5..b68bb52 100644 --- a/inferno-core/test/Parse/Spec.hs +++ b/inferno-core/test/Parse/Spec.hs @@ -11,7 +11,8 @@ import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text, pack, unpack) import Data.Text.Lazy (toStrict) import Inferno.Instances.Arbitrary () -import Inferno.Module.Prelude (ModuleMap, baseOpsTable, builtinModules, builtinModulesOpsTable) +import Inferno.Module (Prelude, baseOpsTable, moduleOpsTables) +import Inferno.Module.Prelude (builtinPrelude) import Inferno.Parse (parseExpr, prettyError) import Inferno.Types.Syntax ( BlockUtils (removeComments), @@ -40,8 +41,8 @@ import Test.QuickCheck ) import Text.Pretty.Simple (pShow) -prelude :: ModuleMap IO () -prelude = builtinModules +prelude :: Prelude IO () +prelude = builtinPrelude normalizePat :: Pat h a -> Pat h a normalizePat = ana $ \case @@ -81,7 +82,7 @@ parsingTests = describe "pretty printing/parsing" $ do prop "parseExpr and pretty are inverse up to normalizeExpr" $ \(x :: Expr () ()) -> within 10000000 $ - case parseExpr (baseOpsTable prelude) (builtinModulesOpsTable prelude) [] (renderPretty x) of + case parseExpr (baseOpsTable prelude) (moduleOpsTables prelude) [] (renderPretty x) of Left err -> property False ( "Pretty: \n" @@ -254,11 +255,11 @@ parsingTests = describe "pretty printing/parsing" $ do where shouldSucceedFor str ast = it ("should succeed for \"" <> unpack str <> "\"") $ - case parseExpr (baseOpsTable prelude) (builtinModulesOpsTable prelude) [] str of + case parseExpr (baseOpsTable prelude) (moduleOpsTables prelude) [] str of Left err -> expectationFailure $ "Failed with: " <> (prettyError $ fst $ NonEmpty.head err) Right (res, _) -> fmap (const ()) res `shouldBe` ast shouldFailFor str = it ("should fail for \"" <> unpack str <> "\"") $ - case parseExpr (baseOpsTable prelude) (builtinModulesOpsTable prelude) [] str of + case parseExpr (baseOpsTable prelude) (moduleOpsTables prelude) [] str of Left _err -> pure () Right _res -> expectationFailure $ "This should not parse" diff --git a/inferno-lsp/CHANGELOG.md b/inferno-lsp/CHANGELOG.md index d0a358c..32cdc1d 100644 --- a/inferno-lsp/CHANGELOG.md +++ b/inferno-lsp/CHANGELOG.md @@ -1,6 +1,9 @@ # Revision History for inferno-lsp *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH) +## 0.3.0.0 -- 2023-11-07 +* Use new Prelude type and new Inferno.Core.Interpreter API + ## 0.2.1.0 -- 2023-11-01 * Update inferno-types version diff --git a/inferno-lsp/app/Main.hs b/inferno-lsp/app/Main.hs index 8c913fd..b279967 100644 --- a/inferno-lsp/app/Main.hs +++ b/inferno-lsp/app/Main.hs @@ -4,11 +4,11 @@ module Main where import Inferno.LSP.Server (runInfernoLspServer) -import Inferno.Module.Prelude (builtinModules) +import Inferno.Module.Prelude (builtinPrelude) import System.Exit (ExitCode (ExitFailure), exitSuccess, exitWith) main :: IO () main = do - runInfernoLspServer @() builtinModules [] >>= \case + runInfernoLspServer @() builtinPrelude [] >>= \case 0 -> exitSuccess c -> exitWith . ExitFailure $ c diff --git a/inferno-lsp/inferno-lsp.cabal b/inferno-lsp/inferno-lsp.cabal index 5db720b..6ba9220 100644 --- a/inferno-lsp/inferno-lsp.cabal +++ b/inferno-lsp/inferno-lsp.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: inferno-lsp -version: 0.2.1.0 +version: 0.3.0.0 synopsis: LSP for Inferno description: A language server protocol implementation for the Inferno language category: IDE,DSL,Scripting @@ -32,7 +32,7 @@ library , bytestring >= 0.10.10 && < 0.12 , co-log-core >= 0.3.1 && < 0.4 , containers >= 0.6.2 && < 0.7 - , inferno-core >= 0.8.0 && < 0.9 + , inferno-core >= 0.9.0 && < 0.10 , inferno-types >= 0.2.0 && < 0.4 , inferno-vc >= 0.3.0 && < 0.4 , lsp >= 1.6.0 && < 1.7 diff --git a/inferno-lsp/src/Inferno/LSP/ParseInfer.hs b/inferno-lsp/src/Inferno/LSP/ParseInfer.hs index a23c89a..5f188f7 100644 --- a/inferno-lsp/src/Inferno/LSP/ParseInfer.hs +++ b/inferno-lsp/src/Inferno/LSP/ParseInfer.hs @@ -18,7 +18,7 @@ import qualified Data.Text as Text import Inferno.Core (InfernoError (..), Interpreter (..), mkInferno) import Inferno.Infer (TypeError (..), closeOverType, findTypeClassWitnesses, inferPossibleTypes, inferTypeReps) import Inferno.Infer.Env (Namespace (..)) -import Inferno.Module.Prelude (ModuleMap) +import Inferno.Module (Prelude) import Inferno.Parse (parseType) import Inferno.Parse.Commented (insertCommentsIntoExpr) import Inferno.Parse.Error (prettyError) @@ -567,7 +567,7 @@ parseAndInferDiagnostics Interpreter {parseAndInfer, typeClasses} idents txt val Just (s, e) -> Left [errorDiagnosticInfer (unPos $ sourceLine s) (unPos $ sourceColumn s) (unPos $ sourceLine e) (unPos $ sourceColumn e) err] _ -> Right () -parseAndInferPretty :: forall c. (Pretty c, Eq c) => ModuleMap IO c -> Text -> IO () +parseAndInferPretty :: forall c. (Pretty c, Eq c) => Prelude IO c -> Text -> IO () parseAndInferPretty prelude txt = do interpreter@(Interpreter {typeClasses}) <- mkInferno prelude [] (parseAndInferDiagnostics @IO @c interpreter) [] txt (const $ Right ()) >>= \case @@ -581,7 +581,7 @@ parseAndInferPretty prelude txt = do putStrLn $ "\ntype (pretty)" <> (Text.unpack $ renderDoc $ mkPrettyTy typeClasses mempty typ) -parseAndInferTypeReps :: forall c. (Pretty c, Eq c) => ModuleMap IO c -> Text -> [Text] -> Text -> IO () +parseAndInferTypeReps :: forall c. (Pretty c, Eq c) => Prelude IO c -> Text -> [Text] -> Text -> IO () parseAndInferTypeReps prelude expr inTys outTy = do interpreter@(Interpreter {typeClasses}) <- mkInferno prelude [] (parseAndInferDiagnostics @IO @c interpreter) [] expr (const $ Right ()) >>= \case @@ -603,7 +603,7 @@ parseAndInferTypeReps prelude expr inTys outTy = do putStrLn ("type reps:" :: String) print res -parseAndInferPossibleTypes :: forall c. (Pretty c, Eq c) => ModuleMap IO c -> Text -> [Maybe Text] -> Maybe Text -> IO () +parseAndInferPossibleTypes :: forall c. (Pretty c, Eq c) => Prelude IO c -> Text -> [Maybe Text] -> Maybe Text -> IO () parseAndInferPossibleTypes prelude expr inTys outTy = do interpreter@(Interpreter {typeClasses}) <- mkInferno prelude [] (parseAndInferDiagnostics @IO @c interpreter) [] expr (const $ Right ()) >>= \case diff --git a/inferno-lsp/src/Inferno/LSP/Server.hs b/inferno-lsp/src/Inferno/LSP/Server.hs index d02b83d..695f14f 100644 --- a/inferno-lsp/src/Inferno/LSP/Server.hs +++ b/inferno-lsp/src/Inferno/LSP/Server.hs @@ -33,7 +33,7 @@ import qualified Data.UUID.V4 as UUID.V4 import Inferno.Core (Interpreter (..), mkInferno) import Inferno.LSP.Completion (completionQueryAt, filterModuleNameCompletionItems, findInPrelude, identifierCompletionItems, mkCompletionItem, rwsCompletionItems) import Inferno.LSP.ParseInfer (errorDiagnostic, parseAndInferDiagnostics) -import Inferno.Module.Prelude (ModuleMap) +import Inferno.Module (Prelude) import Inferno.Types.Syntax (CustomType, Expr, Ident (..), InfernoType) import Inferno.Types.Type (TCScheme) import Inferno.Types.VersionControl (Pinned) @@ -80,7 +80,7 @@ runInfernoLspServerWith :: IOTracer T.Text -> IO BS.ByteString -> (BSL.ByteString -> IO ()) -> - ModuleMap IO c -> + Prelude IO c -> [CustomType] -> IO [Maybe Ident] -> (InfernoType -> Either T.Text ()) -> @@ -117,7 +117,7 @@ runInfernoLspServerWith tracer clientIn clientOut prelude customTypes getIdents ioExcept (e :: E.IOException) = traceWith tracer (T.pack (show e)) >> return 1 someExcept (e :: E.SomeException) = traceWith tracer (T.pack (show e)) >> return 1 -runInfernoLspServer :: forall c. (Pretty c, Eq c) => ModuleMap IO c -> [CustomType] -> IO Int +runInfernoLspServer :: forall c. (Pretty c, Eq c) => Prelude IO c -> [CustomType] -> IO Int runInfernoLspServer prelude customTypes = do hSetBuffering stdin NoBuffering hSetEncoding stdin utf8 diff --git a/inferno-ml/CHANGELOG.md b/inferno-ml/CHANGELOG.md index cef7d4d..7794157 100644 --- a/inferno-ml/CHANGELOG.md +++ b/inferno-ml/CHANGELOG.md @@ -1,6 +1,9 @@ # Revision History for inferno-ml *Note*: we use https://pvp.haskell.org/ (MAJOR.MAJOR.MINOR.PATCH) +## 0.1.3.0 -- 2023-11-07 +* Use new Prelude chaining and new Inferno.Core.Interpreter API + ## 0.1.2.1 -- 2023-10-24 * Update to use changed Interpreter API type diff --git a/inferno-ml/app/Main.hs b/inferno-ml/app/Main.hs index 71cfed7..69a5b04 100644 --- a/inferno-ml/app/Main.hs +++ b/inferno-ml/app/Main.hs @@ -7,7 +7,7 @@ import qualified Data.Map as Map import qualified Data.Text.IO as Text import Inferno.Core (Interpreter (..), mkInferno) import Inferno.ML.Module.Prelude (mlPrelude) -import Inferno.ML.Types.Value (MlValue, customTypes) +import Inferno.ML.Types.Value (MlValue, mlTypes) import Inferno.Utils.Prettyprinter (showPretty) import System.Environment (getArgs) @@ -16,7 +16,7 @@ main = do file <- head <$> getArgs src <- Text.readFile file Interpreter {evalExpr, defaultEnv, parseAndInferTypeReps} <- - mkInferno mlPrelude customTypes :: IO (Interpreter IO MlValue) + mkInferno mlPrelude mlTypes :: IO (Interpreter IO MlValue) case parseAndInferTypeReps src of Left err -> print err Right ast -> diff --git a/inferno-ml/inferno-ml.cabal b/inferno-ml/inferno-ml.cabal index 5649609..87dacd3 100644 --- a/inferno-ml/inferno-ml.cabal +++ b/inferno-ml/inferno-ml.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: inferno-ml -version: 0.1.2.1 +version: 0.1.3.0 synopsis: Machine Learning primitives for Inferno description: Machine Learning primitives for Inferno homepage: https://github.com/plow-technologies/inferno.git#readme @@ -21,16 +21,18 @@ library exposed-modules: Inferno.ML.Module.Prelude , Inferno.ML.Types.Value + other-modules: + Inferno.ML.Module.QQ hs-source-dirs: src ghc-options: -Wall -Werror -Wincomplete-uni-patterns -Wincomplete-record-updates -Wunused-packages build-depends: base - , containers , exceptions , hasktorch , inferno-core , inferno-types + , megaparsec , template-haskell , text , prettyprinter diff --git a/inferno-ml/lsp/Main.hs b/inferno-ml/lsp/Main.hs index 4bae601..4adddec 100644 --- a/inferno-ml/lsp/Main.hs +++ b/inferno-ml/lsp/Main.hs @@ -5,11 +5,11 @@ module Main where import Inferno.LSP.Server (runInfernoLspServer) import Inferno.ML.Module.Prelude (mlPrelude) -import Inferno.ML.Types.Value (MlValue, customTypes) +import Inferno.ML.Types.Value (MlValue, mlTypes) import System.Exit (ExitCode (ExitFailure), exitSuccess, exitWith) main :: IO () main = do - runInfernoLspServer @MlValue mlPrelude customTypes >>= \case + runInfernoLspServer @MlValue mlPrelude mlTypes >>= \case 0 -> exitSuccess c -> exitWith . ExitFailure $ c diff --git a/inferno-ml/src/Inferno/ML/Module/Prelude.hs b/inferno-ml/src/Inferno/ML/Module/Prelude.hs index e746e97..a1a6e6d 100644 --- a/inferno-ml/src/Inferno/ML/Module/Prelude.hs +++ b/inferno-ml/src/Inferno/ML/Module/Prelude.hs @@ -5,24 +5,18 @@ module Inferno.ML.Module.Prelude (mlPrelude) where -import Control.Monad.Catch (MonadThrow (throwM)) +import Control.Monad.Catch (MonadCatch, MonadThrow (throwM)) import Control.Monad.IO.Class (MonadIO, liftIO) -import qualified Data.Map as Map import Data.Proxy (Proxy (Proxy)) import Data.Text (Text, unpack) import GHC.IO.Unsafe (unsafePerformIO) -import Inferno.Eval as Eval (TermEnv) import Inferno.Eval.Error (EvalError (..)) +import Inferno.ML.Module.QQ (preludeQuoter) import Inferno.ML.Types.Value +import Inferno.Module (Prelude) import Inferno.Module.Cast (FromValue (fromValue), ToValue (toValue)) -import qualified Inferno.Module.Prelude as Prelude -import Inferno.Types.Module (PinnedModule) -import Inferno.Types.Syntax - ( Ident, - ModuleName (..), - ) -import Inferno.Types.Value (ImplEnvM, Value (..)) -import Inferno.Types.VersionControl (VCObjectHash) +import Inferno.Types.Syntax (Ident) +import Inferno.Types.Value (Value (..)) import Torch import qualified Torch.DType as TD import Torch.Functional @@ -143,9 +137,9 @@ toDeviceFun d t = device' -> error $ "Unknown device setting: " ++ unpack device' in toDevice dev t -mlModules :: (MonadThrow m, MonadIO m) => Prelude.ModuleMap m MlValue -mlModules = - [mlQuoter| +mlPrelude :: (MonadThrow m, MonadCatch m, MonadIO m) => Prelude m MlValue +mlPrelude = + [preludeQuoter| module ML @@ -208,10 +202,3 @@ module ML forward : model -> array of tensor -> array of tensor := ###forwardFun###; |] - -mlPrelude :: Map.Map ModuleName (PinnedModule (ImplEnvM IO MlValue (Eval.TermEnv VCObjectHash MlValue (ImplEnvM IO MlValue)))) -mlPrelude = - Map.unionWith - (error "Duplicate module name in builtinModules") - (Prelude.builtinModules @IO @MlValue) - (mlModules @IO) diff --git a/inferno-ml/src/Inferno/ML/Module/QQ.hs b/inferno-ml/src/Inferno/ML/Module/QQ.hs new file mode 100644 index 0000000..c44b46b --- /dev/null +++ b/inferno-ml/src/Inferno/ML/Module/QQ.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Inferno.ML.Module.QQ (preludeQuoter) where + +import Control.Monad.Catch (MonadCatch, MonadThrow (..)) +import Control.Monad.IO.Class (MonadIO) +import Inferno.ML.Types.Value (MlValue, mlTypes) +import Inferno.Module (Prelude (..), buildPinnedQQModules) +import Inferno.Module.Prelude (builtinPrelude) +import Inferno.Parse (OpsTable, TopLevelDefn (..)) +import Inferno.Types.Syntax + ( Expr, + ModuleName, + TCScheme (..), + ) +import Inferno.Types.Value (ImplEnvM, Value) +import Inferno.Utils.QQ.Module (modulesToExpQ, parseAndMakePrelude) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Prettyprinter (Pretty) +import Text.Megaparsec (SourcePos) + +buildPrelude :: + (MonadIO m, MonadThrow m, MonadCatch m, Pretty c, Eq c) => + [(ModuleName, OpsTable, [TopLevelDefn (Either (TCScheme, ImplEnvM m c (Value c (ImplEnvM m c))) (Maybe TCScheme, Expr () SourcePos))])] -> + Prelude m c +buildPrelude = buildPinnedQQModules builtinPrelude + +-- | QuasiQuoter for building a prelude that builds on top of the builtin Inferno prelude. +preludeQuoter :: QuasiQuoter +preludeQuoter = + QuasiQuoter + { quoteExp = \str -> do + modules <- parseAndMakePrelude @MlValue (builtinPrelude @IO @MlValue) mlTypes str + [|buildPrelude $(modulesToExpQ modules)|], + quotePat = error "preludeQuoter: Invalid use of this quasi-quoter in pattern context.", + quoteType = error "preludeQuoter: Invalid use of this quasi-quoter in type context.", + quoteDec = error "preludeQuoter: Invalid use of this quasi-quoter in top-level declaration context." + } diff --git a/inferno-ml/src/Inferno/ML/Types/Value.hs b/inferno-ml/src/Inferno/ML/Types/Value.hs index 93200a0..fd9ab5b 100644 --- a/inferno-ml/src/Inferno/ML/Types/Value.hs +++ b/inferno-ml/src/Inferno/ML/Types/Value.hs @@ -4,8 +4,6 @@ import qualified Data.Text as Text import Inferno.Module.Cast (FromValue (..), ToValue (..), couldNotCast) import Inferno.Types.Syntax (CustomType) import Inferno.Types.Value (Value (VCustom)) -import Inferno.Utils.QQ.Module (moduleQuoter) -import Language.Haskell.TH.Quote (QuasiQuoter (..)) import Prettyprinter (Pretty (pretty), align) import qualified Torch as T @@ -36,8 +34,5 @@ instance FromValue MlValue m T.ScriptModule where fromValue (VCustom (VModel t)) = pure t fromValue v = couldNotCast v -customTypes :: [CustomType] -customTypes = ["tensor", "model"] - -mlQuoter :: QuasiQuoter -mlQuoter = moduleQuoter customTypes +mlTypes :: [CustomType] +mlTypes = ["tensor", "model"] diff --git a/inferno-ml/test/Spec.hs b/inferno-ml/test/Spec.hs index 5630ecd..a3db0e6 100644 --- a/inferno-ml/test/Spec.hs +++ b/inferno-ml/test/Spec.hs @@ -10,7 +10,7 @@ import qualified Data.Map as Map import Data.Text (Text, unpack) import Inferno.Core (InfernoError (..), Interpreter (..), mkInferno) import Inferno.ML.Module.Prelude (mlPrelude) -import Inferno.ML.Types.Value (MlValue (VTensor), customTypes) +import Inferno.ML.Types.Value (MlValue (VTensor), mlTypes) import Inferno.Parse.Error (prettyError) import Inferno.Types.Value (Value (..)) import Inferno.Utils.Prettyprinter (renderPretty) @@ -48,7 +48,7 @@ evalTests :: Spec evalTests = describe "evaluate" $ do Interpreter {evalExpr, defaultEnv, parseAndInfer, parseAndInferTypeReps} <- - runIO $ (mkInferno mlPrelude customTypes :: IO (Interpreter IO MlValue)) + runIO $ (mkInferno mlPrelude mlTypes :: IO (Interpreter IO MlValue)) let shouldEvaluateInEnvTo implEnv str (v :: Value MlValue IO) = it ("\"" <> unpack str <> "\" should evaluate to " <> (unpack $ renderPretty v)) $ do case parseAndInferTypeReps str of