WIP: Cache imports

LICENSE

@@ -1,4 +1,4 @@
-Copyright Brent Yorgey and other contributors 2021-2024
+Copyright Brent Yorgey and other contributors 2021-2025
 SPDX-License-Identifier: BSD-3-Clause
 
 All rights reserved.
@@ -29,3 +29,37 @@ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+------------------------------------------------------------
+
+Swarm.Util.InternCache copyright Chris Penner 2025
+SPDX-License-Identifier: BSD-3-Clause
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Chris Penner nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

src/swarm-lang/Swarm/Language/Elaborate.hs

@@ -14,7 +14,7 @@ import Swarm.Language.Syntax
 import Unsafe.Coerce (unsafeCoerce)
 
 elaborateModule :: Module Typed -> Module Elaborated
-elaborateModule (Module t ctx imps) = Module (fmap elaborate t) ctx imps
+elaborateModule (Module t ctx imps time) = Module (fmap elaborate t) ctx imps time
 
 -- | Perform some elaboration / rewriting on a fully type-annotated
 --   term.  This currently performs such operations as rewriting @if@

src/swarm-lang/Swarm/Language/Load.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
@@ -27,6 +29,7 @@ import Data.Set (Set)
 import Data.Set qualified as S
 import Data.Text (Text)
 import Data.Text.Encoding qualified as T
+import Data.Time.Clock
 import GHC.Generics (Generic)
 import Network.HTTP.Simple (getResponseBody, httpBS, parseRequest)
 import Swarm.Failure (Asset (..), AssetData (..), Entry (..), LoadingFailure (..), SystemFailure (..))
@@ -39,8 +42,12 @@ import Swarm.Language.Syntax.Import qualified as Import
 import Swarm.Language.Syntax.Util (Erasable (..))
 import Swarm.Language.Types (TCtx, TDCtx, UCtx)
 import Swarm.Pretty (prettyText)
-import Swarm.Util (Encoding (SystemLocale), readFileMayT, showT)
+import Swarm.Util (Encoding (SystemLocale), getModificationTimeMay, readFileMayT, showT)
 import Swarm.Util.Graph (findCycle)
+import Swarm.Util.InternCache
+import Swarm.Util.InternCache qualified as IC
+import System.Directory (getModificationTime)
+import System.IO.Unsafe (unsafePerformIO)
 import Witch (into)
 
 type ResLoc = ImportLoc Import.Resolved
@@ -76,6 +83,8 @@ data Module phase = Module
   -- ^ The context of names defined in this module and their types.
   , moduleImports :: ModuleImports phase
   -- ^ The moduleImports are mostly for convenience, e.g. for checking modules for cycles.
+  , moduleTimestamp :: Maybe UTCTime
+  -- ^ The time at which the module was loaded
   }
   deriving (Generic)
 
