    -- 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(..), commuteFL, commuteRL, 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, lex_eof, peek_input, my_lex, work, alter_input )
    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)

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

    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 $ dropSpace s of
                                  Just s' -> alter_input (const s') >> ifstr
                                  Nothing -> ifnot

    peekforPS :: ParserM m => BC.ByteString -> 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 = 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