Skip to content

Commit

Permalink
head 2024-12-20 16:08:39+00:00
Browse files Browse the repository at this point in the history
  • Loading branch information
@bfrk
bfrk committed Dec 20, 2024
1 parent 1a9dad2 commit 394b26b
Show file tree
Hide file tree
Showing 246 changed files with 7,755 additions and 4,089 deletions.
76 changes: 46 additions & 30 deletions darcs.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -178,6 +178,7 @@ Library
Darcs.Patch.Prim.FileUUID.Commute
Darcs.Patch.Prim.FileUUID.Core
Darcs.Patch.Prim.FileUUID.Details
Darcs.Patch.Prim.FileUUID.Format
Darcs.Patch.Prim.FileUUID.ObjectMap
Darcs.Patch.Prim.FileUUID.Read
Darcs.Patch.Prim.FileUUID.Show
Expand All @@ -188,6 +189,7 @@ Library
Darcs.Patch.Prim.V1.Commute
Darcs.Patch.Prim.V1.Core
Darcs.Patch.Prim.V1.Details
Darcs.Patch.Prim.V1.Format
Darcs.Patch.Prim.V1.Mangle
Darcs.Patch.Prim.V1.Read
Darcs.Patch.Prim.V1.Show
Expand Down Expand Up @@ -216,6 +218,7 @@ Library
Darcs.Patch.V1.Apply
Darcs.Patch.V1.Commute
Darcs.Patch.V1.Core
Darcs.Patch.V1.Format
Darcs.Patch.V1.Prim
Darcs.Patch.V1.Read
Darcs.Patch.V1.Show
Expand Down Expand Up @@ -354,14 +357,16 @@ Library
Darcs.Util.Exception
Darcs.Util.Exec
Darcs.Util.File
Darcs.Util.Format
Darcs.Util.Global
Darcs.Util.Graph
Darcs.Util.Hash
Darcs.Util.HTTP
Darcs.Util.Index
Darcs.Util.IndexedMonad
Darcs.Util.IsoDate
Darcs.Util.Lock
Darcs.Util.ObjectStore
Darcs.Util.ObjectStore.Utils
Darcs.Util.Parser
Darcs.Util.Path
Darcs.Util.Printer
Expand All @@ -375,7 +380,9 @@ Library
Darcs.Util.Ssh
Darcs.Util.StrictIdentity
Darcs.Util.Tree
Darcs.Util.Tree.Diff
Darcs.Util.Tree.Hashed
Darcs.Util.Tree.Index
Darcs.Util.Tree.Monad
Darcs.Util.Tree.Plain
Darcs.Util.URL
Expand Down Expand Up @@ -457,7 +464,6 @@ Library
zlib >= 0.6.1.2 && < 0.8,
xml >= 1.3.14 && < 1.4,
network-uri >= 2.6 && < 2.8,
network >= 2.6 && < 3.3,
conduit >= 1.3.0 && < 1.4,
http-conduit >= 2.3 && < 2.4,
http-types >= 0.12.1 && < 0.12.5,
Expand All @@ -480,6 +486,7 @@ Library
ghc-options: -Werror

ghc-options: -Wall -funbox-strict-fields -fwarn-tabs
ghc-options: -Wredundant-constraints

-- It's a deliberate choice to use NoMonoLocalBinds and tolerate this warning long-term,
-- as otherwise we'd need 10s of extra type signatures in our code.
Expand Down Expand Up @@ -544,6 +551,7 @@ Executable darcs
ghc-options: -Werror

ghc-options: -Wall -funbox-strict-fields -fwarn-tabs
ghc-options: -Wredundant-constraints

if flag(threaded)
ghc-options: -threaded
Expand Down Expand Up @@ -595,13 +603,16 @@ test-suite darcs-test
quickcheck-instances >= 0.3.29.1 && < 0.4,
leancheck >= 0.9 && < 1.1,
HUnit >= 1.3 && < 1.7,
test-framework >= 0.8.1.1 && < 0.9,
test-framework-hunit >= 0.3.0.2 && < 0.4,
test-framework-quickcheck2 >= 0.3.0.3 && < 0.4,
test-framework-leancheck >= 0.0.1 && < 0.1,
tasty >= 1.4.3 && < 1.5,
tasty-hunit >= 0.10.1 && < 0.11,
tasty-quickcheck >= 0.10.2 && < 0.11,
tasty-leancheck >= 0.0.2 && < 0.1,
tagged >= 0.8.8 && < 0.9,
vector,
zip-archive,
shelly,
ansi-terminal,
terminal-size,

