Cache hashDerivationModulo results ourselves

Ideally, we would have this cache inside the (h)nix-store, and persist
the store connection for the whole session.  Consider this a proof of
concept that may last.

Author: layus

src/Nix/Effects/Basic.hs

@@ -225,13 +225,13 @@ findPathM = findPathBy existingPath
     pure $ if exists then Just apath else Nothing
 
 defaultImportPath
-  :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc) m)
+  :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc, b) m)
   => FilePath
   -> m (NValue t f m)
 defaultImportPath path = do
   traceM $ "Importing file " ++ path
   withFrame Info (ErrorCall $ "While importing file " ++ show path) $ do
-    imports <- get
+    imports <- gets fst
     evalExprLoc =<< case M.lookup path imports of
       Just expr -> pure expr
       Nothing   -> do
@@ -242,7 +242,7 @@ defaultImportPath path = do
               $ ErrorCall
               . show $ fillSep ["Parse during import failed:", err]
           Success expr -> do
-            modify (M.insert path expr)
+            modify (\(a, b) -> (M.insert path expr a, b))
             pure expr
 
 defaultPathToDefaultNix :: MonadNix e t f m => FilePath -> m FilePath

src/Nix/Effects/Derivation.hs

@@ -16,9 +16,11 @@ import           Prelude                 hiding ( readFile )
 import           Control.Arrow                  ( first, second )
 import           Control.Monad                  ( (>=>), forM, when )
 import           Control.Monad.Writer           ( join, lift )
+import           Control.Monad.State            ( MonadState, gets, modify )
 
 import           Data.Char                      ( isAscii, isAlphaNum )
 import qualified Data.HashMap.Lazy             as M
+import qualified Data.HashMap.Strict           as MS
 import qualified Data.HashSet                  as S
 import           Data.List
 import qualified Data.Map.Strict               as Map
@@ -101,7 +103,7 @@ writeDerivation (drv@Derivation {inputs, name}) = do
 
 -- | Traverse the graph of inputDrvs to replace fixed output derivations with their fixed output hash.
 -- this avoids propagating changes to their .drv when the output hash stays the same.
