[WIP] Repl rework

cabal.project

@@ -0,0 +1,2 @@
+packages: .
+

pact-core.cabal

@@ -125,10 +125,11 @@ library
     -- Pact.Core.Untyped.Eval.Builtin
 
     -- Repl
-    Pact.Core.Repl.Utils
+    Pact.Core.Repl.Command
+    Pact.Core.Repl.Compile
     Pact.Core.Repl.Runtime
     Pact.Core.Repl.Runtime.ReplBuiltin
-    Pact.Core.Repl.Compile
+    Pact.Core.Repl.Types
 
 library typed-core
   import: pact-core-common

pact-core/Pact/Core/Repl.hs

@@ -3,21 +3,18 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-
-
 -- |
--- Module      :  Pact.Core.IR.Typecheck
--- Copyright   :  (C) 2022 Kadena
+-- Module      :  Pact.Core.Repl
+-- Copyright   :  (C) 2023 Kadena
 -- License     :  BSD-style (see the file LICENSE)
 -- Maintainer  :  Jose Cardona <jose@kadena.io>
 --
 -- Pact core minimal repl
 --
+module Main
+( main
+) where
 
-
-module Main where
-
-import Control.Lens
 import Control.Monad.Catch
 import Control.Monad.Except
 import Control.Monad.Trans(lift)
@@ -29,23 +26,24 @@ import Data.Foldable(traverse_)
 import qualified Data.ByteString as B
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
-import qualified Data.Set as Set
 
 import Pact.Core.Persistence
 import Pact.Core.Pretty
 import Pact.Core.Builtin
 
 import Pact.Core.Compile
 import Pact.Core.Repl.Compile
-import Pact.Core.Repl.Utils
+import Pact.Core.Repl.Command
+import Pact.Core.Repl.Types
+
 
 main :: IO ()
 main = do
   pactDb <- mockPactDb
   g <- newIORef mempty
   evalLog <- newIORef Nothing
   ref <- newIORef (ReplState mempty mempty pactDb g evalLog)
-  runReplT ref (runInputT replSettings loop) >>= \case
+  runReplM ref (runInputT replSettings loop) >>= \case
     Left err -> do
       putStrLn "Exited repl session with error:"
       putStrLn $ T.unpack $ replError (ReplSource "(interactive)" "") err
@@ -75,9 +73,9 @@ main = do
     case minput of
       Nothing -> outputStrLn "goodbye"
       Just input | T.null input -> loop
-      Just input -> case parseReplAction (T.strip input) of
+      Just input -> case parseReplActionText (T.strip input) of
         Nothing -> do
-          outputStrLn "Error: Expected command [:load, :type, :syntax, :debug] or expression"
+          outputStrLn "Error: Expected supported command or expression. See :help for more information."
           loop
         Just ra -> case ra of
           RALoad txt -> let
@@ -91,19 +89,11 @@ main = do
                   rs = ReplSource (T.pack file) (T.decodeUtf8 source)
                   in outputStrLn (T.unpack (replError rs err))
               loop
-          RASetLispSyntax -> loop
-          RASetNewSyntax -> loop
-          RASetFlag flag -> do
-            lift (replFlags %= Set.insert flag)
-            outputStrLn $ unwords ["set debug flag for", prettyReplFlag flag]
-            loop
-          RADebugAll -> do
-            lift (replFlags .= Set.fromList [minBound .. maxBound])
-            outputStrLn $ unwords ["set all debug flags"]
+          RAShowHelp -> do
+            helpCommand
             loop
-          RADebugNone -> do
-            lift (replFlags .= Set.empty)
-            outputStrLn $ unwords ["Remove all debug flags"]
+          RASetDebugFlag flag -> do
+            debugCommand flag
             loop
           RAExecuteExpr src -> catch' $ do
             eout <- lift (tryError (interpretReplProgram (T.encodeUtf8 src)))
@@ -113,7 +103,3 @@ main = do
                 rs = ReplSource "(interactive)" input
                 in outputStrLn (T.unpack (replError rs err))
             loop
-
--- tryError :: MonadError a m => m b -> m (Either a b)
--- tryError ma =
---   catchError (Right <$> ma) (pure . Left)

