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