-hashDerivationModulo :: (Framed e m, MonadFile m) => Derivation -> m (Store.Digest 'Store.SHA256)
+hashDerivationModulo :: (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => Derivation -> m (Store.Digest 'Store.SHA256)
 hashDerivationModulo (Derivation {
     mFixed = Just (Store.SomeDigest (digest :: Store.Digest hashType)),
     outputs,
@@ -115,10 +117,14 @@ hashDerivationModulo (Derivation {
       <> ":" <> path
     outputsList -> throwError $ ErrorCall $ "This is weird. A fixed output drv should only have one output named 'out'. Got " ++ show outputsList
 hashDerivationModulo drv@(Derivation {inputs = (inputSrcs, inputDrvs)}) = do
-  inputsModulo <- Map.fromList <$> forM (Map.toList inputDrvs) (\(path, outs) -> do
-    drv' <- readDerivation $ Text.unpack path
-    hash <- Store.encodeBase16 <$> hashDerivationModulo drv'
-    return (hash, outs)
+  cache <- gets snd
+  inputsModulo <- Map.fromList <$> forM (Map.toList inputDrvs) (\(path, outs) ->
+    case MS.lookup path cache of
+      Just hash -> return (hash, outs)
+      Nothing -> do
+        drv' <- readDerivation $ Text.unpack path
+        hash <- Store.encodeBase16 <$> hashDerivationModulo drv'
+        return (hash, outs)
     )
   return $ Store.hash @'Store.SHA256 $ Text.encodeUtf8 $ unparseDrv (drv {inputs = (inputSrcs, inputsModulo)})
 
@@ -214,7 +220,7 @@ derivationParser = do
     _ -> (Nothing, Flat)
 
 
-defaultDerivationStrict :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m)
+defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => NValue t f m -> m (NValue t f m)
 defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
     (drv, ctx) <- runWithStringContextT' $ buildDerivationWithContext s
     drvName <- makeStorePathName $ name drv
@@ -242,13 +248,14 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
           , env = if useJson drv then env drv else Map.union outputs' (env drv)
           }
 
-    drvPath <- writeDerivation drv'
+    drvPath <- pathToText <$> writeDerivation drv'
 
-    -- TODO: memoize this result here.
-    -- _ <- hashDerivationModulo drv'
+    -- Memoize here, as it may be our last chance in case of readonly stores.
+    drvHash <- Store.encodeBase16 <$> hashDerivationModulo drv'
+    modify (\(a, b) -> (a, MS.insert drvPath drvHash b))
 
-    let outputsWithContext = Map.mapWithKey (\out path -> principledMakeNixStringWithSingletonContext path (StringContext (pathToText drvPath) (DerivationOutput out))) (outputs drv')
-        drvPathWithContext = principledMakeNixStringWithSingletonContext (pathToText drvPath) (StringContext (pathToText drvPath) AllOutputs)
+    let outputsWithContext = Map.mapWithKey (\out path -> principledMakeNixStringWithSingletonContext path (StringContext drvPath (DerivationOutput out))) (outputs drv')
+        drvPathWithContext = principledMakeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs)
         attrSet = M.map nvStr $ M.fromList $ ("drvPath", drvPathWithContext): Map.toList outputsWithContext
     -- TODO: Add location information for all the entries.
     --              here --v

src/Nix/Reduce.hs

@@ -42,6 +42,7 @@ import           Control.Monad.State.Strict
 import           Data.Fix                       ( Fix(..), foldFix, foldFixM )
 import           Data.HashMap.Lazy              ( HashMap )
 import qualified Data.HashMap.Lazy             as M
+import qualified Data.HashMap.Strict           as MS
 import           Data.IORef
 import           Data.List.NonEmpty             ( NonEmpty(..) )
 import qualified Data.List.NonEmpty            as NE
@@ -66,19 +67,19 @@ import           System.FilePath
 
 newtype Reducer m a = Reducer
     { runReducer :: ReaderT (Maybe FilePath, Scopes (Reducer m) NExprLoc)
-                           (StateT (HashMap FilePath NExprLoc) m) a }
+                           (StateT (HashMap FilePath NExprLoc, MS.HashMap Text Text) m) a }
     deriving (Functor, Applicative, Alternative, Monad, MonadPlus,
               MonadFix, MonadIO, MonadFail,
               MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc),
-              MonadState (HashMap FilePath NExprLoc))
+              MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text))
 
 staticImport
   :: forall m
    . ( MonadIO m
      , Scoped NExprLoc m
      , MonadFail m
      , MonadReader (Maybe FilePath, Scopes m NExprLoc) m
-     , MonadState (HashMap FilePath NExprLoc) m
+     , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m
      )
   => SrcSpan
   -> FilePath
@@ -89,7 +90,7 @@ staticImport pann path = do
   path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath
     (maybe path (\p -> takeDirectory p </> path) mfile)
 
-  imports <- get
+  imports <- gets fst
   case M.lookup path' imports of
     Just expr -> pure expr
     Nothing   -> go path'
@@ -108,10 +109,10 @@ staticImport pann path = do
                           (Fix (NLiteralPath_ pann path))
                           pos
           x' = Fix (NLet_ span [cur] x)
-        modify (M.insert path x')
+        modify (\(a, b) -> (M.insert path x' a, b))
         local (const (Just path, emptyScopes @m @NExprLoc)) $ do
           x'' <- foldFix reduce x'
-          modify (M.insert path x'')
+          modify (\(a, b) -> (M.insert path x'' a, b))
           return x''
 
 -- gatherNames :: NExprLoc -> HashSet VarName
@@ -122,7 +123,7 @@ staticImport pann path = do
 reduceExpr
   :: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc
 reduceExpr mpath expr =
-  (`evalStateT` M.empty)
+  (`evalStateT` (M.empty, MS.empty))
     . (`runReaderT` (mpath, emptyScopes))
     . runReducer
     $ foldFix reduce expr
@@ -133,7 +134,7 @@ reduce
      , Scoped NExprLoc m
      , MonadFail m
      , MonadReader (Maybe FilePath, Scopes m NExprLoc) m
-     , MonadState (HashMap FilePath NExprLoc) m
+     , MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text) m
      )
   => NExprLocF (m NExprLoc)
   -> m NExprLoc

src/Nix/Standard.hs

@@ -30,6 +30,8 @@ import           Control.Monad.Reader
 import           Control.Monad.Ref
 import           Control.Monad.State
 import           Data.HashMap.Lazy              ( HashMap )
+import qualified Data.HashMap.Strict
+import           Data.Text                      ( Text )
 import           Data.Typeable
 import           GHC.Generics
 import           Nix.Cited
@@ -139,7 +141,7 @@ instance ( MonadFix m
          , Typeable m
          , Scoped (StdValue m) m
          , MonadReader (Context m (StdValue m)) m
-         , MonadState (HashMap FilePath NExprLoc) m
+         , MonadState (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m
          , MonadDataErrorContext (StdThunk m) (StdCited m) m
          , MonadThunk (StdThunk m) m (StdValue m)
          , MonadValue (StdValue m) m
@@ -192,7 +194,7 @@ instance ( MonadAtomicRef m
 
 newtype StandardTF r m a
   = StandardTF (ReaderT (Context r (StdValue r))
-                        (StateT (HashMap FilePath NExprLoc) m) a)
+                        (StateT (HashMap FilePath NExprLoc, HashMap Text Text) m) a)
   deriving
     ( Functor
     , Applicative
@@ -206,7 +208,7 @@ newtype StandardTF r m a
     , MonadThrow
     , MonadMask
     , MonadReader (Context r (StdValue r))
-    , MonadState (HashMap FilePath NExprLoc)
+    , MonadState (HashMap FilePath NExprLoc, HashMap Text Text)
     )
 
 instance MonadTrans (StandardTF r) where
@@ -233,7 +235,7 @@ instance MonadThunkId m => MonadThunkId (Fix1T StandardTF m) where
 mkStandardT
   :: ReaderT
        (Context (StandardT m) (StdValue (StandardT m)))
-       (StateT (HashMap FilePath NExprLoc) m)
+       (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)
        a
   -> StandardT m a
 mkStandardT = Fix1T . StandardTF
@@ -242,7 +244,7 @@ runStandardT
   :: StandardT m a
   -> ReaderT
        (Context (StandardT m) (StdValue (StandardT m)))
-       (StateT (HashMap FilePath NExprLoc) m)
+       (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m)
        a
 runStandardT (Fix1T (StandardTF m)) = m