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