%  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.


\begin{code}
{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
#include "gadts.h"
module Darcs.Patch.Patchy ( Patchy,
                            Apply, apply, applyAndTryToFix, applyAndTryToFixFL,
                            mapMaybeSnd,
                            Commute(..), commuteFL, commuteRL, commuteRLFL,
                            mergeFL,
                            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 Darcs.SlurpDirectory ( Slurpy )
import Darcs.Sealed ( Sealed(..) )
import Darcs.Patch.ReadMonads ( ParserM, lex_eof, peek_input, my_lex, work, alter_input )
import Darcs.Patch.Ordered
import Printer ( Doc, (<>), text )
import Darcs.Lock ( writeDocBinFile, gzWriteDocFile )
import Darcs.IO ( WriteableDirectory )
import Darcs.Flags ( DarcsFlag )
import English ( plural, Noun(Noun) )
import FastPackedString ( PackedString, ifHeadThenTail, packString, dropWhitePS )
--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

class Commute p where
    commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))
    commutex :: (p :< p) C(x y) -> Maybe ((p :< p) C(x y))
    commute (x :> y) = do x' :< y' <- commutex (y :< x)
                          return (y' :> x')
    commutex (x :< y) = do x' :> y' <- commute (y :> x)
                           return (y' :< x')
    merge :: (p :\/: p) C(x y) -> (p :/\: p) C(x y)
    list_touched_files :: p C(x y) -> [FilePath]

class Commute p => ShowPatch p where
    showPatch :: p C(x y) -> Doc
    showNicely :: p C(x y) -> Doc
    showNicely = showPatch
    showContextPatch :: Slurpy -> p C(x y) -> Doc
    showContextPatch _ p = 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'))
    list_touched_files xs = nub $ concat $ mapFL list_touched_files xs

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)

commuteFL :: Commute p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))
commuteFL (p :> NilFL) = Just (NilFL :> p)
commuteFL (q :> p :>: ps) = do p' :> q' <- commute (q :> p)
                               ps' :> q'' <- commuteFL (q' :> ps)
                               return (p' :>: ps' :> q'')

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' <- lex_eof
                                                  case unit' of
                                                    () -> return $ Sealed NilFL
                                          else do --tracePeek "no more patches"
                                                  return $ Sealed NilFL
--           tracePeek x = do y <- peek_input
--                            traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return ()

{-# INLINE bracketedFL #-}
bracketedFL :: (ReadPatch p, ParserM m) =>
               Word8 -> Word8 -> m (Maybe (Sealed (FL p C(x))))
bracketedFL pre post =
    peekforw pre bfl (return Nothing)
        where bfl :: (ReadPatch p, ParserM m) => m (Maybe (Sealed (FL p C(x))))
              bfl = peekforw post (return $ Just $ Sealed NilFL)
                                  (do Just (Sealed p) <- readPatch' False
                                      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 <- peek_input
                            case ifHeadThenTail w $ dropWhitePS s of
                              Just s' -> alter_input (const s') >> ifstr
                              Nothing -> ifnot

peekforPS :: ParserM m => PackedString -> m a -> m a -> m a
peekforPS ps ifstr ifnot = do s <- peek_input
                              case ((ps ==) . fst) `fmap` my_lex s of
                                Just True -> work my_lex >> ifstr
                                _ -> ifnot

{-# INLINE peekfor #-}
peekfor :: ParserM m => String -> m a -> m a -> m a
peekfor str = peekforPS (packString str)

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'
    list_touched_files = list_touched_files . 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

\end{code}