diff --git a/saw/SAWScript/REPL/Command.hs b/saw/SAWScript/REPL/Command.hs index c5cbdd9ed2..227de3f641 100644 --- a/saw/SAWScript/REPL/Command.hs +++ b/saw/SAWScript/REPL/Command.hs @@ -228,9 +228,8 @@ sawScriptCmd str = do Left err -> io $ print err Right stmt -> do ro <- getTopLevelRO - ie <- getEnvironment - ((), ie') <- io $ runTopLevel (interpretStmt True stmt) ro ie - putEnvironment ie' + rwRef <- getEnvironmentRef + io $ runTopLevel (interpretStmt True stmt) ro rwRef replFileName :: String replFileName = "" diff --git a/saw/SAWScript/REPL/Monad.hs b/saw/SAWScript/REPL/Monad.hs index b2e6d02ba8..6d24cde547 100644 --- a/saw/SAWScript/REPL/Monad.hs +++ b/saw/SAWScript/REPL/Monad.hs @@ -38,12 +38,12 @@ module SAWScript.REPL.Monad ( , getTermEnv, modifyTermEnv, setTermEnv , getExtraTypes, modifyExtraTypes, setExtraTypes , getExtraNames, modifyExtraNames, setExtraNames - , getRW -- ** SAWScript stuff , getSharedContext , getTopLevelRO , getEnvironment, modifyEnvironment, putEnvironment + , getEnvironmentRef , getSAWScriptNames ) where @@ -96,50 +96,53 @@ deriving instance Typeable AIG.Proxy -- REPL Environment ------------------------------------------------------------ --- REPL RW Environment. -data RW = RW - { eContinue :: Bool - , eIsBatch :: Bool - , eTopLevelRO :: TopLevelRO - , environment :: TopLevelRW +-- REPL Environment. +data Refs = Refs + { eContinue :: IORef Bool + , eIsBatch :: IORef Bool + , eTopLevelRO :: IORef TopLevelRO + , environment :: IORef TopLevelRW } -- | Initial, empty environment. -defaultRW :: Bool -> Options -> IO RW -defaultRW isBatch opts = do +defaultRefs :: Bool -> Options -> IO Refs +defaultRefs isBatch opts = #ifdef USE_BUILTIN_ABC - (_biContext, ro, rw) <- buildTopLevelEnv (AIGProxy GIA.proxy) opts + do (_biContext, ro, rw) <- buildTopLevelEnv (AIGProxy GIA.proxy) opts #else - (_biContext, ro, rw) <- buildTopLevelEnv (AIGProxy AIG.basicProxy) opts + do (_biContext, ro, rw) <- buildTopLevelEnv (AIGProxy AIG.basicProxy) opts #endif - - return RW - { eContinue = True - , eIsBatch = isBatch - , eTopLevelRO = ro - , environment = rw - } + contRef <- newIORef True + batchRef <- newIORef isBatch + roRef <- newIORef ro + rwRef <- newIORef rw + return Refs + { eContinue = contRef + , eIsBatch = batchRef + , eTopLevelRO = roRef + , environment = rwRef + } -- | Build up the prompt for the REPL. -mkPrompt :: RW -> String -mkPrompt rw - | eIsBatch rw = "" - | otherwise = "sawscript> " +mkPrompt :: Bool {- ^ is batch -} -> String +mkPrompt batch + | batch = "" + | otherwise = "sawscript> " -mkTitle :: RW -> String -mkTitle _rw = "sawscript" +mkTitle :: Refs -> String +mkTitle _refs = "sawscript" -- REPL Monad ------------------------------------------------------------------ -- | REPL_ context with InputT handling. -newtype REPL a = REPL { unREPL :: IORef RW -> IO a } +newtype REPL a = REPL { unREPL :: Refs -> IO a } -- | Run a REPL action with a fresh environment. runREPL :: Bool -> Options -> REPL a -> IO a -runREPL isBatch opts m = do - ref <- newIORef =<< defaultRW isBatch opts - unREPL m ref +runREPL isBatch opts m = + do refs <- defaultRefs isBatch opts + unREPL m refs instance Functor REPL where {-# INLINE fmap #-} @@ -247,31 +250,35 @@ rethrowEvalError m = run `X.catch` rethrow io :: IO a -> REPL a io m = REPL (\ _ -> m) -getRW :: REPL RW -getRW = REPL readIORef +getRefs :: REPL Refs +getRefs = REPL pure + +readRef :: (Refs -> IORef a) -> REPL a +readRef r = REPL (\refs -> readIORef (r refs)) -modifyRW_ :: (RW -> RW) -> REPL () -modifyRW_ f = REPL (\ ref -> modifyIORef ref f) +modifyRef :: (Refs -> IORef a) -> (a -> a) -> REPL () +modifyRef r f = REPL (\refs -> modifyIORef (r refs) f) -- | Construct the prompt for the current environment. getPrompt :: REPL String -getPrompt = mkPrompt `fmap` getRW +getPrompt = mkPrompt <$> readRef eIsBatch shouldContinue :: REPL Bool -shouldContinue = eContinue `fmap` getRW +shouldContinue = readRef eContinue stop :: REPL () -stop = modifyRW_ (\ rw -> rw { eContinue = False }) +stop = modifyRef eContinue (const False) unlessBatch :: REPL () -> REPL () -unlessBatch body = do - rw <- getRW - unless (eIsBatch rw) body +unlessBatch body = + do batch <- readRef eIsBatch + unless batch body setREPLTitle :: REPL () -setREPLTitle = unlessBatch $ do - rw <- getRW - io (setTitle (mkTitle rw)) +setREPLTitle = + unlessBatch $ + do refs <- getRefs + io (setTitle (mkTitle refs)) getVars :: REPL (Map.Map T.Name M.IfaceDecl) getVars = do @@ -361,17 +368,19 @@ getSharedContext :: REPL SharedContext getSharedContext = fmap roSharedContext getTopLevelRO getTopLevelRO :: REPL TopLevelRO -getTopLevelRO = fmap eTopLevelRO getRW +getTopLevelRO = readRef eTopLevelRO + +getEnvironmentRef :: REPL (IORef TopLevelRW) +getEnvironmentRef = environment <$> getRefs getEnvironment :: REPL TopLevelRW -getEnvironment = fmap environment getRW +getEnvironment = readRef environment putEnvironment :: TopLevelRW -> REPL () putEnvironment = modifyEnvironment . const modifyEnvironment :: (TopLevelRW -> TopLevelRW) -> REPL () -modifyEnvironment f = modifyRW_ $ \current -> - current { environment = f (environment current) } +modifyEnvironment = modifyRef environment -- | Get visible variable names for Haskeline completion. getSAWScriptNames :: REPL [String] diff --git a/src/SAWScript/Builtins.hs b/src/SAWScript/Builtins.hs index ac265ec643..6acbbebf59 100644 --- a/src/SAWScript/Builtins.hs +++ b/src/SAWScript/Builtins.hs @@ -34,6 +34,7 @@ import qualified Data.ByteString as StrictBS import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.UTF8 as B import qualified Data.IntMap as IntMap +import Data.IORef import Data.List (isPrefixOf, isInfixOf) import qualified Data.Map as Map import Data.Set (Set) @@ -1147,7 +1148,8 @@ failsPrim :: TopLevel SV.Value -> TopLevel () failsPrim m = do topRO <- getTopLevelRO topRW <- getTopLevelRW - x <- liftIO $ Ex.try (runTopLevel m topRO topRW) + ref <- liftIO $ newIORef topRW + x <- liftIO $ Ex.try (runTopLevel m topRO ref) case x of Left (ex :: Ex.SomeException) -> do liftIO $ putStrLn "== Anticipated failure message ==" diff --git a/src/SAWScript/Interpreter.hs b/src/SAWScript/Interpreter.hs index 7f631b5a25..f2ddc27088 100644 --- a/src/SAWScript/Interpreter.hs +++ b/src/SAWScript/Interpreter.hs @@ -38,6 +38,7 @@ import Control.Monad (unless, (>=>), when) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as BS import Data.Foldable (foldrM) +import Data.IORef import qualified Data.Map as Map import Data.Map ( Map ) import qualified Data.Set as Set @@ -277,7 +278,9 @@ interpretStmts env stmts = interpretStmts env' ss stmtInterpreter :: StmtInterpreter -stmtInterpreter ro rw stmts = fmap fst $ runTopLevel (interpretStmts emptyLocal stmts) ro rw +stmtInterpreter ro rw stmts = + do ref <- newIORef rw + runTopLevel (interpretStmts emptyLocal stmts) ro ref processStmtBind :: Bool -> SS.Pattern -> Maybe SS.Type -> SS.Expr -> TopLevel () processStmtBind printBinds pat _mc expr = do -- mx mt @@ -490,7 +493,8 @@ processFile proxy opts file = do oldpath <- getCurrentDirectory file' <- canonicalizePath file setCurrentDirectory (takeDirectory file') - _ <- runTopLevel (interpretFile file' True) ro rw + ref <- newIORef rw + _ <- runTopLevel (interpretFile file' True) ro ref `X.catch` (handleException opts) setCurrentDirectory oldpath return () diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs index bb4f1bfd7d..a756639f86 100644 --- a/src/SAWScript/Value.hs +++ b/src/SAWScript/Value.hs @@ -436,12 +436,9 @@ instance Wrapped (TopLevel a) where instance MonadFail TopLevel where fail = throwTopLevel -runTopLevel :: TopLevel a -> TopLevelRO -> TopLevelRW -> IO (a, TopLevelRW) -runTopLevel (TopLevel m) ro rw = - do ref <- newIORef rw - x <- runReaderT (runReaderT m ro) ref - rw' <- readIORef ref - pure (x, rw') +runTopLevel :: TopLevel a -> TopLevelRO -> IORef TopLevelRW -> IO a +runTopLevel (TopLevel m) ro ref = + runReaderT (runReaderT m ro) ref io :: IO a -> TopLevel a io f = liftIO f