-- the tests shell out to a built darcs binary, so we depend on it to make
-- sure that it's built. It's not actually required for build, just at runtime,
Expand All @@ -612,50 +623,52 @@ test-suite darcs-test
-- include them in the tarball
other-modules: Darcs.Test.Email
Darcs.Test.HashedStorage
Darcs.Test.Patch.Check
Darcs.Test.Patch.Depends
Darcs.Test.Patch.Examples.Set1
Darcs.Test.Patch.Examples.Set2
Darcs.Test.Patch.Examples.Unwind
Darcs.Test.Patch.Info
Darcs.Test.Patch.Properties
Darcs.Test.Patch.Properties.V1Set1
Darcs.Test.Patch.Properties.V1Set2
Darcs.Test.Patch.Properties.Generic
Darcs.Test.Patch.Properties.Check
Darcs.Test.Patch.Properties.Mergeable
Darcs.Test.Patch.Properties.RepoPatchV3
Darcs.Test.Misc
Darcs.Test.Misc.CommandLine
Darcs.Test.Misc.Encoding
Darcs.Test.Misc.Graph
Darcs.Test.Misc.URL
Darcs.Test.Patch
Darcs.Test.Patch.Arbitrary.Generic
Darcs.Test.Patch.Arbitrary.Mergeable
Darcs.Test.Patch.Arbitrary.Named
Darcs.Test.Patch.Arbitrary.NamedPrim
Darcs.Test.Patch.Arbitrary.PatchTree
Darcs.Test.Patch.Arbitrary.PrimFileUUID
Darcs.Test.Patch.Arbitrary.PrimV1
Darcs.Test.Patch.Arbitrary.Mergeable
Darcs.Test.Patch.Arbitrary.RepoPatchV1
Darcs.Test.Patch.Arbitrary.RepoPatchV2
Darcs.Test.Patch.Arbitrary.RepoPatchV3
Darcs.Test.Patch.Arbitrary.Sealed
Darcs.Test.Patch.Arbitrary.Shrink
Darcs.Test.Patch.Binary
Darcs.Test.Patch.ChangePref
Darcs.Test.Patch.Check
Darcs.Test.Patch.Depends
Darcs.Test.Patch.Examples.Set1
Darcs.Test.Patch.Examples.Set2
Darcs.Test.Patch.Examples.Unwind
Darcs.Test.Patch.FileUUIDModel
Darcs.Test.Patch.Info
Darcs.Test.Patch.Merge.Checked
Darcs.Test.Patch.Properties
Darcs.Test.Patch.Properties.Check
Darcs.Test.Patch.Properties.Generic
Darcs.Test.Patch.Properties.Mergeable
Darcs.Test.Patch.Properties.RepoPatchV3
Darcs.Test.Patch.Properties.V1Set1
Darcs.Test.Patch.Properties.V1Set2
Darcs.Test.Patch.Rebase
Darcs.Test.Patch.RepoModel
Darcs.Test.Patch.Selection
Darcs.Test.Patch.Utils
Darcs.Test.Patch.V1Model
Darcs.Test.Patch.FileUUIDModel
Darcs.Test.Patch.Types.MergeableSequence
Darcs.Test.Patch.Types.Merged
Darcs.Test.Patch.Types.Pair
Darcs.Test.Patch.Types.Triple
Darcs.Test.Patch.Unwind
Darcs.Test.Patch.Utils
Darcs.Test.Patch.V1Model
Darcs.Test.Patch.WithState
Darcs.Test.Patch
Darcs.Test.Misc
Darcs.Test.Misc.CommandLine
Darcs.Test.Misc.Encoding
Darcs.Test.Misc.Graph
Darcs.Test.Misc.URL
Darcs.Test.Repository.Inventory
Darcs.Test.Shell
Darcs.Test.TestOnly.Instance
Expand All @@ -665,13 +678,16 @@ test-suite darcs-test
Darcs.Test.UI.Commands.Test.Commutable
Darcs.Test.UI.Commands.Test.IndexedApply
Darcs.Test.UI.Commands.Test.Simple
Darcs.Test.Util.TestResult
Darcs.Test.Util.ConsoleFormat
Darcs.Test.Util.ConsoleReporter
Darcs.Test.Util.QuickCheck
Darcs.Test.Util.TestResult

