HopefullyPrivate.lhs

%  Copyright (C) 2006 David Roundy
%
%  This program is free software; you can redistribute it and/or modify
%  it under the terms of the GNU General Public License as published by
%  the Free Software Foundation; either version 2, or (at your option)
%  any later version.
%
%  This program is distributed in the hope that it will be useful,
%  but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
%  GNU General Public License for more details.
%
%  You should have received a copy of the GNU General Public License
%  along with this program; see the file COPYING.  If not, write to
%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
%  Boston, MA 02110-1301, USA.


\begin{code}
{-# OPTIONS_GHC -cpp #-}
#include "gadts.h"
module Darcs.HopefullyPrivate ( -- ratify HopefullyPrivate: obvously we need it here...
                                Hopefully(..), returnH, (>>>=), (>>>), fmapH, failH,
                                PatchInfoAnd,
                                piap, n2pia, patchInfoAndPatch,
                                conscientiously, hopefully, info,
                                hopefullyM, createHashed, extractHash,
                                actually, unavailable ) where

import System.IO.Unsafe ( unsafeInterleaveIO )

import Darcs.SignalHandler ( catchNonSignal )
import Printer ( Doc, renderString, errorDoc, text, ($$) )
import Darcs.Patch.Info ( PatchInfo, human_friendly, idpatchinfo )
import Darcs.Patch ( RepoPatch, Named, patch2patchinfo )
import Darcs.Patch.Prim ( Effect(..), Conflict(..) )
import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..),
                            ShowPatch(..), Commute(..) )
import Darcs.Patch.Ordered ( MyEq, unsafeCompare, (:>)(..), (:\/:)(..), (:/\:)(..) )
import Darcs.Sealed ( Sealed(Sealed), seal, mapSeal )
import Darcs.Utils ( prettyException )

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 Monad Hopefully where
    return a = Hopefully (Actually a)
    (Hopefully (Unavailable e)) >>= _ = Hopefully (Unavailable e)
    (Hashed h (Unavailable e)) >>= _ = Hashed h (Unavailable e)
    (Hopefully (Actually a)) >>= f = f a
    (Hashed _ (Actually a)) >>= f = f a
    fail e = Hopefully (Unavailable e)

instance Functor Hopefully where
    fmap = liftM
-}

returnH :: a C(x y) -> Hopefully a C(x y)
returnH = Hopefully . Actually

(>>>=) :: Hopefully a C(x y) -> (a C(x y) -> Hopefully b C(u v)) -> Hopefully b C(u v)
(Hopefully (Unavailable e)) >>>= _ = Hopefully (Unavailable e)
(Hashed h (Unavailable e)) >>>= _ = Hashed h (Unavailable e)
(Hopefully (Actually a)) >>>= f = f a
(Hashed _ (Actually a)) >>>= f = f a

(>>>) :: Hopefully a C(x y) -> Hopefully b C(u v) -> Hopefully b C(u v)
m >>> k = m >>>= \_ -> k

failH :: String -> Hopefully a C(x y)
failH e = Hopefully (Unavailable e)

fmapH :: (a C(x y) -> b C(w z)) -> Hopefully a C(x y) -> Hopefully b C(w z)
fmapH f m1 = m1 >>>= \x1 -> returnH (f x1)

info :: PatchInfoAnd p C(a b) -> PatchInfo
info (PIAP i _) = 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

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 (human_friendly 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 (human_friendly pinf $$ text e)

-- Any recommendations for a nice adverb to name the below?
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 MyEq p => MyEq (PatchInfoAnd p) where
    unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2

--instance Invert (p C(x y)) => Invert (PatchInfoAnd (p C(x y))) where
instance Invert p => Invert (PatchInfoAnd p) where
    identity = PIAP idpatchinfo (actually identity)
    invert (PIAP i p) = PIAP i (invert `fmapH` p)

instance (Conflict p, Effect p, ShowPatch p) => ShowPatch (PatchInfoAnd p) where
    showPatch (PIAP n p) = case hopefully2either p of
                           Right x -> showPatch x
                           Left _ -> human_friendly n
    showContextPatch s (PIAP n p) = case hopefully2either p of
                                    Right x -> showContextPatch s x
                                    Left _ -> human_friendly n
    description (PIAP n _) = human_friendly n
    summary (PIAP n p) = case hopefully2either p of
                         Right x -> summary x
                         Left _ -> human_friendly n
    showNicely (PIAP n p) = case hopefully2either p of
                            Right x -> showNicely x
                            Left _ -> human_friendly 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')
    list_touched_files = list_touched_files . hopefully
    merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of
                       y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x')

instance Apply p => Apply (PatchInfoAnd p) where
    apply opts p = apply opts $ hopefully p
    applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p
                            case mp' of
                              Nothing -> return Nothing
                              Just (e,p') -> return $ Just (e, n2pia p')

instance ReadPatch p => ReadPatch (PatchInfoAnd p) where
    readPatch' wanteof = do x <- readPatch' wanteof
                            case x of
                              Just (Sealed p) -> return $ Just $ Sealed $ n2pia p
                              Nothing -> return Nothing

instance Effect p => Effect (PatchInfoAnd p) where
    effect = effect . hopefully
    effectRL = effectRL . hopefully

instance Conflict (p C(x y)) => Conflict (PatchInfoAnd (p C(x y))) where
    list_conflicted_files = list_conflicted_files . hopefully
    resolve_conflicts = resolve_conflicts . hopefully
    commute_no_conflicts (x:>y) = do y':>x' <- commute_no_conflicts (hopefully x :> hopefully y)
                                     return (info y `piap` y' :> info x `piap` x')
    conflictedEffect = conflictedEffect . hopefully

instance RepoPatch (p C(x y)) => Patchy (PatchInfoAnd (p C(x y)))

\end{code}