src/Darcs/Hopefully.lhs

   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
  18
  19 \begin{code}
  20 {-# OPTIONS_GHC -cpp #-}
  21 {-# LANGUAGE CPP #-}
  22
  23 #include "gadts.h"
  24
  25 module Darcs.Hopefully ( Hopefully, PatchInfoAnd,
  26                          piap, n2pia, patchInfoAndPatch,
  27                          conscientiously, hopefully, info,
  28                          hopefullyM, createHashed, extractHash,
  29                          actually, unavailable ) where
  30
  31 import System.IO.Unsafe ( unsafeInterleaveIO )
  32
  33 import Darcs.SignalHandler ( catchNonSignal )
  34 import Printer ( Doc, renderString, errorDoc, text, ($$) )
  35 import Darcs.Patch.Info ( PatchInfo, human_friendly, idpatchinfo )
  36 import Darcs.Patch ( RepoPatch, Named, patch2patchinfo )
  37 import Darcs.Patch.Prim ( Effect(..), Conflict(..) )
  38 import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..),
  39                             ShowPatch(..), Commute(..) )
  40 import Darcs.Ordered ( MyEq, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) )
  41 import Darcs.Sealed ( Sealed(Sealed), seal, mapSeal )
  42 import Darcs.Utils ( prettyException )
  43
  44 -- | @'Hopefully' p C@ @(x y)@ is @'Either' String (p C@ @(x y))@ in a
  45 -- form adapted to darcs patches. The @C@ @(x y)@ represents the type
  46 -- witness for the patch that should be there. The @Hopefully@ type
  47 -- just tells whether we expect the patch to be hashed or not, and
  48 -- 'SimpleHopefully' does the real work of emulating
  49 -- 'Either'. @Hopefully sh@ represents an expected unhashed patch, and
  50 -- @Hashed hash sh@ represents an expected hashed patch with its hash.
  51 data Hopefully a C(x y) = Hopefully (SimpleHopefully a C(x y)) | Hashed String (SimpleHopefully a C(x y))
  52
  53 -- | @SimpleHopefully@ is a variant of @Either String@ adapted for
  54 -- type witnesses. @Actually@ is the equivalent of @Right@, while
  55 -- @Unavailable@ is @Left@.
  56 data SimpleHopefully a C(x y) = Actually (a C(x y)) | Unavailable String
  57
  58 -- | @'PatchInfoAnd' p C(a b)@ represents a hope we have to get a
  59 -- patch through its info. We're not sure we have the patch, but we
  60 -- know its info.
  61 data PatchInfoAnd p C(a b) = PIAP !PatchInfo (Hopefully (Named p) C(a b))
  62
  63 fmapH :: (a C(x y) -> b C(w z)) -> Hopefully a C(x y) -> Hopefully b C(w z)
  64 fmapH f (Hopefully sh) = Hopefully (ff sh)
  65     where ff (Actually a) = Actually (f a)
  66           ff (Unavailable e) = Unavailable e
  67 fmapH f (Hashed h sh) = Hashed h (ff sh)
  68     where ff (Actually a) = Actually (f a)
  69           ff (Unavailable e) = Unavailable e
  70
  71 info :: PatchInfoAnd p C(a b) -> PatchInfo
  72 info (PIAP i _) = i
  73
  74 -- | @'piap' i p@ creates a PatchInfoAnd containing p with info i.
  75 piap :: PatchInfo -> Named p C(a b) -> PatchInfoAnd p C(a b)
  76 piap i p = PIAP i (Hopefully $ Actually p)
  77
  78 -- | @n2pia@ creates a PatchInfoAnd represeting a @Named@ patch.
  79 n2pia :: Named p C(x y) -> PatchInfoAnd p C(x y)
  80 n2pia x = patch2patchinfo x `piap` x
  81
  82 patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) C(a b) -> PatchInfoAnd p C(a b)
  83 patchInfoAndPatch =  PIAP
  84
  85 -- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd'
  86 -- value. If it fails, it outputs an error \"failed to read patch:
  87 -- \<description of the patch>\". We get the description of the patch
  88 -- from the info part of 'hp'
  89 hopefully :: PatchInfoAnd p C(a b) -> Named p C(a b)
  90 hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e
  91
  92 -- | @'conscientiously' er hp@ tries to extract a patch from a 'PatchInfoAnd'.
  93 -- If it fails, it applies the error handling function @er@ to a description
  94 -- of the patch info component of @hp@.
  95 conscientiously :: (Doc -> Doc)
  96                 -> PatchInfoAnd p C(a b) -> Named p C(a b)
  97 conscientiously er (PIAP pinf hp) =
  98     case hopefully2either hp of
  99       Right p -> p
 100       Left e -> errorDoc $ er (human_friendly pinf $$ text e)
 101
 102 -- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a
 103 -- monad instead of erroring.
 104 hopefullyM :: Monad m => PatchInfoAnd p C(a b) -> m (Named p C(a b))
 105 hopefullyM (PIAP pinf hp) = case hopefully2either hp of
 106                               Right p -> return p
 107                               Left e -> fail $ renderString (human_friendly pinf $$ text e)
 108
 109 -- Any recommendations for a nice adverb to name the below?
 110 hopefully2either :: Hopefully a C(x y) -> Either String (a C(x y))
 111 hopefully2either (Hopefully (Actually p)) = Right p
 112 hopefully2either (Hashed _ (Actually p)) = Right p
 113 hopefully2either (Hopefully (Unavailable e)) = Left e
 114 hopefully2either (Hashed _ (Unavailable e)) = Left e
 115
 116 actually :: a C(x y) -> Hopefully a C(x y)
 117 actually = Hopefully . Actually
 118
 119 createHashed :: String -> (String -> IO (Sealed (a C(x)))) -> IO (Sealed (Hopefully a C(x)))
 120 createHashed h f = do mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler)
 121   where
 122   f' = do Sealed x <- f h
 123           return (Sealed (Actually x))
 124   handler e = return $ seal $ Unavailable $ prettyException e
 125
 126 extractHash :: PatchInfoAnd p C(a b) -> Either (Named p C(a b)) String
 127 extractHash (PIAP _ (Hashed s _)) = Right s
 128 extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp
 129
 130 unavailable :: String -> Hopefully a C(x y)
 131 unavailable = Hopefully . Unavailable
 132
 133 instance MyEq p => MyEq (PatchInfoAnd p) where
 134     unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2
 135
 136 --instance Invert (p C(x y)) => Invert (PatchInfoAnd (p C(x y))) where
 137 instance Invert p => Invert (PatchInfoAnd p) where
 138     identity = PIAP idpatchinfo (actually identity)
 139     invert (PIAP i p) = PIAP i (invert `fmapH` p)
 140
 141 instance (Conflict p, Effect p, ShowPatch p) => ShowPatch (PatchInfoAnd p) where
 142     showPatch (PIAP n p) = case hopefully2either p of
 143                            Right x -> showPatch x
 144                            Left _ -> human_friendly n
 145     showContextPatch s (PIAP n p) = case hopefully2either p of
 146                                     Right x -> showContextPatch s x
 147                                     Left _ -> human_friendly n
 148     description (PIAP n _) = human_friendly n
 149     summary (PIAP n p) = case hopefully2either p of
 150                          Right x -> summary x
 151                          Left _ -> human_friendly n
 152     showNicely (PIAP n p) = case hopefully2either p of
 153                             Right x -> showNicely x
 154                             Left _ -> human_friendly n
 155
 156 instance Commute p => Commute (PatchInfoAnd p) where
 157     commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y)
 158                           return $ (info y `piap` y') :> (info x `piap` x')
 159     list_touched_files = list_touched_files . hopefully
 160     merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of
 161                        y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x')
 162
 163 instance Apply p => Apply (PatchInfoAnd p) where
 164     apply opts p = apply opts $ hopefully p
 165     applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p
 166                             case mp' of
 167                               Nothing -> return Nothing
 168                               Just (e,p') -> return $ Just (e, n2pia p')
 169
 170 instance ReadPatch p => ReadPatch (PatchInfoAnd p) where
 171     readPatch' wanteof = do x <- readPatch' wanteof
 172                             case x of
 173                               Just (Sealed p) -> return $ Just $ Sealed $ n2pia p
 174                               Nothing -> return Nothing
 175
 176 instance Effect p => Effect (PatchInfoAnd p) where
 177     effect = effect . hopefully
 178     effectRL = effectRL . hopefully
 179
 180 instance Conflict p => Conflict (PatchInfoAnd p) where
 181     list_conflicted_files = list_conflicted_files . hopefully
 182     resolve_conflicts = resolve_conflicts . hopefully
 183     commute_no_conflicts (x:>y) = do y':>x' <- commute_no_conflicts (hopefully x :> hopefully y)
 184                                      return (info y `piap` y' :> info x `piap` x')
 185     conflictedEffect = conflictedEffect . hopefully
 186
 187 instance RepoPatch p => Patchy (PatchInfoAnd p)
 188
 189 \end{code}
 190