Git: use NonEmpty in fullconfig

This is a nice win. Avoids partial functions, by encoding at the type
level the fact that fullconfig is never an empty list.

diff --git a/Git/Config.hs b/Git/Config.hs
index 4423ea6d48e333bd6664263e1f19bae723de79db..6c24c04dc315417d7187466927f23b2db081389d 100644 (file)
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -12,6 +12,7 @@ module Git.Config where
 import qualified Data.Map as M
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
+import qualified Data.List.NonEmpty as NE
 import Data.Char
 import qualified System.FilePath.ByteString as P
 import Control.Concurrent.Async
@@ -31,7 +32,7 @@ get key fallback repo = M.findWithDefault fallback key (config repo)
 
 {- Returns a list of values. -}
 getList :: ConfigKey -> Repo -> [ConfigValue]
-getList key repo = M.findWithDefault [] key (fullconfig repo)
+getList key repo = maybe [] NE.toList $ M.lookup key (fullconfig repo)
 
 {- Returns a single git config setting, if set. -}
 getMaybe :: ConfigKey -> Repo -> Maybe ConfigValue
@@ -118,7 +119,8 @@ hRead repo st h = do
        val <- S.hGetContents h
        let c = parse val st
        debug (DebugSource "Git.Config") $ "git config read: " ++
