Interleave printing with Repl output

pact-core-tests/Pact/Core/Test/ReplTests.hs

@@ -61,7 +61,7 @@ runReplTest file src = do
             , _replTx = Nothing
             }
   stateRef <- newIORef rstate
-  runReplT stateRef (interpretReplProgram (SourceCode src)) >>= \case
+  runReplT stateRef (interpretReplProgram (SourceCode src) (const (pure ()))) >>= \case
     Left e -> let
       rendered = replError (ReplSource (T.pack file) (decodeUtf8 src)) e
       in assertFailure (T.unpack rendered)

pact-core/Pact/Core/Compile.hs

@@ -5,9 +5,13 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 
-module Pact.Core.Compile where
+module Pact.Core.Compile
+ ( interpretTopLevel
+ , CompileValue(..)
+ ) where
 
 import Control.Lens
 import Control.Monad.State.Strict ( MonadIO(..), MonadState )
@@ -29,7 +33,6 @@ import Pact.Core.Names
 import Pact.Core.IR.Desugar
 import Pact.Core.Errors
 import Pact.Core.Pretty
-import Pact.Core.Type
 import Pact.Core.IR.Term
 import Pact.Core.Interpreter
 import Pact.Core.Guards
@@ -43,15 +46,16 @@ import qualified Pact.Core.Syntax.Lexer as Lisp
 import qualified Pact.Core.Syntax.Parser as Lisp
 import qualified Pact.Core.Syntax.ParseTree as Lisp
 
-type HasCompileEnv b s m
-  = ( MonadError PactErrorI m
+type HasCompileEnv b i s m
+  = ( MonadError (PactError i) m
     , MonadState s m
-    , HasEvalState s b SpanInfo
+    , HasEvalState s b i
     , DesugarBuiltin b
     , Pretty b
     , MonadIO m
     , Show b
-    , PhaseDebug m)
+    , Show i
+    , PhaseDebug b i m)
 
 _parseOnly
   :: ByteString -> Either PactErrorI [Lisp.TopLevel SpanInfo]
@@ -69,62 +73,51 @@ data CompileValue b
   | InterpretValue InterpretValue
   deriving Show
 
-
-compileProgram
-  :: (HasCompileEnv b s m)
-  => ByteString
-  -> PactDb b SpanInfo
-  -> Interpreter b m
-  -> m [CompileValue b]
-compileProgram source pdb interp = do
-  lexed <- liftEither (Lisp.lexer source)
-  debugPrint DebugLexer lexed
-  parsed <- liftEither (Lisp.parseProgram lexed)
-  lo <- use (evalState . loaded)
-  traverse (go lo) parsed
-  where
-  go lo =
-    evalModuleGovernance pdb interp
-    >=> runDesugarTopLevel Proxy pdb lo
-    >=> interpretTopLevel pdb interp
-
 -- | Evaluate module governance
 evalModuleGovernance
-  :: (HasCompileEnv b s m)
-  => PactDb b SpanInfo
-  -> Interpreter b m
-  -> Lisp.TopLevel SpanInfo
-  -> m (Lisp.TopLevel SpanInfo)
+  :: (HasCompileEnv b i s m)
+  => PactDb b i
+  -> Interpreter b i m
+  -> Lisp.TopLevel i
+  -> m ()
 evalModuleGovernance pdb interp = \case
-  tl@(Lisp.TLModule m) -> liftIO (readModule pdb (Lisp._mName m)) >>= \case
+  Lisp.TLModule m -> liftIO (readModule pdb (Lisp._mName m)) >>= \case
+    -- Existing module found
     Just (ModuleData md _) ->
       case _mGovernance md of
         KeyGov (KeySetName ksn) -> do
           let info = Lisp._mInfo m
               ksnTerm = Constant (LString ksn) info
               ksrg = App (Builtin (liftRaw RawKeysetRefGuard) info) (pure ksnTerm) info
               term = App (Builtin (liftRaw RawEnforceGuard) info) (pure ksrg) info
-          _interpret interp term *> pure tl
+          void (_interpret interp term)
         CapGov (ResolvedGov fqn) ->
           -- Todo: this does not allow us to delegate governance, which is an issue.
           case find (\d -> defName d == _fqName fqn) (_mDefs md) of
             Just (DCap d) ->
