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