if flag(warn-as-error)
ghc-options: -Werror

ghc-options: -Wall -funbox-strict-fields -fwarn-tabs
ghc-options: -Wredundant-constraints

if impl(ghc >= 9.4.1)
ghc-options: -Wno-gadt-mono-local-binds
Expand Down
32 changes: 16 additions & 16 deletions harness/Darcs/Test/Email.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,16 +30,16 @@ import Data.Char ( isPrint )
import qualified Data.ByteString as B ( length, unpack, null, head,
cons, empty, foldr, ByteString )
import qualified Data.ByteString.Char8 as BC ( unlines )
import Test.Framework ( Test, testGroup )
import Test.Framework.Providers.QuickCheck2 ( testProperty )
import Test.Tasty ( TestTree, testGroup )
import Test.Tasty.QuickCheck ( testProperty )
import Test.QuickCheck.Instances.ByteString ()

import Darcs.Util.Printer ( text, renderPS, packedString )
import Darcs.UI.Email ( makeEmail, readEmail, formatHeader, prop_qp_roundtrip )
import Safe ( tailErr )

testSuite :: Test
testSuite = testGroup "Darcs.Email"
testSuite :: TestTree
testSuite = testGroup "Darcs.UI.Email"
[ emailParsing
, emailHeaderNoLongLines
, emailHeaderAsciiChars
Expand All @@ -49,8 +49,8 @@ testSuite = testGroup "Darcs.Email"
]

