From 181d801d6f776fc6b93fa99c6b1fc45f3b56417b Mon Sep 17 00:00:00 2001 From: Emily Pillmore Date: Fri, 18 Aug 2023 16:07:09 -0600 Subject: [PATCH 1/2] Rework modules, add types, split out command actions, needs parser help --- cabal.project | 2 + pact-core.cabal | 5 +- pact-core/Pact/Core/Repl.hs | 45 ++--- pact-core/Pact/Core/Repl/Command.hs | 141 +++++++++++++++ pact-core/Pact/Core/Repl/Compile.hs | 69 +++++++- pact-core/Pact/Core/Repl/Types.hs | 223 +++++++++++++++++++++++ pact-core/Pact/Core/Repl/Utils.hs | 264 ---------------------------- 7 files changed, 449 insertions(+), 300 deletions(-) create mode 100644 cabal.project create mode 100644 pact-core/Pact/Core/Repl/Command.hs create mode 100644 pact-core/Pact/Core/Repl/Types.hs delete mode 100644 pact-core/Pact/Core/Repl/Utils.hs diff --git a/cabal.project b/cabal.project new file mode 100644 index 000000000..b764c340a --- /dev/null +++ b/cabal.project @@ -0,0 +1,2 @@ +packages: . + diff --git a/pact-core.cabal b/pact-core.cabal index d18375c61..866049e6e 100644 --- a/pact-core.cabal +++ b/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 diff --git a/pact-core/Pact/Core/Repl.hs b/pact-core/Pact/Core/Repl.hs index 0d6bcdf17..1210af8a3 100644 --- a/pact-core/Pact/Core/Repl.hs +++ b/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 -- -- 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,7 +26,6 @@ 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 @@ -37,7 +33,9 @@ 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 @@ -45,7 +43,7 @@ main = do 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,10 @@ 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." + outputStrLn $ show $ parseReplActionText input loop Just ra -> case ra of RALoad txt -> let @@ -91,19 +90,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 +104,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) diff --git a/pact-core/Pact/Core/Repl/Command.hs b/pact-core/Pact/Core/Repl/Command.hs new file mode 100644 index 000000000..ea1bd601c --- /dev/null +++ b/pact-core/Pact/Core/Repl/Command.hs @@ -0,0 +1,141 @@ +{-# 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 +-- +-- 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:" + , "" + , " evaluate and run a pact expression" + , " :help display all available commands" + , " :load ... load .pact or .repl files and their dependents" + , " :debug ... 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 diff --git a/pact-core/Pact/Core/Repl/Compile.hs b/pact-core/Pact/Core/Repl/Compile.hs index fa3eac502..9146e2541 100644 --- a/pact-core/Pact/Core/Repl/Compile.hs +++ b/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) diff --git a/pact-core/Pact/Core/Repl/Types.hs b/pact-core/Pact/Core/Repl/Types.hs new file mode 100644 index 000000000..496dd8ad2 --- /dev/null +++ b/pact-core/Pact/Core/Repl/Types.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +module Pact.Core.Repl.Types +( -- * Repl State + ReplState(..) +, replLoaded +, replPactDb +, replGas +, replEvalLog +, replFlags + + -- * Repl monad +, ReplM(..) +, runReplM + + -- * Supported repl commmands +, DebugFlagUpdate(..) +, ReplAction(..) +, parseReplAction +, parseReplActionText + -- * Repl debug flags + +, ReplDebugFlag(..) +, prettyReplDebugFlag +, parseReplDebugFlag + + -- * Repl source files +, ReplSource(..) +) where + +import Control.Lens +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Catch ( MonadCatch, MonadThrow, MonadMask ) +import Control.Monad.Except + +import Data.IORef +import Data.Set as Set +import Data.Text +import Data.Void + + +import Text.Megaparsec((<|>)) +import qualified Text.Megaparsec as MP +import qualified Text.Megaparsec.Char as MP + +import Pact.Core.Info +import Pact.Core.Persistence +import Pact.Core.Gas +import Pact.Core.Errors +import Pact.Core.Debug + + +-- -------------------------------------------------------------------- -- +-- Repl parser + +-- | Repl Parser +-- +type ReplParser = MP.Parsec Void Text + +-- -------------------------------------------------------------------- -- +-- Repl debug flags + +-- | $Commands +-- +-- The following repl commands are supported in Pact: +-- +-- * +data ReplDebugFlag + = ReplDebugLexer + | ReplDebugParser + | ReplDebugDesugar + | ReplDebugTypechecker + | ReplDebugTypecheckerType + | ReplDebugSpecializer + | ReplDebugUntyped + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | Pretty print a debug flag +-- +prettyReplDebugFlag :: ReplDebugFlag -> String +prettyReplDebugFlag = \case + ReplDebugLexer -> "lexer" + ReplDebugParser -> "parser" + ReplDebugDesugar -> "desugar" + ReplDebugTypechecker -> "tc-term" + ReplDebugTypecheckerType -> "tc-type" + ReplDebugSpecializer -> "specializer" + ReplDebugUntyped -> "untyped-core" + +-- | Parser for repl debug flags +-- +parseReplDebugFlag :: ReplParser ReplDebugFlag +parseReplDebugFlag = + (ReplDebugLexer <$ MP.chunk "lexer") <|> + (ReplDebugParser <$ MP.chunk "parser") <|> + (ReplDebugDesugar <$ MP.chunk "desugar") <|> + (ReplDebugTypechecker <$ MP.chunk "tc-term") <|> + (ReplDebugTypecheckerType <$ MP.chunk "tc-type") <|> + (ReplDebugSpecializer <$ MP.chunk "specializer") <|> + (ReplDebugUntyped <$ MP.chunk "untyped-core") + +-- -------------------------------------------------------------------- -- +-- Repl source + +-- | Repl source +-- +data ReplSource + = ReplSource + { _rsFile :: Text + , _rsSource :: Text + } deriving Show + +-- -------------------------------------------------------------------- -- +-- Repl monad + +-- | Repl monad state +-- +data ReplState b + = ReplState + { _replFlags :: Set ReplDebugFlag + , _replLoaded :: Loaded b SpanInfo + , _replPactDb :: PactDb b SpanInfo + , _replGas :: IORef Gas + , _replEvalLog :: IORef (Maybe [(Text, Gas)]) + } +makeLenses ''ReplState + +instance PhaseDebug (ReplM b) where + debugPrint _ _ = pure () + +instance HasLoaded (ReplState b) b SpanInfo where + loaded = replLoaded + +-- | The Pact repl monad +-- +-- All expressions and flag updates run through this monad in the repl. +-- +newtype ReplM b a + = ReplM { unReplM :: ExceptT (PactError SpanInfo) (ReaderT (IORef (ReplState b)) IO) a } + deriving + ( Functor + , Applicative + , Monad + , MonadIO + , MonadThrow + , MonadError (PactError SpanInfo) + , MonadCatch + , MonadMask) + via (ExceptT (PactError SpanInfo) (ReaderT (IORef (ReplState b)) IO)) + +instance MonadState (ReplState b) (ReplM b) where + get = ReplM (ExceptT (Right <$> ReaderT readIORef)) + put rs = ReplM (ExceptT (Right <$> ReaderT (`writeIORef` rs))) + +-- | Run repl action +-- +runReplM :: IORef (ReplState b) -> ReplM b a -> IO (Either (PactError SpanInfo) a) +runReplM env (ReplM act) = runReaderT (runExceptT act) env + +-- -------------------------------------------------------------------- -- +-- Suported Repl Commands + +-- | Debug flag delta type for setting debug flags +-- +-- TODO: We can make this more robust by allowing for multiple flag updates +-- +data DebugFlagUpdate + = All + | Some ReplDebugFlag + | None + deriving (Eq, Show) + +-- | Parser for setting repl debug flags +-- +parseReplDebugUpdate :: ReplParser DebugFlagUpdate +parseReplDebugUpdate = + (All <$ MP.chunk "all") + <|> (None <$ MP.chunk "none") + <|> (Some <$> parseReplDebugFlag) + +-- | Repl action dispatch +-- +data ReplAction + = RALoad Text + -- ^ load a .pact or .repl file + | RAShowHelp + -- ^ show all commands and associated help + -- | RATypecheck Text + -- ^ typecheck an expression + | RASetDebugFlag DebugFlagUpdate + -- ^ set a repl debug flag + | RAExecuteExpr Text + -- ^ (default) execute an arbitrary pact expression + deriving Show + +parseReplAction :: ReplParser ReplAction +parseReplAction = + cmd <|> execute + where + execute = + RAExecuteExpr <$> MP.takeRest + cmdKw kw = MP.chunk kw *> MP.space1 + cmd = do + _ <- MP.char ':' + load <|> setFlag <|> showHelp + showHelp = pure RAShowHelp + setFlag = + cmdKw "debug" *> (RASetDebugFlag <$> parseReplDebugUpdate) + + -- tc = do + -- cmdKw "type" + -- RATypecheck <$> MP.takeRest + load = do + cmdKw "load" + let c = MP.char '\"' + RALoad <$> MP.between c c (MP.takeWhile1P Nothing (/= '\"')) + +-- | Parser for Repl debug actions +-- +parseReplActionText :: Text -> Maybe ReplAction +parseReplActionText = MP.parseMaybe parseReplAction diff --git a/pact-core/Pact/Core/Repl/Utils.hs b/pact-core/Pact/Core/Repl/Utils.hs deleted file mode 100644 index 9f21bc316..000000000 --- a/pact-core/Pact/Core/Repl/Utils.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GADTs #-} - - -module Pact.Core.Repl.Utils - ( ReplDebugFlag(..) - , printDebug - , ReplM(..) - , replFlagSet - , runReplT - , ReplState(..) - , replFlags - , replLoaded - , replPactDb - , replGas - , replEvalLog - , whenReplFlagSet - , unlessReplFlagSet - , debugIfFlagSet - , replCompletion - , ReplAction(..) - , parseReplAction - , prettyReplFlag - , ReplSource(..) - , replError - ) where - -import Control.Lens -import Control.Monad ( when, unless ) -import Control.Monad.Reader -import Control.Monad.State.Strict -import Control.Monad.Catch -import Control.Monad.Except - -import Data.Void -import Data.IORef -import Data.Set(Set) -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 Text.Megaparsec((<|>), ()) -import qualified Text.Megaparsec as MP -import qualified Text.Megaparsec.Char as MP - -import Pact.Core.Info -import Pact.Core.Names -import Pact.Core.Persistence -import Pact.Core.Pretty -import Pact.Core.Gas -import Pact.Core.Errors -import Pact.Core.Debug -import qualified Pact.Core.IR.Term as Term - -import System.Console.Haskeline.Completion - -data ReplDebugFlag - = ReplDebugLexer - | ReplDebugParser - | ReplDebugDesugar - | ReplDebugTypechecker - | ReplDebugTypecheckerType - | ReplDebugSpecializer - | ReplDebugUntyped - deriving (Show, Eq, Ord, Enum, Bounded) - -prettyReplFlag :: ReplDebugFlag -> String -prettyReplFlag = \case - ReplDebugLexer -> "lexer" - ReplDebugParser -> "parser" - ReplDebugDesugar -> "desugar" - ReplDebugTypechecker -> "tc-term" - ReplDebugTypecheckerType -> "tc-type" - ReplDebugSpecializer -> "specializer" - ReplDebugUntyped -> "untyped-core" - -newtype ReplM b a - = ReplT { unReplT :: ExceptT (PactError SpanInfo) (ReaderT (IORef (ReplState b)) IO) a } - deriving - ( Functor - , Applicative - , Monad - , MonadIO - , MonadThrow - , MonadError (PactError SpanInfo) - , MonadCatch - , MonadMask) - via (ExceptT (PactError SpanInfo) (ReaderT (IORef (ReplState b)) IO)) - - -instance MonadState (ReplState b) (ReplM b) where - get = ReplT (ExceptT (Right <$> ReaderT readIORef)) - put rs = ReplT (ExceptT (Right <$> ReaderT (`writeIORef` rs))) - --- | Passed in repl environment --- Todo: not a `newtype` since there's --- more fields we can set. -data ReplState b - = ReplState - { _replFlags :: Set ReplDebugFlag - , _replLoaded :: Loaded b SpanInfo - , _replPactDb :: PactDb b SpanInfo - , _replGas :: IORef Gas - , _replEvalLog :: IORef (Maybe [(Text, Gas)]) - } - - -makeLenses ''ReplState - -instance PhaseDebug (ReplM b) where - debugPrint _ _ = pure () - -instance HasLoaded (ReplState b) b SpanInfo where - loaded = replLoaded - -data ReplAction - = RALoad Text - | RASetLispSyntax - | RASetNewSyntax - -- | RATypecheck Text - | RASetFlag ReplDebugFlag - | RADebugAll - | RADebugNone - | RAExecuteExpr Text - deriving Show - -type ReplParser = MP.Parsec Void Text - -replFlag :: ReplParser ReplDebugFlag -replFlag = - (ReplDebugLexer <$ MP.chunk "lexer") <|> - (ReplDebugParser <$ MP.chunk "parser") <|> - (ReplDebugDesugar <$ MP.chunk "desugar") <|> - (ReplDebugTypechecker <$ MP.chunk "tc-term") <|> - (ReplDebugTypecheckerType <$ MP.chunk "tc-type") <|> - (ReplDebugSpecializer <$ MP.chunk "specializer") <|> - (ReplDebugUntyped <$ MP.chunk "untyped-core") - -replAction :: ReplParser ReplAction -replAction = - cmd <|> execute - where - execute = - RAExecuteExpr <$> MP.takeRest - cmdKw kw = MP.chunk kw *> MP.space1 - cmd = do - _ <- MP.chunk ":" - load <|> setLang <|> setFlag "asdf" - setFlag = - cmdKw "debug" *> ((RASetFlag <$> replFlag) <|> (RADebugAll <$ MP.chunk "all") <|> (RADebugNone <$ MP.chunk "none")) - setLang = do - cmdKw "syntax" - (RASetLispSyntax <$ MP.chunk "lisp") <|> (RASetNewSyntax <$ MP.chunk "new") - -- tc = do - -- cmdKw "type" - -- RATypecheck <$> MP.takeRest - load = do - cmdKw "load" - let c = MP.char '\"' - RALoad <$> MP.between c c (MP.takeWhile1P Nothing (/= '\"')) - -parseReplAction :: Text -> Maybe ReplAction -parseReplAction = MP.parseMaybe replAction - -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) - -replFlagSet - :: ReplDebugFlag - -> ReplM b Bool -replFlagSet flag = - uses replFlags (Set.member flag) - -debugIfFlagSet :: Pretty a => ReplDebugFlag -> a -> ReplM b () -debugIfFlagSet flag a = - whenReplFlagSet flag $ liftIO (printDebug a flag) - -whenReplFlagSet :: ReplDebugFlag -> ReplM b () -> ReplM b () -whenReplFlagSet flag ma = - replFlagSet flag >>= \b -> when b ma - -unlessReplFlagSet :: ReplDebugFlag -> ReplM b () -> ReplM b () -unlessReplFlagSet flag ma = - replFlagSet flag >>= \b -> unless b ma - -data ReplSource - = ReplSource - { _rsFile :: Text - , _rsSource :: Text - } deriving Show - -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", ":syntax", ":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 - -runReplT :: IORef (ReplState b) -> ReplM b a -> IO (Either (PactError SpanInfo) a) -runReplT env (ReplT act) = runReaderT (runExceptT act) env - -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 From 4c6645aae75363777341e46abbfa5cbf36974708 Mon Sep 17 00:00:00 2001 From: Emily Pillmore Date: Fri, 18 Aug 2023 16:17:52 -0600 Subject: [PATCH 2/2] fix parser, display help --- pact-core/Pact/Core/Repl.hs | 1 - pact-core/Pact/Core/Repl/Command.hs | 1 + pact-core/Pact/Core/Repl/Types.hs | 21 +++++++++++---------- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/pact-core/Pact/Core/Repl.hs b/pact-core/Pact/Core/Repl.hs index 1210af8a3..a2593b04b 100644 --- a/pact-core/Pact/Core/Repl.hs +++ b/pact-core/Pact/Core/Repl.hs @@ -76,7 +76,6 @@ main = do Just input -> case parseReplActionText (T.strip input) of Nothing -> do outputStrLn "Error: Expected supported command or expression. See :help for more information." - outputStrLn $ show $ parseReplActionText input loop Just ra -> case ra of RALoad txt -> let diff --git a/pact-core/Pact/Core/Repl/Command.hs b/pact-core/Pact/Core/Repl/Command.hs index ea1bd601c..82e7aa456 100644 --- a/pact-core/Pact/Core/Repl/Command.hs +++ b/pact-core/Pact/Core/Repl/Command.hs @@ -87,6 +87,7 @@ helpCommand = outputStrLn $ List.intercalate "\n" , " tc-type show inferred type information" , " specializer show specializer phase information" , " untyped-core show untyped core phase information" + , "" ] diff --git a/pact-core/Pact/Core/Repl/Types.hs b/pact-core/Pact/Core/Repl/Types.hs index 496dd8ad2..191e657e2 100644 --- a/pact-core/Pact/Core/Repl/Types.hs +++ b/pact-core/Pact/Core/Repl/Types.hs @@ -201,19 +201,20 @@ parseReplAction = where execute = RAExecuteExpr <$> MP.takeRest - cmdKw kw = MP.chunk kw *> MP.space1 cmd = do _ <- MP.char ':' - load <|> setFlag <|> showHelp - showHelp = pure RAShowHelp - setFlag = - cmdKw "debug" *> (RASetDebugFlag <$> parseReplDebugUpdate) - - -- tc = do - -- cmdKw "type" - -- RATypecheck <$> MP.takeRest + load <|> setDebugFlag <|> showHelp + + cmdKwWithArg kw = MP.chunk kw *> MP.space1 + + showHelp = + RAShowHelp <$ MP.chunk "help" + + setDebugFlag = + cmdKwWithArg "debug" *> (RASetDebugFlag <$> parseReplDebugUpdate) + load = do - cmdKw "load" + cmdKwWithArg "load" let c = MP.char '\"' RALoad <$> MP.between c c (MP.takeWhile1P Nothing (/= '\"'))