@@ -85,8 +94,8 @@ deriving instance (Eq (Anchor (ImportPhaseFor phase)), Data (Anchor (ImportPhase
 deriving instance (Hashable (ModuleImports phase), Hashable (ModuleCtx phase), Hashable (SwarmType phase), Hashable (Anchor (ImportPhaseFor phase)), Generic (Anchor (ImportPhaseFor phase))) => Hashable (Module phase)
 
 instance Erasable Module where
-  erase (Module t _ _) = Module (erase <$> t) () S.empty
-  eraseRaw (Module t _ _) = Module (eraseRaw <$> t) () ()
+  erase (Module t _ _ time) = Module (erase <$> t) () S.empty time
+  eraseRaw (Module t _ _ time) = Module (eraseRaw <$> t) () () time
 
 -- | A SourceMap associates canonical 'ImportLocation's to modules.
 type SourceMap phase = Map (ImportLoc (ImportPhaseFor phase)) (Module phase)
@@ -141,7 +150,7 @@ eraseSourceMap = M.map erase
 toImportGraph :: SourceMap Resolved -> [(ResLoc, ResLoc, [ResLoc])]
 toImportGraph = map processNode . M.assocs
  where
-  processNode (imp, Module _ _ imps) = (imp, imp, S.toList imps)
+  processNode (imp, m) = (imp, imp, S.toList (moduleImports m))
 
 -- | Check a 'SourceMap' to ensure that it contains no import cycles.
 checkImportCycles ::
@@ -168,11 +177,17 @@ resolveImports ::
   m (Set (ImportLoc Import.Resolved), Syntax Resolved)
 resolveImports parent = runAccum S.empty . traverseSyntax pure (resolveImport parent)
 
+-- | Cache imported modules.
+moduleCache :: (Has (Lift IO) sig m) => InternCache m (ImportLoc Import.Resolved) (Module Resolved)
+moduleCache = unsafePerformIO $ hoist sendIO <$> IC.newInternCache @_ @IO
+{-# NOINLINE moduleCache #-}
+
 -- | Given a parent directory relative to which any local imports
 --   should be interpreted, load an import and all its imports,
 --   transitively.  Also return a canonicalized version of the import
 --   location.
 resolveImport ::
+  forall sig m.
   ( Has (Throw SystemFailure) sig m
   , Has (State (SourceMap Resolved)) sig m
   , Has (Accum (Set (ImportLoc Import.Resolved))) sig m
@@ -186,32 +201,66 @@ resolveImport parent loc = do
   canonicalLoc <- resolveImportLoc (unresolveImportDir parent <//> loc)
   add $ S.singleton canonicalLoc
 
-  srcMap <- get @(SourceMap Resolved)
-  resMod <- case M.lookup canonicalLoc srcMap of
-    Just m -> pure m -- Already loaded - do nothing
-    Nothing -> do
-      -- Record this import loc in the source map using a temporary, empty module,
-      -- to prevent it from attempting to load itself recursively
-      modify @(SourceMap Resolved) (M.insert canonicalLoc $ Module Nothing () mempty)
+  -- Load + check the module, either from the cache if possible or
+  -- from disk/network if necessary.
+  m <- IC.updateCached moduleCache importModule isOutdated canonicalLoc
 
-      -- Read it from network/disk
-      mt <- readLoc canonicalLoc
+  -- Add the module to the SourceMap.
+  modify @(SourceMap Resolved) (M.insert canonicalLoc m)
 
-      -- Recursively resolve any imports it contains
-      mres <- traverse (resolveImports (importDir canonicalLoc)) mt
-      -- sequence :: Maybe (Set a, b) -> (Set a, Maybe b)
-      let (imps, mt') = sequence mres
+  pure canonicalLoc
+ where
+  -- Check whether a cached module is outdated and needs to be reloaded + rechecked.
+  isOutdated :: ImportLoc Import.Resolved -> Module Resolved -> m Bool
+  isOutdated cloc (moduleTimestamp -> mt) = case locToPath cloc of
+    -- URLs are never considered outdated.  There is no consistent way
+    -- to get a "modification time" for a remote file; in any case,
+    -- typically, we expect modules loaded from URLs to change much
+    -- less frequently than those loaded from local files.  If you
+    -- want to pick up a change to a module imported from a URL, you
+    -- can restart the entire app to clear the cache.  (Quitting the
+    -- scenario and restarting may work as well, as long as the cache
+    -- entry gets GC'd.)
+    URL {} -> pure False
+    -- For local files, get the modification time and compare to
+    -- stored timestamp.
+    LocalPath f ->
+      maybe
+        (pure True) -- Modules without a timestamp are always outdated
+        (\t -> (t <) <$> sendIO (getModificationTime f))
+        mt
 
-      -- Finally, record the loaded module in the SourceMap.
-      let m = Module mt' () imps
-      modify @(SourceMap Resolved) (M.insert canonicalLoc m)
+  -- Actually load a module from disk or network and check it.
+  importModule :: ImportLoc Import.Resolved -> m (Module Resolved)
+  importModule cloc =
+    -- Even though we know the module is not in the module cache, we
+    -- still have to look it up in the SourceMap to see if it's
+    -- already there---which can happen if a module transitively
+    -- imports itself.  This prevents getting stuck in infinite
+    -- recursion.
+    M.lookup cloc <$> get @(SourceMap Resolved) >>= \case
+      Just m -> pure m
+      Nothing -> do
+        -- Record this import loc in the source map using a temporary, empty module,
+        -- to prevent it from attempting to load itself recursively
+        modify @(SourceMap Resolved) (M.insert cloc $ Module Nothing () mempty Nothing)
 
-      pure m
+        -- Read it from network/disk
+        (mt, mtime) <- readLoc cloc
 
-  -- Make sure imports are pure, i.e. contain ONLY defs + imports.
-  validateImport canonicalLoc resMod
+        -- Recursively resolve any imports it contains
+        mres <- traverse (resolveImports (importDir cloc)) mt
+        -- sequence :: Maybe (Set a, b) -> (Set a, Maybe b)
+        let (imps, mt') = sequence mres
 
-  pure canonicalLoc
+        -- Build the final checked module.
+        let m = Module mt' () imps mtime
+
+        -- Make sure imports are pure, i.e. contain ONLY defs + imports.
+        validateImport cloc m
+
+        -- Finally, return it.
+        pure m
 
 -- | Validate the source code of the import to ensure that it contains
 --   *only* imports and definitions.  This is so we do not have to worry
@@ -237,28 +286,34 @@ validateImport loc = maybe (pure ()) validate . moduleTerm
 readLoc ::
   (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
   ImportLoc Import.Resolved ->
-  m (Maybe (Syntax Raw))
+  m (Maybe (Syntax Raw), Maybe UTCTime)
 readLoc loc = do
-  let path = locToFilePath loc
-      badImport :: Has (Throw SystemFailure) sig m => LoadingFailure -> m a
-      badImport = throwError . AssetNotLoaded (Data Script) path
-      withBadImport :: Has (Throw SystemFailure) sig m => (e -> LoadingFailure) -> Either e a -> m a
-      withBadImport f = either (badImport . f) pure
-
   -- Try to read the file from network/disk, depending on the anchor
-  src <- case importAnchor loc of
-    -- Read from network
-    Web_ {} -> do
-      -- Try to parse the URL
-      req <- parseRequest (into @String path) & withBadImport (BadURL . showT)
-      -- Send HTTP request
-      resp <- sendIO $ httpBS req
-      -- Try to decode the response
-      T.decodeUtf8' (getResponseBody resp) & withBadImport CanNotDecodeUTF8
-
-    -- Read from disk
-    _ -> sendIO (readFileMayT SystemLocale path) >>= maybe (badImport (DoesNotExist File)) pure
-
+  (src, mtime) <- case importAnchor loc of
+    Web_ {} -> readFromNet
+    _ -> readFromDisk
   -- Finally, try to parse the contents
-  readTerm' (defaultParserConfig & importLoc ?~ loc) src
-    & withBadImport (SystemFailure . CanNotParseMegaparsec)
+  syn <-
+    readTerm' (defaultParserConfig & importLoc ?~ loc) src
+      & withBadImport (SystemFailure . CanNotParseMegaparsec)
+  pure (syn, mtime)
+ where
+  path = locToFilePath loc
+  badImport :: Has (Throw SystemFailure) sig m => LoadingFailure -> m a
+  badImport = throwError . AssetNotLoaded (Data Script) path
+  withBadImport :: Has (Throw SystemFailure) sig m => (e -> LoadingFailure) -> Either e a -> m a
+  withBadImport f = either (badImport . f) pure
+  readFromDisk = do
+    mcontent <- sendIO (readFileMayT SystemLocale path)
+    content <- maybe (badImport (DoesNotExist File)) pure mcontent
+    mt <- sendIO $ getModificationTimeMay path
+    pure (content, mt)
+  readFromNet = do
+    -- Try to parse the URL
+    req <- parseRequest (into @String path) & withBadImport (BadURL . showT)
+    -- Send HTTP request
+    resp <- sendIO $ httpBS req
+    -- Try to decode the response
+    content <- T.decodeUtf8' (getResponseBody resp) & withBadImport CanNotDecodeUTF8
+    time <- sendIO getCurrentTime
+    pure (content, Just time)

src/swarm-lang/Swarm/Language/Typecheck.hs

@@ -216,11 +216,12 @@ fromInferredModule ::
   ) =>
   Module Inferred ->
   m (Module Typed)
-fromInferredModule (Module t (ctx, tdCtx) imps) =
+fromInferredModule (Module t (ctx, tdCtx) imps time) =
   Module
     <$> traverse fromInferredSyntax t
     <*> ((,tdCtx) <$> traverse (checkPredicative . fromU) ctx)
     <*> pure imps
+    <*> pure time
 
 -- | Finalize the typechecking process by generalizing over free
 --   unification variables and ensuring that no bound unification
@@ -430,7 +431,7 @@ instance HasBindings (Syntax Inferred) where
   applyBindings (Syntax l t cs u) = Syntax l <$> applyBindings t <*> pure cs <*> applyBindings u
 
 instance HasBindings (Module Inferred) where
-  applyBindings (Module t ctx imps) = Module <$> applyBindings t <*> applyBindings ctx <*> pure imps
+  applyBindings (Module t ctx imps time) = Module <$> applyBindings t <*> applyBindings ctx <*> pure imps <*> pure time
 
 ------------------------------------------------------------
 -- Converting between mono- and polytypes
@@ -1172,14 +1173,14 @@ inferModule ::
   , Has (Error ContextualTypeErr) sig m
   ) =>
   Module Resolved -> m (Module Inferred)
-inferModule (Module ms _ _imps) = do
+inferModule (Module ms _ _imps time) = do
   -- Infer the type of the term
   mt <- traverse infer ms
 
   -- Now, if the term has top-level definitions, collect up their
   -- types and put them in the context.
   ctx <- maybe (pure (Ctx.empty, emptyTDCtx)) collectDefs mt
-  pure $ Module mt ctx ()
+  pure $ Module mt ctx () time
 
 -- | Infer the type of a constant.
 inferConst :: Const -> Polytype

src/swarm-util/Swarm/Language/Syntax/Import.hs

@@ -41,6 +41,7 @@ module Swarm.Language.Syntax.Import (
   importAnchor,
 
   -- ** Utilities
+  Path (..),
   anchorToPath,
   dirToPath,
   locToPath,
@@ -150,12 +151,12 @@ instance PrettyPrec UAnchor where
     Home_ -> "~"
 
 -- | A concrete representation of a path: either a local path or a URL.
-data Path = File FilePath | URL String
+data Path = LocalPath FilePath | URL String
   deriving (Eq, Ord, Show)
 
 pathToString :: Path -> String
 pathToString = \case
-  File f -> f
+  LocalPath f -> f
   URL u -> u
 
 -- | Turn an 'Anchor' into a concrete path.
@@ -259,7 +260,7 @@ dirToPath = withImportDir $ \a p ->
     -- URLs must specifically use front slashes as separators
     Web_ {} -> URL $ intercalate "/" (anchorToPath a : map (into @FilePath) p)
     -- Otherwise, use whatever is appropriate for the OS
-    _ -> File $ anchorToPath a </> joinPath (map (into @FilePath) p)
+    _ -> LocalPath $ anchorToPath a </> joinPath (map (into @FilePath) p)
 
 -- | Turn any import dir back into a raw one.
 unresolveImportDir :: Unresolvable phase => ImportDir phase -> ImportDir Raw
@@ -339,7 +340,7 @@ importAnchor = withImportDir const . importDir
 locToPath :: ImportLoc Resolved -> Path
 locToPath (ImportLoc d f) =
   case dirToPath d of
-    File dp -> File (dp </> into @FilePath f)
+    LocalPath dp -> LocalPath (dp </> into @FilePath f)
     URL url -> URL (url ++ "/" ++ into @String f)
 
 -- | Turn an 'ImportLoc' into a concrete FilePath (or URL).
@@ -379,7 +380,7 @@ resolveImportDir (ImportDir a p) = case a of
 doesLocationExist :: (Has (Lift IO) sig m) => ImportLoc Resolved -> m Bool
 doesLocationExist loc = case locToPath loc of
   URL _ -> pure True
-  File fp -> sendIO $ doesFileExist fp
+  LocalPath fp -> sendIO $ doesFileExist fp
 
 -- | Resolve an import location, by turning the path into an absolute
 --   path, and optionally adding a .sw suffix to the file name.

src/swarm-util/Swarm/Util.hs

@@ -43,6 +43,7 @@ module Swarm.Util (
   writeFileT,
   findAllWithExt,
   acquireAllWithExt,
+  getModificationTimeMay,
 
   -- * Text utilities
   isIdentChar,
@@ -115,14 +116,15 @@ import Data.Set qualified as S
 import Data.Text (Text, toUpper)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
+import Data.Time.Clock
 import Data.Tuple (swap)
 import Data.Yaml
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (lift)
 import NLP.Minimorph.English qualified as MM
 import NLP.Minimorph.Util ((<+>))
 import System.Clock (TimeSpec)
-import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
+import System.Directory (doesDirectoryExist, doesFileExist, getModificationTime, listDirectory)
 import System.FilePath (normalise, takeExtension, (</>))
 import System.IO hiding (readFile, writeFile)
 import System.IO.Error (catchIOError)
@@ -424,6 +426,9 @@ acquireAllWithExt dir ext = findAllWithExt dir ext >>= wither addContent
   addContent :: FilePath -> IO (Maybe (FilePath, Text))
   addContent path = (fmap . fmap) (path,) (readFileMayT UTF8 path)
 
+getModificationTimeMay :: FilePath -> IO (Maybe UTCTime)
+getModificationTimeMay = catchIO . getModificationTime
+
 -- | Turns any IO error into Nothing.
 catchIO :: IO a -> IO (Maybe a)
 catchIO act = (Just <$> act) `catchIOError` (\_ -> return Nothing)