mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

avoid head

Browse source 
While in some sense this is better, the use of NE.fromList is still
partial.
This commit is contained in:
Joey Hess 2024-09-26 17:53:00 -04:00
parent c8fcd97626
commit 936f22273e
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 16 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
Command/TestRemote.hs
View file

@ -42,6 +42,7 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M import qualified Data.Map as M
import Data.Either import Data.Either
import Control.Concurrent.STM hiding (check) import Control.Concurrent.STM hiding (check)
import qualified Data.List.NonEmpty as NE
cmd :: Command cmd :: Command
cmd = command "testremote" SectionTesting cmd = command "testremote" SectionTesting
@ -83,8 +84,10 @@ start o = starting "testremote" (ActionItemOther (Just (UnquotedString (testRemo
then giveup "This remote is readonly, so you need to use the --test-readonly option." then giveup "This remote is readonly, so you need to use the --test-readonly option."
else do else do
showAction "generating test keys" showAction "generating test keys"
mapM randKey (keySizes basesz fast) NE.fromList
fs -> mapM (getReadonlyKey r . toRawFilePath) fs <$> mapM randKey (keySizes basesz fast)
fs -> NE.fromList
<$> mapM (getReadonlyKey r . toRawFilePath) fs
let r' = if null (testReadonlyFile o) let r' = if null (testReadonlyFile o)
then r then r
else r { Remote.readonly = True } else r { Remote.readonly = True }
@ -100,7 +103,7 @@ start o = starting "testremote" (ActionItemOther (Just (UnquotedString (testRemo
basesz = fromInteger $ sizeOption o basesz = fromInteger $ sizeOption o
si = SeekInput [testRemote o] si = SeekInput [testRemote o]
perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> NE.NonEmpty Key -> CommandPerform
perform drs unavailr exportr ks = do perform drs unavailr exportr ks = do
st <- liftIO . newTVarIO =<< (,) st <- liftIO . newTVarIO =<< (,)
<$> Annex.getState id <$> Annex.getState id
@ -110,12 +113,12 @@ perform drs unavailr exportr ks = do
drs drs
(pure unavailr) (pure unavailr)
exportr exportr
(map (\k -> Described (desck k) (pure k)) ks) (NE.map (\k -> Described (desck k) (pure k)) ks)
ok <- case tryIngredients [consoleTestReporter] mempty tests of ok <- case tryIngredients [consoleTestReporter] mempty tests of
Nothing -> error "No tests found!?" Nothing -> error "No tests found!?"
Just act -> liftIO act Just act -> liftIO act
rs <- catMaybes <$> mapM getVal drs rs <- catMaybes <$> mapM getVal drs
next $ cleanup rs ks ok next $ cleanup rs (NE.toList ks) ok
where where
desck k = unwords [ "key size", show (fromKey keySize k) ] desck k = unwords [ "key size", show (fromKey keySize k) ]
@ -216,12 +219,12 @@ mkTestTrees
-> [Described (Annex (Maybe Remote))] -> [Described (Annex (Maybe Remote))]
-> Annex (Maybe Remote) -> Annex (Maybe Remote)
-> Annex (Maybe Remote) -> Annex (Maybe Remote)
-> [Described (Annex Key)] -> (NE.NonEmpty (Described (Annex Key)))
-> [TestTree] -> [TestTree]
mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $ mkTestTrees runannex mkrs mkunavailr mkexportr mkks = concat $
[ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (Prelude.head mkks))) ] [ [ testGroup "unavailable remote" (testUnavailable runannex mkunavailr (getVal (NE.head mkks))) ]
, [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- mkks, mkr <- mkrs ] , [ testGroup (desc mkr mkk) (test runannex (getVal mkr) (getVal mkk)) | mkk <- NE.toList mkks, mkr <- mkrs ]
, [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 mkks, mkk2 <- take 2 (reverse mkks) ] , [ testGroup (descexport mkk1 mkk2) (testExportTree runannex mkexportr (getVal mkk1) (getVal mkk2)) | mkk1 <- take 2 (NE.toList mkks), mkk2 <- take 2 (reverse (NE.toList mkks)) ]
] ]
where where
desc r k = intercalate "; " $ map unwords desc r k = intercalate "; " $ map unwords

7
Test.hs
View file

@ -23,11 +23,12 @@ import Options.Applicative (switch, long, short, help, internal, maybeReader, op
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.ByteString.Lazy.UTF8 as BU8 import qualified Data.ByteString.Lazy.UTF8 as BU8
import Control.Concurrent.STM hiding (check) import Control.Concurrent.STM hiding (check)
import qualified Utility.RawFilePath as R
import qualified Data.List.NonEmpty as NE
import Data.String
import Common import Common
import CmdLine.GitAnnex.Options import CmdLine.GitAnnex.Options
import qualified Utility.RawFilePath as R
import Data.String
import qualified Utility.ShellEscape import qualified Utility.ShellEscape
import qualified Annex import qualified Annex
@ -251,7 +252,7 @@ testRemote testvariants remotetype setupremote =
cv <- annexeval cache cv <- annexeval cache
liftIO $ atomically $ putTMVar v liftIO $ atomically $ putTMVar v
(r, (unavailr, (exportr, (ks, cv)))) (r, (unavailr, (exportr, (ks, cv))))
go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr (NE.fromList mkks)
where where
runannex = inmainrepo . annexeval runannex = inmainrepo . annexeval
mkrs = if testvariants mkrs = if testvariants