Improve testability of the Real interpreter

There is an issue in how we test actions. Fundamentally, we rely on the
fact that the `Real` runner is generating `git` calls correctly. This
could be neglected in theory, but there is another issue, which forces
us to generate "textual" representation of what our command is doing, in
multiple places, which leads to code repetition.
As a solution to this, I've created 1 data type for every type of the
command we can execute, and implemeted the way to render it to the
"textual" representation.
This could be used by `Real` runner directly, but this still suffers
from a different issue. We give `Real` runner to much access, by adding
`MonadIO` to the context.
There is a solution however. We can create a custom `Monad` which can
provide all needed functions for `Real` to proceed. Going this way, we
can hide how we "render" and "execute" git calls from the `Real` runner,
which implies that it has no way to run arbitrary commands at all.

#299

Author: teggotic

.github/workflows/haskell-quality-pipeline.yml

@@ -28,19 +28,21 @@ jobs:
     - uses: actions/checkout@v3
     - uses: actions/cache@v3
       name: Cache .ghcup
+      id: haskell-env-cache
       with:
         path: ~/.ghcup
         key: ${{ runner.os }}-ghcup-global-${{ env.GHCUP_VERSION }}-${{ env.STACK_VERSION }}
         restore-keys: |
-          ${{ runner.os }}-ghcup-global-${{ env.GHCUP_VERSION }}
+          ${{ runner.os }}-ghcup-global-${{ env.GHCUP_VERSION }}-
           ${{ runner.os }}-ghcup-global-
     - uses: actions/cache@v3
       name: Cache .stack
+      id: haskell-deps-cache
       with:
         path: ~/.stack
-        key: ${{ runner.os }}-stack-global-${{ env.GHC_VERSION }}-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }}-${{ hashFiles('**/*.hs') }}
+        key: ${{ runner.os }}-stack-global-${{ env.GHC_VERSION }}-${{ hashFiles('stack.yaml') }}-${{ hashFiles('package.yaml') }}
         restore-keys: |
-          ${{ runner.os }}-stack-global-${{ env.GHC_VERSION }}
+          ${{ runner.os }}-stack-global-${{ env.GHC_VERSION }}-
     - name: Setup haskell enviroment
       run: |
         export PATH=~/.ghcup/bin:$PATH

elegant-git.cabal

@@ -30,6 +30,7 @@ library
       Elegit.Cli.Command
       Elegit.Cli.Parser
       Elegit.Git.Action
+      Elegit.Git.Exec
       Elegit.Git.Runner.Real
       Elegit.Git.Runner.Simulated
       Lib
@@ -46,6 +47,7 @@ library
       base >=4.7 && <5
     , containers
     , dlist
+    , exceptions
     , fmt
     , free
     , microlens
@@ -79,6 +81,7 @@ executable git-elegant
     , containers
     , dlist
     , elegant-git
+    , exceptions
     , fmt
     , free
     , microlens
@@ -119,6 +122,7 @@ test-suite elegant-git-test
     , containers
     , dlist
     , elegant-git
+    , exceptions
     , fmt
     , free
     , hspec

package.yaml

@@ -24,6 +24,7 @@ dependencies:
 
 - universum
 - string-qq
+- exceptions
 - text
 - safe-exceptions
 - fmt

src/Elegit/Git/Action.hs

