Changes.hs

{-# LANGUAGE GADTs, RankNTypes, FlexibleContexts, TypeFamilies, CPP #-}
module DarcsDen.Handler.Repository.Changes where

import Darcs.Patch.PatchInfoAnd (PatchInfoAnd, info)
import Darcs.Patch.Info (PatchInfo(..), piDate, makeFilename)
import Darcs.Patch.Patchy (Commute(..))
import Darcs.Patch.Permutations (commuteWhatWeCanFL)
import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..))
-- import Darcs.Patch.Patchy ( Patchy )
-- import Darcs.Patch.Prim.Class ( FromPrim(..), PrimPatch)
import Darcs.Patch.Prim.Class (PrimPatchBase(..))
#ifdef DARCS28
import Darcs.Patch.FileName (fn2fp)
import Darcs.Witnesses.Ordered
import qualified Darcs.Witnesses.Ordered as WO
#else
import Darcs.Util.Path (fn2fp)
import Darcs.Patch.Rebase.NameHack ( NameHack(..) )
import Darcs.Patch.Witnesses.Ordered
import qualified Darcs.Patch.Witnesses.Ordered as WO
import Darcs.Repository.Flags
#endif
import Data.List (isPrefixOf, nub)
import Data.Time (UTCTime, readTime)
import System.Locale (defaultTimeLocale)
import System.Time (calendarTimeToString)
import qualified Darcs.Patch as P
import qualified Darcs.Repository as R
import qualified Data.ByteString as BS

import DarcsDen.Handler.Repository.Util
import DarcsDen.State.User
import DarcsDen.Util

--instance PrimPatch Prim
--instance Patchy Prim
--instance PrimPatchBase Prim where
--  type PrimOf Prim = Prim
--
--instance FromPrim Prim where
--  fromPrim = id


data Summary
    = Removed FilePath
    | Added FilePath
    | Replaced FilePath String String
    | Modified FilePath
    | Preference String String String
    deriving (Eq, Show)

data PatchLog =
    PatchLog
        { pID :: String
        , pDate :: UTCTime
        , pName :: String
        , pAuthor :: String
        , pIsUser :: Bool
        , pLog :: String
        , pDepends :: [String]
        }
    deriving (Eq, Show)


data PatchChange
    = Moved
        { cmFrom :: FilePath
        , cmTo :: FilePath
        }
    | DirChange
        { cdName :: FilePath
        , cdType :: DirChange
        }
    | FileChange
        { cfName :: FilePath
        , cfType :: FileChange
        }
    | PrefChange
        { cpName :: String
        , cpFrom :: String
        , cpTo :: String
        }
    deriving (Eq, Show)

data DirChange
    = DirRemoved
    | DirAdded
    deriving (Eq, Show)

data FileChange
    = FileRemoved
    | FileAdded
    | FileHunk
        { fchLine :: Int
        , fchRemove :: BS.ByteString
        , fchAdd :: BS.ByteString
        }
    | FileBinary
    | FileReplace
        { fchFind :: String
        , fchReplace :: String
        }
    deriving (Eq, Show)

data PatchChanges =
    PatchChanges
        { pPatch :: PatchLog
        , pChanges :: [PatchChange]
        }
    deriving (Eq, Show)


toLog :: (PatchInfo, [PatchInfo]) -> PatchLog
toLog (i, ds) =
    PatchLog
        (take 20 $ makeFilename i)
        (readTime defaultTimeLocale "%c" (calendarTimeToString (piDate i)))
        (fromBS $ _piName i)
        (fromBS $ _piAuthor i)
        False
        (doMarkdown . unlines . filter (not . ("Ignore-this" `isPrefixOf`)) . map fromBS $ _piLog i)
        (map (take 20 . makeFilename) ds)

findUsers :: [PatchLog] -> IO [PatchLog]
findUsers = findUsers' []
  where
    findUsers' :: [(String, Maybe String)] -> [PatchLog] -> IO [PatchLog]
    findUsers' _ [] = return []
    findUsers' checked (p:ps) =
        case lookup (pAuthor p) checked of
            Just (Just n) -> do
                rest <- findUsers' checked ps
                return (p { pAuthor = n, pIsUser = True } : rest)
            Just Nothing -> do
                rest <- findUsers' checked ps
                return (p { pAuthor = safeAuthorFrom (pAuthor p) } : rest)
            Nothing -> do
                mu <- getUserByEmail (emailFrom (pAuthor p))
                case mu of
                    Just u -> do
                        rest <- findUsers' ((pAuthor p, Just (uName u)) : checked) ps
                        return (p { pAuthor = uName u, pIsUser = True } : rest)
                    Nothing -> do
                        rest <- findUsers' ((pAuthor p, Nothing) : checked) ps
                        return (p { pAuthor = safeAuthorFrom (pAuthor p) } : rest)

