{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ViewPatterns               #-}

{-# OPTIONS_HADDOCK not-home #-}

-- | Internal object stuff.

module Data.Git.Internal.Object where

import           Control.Applicative
import           Control.Monad
import           Data.Attoparsec.ByteString.Lazy as A
import           Data.Bits
import qualified Data.ByteString         as B
import           Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy    as BL
import           Data.Git.Formats
import           Data.Git.Hash
import           Data.Git.Internal.Parsers
import           Data.Git.Types
import           Data.Map                (Map)
import qualified Data.Map                as M
import           Data.Semigroup
import           Data.String

-- | Objects can be blobs, trees, commits, or tags.
data ObjectType = BlobType | TreeType | CommitType | TagType
             deriving (Eq, Ord, Show)

-- | A blob is just some data.
newtype Blob = Blob { getBlob :: BL.ByteString }
    deriving (Eq, Ord, Show)

instance HasSha1 Blob where
    sha1 = sha1 . BlobObj

instance IsString Blob where
    fromString = Blob . fromString

-- | 'Tree's are composed of entries, each of which has a name and a 'Mode', which determines what
--   kind of thing it is.
data TreeEntry = Entry {
      entryName :: PathComponent
    , entryMode :: Mode
    } deriving (Eq, Show)

instance Ord TreeEntry where
    compare (Entry b TreeMode) (Entry b' TreeMode) = slashify b `compare` slashify b'
    compare (Entry b TreeMode) (Entry b' _) = slashify b `compare` getPC b'
    compare (Entry b _) (Entry b' TreeMode) = getPC b `compare` slashify b'
    compare (Entry b m) (Entry b' m')       = (b,m) `compare` (b', m')

-- | 'Tree's map 'TreeEntry's to the 'Sha1's of objects.
newtype Tree = Tree { getTree :: Map TreeEntry Sha1 }
    deriving (Eq, Ord, Show, Semigroup, Monoid)

instance HasSha1 Tree where
    sha1 = sha1 . TreeObj

-- | A 'Commit' must point to the 'Sha1' of a 'Tree', and can have 0 or more parents (each of which
--   are 'Commit's).  A commit with 0 parents is the initial commit in a repo, a commit with 1
--   parent is a normal commit, and a commit with more than 1 parent is a merge commit.
data Commit = Commit {
      commitTree      :: Sha1
    , commitParents   :: [Sha1]
    , commitAuthor    :: (Contact, Date)
    , commitCommitter :: (Contact, Date)
    , commitMessage   :: BL.ByteString
    } deriving (Eq, Ord, Show)

instance HasSha1 Commit where
    sha1 = sha1 . CommitObj

-- | An 'Object' can be a 'Blob', a 'Tree', a 'Commit', or a 'Tag'.
data Object = BlobObj   Blob
            | TreeObj   Tree
            | CommitObj Commit
            | TagObj    Tag
              deriving (Eq, Ord, Show)

instance HasSha1 Object where
    sha1 = sha1 . BB.toLazyByteString . buildLooseObject

-- | A 'Tag' can point to anything, but should probably point to a 'Commit'.
data Tag = Tag {
      tagObject  :: Sha1
    , tagType    :: ObjectType
    , tagName    :: LfFree
    , tagTagger  :: (Contact, Date)
    , tagMessage :: BL.ByteString
    } deriving (Eq, Ord, Show)

instance HasSha1 Tag where
    sha1 = sha1 . TagObj

-- | Build a 'Blob'.
buildBlob :: Blob -> Builder
buildBlob = BB.lazyByteString . getBlob

-- | Build a 'Tree'
buildTree :: Tree -> Builder
buildTree = foldMap buildTreeEntry . M.toAscList . getTree

-- | The empty 'Tree'
emptyTree :: Tree
emptyTree = Tree mempty

-- | The 'Sha1' of the empty 'Tree'
emptyTreeSha :: Sha1
emptyTreeSha = sha1 emptyTree

-- | Build a 'Commit'.
buildCommit :: Commit -> Builder
buildCommit (Commit tree parents author committer message) =
    "tree " <> buildHexSha1 tree <> lfB
    <> foldMap (\p -> "parent " <> buildHexSha1 p <> lfB) parents
    <> "author " <> buildContactAndDate author
    <> "committer " <> buildContactAndDate committer
    <> lfB
    <> BB.lazyByteString message

-- | Build a 'Tag'.
buildTag :: Tag -> Builder
buildTag (Tag object objType name tagger message) =
    "object " <> buildHexSha1 object <> lfB
    <> "type " <> buildObjType objType <> lfB
    <> "tag "  <> BB.byteString (getLfFree name) <> lfB
    <> "tagger " <> buildContactAndDate tagger <> lfB
    <> lfB
    <> BB.lazyByteString message

buildObjType :: ObjectType -> Builder
buildObjType BlobType   = "blob"
buildObjType TreeType   = "tree"
buildObjType CommitType = "commit"
buildObjType TagType    = "tag"

buildTreeEntry :: (TreeEntry, Sha1) -> Builder
buildTreeEntry (Entry b m, s) = buildMode m <> " " <> BB.byteString (getPC b) <> BB.word8 0 <> buildSha1 s

-- | A 'Builder' for 'Mode', special cased on the common cases.
buildMode :: Mode -> Builder
buildMode BlobMode     = "100644"
buildMode ExecMode     = "100755"
buildMode TreeMode     = "40000"
buildMode SubmMode     = "160000"
buildMode LinkMode     = "120000"
buildMode (BareMode m) = fastOct m
    where fastOct n | n < 8 = {-# SCC "fastOct/val" #-} BB.word8Dec (fromIntegral n)
                    | otherwise = {-# SCC "fastOct/digit" #-} fastOct q <> BB.word8Dec (fromIntegral r)
              where (q, r) = {-# SCC "fastOct/quoteRem" #-} n `quotRem` 8
          {-# INLINE fastOct #-}

buildSha1 :: Sha1 -> Builder
buildSha1 = BB.byteString . getSha1

buildSha1Hex :: Sha1Hex -> Builder
buildSha1Hex = BB.byteString . getSha1Hex

-- Naming is really hard
buildHexSha1 :: Sha1 -> Builder
buildHexSha1 = buildSha1Hex . toHex

lfB :: Builder
lfB = BB.word8 0x0a

buildDate :: Date -> Builder
buildDate (n, tz) = BB.intDec n <> " " <> BB.byteString tz

buildContactAndDate :: (Contact, Date) -> Builder
buildContactAndDate (Contact name email, d) =
    BB.byteString (getSS name) <> " <" <> BB.byteString (getSS email) <> "> " <> buildDate d <> lfB

-- | Build an 'Object'.
buildObject :: Object -> Builder
buildObject (BlobObj   b) = buildBlob   b
buildObject (TreeObj   t) = buildTree   t
buildObject (CommitObj c) = buildCommit c
buildObject (TagObj    t) = buildTag    t

--- TODO: Suck less
suck :: Builder -> Builder -> Builder
suck t b = t <> BB.int64Dec (BL.length b') <> BB.word8 0 <> BB.lazyByteString b'
    where b' = BB.toLazyByteString b

-- | Build a loose 'Object'.
buildLooseObject :: Object -> Builder
buildLooseObject (BlobObj   b) = suck "blob "   (buildBlob   b)
buildLooseObject (TreeObj   t) = suck "tree "   (buildTree   t)
buildLooseObject (CommitObj c) = suck "commit " (buildCommit c)
buildLooseObject (TagObj    t) = suck "tag "    (buildTag    t)

parseBlob :: Parser Blob
parseBlob = Blob <$ looseHeader BlobType <*> takeLazyByteString

parseTreeEntry :: Parser (TreeEntry, Sha1)
parseTreeEntry = do mode <- parseMode <* space
                    name <- maybe (fail "bad path name") pure =<< (pathComponent <$> (takeTill (==0) <* nullByte))
                    sha  <- parseSha1
                    return (Entry name mode, sha)

parseTree :: Parser Tree
parseTree = do looseHeader TreeType
               ents <- many parseTreeEntry
               return . Tree . M.fromList $ ents

parseCommit :: Parser Commit
parseCommit = do looseHeader CommitType
                 tree      <- "tree "          *> parseSha1Hex <* lf
                 parents   <- many $ "parent " *> parseSha1Hex <* lf
                 author    <- "author "        *> parseContactAndDate
                 committer <- "committer "     *> parseContactAndDate
                 lf
                 message   <- takeLazyByteString
                 return $ Commit tree parents author committer message

parseTag :: Parser Tag
parseTag = do looseHeader TagType
              object  <- "object " *> parseSha1Hex <* lf
              objType <- "type "   *> parseObjectType <* lf
              Just name    <- "tag "    *> (lfFree <$> takeTill (==0x0a)) <* lf
              tagger  <- "tagger " *> parseContactAndDate <* lf
              lf
              message <- takeLazyByteString
              return $ Tag object objType name tagger message

parseObjectType :: Parser ObjectType
parseObjectType =     "blob"   *> pure BlobType
                  <|> "tree"   *> pure TreeType
                  <|> "commit" *> pure CommitType
                  <|> "tag"    *> pure TagType

skipRestOfHeader :: Parser ()
skipRestOfHeader = skipWhile (/=0x00) *> void anyWord8

looseHeader :: ObjectType -> Parser ()
looseHeader BlobType   = "blob "   *> skipRestOfHeader
looseHeader TreeType   = "tree "   *> skipRestOfHeader
looseHeader CommitType = "commit " *> skipRestOfHeader
looseHeader TagType    = "tag "    *> skipRestOfHeader

parseMode :: Parser Mode
parseMode = BareMode . B.foldl' go 0 <$> takeWhile1 isOctal
    where isOctal n = 48 <= n && n <= 56
          go acc  n = (acc `unsafeShiftL` 3) .|. (fromIntegral n - 48)

parseContactAndDate :: Parser (Contact, Date)
parseContactAndDate = (,) <$> parseContact <*> parseDate

parseObject :: Parser Object
parseObject =     BlobObj   <$> parseBlob
              <|> TreeObj   <$> parseTree
              <|> CommitObj <$> parseCommit
              <|> TagObj    <$> parseTag