-              _interpret interp (_dcapTerm d) *> pure tl
+              void (_interpret interp (_dcapTerm d))
             _ ->
               throwError (PEExecutionError (ModuleGovernanceFailure (Lisp._mName m)) (Lisp._mInfo m))
+    -- Found an interface, oopsie it's not upgradeable.
     Just (InterfaceData iface _) ->
       throwError (PEExecutionError (CannotUpgradeInterface (_ifName iface)) (_ifInfo iface))
-    Nothing -> pure tl
-  a -> pure a
+    Nothing -> pure ()
+  _ -> pure ()
 
 interpretTopLevel
-  :: (HasCompileEnv b s m)
-  => PactDb b SpanInfo
-  -> Interpreter b m
-  -> DesugarOutput b SpanInfo (TopLevel Name Type b SpanInfo)
+  :: forall b i s m
+  .  (HasCompileEnv b i s m)
+  => PactDb b i
+  -> Interpreter b i m
+  -> Lisp.TopLevel i
   -> m (CompileValue b)
-interpretTopLevel pdb interp (DesugarOutput ds lo0 _deps) = do
-  debugPrint DebugDesugar ds
+interpretTopLevel pdb interp tl = do
+  evalModuleGovernance pdb interp tl
+  lo <- use (evalState . loaded)
+  -- Todo: pretty instance for modules and all of toplevel
+  debugPrint (DPParser @b) tl
+  (DesugarOutput ds lo0 _deps) <- runDesugarTopLevel Proxy pdb lo tl
+  debugPrint DPDesugar ds
   evalState . loaded .= lo0
   case ds of
     TLModule m -> do

pact-core/Pact/Core/Debug.hs

@@ -1,19 +1,30 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+-- {-# LANGUAGE FunctionalDependencies #-}
+
 module Pact.Core.Debug
  ( DebugFlag(..)
  , PhaseDebug(..)
+ , DebugPrint(..)
  ) where
 
-import Pact.Core.Pretty
+import Pact.Core.Type
+import Pact.Core.Names
+import Pact.Core.Syntax.LexUtils(PosToken)
+import qualified Pact.Core.Syntax.ParseTree as Syntax
+import qualified Pact.Core.IR.Term as Term
+
+data DebugPrint b i term where
+  DPLexer :: DebugPrint b i [PosToken]
+  DPParser :: DebugPrint b i (Syntax.TopLevel i)
+  DPDesugar :: DebugPrint b i (Term.TopLevel Name Type b i)
+  -- deriving (Show, Eq, Ord, Enum, Bounded)
 
 data DebugFlag
-  = DebugLexer
-  | DebugParser
-  | DebugDesugar
-  | DebugTypechecker
-  | DebugTypecheckerType
-  | DebugSpecializer
-  | DebugUntyped
+  = DFLexer
+  | DFParser
+  | DFDesugar
   deriving (Show, Eq, Ord, Enum, Bounded)
 
-class Monad m => PhaseDebug m where
-  debugPrint :: Pretty a => DebugFlag -> a -> m ()
+class Monad m => PhaseDebug b i m where
+  debugPrint :: DebugPrint b i term -> term -> m ()

pact-core/Pact/Core/IR/Desugar.hs

@@ -252,28 +252,12 @@ instance DesugarBuiltin (ReplBuiltin RawBuiltin) where
 throwDesugarError :: MonadError (PactError i) m => DesugarError -> i -> m a
 throwDesugarError de = throwError . PEDesugarError de
 
--- Really ugly hack because
--- of inconsistent old prod pact syntax :)))))))
--- pattern HigherOrderApp :: Text -> i -> Text -> i -> [Lisp.Expr i] -> i -> i -> Lisp.Expr i
--- pattern HigherOrderApp fnCaller ci fnCallee fi xs ai unused =
---   Lisp.App (Lisp.Var (BN (BareName fnCaller)) ci)
---     (Lisp.App (Lisp.Var (BN (BareName fnCallee)) unused) [] fi :   xs)
---     ai
-
 desugarLispTerm
   :: forall raw reso i m
   . (MonadDesugar raw reso i m)
   => Lisp.Expr i
   -> m (Term ParsedName DesugarType raw i)
 desugarLispTerm = \case
