1-- Copyright (C) 2006 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 18module Darcs.Patch.PatchInfoAnd 19 ( Hopefully 20 , PatchInfoAnd 21 , PatchInfoAndG 22 , WPatchInfo 23 , unWPatchInfo 24 , compareWPatchInfo 25 , piap 26 , n2pia 27 , patchInfoAndPatch 28 , fmapPIAP 29 , fmapFLPIAP 30 , conscientiously 31 , hopefully 32 , info 33 , winfo 34 , hopefullyM 35 , createHashed 36 , extractHash 37 , actually 38 , unavailable 39 , patchDesc 40 ) where 41 42import Darcs.Prelude 43 44import Control.Exception ( Exception, throw ) 45import System.IO.Unsafe ( unsafeInterleaveIO ) 46import Data.Typeable ( Typeable ) 47 48import Darcs.Util.SignalHandler ( catchNonSignal ) 49import Darcs.Util.Printer ( Doc, ($$), renderString, text, vcat ) 50import Darcs.Patch.Ident ( Ident(..), PatchId, IdEq2(..) ) 51import Darcs.Patch.Info ( PatchInfo, showPatchInfo, displayPatchInfo, justName ) 52import Darcs.Patch.Conflict ( Conflict(..) ) 53import Darcs.Patch.Debug ( PatchDebug(..) ) 54import Darcs.Patch.Effect ( Effect(..) ) 55import Darcs.Patch.FileHunk ( IsHunk(..) ) 56import Darcs.Patch.Format ( PatchListFormat ) 57import Darcs.Patch.Merge ( CleanMerge(..), Merge(..) ) 58import Darcs.Patch.Named ( Named, fmapFL_Named ) 59import Darcs.Patch.Apply ( Apply(..) ) 60import Darcs.Patch.Commute ( Commute(..) ) 61import Darcs.Patch.Inspect ( PatchInspect(..) ) 62import Darcs.Patch.FromPrim ( PrimPatchBase(..) ) 63import Darcs.Patch.Read ( ReadPatch(..) ) 64import Darcs.Patch.Show ( ShowPatch(..) ) 65import Darcs.Patch.Repair ( Repair(..), RepairToFL ) 66import Darcs.Patch.RepoType ( RepoType(..) ) 67import Darcs.Patch.Show ( ShowPatchBasic(..), ShowContextPatch(..) ) 68import Darcs.Patch.Summary ( Summary ) 69import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) ) 70import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) 71import Darcs.Patch.Witnesses.Ordered 72 ( (:/\:)(..) 73 , (:>)(..) 74 , (:\/:)(..) 75 , FL 76 , mapFL 77 , mapRL_RL 78 ) 79import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal ) 80import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) 81import Darcs.Util.Exception ( prettyException ) 82 83-- | @'Hopefully' p C@ @(x y)@ is @'Either' String (p C@ @(x y))@ in a 84-- form adapted to darcs patches. The @C@ @(x y)@ represents the type 85-- witness for the patch that should be there. The @Hopefully@ type 86-- just tells whether we expect the patch to be hashed or not, and 87-- 'SimpleHopefully' does the real work of emulating 88-- 'Either'. @Hopefully sh@ represents an expected unhashed patch, and 89-- @Hashed hash sh@ represents an expected hashed patch with its hash. 90data Hopefully a wX wY 91 = Hopefully (SimpleHopefully a wX wY) 92 | Hashed String (SimpleHopefully a wX wY) 93 deriving Show 94 95-- | @SimpleHopefully@ is a variant of @Either String@ adapted for 96-- type witnesses. @Actually@ is the equivalent of @Right@, while 97-- @Unavailable@ is @Left@. 98data SimpleHopefully a wX wY = Actually (a wX wY) | Unavailable String 99 deriving Show 100 101type PatchInfoAnd rt p = PatchInfoAndG rt (Named p) 102 103-- | @'PatchInfoAnd' p wA wB@ represents a hope we have to get a 104-- patch through its info. We're not sure we have the patch, but we 105-- know its info. 106data PatchInfoAndG (rt :: RepoType) p wA wB = 107 PIAP !PatchInfo 108 (Hopefully p wA wB) 109 deriving (Show) 110 111-- | @'WPatchInfo' wA wB@ represents the info of a patch, marked with 112-- the patch's witnesses. 113newtype WPatchInfo wA wB = WPatchInfo { unWPatchInfo :: PatchInfo } 114 115-- This is actually unsafe if we ever commute patches and then compare them 116-- using this function. TODO: consider adding an extra existential to WPatchInfo 117-- (as with LabelledPatch in Darcs.Patch.Choices) 118compareWPatchInfo :: WPatchInfo wA wB -> WPatchInfo wC wD -> EqCheck (wA, wB) (wC, wD) 119compareWPatchInfo (WPatchInfo x) (WPatchInfo y) = if x == y then unsafeCoerceP IsEq else NotEq 120 121instance Eq2 WPatchInfo where 122 WPatchInfo x `unsafeCompare` WPatchInfo y = x == y 123 124fmapH :: (a wX wY -> b wW wZ) -> Hopefully a wX wY -> Hopefully b wW wZ 125fmapH f (Hopefully sh) = Hopefully (ff sh) 126 where ff (Actually a) = Actually (f a) 127 ff (Unavailable e) = Unavailable e 128fmapH f (Hashed h sh) = Hashed h (ff sh) 129 where ff (Actually a) = Actually (f a) 130 ff (Unavailable e) = Unavailable e 131 132info :: PatchInfoAndG rt p wA wB -> PatchInfo 133info (PIAP i _) = i 134 135patchDesc :: forall rt p wX wY . PatchInfoAnd rt p wX wY -> String 136patchDesc p = justName $ info p 137 138winfo :: PatchInfoAnd rt p wA wB -> WPatchInfo wA wB 139winfo (PIAP i _) = WPatchInfo i 140 141-- | @'piap' i p@ creates a PatchInfoAnd containing p with info i. 142piap :: PatchInfo -> p wA wB -> PatchInfoAndG rt p wA wB 143piap i p = PIAP i (Hopefully $ Actually p) 144 145-- | @n2pia@ creates a PatchInfoAnd representing a @Named@ patch. 146n2pia :: (Ident p, PatchId p ~ PatchInfo) => p wX wY -> PatchInfoAndG rt p wX wY 147n2pia x = ident x `piap` x 148 149patchInfoAndPatch :: PatchInfo -> Hopefully p wA wB -> PatchInfoAndG rt p wA wB 150patchInfoAndPatch = PIAP 151 152fmapFLPIAP :: (FL p wX wY -> FL q wX wY) 153 -> PatchInfoAnd rt p wX wY -> PatchInfoAnd rt q wX wY 154fmapFLPIAP f (PIAP i hp) = PIAP i (fmapH (fmapFL_Named f) hp) 155 156fmapPIAP :: (p wX wY -> q wX wY) 157 -> PatchInfoAndG rt p wX wY -> PatchInfoAndG rt q wX wY 158fmapPIAP f (PIAP i hp) = PIAP i (fmapH f hp) 159 160-- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd' 161-- value. If it fails, it outputs an error \"failed to read patch: 162-- \<description of the patch>\". We get the description of the patch 163-- from the info part of 'hp' 164hopefully :: PatchInfoAndG rt p wA wB -> p wA wB 165hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e 166 167-- | Using a special exception type here means that is is treated as 168-- regular failure, and not as a bug in Darcs. 169data PatchNotAvailable = PatchNotAvailable Doc 170 deriving Typeable 171 172instance Exception PatchNotAvailable 173 174instance Show PatchNotAvailable where 175 show (PatchNotAvailable e) = renderString e 176 177-- | @'conscientiously' er hp@ tries to extract a patch from a 'PatchInfoAnd'. 178-- If it fails, it applies the error handling function @er@ to a description 179-- of the patch info component of @hp@. 180-- Note: this function must be lazy in its second argument, which is why we 181-- use a lazy pattern match. 182conscientiously :: (Doc -> Doc) 183 -> PatchInfoAndG rt p wA wB -> p wA wB 184conscientiously er ~(PIAP pinf hp) = 185 case hopefully2either hp of 186 Right p -> p 187 Left e -> throw $ PatchNotAvailable $ er (displayPatchInfo pinf $$ text e) 188 189-- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a 190-- monad instead of erroring. 191hopefullyM :: PatchInfoAndG rt p wA wB -> Maybe (p wA wB) 192hopefullyM (PIAP _ hp) = case hopefully2either hp of 193 Right p -> return p 194 Left _ -> Nothing 195 196-- Any recommendations for a nice adverb to name the below? 197hopefully2either :: Hopefully a wX wY -> Either String (a wX wY) 198hopefully2either (Hopefully (Actually p)) = Right p 199hopefully2either (Hashed _ (Actually p)) = Right p 200hopefully2either (Hopefully (Unavailable e)) = Left e 201hopefully2either (Hashed _ (Unavailable e)) = Left e 202 203actually :: a wX wY -> Hopefully a wX wY 204actually = Hopefully . Actually 205 206createHashed :: String -> (String -> IO (Sealed (a wX))) -> IO (Sealed (Hopefully a wX)) 207createHashed h f = mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler) 208 where 209 f' = do Sealed x <- f h 210 return (Sealed (Actually x)) 211 handler e = return $ seal $ Unavailable $ prettyException e 212 213extractHash :: PatchInfoAndG rt p wA wB -> Either (p wA wB) String 214extractHash (PIAP _ (Hashed s _)) = Right s 215extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp 216 217unavailable :: String -> Hopefully a wX wY 218unavailable = Hopefully . Unavailable 219 220-- * Instances defined only for PatchInfoAnd 221 222instance Show2 p => Show1 (PatchInfoAnd rt p wX) 223 224instance Show2 p => Show2 (PatchInfoAnd rt p) 225 226instance RepairToFL p => Repair (PatchInfoAnd rt p) where 227 applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p 228 case mp' of 229 Nothing -> return Nothing 230 Just (e,p') -> return $ Just (e, n2pia p') 231 232-- * Instances defined for PatchInfoAndG 233 234instance PrimPatchBase p => PrimPatchBase (PatchInfoAndG rt p) where 235 type PrimOf (PatchInfoAndG rt p) = PrimOf p 236 237-- Equality on PatchInfoAndG is solely determined by the PatchInfo 238-- It is a global invariant of darcs that once a patch is recorded, 239-- it should always have the same representation in the same context. 240instance Eq2 (PatchInfoAndG rt p) where 241 unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2 242 243type instance PatchId (PatchInfoAndG rt p) = PatchInfo 244 245instance Ident (PatchInfoAndG rt p) where 246 ident (PIAP i _) = i 247 248instance IdEq2 (PatchInfoAndG rt p) 249 250instance PatchListFormat (PatchInfoAndG rt p) 251 252instance ShowPatchBasic p => ShowPatchBasic (PatchInfoAndG rt p) where 253 showPatch f (PIAP n p) = 254 case hopefully2either p of 255 Right x -> showPatch f x 256 Left _ -> showPatchInfo f n 257 258instance ShowContextPatch p => ShowContextPatch (PatchInfoAndG rt p) where 259 showContextPatch f (PIAP n p) = 260 case hopefully2either p of 261 Right x -> showContextPatch f x 262 Left _ -> return $ showPatchInfo f n 263 264instance (Summary p, PatchListFormat p, 265 ShowPatch p) => ShowPatch (PatchInfoAndG rt p) where 266 description (PIAP n _) = displayPatchInfo n 267 summary (PIAP _ p) = 268 case hopefully2either p of 269 Right x -> summary x 270 Left _ -> text $ "[patch summary is unavailable]" 271 summaryFL = vcat . mapFL summary 272 content (PIAP _ p) = 273 case hopefully2either p of 274 Right x -> content x 275 Left _ -> text $ "[patch content is unavailable]" 276 277instance (PatchId p ~ PatchInfo, Commute p) => Commute (PatchInfoAndG rt p) where 278 commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y) 279 return $ (ident y `piap` y') :> (ident x `piap` x') 280 281instance (PatchId p ~ PatchInfo, CleanMerge p) => 282 CleanMerge (PatchInfoAndG rt p) where 283 cleanMerge (x :\/: y) 284 | ident x == ident y = error "cannot cleanMerge identical PatchInfoAndG" 285 | otherwise = do 286 y' :/\: x' <- cleanMerge (hopefully x :\/: hopefully y) 287 return $ (ident y `piap` y') :/\: (ident x `piap` x') 288 289instance (PatchId p ~ PatchInfo, Merge p) => Merge (PatchInfoAndG rt p) where 290 merge (x :\/: y) 291 | ident x == ident y = error "cannot merge identical PatchInfoAndG" 292 | otherwise = 293 case merge (hopefully x :\/: hopefully y) of 294 y' :/\: x' -> (ident y `piap` y') :/\: (ident x `piap` x') 295 296instance PatchInspect p => PatchInspect (PatchInfoAndG rt p) where 297 listTouchedFiles = listTouchedFiles . hopefully 298 hunkMatches f = hunkMatches f . hopefully 299 300instance Apply p => Apply (PatchInfoAndG rt p) where 301 type ApplyState (PatchInfoAndG rt p) = ApplyState p 302 apply = apply . hopefully 303 unapply = unapply .hopefully 304 305instance ( ReadPatch p, Ident p, PatchId p ~ PatchInfo 306 ) => ReadPatch (PatchInfoAndG rt p) where 307 readPatch' = mapSeal n2pia <$> readPatch' 308 309instance Effect p => Effect (PatchInfoAndG rt p) where 310 effect = effect . hopefully 311 312instance IsHunk (PatchInfoAndG rt p) where 313 isHunk _ = Nothing 314 315instance PatchDebug p => PatchDebug (PatchInfoAndG rt p) 316 317instance (Commute p, Conflict p) => Conflict (PatchInfoAnd rt p) where 318 -- Note: this relies on the laziness of 'hopefully' for efficiency 319 -- and correctness in the face of lazy repositories 320 resolveConflicts context patches = 321 resolveConflicts (mapRL_RL hopefully context) (mapRL_RL hopefully patches) 322