From 12b9f5bed42830776a3d47d3701ec6f92189c8ee Mon Sep 17 00:00:00 2001 From: Jonathan Coates Date: Tue, 29 Oct 2019 22:05:19 +0000 Subject: [PATCH 1/4] Initial prototype of cache invalidation in the REPL Doesn't support minor updates (ticks) yet, but it's a good enough start. In need of a lot of testing. --- amuletml.cabal | 2 + bin/Amc/Repl.hs | 6 +- src/Frontend/Driver.hs | 167 ++++++++++++++++++++++++++++++----------- 3 files changed, 130 insertions(+), 45 deletions(-) diff --git a/amuletml.cabal b/amuletml.cabal index cf332eace..f417cbfbe 100644 --- a/amuletml.cabal +++ b/amuletml.cabal @@ -176,11 +176,13 @@ library , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.4 , directory >= 1.3 && < 1.4 + , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.7 , these-lens >= 1 && < 1.1 , transformers >= 0.5 && < 0.6 , monad-chronicle >= 1 && < 1.1 , template-haskell >= 2.13 && < 2.16 + , cryptohash-sha256 >= 0.11 && < 0.12 , annotated-wl-pprint >= 0.7 && < 0.8 , unordered-containers >= 0.2 && < 0.3 , logict >= 0.7 && < 0.8 diff --git a/bin/Amc/Repl.hs b/bin/Amc/Repl.hs index 2be964e24..bc6284ea5 100644 --- a/bin/Amc/Repl.hs +++ b/bin/Amc/Repl.hs @@ -438,9 +438,13 @@ loadFile file = do -- Reset the state config <- gets config handle <- gets outputHandle + driver <- gets driver state' <- liftIO (defaultState config) put state' { currentFile = Just file - , outputHandle = handle } + , outputHandle = handle + , driver = driver } + + wrapDriver D.tock -- FIXME: This is a little broken, in that if the prelude and the -- loaded file both require the same code, we will execute it diff --git a/src/Frontend/Driver.hs b/src/Frontend/Driver.hs index b930e7b00..d82ca08d9 100644 --- a/src/Frontend/Driver.hs +++ b/src/Frontend/Driver.hs @@ -26,6 +26,9 @@ module Frontend.Driver , fileMap , getConfig, adjustConfig + -- * Cache invalidation + , tick, tock + -- * REPL interaction -- -- $repl @@ -56,9 +59,11 @@ import Control.Monad.Namey import Control.Applicative import Control.Lens hiding ((<.>)) +import qualified Data.Text.Lazy.Encoding as L +import qualified Data.ByteString.Lazy as BSL import qualified Data.List.NonEmpty as E import qualified Data.Map.Strict as Map -import qualified Data.Text.Lazy.IO as L +import qualified Data.ByteString as BS import qualified Data.Sequence as Seq import qualified Data.Text.IO as T import qualified Data.Text as T @@ -71,6 +76,8 @@ import Data.Maybe import Data.These import Data.Span +import qualified Crypto.Hash.SHA256 as SHA + import Core.Core (Stmt) import Core.Var (CoVar) import Core.Lower (LowerState, runLowerWithEnv, lowerProgEnv, defaultState) @@ -94,6 +101,8 @@ import Frontend.Errors import Text.Pretty.Note +import Debug.Trace + -- | The stage a file is at. Files are parsed, resolved, type checked, -- verified, and then lowered. -- @@ -108,6 +117,7 @@ data Stage = SParsed { _pBody :: [Toplevel Parsed] } | SUnparsed + | SResolving | SResolved { _rBody :: [Toplevel Resolved], sig :: Signature } | SUnresolved @@ -120,10 +130,24 @@ data Stage | SEmitted { _cBody :: [Stmt CoVar], sig :: Signature, env :: Env, _lowerState :: LowerState } deriving Show +-- | A clock, composed of a major 'cTock' counter and a minor 'cTick' counter. +-- +-- Ticks represent a "minor" change to the cache, which does not require +-- us to update the executable state. Any file which has not yet been +-- emitted may be reloaded at this point. +-- +-- Tocks are used for a major change, where we will dispose of the whole +-- executable state. Any module may be reloaded at this point. +data Clock = Clock { cTock :: Int, cTick :: Int } + deriving (Show, Eq, Ord) + data LoadedFile = LoadedFile { fileLocation :: FilePath - , fileSource :: SourceName - , fileVar :: Name + , fileSource :: SourceName + , fileVar :: Name + + , fileHash :: BS.ByteString + , fileClock :: Clock -- | Files upon which this one depends. , _dependencies :: Set.Set FilePath @@ -145,8 +169,8 @@ newtype DriverConfig = DriverConfig data Driver = Driver { -- | All loaded files. _files :: Map.Map FilePath LoadedFile - -- | A mapping of pretty source paths, to cannonical file names. - , _filePaths :: Map.Map SourceName FilePath + -- | The current clock of the loader. + , _clock :: Clock -- | The driver's current config , _config :: DriverConfig } deriving Show @@ -156,11 +180,11 @@ makeLenses ''Driver -- | Construct a new driver from the given config. makeDriverWith :: DriverConfig -> Driver -makeDriverWith = Driver mempty mempty +makeDriverWith = Driver mempty (Clock 0 0) -- | Construct a new driver using 'makeConfig'. makeDriver :: IO Driver -makeDriver = Driver mempty mempty <$> makeConfig +makeDriver = Driver mempty (Clock 0 0) <$> makeConfig -- | The default driver config. -- @@ -205,6 +229,19 @@ getConfig = _config adjustConfig :: MonadState Driver m => (DriverConfig -> DriverConfig) -> m () adjustConfig = (config%=) +-- | Update the drivers's internal counter, allowing to reload any +-- non-emitted files. +tick :: MonadState Driver m => m () +tick = clock %= \(Clock to ti) -> Clock to (ti + 1) + +-- | Update the driver's internal counter, allowing it to reload any +-- emitted file. +-- +-- This should only be used in conjunction with resetting your execution +-- state (such as a Lua environment). +tock :: MonadState Driver m => m () +tock = clock %= \(Clock to _) -> Clock (to + 1) 0 + {- $repl These functions provide a way of loading an external expression, @@ -360,45 +397,86 @@ verifyProg v env inferred = occurred in the process of loading this file. -} -addFile :: (MonadNamey m, MonadState Driver m, MonadIO m) +-- | Get a file, reloading from disk if the cache state has changed. +getFile :: forall m. (MonadNamey m, MonadState Driver m, MonadIO m) => FilePath -> m LoadedFile -addFile path = do - name <- liftIO $ makeRelativeToCurrentDirectory path - var <- genNameFrom (T.pack ("\"" ++ name ++ "\"")) - contents <- liftIO $ L.readFile path - let (parsed, es) = runParser name contents parseTops - let file = LoadedFile - { fileLocation = path - , fileSource = name - , fileVar = var - - , _dependencies = mempty - , _dependent = Nothing - - , _stage = maybe SUnparsed SParsed parsed - - , _errors = mempty & parseErrors .~ es - } - - filePaths %= Map.insert name path - files %= Map.insert path file - - pure file +getFile = fmap (fst . fromJust) . reloadFile where + -- | Get or reload a file, returning it and whether it changed. + reloadFile :: FilePath -> m (Maybe (LoadedFile, Bool)) + reloadFile path = do + file <- use (files . at path) + clock <- use clock + case file of + Nothing -> do + contents <- read path + case contents of + Nothing -> pure Nothing + Just (sha, contents) -> do + -- File isn't in cache: add it. + name <- liftIO $ makeRelativeToCurrentDirectory path + var <- genNameFrom (T.pack ("\"" ++ name ++ "\"")) + Just . (,True) <$> addFile path name var sha contents + + Just file + | fileClock file == clock -> pure (Just (file, False)) + | otherwise -> do + contents <- read path + case contents of + Nothing -> + -- Remove file from cache if it doesn't exist on disk + (files %= Map.delete path) $> Nothing + Just (sha, contents) + | sha /= fileHash file -> + -- If it's been updated on disk, just reload it immediately. + Just . (,True) <$> addFile path (fileSource file) (fileVar file) sha contents + | otherwise -> do + -- Otherwise check each dependency. + Any changed <- foldMapM (fmap (Any . maybe True snd) . reloadFile) (file ^. dependencies) + if changed + then Just . (,True) <$> addFile path (fileSource file) (fileVar file) sha contents + else pure (Just (file, False)) + + read :: FilePath -> m (Maybe (BS.ByteString, BSL.ByteString)) + read path = do + exists <- liftIO $ doesFileExist path + if not exists then pure Nothing else do + contents <- liftIO $ BSL.readFile path + pure (Just (SHA.hashlazy contents, contents)) + + addFile :: FilePath -> String -> Name -> BS.ByteString -> BSL.ByteString -> m LoadedFile + addFile path name var hash contents = do + clock <- use clock + let (parsed, es) = runParser name (L.decodeUtf8 contents) parseTops + let file = LoadedFile + { fileLocation = path + , fileSource = name + , fileVar = var + + , fileHash = hash + , fileClock = clock + + , _dependencies = mempty + , _dependent = Nothing + + , _stage = maybe SUnparsed SParsed parsed + + , _errors = mempty & parseErrors .~ es + } + + files %= Map.insert path file + + pure file -- | Get or compute a file's signature. getSignature :: (MonadNamey m, MonadState Driver m, MonadIO m) => FilePath -> m (Maybe Signature) getSignature path = do - file <- use (files . at path) - file <- case file of - Nothing -> do - exists <- liftIO $ doesFileExist path - if exists then Just <$> addFile path else pure Nothing - Just file -> pure (Just file) - - case maybe SUnparsed (^. stage) file of + file <- getFile path + case file ^. stage of SUnparsed -> pure Nothing SParsed parsed -> do + updateFile path $ stage .~ SResolving + traceM ("Resolving " ++ path) (resolved, deps) <- flip runFileImport (LoadContext (dropFileName path) (Just path)) $ resolveProgram builtinResolve parsed @@ -426,6 +504,7 @@ getTypeEnv path = do SUnresolved{} -> pure Nothing SUntyped{} -> pure Nothing + SResolving{} -> error "Impossible SResolving - should have been resolved." SResolved { _rBody = rBody, sig } -> do let ~(Just file') = file AllOf env <- foldMapM (fmap AllOf . getTypeEnv) (file' ^. dependencies) @@ -483,6 +562,7 @@ getVerified path = do SUntyped{} -> pure False SUnresolved{} -> pure False + SResolving{} -> error "Impossible SResolving - should have been resolved." SResolved{} -> error "Impossible SResolved - should have been typed." -- Already done @@ -613,22 +693,21 @@ importFile :: (MonadNamey m, MonadState Driver m, MonadIO m) importFile fromPath fromLoc path = do file <- use (files . at path) case file of - Just file -> do + Just{} -> do + file <- getFile path case file ^. stage of - SUnresolved -> pure Errored - SUnparsed -> pure Errored - SParsed _ -> do + SResolving -> do state <- get let ~(Just loc) = fromLoc fromFile = flip Map.lookup (state ^. files) =<< fromPath pure (ImportCycle ((fileSource file, loc) E.:| foldMap (`findCycle` state) fromFile)) - stage -> pure (Imported (fileVar file) (sig stage)) + _ -> maybe Errored (Imported (fileVar file)) <$> getSignature path Nothing -> do exists <- liftIO $ doesFileExist path if not exists then pure NotFound else do - file <- addFile path + file <- getFile path updateFile path $ dependent .~ ((,) <$> fromPath <*> fromLoc) maybe Errored (Imported (fileVar file)) <$> getSignature path From 1628d5115fc08895d111f93f55dc0b2fad9efa8f Mon Sep 17 00:00:00 2001 From: Jonathan Coates Date: Wed, 30 Oct 2019 09:26:49 +0000 Subject: [PATCH 2/4] Allow reloading unemitted files on minor ticks Most importantly, this allows us to reattempt compilation of erroring files on each new REPL input, which makes the workflow much easier. --- bin/Amc/Repl.hs | 13 +++++++----- src/Frontend/Driver.hs | 45 ++++++++++++++++++++++-------------------- 2 files changed, 32 insertions(+), 26 deletions(-) diff --git a/bin/Amc/Repl.hs b/bin/Amc/Repl.hs index bc6284ea5..3f761dcf7 100644 --- a/bin/Amc/Repl.hs +++ b/bin/Amc/Repl.hs @@ -266,7 +266,9 @@ typeCommand (dropWhile isSpace -> input) = do prog :: [S.Toplevel S.Parsed] prog = [ S.LetStmt S.Public [ S.Matching (S.Wildcard ann) parsed ann ] ] - (infer, es) <- wrapDriver $ D.inferWith (root (config state)) prog (resolveScope state) (inferScope state) + (infer, es) <- wrapDriver $ do + D.tick + D.inferWith (root (config state)) prog (resolveScope state) (inferScope state) hReportAll (outputHandle state) files es case infer of Nothing -> pure () @@ -284,7 +286,7 @@ compileCommand (dropWhile isSpace -> path) = do case current of Just file -> do in_p <- liftIO $ canonicalizePath file - (core, errors) <- wrapDriver (D.compile in_p) + (core, errors) <- wrapDriver $ D.tick >> D.compile in_p handle <- liftIO $ openFile path WriteMode case core of @@ -402,8 +404,9 @@ parseCore parser name input = do Left s -> s Right e -> [S.LetStmt S.Public [S.Binding (S.Name "_") e True (annotation e)]] - (lower, es) <- wrapDriver $ D.lowerWith (root (config state)) parsed' - (resolveScope state) (inferScope state) (lowerState state) + (lower, es) <- wrapDriver $ do + D.tick + D.lowerWith (root (config state)) parsed' (resolveScope state) (inferScope state) (lowerState state) driver_files <- D.fileMap =<< gets driver hReportAll (outputHandle state) (files ++ driver_files) es case lower of @@ -485,7 +488,7 @@ runRemoteReplCommand port command = Net.withSocketsDo $ do loadFileImpl :: (MonadState ReplState m, MonadIO m) => FilePath -> m Bool loadFileImpl path = do - (core, es) <- wrapDriver $ D.compile path + (core, es) <- wrapDriver $ D.tick >> D.compile path files <- D.fileMap =<< gets driver handle <- gets outputHandle diff --git a/src/Frontend/Driver.hs b/src/Frontend/Driver.hs index d82ca08d9..c28254829 100644 --- a/src/Frontend/Driver.hs +++ b/src/Frontend/Driver.hs @@ -101,8 +101,6 @@ import Frontend.Errors import Text.Pretty.Note -import Debug.Trace - -- | The stage a file is at. Files are parsed, resolved, type checked, -- verified, and then lowered. -- @@ -147,7 +145,7 @@ data LoadedFile = LoadedFile , fileVar :: Name , fileHash :: BS.ByteString - , fileClock :: Clock + , _fileClock :: Clock -- | Files upon which this one depends. , _dependencies :: Set.Set FilePath @@ -399,8 +397,8 @@ verifyProg v env inferred = -- | Get a file, reloading from disk if the cache state has changed. getFile :: forall m. (MonadNamey m, MonadState Driver m, MonadIO m) - => FilePath -> m LoadedFile -getFile = fmap (fst . fromJust) . reloadFile where + => FilePath -> m (Maybe LoadedFile) +getFile = fmap (fmap fst) . reloadFile where -- | Get or reload a file, returning it and whether it changed. reloadFile :: FilePath -> m (Maybe (LoadedFile, Bool)) reloadFile path = do @@ -418,7 +416,15 @@ getFile = fmap (fst . fromJust) . reloadFile where Just . (,True) <$> addFile path name var sha contents Just file - | fileClock file == clock -> pure (Just (file, False)) + | file ^. fileClock == clock -> pure (Just (file, False)) + + | SEmitted{} <- file ^. stage + , cTock (file ^. fileClock) == cTock clock -> + -- If we've emitted the file, and we're on the same major tick, then + -- it's not safe to recompile - we don't want to break any REPL + -- state. So just update the clock. + updateFile path (fileClock .~ clock) $> (Just (file, False)) + | otherwise -> do contents <- read path case contents of @@ -430,7 +436,9 @@ getFile = fmap (fst . fromJust) . reloadFile where -- If it's been updated on disk, just reload it immediately. Just . (,True) <$> addFile path (fileSource file) (fileVar file) sha contents | otherwise -> do - -- Otherwise check each dependency. + -- Otherwise check each dependency. We update the clock + -- beforehand, to avoid getting into any dependency loops. + updateFile path (fileClock .~ clock) Any changed <- foldMapM (fmap (Any . maybe True snd) . reloadFile) (file ^. dependencies) if changed then Just . (,True) <$> addFile path (fileSource file) (fileVar file) sha contents @@ -453,7 +461,7 @@ getFile = fmap (fst . fromJust) . reloadFile where , fileVar = var , fileHash = hash - , fileClock = clock + , _fileClock = clock , _dependencies = mempty , _dependent = Nothing @@ -471,12 +479,11 @@ getFile = fmap (fst . fromJust) . reloadFile where getSignature :: (MonadNamey m, MonadState Driver m, MonadIO m) => FilePath -> m (Maybe Signature) getSignature path = do - file <- getFile path + file <- fromMaybe (error ("Cannot find " ++ show path)) <$> getFile path case file ^. stage of SUnparsed -> pure Nothing SParsed parsed -> do updateFile path $ stage .~ SResolving - traceM ("Resolving " ++ path) (resolved, deps) <- flip runFileImport (LoadContext (dropFileName path) (Just path)) $ resolveProgram builtinResolve parsed @@ -691,10 +698,10 @@ instance (MonadNamey m, MonadState Driver m, MonadIO m) => MonadImport (FileImpo importFile :: (MonadNamey m, MonadState Driver m, MonadIO m) => Maybe FilePath -> Maybe Span -> FilePath -> m ImportResult importFile fromPath fromLoc path = do - file <- use (files . at path) + file <- getFile path case file of - Just{} -> do - file <- getFile path + Nothing -> pure NotFound + Just file -> do case file ^. stage of SResolving -> do state <- get @@ -702,14 +709,10 @@ importFile fromPath fromLoc path = do fromFile = flip Map.lookup (state ^. files) =<< fromPath pure (ImportCycle ((fileSource file, loc) E.:| foldMap (`findCycle` state) fromFile)) - _ -> maybe Errored (Imported (fileVar file)) <$> getSignature path + _ -> do + updateFile path $ dependent %~ (<|> ((,) <$> fromPath <*> fromLoc)) + maybe Errored (Imported (fileVar file)) <$> getSignature path - Nothing -> do - exists <- liftIO $ doesFileExist path - if not exists then pure NotFound else do - file <- getFile path - updateFile path $ dependent .~ ((,) <$> fromPath <*> fromLoc) - maybe Errored (Imported (fileVar file)) <$> getSignature path -- | Find the first file which matches a list. findFile' :: [FilePath] -> IO (Maybe FilePath) @@ -721,7 +724,7 @@ findFile' (x:xs) = do -- | Try to identify the cycle of files requiring each other. findCycle :: LoadedFile -> Driver -> [(FilePath, Span)] -findCycle (LoadedFile { fileSource, _stage = SParsed _, _dependent = Just (from, loc) }) st = +findCycle (LoadedFile { fileSource, _stage = SResolving, _dependent = Just (from, loc) }) st = (fileSource, loc) : findCycle (fromJust (Map.lookup from (st ^. files))) st findCycle _ _ = [] From f9aa56608cb3f1d2e1bb24a01fe353e696831f35 Mon Sep 17 00:00:00 2001 From: Jonathan Coates Date: Wed, 30 Oct 2019 12:54:36 +0000 Subject: [PATCH 3/4] Various caching/reloading bug fixes - Make Driver.compile take a list of files to compile instead, and use that for loading files within the REPL. This prevents us from running the prelude twice. - Be more selective in what driver state we reset - make resetting opt-in rather than opt out. This fixes several issues with fresh name generation. --- bin/Amc.hs | 2 +- bin/Amc/Repl.hs | 102 +++++++++++++++++++---------------------- src/Frontend/Driver.hs | 27 +++++------ 3 files changed, 63 insertions(+), 68 deletions(-) diff --git a/bin/Amc.hs b/bin/Amc.hs index 2295e1faf..d9fbb85f9 100644 --- a/bin/Amc.hs +++ b/bin/Amc.hs @@ -53,7 +53,7 @@ runCompile opt (DoLint lint) dconfig file = do flip runNameyT firstName . flip runStateT (D.makeDriverWith dconfig) $ do - (core, errors) <- D.compile path + (core, errors) <- D.compiles path ~(Just env) <- D.getTypeEnv path pure (env, core, errors) diff --git a/bin/Amc/Repl.hs b/bin/Amc/Repl.hs index 3f761dcf7..24a8b2d3d 100644 --- a/bin/Amc/Repl.hs +++ b/bin/Amc/Repl.hs @@ -119,11 +119,10 @@ defaultState config = do { resolveScope = Bi.builtinResolve , inferScope = Bi.builtinEnv , emitState = B.defaultEmitState - , lastName = S.TgName (T.pack "a") 1 , lowerState = L.defaultState - , luaState = state + , lastName = S.TgName (T.pack "a") 1 , driver = D.makeDriverWith (driverConfig config) , config = config @@ -131,6 +130,18 @@ defaultState config = do , outputHandle = stdout } +resetState :: ReplState -> IO ReplState +resetState state = do + lState <- L.newstate + L.runWith lState L.openlibs + pure state + { resolveScope = Bi.builtinResolve + , inferScope = Bi.builtinEnv + , emitState = B.defaultEmitState + , lowerState = L.defaultState + , luaState = lState + } + type Listener = Maybe ThreadId runRepl :: Listener -> InputT (StateT ReplState IO) () @@ -212,15 +223,11 @@ parseArgs xs = loadCommand :: (MonadState ReplState m, MonadIO m) => String -> m () loadCommand arg = case parseArgs arg of - [file] -> loadFile file + [file] -> loadFile (Just file) _ -> outputDoc "Usage `:load [file]`" reloadCommand :: (MonadState ReplState m, MonadIO m) => m () -reloadCommand = do - file <- gets currentFile - case file of - Nothing -> outputDoc "No module to reload" - Just file -> loadFile file +reloadCommand = loadFile =<< gets currentFile infoCommand :: (MonadState ReplState m, MonadIO m) => String -> m () infoCommand (T.pack . dropWhile isSpace -> input) = do @@ -286,7 +293,7 @@ compileCommand (dropWhile isSpace -> path) = do case current of Just file -> do in_p <- liftIO $ canonicalizePath file - (core, errors) <- wrapDriver $ D.tick >> D.compile in_p + (core, errors) <- wrapDriver $ D.tick >> D.compiles in_p handle <- liftIO $ openFile path WriteMode case core of @@ -436,34 +443,25 @@ emitCore core = do pure (luaExpr, luaSyntax) -- | Reset the environment and load a series of files from environment -loadFile :: (MonadState ReplState m, MonadIO m) => FilePath -> m () +loadFile :: (MonadState ReplState m, MonadIO m) => Maybe FilePath -> m () loadFile file = do -- Reset the state - config <- gets config - handle <- gets outputHandle - driver <- gets driver - state' <- liftIO (defaultState config) - put state' { currentFile = Just file - , outputHandle = handle - , driver = driver } - + put =<< (liftIO . resetState) =<< get + modify (\s -> s { currentFile = file }) wrapDriver D.tock - -- FIXME: This is a little broken, in that if the prelude and the - -- loaded file both require the same code, we will execute it - -- twice. Ideally we should probably have a 'loadFilsImpl', which loads - -- 1..n files, and correctly handles stitching them together. - _ <- setupPrelude - - -- Load each file in turn - path <- liftIO $ canonicalizePath file - exists <- liftIO $ doesFileExist path - if not exists - then outputDoc ("Cannot open" <+> verbatim file) - else do - outputDoc $ "Loading:" <+> verbatim file - loadFileImpl path $> () + -- Determine whether to load the prelude and an additional file. + prelude <- gets (toList . prelude . config) + load <- case file of + Nothing -> pure [] + Just file -> do + path <- liftIO $ canonicalizePath file + exists <- liftIO $ doesFileExist path + if exists + then outputDoc ("Loading:" <+> verbatim file) $> [path] + else outputDoc ("Cannot open" <+> verbatim file) $> [] + loadFiles (prelude ++ load) $> () outputDoc :: (MonadState ReplState m, MonadIO m) => Doc -> m () outputDoc x = do @@ -486,9 +484,10 @@ runRemoteReplCommand port command = Net.withSocketsDo $ do Left (_ :: SomeException) -> putStrLn $ "Failed to connect to server on port " ++ show port -loadFileImpl :: (MonadState ReplState m, MonadIO m) => FilePath -> m Bool -loadFileImpl path = do - (core, es) <- wrapDriver $ D.tick >> D.compile path +loadFiles :: (MonadState ReplState m, MonadIO m) => [FilePath] -> m Bool +loadFiles [] = pure True +loadFiles paths = do + (core, es) <- wrapDriver $ D.tick >> D.compile paths files <- D.fileMap =<< gets driver handle <- gets outputHandle @@ -496,25 +495,27 @@ loadFileImpl path = do case core of Nothing -> pure False Just core -> do - (sig, env, lEnv) <- wrapDriver $ do - ~(Just sig) <- D.getSignature path - ~(Just env) <- D.getOpenedTypeEnv path - ~(Just lEnv) <- D.getLowerState path - pure (sig, env, lEnv) - - modify (\s -> s { resolveScope = resolveScope s <> sig - , inferScope = inferScope s <> env - , lowerState = lowerState s <> lEnv }) + oldEnv <- gets inferScope + for_ paths $ \path -> do + (sig, env, lEnv) <- wrapDriver $ do + ~(Just sig) <- D.getSignature path + ~(Just env) <- D.getOpenedTypeEnv path + ~(Just lEnv) <- D.getLowerState path + pure (sig, env, lEnv) + + modify (\s -> s { resolveScope = resolveScope s <> sig + , inferScope = inferScope s <> env + , lowerState = lowerState s <> lEnv }) + newEnv <- gets inferScope (luaExpr, luaSyntax) <- emitCore core luaState <- gets luaState debug <- gets (debugMode . config) liftIO $ do - dump debug [] core core luaExpr Bi.builtinEnv env + dump debug [] core core luaExpr oldEnv newEnv res <- L.runWith luaState $ do code <- L.dostring luaSyntax - case code of L.OK -> pure (Right ()) _ -> do @@ -528,19 +529,12 @@ loadFileImpl path = do Left err -> hPutDoc handle err >> pure False Right () -> pure True -setupPrelude :: (MonadState ReplState m, MonadIO m) => m Bool -setupPrelude = do - prelude <- gets (prelude . config) - case prelude of - Nothing -> pure True - Just prelude -> loadFileImpl prelude - repl :: ReplConfig -> IO () repl config = replFrom config Nothing replFrom :: ReplConfig -> Maybe FilePath -> IO () replFrom config file = do - state <- execStateT (maybe (setupPrelude $> ()) loadFile file) =<< defaultState config + state <- execStateT (loadFile file) =<< defaultState config hSetBuffering stdout LineBuffering ready <- newEmptyMVar diff --git a/src/Frontend/Driver.hs b/src/Frontend/Driver.hs index c28254829..16575dc84 100644 --- a/src/Frontend/Driver.hs +++ b/src/Frontend/Driver.hs @@ -40,7 +40,7 @@ module Frontend.Driver -- * Compilation -- -- $compile - , compile + , compile, compiles -- * Querying the driver -- @@ -346,13 +346,20 @@ lowerWith root parsed sig env lState = do Various helper functions for compiling a whole bundle of files. -} --- | Attempt to compile a single file. Returns the concatenated core of --- all files. +-- | Attempt to compile a single of file. Returns the concatenated core +-- of all files. +compiles :: (MonadNamey m, MonadIO m, MonadState Driver m) + => FilePath -> m (Maybe [Stmt CoVar], ErrorBundle) +compiles = compile . pure + +-- | Attempt to compile a collection of files. Returns the concatenated +-- core of all files. compile :: (MonadNamey m, MonadIO m, MonadState Driver m) - => FilePath -> m (Maybe [Stmt CoVar], ErrorBundle) -compile path = do - l <- fmap (concat . fmap fst) . sequence <$> gatherDeps getLowered path - errors <- fold <$> gatherDeps getErrors path + => [FilePath] -> m (Maybe [Stmt CoVar], ErrorBundle) +compile ps = do + let paths = Set.fromList ps + l <- fmap (concat . fmap fst) . sequence <$> gatherDepsOf getLowered paths + errors <- fold <$> gatherDepsOf getErrors paths pure (l, errors) errorsFromDeps :: (MonadNamey m, MonadState Driver m) @@ -374,12 +381,6 @@ gatherDepsOf f = fmap snd . foldlM go mempty where (visited, seq) <- foldlM go (Set.insert path visited, seq) deps pure (visited, seq Seq.|> this) --- | Walk over all nodes in dependency order. Effectively a preorder traversal. -gatherDeps :: (MonadNamey m, MonadState Driver m) - => (FilePath -> m a) - -> FilePath -> m (Seq.Seq a) -gatherDeps f = gatherDepsOf f . Set.singleton - verifyProg :: Name -> Env -> [Toplevel Typed] -> (Bool, ErrorBundle) verifyProg v env inferred = let (ok, es) = runVerify env v (verifyProgram inferred) From b2a3579b52a8159cca56cbe5836eab5039637f94 Mon Sep 17 00:00:00 2001 From: Jonathan Coates Date: Wed, 30 Oct 2019 13:04:20 +0000 Subject: [PATCH 4/4] Fix Driver call in GenExample Note to self: don't just compile within the REPL --- bin/GenExample.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bin/GenExample.hs b/bin/GenExample.hs index 438a0fbd2..f5ecabb5a 100644 --- a/bin/GenExample.hs +++ b/bin/GenExample.hs @@ -31,7 +31,7 @@ main = do (((core, errors), driver), _) <- flip runNameyT firstName . flip runStateT driver - $ compile file + $ compiles file x <- T.readFile file