From 0de32f92384d3fc26bcd1f0359457ca7d1e6724b Mon Sep 17 00:00:00 2001 From: gnumonik Date: Thu, 29 Aug 2024 02:01:01 -0400 Subject: [PATCH] more cleaning up, more removing dead code, more writing comments --- purescript.cabal | 2 +- .../Purus/{Pipeline/CompileToPIR => }/Eval.hs | 69 ++-------- src/Language/Purus/IR.hs | 26 +++- src/Language/Purus/Make.hs | 124 +++++------------ src/Language/Purus/Pipeline/CompileToPIR.hs | 3 +- .../Purus/Pipeline/CompileToPIR/Utils.hs | 54 ++------ src/Language/Purus/Pipeline/DesugarObjects.hs | 92 +------------ src/Language/Purus/Pipeline/EliminateCases.hs | 16 +-- .../Purus/Pipeline/GenerateDatatypes.hs | 54 +++++--- .../Purus/Pipeline/GenerateDatatypes/Utils.hs | 55 +++----- src/Language/Purus/Pipeline/Inline.hs | 22 +-- src/Language/Purus/Pipeline/Inline/Types.hs | 6 +- src/Language/Purus/Pipeline/Instantiate.hs | 9 +- src/Language/Purus/Pipeline/Lift.hs | 28 +--- src/Language/Purus/Pipeline/Monad.hs | 130 +++--------------- src/Language/Purus/Prim/Ledger.hs | 29 +++- src/Language/Purus/Utils.hs | 12 +- tests/TestPurus.hs | 22 +-- 18 files changed, 217 insertions(+), 536 deletions(-) rename src/Language/Purus/{Pipeline/CompileToPIR => }/Eval.hs (52%) diff --git a/purescript.cabal b/purescript.cabal index e7436362..d87ba605 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -408,12 +408,12 @@ library Language.Purus.Config Language.Purus.Debug + Language.Purus.Eval Language.Purus.IR Language.Purus.IR.Utils Language.Purus.Make Language.Purus.Pipeline.Monad Language.Purus.Pipeline.CompileToPIR - Language.Purus.Pipeline.CompileToPIR.Eval Language.Purus.Pipeline.CompileToPIR.Utils Language.Purus.Pipeline.DesugarCore Language.Purus.Pipeline.DesugarObjects diff --git a/src/Language/Purus/Pipeline/CompileToPIR/Eval.hs b/src/Language/Purus/Eval.hs similarity index 52% rename from src/Language/Purus/Pipeline/CompileToPIR/Eval.hs rename to src/Language/Purus/Eval.hs index 3d8b3cff..7e9b82f3 100644 --- a/src/Language/Purus/Pipeline/CompileToPIR/Eval.hs +++ b/src/Language/Purus/Eval.hs @@ -1,33 +1,25 @@ {-# LANGUAGE TypeApplications #-} -module Language.Purus.Pipeline.CompileToPIR.Eval where +module Language.Purus.Eval ( + compileToUPLC, + evaluateTerm, + -- temporary for GHCI testing. TODO move these to the test suite + passing + ) where import Prelude import Data.Text (Text) -import Data.Text qualified as T - -import Data.Foldable (traverse_) import Data.Bifunctor (Bifunctor (first)) -import Data.Functor ((<&>)) import Control.Exception (throwIO) -import Control.Exception qualified as E import Control.Monad (join, void) import Control.Monad.Reader (Reader, runReader) import Control.Monad.Trans.Except (ExceptT, runExceptT) -import Language.PureScript.CoreFn.Module (Datatypes) - -import Language.Purus.IR (BVar, Exp, FVar, Ty) -import Language.Purus.IR qualified as IR -import Language.Purus.IR.Utils (WithoutObjects) -import Language.Purus.Pretty.Common (prettyStr) -import Language.Purus.Types (PIRTerm) - -import Bound (Var) +import Language.Purus.Types (PIRTerm, PLCTerm) import PlutusCore ( getDefTypeCheckConfig, @@ -44,7 +36,6 @@ import PlutusCore.Evaluation.Machine.Ck ( unsafeEvaluateCk, ) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC -import PlutusCore.Pretty (prettyPlcReadableDef) import PlutusIR (Name, Program (Program)) import PlutusIR.Compiler (CompilationCtx, Compiling, compileProgram, compileToReadable, toDefaultCompilationCtx) import PlutusIR.Compiler.Provenance (Provenance (Original)) @@ -52,58 +43,23 @@ import PlutusIR.Error (Error) type PLCProgram uni fun a = PLC.Program PLC.TyName PLC.Name uni fun (Provenance a) ----- Compilation helpers/utilities - --- FIXME/TODO re-implement this when we have the pipeline reorganized and rebuilt -prepPIR :: String -> Text -> IO (Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)), Datatypes IR.Kind Ty) -prepPIR = undefined - -runPLCProgram :: PLCProgram DefaultUni DefaultFun () -> (EvaluationResult (PLC.Term PLC.TyName Name DefaultUni DefaultFun ()), [Text]) +{- Evaluates a UPLC Program -} +runPLCProgram :: PLCProgram DefaultUni DefaultFun () -> (EvaluationResult PLCTerm, [Text]) runPLCProgram (PLC.Program _ _ c) = unsafeEvaluateCk PLC.defaultBuiltinsRuntime $ void c -declToPIR :: - FilePath -> - Text -> - IO PIRTerm -declToPIR _path _decl = undefined {- - prepPIR path decl >>= \case - (mainExpr, datatypes) -> do - case mkTypeBindDict datatypes mainExpr of - Left err -> throwIO . userError $ err - Right dict -> case runPlutusContext dict $ firstPass datatypes id =<< eliminateCaseExpressionsTrace datatypes mainExpr of - Left err -> throwIO . userError $ err - Right e -> do - print (pretty e) - let - dtBinds = NE.fromList $ PIR.DatatypeBind () <$> M.elems (dict ^. pirDatatypes) - result = PIR.Let () Rec dtBinds e - putStrLn "-------\\/ PIR \\/ --------" - print e - print $ prettyPirReadable result - pure result - -} - -printExpr :: FilePath -> Text -> IO () -printExpr path decl = - prepPIR path decl >>= \case - (e, _) -> putStrLn ("\n\n\n" <> T.unpack decl <> " = \n" <> prettyStr e) - -declToPLC :: FilePath -> Text -> IO (PLCProgram DefaultUni DefaultFun ()) -declToPLC path main = declToPIR path main >>= compileToUPLC - +{- Evaluates a PIR Term -} evaluateTerm :: PIRTerm -> IO (EvaluationResult (PLC.Term PLC.TyName Name DefaultUni DefaultFun ()), [Text]) evaluateTerm term = runPLCProgram <$> compileToUPLC term +{- Compile a PIR Term to a UPLC Program-} compileToUPLC :: PIRTerm -> IO (PLCProgram DefaultUni DefaultFun ()) compileToUPLC e = do let input = Program (Original ()) latestVersion (Original <$> e) withErrors = either (throwIO . userError) pure readable <- withErrors . runCompile $ compileToReadable input - let pretty = prettyPlcReadableDef readable - putStrLn "-------\\/ PIR (2) \\/ --------" - print pretty withErrors . runCompile $ compileProgram (void readable) +{- lol -} runCompile :: forall e m c b. ( e ~ Error DefaultUni DefaultFun (Provenance ()) @@ -123,6 +79,7 @@ runCompile x = in first show res +-- temporary list of test cases used to validate compiler behavior passing :: [Text] passing = [ "testTestClass" diff --git a/src/Language/Purus/IR.hs b/src/Language/Purus/IR.hs index d1c7f3f7..9313acf9 100644 --- a/src/Language/Purus/IR.hs +++ b/src/Language/Purus/IR.hs @@ -18,7 +18,7 @@ import Prelude import Protolude.List (ordNub) -import Control.Monad +import Control.Monad ( join, ap ) import Data.Bifunctor (Bifunctor (first)) import Data.Kind qualified as GHC import Data.List (elemIndex, sortOn) @@ -30,6 +30,7 @@ import Data.Text qualified as T import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.CoreFn.TypeLike + ( instantiateWithArgs, TypeLike(..) ) import Language.PureScript.Names (Ident (..), ProperName (..), ProperNameType (..), Qualified (..), QualifiedBy (..), disqualify, runIdent, runModuleName, showIdent, showQualified) import Language.PureScript.PSString (PSString, decodeStringWithReplacement, prettyPrintString) import Language.PureScript.Types ( @@ -42,18 +43,35 @@ import Language.Purus.Debug (doTrace) import Language.Purus.Pretty ((<::>)) import Language.Purus.Pretty.Common (prettyStr) -import Bound +import Bound ( Bound(..), Var(..), Scope, fromScope ) import Bound.Scope (instantiateEither) -import Control.Lens.Plated +import Control.Lens.Plated ( Plated(..) ) import Control.Lens.TH (makePrisms) import Data.Functor.Classes + ( Eq1(..), Ord1(..), Show1(liftShowsPrec) ) import Prettyprinter + ( Doc, + Pretty(pretty), + viaShow, + layoutPretty, + (<+>), + align, + defaultLayoutOptions, + encloseSep, + group, + hardline, + hsep, + indent, + vcat, + vsep, + dot, + parens ) import Prettyprinter.Render.Text (renderStrict) -import Text.Show.Deriving +import Text.Show.Deriving ( deriveShow1, makeLiftShowsPrec ) -- The final representation of types and terms, where all constructions that diff --git a/src/Language/Purus/Make.hs b/src/Language/Purus/Make.hs index 6c2f3706..df34c846 100644 --- a/src/Language/Purus/Make.hs +++ b/src/Language/Purus/Make.hs @@ -34,7 +34,7 @@ import Language.PureScript.Names ( import Language.Purus.IR.Utils (IR_Decl, foldBinds) import Language.Purus.Pipeline.CompileToPIR (compileToPIR) -import Language.Purus.Pipeline.CompileToPIR.Eval +import Language.Purus.Eval import Language.Purus.Pipeline.DesugarCore (desugarCoreModule) import Language.Purus.Pipeline.DesugarObjects ( desugarObjects, @@ -56,7 +56,7 @@ import Language.Purus.Pipeline.Monad ( runInline, runPlutusContext, ) -import Language.Purus.Pretty.Common (docString, prettyStr) +import Language.Purus.Pretty.Common (prettyStr) import Language.Purus.Prim.Data (primDataPS) import Language.Purus.Types (PIRTerm, initDatatypeDict, PLCTerm) import Language.Purus.Utils ( @@ -76,87 +76,22 @@ import Algebra.Graph.AdjacencyMap.Algorithm (topSort) import System.FilePath.Glob qualified as Glob -import Debug.Trace (traceM) - -import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadable) import PlutusCore.Evaluation.Result (EvaluationResult) +-- import Debug.Trace (traceM) +--import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadable) -{- -decodeModuleIR :: FilePath -> IO (Module IR_Decl SourceType SourceType Ann, (Int, M.Map Ident Int)) -decodeModuleIR path = do - myMod <- decodeModuleIO path - case desugarCoreModule myMod of - Left err -> throwIO $ userError err - Right myModIR -> pure myModIR - -testDesugarObjects :: FilePath -> Text -> IO (Exp WithoutObjects Ty (Vars Ty)) -testDesugarObjects path decl = do - (myMod, ds) <- decodeModuleIR path - Just myDecl <- pure . fmap snd $ findDeclBody decl myMod - case runMonomorphize myMod [] (toExp myDecl) of - Left (MonoError msg) -> throwIO $ userError $ "Couldn't monomorphize " <> T.unpack decl <> "\nReason:\n" <> msg - Right body -> case evalStateT (tryConvertExpr body) ds of - Left convertErr -> throwIO $ userError convertErr - Right e -> do - putStrLn (ppExp e) - pure e - -prepPIR :: - FilePath -> - Text -> - IO (Exp WithoutObjects Ty (Vars Ty), Datatypes Kind Ty) -prepPIR path decl = do - (myMod@Module {..}, ds) <- decodeModuleIR path - - desugaredExpr <- case snd <$> findDeclBody decl myMod of - Nothing -> throwIO $ userError "findDeclBody" - Just expr -> pure expr - case runMonomorphize myMod [] (toExp desugaredExpr) of - Left (MonoError msg) -> - throwIO $ - userError $ - "Couldn't monomorphize " - <> T.unpack (runModuleName moduleName <> ".main") - <> "\nReason:\n" - <> msg - Right body -> do - putStrLn (ppExp body) - case evalStateT (tryConvertExpr body) ds of - Left convertErr -> throwIO $ userError convertErr - Right e -> do - moduleDataTypes' <- - either (throwIO . userError) pure $ - bitraverseDatatypes - tryConvertKind - tryConvertType - moduleDataTypes - putStrLn $ "tryConvertExpr result:\n" <> ppExp e <> "\n" <> replicate 20 '-' - pure (e, moduleDataTypes') --} - -{- Arguments are: - - A CoreFn `Prim` module containing the *primitive-but-not-builtin-functions* - (e.g. serialization and deserialization functions). This always gets processed first - - - The parsed set of CoreFn modules needed for compilation, *sorted in dependency order) - (e.g. so that the module containing the `main` function comes *last* and all depdencies - are prior to the modules that they depend upon) - - The name of the module containing the main function - - The name of the main function +{- Compiles a main function to PIR, given its module name, dependencies, and a + Prim module that will be compiled before anything else. (This is kind of a hack-ey shim + to let us write e.g. serialization functions and provide them by default without a + more sophisticated build system). -} - -note :: (MonadError String m) => String -> Maybe a -> m a -note msg = \case - Nothing -> throwError msg - Just x -> pure x - compile :: - Module (Bind Ann) PurusType PurusType Ann -> - [Module (Bind Ann) PurusType PurusType Ann] -> - ModuleName -> - Ident -> + Module (Bind Ann) PurusType PurusType Ann -> -- The Prim Module, or, if there isn't one, the first module to be compiles + [Module (Bind Ann) PurusType PurusType Ann] -> -- The rest of the modules, sorted in dependency order (e.g. so Main comes last) + ModuleName -> -- Name of the module with the main function (will probably be hardcoded to "Main") + Ident -> -- Name of the main function (will probably be hardcoded to "main") Either String PIRTerm compile primModule orderedModules mainModuleName mainFunctionName = evalStateT (runCounterT go) 0 @@ -178,12 +113,12 @@ compile primModule orderedModules mainModuleName mainFunctionName = go :: CounterT (Either String) PIRTerm go = do (summedModule, dsCxt) <- runDesugarCore $ desugarCoreModules primModule orderedModules - let traceBracket lbl msg = traceM ("\n" <> lbl <> "\n\n" <> msg <> "\n\n") + let --traceBracket lbl msg = traceM ("\n" <> lbl <> "\n\n" <> msg <> "\n\n") decls = moduleDecls summedModule declIdentsSet = foldBinds (\acc nm _ -> S.insert nm acc) S.empty decls couldn'tFindMain n = "Error: Could not find a main function with the name (" - <> show n + <> show (n :: Int) <> ") '" <> T.unpack (runIdent mainFunctionName) <> "' in module " @@ -191,25 +126,25 @@ compile primModule orderedModules mainModuleName mainFunctionName = <> "\nin declarations:\n" <> prettyStr (S.toList declIdentsSet) mainFunctionIx <- note (couldn'tFindMain 1) $ dsCxt ^? globalScope . at mainModuleName . folded . at mainFunctionName . folded - traceM $ "Found main function Index: " <> show mainFunctionIx + --traceM $ "Found main function Index: " <> show mainFunctionIx mainFunctionBody <- note (couldn'tFindMain 2) $ findDeclBodyWithIndex mainFunctionName mainFunctionIx decls - traceM "Found main function body" + --traceM "Found main function body" inlined <- runInline summedModule $ lift (mainFunctionName, mainFunctionIx) mainFunctionBody >>= inline - traceBracket "Done inlining. Result:" $ prettyStr inlined + --traceBracket "Done inlining. Result:" $ prettyStr inlined let !instantiated = applyPolyRowArgs $ instantiateTypes inlined - traceBracket "Done instantiating types. Result:" $ prettyStr instantiated + --traceBracket "Done instantiating types. Result:" $ prettyStr instantiated withoutObjects <- instantiateTypes <$> runCounter (desugarObjects instantiated) - traceBracket "Desugared objects. Result:\n" $ prettyStr withoutObjects + --traceBracket "Desugared objects. Result:\n" $ prettyStr withoutObjects datatypes <- runCounter $ desugarObjectsInDatatypes (moduleDataTypes summedModule) - traceM "Desugared datatypes" + --traceM "Desugared datatypes" runPlutusContext initDatatypeDict $ do - generateDatatypes datatypes withoutObjects - traceM "Generated PIR datatypes" + generateDatatypes datatypes + --traceM "Generated PIR datatypes" withoutCases <- eliminateCases datatypes withoutObjects - traceM "Eliminated case expressions. Compiling to PIR..." - pirTerm <- compileToPIR datatypes withoutCases - traceM . docString $ prettyPirReadable pirTerm - pure pirTerm + --traceM "Eliminated case expressions. Compiling to PIR..." + compileToPIR datatypes withoutCases + --traceM . docString $ prettyPirReadable pirTerm + modulesInDependencyOrder :: [[FilePath]] -> IO [Module (Bind Ann) PurusType PurusType Ann] modulesInDependencyOrder (concat -> paths) = do @@ -285,3 +220,10 @@ evalForTest_ main = evalForTest main >>= print evalForTest :: Text -> IO (EvaluationResult PLCTerm,[Text]) evalForTest main = makeForTest main >>= evaluateTerm + + +-- TODO put this somewhere else +note :: (MonadError String m) => String -> Maybe a -> m a +note msg = \case + Nothing -> throwError msg + Just x -> pure x diff --git a/src/Language/Purus/Pipeline/CompileToPIR.hs b/src/Language/Purus/Pipeline/CompileToPIR.hs index aed5829c..278d6ea6 100644 --- a/src/Language/Purus/Pipeline/CompileToPIR.hs +++ b/src/Language/Purus/Pipeline/CompileToPIR.hs @@ -27,7 +27,6 @@ import Language.PureScript.CoreFn.Module ( import Language.PureScript.CoreFn.TypeLike (TypeLike (..)) import Language.PureScript.Names ( Ident (..), - disqualify, runIdent, Qualified (..), QualifiedBy (ByModuleName), ) import Language.PureScript.PSString (prettyPrintString) @@ -100,7 +99,7 @@ compileToPIR' datatypes _exp = doTraceM "compileToPIR'" (prettyStr _exp) >> case _exp of V x -> case x of F Unit -> pure $ mkConstant () () - F (FVar _ ident@(Qualified qb (runIdent -> nm))) -> + F (FVar _ ident@(Qualified _ (runIdent -> nm))) -> case M.lookup (T.unpack nm) defaultFunMap of Just aBuiltinFun -> case M.lookup aBuiltinFun builtinSubstitutions of Nothing -> pure $ Builtin () aBuiltinFun diff --git a/src/Language/Purus/Pipeline/CompileToPIR/Utils.hs b/src/Language/Purus/Pipeline/CompileToPIR/Utils.hs index e20f40ad..5cc07f18 100644 --- a/src/Language/Purus/Pipeline/CompileToPIR/Utils.hs +++ b/src/Language/Purus/Pipeline/CompileToPIR/Utils.hs @@ -9,32 +9,22 @@ import Prelude import Data.Map (Map) import Data.Map qualified as M -import Data.Kind qualified as GHC -import Data.List (foldl') -import Data.List.NonEmpty qualified as NE - import Language.Purus.IR (Ty (..)) import Language.Purus.Pipeline.GenerateDatatypes (toPIRType) import Language.Purus.Pipeline.GenerateDatatypes.Utils ( - freshName, getConstructorName, note, getDestructorTy, + freshName, getConstructorName, note, getDestructorTy, ) import Language.Purus.Pipeline.Monad (PlutusContext) import Language.Purus.Types (PIRTerm, PIRType) import PlutusCore qualified as PLC import PlutusIR ( - Binding (TermBind), - Recursivity (NonRec), - Strictness (..), Type (TyBuiltin), ) import PlutusIR qualified as PIR import PlutusIR.MkPir (mkConstant) import Language.Purus.Prim.Utils ( properToIdent ) -import Control.Monad.Except ( - liftEither, - ) import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.Constants.Purus qualified as C @@ -45,12 +35,14 @@ import Language.PureScript.Constants.Purus qualified as C tyBuiltinBool :: PIRType tyBuiltinBool = PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniBool) +{- Mainly used for type abstraction/instantiation, it should be the "smallest" thing we can use (or close to it) -} unit :: PIRType unit = PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniUnit) unitTerm :: PIRTerm unitTerm = mkConstant () () +{- A la plutarch, helper for writing the other functions in this module-} (#) :: PIRTerm -> PIRTerm -> PIRTerm e1 # e2 = PIR.Apply () e1 e2 -- I think this is the right fixity? TODO: Check plutarch @@ -72,7 +64,9 @@ pirBooleanToBool psBool = do boolDctor <- PIR.Var () <$> getDestructorTy C.Boolean pure $ PIR.TyInst () (boolDctor # psBool # mkConstant () True # mkConstant () False) tyBuiltinBool -{- This is the *lazy* +{- This is *NOT* the thing that we desugar `Builtin.IfThenElse` to. This is a *lazy* if-then-else + (using TyAbs/TyInst to emulate force/delay since PIR lacks force/delay). You have to pass in the + return type. -} pirIfThen :: PIRType -> PIRTerm -> PIRTerm -> PIRTerm -> PlutusContext PIRTerm pirIfThen resTy cond troo fawlse = do @@ -80,7 +74,8 @@ pirIfThen resTy cond troo fawlse = do fawlse' <- pirDelay fawlse pure . pirForce $ pirTyInst (PIR.TyFun () unit resTy) (PIR.Builtin () PLC.IfThenElse) # cond # troo' # fawlse' --- utility for constructing LamAbs w/ a fresh variable name. We do this a lot in the case analysis stuff +{- A utility for constructing LamAbs w/ a fresh variable name. Only serves to make this module more readable. +-} freshLam :: Ty -> -- type of the fresh var being created (PIRType -> PIRTerm -> PlutusContext PIRTerm) -> -- fn from that fresh var to a term @@ -90,7 +85,7 @@ freshLam t f = do t' <- toPIRType t PIR.LamAbs () name t' <$> f t' (PIR.Var () name) --- Variant of the above function but accepts a PIR Type (useful in a few contexts) +{- Variant of the above function but accepts a PIR Type (useful in a few contexts) -} freshLam' :: PIRType -> -- type of the fresh var being created (PIRType -> PIRTerm -> PlutusContext PIRTerm) -> -- fn from that fresh var to a term @@ -99,16 +94,12 @@ freshLam' t f = do name <- freshName PIR.LamAbs () name t <$> f t (PIR.Var () name) - - +{- Type instantiation -} pirTyInst :: PIRType -> PIRTerm -> PIRTerm pirTyInst ty term = PIR.TyInst () term ty -tyInstMany :: PIRTerm -> [PIRType] -> PIRTerm -tyInstMany = foldl' (flip pirTyInst) - - +{- Delay/Force implemented with type abstraction/instantiation -} pirDelay :: PIRTerm -> PlutusContext PIRTerm pirDelay term = do nm <- freshName @@ -117,7 +108,7 @@ pirDelay term = do pirForce :: PIRTerm -> PIRTerm pirForce term = PIR.Apply () term unitTerm --- Assumes the kind is * +{- This assumes that the kind is * -} pirTyAbs :: (PIRType -> PlutusContext PIRTerm) -> PlutusContext PIRTerm pirTyAbs f = do tName <- PIR.TyName <$> freshName @@ -127,28 +118,11 @@ pirTyAbs f = do {- REVIEW: Is this right? Is that what we *want*? + TODO: Add a "fake" function to Language.PureScript.Environment so that users can... use this... -} pirError :: PIRType -> PlutusContext PIRTerm pirError t = pirForce <$> pirDelay (PIR.Error () t) --- for builtin booleans jfc why don't they have thiiiisss -pirAnd :: PIRTerm -> PIRTerm -> PlutusContext PIRTerm -pirAnd t1 t2 = do - tBranch <- pirIfThen tyBuiltinBool t2 (mkConstant () True) (mkConstant () False) - pirIfThen tyBuiltinBool t1 tBranch (mkConstant () False) - -pirLetNonRec :: - PIRType -> -- type of the expression we're let- binding - PIRTerm -> - (PIRTerm -> PlutusContext PIRTerm) -> - PlutusContext PIRTerm -pirLetNonRec ty toLet f = do - nm <- freshName - let myvar = PIR.Var () nm - varDecl = PIR.VarDecl () nm ty - binding = TermBind () NonStrict varDecl toLet - PIR.Let () NonRec (NE.singleton binding) <$> f myvar - {- Builtin function substitutions. Each builtin function with a Purus type that contains a `Boolean` is a lie. We use algebraic datatype Booleans, not the Plutus builtin. (This @@ -239,7 +213,7 @@ pirEqualsData = wrapBoolToBoolean2 tyData PLC.EqualsData -- will be represented as an ADT Prim.Boolean -- so we need to turn it into a con bool -- (also we're not adding force/delay here) --- forall x. Bool -> x -> x -> +-- forall x. Bool -> x -> x -> x pirIfThenElse :: PlutusContext PIRTerm pirIfThenElse = pirTyAbs $ \tv -> diff --git a/src/Language/Purus/Pipeline/DesugarObjects.hs b/src/Language/Purus/Pipeline/DesugarObjects.hs index 210b918e..54a51ee9 100644 --- a/src/Language/Purus/Pipeline/DesugarObjects.hs +++ b/src/Language/Purus/Pipeline/DesugarObjects.hs @@ -1,39 +1,30 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Language.Purus.Pipeline.DesugarObjects where +module Language.Purus.Pipeline.DesugarObjects (desugarObjects, desugarObjectsInDatatypes) where import Data.Bifunctor (Bifunctor (second)) import Data.List (elemIndex, foldl', sortOn) -import Data.Map (Map) import Data.Map qualified as M import Data.Maybe (fromJust) -import Data.Text (Text) import Data.Text qualified as T import Control.Monad (foldM) import Language.PureScript.Constants.Prim qualified as C -import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.Desugar.Utils (properToIdent) import Language.PureScript.CoreFn.Expr ( - Expr (..), PurusType, ) import Language.PureScript.CoreFn.FromJSON () import Language.PureScript.CoreFn.Module - ( Datatypes(Datatypes), - bitraverseDatatypes, - dDataTyName, - CtorDecl(CtorDecl), - DataDecl(DataDecl) ) + ( bitraverseDatatypes, Datatypes ) import Language.PureScript.CoreFn.TypeLike (TypeLike (..)) -import Language.PureScript.CoreFn.Utils (exprType) -import Language.PureScript.Environment (DataDeclType (Data), kindType, mkTupleTyName, pattern RecordT, pattern (:->)) -import Language.PureScript.Names (Ident (..), ProperName (..), ProperNameType (..), Qualified (..), QualifiedBy (..), coerceProperName) +import Language.PureScript.Environment (kindType, mkTupleTyName, pattern RecordT, pattern (:->)) +import Language.PureScript.Names (Ident (..), coerceProperName) import Language.PureScript.PSString (PSString) import Language.PureScript.Types ( RowListItem (rowListType), @@ -71,7 +62,7 @@ import Prelude import Bound (Var (..)) import Bound.Scope ( toScope ) -import Control.Lens (cosmos, ix, to, (&), (.~), (<&>), (^.), (^..)) +import Control.Lens (ix, (&), (.~)) import Control.Monad.Except (liftEither, throwError) @@ -112,9 +103,6 @@ tryConvertType = go id pure $ KType t1' t2' other -> throwError $ "Unsupported type:\n " <> show other -tryConvertKind :: SourceType -> Counter Kind -tryConvertKind t = tryConvertKind' id t t - tryConvertKind' :: (SourceType -> SourceType) -> SourceType -> SourceType -> Counter Kind tryConvertKind' f t = \case TypeConstructor _ C.Type -> pure KindType @@ -139,9 +127,6 @@ rowLast :: SourceType -> SourceType rowLast t = case rowToList t of (_, r) -> r -allTypes :: Expr Ann -> [SourceType] -allTypes e = e ^.. cosmos . to exprType - desugarObjects :: Exp WithObjects SourceType (Vars SourceType) -> Counter (Exp WithoutObjects Ty (Vars Ty)) @@ -422,73 +407,6 @@ assembleDesugaredObjectLit expr (_ :~> b) (arg : args) = assembleDesugaredObject assembleDesugaredObjectLit expr _ [] = pure expr -- TODO better error assembleDesugaredObjectLit _ _ _ = error "something went wrong in assembleDesugaredObjectLit" --- TODO/FIXME: Adapt this for use w/ the PIR Data declaration machinery (i.e. don't manually construct SOPs) - -pattern ArrayCons :: Qualified Ident -pattern ArrayCons = Qualified (ByModuleName C.M_Prim) (Ident "Cons") - -pattern ArrayNil :: Qualified Ident -pattern ArrayNil = Qualified (ByModuleName C.M_Prim) (Ident "Nil") - -mkProdFields :: [t] -> [(Ident, t)] -mkProdFields = map (UnusedIdent,) - -primData :: Datatypes Kind Ty -primData = - tupleDatatypes - <> Datatypes tDict cDict - where - tDict :: Map (Qualified (ProperName 'TypeName)) (DataDecl Kind Ty) - tDict = - M.fromList $ - map - (\x -> (x ^. dDataTyName, x)) - [ DataDecl - Data - C.Array - [("a", KindType)] - [ CtorDecl ArrayNil [] - , CtorDecl ArrayCons $ mkProdFields [TyVar "a" KindType, TyApp (TyCon C.Array) (TyVar "a" KindType)] - ] - , DataDecl - Data - C.Boolean - [] - [ CtorDecl (properToIdent <$> C.C_False) [] - , CtorDecl (properToIdent <$> C.C_True) [] - ] - ] - - cDict :: Map (Qualified Ident) (Qualified (ProperName 'TypeName)) - cDict = - M.fromList - [ (ArrayCons, C.Array) - , (ArrayNil, C.Array) - , (properToIdent <$> C.C_True, C.Boolean) - , (properToIdent <$> C.C_False, C.Boolean) - ] - -tupleDatatypes :: Datatypes Kind Ty -tupleDatatypes = Datatypes (M.fromList tupleTypes) (M.fromList tupleCtors) - where - tupleTypes = flip map [0 .. 10] $ \(n :: Int) -> - let tyNm = mkTupleTyName n - ctorNm = mkTupleCtorIdent n - argKinds = mkTupleArgKinds n - ctorTvArgs = mkTupleCtorTvArgs n - in (tyNm, DataDecl Data tyNm argKinds [CtorDecl ctorNm ctorTvArgs]) - - tupleCtors = [0 .. 10] <&> \x -> (mkTupleCtorIdent x, mkTupleTyName x) - - mkTupleCtorIdent :: Int -> Qualified Ident - mkTupleCtorIdent n = properToIdent <$> mkTupleTyName n - - vars :: Int -> [Text] - vars n = map (\x -> "t" <> T.pack (show x)) [1 .. n] - - mkTupleArgKinds = fmap (,KindType) . vars - - mkTupleCtorTvArgs = mkProdFields . map (flip TyVar KindType) . vars purusTypeToKind :: SourceType -> Either String Kind purusTypeToKind _t = diff --git a/src/Language/Purus/Pipeline/EliminateCases.hs b/src/Language/Purus/Pipeline/EliminateCases.hs index 97cf856d..2bd80b8b 100644 --- a/src/Language/Purus/Pipeline/EliminateCases.hs +++ b/src/Language/Purus/Pipeline/EliminateCases.hs @@ -39,7 +39,7 @@ import Language.PureScript.Names ( ProperNameType (..), Qualified (..), runIdent, - showQualified, ModuleName (..), QualifiedBy (..), + showQualified, ) import Language.PureScript.Types ( TypeVarVisibility (TypeVarVisible), @@ -93,7 +93,6 @@ import Control.Lens ( (^.), ) import Control.Lens.Combinators (transform) -import Control.Lens.Plated (transformM) import Control.Monad.Except ( MonadError (throwError), @@ -667,17 +666,6 @@ desugarLiteralPatterns :: Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) desugarLiteralPatterns = transform desugarLiteralPattern -{- TODO/FIXME (8/28): This is currently broken because we use the Builtins.equalsInteger/String/etc - which return a PLC `bool` not a SOP `Boolean`. - - The only sensible solution is to replace the equality test with some specific - free variable (maybe qualified by a "$COMPILER" ModuleName) that represents the - equality test for the correct primitive type, and replace those variables - during final PIR compilation. - - Actually we can get away with $COMPILER.boolToBoolean :: forall x. x -> Boolean, - don't need to catch anything else --} desugarLiteralPattern :: Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -> Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) @@ -748,6 +736,8 @@ data CtorCase = CtorCase , scrutType :: Ty } +-- I think we can replace this with Language.Purus.Pipeline.Instantiate.instantiateTypes but I'm terrified to +-- change anything now that the compiler seems to work.... -- FIXME/REVIEW: I don't think we'll have to do this anymore if we re-instantiate after object desugaring. I should test this. ezMonomorphize :: Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -> diff --git a/src/Language/Purus/Pipeline/GenerateDatatypes.hs b/src/Language/Purus/Pipeline/GenerateDatatypes.hs index 22cf1f8a..213aec85 100644 --- a/src/Language/Purus/Pipeline/GenerateDatatypes.hs +++ b/src/Language/Purus/Pipeline/GenerateDatatypes.hs @@ -1,13 +1,23 @@ +{- Generates the PIR Datatype declarations which must be let- bound in order for + our modules to compile. +-} + {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Language.Purus.Pipeline.GenerateDatatypes where +module Language.Purus.Pipeline.GenerateDatatypes ( + generateDatatypes, + toPIRType, + mkKind + ) where import Prelude import Data.Map qualified as M + import Data.Set qualified as S + import Data.Text (Text) import Data.Text qualified as T @@ -43,14 +53,10 @@ import Language.PureScript.Types ( import Language.Purus.Debug (doTraceM) import Language.Purus.IR ( - BVar, - Exp (..), - FVar, Ty (..), - ppTy, + ppTy ) import Language.Purus.IR qualified as IR -import Language.Purus.IR.Utils (WithoutObjects) import Language.Purus.Pipeline.GenerateDatatypes.Utils ( bindTV, foldr1Err, @@ -76,24 +82,38 @@ import PlutusIR ( ) import PlutusIR qualified as PIR -import Bound.Var (Var) import Control.Lens ( over, to, - (^.), + (^.) ) import Control.Monad.Except ( MonadError (throwError), ) +{- Generates PIR datatypes declarations for all of the datatypes in scope + in the Main module we are compiling and adds them to the monadic context for use + by the subsequent passes. + + We are using PIR's datatype encodings, so we need to do this to ensure that + all possibly-used datatypes are available for case desugaring (which references + the destructors for those datatypes), and so that CompileToPIR can let- bind them + in the outermost scope of the main expression. + + This does strictly more work than it needs to, since we could get away with generating + only declarations for the types directly mentioned in the expression and the recursive + dependencies of those types. However, PIR removes unused datatype declarations (seemingly + with 100% reliability?), so being lazy here doesn't have that much of an impact + (unless we're reading our traces -_-) + +-} generateDatatypes :: Datatypes IR.Kind Ty -> - Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -> PlutusContext () -generateDatatypes datatypes main = mkPIRDatatypes datatypes (allTypeConstructors main) +generateDatatypes datatypes = mkPIRDatatypes datatypes allTypeConstructors where - allTypeConstructors :: Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -> S.Set (Qualified (ProperName 'TypeName)) - allTypeConstructors _ = datatypes ^. tyDict . to M.keys . to S.fromList + allTypeConstructors :: S.Set (Qualified (ProperName 'TypeName)) + allTypeConstructors = datatypes ^. tyDict . to M.keys . to S.fromList mkPIRDatatypes :: Datatypes IR.Kind Ty -> @@ -212,13 +232,3 @@ mkKind :: IR.Kind -> PIR.Kind () mkKind = \case IR.KindType -> PIR.Type () IR.KindArrow k1 k2 -> PIR.KindArrow () (mkKind k1) (mkKind k2) - -sourceTypeToKind :: SourceType -> Either String (PIR.Kind ()) -sourceTypeToKind _t = - doTraceM "sourceTypeToKind" (prettyStr _t) >> case _t of - TypeConstructor _ C.Type -> pure $ PIR.Type () - t1 :-> t2 -> do - t1' <- sourceTypeToKind t1 - t2' <- sourceTypeToKind t2 - pure $ PIR.KindArrow () t1' t2' - other -> Left $ "Error: PureScript type '" <> prettyTypeStr other <> " is not a valid Plutus Kind" diff --git a/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs b/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs index 87bc84f5..56caefcc 100644 --- a/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs +++ b/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs @@ -1,26 +1,37 @@ {-# OPTIONS_GHC -Wno-orphans #-} -module Language.Purus.Pipeline.GenerateDatatypes.Utils where +module Language.Purus.Pipeline.GenerateDatatypes.Utils ( + bindTV, + getConstructorName, + analyzeTyApp, + foldr1Err, + freshName, + funResultTy, + getDestructorTy, + prettyQI, + prettyQPN, + getBoundTyVarName, + mkConstrName, + mkNewTyVar, + mkTyName, + note + ) where import Prelude -import Data.Map (Map) import Data.Map qualified as M import Data.Text (Text) import Data.Text qualified as T import Control.Monad.State (gets, modify) -import Data.Foldable (foldl') import Debug.Trace (traceM) -import Language.PureScript.Constants.Prim qualified as C import Language.PureScript.CoreFn.TypeLike import Language.PureScript.Names ( Ident (..), ProperName (..), ProperNameType (..), Qualified (..), - QualifiedBy (ByModuleName), disqualify, runIdent, showIdent, @@ -29,7 +40,6 @@ import Language.PureScript.Names ( import Language.Purus.Debug (doTraceM) import Language.Purus.IR ( - BVar (BVar), Ty (..), ) import Language.Purus.IR qualified as IR @@ -43,7 +53,6 @@ import Language.Purus.Types ( destructors, tyNames, tyVars, - vars, ) import PlutusCore qualified as PLC @@ -57,9 +66,7 @@ import Control.Lens ( at, folded, over, - preview, view, - (^.), (^?), _1, ) @@ -104,10 +111,6 @@ mkNewTyVar nm = uniq <- next pure . PIR.TyName $ PIR.Name nm $ PLC.Unique uniq --- | Only gives you a Name, doesn't insert anything into the context -mkNewVar :: Text -> PlutusContext PIR.Name -mkNewVar nm = doTraceM "mkNewVar" (T.unpack nm) >> PIR.Name nm . PLC.Unique <$> next - freshName :: PlutusContext PIR.Name freshName = do uniq <- next @@ -115,15 +118,6 @@ freshName = do let nm = T.pack (c : '#' : show uniq) pure $ PIR.Name nm (PLC.Unique uniq) -mkVar :: Text -> PlutusContext PIR.Name -mkVar nm = - doTraceM "mkVar" (T.unpack nm) >> gets (view vars) >>= \names -> case M.lookup nm names of - Nothing -> do - var <- mkNewVar nm - modify $ over vars (M.insert nm var) - pure var - Just var -> pure var - getBoundTyVarName :: Text -> PlutusContext PIR.TyName getBoundTyVarName nm = doTraceM "mkBoundTyVarName" (T.unpack nm) >> do @@ -132,26 +126,12 @@ getBoundTyVarName nm = Just tyName -> pure tyName Nothing -> error $ "Free type variable in IR: " <> T.unpack nm --- Sometimes (e.g. when typing lambdas) we have to branch on whether the tv is already bound -lookupTyVar :: Text -> PlutusContext (Maybe PIR.TyName) -lookupTyVar nm = gets (preview (tyVars . at nm . folded)) - bindTV :: Text -> PIR.TyName -> PlutusContext () bindTV txt nm = modify $ over tyVars (M.insert txt nm) -insertMany :: forall k v. (Ord k) => [(k, v)] -> Map k v -> Map k v -insertMany new acc = foldl' (flip $ uncurry M.insert) acc new - -deleteMany :: forall k v. (Ord k) => [k] -> Map k v -> Map k v -deleteMany xs acc = foldl' (flip M.delete) acc xs - note :: String -> Maybe a -> PlutusContext a note msg = maybe (throwError msg) pure -isTupleCtor :: Qualified (ProperName a) -> Bool -isTupleCtor (Qualified (ByModuleName C.M_Prim) (ProperName xs)) = T.isPrefixOf "Tuple" xs -isTupleCtor _ = False - getDestructorTy :: Qualified (ProperName 'TypeName) -> PlutusContext PLC.Name getDestructorTy qn = do dctors <- gets (view destructors) @@ -182,9 +162,6 @@ prettyQI = T.unpack . showQualified runIdent instance Pretty (Qualified Ident) where pretty = pretty . prettyQI -bvTy :: BVar ty -> ty -bvTy (BVar _ t _) = t - funResultTy :: (TypeLike t) => t -> t funResultTy = last . splitFunTyParts diff --git a/src/Language/Purus/Pipeline/Inline.hs b/src/Language/Purus/Pipeline/Inline.hs index c0da7b78..733aede7 100644 --- a/src/Language/Purus/Pipeline/Inline.hs +++ b/src/Language/Purus/Pipeline/Inline.hs @@ -1,4 +1,4 @@ -module Language.Purus.Pipeline.Inline where +module Language.Purus.Pipeline.Inline (inline) where import Prelude @@ -230,7 +230,7 @@ handleSelfRecursive (nm, indx) body updatedOriginalBody = viaExp (deepMapMaybeBound f) body updatedOriginalDecl = ((nm, indx), updatedOriginalBody) abstr = abstract $ \case B bv -> Just bv; _ -> Nothing - newBreakerDecl = ((newNm, u), (abstr . V . B $ BVar indx bodyTy nm)) + newBreakerDecl = ((newNm, u), abstr . V . B $ BVar indx bodyTy nm) pure $ M.fromList [updatedOriginalDecl, newBreakerDecl] inlineWithData :: MonoExp -> InlineState MonoExp @@ -293,13 +293,6 @@ doneInlining me = do doTraceM "doneInlining" msg pure result -remainingInlineTargets :: MonoExp -> InlineState (Set (Ident, Int)) -remainingInlineTargets me = do - dct <- get - let allInlineable = M.keysSet $ M.filter notALoopBreaker dct - allHoles = S.fromList $ mapMaybe (fmap unHole . toHole) (me ^.. cosmos) - pure $ S.intersection allHoles allInlineable - prettyDict :: Map (Ident, Int) InlineBodyData -> String prettyDict = show @@ -463,14 +456,3 @@ inlineInLifted decls = do KindedType _ t1 t2 -> isRow t1 || isRow t2 TypeApp _ t1 t2 -> isRow t1 || isRow t2 _ -> False -findDeclGroup :: - (Ident, Int) -> - [BindE ty (Exp x ty) a] -> - Maybe (BindE ty (Exp x ty) a) -findDeclGroup _ [] = Nothing -findDeclGroup (ident, indx) (NonRecursive ident' bvix expr : rest) - | ident == ident' && bvix == indx = Just $ NonRecursive ident' bvix expr - | otherwise = findDeclGroup (ident, indx) rest -findDeclGroup nm (Recursive xs : rest) = case find (\x -> fst x == nm) xs of - Nothing -> findDeclGroup nm rest - Just _ -> Just (Recursive xs) diff --git a/src/Language/Purus/Pipeline/Inline/Types.hs b/src/Language/Purus/Pipeline/Inline/Types.hs index f6d19a52..e064ccff 100644 --- a/src/Language/Purus/Pipeline/Inline/Types.hs +++ b/src/Language/Purus/Pipeline/Inline/Types.hs @@ -2,11 +2,11 @@ module Language.Purus.Pipeline.Inline.Types where import Prelude -import Language.PureScript.Names +import Language.PureScript.Names ( Ident ) -import Language.Purus.Pipeline.Lift.Types +import Language.Purus.Pipeline.Lift.Types ( MonoScoped ) -import Prettyprinter +import Prettyprinter ( Pretty ) newtype LoopBreakerScore = LoopBreakerScore {getScore :: ((Ident, Int), Maybe Int)} deriving (Show, Eq, Ord) diff --git a/src/Language/Purus/Pipeline/Instantiate.hs b/src/Language/Purus/Pipeline/Instantiate.hs index 783ff938..b5e7c663 100644 --- a/src/Language/Purus/Pipeline/Instantiate.hs +++ b/src/Language/Purus/Pipeline/Instantiate.hs @@ -3,7 +3,7 @@ typecheck in PIR (and also to simplify some of our own subsequent compiler passes). -} -module Language.Purus.Pipeline.Instantiate where +module Language.Purus.Pipeline.Instantiate (instantiateTypes, applyPolyRowArgs) where import Prelude @@ -29,6 +29,11 @@ import Language.Purus.Pretty.Common (prettyStr) import Control.Lens (transform, view, _2) import Prettyprinter (Pretty) +{- After inlining and instantiating, we're left abstracted type variables and instantiated types which + may be of kind `Row Type`. That's bad! We need to "apply" the instantiations to the abstractions so + that we have concrete rows (or as concrete as they can possibly be at any rate) before we + do object desugaring. +-} applyPolyRowArgs :: Exp WithObjects PurusType (Vars PurusType) -> Exp WithObjects PurusType (Vars PurusType) @@ -38,6 +43,8 @@ applyPolyRowArgs = transform $ \case _ -> instE other -> other +{- Instantiates every type abstraction wherever it is possible to deduce the instantiation. +-} instantiateTypes :: forall x (t :: *). (TypeLike t, Pretty t, Pretty (KindOf t)) => Exp x t (Vars t) -> Exp x t (Vars t) instantiateTypes = \case V v -> V v diff --git a/src/Language/Purus/Pipeline/Lift.hs b/src/Language/Purus/Pipeline/Lift.hs index 8f54a172..1a875d55 100644 --- a/src/Language/Purus/Pipeline/Lift.hs +++ b/src/Language/Purus/Pipeline/Lift.hs @@ -3,7 +3,7 @@ {-# HLINT ignore "Use <&>" #-} {-# HLINT ignore "Move concatMap out" #-} -module Language.Purus.Pipeline.Lift where +module Language.Purus.Pipeline.Lift (lift) where import Prelude @@ -42,7 +42,6 @@ import Language.Purus.IR.Utils ( stripSkolems, stripSkolemsFromExpr, toExp, - unBVar, viaExp, ) import Language.Purus.Pipeline.Lift.Types @@ -530,31 +529,6 @@ lift mainNm _e = do LitP (ObjectL _ ps) -> concatMap (extractPatVarBinders . snd) ps _ -> [] -usedModuleDecls :: MonoExp -> Inline [MonoBind] -usedModuleDecls e = do - modDict <- mkModDict - let deps = - S.fromList - . filter (`M.member` modDict) - . mapMaybe (\case (V (B bv)) -> Just (unBVar bv); _ -> Nothing) - $ directDeps - let usedIdents = S.toList $ go modDict deps - pure $ (\nm@(idn, ind) -> NonRecursive idn ind (modDict M.! nm)) <$> usedIdents - where - go :: Map (Ident, Int) MonoScoped -> Set (Ident, Int) -> Set (Ident, Int) - go dict visited = - let nextRound = S.foldl' (\acc nm -> dict M.! nm : acc) [] visited - nextRoundDeps = - S.fromList - . filter (\x -> S.notMember x visited && M.member x dict) - . mapMaybe (\case (V (B bv)) -> Just (unBVar bv); _ -> Nothing) - $ concatMap (toListOf cosmos . toExp) nextRound - in case S.null nextRoundDeps of - True -> visited - False -> go dict (visited <> nextRoundDeps) - - directDeps = e ^.. cosmos - mkModDict :: Inline (Map (Ident, Int) MonoScoped) mkModDict = do decls <- asks moduleDecls diff --git a/src/Language/Purus/Pipeline/Monad.hs b/src/Language/Purus/Pipeline/Monad.hs index ec4ae306..97fb664d 100644 --- a/src/Language/Purus/Pipeline/Monad.hs +++ b/src/Language/Purus/Pipeline/Monad.hs @@ -1,3 +1,17 @@ +{- Various concrete monads used by the pipeline components. There's probably a more elegant solution, + but this works well-enough for now. + + DesugarCore and Inline run in the monads with those names. + + Lift runs in the Inline monad. + + DesugarObjects runs in `Counter` (it only needs access to the stream of uniques) + + GenerateDatatypes, EliminateCases, and CompileToPIR run in the PlutusContext Monad. + + Intantiate is pure. +-} + {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StarIsType #-} {-# LANGUAGE TemplateHaskell #-} @@ -27,118 +41,6 @@ import Control.Lens.TH (makeLenses) import Prettyprinter ( Pretty(pretty), (<+>), align, hardline, indent, vcat ) -{- [Current Compilation Pipeline Structure] - - That is, "current" before the `Language.Purus` reorganization. - - It's a bit of a mess so I gotta remember how it all works before cleaning it up :p - -DesugarCore -> -Lift -> -Inline -> -Instantiate -> -DesugarObjects -> -GenerateDatatypes -> -EliminateCaseExpressions -> -CompileToPIR - -NOTE: ALL THE ERRORS are morally strings at this point - -NOTE: I'm "factoring out" the Supply part of the types. *Everything* here needs - access to that. - -1. DesugarCore :: [Module (Bind Ann) PurusType PurusType Ann] - -> State (Map Ident Int) (Module IR_Decl SourceType SourceType Ann) - - - NOTE: The state represents `unique` bindings for bound variables - - NOTE: At present, this state gets passed to DesugarObjects. - That's a bit weird. I don't think it needs to be passed to - DesugarObjects now that we bind *everything* in DesugarCore? - - If we don't need to pass it to DesugarObjects then the return type of - this is just (Module IR_Decl SourceType SourceType Ann) - - NOTE: I think we want to smash the in-scope data declarations into the - `Module` returned by this, but if we do that we need to add that as an - argument - --- NOTE: After core desugaring, we're only ever concerned with a single module - (and its scope). We should make sure that dependencies (including datatypes) - are resolved after this point. - -2. Lift :: (Ident,Int) - -> Exp WithObjects PurusType - -> Reader - (ModuleName, Module IR_Decl SourceType SourceType Ann) - LiftResult - - - NOTE: This and inline run in the old Monomorphizer monad. - - NOTE: It seems to *only* use the Module to get ahold of the declarations - (this is likely also true for Inline as well) - -3. Inline :: LiftResult - -> Reader - (ModuleName, Module IR_Decl SourceType SourceType Ann) - Exp WithObjects PurusType - - - NOTE: Lift composes with this to give us `(Ident,Int) -> Exp WithObjects PurusType -> m Exp WithObjects PurusType ` - - NOTE: We don't seem to care about the module context anymore, as we've already - extracted the used declarations in `Lift`. This just uses the - unique counter portion of Monomorphizer. - * So the return type of this can be `Exp WithObjects PurusType` (w/ the counter factored out) - - NOTE: After this stage, we don't care about the module declarations or anything else, - but we *do* care about the datatypes! - -4. Instantiate :: Exp WithObjects PurusType -> Exp WithObjects PurusType - - - NOTE: Pure. - - NOTE: We probably want to rewrite this to be generic over the XObjectFoo and Type representation. We'll have - to do it again after or during object desugaring (but we *must* do it before then). - -5. DesugarObjects :: Exp Withobjects PurusType -> State (Map Ident Int) (Exp WithoutObjects Ty) - - - NOTE: Shouldn't actually need to use the Map, and is pure modulo the unique counter afaict - --- NOTE: The rest of the steps run in `DataTypeM`, which is a state monad with a counter plus some bookkeeping - stuff required for the final passes. - -6. GenerateDataTypes :: Datatypes Kind Ty - -> Exp WithoutObjects Ty - -> State DatatypeDictionary () - - This gives us a state with a bunch of Maps from PS names to PIR Names (with uniques), for - constructors, datatypes, type names, type variables, etc. - - - We need to (or should, at least) do this *before* case expression elimination because - we need to know *what* the Unique is for the destructor functions (and also for the - types that we mention in the destructor functions). - -7. EliminateCaseExpressions :: Exp WithoutObjects Ty - -> State DatatypeDictionary (Exp WithoutObjects Ty) - - This should be *reader* DatatypeDictionary b/c it never modifies it. I don't think CompileToPIR does either? - -8. CompileToPIR :: DataTypes Kind Ty - -> Exp WithoutObjects Ty - -> PIRTerm - - - It *really* should not need those datatypes. I don't think it uses them for anything except constructor - instantiation, which should happen *way* before this. I'm guessing that was a dirty hack to - ensure that everything got instantiated again after desugarobjects? - - This needs updated to use the Exp x t (Vars t) concrete style (which is vastly superior) - - Need to split some of the PIR utils out into their own utility - -Major changes to make while fixing all this: - - Delete the "IR.Bindings" maps from let expressions and anywhere else I left them - - Refactor using the new IR utils, especially toExp/fromExp/viaExp and foldBind/Alt/etc - -So there are basically 4 different phases: - - - a) DesugarCore, hich maintains an ident-int map local state (for initial index generation ) - - - b) Lift and Inline read from, but do not modify, the set of in-scope expression declarations - for the main module being compiled - - - c) Instantiate is pure. DesugarObjects *should* be pure modulo the counter - - - d) GenerateDatatypes makes the DatatypeDictionary which EliminateCaseExpressions, and CompileToPIR - read from. - --} newtype CounterT m a = CounterT {runCounterT :: StateT Int m a} deriving newtype (Functor, Applicative, Monad, MonadTrans) @@ -162,6 +64,9 @@ instance (Monad m) => MonadCounter (CounterT m) where instance (Monad m) => MonadCounter (StateT s (CounterT m)) where next = lift next +{- The different compiler monads are primarily distinguished by their State type, + this is a way to generalize that. +-} newtype PurusM s a = PurusM {runPurusM :: StateT s (CounterT (Either String)) a} deriving newtype (Functor, Applicative, Monad, MonadCounter, MonadError String, MonadState s) @@ -183,6 +88,7 @@ evalPurusM s pm = evalStateT (runPurusM pm) s runStatePurusM :: s -> PurusM s a -> CounterT (Either String) (a, s) runStatePurusM s pm = runStateT (runPurusM pm) s +{- See explanation in Language.Purus.Pipeline.Desugar for why we need two scopes -} data DesugarContext = DesugarContext {_globalScope :: Map ModuleName (Map Ident Int), _localScope :: Map Ident Int} deriving (Show, Eq) diff --git a/src/Language/Purus/Prim/Ledger.hs b/src/Language/Purus/Prim/Ledger.hs index 5fa45201..146759b9 100644 --- a/src/Language/Purus/Prim/Ledger.hs +++ b/src/Language/Purus/Prim/Ledger.hs @@ -1,6 +1,11 @@ {-# LANGUAGE TypeApplications #-} -module Language.Purus.Prim.Ledger where +module Language.Purus.Prim.Ledger ( + ledgerTypes, + ledgerCons, + ledgerConstructorsEnv, + ledgerConstructorsEnvReadable + ) where import Data.Map qualified as M @@ -32,12 +37,32 @@ import Language.PureScript.Types ( Type (TypeConstructor, TypeVar), ) import Language.Purus.IR () -import Language.Purus.Prim.LedgerData +import Language.Purus.Prim.LedgerData ( ledgerDecls ) import Language.Purus.Prim.Utils + ( arm, + listOf, + mapOf, + maybeOf, + monoType, + mononym, + newtypeOf, + nominalVar, + polyNewtypeOf, + polyRecordType, + polySumType, + polyType, + primName, + recordType, + sumType, + tuple2Of, + tyApp, + tyCon, + tyVar ) import Prelude import Language.Purus.Pretty.Common (docString) import Prettyprinter + ( Pretty(pretty), (<+>), hardline, punctuate, vcat ) -- | Ledger API (V2) types, as per https://github.com/IntersectMBO/plutus/blob/master/plutus-ledger-api/src/PlutusLedgerApi/V2.hs ledgerTypes :: [(Qualified (ProperName 'TypeName), (Type SourceAnn, TypeKind))] diff --git a/src/Language/Purus/Utils.hs b/src/Language/Purus/Utils.hs index 85342b85..f72c81f9 100644 --- a/src/Language/Purus/Utils.hs +++ b/src/Language/Purus/Utils.hs @@ -11,14 +11,14 @@ import Language.PureScript.CoreFn.Ann (Ann) import Language.PureScript.CoreFn.Expr (Bind, PurusType) import Language.PureScript.CoreFn.FromJSON () import Language.PureScript.CoreFn.Module (Module (..)) -import Language.PureScript.CoreFn.TypeLike import Language.PureScript.Names + ( pattern ByNullSourcePos, Ident(Ident), Qualified(..) ) -import Language.Purus.Debug -import Language.Purus.IR +import Language.Purus.Debug ( doTrace ) +import Language.Purus.IR ( BVar, BindE(..), Exp ) import Language.Purus.IR.Utils (IR_Decl, Vars, WithObjects, foldBinds, toExp) -import Control.Exception +import Control.Exception ( throwIO ) import Data.List (find) @@ -30,9 +30,8 @@ import Data.Text qualified as T import Data.Aeson qualified as Aeson -import Bound +import Bound ( Scope ) -import Prettyprinter {- IO utility. Reads a CoreFn module from a source file. @@ -63,7 +62,6 @@ findMain nm Module {..} = doTrace "findDeclBody" ("NAME: " <> T.unpack nm) $ fin findMain' :: forall x ty. - (TypeLike ty, Pretty ty, Pretty (KindOf ty)) => Ident -> [BindE ty (Exp x ty) (Vars ty)] -> Maybe ((Ident, Int), Scope (BVar ty) (Exp x ty) (Vars ty)) diff --git a/tests/TestPurus.hs b/tests/TestPurus.hs index 8f2c6302..37f14832 100644 --- a/tests/TestPurus.hs +++ b/tests/TestPurus.hs @@ -2,8 +2,9 @@ module TestPurus where import Prelude +import Data.Text (Text) import Command.Compile ( compileForTests, PSCMakeOptions(..) ) -import Control.Monad (when,unless,void) +import Control.Monad (when,unless) import System.FilePath import Language.PureScript qualified as P import Data.Set qualified as S @@ -11,14 +12,10 @@ import Data.Foldable (traverse_) import System.Directory (removeDirectoryRecursive, doesDirectoryExist, createDirectory) import System.FilePath.Glob qualified as Glob import Data.Function (on) -import Data.List (sort, sortBy, stripPrefix, groupBy, find) -import Control.Exception.Base -import Language.Purus.Pipeline.CompileToPIR -import PlutusCore.Core -import Test.Tasty -import PlutusCore.Evaluation.Machine.Ck (EvaluationResult(..)) -import PlutusCore -import PlutusCore.Default +import Data.List (sortBy, stripPrefix, groupBy) +import Language.Purus.Make +import Language.Purus.Eval +import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadable) shouldPassTests :: IO () shouldPassTests = do @@ -74,6 +71,13 @@ runPurusDefault path = runPurus P.CoreFn path runPurusGolden :: FilePath -> IO () runPurusGolden path = runPurus P.CheckCoreFn path +runFullPipeline :: FilePath -> Text -> Text -> IO () +runFullPipeline targetDir mainModuleName mainFunctionName = do + runPurusDefault targetDir + pir <- make targetDir mainModuleName mainFunctionName Nothing + result <- evaluateTerm pir + print $ prettyPirReadable result + shouldPass :: [FilePath] shouldPass = map (prefix ) paths