Cache Box results

Some results were fetched _way_ too many times. All IO operations run in
updates are now cached. This makes `niv` effectively twice as fast.

*before:*

```
~/niv$ time niv add git git@github.com:nmattia/niv
Adding package niv
  Writing new sources file
Done: Adding package niv

real    0m3.603s
user    0m0.079s
sys     0m0.031s
```

*after:*
```
~/niv$ time niv add git git@github.com:nmattia/niv
Adding package niv
  Writing new sources file
Done: Adding package niv

real    0m1.387s
user    0m0.049s
sys     0m0.007s
```

src/Niv/Git/Test.hs

@@ -9,6 +9,7 @@ where
 import Control.Monad
 import Data.Bifunctor
 import qualified Data.HashMap.Strict as HMS
+import Data.IORef
 import Niv.Git.Cmd
 import Niv.Sources
 import Niv.Update
@@ -49,7 +50,8 @@ test_gitUpdates :: Tasty.TestTree
 test_gitUpdates =
   Tasty.testGroup
     "updates"
-    [ Tasty.testCase "rev is updated" test_gitUpdateRev
+    [ Tasty.testCase "rev is updated" test_gitUpdateRev,
+      Tasty.testCase "git is called once" test_gitCalledOnce
     ]
 
 test_gitUpdateRev :: IO ()
@@ -75,3 +77,53 @@ test_gitUpdateRev = do
           ("rev", "some-other-rev"),
           ("type", "git")
         ]
+
+once1 :: (b -> IO a) -> IO (b -> IO a)
+once1 f = do
+  used <- newIORef False
+  pure $ \x -> do
+    used' <- readIORef used
+    if used'
+      then error "already used"
+      else do
+        writeIORef used True
+        f x
+
+once2 :: (a -> b -> IO c) -> IO (a -> b -> IO c)
+once2 f = do
+  used <- newIORef False
+  pure $ \x y -> do
+    used' <- readIORef used
+    if used'
+      then error "already used"
+      else do
+        writeIORef used True
+        f x y
+
+-- | This tests that we don't run the same git operations several times during
+-- the update
+test_gitCalledOnce :: IO ()
+test_gitCalledOnce = do
+  defaultRefAndHEAD'' <- once1 defaultRefAndHEAD'
+  latestRev'' <- once2 latestRev'
+  interState <- evalUpdate initialState $ proc () ->
+    gitUpdate (error "should be def") defaultRefAndHEAD'' -< ()
+  let interState' = HMS.map (first (\_ -> Free)) interState
+  actualState <- evalUpdate interState' $ proc () ->
+    gitUpdate latestRev'' (error "should update") -< ()
+  unless ((snd <$> actualState) == expectedState)
+    $ error
+    $ "State mismatch: " <> show actualState
+  where
+    latestRev' _ _ = pure "some-other-rev"
+    defaultRefAndHEAD' _ = pure ("some-ref", "some-rev")
+    initialState =
+      HMS.fromList
+        [("repo", (Free, "git@github.com:nmattia/niv"))]
+    expectedState =
+      HMS.fromList
+        [ ("repo", "git@github.com:nmattia/niv"),
+          ("ref", "some-ref"),
+          ("rev", "some-other-rev"),
+          ("type", "git")
+        ]

src/Niv/Update.hs

@@ -70,7 +70,7 @@ data Compose a c = forall b. Compose' (Update b c) (Update a b)
 
 -- | Run an 'Update' and return the new attributes and result.
 runUpdate :: Attrs -> Update () a -> IO (Attrs, a)
-runUpdate (boxAttrs -> attrs) a = runUpdate' attrs a >>= feed
+runUpdate (attrs) a = boxAttrs attrs >>= flip runUpdate' a >>= feed
   where
     feed = \case
       UpdateReady res -> hndl res
@@ -129,6 +129,19 @@ data Box a
       }
   deriving (Functor)
 
+mkBox :: Box a -> IO (Box a)
+mkBox b = do
+  mvar <- newMVar Nothing
+  pure b {boxOp = singleton mvar (boxOp b)}
+
+singleton :: MVar (Maybe a) -> IO a -> IO a
+singleton mvar def = do
+  modifyMVar mvar $ \case
+    Just a -> pure (Just a, a)
+    Nothing -> do
+      a <- def
+      pure (Just a, a)
+
 instance Applicative Box where
   pure x = Box {boxNew = False, boxOp = pure x}
   f <*> v =
@@ -148,15 +161,17 @@ type BoxedAttrs = HMS.HashMap T.Text (Freedom, Box Value)
 unboxAttrs :: BoxedAttrs -> IO Attrs
 unboxAttrs = traverse (\(fr, v) -> (fr,) <$> runBox v)
 
-boxAttrs :: Attrs -> BoxedAttrs
+boxAttrs :: Attrs -> IO BoxedAttrs
 boxAttrs =
-  fmap
+  mapM
-    ( \(fr, v) ->
+    ( \(fr, v) -> do
+        box <- mkBox (pure v)
+        pure
           ( fr,
             case fr of
               -- TODO: explain why hacky
-            Locked -> (pure v) {boxNew = True} -- XXX: somewhat hacky
+              Locked -> box {boxNew = True} -- XXX: somewhat hacky
-            Free -> pure v
+              Free -> box
           )
     )
 
@@ -198,7 +213,8 @@ runUpdate' attrs = \case
   Run act ->
     pure
       ( UpdateNeedMore $ \gtt -> do
-          pure $ UpdateSuccess attrs $ Box (boxNew gtt) (act =<< runBox gtt)
+          box <- mkBox $ Box (boxNew gtt) (act =<< runBox gtt)
+          pure $ UpdateSuccess attrs box
       )
   Check ch ->
     pure