@@ -1,6 +1,7 @@
-{-# LANGUAGE DeriveFunctor      #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE DerivingStrategies    #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts      #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -35,25 +36,125 @@ import qualified Data.Text                 as T
 import           Fmt
 import           Universum                 hiding (print)
 
+-- TODO: maybe, cover with tests
+class RenderGitCommand c where
+  renderGC :: c -> Text
+
+data GCurrentBranchData
+  = GCurrentBranchData
+
+instance RenderGitCommand GCurrentBranchData where
+  renderGC _ = "rev-parse --abbrev-ref @"
+
+newtype GBranchUpstreamData
+  = GBranchUpstreamData { branch :: Text }
+
+instance RenderGitCommand GBranchUpstreamData where
+  renderGC (GBranchUpstreamData branchName) = "rev-parse --abbrev-ref "+|branchName|+"@{upstream}"
+
+data GLogData
+  = GLogData
+      { logType :: LogType
+      , base    :: Text
+      , target  :: Text
+      }
+instance RenderGitCommand GLogData where
+  renderGC (GLogData lType baseName targetName) = "log "+|logArg|+" "+|baseName|+".."+|targetName|+""
+    where
+      logArg :: Text
+      logArg = case lType of
+                 LogOneLine -> "--oneline"
+
+newtype GStatusData
+  = GStatusData { statusType :: StatusType }
+
+instance RenderGitCommand GStatusData where
+  renderGC (GStatusData sType) = "status "+|statusFormat|+""
+    where
+      statusFormat :: Text
+      statusFormat = case sType of
+                       StatusShort -> "--short"
+
+data GStashListData
+  = GStashListData
+instance RenderGitCommand GStashListData where
+  renderGC _ = "stash list"
+
+data GReadConfigData
+  = GReadConfigData
+      { scope :: ConfigScope
+      , key   :: Text
+      }
+
+instance RenderGitCommand GReadConfigData where
+  renderGC (GReadConfigData cScope cName) = "config "+|scopeText|+" --get "+|cName|+""
+    where
+      scopeText :: Text
+      scopeText = case cScope of
+                LocalConfig  -> "--local"
+                GlobalConfig -> "--global"
+                AutoConfig   -> ""
+
+data GSetConfigData
+  = GSetConfigData
+      { scope :: ConfigScope
+      , key   :: Text
+      , value :: Text
+      }
+
+instance RenderGitCommand GSetConfigData where
+  renderGC (GSetConfigData cScope cName cValue) = "config "+|scopeText|+" "+|cName|+" "+|cValue|+""
+    where
+      scopeText :: Text
+      scopeText = case cScope of
+                GlobalConfig -> "--global"
+                LocalConfig  -> "--local"
+                AutoConfig   -> "--local"
+
+data GUnsetConfigData
+  = GUnsetConfigData
+      { scope :: ConfigScope
+      , key   :: Text
+      }
+
+instance RenderGitCommand GUnsetConfigData where
+  renderGC (GUnsetConfigData cScope cName) = "config "+|scopeText|+" --unset "+|cName|+""
+    where
+      scopeText :: Text
+      scopeText = case cScope of
+                GlobalConfig -> "--global"
+                LocalConfig  -> "--local"
+                AutoConfig   -> "--local"
+
+newtype GAliasesToRemoveData
+  = GAliasesToRemoveData { scope :: ConfigScope }
+
+instance RenderGitCommand GAliasesToRemoveData where
+  renderGC (GAliasesToRemoveData cScope) = "config "+|scopeText|+" --name-only --get-regexp \"^alias.\" \"^elegant ([-a-z]+)$\""
+    where
+      scopeText :: Text
+      scopeText = case cScope of
+                GlobalConfig -> "--global"
+                LocalConfig  -> "--local"
+                AutoConfig   -> ""
+
 -- | The declaration of all posible actions we can do in the git action.
 --
 -- This describes the data of the action, and whether it can return any value
 -- for further computations.
 --
 -- We can use records later to better comunicate the purpose of each field by
 -- providing a name.
---
--- TODO: Use records
 data GitF a
-  = CurrentBranch (Text -> a)
-  | BranchUpstream Text (Maybe Text -> a)
-  | Log LogType Text Text ([Text] -> a)
-  | Status StatusType ([Text] -> a)
-  | StashList ([Text] -> a)
-  | ReadConfig ConfigScope Text (Maybe Text -> a)
-  | AliasesToRemove ConfigScope (Maybe (NonEmpty Text) -> a)
-  | SetConfig ConfigScope Text Text a
-  | UnsetConfig ConfigScope Text a
+  = CurrentBranch GCurrentBranchData (Text -> a)
+  | BranchUpstream GBranchUpstreamData (Maybe Text -> a)
+  | Log GLogData ([Text] -> a)
+  | Status GStatusData ([Text] -> a)
+  | StashList GStashListData ([Text] -> a)
+  | ReadConfig GReadConfigData (Maybe Text -> a)
+  | AliasesToRemove GAliasesToRemoveData (Maybe (NonEmpty Text) -> a)
+  | SetConfig GSetConfigData a
+  | UnsetConfig GUnsetConfigData a
   | Prompt Text (Maybe Text) (Text -> a)
   | FormatInfo Text (Text -> a)
   | FormatCommand Text (Text -> a)
@@ -101,34 +202,34 @@ type FreeGit t = F GitF t
 -- * Otherwise just use `id` function.
 
 status :: MonadFree GitF m => StatusType -> m [Text]
-status sType = liftF $ Status sType id
+status sType = liftF $ Status (GStatusData sType) id
 
 log :: MonadFree GitF m => LogType -> Text -> Text -> m [Text]
-log lType lBase lTarget = liftF $ Log lType lBase lTarget id
+log lType lBase lTarget = liftF $ Log (GLogData lType lBase lTarget) id
 
 stashList :: MonadFree GitF m => m [Text]
-stashList = liftF $ StashList id
+stashList = liftF $ StashList GStashListData id
 
 currentBranch :: MonadFree GitF m => m Text
-currentBranch = liftF $ CurrentBranch id
+currentBranch = liftF $ CurrentBranch GCurrentBranchData id
 
 branchUpstream :: MonadFree GitF m => Text -> m (Maybe Text)
-branchUpstream bName = liftF $ BranchUpstream bName id
+branchUpstream bName = liftF $ BranchUpstream (GBranchUpstreamData bName) id
 
 readConfig :: MonadFree GitF m => ConfigScope -> Text -> m (Maybe Text)
-readConfig cScope cName = liftF $ ReadConfig cScope cName id
+readConfig cScope cName = liftF $ ReadConfig (GReadConfigData cScope cName) id
 
--- TODO: Check if it's better or even possible to get all configurations and filter then ourself.
+-- TODO: Check if it's better or even possible to get all configurations and filter them ourself.
 -- This would improve testability of this, as now we rely on the fact that we make a correct cli call
 -- to find config with regex in the `Real.hs`.
 aliasesToRemove :: MonadFree GitF m => ConfigScope -> m (Maybe (NonEmpty Text))
-aliasesToRemove cScope = liftF $ AliasesToRemove cScope id
+aliasesToRemove cScope = liftF $ AliasesToRemove (GAliasesToRemoveData cScope) id
 
 setConfig :: MonadFree GitF m => ConfigScope -> Text -> Text -> m ()
-setConfig cScope cName cValue = liftF $ SetConfig cScope cName cValue ()
+setConfig cScope cName cValue = liftF $ SetConfig (GSetConfigData cScope cName cValue) ()
 
 unsetConfig :: MonadFree GitF m => ConfigScope -> Text -> m ()
-unsetConfig cScope cName = liftF $ UnsetConfig cScope cName ()
+unsetConfig cScope cName = liftF $ UnsetConfig (GUnsetConfigData cScope cName) ()
 
 promptDefault :: MonadFree GitF m => Text -> Maybe Text -> m Text
 promptDefault pText pDefault = liftF $ Prompt pText pDefault id
@@ -144,22 +245,18 @@ print content = liftF $ PrintText content ()
 
 -- Derived actions
 
-configScopeText :: ConfigScope -> Text
-configScopeText LocalConfig  = "--local"
-configScopeText GlobalConfig = "--global"
-configScopeText AutoConfig   = ""
+formatGitCommand :: (RenderGitCommand gc, MonadFree GitF m) => gc -> m Text
+formatGitCommand gc = formatCommand ("git "+|renderGC gc|+"")
 
 setConfigVerbose :: MonadFree GitF m => ConfigScope -> Text -> Text -> m ()
 setConfigVerbose cScope cName cValue = do
   setConfig cScope cName cValue
-  -- TODO: Generate these messages only in a single place and reuse in `Real.hs`
-  print =<< formatCommand ("git config "+|configScopeText cScope|+" "+|cName|+" "+|cValue|+"")
+  print =<< formatGitCommand (GSetConfigData cScope cName cValue)
 
 unsetConfigVerbose :: MonadFree GitF m => ConfigScope -> Text -> m ()
 unsetConfigVerbose cScope cName = do
   unsetConfig cScope cName
-  -- TODO: Generate these messages only in a single place and reuse in `Real.hs`
-  print =<< formatCommand ("git config "+|configScopeText cScope|+" --unset "+|cName|+"")
+  print =<< formatGitCommand (GUnsetConfigData cScope cName)
 
 freshestDefaultBranch :: MonadFree GitF m => m Text
 freshestDefaultBranch = do