-- Copyright (C) 2007 David Roundy
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{-# LANGUAGE CPP #-}
-- , TypeOperators, GADTs #-}

#include "gadts.h"

module Darcs.Patch.Patchy ( Patchy,
                            Apply, apply, applyAndTryToFix, applyAndTryToFixFL,
                            mapMaybeSnd,
                            Commute(..), commuteFLorComplain, commuteRL,
                            commuteFL, commuteRLFL,
                            mergeFL, toFwdCommute, toRevCommute,
                            ShowPatch(..),
                            ReadPatch, readPatch', bracketedFL, peekfor,
                            Invert(..), invertFL, invertRL ) where

import Control.Monad ( liftM )
import Data.Maybe ( fromJust )
import Data.Word ( Word8 )
import Data.List ( nub )

import Storage.Hashed.Monad( TreeIO )
import Darcs.Witnesses.Sealed ( Sealed(..), Sealed2(..), seal2 )
import Darcs.Patch.ReadMonads ( ParserM, lexEof, peekInput, myLex, work, alterInput )
import Darcs.Witnesses.Ordered
import Printer ( Doc, (<>), text )
import Darcs.Lock ( writeDocBinFile, gzWriteDocFile )
import Darcs.IO ( WriteableDirectory )
import Darcs.Flags ( DarcsFlag )
import English ( plural, Noun(Noun) )

import ByteStringUtils ( ifHeadThenTail, dropSpace )
import qualified Data.ByteString.Char8 as BC (pack, ByteString)

--import Darcs.ColorPrinter ( traceDoc )
--import Printer ( greenText, ($$) )

class (Apply p, Commute p, ShowPatch p, ReadPatch p, Invert p) => Patchy p where
-- instance (ShowPatch p, Invert p) => Patchy p where

class Apply p where
    apply :: WriteableDirectory m => [DarcsFlag] -> p C(x y) -> m ()
    apply _ p = do mp' <- applyAndTryToFix p
                   case mp' of
                     Nothing -> return ()
                     Just (e, _) -> fail $ "Unable to apply a patch: " ++ e
    applyAndTryToFix :: WriteableDirectory m => p C(x y) -> m (Maybe (String, p C(x y)))
    applyAndTryToFix p = do apply [] p; return Nothing
    applyAndTryToFixFL :: WriteableDirectory m => p C(x y) -> m (Maybe (String, FL p C(x y)))
    applyAndTryToFixFL p = mapMaybeSnd (:>:NilFL) `liftM` applyAndTryToFix p

mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b)
mapMaybeSnd f (Just (a,b)) = Just (a,f b)
mapMaybeSnd _ Nothing = Nothing

-- | Things that can commute.
class Commute p where
    commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))
    merge :: (p :\/: p) C(x y) -> (p :/\: p) C(x y)
    listTouchedFiles :: p C(x y) -> [FilePath]
    hunkMatches :: (BC.ByteString -> Bool) -> p C(x y) -> Bool

-- | Swaps the ordered pair type so that commute can be
-- called directly.
toFwdCommute :: (Commute p, Commute q, Monad m)
             => ((p :< q) C(x y) -> m ((q :< p) C(x y)))
             -> (q :> p) C(x y) -> m ((p :> q) C(x y))
toFwdCommute c (x :> y) = do x' :< y' <- c (y :< x)
                             return (y' :> x')

-- | Swaps the ordered pair type from the order expected
-- by commute to the reverse order.
toRevCommute :: (Commute p, Commute q, Monad m)
             => ((p :> q) C(x y) -> m ((q :> p) C(x y)))
             -> (q :< p) C(x y) -> m ((p :< q) C(x y))
toRevCommute c (x :< y) = do x' :> y' <- c (y :> x)
                             return (y' :< x')

