#include "gadts.h"
module Darcs.Patch.PatchInfoAnd ( Hopefully, PatchInfoAnd,
WPatchInfo, unWPatchInfo, compareWPatchInfo,
piap, n2pia, patchInfoAndPatch,
fmapPIAP, fmapFL_PIAP,
conscientiously, hopefully, info, winfo,
hopefullyM, createHashed, extractHash,
actually, unavailable, patchDesc ) where
import System.IO.Unsafe ( unsafeInterleaveIO )
import Darcs.SignalHandler ( catchNonSignal )
import Printer ( Doc, renderString, errorDoc, text, ($$), vcat )
import Darcs.Patch.Info ( PatchInfo, humanFriendly, justName )
import Darcs.Patch ( RepoPatch, Named, patch2patchinfo )
import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )
import Darcs.Patch.Effect ( Effect(..) )
import Darcs.Patch.FileHunk ( IsHunk(..) )
import Darcs.Patch.Format ( PatchListFormat )
import Darcs.Patch.Merge ( Merge(..) )
import Darcs.Patch.Named ( fmapNamed, fmapFL_Named )
import Darcs.Patch.Prim ( PrimPatchBase(..) )
import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..),
ShowPatch(..), Commute(..), PatchInspect(..) )
import Darcs.Patch.Repair ( Repair(..), RepairToFL )
import Darcs.Patch.Show ( ShowPatchBasic(..) )
import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )
import Darcs.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL )
import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal )
import Darcs.Utils ( prettyException )
import Storage.Hashed.Tree( Tree )
import Control.Applicative ( (<$>) )
data Hopefully a C(x y) = Hopefully (SimpleHopefully a C(x y)) | Hashed String (SimpleHopefully a C(x y))
data SimpleHopefully a C(x y) = Actually (a C(x y)) | Unavailable String
data PatchInfoAnd p C(a b) = PIAP !PatchInfo (Hopefully (Named p) C(a b))
instance PrimPatchBase p => PrimPatchBase (PatchInfoAnd p) where
type PrimOf (PatchInfoAnd p) = PrimOf p
newtype WPatchInfo C(a b) = WPatchInfo { unWPatchInfo :: PatchInfo }
compareWPatchInfo :: WPatchInfo C(a b) -> WPatchInfo C(c d) -> EqCheck C((a, b) (c, d))
compareWPatchInfo (WPatchInfo x) (WPatchInfo y) = if x == y then unsafeCoerceP IsEq else NotEq
instance MyEq WPatchInfo where
WPatchInfo x `unsafeCompare` WPatchInfo y = x == y
fmapH :: (a C(x y) -> b C(w z)) -> Hopefully a C(x y) -> Hopefully b C(w z)
fmapH f (Hopefully sh) = Hopefully (ff sh)
where ff (Actually a) = Actually (f a)
ff (Unavailable e) = Unavailable e
fmapH f (Hashed h sh) = Hashed h (ff sh)
where ff (Actually a) = Actually (f a)
ff (Unavailable e) = Unavailable e
info :: PatchInfoAnd p C(a b) -> PatchInfo
info (PIAP i _) = i
patchDesc :: forall p C(x y) . PatchInfoAnd p C(x y) -> String
patchDesc p = justName $ info p
winfo :: PatchInfoAnd p C(a b) -> WPatchInfo C(a b)
winfo (PIAP i _) = WPatchInfo i
piap :: PatchInfo -> Named p C(a b) -> PatchInfoAnd p C(a b)
piap i p = PIAP i (Hopefully $ Actually p)
n2pia :: Named p C(x y) -> PatchInfoAnd p C(x y)
n2pia x = patch2patchinfo x `piap` x
patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) C(a b) -> PatchInfoAnd p C(a b)
patchInfoAndPatch = PIAP
fmapPIAP :: (FORALL(a b) p C(a b) -> q C(a b)) -> PatchInfoAnd p C(x y) -> PatchInfoAnd q C(x y)
fmapPIAP f (PIAP i hp) = PIAP i (fmapH (fmapNamed f) hp)
fmapFL_PIAP :: (FL p C(x y) -> FL q C(x y)) -> PatchInfoAnd p C(x y) -> PatchInfoAnd q C(x y)
fmapFL_PIAP f (PIAP i hp) = PIAP i (fmapH (fmapFL_Named f) hp)
hopefully :: PatchInfoAnd p C(a b) -> Named p C(a b)
hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e
conscientiously :: (Doc -> Doc)
-> PatchInfoAnd p C(a b) -> Named p C(a b)
conscientiously er (PIAP pinf hp) =
case hopefully2either hp of
Right p -> p
Left e -> errorDoc $ er (humanFriendly pinf $$ text e)
hopefullyM :: Monad m => PatchInfoAnd p C(a b) -> m (Named p C(a b))
hopefullyM (PIAP pinf hp) = case hopefully2either hp of
Right p -> return p
Left e -> fail $ renderString (humanFriendly pinf $$ text e)
hopefully2either :: Hopefully a C(x y) -> Either String (a C(x y))
hopefully2either (Hopefully (Actually p)) = Right p
hopefully2either (Hashed _ (Actually p)) = Right p
hopefully2either (Hopefully (Unavailable e)) = Left e
hopefully2either (Hashed _ (Unavailable e)) = Left e
actually :: a C(x y) -> Hopefully a C(x y)
actually = Hopefully . Actually
createHashed :: String -> (String -> IO (Sealed (a C(x)))) -> IO (Sealed (Hopefully a C(x)))
createHashed h f = do mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler)
where
f' = do Sealed x <- f h
return (Sealed (Actually x))
handler e = return $ seal $ Unavailable $ prettyException e
extractHash :: PatchInfoAnd p C(a b) -> Either (Named p C(a b)) String
extractHash (PIAP _ (Hashed s _)) = Right s
extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp
unavailable :: String -> Hopefully a C(x y)
unavailable = Hopefully . Unavailable
instance (Commute p, MyEq p) => MyEq (PatchInfoAnd p) where
unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2
instance (Commute p, Invert p) => Invert (PatchInfoAnd p) where
invert (PIAP i p) = PIAP i (invert `fmapH` p)
instance PatchListFormat (PatchInfoAnd p)
instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (PatchInfoAnd p) where
showPatch (PIAP n p) = case hopefully2either p of
Right x -> showPatch x
Left _ -> humanFriendly n
instance (Apply p, Conflict p, CommuteNoConflicts p, IsHunk p, PatchListFormat p, PrimPatchBase p,
ShowPatch p, ApplyState p ~ Tree) => ShowPatch (PatchInfoAnd p) where
showContextPatch (PIAP n p) = case hopefully2either p of
Right x -> showContextPatch x
Left _ -> return $ humanFriendly n
description (PIAP n _) = humanFriendly n
summary (PIAP n p) = case hopefully2either p of
Right x -> summary x
Left _ -> humanFriendly n
summaryFL = vcat . mapFL summary
showNicely (PIAP n p) = case hopefully2either p of
Right x -> showNicely x
Left _ -> humanFriendly n
instance Commute p => Commute (PatchInfoAnd p) where
commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y)
return $ (info y `piap` y') :> (info x `piap` x')
instance Merge p => Merge (PatchInfoAnd p) where
merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of
y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x')
instance PatchInspect p => PatchInspect (PatchInfoAnd p) where
listTouchedFiles = listTouchedFiles . hopefully
hunkMatches _ _ = error "hunkmatches not implemented for PatchInfoAnd"
instance Apply p => Apply (PatchInfoAnd p) where
type ApplyState (PatchInfoAnd p) = ApplyState p
apply p = apply $ hopefully p
instance RepairToFL p => Repair (PatchInfoAnd p) where
applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p
case mp' of
Nothing -> return Nothing
Just (e,p') -> return $ Just (e, n2pia p')
instance (ReadPatch p, PatchListFormat p) => ReadPatch (PatchInfoAnd p) where
readPatch' = mapSeal n2pia <$> readPatch'
instance Effect p => Effect (PatchInfoAnd p) where
effect = effect . hopefully
effectRL = effectRL . hopefully
instance IsHunk (PatchInfoAnd p) where
isHunk _ = Nothing
instance (RepoPatch p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd p)