src/Darcs/Patch/Non.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 \section{``NonPatch'' patches}
  20
  21 \begin{code}
  22 {-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-}
  23 {-# LANGUAGE CPP #-}
  24 -- , TypeOperators, GADTs, FlexibleContexts #-}
  25
  26 #include "gadts.h"
  27
  28 module Darcs.Patch.Non
  29        ( NonPatch, Non(..), Nonable(..), unNon,
  30          showNon, readNon, showNons, readNons,
  31          add, rem, addP, remP, addPs, remPs, remAddP, remAddPs, remNons,
  32          (*>), (>*), (*>>), (>>*),
  33          prop_adjust_twice ) where
  34
  35 import Prelude hiding ( rem )
  36 import Data.List ( delete )
  37 import Control.Monad ( liftM )
  38 import Darcs.Patch.Prim ( Prim, FromPrim(..), ToFromPrim(..), Effect(..),
  39                           showPrim, FileNameFormat(..), sort_coalesceFL )
  40 import Darcs.Patch.Patchy
  41 import Darcs.Patch.ReadMonads ( ParserM, lex_char )
  42 import Darcs.Ordered
  43 import Darcs.Patch.Read ( readPrim )
  44 import Darcs.Patch.Viewing ()
  45 import Darcs.Patch.Permutations ( removeFL, commuteWhatWeCanFL )
  46 import Darcs.Show
  47 import Darcs.Sealed ( Sealed(Sealed) )
  48 import Printer ( Doc, empty, vcat, hiddenPrefix, blueText, redText, ($$) )
  49
  50 --import Darcs.ColorPrinter ( traceDoc )
  51 --import Printer ( greenText )
  52
  53 showNons :: ShowPatch (FL p) => [Non p C(x)] -> Doc
  54 showNons [] = empty
  55 showNons xs = blueText "{{" $$ vcat (map showNon xs) $$ blueText "}}"
  56
  57 showNon :: ShowPatch (FL p) => Non p C(x) -> Doc
  58 showNon (Non c p) = hiddenPrefix "|" (showPatch c)
  59                     $$ hiddenPrefix "|" (blueText ":")
  60                     $$ showPrim NewFormat p
  61
  62 readNons :: (ReadPatch p, ParserM m) => m [Non p C(x)]
  63 readNons = peekfor "{{" rns (return [])
  64     where rns = peekfor "}}" (return []) $
  65                 do Just (Sealed ps) <- readPatch' False
  66                    lex_char ':'
  67                    Just (Sealed p) <- readPrim NewFormat False
  68                    (Non ps p :) `liftM` rns
  69
  70 readNon :: (ReadPatch p, ParserM m) => m (Maybe (Non p C(x)))
  71 readNon = do Just (Sealed ps) <- readPatch' False
  72              peekfor ":" (do Just (Sealed p) <- readPatch' False
  73                              return $ Just $ Non ps p)
  74                          (return Nothing)
  75
  76 instance (Commute p, MyEq p) => Eq (Non p C(x)) where
  77     (Non cx x) == (Non cy y) | IsEq <- cx =\/= cy,
  78                                IsEq <- x =\/= y = True
  79                              | otherwise = False
  80
  81 data Non p C(x) where
  82     Non :: FL p C(a x) -> Prim C(x y) -> Non p C(a)
  83
  84 type NonPatch C(x) = Non Prim C(x)
  85
  86 unNon :: FromPrim p => Non p C(x) -> Sealed (FL p C(x))
  87 unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL)
  88
  89 class Nonable p where
  90     non :: p C(x y) -> Non p C(x)
  91
  92 addP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Non p C(x)
  93 addP p n | Just n' <- p >* n = n'
  94 addP p (Non c x) = Non (p:>:c) x
  95
  96 addPs :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y) -> Non p C(x)
  97 addPs NilRL n = n
  98 addPs (p:<:ps) n = addPs ps $ addP p n
  99
 100 add :: (Effect q, Patchy p, ToFromPrim p) => q C(x y) -> Non p C(y) -> Non p C(x)
 101 add q = addPs (mapRL_RL fromPrim $ effectRL q)
 102
 103 -- remNons really only works right if the relevant nons are conflicting...
 104 remNons :: (Nonable p, Effect p, Patchy p, ToFromPrim p, ShowPatch p) => [Non p C(x)] -> Non p C(x) -> Non p C(x)
 105 remNons ns (Non c x) = case remNonHelper ns c of
 106                        NilFL :> c' -> Non c' x
 107                        _ -> Non c x
 108
 109 remNonHelper :: (Nonable p, Effect p, Patchy p, ToFromPrim p) => [Non p C(x)] -> FL p C(x y)
 110              -> (FL Prim :> FL p) C(x y)
 111 remNonHelper [] x = NilFL :> x
 112 remNonHelper ns (c:>:cs)
 113     | non c `elem` ns = case remNonHelper (map (addP $ invert c) $ delete (non c) ns) cs of
 114                         a :> z -> sort_coalesceFL (effect c+>+a) :> z
 115     | otherwise = case commuteWhatWeCanFL (c :> cs) of
 116                   b :> c' :> d ->
 117                       case remNonHelper ns b of
 118                       a :> b' -> a :> (b'+>+c':>:d)
 119 remNonHelper _ NilFL = NilFL :> NilFL
 120
 121 remP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(x) -> Maybe (Non p C(y))
 122 remP p n | Just n' <- n *> p = Just n'
 123 remP p (Non pc x) = do c <- removeFL p pc
 124                        return (Non c x)
 125
 126 remPs :: (Patchy p, ToFromPrim p) => FL p C(x y) -> Non p C(x) -> Maybe (Non p C(y))
 127 remPs NilFL n = Just n
 128 remPs (p:>:ps) n = remP p n >>= remPs ps
 129
 130 rem :: (Effect q, Patchy p, ToFromPrim p) => q C(x y) -> Non p C(x) -> Maybe (Non p C(y))
 131 rem q = remPs (mapFL_FL fromPrim $ effect q)
 132
 133 remAddP :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Non p C(x)
 134 remAddP p n = maybe (addP p n) id $ remP (invert p) n
 135
 136 remAddPs :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y) -> Non p C(x)
 137 remAddPs NilRL n = n
 138 remAddPs (x:<:xs) n = remAddPs xs $ remAddP x n
 139
 140 (*>) :: (Patchy p, ToFromPrim p) => Non p C(x) -> p C(x y) -> Maybe (Non p C(y))
 141 n *> p = invert p >* n
 142
 143 (>*) :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe (Non p C(x))
 144 y >* (Non c x) = case commuteFL (y :> c) of
 145                     Right (c' :> y') -> do
 146                       px' :> _ <- commute (y' :> fromPrim x)
 147                       x' <- toPrim px'
 148                       return (Non c' x')
 149                     _ -> Nothing
 150
 151 (*>>) :: (Effect q, Patchy q, Patchy p, ToFromPrim p) => Non p C(x) -> q C(x y) -> Maybe (Non p C(y))
 152 n *>> p = invert p >>* n
 153
 154 (>>*) :: (Effect q, Patchy p, ToFromPrim p) => q C(x y) -> Non p C(y) -> Maybe (Non p C(x))
 155 q >>* nn = adj (effectRL q) nn
 156     where adj :: (Patchy p, ToFromPrim p) => RL Prim C(x y) -> Non p C(y) -> Maybe (Non p C(x))
 157           adj NilRL n = Just n
 158           adj (x:<:xs) n = fromPrim x >* n >>= adj xs
 159
 160 prop_adjust_twice :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y) -> Maybe Doc
 161 prop_adjust_twice p n =
 162     do n' <- p >* n
 163        case n' *> p of
 164          Nothing -> Just (redText "prop_adjust_inverse 1")
 165          Just n'' | n'' /= n -> Just (redText "prop_adjust_inverse 2")
 166          _ -> case n *> invert p of
 167               Nothing -> Just (redText "prop_adjust_inverse 3")
 168               Just n'' | n'' /= n' -> Just (redText "prop_adjust_inverse 4")
 169               _ -> case invert p >* n' of
 170                    Nothing -> Just (redText "prop_adjust_inverse 5")
 171                    Just n'' | n'' /= n -> Just (redText "prop_adjust_inverse 6")
 172                    _ -> Nothing
 173
 174
 175 instance Nonable Prim where
 176     non = Non NilFL
 177
 178 instance Show2 p => Show (Non p C(x)) where
 179     showsPrec = showsPrec1
 180
 181 instance Show2 p => Show1 (Non p) where
 182     showsPrec1 d (Non cs p) = showParen (d > app_prec) $ showString "Non " .
 183                               showsPrec2 (app_prec + 1) cs . showString " " .
 184                               showsPrec (app_prec + 1) p
 185
 186 instance Patchy Prim
 187
 188 \end{code}