pact-core/Pact/Core/Repl/Command.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GADTs #-}
+-- |
+-- Module       : Pact.Core.Repl.Commands
+-- Copyright    : (c) 2023, Kadena LLC
+-- License      : BSD-style
+--
+-- Maintainer   : Jose Cardona <jose@kadena.io>
+--
+-- This module contains the datatypes and utilities for the
+-- core Pact repl commands, as well as their semantics and
+-- specification.
+--
+module Pact.Core.Repl.Command
+( -- * commands
+  debugCommand
+, helpCommand
+ -- * utils
+, replCompletion
+, replError
+) where
+
+import Control.Lens
+import Control.Monad.Reader
+
+import qualified Data.List as List
+import Data.Text(Text)
+import Data.List(isPrefixOf)
+import Data.Maybe(mapMaybe)
+import qualified Data.Set as Set
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+
+import Pact.Core.Info
+import Pact.Core.Names
+import Pact.Core.Persistence
+import Pact.Core.Pretty
+
+import Pact.Core.Errors
+import qualified Pact.Core.IR.Term as Term
+import Pact.Core.Repl.Types
+import System.Console.Haskeline
+
+
+
+-- -------------------------------------------------------------------- --
+-- Debug command
+
+-- | The individual action of the debug command
+debugCommand :: DebugFlagUpdate -> InputT (ReplM b) ()
+debugCommand = \case
+  None -> do
+    lift (replFlags .= Set.empty)
+    outputStrLn $ unwords ["Disabling all debug flags"]
+  All -> do
+    lift (replFlags .= Set.fromList [minBound .. maxBound])
+    outputStrLn $ unwords ["Enabling all debug flags"]
+  Some flag -> do
+    lift (replFlags %= Set.insert flag)
+    outputStrLn $ unwords ["set debug flag for", prettyReplDebugFlag flag]
+
+-- -------------------------------------------------------------------- --
+-- Help command
+
+-- | The individual action of the help command
+--
+helpCommand :: InputT (ReplM b) ()
+helpCommand = outputStrLn $ List.intercalate "\n"
+  [ "The following commands are supported by the Pact repl:"
+  , ""
+  , "   <expression>      evaluate and run a pact expression"
+  , "   :help             display all available commands"
+  , "   :load  <file> ... load .pact or .repl files and their dependents"
+  , "   :debug <flag> ... set a debug flag in the repl"
+  , ""
+  , "   options for debug flags: "
+  , ""
+  , "     lexer           show lexer phase information"
+  , "     parser          show parse phase information"
+  , "     desugar         show desugaring phase information"
+  , "     tc-term         show typecheck phase information"
+  , "     tc-type         show inferred type information"
+  , "     specializer     show specializer phase information"
+  , "     untyped-core    show untyped core phase information"
+  , ""
+  ]
+
+
+-- -------------------------------------------------------------------- --
+-- Completion and Error reporting
+
+-- | Repl name and command completion
+--
+replCompletion
+  :: [Text]
+  -- ^ natives
+  -> CompletionFunc (ReplM b)
+replCompletion natives =
+  completeQuotedWord (Just '\\') "\"" listFiles $
+  completeWord (Just '\\') filenameWordBreakChars $ \str -> do
+    tlns <- uses (replLoaded . loToplevel) Map.keys
+    moduleNames <- uses (replLoaded . loModules) (fmap renderModuleName . Map.keys)
+    prefixedNames <- uses (replLoaded . loModules) toPrefixed
+    let
+      cmds = [":load", ":type", ":debug"]
+      allNames = Set.fromList $ T.unpack <$> concat
+        [tlns, moduleNames, prefixedNames, natives, cmds]
+    pure $ simpleCompletion <$> Set.toList (Set.filter (str `isPrefixOf`) allNames)
+  where
+    defNames = \case
+      ModuleData md _ ->
+        Term.defName <$> Term._mDefs md
+      InterfaceData iface _ ->
+        fmap Term._dcName $ mapMaybe (preview Term._IfDConst) $ Term._ifDefns iface
+      -- fmap Term.defName . Term._mDefs . _mdModule
+    toPrefixed m =
+      concat $ prefixF <$> Map.toList m
+    prefixF (mn, ems) = let
+      dns = defNames ems
+      in fmap ((renderModuleName mn <> ".") <>) dns
+
+-- | Repl error reporting
+--
+replError
+  :: ReplSource
+  -> PactErrorI
+  -> Text
+replError (ReplSource file src) pe =
+  let srcLines = T.lines src
+      pei = view peInfo pe
+      slice = withLine (_liStartLine pei) $ take (max 1 (_liEndLine pei)) $ drop (_liStartLine pei) srcLines
+      colMarker = "  | " <> T.replicate (_liStartColumn pei) " " <> T.replicate (max 1 (_liEndColumn pei - _liStartColumn pei)) "^"
+      errRender = renderText pe
+      fileErr = file <> ":" <> T.pack (show (_liStartLine pei)) <> ":" <> T.pack (show (_liStartColumn pei)) <> ": "
+  in T.unlines ([fileErr <> errRender] ++ slice ++ [colMarker])
+  where
+    withLine st lns = zipWith (\i e -> T.pack (show i) <> " | " <> e) [st ..] lns