-               show (map (\(k, v) -> (show k, map show v)) (M.toList c))
+               show (map (\(k, v) -> (show k, map show (NE.toList v))) 
+                       (M.toList c))
        storeParsed c repo
 
 {- Stores a git config into a Repo, returning the new version of the Repo.
@@ -128,10 +130,10 @@ hRead repo st h = do
 store :: S.ByteString -> ConfigStyle -> Repo -> IO Repo
 store s st = storeParsed (parse s st)
 
-storeParsed :: M.Map ConfigKey [ConfigValue] -> Repo -> IO Repo
+storeParsed :: M.Map ConfigKey (NE.NonEmpty ConfigValue) -> Repo -> IO Repo
 storeParsed c repo = updateLocation $ repo
-       { config = (M.map Prelude.head c) `M.union` config repo
-       , fullconfig = M.unionWith (++) c (fullconfig repo)
+       { config = (M.map NE.head c) `M.union` config repo
+       , fullconfig = M.unionWith (<>) c (fullconfig repo)
        }
 
 {- Stores a single config setting in a Repo, returning the new version of
@@ -139,7 +141,8 @@ storeParsed c repo = updateLocation $ repo
 store' :: ConfigKey -> ConfigValue -> Repo -> Repo
 store' k v repo = repo
        { config = M.singleton k v `M.union` config repo
-       , fullconfig = M.unionWith (++) (M.singleton k [v]) (fullconfig repo)
+       , fullconfig = M.unionWith (<>) (M.singleton k (NE.singleton v))
+               (fullconfig repo)
        }
 
 {- Updates the location of a repo, based on its configuration.
@@ -191,7 +194,7 @@ data ConfigStyle = ConfigList | ConfigNullList
 
 {- Parses git config --list or git config --null --list output into a
  - config map. -}
-parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey [ConfigValue]
+parse :: S.ByteString -> ConfigStyle -> M.Map ConfigKey (NE.NonEmpty ConfigValue)
 parse s st
        | S.null s = M.empty
        | otherwise = case st of
@@ -201,8 +204,8 @@ parse s st
        nl = fromIntegral (ord '\n')
        eq = fromIntegral (ord '=')
 
-       sep c = M.fromListWith (++)
-               . map (\(k,v) -> (ConfigKey k, [mkval v])) 
+       sep c = M.fromListWith (<>)
+               . map (\(k,v) -> (ConfigKey k, (NE.singleton (mkval v))) )
                . map (S.break (== c))
        
        mkval v 

diff --git a/Git/Remote.hs b/Git/Remote.hs
index 3a8945c146158958c342856943c886d25b4e7144..2cc0e2601db61cd2953ae050a2f17b3a66282a87 100644 (file)
--- a/Git/Remote.hs
+++ b/Git/Remote.hs
@@ -19,6 +19,7 @@ import Data.Char
 import qualified Data.Map as M
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
+import qualified Data.List.NonEmpty as NE
 import Network.URI
 #ifdef mingw32_HOST_OS
 import Git.FilePath
@@ -117,7 +118,7 @@ parseRemoteLocation s knownurl repo = go
                        (_, NoConfigValue) -> False
                filterconfig f = filter f $
                        concatMap splitconfigs $ M.toList $ fullconfig repo
-               splitconfigs (k, vs) = map (\v -> (k, v)) vs
+               splitconfigs (k, vs) = map (\v -> (k, v)) (NE.toList vs)
                (prefix, suffix) = ("url." , ".insteadof")
        -- git supports URIs that contain unescaped characters such as
        -- spaces. So to test if it's a (git) URI, escape those.

diff --git a/Git/Types.hs b/Git/Types.hs
index 3f4410fc0db62945add5146fe864a7b385e43a10..18398a040e06a878206b865df211d335452432dc 100644 (file)
--- a/Git/Types.hs
+++ b/Git/Types.hs
@@ -14,6 +14,7 @@ import Data.String
 import Data.Default
 import qualified Data.Map as M
 import qualified Data.ByteString as S
+import qualified Data.List.NonEmpty as NE
 import System.Posix.Types
 import Utility.SafeCommand
 import Utility.FileSystemEncoding
@@ -42,7 +43,7 @@ data Repo = Repo
        { location :: RepoLocation
        , config :: M.Map ConfigKey ConfigValue
        -- a given git config key can actually have multiple values
-       , fullconfig :: M.Map ConfigKey [ConfigValue]
+       , fullconfig :: M.Map ConfigKey (NE.NonEmpty ConfigValue)
        -- remoteName holds the name used for this repo in some other
        -- repo's list of remotes, when this repo is such a remote
        , remoteName :: Maybe RemoteName

diff --git a/Remote/Git.hs b/Remote/Git.hs
index 4a79cfed40aabc4a0b581de2d0ea02f3eaa9e5d8..25e2d62c4cd2562e440c40f4fb5ab29f874e1d92 100644 (file)
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -72,6 +72,7 @@ import Messages.Progress
 import Control.Concurrent
 import qualified Data.Map as M
 import qualified Data.Set as S
+import qualified Data.List.NonEmpty as NE
 import qualified Data.ByteString as B
 import qualified Utility.RawFilePath as R
 import Network.URI
@@ -937,7 +938,7 @@ listProxied proxies rs = concat <$> mapM go rs
                                Git.fullconfig r
                        in r 
                                { Git.remoteName = Just proxyname
-                               , Git.config = M.map Prelude.head c
+                               , Git.config = M.map NE.head c
                                , Git.fullconfig = c
                                }
                
@@ -948,19 +949,19 @@ listProxied proxies rs = concat <$> mapM go rs
                                adjustclusternode clusters $
                                inheritconfigs $ Git.fullconfig r'
                        in r'
-                               { Git.config = M.map Prelude.head c
+                               { Git.config = M.map NE.head c
                                , Git.fullconfig = c
                                }
 
-               adduuid ck = M.insert ck
-                       [Git.ConfigValue $ fromUUID $ proxyRemoteUUID p]
+               adduuid ck = M.insert ck $ NE.singleton $
+                       Git.ConfigValue $ fromUUID $ proxyRemoteUUID p
 
-               addurl = M.insert (mkRemoteConfigKey renamedr (remoteGitConfigKey UrlField))
-                       [Git.ConfigValue $ encodeBS $ Git.repoLocation r]
+               addurl = M.insert (mkRemoteConfigKey renamedr (remoteGitConfigKey UrlField)) $
+                       NE.singleton $ Git.ConfigValue $ encodeBS $ Git.repoLocation r
                
                addproxiedby = case remoteAnnexUUID gc of
                        Just u -> addremoteannexfield ProxiedByField
-                               [Git.ConfigValue $ fromUUID u]
+                               (Git.ConfigValue $ fromUUID u)
                        Nothing -> id
                
                -- A node of a cluster that is being proxied along with
@@ -975,15 +976,16 @@ listProxied proxies rs = concat <$> mapM go rs
                                Just cs
                                        | any (\c -> S.member (fromClusterUUID c) proxieduuids) (S.toList cs) ->
                                                addremoteannexfield SyncField
-                                                       [Git.ConfigValue $ Git.Config.boolConfig' False]
+                                                       (Git.ConfigValue $ Git.Config.boolConfig' False)
                                                . addremoteannexfield CostField 
-                                                       [Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1]
+                                                       (Git.ConfigValue $ encodeBS $ show $ defaultRepoCost r + 0.1)
                                _ -> id
 
                proxieduuids = S.map proxyRemoteUUID proxied
 
                addremoteannexfield f = M.insert
-                       (mkRemoteConfigKey renamedr (remoteGitConfigKey f))
+                       (mkRemoteConfigKey renamedr (remoteGitConfigKey f)) 
+                       . NE.singleton
 
                inheritconfigs c = foldl' inheritconfig c proxyInheritedFields