class Commute p => ShowPatch p where
    showPatch :: p C(x y) -> Doc
    showNicely :: p C(x y) -> Doc
    showNicely = showPatch
    showContextPatch :: p C(x y) -> TreeIO Doc
    showContextPatch p = return $ showPatch p
    description :: p C(x y) -> Doc
    description = showPatch
    summary :: p C(x y) -> Doc
    summary = showPatch
    writePatch :: FilePath -> p C(x y) -> IO ()
    writePatch f p = writeDocBinFile f $ showPatch p <> text "\n"
    gzWritePatch :: FilePath -> p C(x y) -> IO ()
    gzWritePatch f p = gzWriteDocFile f $ showPatch p <> text "\n"
    thing :: p C(x y) -> String
    thing _ = "patch"
    things :: p C(x y) -> String
    things x = plural (Noun $ thing x) ""

class ReadPatch p where
    readPatch'
        :: ParserM m => Bool -> m (Maybe (Sealed (p C(x ))))

class MyEq p => Invert p where
    invert :: p C(x y) -> p C(y x)
    identity :: p C(x x)
    sloppyIdentity :: p C(x y) -> EqCheck C(x y)
    sloppyIdentity p = identity =\/= p

instance Apply p => Apply (FL p) where
    apply _ NilFL = return ()
    apply opts (p:>:ps) = apply opts p >> apply opts ps
    applyAndTryToFix NilFL = return Nothing
    applyAndTryToFix (p:>:ps) = do mp <- applyAndTryToFixFL p
                                   mps <- applyAndTryToFix ps
                                   return $ case (mp,mps) of
                                            (Nothing, Nothing) -> Nothing
                                            (Just (e,p'),Nothing) -> Just (e,p'+>+ps)
                                            (Nothing, Just (e,ps')) -> Just (e,p:>:ps')
                                            (Just (e,p'), Just (es,ps')) ->
                                                Just (unlines [e,es], p'+>+ps')

instance Commute p => Commute (FL p) where
    commute (NilFL :> x) = Just (x :> NilFL)
    commute (x :> NilFL) = Just (NilFL :> x)
    commute (xs :> ys) = do ys' :> rxs' <- commuteRLFL (reverseFL xs :> ys)
                            return $ ys' :> reverseRL rxs'
    merge (NilFL :\/: x) = x :/\: NilFL
    merge (x :\/: NilFL) = NilFL :/\: x
    merge ((x:>:xs) :\/: ys) = fromJust $ do ys' :/\: x' <- return $ mergeFL (x :\/: ys)
                                             xs' :/\: ys'' <- return $ merge (ys' :\/: xs)
                                             return (ys'' :/\: (x' :>: xs'))
    listTouchedFiles xs = nub $ concat $ mapFL listTouchedFiles xs
    hunkMatches f = or . mapFL (hunkMatches f)

mergeFL :: Commute p => (p :\/: FL p) C(x y) -> (FL p :/\: p) C(x y)
mergeFL (p :\/: NilFL) = NilFL :/\: p
mergeFL (p :\/: (x :>: xs)) = fromJust $ do x' :/\: p' <- return $ merge (p :\/: x)
                                            xs' :/\: p'' <- return $ mergeFL (p' :\/: xs)
                                            return ((x' :>: xs') :/\: p'')

commuteRLFL :: Commute p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))
commuteRLFL (NilRL :> ys) = Just (ys :> NilRL)
commuteRLFL (xs :> NilFL) = Just (NilFL :> xs)
commuteRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteRL (xs :> y)
                                  ys' :> xs'' <- commuteRLFL (xs' :> ys)
                                  return (y' :>: ys' :> xs'')

commuteRL :: Commute p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))
commuteRL (z :<: zs :> w) = do w' :> z' <- commute (z :> w)
                               w'' :> zs' <- commuteRL (zs :> w')
                               return (w'' :> z' :<: zs')
commuteRL (NilRL :> w) = Just (w :> NilRL)