pact-core/Pact/Core/Repl/Compile.hs

@@ -17,6 +17,8 @@ import Control.Lens
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class(liftIO)
+
+import qualified Data.Set as Set
 import Data.Text(Text)
 import Data.ByteString(ByteString)
 import Data.Proxy
@@ -31,7 +33,8 @@ import Pact.Core.Persistence
 import Pact.Core.Builtin
 import Pact.Core.Gas
 import Pact.Core.Names
-import Pact.Core.Repl.Utils
+import Pact.Core.Pretty hiding (pipe)
+import Pact.Core.Repl.Types
 import Pact.Core.IR.Desugar
 import Pact.Core.Errors
 import Pact.Core.IR.Term
@@ -96,15 +99,15 @@ interpretReplProgram
 interpretReplProgram source = do
   pactdb <- use replPactDb
   lexx <- liftEither (Lisp.lexer source)
-  debugIfFlagSet ReplDebugLexer lexx
+  printIfReplFlagSet ReplDebugLexer lexx
   parsed <- liftEither $ Lisp.parseReplProgram lexx
   concat <$> traverse (pipe pactdb) parsed
   where
   debugIfLispExpr = \case
-    Lisp.RTLTerm t -> debugIfFlagSet ReplDebugParser t
+    Lisp.RTLTerm t -> printIfReplFlagSet ReplDebugParser t
     _ -> pure ()
   debugIfIRExpr flag = \case
-    RTLTerm t -> debugIfFlagSet flag t
+    RTLTerm t -> printIfReplFlagSet flag t
     _ -> pure ()
   pipe pactdb = \case
     Lisp.RTL rtl ->
@@ -129,7 +132,7 @@ interpretReplProgram source = do
         RCompileValue <$> interpretTopLevel pdb interp (DesugarOutput tt lo deps)
         where
         interpreter te = do
-          debugIfFlagSet ReplDebugUntyped te
+          printIfReplFlagSet ReplDebugUntyped te
           let i = view termInfo te
           evalGas <- use replGas
           evalLog <- use replEvalLog
@@ -218,3 +221,59 @@ interpretReplProgram source = do
       --   toFqDep modName mhash defn =
       --     let fqn = FullyQualifiedName modName (defName defn) mhash
       --     in (fqn, defn)
+
+-- | Print debugging information for a particular Repl debug flag
+-- if set in the Repl environment.
+--
+printIfReplFlagSet :: Pretty a => ReplDebugFlag -> a -> ReplM b ()
+printIfReplFlagSet flag a =
+  whenReplFlagSet flag $ liftIO (printDebug a flag)
+
+-- | Set Repl debug flag in the repl monad.
+--
+replFlagSet
+  :: ReplDebugFlag
+  -> ReplM b Bool
+replFlagSet flag =
+  uses replFlags (Set.member flag)
+
+-- | Execute an action if a particular debug flag is set in
+-- in the Repl environment.
+--
+whenReplFlagSet :: ReplDebugFlag -> ReplM b () -> ReplM b ()
+whenReplFlagSet flag ma =
+  replFlagSet flag >>= \b -> when b ma
+
+-- | Execute an action if a particular debug flag is not set in
+-- in the Repl environment.
+--
+_unlessReplFlagSet :: ReplDebugFlag -> ReplM b () -> ReplM b ()
+_unlessReplFlagSet flag ma =
+  replFlagSet flag >>= \b -> unless b ma
+
+-- | Print configuration for repl debug flags
+--
+-- TODO: this seems useful, but stale.
+printDebug :: Pretty a => a -> ReplDebugFlag -> IO ()
+printDebug a = \case
+  ReplDebugLexer -> do
+    putStrLn "----------- Lexer output -----------------"
+    print (pretty a)
+  ReplDebugParser -> do
+    putStrLn "----------- Parser output ----------------"
+    print (pretty a)
+  ReplDebugDesugar -> do
+    putStrLn "----------- Desugar output ---------------"
+    print (pretty a)
+  ReplDebugTypechecker -> do
+    putStrLn "----------- Typechecker output -----------"
+    print (pretty a)
+  ReplDebugTypecheckerType -> do
+    putStrLn "----------- Inferred type output ---------"
+    print (pretty a)
+  ReplDebugSpecializer -> do
+    putStrLn "----------- Specializer output -----------"
+    print (pretty a)
+  ReplDebugUntyped -> do
+    putStrLn "----------- Untyped core output ----------"
+    print (pretty a)