1 -- Copyright (C) 2007 David Roundy
    2 --
    3 -- This program is free software; you can redistribute it and/or modify
    4 -- it under the terms of the GNU General Public License as published by
    5 -- the Free Software Foundation; either version 2, or (at your option)
    6 -- any later version.
    7 --
    8 -- This program is distributed in the hope that it will be useful,
    9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of
   10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   11 -- GNU General Public License for more details.
   12 --
   13 -- You should have received a copy of the GNU General Public License
   14 -- along with this program; see the file COPYING.  If not, write to
   15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   16 -- Boston, MA 02110-1301, USA.
   17 
   18 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
   19 {-# LANGUAGE CPP #-}
   20 -- , TypeOperators, GADTs #-}
   21 
   22 #include "gadts.h"
   23 
   24 module Darcs.Patch.Patchy ( Patchy,
   25                             Apply, apply, applyAndTryToFix, applyAndTryToFixFL,
   26                             mapMaybeSnd,
   27                             Commute(..), commuteFL, commuteRL, commuteRLFL,
   28                             mergeFL,
   29                             ShowPatch(..),
   30                             ReadPatch, readPatch', bracketedFL, peekfor,
   31                             Invert(..), invertFL, invertRL ) where
   32 
   33 import Control.Monad ( liftM )
   34 import Data.Maybe ( fromJust )
   35 import Data.Word ( Word8 )
   36 import Data.List ( nub )
   37 
   38 import Darcs.SlurpDirectory ( Slurpy )
   39 import Darcs.Sealed ( Sealed(..), Sealed2(..), seal2 )
   40 import Darcs.Patch.ReadMonads ( ParserM, lex_eof, peek_input, my_lex, work, alter_input )
   41 import Darcs.Ordered
   42 import Printer ( Doc, (<>), text )
   43 import Darcs.Lock ( writeDocBinFile, gzWriteDocFile )
   44 import Darcs.IO ( WriteableDirectory )
   45 import Darcs.Flags ( DarcsFlag )
   46 import English ( plural, Noun(Noun) )
   47 
   48 import ByteStringUtils ( ifHeadThenTail, dropSpace )
   49 import qualified Data.ByteString.Char8 as BC (pack, ByteString)
   50 
   51 --import Darcs.ColorPrinter ( traceDoc )
   52 --import Printer ( greenText, ($$) )
   53 
   54 class (Apply p, Commute p, ShowPatch p, ReadPatch p, Invert p) => Patchy p where
   55 -- instance (ShowPatch p, Invert p) => Patchy p where
   56 
   57 class Apply p where
   58     apply :: WriteableDirectory m => [DarcsFlag] -> p C(x y) -> m ()
   59     apply _ p = do mp' <- applyAndTryToFix p
   60                    case mp' of
   61                      Nothing -> return ()
   62                      Just (e, _) -> fail $ "Unable to apply a patch: " ++ e
   63     applyAndTryToFix :: WriteableDirectory m => p C(x y) -> m (Maybe (String, p C(x y)))
   64     applyAndTryToFix p = do apply [] p; return Nothing
   65     applyAndTryToFixFL :: WriteableDirectory m => p C(x y) -> m (Maybe (String, FL p C(x y)))
   66     applyAndTryToFixFL p = mapMaybeSnd (:>:NilFL) `liftM` applyAndTryToFix p
   67 
   68 mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b)
   69 mapMaybeSnd f (Just (a,b)) = Just (a,f b)
   70 mapMaybeSnd _ Nothing = Nothing
   71 
   72 class Commute p where
   73     commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))
   74     commutex :: (p :< p) C(x y) -> Maybe ((p :< p) C(x y))
   75     commute (x :> y) = do x' :< y' <- commutex (y :< x)
   76                           return (y' :> x')
   77     commutex (x :< y) = do x' :> y' <- commute (y :> x)
   78                            return (y' :< x')
   79     merge :: (p :\/: p) C(x y) -> (p :/\: p) C(x y)
   80     list_touched_files :: p C(x y) -> [FilePath]
   81 
   82 class Commute p => ShowPatch p where
   83     showPatch :: p C(x y) -> Doc
   84     showNicely :: p C(x y) -> Doc
   85     showNicely = showPatch
   86     showContextPatch :: Slurpy -> p C(x y) -> Doc
   87     showContextPatch _ p = showPatch p
   88     description :: p C(x y) -> Doc
   89     description = showPatch
   90     summary :: p C(x y) -> Doc
   91     summary = showPatch
   92     writePatch :: FilePath -> p C(x y) -> IO ()
   93     writePatch f p = writeDocBinFile f $ showPatch p <> text "\n"
   94     gzWritePatch :: FilePath -> p C(x y) -> IO ()
   95     gzWritePatch f p = gzWriteDocFile f $ showPatch p <> text "\n"
   96     thing :: p C(x y) -> String
   97     thing _ = "patch"
   98     things :: p C(x y) -> String
   99     things x = plural (Noun $ thing x) ""
  100 
  101 class ReadPatch p where
  102     readPatch'
  103         :: ParserM m => Bool -> m (Maybe (Sealed (p C(x ))))
  104 
  105 class MyEq p => Invert p where
  106     invert :: p C(x y) -> p C(y x)
  107     identity :: p C(x x)
  108     sloppyIdentity :: p C(x y) -> EqCheck C(x y)
  109     sloppyIdentity p = identity =\/= p
  110 
  111 instance Apply p => Apply (FL p) where
  112     apply _ NilFL = return ()
  113     apply opts (p:>:ps) = apply opts p >> apply opts ps
  114     applyAndTryToFix NilFL = return Nothing
  115     applyAndTryToFix (p:>:ps) = do mp <- applyAndTryToFixFL p
  116                                    mps <- applyAndTryToFix ps
  117                                    return $ case (mp,mps) of
  118                                             (Nothing, Nothing) -> Nothing
  119                                             (Just (e,p'),Nothing) -> Just (e,p'+>+ps)
  120                                             (Nothing, Just (e,ps')) -> Just (e,p:>:ps')
  121                                             (Just (e,p'), Just (es,ps')) ->
  122                                                 Just (unlines [e,es], p'+>+ps')
  123 
  124 instance Commute p => Commute (FL p) where
  125     commute (NilFL :> x) = Just (x :> NilFL)
  126     commute (x :> NilFL) = Just (NilFL :> x)
  127     commute (xs :> ys) = do ys' :> rxs' <- commuteRLFL (reverseFL xs :> ys)
  128                             return $ ys' :> reverseRL rxs'
  129     merge (NilFL :\/: x) = x :/\: NilFL
  130     merge (x :\/: NilFL) = NilFL :/\: x
  131     merge ((x:>:xs) :\/: ys) = fromJust $ do ys' :/\: x' <- return $ mergeFL (x :\/: ys)
  132                                              xs' :/\: ys'' <- return $ merge (ys' :\/: xs)
  133                                              return (ys'' :/\: (x' :>: xs'))
  134     list_touched_files xs = nub $ concat $ mapFL list_touched_files xs
  135 
  136 mergeFL :: Commute p => (p :\/: FL p) C(x y) -> (FL p :/\: p) C(x y)
  137 mergeFL (p :\/: NilFL) = NilFL :/\: p
  138 mergeFL (p :\/: (x :>: xs)) = fromJust $ do x' :/\: p' <- return $ merge (p :\/: x)
  139                                             xs' :/\: p'' <- return $ mergeFL (p' :\/: xs)
  140                                             return ((x' :>: xs') :/\: p'')
  141 
  142 commuteRLFL :: Commute p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))
  143 commuteRLFL (NilRL :> ys) = Just (ys :> NilRL)
  144 commuteRLFL (xs :> NilFL) = Just (NilFL :> xs)
  145 commuteRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteRL (xs :> y)
  146                                   ys' :> xs'' <- commuteRLFL (xs' :> ys)
  147                                   return (y' :>: ys' :> xs'')
  148 
  149 commuteRL :: Commute p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))
  150 commuteRL (z :<: zs :> w) = do w' :> z' <- commute (z :> w)
  151                                w'' :> zs' <- commuteRL (zs :> w')
  152                                return (w'' :> z' :<: zs')
  153 commuteRL (NilRL :> w) = Just (w :> NilRL)
  154 
  155 commuteFL :: Commute p => (p :> FL p) C(x y) -> Either (Sealed2 p) ((FL p :> p) C(x y))
  156 commuteFL (p :> NilFL) = Right (NilFL :> p)
  157 commuteFL (q :> p :>: ps) = case commute (q :> p) of
  158                             Just (p' :> q') ->
  159                                case commuteFL (q' :> ps) of
  160                                Right (ps' :> q'') -> Right (p' :>: ps' :> q'')
  161                                Left l -> Left l
  162                             Nothing -> Left $ seal2 p
  163 
  164 instance ReadPatch p => ReadPatch (FL p) where
  165     readPatch' want_eof = Just `liftM` read_patches
  166      where read_patches :: ParserM m => m (Sealed (FL p C(x )))
  167            read_patches = do --tracePeek "starting FL read"
  168                              mp <- readPatch' False
  169                              case mp of
  170                                Just (Sealed p) -> do --tracePeek "found one patch"
  171                                                      Sealed ps <- read_patches
  172                                                      return $ Sealed (p:>:ps)
  173                                Nothing -> if want_eof
  174                                           then do --tracePeek "no more patches"
  175                                                   unit' <- lex_eof
  176                                                   case unit' of
  177                                                     () -> return $ Sealed NilFL
  178                                           else do --tracePeek "no more patches"
  179                                                   return $ Sealed NilFL
  180 --           tracePeek x = do y <- peek_input
  181 --                            traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return ()
  182 
  183 {-# INLINE bracketedFL #-}
  184 bracketedFL :: (ReadPatch p, ParserM m) =>
  185                Word8 -> Word8 -> m (Maybe (Sealed (FL p C(x))))
  186 bracketedFL pre post =
  187     peekforw pre bfl (return Nothing)
  188         where bfl :: (ReadPatch p, ParserM m) => m (Maybe (Sealed (FL p C(x))))
  189               bfl = peekforw post (return $ Just $ Sealed NilFL)
  190                                   (do Just (Sealed p) <- readPatch' False
  191                                       Just (Sealed ps) <- bfl
  192                                       return $ Just $ Sealed (p:>:ps))
  193 
  194 {-# INLINE peekforw #-}
  195 peekforw :: ParserM m => Word8 -> m a -> m a -> m a
  196 peekforw w ifstr ifnot = do s <- peek_input
  197                             case ifHeadThenTail w $ dropSpace s of
  198                               Just s' -> alter_input (const s') >> ifstr
  199                               Nothing -> ifnot
  200 
  201 peekforPS :: ParserM m => BC.ByteString -> m a -> m a -> m a
  202 peekforPS ps ifstr ifnot = do s <- peek_input
  203                               case ((ps ==) . fst) `fmap` my_lex s of
  204                                 Just True -> work my_lex >> ifstr
  205                                 _ -> ifnot
  206 
  207 {-# INLINE peekfor #-}
  208 peekfor :: ParserM m => String -> m a -> m a -> m a
  209 peekfor = peekforPS . BC.pack
  210 
  211 instance Apply p => Apply (RL p) where
  212     apply _ NilRL = return ()
  213     apply opts (p:<:ps) = apply opts ps >> apply opts p
  214 instance Commute p => Commute (RL p) where
  215     commute (xs :> ys) = do fys' :> xs' <- commuteRLFL (xs :> reverseRL ys)
  216                             return (reverseFL fys' :> xs')
  217     merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of
  218                        (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx'
  219     list_touched_files = list_touched_files . reverseRL
  220 instance ReadPatch p => ReadPatch (RL p) where
  221     readPatch' want_eof = do Just (Sealed fl) <- readPatch' want_eof
  222                              return $ Just $ Sealed $ reverseFL fl
  223 
  224 invertFL :: Invert p => FL p C(x y) -> RL p C(y x)
  225 invertFL NilFL = NilRL
  226 invertFL (x:>:xs) = invert x :<: invertFL xs
  227 
  228 invertRL :: Invert p => RL p C(x y) -> FL p C(y x)
  229 invertRL NilRL = NilFL
  230 invertRL (x:<:xs) = invert x :>: invertRL xs