-  -- HigherOrderApp fnCaller ci fnCallee fi xs ai _
-  --   | fnCaller `elem` specialCallsiteFns -> do
-  --     caller <- desugarLispTerm (Lisp.Var (BN (BareName fnCaller)) ci)
-  --     callee <- desugarLispTerm $ Lisp.Var (BN (BareName fnCallee)) fi
-  --     xs' <- traverse desugarLispTerm xs
-  --     pure (App caller (callee:xs') ai)
-  --   where
-  --   specialCallsiteFns = ["map", "fold", "zip"]
   Lisp.Var (BN n) i  ->
     case M.lookup (_bnName n) reservedNatives' of
       Just b -> pure (Builtin b i)
@@ -320,17 +304,6 @@ desugarLispTerm = \case
         in Let arg access body i
   Lisp.If e1 e2 e3 i -> Conditional <$>
      (CIf <$> desugarLispTerm e1 <*> desugarLispTerm e2 <*> desugarLispTerm e3) <*> pure i
-  -- Note: this is our "unit arg application" desugaring
-  -- This _may not_ stay long term
-  -- Lisp.App e [] i ->
-  --   App <$> desugarLispTerm e <&> [] <*> pure i
-    -- v@Var{} ->
-    --   let arg = Constant LUnit i :| []
-    --   in App v arg i
-    -- v@Builtin{} ->
-    --   let arg = Constant LUnit i :| []
-    --   in App v arg i
-    -- e' -> e'
   Lisp.App (Lisp.Operator o _oi) [e1, e2] i -> case o of
     Lisp.AndOp ->
       Conditional <$> (CAnd <$> desugarLispTerm e1 <*> desugarLispTerm e2) <*> pure i
@@ -367,14 +340,6 @@ desugarLispTerm = \case
       WithCapability pn <$> traverse desugarLispTerm exs <*> desugarLispTerm ex
     Lisp.CreateUserGuard pn exs ->
       CreateUserGuard pn <$> traverse desugarLispTerm exs
-    -- Lisp.RequireCapability pn exs ->
-    --   RequireCapability pn <$> traverse desugarLispTerm exs
-    -- Lisp.ComposeCapability pn exs ->
-    --   ComposeCapability pn <$> traverse desugarLispTerm exs
-    -- Lisp.InstallCapability pn exs ->
-    --   InstallCapability pn <$> traverse desugarLispTerm exs
-    -- Lisp.EmitEvent pn exs ->
-    --   EmitEvent pn <$> traverse desugarLispTerm exs
   where
   binderToLet i (Lisp.Binder n mty expr) term = do
     expr' <- desugarLispTerm expr
@@ -1549,13 +1514,6 @@ runDesugarReplDefConst _ pdb loaded =
   . RenamerT
   . (desugarDefConst >=> renameReplDefConst)
 
--- runDesugarModule
---   :: (DesugarTerm term raw i)
---   => Loaded b i
---   -> Lisp.Module term i
---   -> IO (DesugarOutput b i (Module Name TypeVar raw i))
--- runDesugarModule loaded = runDesugarModule' loaded 0
-
 runDesugarTopLevel
   :: (MonadError (PactError i) m, MonadIO m, DesugarBuiltin raw, Show reso, Show i)
   => Proxy raw
@@ -1579,8 +1537,13 @@ runDesugarReplTopLevel
   -> Lisp.ReplTopLevel i
   -> m (DesugarOutput reso i (ReplTopLevel Name Type raw i))
 runDesugarReplTopLevel proxy pdb loaded = \case
-  Lisp.RTLTopLevel m ->
-    over dsOut RTLTopLevel <$> runDesugarTopLevel proxy pdb loaded m
+  -- We do not run desugar here for the repl.
+  -- We pattern match before we ever hit this case, therefore this should not be reachable
+  -- This is fine to stay in `error`. The repl special functions and forms do not show up on chain
+  -- and we want this to be a clear haskell error. The current repl implementation
+  -- makes sure to not ever hit this.
+  Lisp.RTLTopLevel _ ->
+    error "Fatal: do not use desugarReplTopLevel on toplevel forms from the parser. Use runDesugarTopLevel directly"
   Lisp.RTLDefun de ->
     over dsOut RTLDefun <$> runDesugarReplDefun proxy pdb loaded de
   Lisp.RTLDefConst dc ->

pact-core/Pact/Core/IR/Term.hs

@@ -189,20 +189,10 @@ data TopLevel name ty builtin info
   deriving (Show, Functor)
 
 data ReplTopLevel name ty builtin info
-  = RTLTopLevel (TopLevel name ty builtin info)
-  | RTLDefConst (DefConst name ty builtin info)
+  = RTLDefConst (DefConst name ty builtin info)
   | RTLDefun (Defun name ty builtin info)
   deriving (Show, Functor)
 
-pattern RTLTerm :: Term name ty builtin info -> ReplTopLevel name ty builtin info
-pattern RTLTerm e = RTLTopLevel (TLTerm e)
-
-pattern RTLModule :: Module name ty builtin info -> ReplTopLevel name ty builtin info
-pattern RTLModule m = RTLTopLevel (TLModule m)
-
-pattern RTLInterface :: Interface name ty builtin info -> ReplTopLevel name ty builtin info
-pattern RTLInterface iface = RTLTopLevel (TLInterface iface)
-
 defName :: Def name t b i -> Text
 defName (Dfun d) = _dfunName d
 defName (DConst d) = _dcName d

pact-core/Pact/Core/Interpreter.hs

@@ -19,9 +19,9 @@ import Pact.Core.PactValue
 -- import Pact.Core.Environment
 -- import Pact.Core.Errors
 
-newtype Interpreter b m
+newtype Interpreter b i m
   = Interpreter
-  { _interpret :: Term Name Type b SpanInfo -> m InterpretValue
+  { _interpret :: Term Name Type b i -> m InterpretValue
   }
 
 data InterpretValue

pact-core/Pact/Core/Repl.hs

@@ -23,8 +23,6 @@ import Control.Monad.Except
 import Control.Monad.Trans(lift)
 import System.Console.Haskeline
 import Data.IORef
-import Data.Foldable(traverse_)
-
 import Data.Default
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
@@ -52,7 +50,7 @@ main = do
   evalLog <- newIORef Nothing
   let ee = EvalEnv mempty pdb (EnvData mempty) (Hash "default") def Nothing Transactional mempty
       es = EvalState (CapState [] mempty mempty mempty) [] [] mempty Nothing
-  ref <- newIORef (ReplState mempty pdb es ee g evalLog (SourceCode mempty) Nothing)
+  ref <- newIORef (ReplState mempty pdb es ee g evalLog defaultSrc Nothing)
   runReplT ref (runInputT replSettings loop) >>= \case
     Left err -> do
       putStrLn "Exited repl session with error:"
@@ -78,9 +76,8 @@ main = do
     RLoadedDefConst mn ->
       outputStrLn $ show $
         "loaded defconst" <+> pretty mn
-    -- InterpretValue v _ -> outputStrLn (show (pretty v))
-    -- InterpretLog t -> outputStrLn (T.unpack t)
   catch' ma = catchAll ma (\e -> outputStrLn (show e) *> loop)
+  defaultSrc = SourceCode "(interactive)" mempty
   loop = do
     minput <- fmap T.pack <$> getInputLine "pact>"
     case minput of
@@ -104,12 +101,16 @@ main = do
             outputStrLn $ unwords ["Remove all debug flags"]
             loop
           RAExecuteExpr src -> catch' $ do
-            eout <- lift (tryError (interpretReplProgram (SourceCode (T.encodeUtf8 src))))
+            let display' rcv = runInputT replSettings (displayOutput rcv)
+            let sourceBs = T.encodeUtf8 src
+            lift (replCurrSource .= defaultSrc{_scPayload=sourceBs})
+            eout <- lift (tryError (interpretReplProgram (SourceCode "(interactive)" sourceBs) display'))
             case eout of
-              Right out -> traverse_ displayOutput out
+              Right _ -> pure ()
               Left err -> do
-                SourceCode currSrc <- lift (use replCurrSource)
+                SourceCode srcFile currSrc <- lift (use replCurrSource)
                 let srcText = T.decodeUtf8 currSrc
-                let rs = ReplSource "(interactive)" srcText
+                let rs = ReplSource (T.pack srcFile) srcText
+                lift (replCurrSource .= defaultSrc)
                 outputStrLn (T.unpack (replError rs err))
             loop