toChanges :: ((PatchInfo, [PatchInfo]), [PatchChange])  -> PatchChanges
toChanges (p, changes) =
    PatchChanges (toLog p) (simplify [] changes)
  where
    simplify a [] = reverse a
    simplify a (c@(FileChange n t):cs)
        | t == FileBinary =
            simplify (c:filter (notFile n) a) (filter (notFile n) cs)
    simplify a (c@(FileChange _ (FileReplace _ _)):cs) =
        simplify (c:a) cs
    simplify a (FileChange n (FileHunk l f t):cs) =
        simplify (FileChange n (FileHunk l (highlight False n f) (highlight False n t)):a) cs
    simplify a (c@(FileChange _ _):cs) = simplify (c:a) cs
    simplify a (c@(PrefChange _ _ _):cs) = simplify (c:a) cs
    simplify a (_:cs) = simplify a cs

    notFile n (FileChange { cfName = n' })
        | n == n' = False
    notFile _ _ = True

primToChange :: Prim x y -> PatchChange
primToChange (Move f t) = Moved (drop 2 $ fn2fp f) (drop 2 $ fn2fp t)
primToChange (DP f t) = DirChange (drop 2 $ fn2fp f) (fromDP t)
primToChange (FP f t) = FileChange (drop 2 $ fn2fp f) (fromFP t)
primToChange (ChangePref n f t) = PrefChange n f t
-- primToChange a = error ("primToChange not supported for " ++ show a)

fromDP :: DirPatchType x y -> DirChange
fromDP RmDir = DirRemoved
fromDP AddDir = DirAdded

fromFP :: FilePatchType x y -> FileChange
fromFP RmFile = FileRemoved
fromFP AddFile = FileAdded
fromFP (Hunk l rs as) = FileHunk l (unlinesBS rs) (unlinesBS as)
  where
    unlinesBS = BS.concat . map (`BS.append` toBS "\n") 
fromFP (Binary _ _) = FileBinary
fromFP (TokReplace _ f r) = FileReplace f r

getChanges :: String -> Int -> IO ([PatchLog], Int)
#ifdef DARCS28
getChanges dir page = R.withRepositoryDirectory [] dir $ R.RepoJob $ \dr -> do
#else
getChanges dir page = R.withRepositoryDirectory YesUseCache dir $ R.RepoJob $ \dr -> do
#endif
    pset <- R.readRepo dr

    let ps = fromPS (\np -> (P.patch2patchinfo np, P.getdeps np)) pset
        patches = map toLog (paginate 30 page ps)

    prettyLog <- findUsers patches

    return
        ( prettyLog
        , ceiling ((fromIntegral (length ps) :: Double) / 30)
        )

getPatch :: String -> String -> IO (Maybe PatchChanges)
#ifdef DARCS28
getPatch dir patch = R.withRepositoryDirectory [] dir $ R.PrimV1Job $ \dr -> do
#else
getPatch dir patch = R.withRepositoryDirectory YesUseCache dir $ R.PrimV1Job $ \dr -> do
#endif
    pset <- R.readRepo dr

    let ps = fromPS makeList pset
        ps' = filter (\(n, _) -> take 20 n == patch) ps
    case ps' of
        [] -> return Nothing
        ((_, p):_) -> do
            let cs = toChanges p
            [l] <- findUsers [pPatch cs]
            return $ Just cs{pPatch = l}

makeList :: (P.Effect p, PrimOf p ~ Prim)
         => P.Named p x y
         -> (String, ((PatchInfo,[PatchInfo]), [PatchChange]))
makeList np =
 (P.patchname np,
    ((P.patch2patchinfo np, P.getdeps np), domap np))

domap :: (P.Effect p, PrimOf p ~ Prim)
      => P.Named p x y
      -> [PatchChange]
domap np = WO.mapFL primToChange $ (P.effect np)

--domap2 :: (P.Effect p)
--       => P.Named p x y
--       -> FL (forall a b . Prim a b) x y
--domap2 np = WO.mapFL_FL fromPrim (P.effect np)

fromPS :: P.RepoPatch p => (forall x0 y0 . P.Named p x0 y0 -> b) -> R.PatchSet p x1 y1 -> [b]
fromPS f = WO.mapRL f . WO.reverseFL . R.patchSetToPatches

summarize :: [PatchChange] -> [Summary]
summarize = nub . summarize'
  where
    summarize' [] = []
    summarize' (FileChange n FileRemoved:cs) = (Removed n) : summarize cs
    summarize' (FileChange n FileAdded:cs) = (Added n) : summarize cs
    summarize' (FileChange n (FileReplace f t):cs) = (Replaced n f t) : summarize cs
    summarize' (FileChange n _:cs) = (Modified n) : summarize cs
    summarize' (PrefChange n f t:cs) = (Preference n f t) : summarize cs
    summarize' (_:cs) = summarize cs

isModification :: PatchChange -> Bool
isModification (FileChange _ (FileHunk _ _ _)) = True
isModification _ = False

#ifdef DARCS28
findAllDeps :: Commute p
#else
findAllDeps :: (Commute p, NameHack p)
#endif
            => RL (PatchInfoAnd p) x y -> [(PatchInfo, [PatchInfo])]
findAllDeps NilRL = []
findAllDeps (p :<: ps) = (info p, findDeps ps NilFL p) : findAllDeps ps

#ifdef DARCS28
findDeps :: Commute p
#else
findDeps :: (Commute p, NameHack p)
#endif
         => RL (PatchInfoAnd p) x y
         -> FL (PatchInfoAnd p) y z
         -> PatchInfoAnd p z z1
         -> [PatchInfo]
findDeps NilRL _ _ = []
findDeps (p :<: ps) deps me =
    case commuteWhatWeCanFL (p :> deps) of
        deps' :> p' :> NilFL ->
            case commute (p' :> me) of
                Just (me' :> _) ->
                    -- not a dependency
                    findDeps ps deps' me'

                Nothing ->
                    -- a direct dependency
                    info p' : findDeps ps (p :>: deps) me
        _ ->
            -- an indirect dependency
            findDeps ps (p :>: deps) me