-- | Checks that darcs can read the emails it generates
emailParsing :: Test
emailParsing = testProperty "Checking that email can be parsed" $ \bs ->
emailParsing :: TestTree
emailParsing = testProperty "email can be parsed" $ \bs ->
BC.unlines (B.empty:bs++[B.empty,B.empty]) ==
readEmail (renderPS
$ makeEmail "reponame" [] (Just (text "contents\n"))
Expand All @@ -59,40 +59,40 @@ emailParsing = testProperty "Checking that email can be parsed" $ \bs ->

-- | Check that formatHeader never creates lines longer than 78 characters
-- (excluding the carriage return and line feed)
emailHeaderNoLongLines :: Test
emailHeaderNoLongLines :: TestTree
emailHeaderNoLongLines =
testProperty "Checking email header line length" $ \field value ->
testProperty "email header line length" $ \field value ->
let cleanField = cleanFieldString field
in not $ any (>78) $ map B.length $ bsLines $ formatHeader cleanField value

-- Check that an email header does not contain non-ASCII characters
-- formatHeader doesn't escape field names, there is no such thing as non-ascii
-- field names afaik
emailHeaderAsciiChars :: Test
emailHeaderAsciiChars :: TestTree
emailHeaderAsciiChars =
testProperty "Checking email for illegal characters" $ \field value ->
testProperty "no illegal characters" $ \field value ->
let cleanField = cleanFieldString field
in not (any (>127) (B.unpack (formatHeader cleanField value)))

-- Check that header the second and later lines of a header start with a space
emailHeaderLinesStart :: Test
emailHeaderLinesStart :: TestTree
emailHeaderLinesStart =
testProperty "Checking for spaces at start of folded email header lines" $ \field value ->
testProperty "spaces at start of folded email header lines" $ \field value ->
let headerLines = bsLines (formatHeader cleanField value)
cleanField = cleanFieldString field
in all (\l -> B.null l || B.head l == 32) (tailErr headerLines)

-- Checks that there are no lines in email headers with only whitespace
emailHeaderNoEmptyLines :: Test
emailHeaderNoEmptyLines :: TestTree
emailHeaderNoEmptyLines =
testProperty "Checking that there are no empty lines in email headers" $ \field value ->
testProperty "no empty lines in email headers" $ \field value ->
let headerLines = bsLines (formatHeader cleanField value)
cleanField = cleanFieldString field
in all (not . B.null) headerLines --(not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines

emailCodecRoundtrip :: Test
emailCodecRoundtrip :: TestTree
emailCodecRoundtrip =
testProperty "Checking that quoted printable en- then decoding is id" $ prop_qp_roundtrip
testProperty "quoted printable en- then decoding is id" $ prop_qp_roundtrip

bsLines :: B.ByteString -> [B.ByteString]
bsLines = finalizeFold . B.foldr splitAtLines (B.empty, [])
Expand Down
34 changes: 17 additions & 17 deletions harness/Darcs/Test/HashedStorage.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,7 +22,7 @@ import Darcs.Util.Cache ( mkRepoCache )
import Darcs.Util.Path hiding ( setCurrentDirectory )
import Darcs.Util.Lock ( withPermDir )
import Darcs.Util.Tree hiding ( lookup )
import Darcs.Util.Index
import Darcs.Util.Tree.Index
import Darcs.Util.Tree.Hashed
import Darcs.Util.Hash
import Darcs.Util.Tree.Monad hiding ( tree, createDirectory )
Expand All @@ -32,14 +32,12 @@ import System.Mem( performGC )

import qualified Data.Set as S

import Test.HUnit hiding ( path )
import Test.Framework( testGroup )
import qualified Test.Framework as TF ( Test )
import Test.Tasty( TestTree, testGroup )
import Test.QuickCheck
import Test.QuickCheck.Instances.ByteString ()

import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck

------------------------
-- Test Data
Expand Down Expand Up @@ -94,18 +92,20 @@ equals_testdata t = sequence_ [
-- Test list
--

tests :: [TF.Test]
tests = [ testGroup "Darcs.Util.Hash" hash
, testGroup "Darcs.Util.Tree" tree
, testGroup "Darcs.Util.Index" index
, testGroup "Darcs.Util.Tree.Monad" monad
, testGroup "Hashed Storage" hashed ]
tests :: [TestTree]
tests =
[ testGroup "Darcs.Util.Hash" hash
, testGroup "Darcs.Util.Tree" tree
, testGroup "Darcs.Util.Tree.Index" index
, testGroup "Darcs.Util.Tree.Monad" monad
, testGroup "Plain and Pristine Trees" hashed
]

--------------------------
-- Tests
--

hashed :: [TF.Test]
hashed :: [TestTree]
hashed = [ testCase "plain has all files" have_files
, testCase "pristine has all files" have_pristine_files
, testCase "pristine has no extras" pristine_no_extra
Expand Down Expand Up @@ -143,7 +143,7 @@ hashed = [ testCase "plain has all files" have_files
t <- expand =<< readPlainTree "_darcs/plain"
equals_testdata t

index :: [TF.Test]
index :: [TestTree]
index = [ testCase "index versioning" check_index_versions
, testCase "index listing" check_index
, testCase "index content" check_index_content
Expand Down Expand Up @@ -183,7 +183,7 @@ index = [ testCase "index versioning" check_index_versions
align bound x `rem` bound == 0
where _types = (bound, x) :: (Int, Int)

tree :: [TF.Test]
tree :: [TestTree]
tree = [ testCase "modifyTree" check_modify
, testCase "complex modifyTree" check_modify_complex
, testCase "modifyTree removal" check_modify_remove
Expand Down Expand Up @@ -342,11 +342,11 @@ tree = [ testCase "modifyTree" check_modify
notStub Nothing = error "Did not exist."
notStub _ = True

hash :: [TF.Test]
hash :: [TestTree]
hash = [ testProperty "decodeBase16 . encodeBase16 == Just" prop_base16 ]
where prop_base16 x = (decodeBase16 . encodeBase16) x == Just x

monad :: [TF.Test]
monad :: [TestTree]
monad = [ testCase "path expansion" check_virtual
, testCase "rename" check_rename ]
where check_virtual = virtualTreeMonad run testTree >> return ()
Expand Down
Loading

0 comments on commit 394b26b

Please sign in to comment.