From 1c89b6d05b88af68952da0dbdd2811b8d5888a0a Mon Sep 17 00:00:00 2001
From: Nicolas Mattia <nicolas@nmattia.com>
Date: Thu, 5 Dec 2019 16:05:28 +0100
Subject: [PATCH] Fix git update

---
 src/Niv/Git/Cmd.hs  | 28 ++++++++++++++++++----------
 src/Niv/Git/Test.hs | 35 ++++++++++++++++++++++++++++++++++-
 2 files changed, 52 insertions(+), 11 deletions(-)

diff --git a/src/Niv/Git/Cmd.hs b/src/Niv/Git/Cmd.hs
index a2feb79..df4ae08 100644
--- a/src/Niv/Git/Cmd.hs
+++ b/src/Niv/Git/Cmd.hs
@@ -29,7 +29,7 @@ gitCmd = Cmd
   { description = describeGit
   , parseCmdShortcut = parseGitShortcut
   , parsePackageSpec = parseGitPackageSpec
-  , updateCmd = gitUpdate
+  , updateCmd = gitUpdate'
   , name = "git"
   }
 
@@ -108,21 +108,29 @@ describeGit = mconcat
       "  niv add git --repo /my/custom/repo --name custom --ref foobar"
   ]
 
-gitUpdate :: Update () ()
-gitUpdate = proc () -> do
+gitUpdate
+  :: (T.Text -> T.Text -> IO T.Text) -- ^ latest rev
+  -> (T.Text -> IO (T.Text, T.Text)) -- ^ latest rev and default ref
+  -> Update () ()
+gitUpdate latestRev' defaultRefAndHEAD' = proc () -> do
     useOrSet "type" -< ("git" :: Box T.Text)
     repository <- load "repo" -< ()
-    refAndRev <- (discoverRev <+> discoverRefAndRev) -< repository
-    update "ref" -< fst <$> refAndRev
-    update "rev" -< snd <$> refAndRev
-    returnA -< ()
+    discoverRev <+> discoverRefAndRev -< repository
   where
     discoverRefAndRev = proc repository -> do
-      run defaultRefAndHEAD -< repository
+      refAndRev <- run defaultRefAndHEAD' -< repository
+      update "ref" -< fst <$> refAndRev
+      update "rev" -< snd <$> refAndRev
+      returnA -< ()
     discoverRev = proc repository -> do
       ref <- load "ref" -< ()
-      rev <- run (\(r1,r2) -> latestRev r1 r2)-< (,) <$> repository <*> ref
-      returnA -< (,) <$> ref <*> rev
+      rev <- run' (uncurry latestRev') -< (,) <$> repository <*> ref
+      update "rev" -< rev
+      returnA -< ()
+
+-- | The "real" (IO) update
+gitUpdate' :: Update () ()
+gitUpdate' = gitUpdate latestRev defaultRefAndHEAD
 
 latestRev
     :: T.Text -- ^ the repository
diff --git a/src/Niv/Git/Test.hs b/src/Niv/Git/Test.hs
index 223ec71..fa9a429 100644
--- a/src/Niv/Git/Test.hs
+++ b/src/Niv/Git/Test.hs
@@ -1,16 +1,23 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Arrows #-}
 
 module Niv.Git.Test (tests) where
 
+import Control.Monad
+import Data.Bifunctor
 import Niv.Git.Cmd
 import Niv.Sources
+import Niv.Update
 import Test.Tasty.HUnit ((@=?))
 import qualified Data.HashMap.Strict as HMS
 import qualified Test.Tasty as Tasty
 import qualified Test.Tasty.HUnit as Tasty
 
 tests :: [Tasty.TestTree]
-tests = pure $ Tasty.testGroup "repository parse"
+tests = [ test_repositoryParse , test_gitUpdates ]
+
+test_repositoryParse :: Tasty.TestTree
+test_repositoryParse = Tasty.testGroup "repository parse"
   [ Tasty.testCase "goo" $
       parseGitShortcut "goo" @=? Nothing
   , Tasty.testCase "git@github.com:nmattia/niv" $
@@ -28,3 +35,29 @@ tests = pure $ Tasty.testGroup "repository parse"
       parseGitShortcut "~/path/to/repo.git" @=? Just
         (PackageName "repo", HMS.singleton "repo" "~/path/to/repo.git")
   ]
+
+test_gitUpdates :: Tasty.TestTree
+test_gitUpdates = Tasty.testGroup "updates"
+  [ Tasty.testCase "rev is updated" test_gitUpdateRev
+  ]
+
+test_gitUpdateRev :: IO ()
+test_gitUpdateRev = do
+    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")
+      ]