{-# 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]