commuteFLorComplain :: Commute p => (p :> FL p) C(x y) -> Either (Sealed2 p) ((FL p :> p) C(x y))
commuteFLorComplain (p :> NilFL) = Right (NilFL :> p)
commuteFLorComplain (q :> p :>: ps) = case commute (q :> p) of
                            Just (p' :> q') ->
                               case commuteFLorComplain (q' :> ps) of
                               Right (ps' :> q'') -> Right (p' :>: ps' :> q'')
                               Left l -> Left l
                            Nothing -> Left $ seal2 p

commuteFL :: Commute p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))
commuteFL = either (const Nothing) Just . commuteFLorComplain

instance ReadPatch p => ReadPatch (FL p) where
    readPatch' want_eof = Just `liftM` read_patches
     where read_patches :: ParserM m => m (Sealed (FL p C(x )))
           read_patches = do --tracePeek "starting FL read"
                             mp <- readPatch' False
                             case mp of
                               Just (Sealed p) -> do --tracePeek "found one patch"
                                                     Sealed ps <- read_patches
                                                     return $ Sealed (p:>:ps)
                               Nothing -> if want_eof
                                          then do --tracePeek "no more patches"
                                                  unit' <- lexEof
                                                  case unit' of
                                                    () -> return $ Sealed NilFL
                                          else do --tracePeek "no more patches"
                                                  return $ Sealed NilFL
--           tracePeek x = do y <- peekInput
--                            traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return ()

{-# INLINE bracketedFL #-}
bracketedFL :: forall p m C(x) . (ReadPatch p, ParserM m) =>
               (FORALL(y) m (Maybe (Sealed (p C(y))))) -> Word8 -> Word8 -> m (Maybe (Sealed (FL p C(x))))
bracketedFL parser pre post =
    peekforw pre bfl (return Nothing)
        where bfl :: FORALL(z) m (Maybe (Sealed (FL p C(z))))
              bfl = peekforw post (return $ Just $ Sealed NilFL)
                                  (do Just (Sealed p) <- parser
                                      Just (Sealed ps) <- bfl
                                      return $ Just $ Sealed (p:>:ps))

{-# INLINE peekforw #-}
peekforw :: ParserM m => Word8 -> m a -> m a -> m a
peekforw w ifstr ifnot = do s <- peekInput
                            case ifHeadThenTail w $ dropSpace s of
                              Just s' -> alterInput (const s') >> ifstr
                              Nothing -> ifnot

peekforPS :: ParserM m => BC.ByteString -> m a -> m a -> m a
peekforPS ps ifstr ifnot = do s <- peekInput
                              case ((ps ==) . fst) `fmap` myLex s of
                                Just True -> work myLex >> ifstr
                                _ -> ifnot

{-# INLINE peekfor #-}
peekfor :: ParserM m => String -> m a -> m a -> m a
peekfor = peekforPS . BC.pack

instance Apply p => Apply (RL p) where
    apply _ NilRL = return ()
    apply opts (p:<:ps) = apply opts ps >> apply opts p
instance Commute p => Commute (RL p) where
    commute (xs :> ys) = do fys' :> xs' <- commuteRLFL (xs :> reverseRL ys)
                            return (reverseFL fys' :> xs')
    merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of
                       (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx'
    listTouchedFiles = listTouchedFiles . reverseRL
    hunkMatches f = hunkMatches f . reverseRL
instance ReadPatch p => ReadPatch (RL p) where
    readPatch' want_eof = do Just (Sealed fl) <- readPatch' want_eof
                             return $ Just $ Sealed $ reverseFL fl

invertFL :: Invert p => FL p C(x y) -> RL p C(y x)
invertFL NilFL = NilRL
invertFL (x:>:xs) = invert x :<: invertFL xs

invertRL :: Invert p => RL p C(x y) -> FL p C(y x)
invertRL NilRL = NilFL
invertRL (x:<:xs) = invert x :>: invertRL xs