miss-0: tests/Cover.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Cover (coverage) where
import qualified Data.ByteString as BS
import Data.Bifunctor (first)
import Data.List (tails)
import Data.Git.Formats
import Data.Git.Hash
import Data.Git.Internal.Types
import Data.Git.Object
import Data.Git.Ref
import Data.Git.RefName
import Data.Git.Types
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Semigroup
import Data.String
import TestUtil
-- | This exists to give coverage to some things that don't have much meaning like show instances.
-- All they really test is that we know when they change. They shouldn't show stability.
-- If any of these should be stable they should be moved to another area of the test suite.
coverage :: TestTree
coverage = testGroup "Coverage - these properties are not stable"
[ testShow "Ref"
[ (HEAD, "HEAD")
, (Branch "master", "Branch (RefName {getRefName = \"master\"})")
, (TagRef "tag" Nothing, "TagRef (RefName {getRefName = \"tag\"}) Nothing")
, (TagRef "tag" (Just $ sha1 ("sha"::BS.ByteString))
,"TagRef (RefName {getRefName = \"tag\"}) (Just (Sha1 {getSha1 = \"\\216\\244Y\\ETX \\225\\&4:\\145[c\\148\\ETB\\ACKP\\168\\243]i&\"}))")
, (RemRef "remote" "master"
,"RemRef (RemoteName {getRemoteName = \"remote\"}) (RefName {getRefName = \"master\"})")
, (ExpRef "path/this/is", "ExpRef (RefName {getRefName = \"path/this/is\"})")
]
, testShow "RefName"
[ ("remote"::RefName, "RefName {getRefName = \"remote\"}")
]
, testBottom "IsString RefName can fail" (""::RefName)
, testShow "RemoteName"
[ ("remote"::RemoteName, "RemoteName {getRemoteName = \"remote\"}")
]
, testBottom "IsString RefName can fail" (""::RemoteName)
, testOrder "ObjectType Ordering" [ BlobType, TreeType, CommitType, TagType ]
, testOrder "Blob Ordering" [Blob "", Blob "a", Blob "b"]
, testShow "Blob"
[ (Blob "", "Blob {getBlob = \"\"}"), (Blob "test", "Blob {getBlob = \"test\"}") ]
, testShow "TreeEntry"
[(Entry "this" BlobMode, "Entry {entryName = PC {getPC = \"this\"}, entryMode = BareMode 33188}")
]
, testShow "Tree"
[ (Tree mempty, "Tree {getTree = fromList []}")
]
, testOrder "Tree Ordering"
[ Tree mempty
, Tree $ Map.fromList [(Entry "file" BlobMode, sha1 (""::Blob))]
]
, testVectors "Tree Monoid" (==) $
let mkEnt nm = (Entry (fromString nm) BlobMode, sha1 (Blob (fromString nm)))
ent1 = mkEnt "file1"
ent2 = mkEnt "file2"
t1 = Tree (Map.fromList [ent1])
t2 = Tree (Map.fromList [ent2])
t12 = Tree (Map.fromList [ent1, ent2])
in [ (mempty, emptyTree)
, (t1 <> t2, t12)
, (stimes (5::Int) t1, t1)
, (sconcat (t1 :| []), t1)
, (mconcat [t1, t2], t12)
, (t1 `mappend` t2, t12)
]
, testShow "Tag"
[ (Tag (sha1 (""::Blob)) BlobType "name" (testContact, testDate) "msg"
,"Tag {tagObject = Sha1 {getSha1 = "<>
"\"\\230\\157\\226\\155\\178\\209\\214CK\\139)\\174wZ\\216\\194\\228\\140S\\145\"}, tagType = BlobType, "<>
"tagName = LfFree {getLfFree = \"name\"}, tagTagger = (Contact {contactName = SS {getSS = "<>
"\"Bob McTesterton\"}, contactEmail = SS {getSS = \"bob@mctesterton.gov\"}},(1467644623,"<>
"\"+0000\")), tagMessage = \"msg\"}")
]
, testOrder "Tag Ordering"
[ Tag (sha1 (""::Blob)) BlobType "file" (testContact, testDate) "msg"
, Tag (sha1 (""::Blob)) BlobType "name" (testContact, testDate) "msg"
, Tag (sha1 (""::Blob)) BlobType "name" (testContact, testDate) "msg1"
]
, testOrder "Commit Ordering"
[ testCommit { commitMessage = "New message" }
, testCommit
, testCommit { commitParents = [emptyTreeSha] }
]
, testShow "Commit"
[ (testCommit
,"Commit {commitTree = Sha1 {getSha1 = "<>
"\"K\\130]\\198B\\203n\\185\\160`\\229K\\248\\214\\146\\136\\251\\238I\\EOT\"}, "<>
"commitParents = [], commitAuthor = (Contact {contactName = SS {getSS = "<>
"\"Bob McTesterton\"}, contactEmail = SS {getSS = \"bob@mctesterton.gov\"}},(1467644623,"<>
"\"+0000\")), commitCommitter = (Contact {contactName = SS {getSS = \"Bob McTesterton\"}, "<>
"contactEmail = SS {getSS = \"bob@mctesterton.gov\"}},(1467644623,\"+0000\")), "<>
"commitMessage = \"msg\"}")
]
, testShow "Object"
[ (BlobObj $ Blob "", "BlobObj (Blob {getBlob = \"\"})")
, (BlobObj $ Blob "test", "BlobObj (Blob {getBlob = \"test\"})")
, (TreeObj $ Tree mempty, "TreeObj (Tree {getTree = fromList []})")
, (TagObj $ Tag (sha1 (""::Blob)) BlobType "name" (testContact, testDate) "msg"
,"TagObj (Tag {tagObject = Sha1 {getSha1 = "<>
"\"\\230\\157\\226\\155\\178\\209\\214CK\\139)\\174wZ\\216\\194\\228\\140S\\145\"}, tagType = BlobType, "<>
"tagName = LfFree {getLfFree = \"name\"}, tagTagger = (Contact {contactName = SS {getSS = "<>
"\"Bob McTesterton\"}, contactEmail = SS {getSS = \"bob@mctesterton.gov\"}},(1467644623,"<>
"\"+0000\")), tagMessage = \"msg\"})")
, (CommitObj testCommit
,"CommitObj (Commit {commitTree = Sha1 {getSha1 = "<>
"\"K\\130]\\198B\\203n\\185\\160`\\229K\\248\\214\\146\\136\\251\\238I\\EOT\"}, "<>
"commitParents = [], commitAuthor = (Contact {contactName = SS {getSS = "<>
"\"Bob McTesterton\"}, contactEmail = SS {getSS = \"bob@mctesterton.gov\"}},(1467644623,"<>
"\"+0000\")), commitCommitter = (Contact {contactName = SS {getSS = \"Bob McTesterton\"}, "<>
"contactEmail = SS {getSS = \"bob@mctesterton.gov\"}},(1467644623,\"+0000\")), "<>
"commitMessage = \"msg\"})")
]
, testBottom "makeContact can fail on name" (makeContact "<>" "")
, testBottom "makeContact can fail on email" (makeContact "" "<>")
, testOrder "Mode Ordering"
[TreeMode, BareMode 0o100643, BlobMode, ExecMode, LinkMode, SubmMode]
, testShow "Mode"
[(TreeMode, "BareMode 16384"), (BareMode 0o100643, "BareMode 33187")
,(BlobMode, "BareMode 33188"), (ExecMode, "BareMode 33261"), (LinkMode, "BareMode 40960")
,(SubmMode, "BareMode 57344")]
, testOrder "SafeString Ordering"
[mempty::SafeString, "a", "aa"<>"a", stimes (4::Int) "a", sconcat ("a" :| ["ab"])
,"a"`mappend`"bb", "b", mconcat ["ba","a"]]
, testBottom "safeString can fail" ("<>"::SafeString)
, testShow "SafeString" [(""::SafeString, "SS {getSS = \"\"}")]
, testOrder "LfFree Ordering"
[mempty::LfFree, "a", "a"<>"a", "b", sconcat ("b" :| ["a"]), stimes (3::Int) "b"
,"c", "c"`mappend`"b", mconcat ["c", "d"]]
, testBottom "lfFree can fail" ("\n"::LfFree)
, testShow "LfFree" [(""::LfFree, "LfFree {getLfFree = \"\"}")]
, testOrder "PathComponent Ordering"
["a"::PathComponent, "a"<>"a", "b", sconcat ("b" :| ["a"]), stimes (3::Int) "b", "c"]
, testBottom "pathComponent can fail" (""::PathComponent)
, testShow "PathComponent" [("a"::PathComponent, "PC {getPC = \"a\"}")]
, testVectors "slashify" (\a b -> b == slashify a) [("a"::PathComponent, "a/")]
, testVectors "utcTimeToDate" (\a b -> b == utcTimeToDate a)
[(read "1970-01-01 00:00:00 UTC", (0, "+0000"))]
, testOrder "Contact Ordering"
[ Contact "a" "", Contact "a" "b", Contact "d" "", Contact "d" "c"]
, testOrder "Sha1 Ordering" . map sha1 $
[ "test2"::BS.ByteString, "test3", "test", "test1" ]
, testOrder "Sha1hex Ordering" . map sha1hex $
[ "test2"::BS.ByteString, "test3", "test", "test1" ]
, testShow "Sha1Hex" . map (first sha1hex) $
[ ("test3"::BS.ByteString, "Sha1Hex {getSha1Hex = \"3ebfa301dc59196f18593c45e519287a23297589\"}")
, ("test" , "Sha1Hex {getSha1Hex = \"a94a8fe5ccb19ba61c4c0873d391e987982fbbd3\"}")
, ("test2", "Sha1Hex {getSha1Hex = \"109f4b3c50d7b0df729d299bc6f8e9ef9066971f\"}")
, ("test1", "Sha1Hex {getSha1Hex = \"b444ac06613fc8d63795be9ad0beaf55011936ac\"}")
]
, testOrder "RefFile Ordering"
[ ShaRef (sha1 ("test2"::BS.ByteString)), ShaRef (sha1 ("test3"::BS.ByteString))
, SymRef HEAD, SymRef (ExpRef "path")
]
, testShow "RefFile"
[ (ShaRef (sha1 ("test2"::BS.ByteString))
,"ShaRef (Sha1 {getSha1 = \"\\DLE\\159K<P\\215\\176\\223r\\157)\\155\\198\\248\\233\\239\\144f\\151\\US\"})")
, (ShaRef (sha1 ("test3"::BS.ByteString))
,"ShaRef (Sha1 {getSha1 = \">\\191\\163\\SOH\\220Y\\EMo\\CANY<E\\229\\EM(z#)u\\137\"})")
, (SymRef HEAD, "SymRef HEAD")
, (SymRef (ExpRef "path"), "SymRef (ExpRef (RefName {getRefName = \"path\"}))")
]
, testOrder "RefName" . mapMaybe refName $
[ "", "a", "b" ]
, testOrder "RemoteName" . mapMaybe remoteName $
[ "", "a", "b" ]
, testShow "PackIndex"
[ (PackIndex mempty mempty mempty mempty mempty
,"PackIndex {fanout = [], indexShas = [], shaCrcs = [], shaOffsets = [], shaBigOffsets = []}")
]
, testShow "PackFile"
[ (PackFile mempty (PackIndex mempty mempty mempty mempty mempty)
,"PackFile {getPackFile = \"\", getIndex = PackIndex {fanout = [], indexShas = [], shaCrcs = [], shaOffsets = [], shaBigOffsets = []}}")
]
, testVectors "FromString Blob" (==)
[ (Blob "This is a string", "This is a string")
]
, testCase "Contact accessors" $ do
contactName testContact @?= "Bob McTesterton"
contactEmail testContact @?= "bob@mctesterton.gov"
, testCase "Commit accessors" $ do
commitTree testCommit @?= emptyTreeSha
commitParents testCommit @?= []
commitAuthor testCommit @?= (testContact, testDate)
commitCommitter testCommit @?= (testContact, testDate)
commitMessage testCommit @?= "msg"
, testCase "TreeEntry accessors" $ do
let te = Entry "file" BlobMode
entryName te @?= "file"
entryMode te @?= BlobMode
, testCase "Tag accessors" $ do
tagObject testTag @?= emptyTreeSha
tagType testTag @?= TreeType
tagName testTag @?= "the-tag"
tagTagger testTag @?= (testContact, testDate)
tagMessage testTag @?= "the message"
]
testShow :: Show a => TestName -> [(a, String)] -> TestTree
testShow name = testVectors name (\a str -> str == show a)
testOrder :: (Ord a, Show a) => TestName -> [a] -> TestTree
testOrder name ord = testCase name . assertBool "Some Ord issues" . and . concat $
[ map (\a -> a == a) ord
, map (uncurry (/=)) (allPairs ord)
, map (uncurry (<)) (allPairs ord)
, map (uncurry (<=)) (allPairs ord)
, map (uncurry (>)) (allPairs $ reverse ord)
, map (uncurry (>=)) (allPairs $ reverse ord)
, map (\(a, b) -> LT == compare a b) (allPairs ord)
, map (\(a, b) -> a == min a b) (allPairs ord)
, map (\(a, b) -> b == max a b) (allPairs ord)
]
where
allPairs :: [a] -> [(a, a)]
allPairs l = [(x,y) | (x:ys) <- tails l, y <- ys]