src/Darcs/Patch/Patchy.lhs

   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
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
  21 {-# LANGUAGE CPP #-}
  22 -- , TypeOperators, GADTs #-}
  23
  24 #include "gadts.h"
  25
  26 module Darcs.Patch.Patchy ( Patchy,
  27                             Apply, apply, applyAndTryToFix, applyAndTryToFixFL,
  28                             mapMaybeSnd,
  29                             Commute(..), commuteFL, commuteRL, commuteRLFL,
  30                             mergeFL,
  31                             ShowPatch(..),
  32                             ReadPatch, readPatch', bracketedFL, peekfor,
  33                             Invert(..), invertFL, invertRL ) where
  34
  35 import Control.Monad ( liftM )
  36 import Data.Maybe ( fromJust )
  37 import Data.Word ( Word8 )
  38 import Data.List ( nub )
  39
  40 import Darcs.SlurpDirectory ( Slurpy )
  41 import Darcs.Sealed ( Sealed(..), Sealed2(..), seal2 )
  42 import Darcs.Patch.ReadMonads ( ParserM, lex_eof, peek_input, my_lex, work, alter_input )
  43 import Darcs.Ordered
  44 import Printer ( Doc, (<>), text )
  45 import Darcs.Lock ( writeDocBinFile, gzWriteDocFile )
  46 import Darcs.IO ( WriteableDirectory )
  47 import Darcs.Flags ( DarcsFlag )
  48 import English ( plural, Noun(Noun) )
  49
  50 import ByteStringUtils ( ifHeadThenTail, dropSpace )
  51 import qualified Data.ByteString.Char8 as BC (pack, ByteString)
  52
  53 --import Darcs.ColorPrinter ( traceDoc )
  54 --import Printer ( greenText, ($$) )
  55
  56 class (Apply p, Commute p, ShowPatch p, ReadPatch p, Invert p) => Patchy p where
  57 -- instance (ShowPatch p, Invert p) => Patchy p where
  58
  59 class Apply p where
  60     apply :: WriteableDirectory m => [DarcsFlag] -> p C(x y) -> m ()
  61     apply _ p = do mp' <- applyAndTryToFix p
  62                    case mp' of
  63                      Nothing -> return ()
  64                      Just (e, _) -> fail $ "Unable to apply a patch: " ++ e
  65     applyAndTryToFix :: WriteableDirectory m => p C(x y) -> m (Maybe (String, p C(x y)))
  66     applyAndTryToFix p = do apply [] p; return Nothing
  67     applyAndTryToFixFL :: WriteableDirectory m => p C(x y) -> m (Maybe (String, FL p C(x y)))
  68     applyAndTryToFixFL p = mapMaybeSnd (:>:NilFL) `liftM` applyAndTryToFix p
  69
  70 mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b)
  71 mapMaybeSnd f (Just (a,b)) = Just (a,f b)
  72 mapMaybeSnd _ Nothing = Nothing
  73
  74 class Commute p where
  75     commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))
  76     commutex :: (p :< p) C(x y) -> Maybe ((p :< p) C(x y))
  77     commute (x :> y) = do x' :< y' <- commutex (y :< x)
  78                           return (y' :> x')
  79     commutex (x :< y) = do x' :> y' <- commute (y :> x)
  80                            return (y' :< x')
  81     merge :: (p :\/: p) C(x y) -> (p :/\: p) C(x y)
  82     list_touched_files :: p C(x y) -> [FilePath]
  83
  84 class Commute p => ShowPatch p where
  85     showPatch :: p C(x y) -> Doc
  86     showNicely :: p C(x y) -> Doc
  87     showNicely = showPatch
  88     showContextPatch :: Slurpy -> p C(x y) -> Doc
  89     showContextPatch _ p = showPatch p
  90     description :: p C(x y) -> Doc
  91     description = showPatch
  92     summary :: p C(x y) -> Doc
  93     summary = showPatch
  94     writePatch :: FilePath -> p C(x y) -> IO ()
  95     writePatch f p = writeDocBinFile f $ showPatch p <> text "\n"
  96     gzWritePatch :: FilePath -> p C(x y) -> IO ()
  97     gzWritePatch f p = gzWriteDocFile f $ showPatch p <> text "\n"
  98     thing :: p C(x y) -> String
  99     thing _ = "patch"
 100     things :: p C(x y) -> String
 101     things x = plural (Noun $ thing x) ""
 102
 103 class ReadPatch p where
 104     readPatch'
 105         :: ParserM m => Bool -> m (Maybe (Sealed (p C(x ))))
 106
 107 class MyEq p => Invert p where
 108     invert :: p C(x y) -> p C(y x)
 109     identity :: p C(x x)
 110     sloppyIdentity :: p C(x y) -> EqCheck C(x y)
 111     sloppyIdentity p = identity =\/= p
 112
 113 instance Apply p => Apply (FL p) where
 114     apply _ NilFL = return ()
 115     apply opts (p:>:ps) = apply opts p >> apply opts ps
 116     applyAndTryToFix NilFL = return Nothing
 117     applyAndTryToFix (p:>:ps) = do mp <- applyAndTryToFixFL p
 118                                    mps <- applyAndTryToFix ps
 119                                    return $ case (mp,mps) of
 120                                             (Nothing, Nothing) -> Nothing
 121                                             (Just (e,p'),Nothing) -> Just (e,p'+>+ps)
 122                                             (Nothing, Just (e,ps')) -> Just (e,p:>:ps')
 123                                             (Just (e,p'), Just (es,ps')) ->
 124                                                 Just (unlines [e,es], p'+>+ps')
 125
 126 instance Commute p => Commute (FL p) where
 127     commute (NilFL :> x) = Just (x :> NilFL)
 128     commute (x :> NilFL) = Just (NilFL :> x)
 129     commute (xs :> ys) = do ys' :> rxs' <- commuteRLFL (reverseFL xs :> ys)
 130                             return $ ys' :> reverseRL rxs'
 131     merge (NilFL :\/: x) = x :/\: NilFL
 132     merge (x :\/: NilFL) = NilFL :/\: x
 133     merge ((x:>:xs) :\/: ys) = fromJust $ do ys' :/\: x' <- return $ mergeFL (x :\/: ys)
 134                                              xs' :/\: ys'' <- return $ merge (ys' :\/: xs)
 135                                              return (ys'' :/\: (x' :>: xs'))
 136     list_touched_files xs = nub $ concat $ mapFL list_touched_files xs
 137
 138 mergeFL :: Commute p => (p :\/: FL p) C(x y) -> (FL p :/\: p) C(x y)
 139 mergeFL (p :\/: NilFL) = NilFL :/\: p
 140 mergeFL (p :\/: (x :>: xs)) = fromJust $ do x' :/\: p' <- return $ merge (p :\/: x)
 141                                             xs' :/\: p'' <- return $ mergeFL (p' :\/: xs)
 142                                             return ((x' :>: xs') :/\: p'')
 143
 144 commuteRLFL :: Commute p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))
 145 commuteRLFL (NilRL :> ys) = Just (ys :> NilRL)
 146 commuteRLFL (xs :> NilFL) = Just (NilFL :> xs)
 147 commuteRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteRL (xs :> y)
 148                                   ys' :> xs'' <- commuteRLFL (xs' :> ys)
 149                                   return (y' :>: ys' :> xs'')
 150
 151 commuteRL :: Commute p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))
 152 commuteRL (z :<: zs :> w) = do w' :> z' <- commute (z :> w)
 153                                w'' :> zs' <- commuteRL (zs :> w')
 154                                return (w'' :> z' :<: zs')
 155 commuteRL (NilRL :> w) = Just (w :> NilRL)
 156
 157 commuteFL :: Commute p => (p :> FL p) C(x y) -> Either (Sealed2 p) ((FL p :> p) C(x y))
 158 commuteFL (p :> NilFL) = Right (NilFL :> p)
 159 commuteFL (q :> p :>: ps) = case commute (q :> p) of
 160                             Just (p' :> q') ->
 161                                case commuteFL (q' :> ps) of
 162                                Right (ps' :> q'') -> Right (p' :>: ps' :> q'')
 163                                Left l -> Left l
 164                             Nothing -> Left $ seal2 p
 165
 166 instance ReadPatch p => ReadPatch (FL p) where
 167     readPatch' want_eof = Just `liftM` read_patches
 168      where read_patches :: ParserM m => m (Sealed (FL p C(x )))
 169            read_patches = do --tracePeek "starting FL read"
 170                              mp <- readPatch' False
 171                              case mp of
 172                                Just (Sealed p) -> do --tracePeek "found one patch"
 173                                                      Sealed ps <- read_patches
 174                                                      return $ Sealed (p:>:ps)
 175                                Nothing -> if want_eof
 176                                           then do --tracePeek "no more patches"
 177                                                   unit' <- lex_eof
 178                                                   case unit' of
 179                                                     () -> return $ Sealed NilFL
 180                                           else do --tracePeek "no more patches"
 181                                                   return $ Sealed NilFL
 182 --           tracePeek x = do y <- peek_input
 183 --                            traceDoc (greenText x $$ greenText (show $ sal_to_string y)) return ()
 184
 185 {-# INLINE bracketedFL #-}
 186 bracketedFL :: (ReadPatch p, ParserM m) =>
 187                Word8 -> Word8 -> m (Maybe (Sealed (FL p C(x))))
 188 bracketedFL pre post =
 189     peekforw pre bfl (return Nothing)
 190         where bfl :: (ReadPatch p, ParserM m) => m (Maybe (Sealed (FL p C(x))))
 191               bfl = peekforw post (return $ Just $ Sealed NilFL)
 192                                   (do Just (Sealed p) <- readPatch' False
 193                                       Just (Sealed ps) <- bfl
 194                                       return $ Just $ Sealed (p:>:ps))
 195
 196 {-# INLINE peekforw #-}
 197 peekforw :: ParserM m => Word8 -> m a -> m a -> m a
 198 peekforw w ifstr ifnot = do s <- peek_input
 199                             case ifHeadThenTail w $ dropSpace s of
 200                               Just s' -> alter_input (const s') >> ifstr
 201                               Nothing -> ifnot
 202
 203 peekforPS :: ParserM m => BC.ByteString -> m a -> m a -> m a
 204 peekforPS ps ifstr ifnot = do s <- peek_input
 205                               case ((ps ==) . fst) `fmap` my_lex s of
 206                                 Just True -> work my_lex >> ifstr
 207                                 _ -> ifnot
 208
 209 {-# INLINE peekfor #-}
 210 peekfor :: ParserM m => String -> m a -> m a -> m a
 211 peekfor = peekforPS . BC.pack
 212
 213 instance Apply p => Apply (RL p) where
 214     apply _ NilRL = return ()
 215     apply opts (p:<:ps) = apply opts ps >> apply opts p
 216 instance Commute p => Commute (RL p) where
 217     commute (xs :> ys) = do fys' :> xs' <- commuteRLFL (xs :> reverseRL ys)
 218                             return (reverseFL fys' :> xs')
 219     merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of
 220                        (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx'
 221     list_touched_files = list_touched_files . reverseRL
 222 instance ReadPatch p => ReadPatch (RL p) where
 223     readPatch' want_eof = do Just (Sealed fl) <- readPatch' want_eof
 224                              return $ Just $ Sealed $ reverseFL fl
 225
 226 invertFL :: Invert p => FL p C(x y) -> RL p C(y x)
 227 invertFL NilFL = NilRL
 228 invertFL (x:>:xs) = invert x :<: invertFL xs
 229
 230 invertRL :: Invert p => RL p C(x y) -> FL p C(y x)
 231 invertRL NilRL = NilFL
 232 invertRL (x:<:xs) = invert x :>: invertRL xs
 233
 234 \end{code}
 235