more cleaning up, more removing dead code, more writing comments

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

src/Language/Purus/Pipeline/CompileToPIR/Eval.hs → 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,66 +36,30 @@ 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))
 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"

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
 

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,38 +113,38 @@ 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 "
               <> T.unpack (runModuleName mainModuleName)
               <> "\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

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