packages feed

sr-extra 1.64 → 1.72.1

raw patch · 16 files changed

+707/−160 lines, 16 filesdep +transformersdep +unexceptionalio-transdep ~ListLike

Dependencies added: transformers, unexceptionalio-trans

Dependency ranges changed: ListLike

Files

+ Extra/ErrorControl.hs view
@@ -0,0 +1,104 @@+-- | From the PureScript Error.Control package by Luka Jacobowitz.++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Extra.ErrorControl+  ( MonadError(throwError) -- re-export+  , ErrorControl(controlError, accept)+  , intercept+  , trial+  , trialT+  , absolve+  , assure+  ) where++import Control.Monad.Except+  (catchError, ExceptT(ExceptT), lift, MonadError, runExceptT, throwError, withExceptT)+import Control.Monad.Identity (Identity(Identity), runIdentity)+import Control.Monad.Reader (mapReaderT, ReaderT(ReaderT), runReaderT)+import Control.Monad.RWS (mapRWST, runRWST, RWST(RWST))+import Control.Monad.State (mapStateT, runStateT, StateT(StateT))+import Control.Monad.Writer (mapWriterT, runWriterT, WriterT(WriterT))+import Control.Exception (IOException)+import UnexceptionalIO.Trans (run, UIO, unsafeFromIO)++class (MonadError e m, Monad n) => ErrorControl e m n where+  controlError :: m a -> (e -> n a) -> n a+  accept :: n a -> m a++instance ErrorControl e (Either e) Identity where+  controlError ma f = either f Identity ma+  accept = Right . runIdentity++instance ErrorControl IOException IO UIO where+  controlError ma f = unsafeFromIO (ma `catchError` (accept . f))+  accept = run++instance Monad m => ErrorControl e (ExceptT e m) m where+  controlError ma f = runExceptT ma >>= either f pure+  accept = lift++-- | Resolve the error on the left side of an Either.+instance Monad m => ErrorControl (Either e1 e2) (ExceptT (Either e1 e2) m) (ExceptT e2 m) where+  controlError :: ExceptT (Either e1 e2) m a -> (Either e1 e2 -> ExceptT e2 m a) -> ExceptT e2 m a+  controlError ma f =+    ExceptT (pivot <$> runExceptT ma) >>= either pure (f . Left)+    where+      pivot :: Either (Either a b) c -> Either b (Either c a)+      pivot = either (either (Right . Right) Left) (Right . Left)+  accept :: ExceptT e2 m a -> ExceptT (Either e1 e2) m a+  accept = withExceptT Right++#if 0+-- | Resolve the error on the right side of an Either.  (It turns out+-- this actually does conflict with the one above.)+instance Monad m => ErrorControl (Either e1 e2) (ExceptT (Either e1 e2) m) (ExceptT e1 m) where+  controlError ma f =+    ExceptT (pivot <$> runExceptT ma) >>= either (f . Right) pure+    where+      pivot :: Either (Either a b) c -> Either a (Either b c)+      pivot = either (either Left (Right . Left)) (Right . Right)+  accept = withExceptT Left+#endif++instance ErrorControl e m n => ErrorControl e (StateT s m) (StateT s n) where+  controlError sma f = StateT (\s -> controlError (runStateT sma s) (\e -> runStateT (f e) s))+  accept = mapStateT accept++instance ErrorControl e m n => ErrorControl e (ReaderT r m) (ReaderT r n) where+  controlError rma f = ReaderT (\r -> controlError (runReaderT rma r) (\e -> runReaderT (f e) r))+  accept = mapReaderT accept++instance (ErrorControl e m n, Monoid w) => ErrorControl e (WriterT w m) (WriterT w n) where+  controlError wma f = WriterT (controlError (runWriterT wma) (runWriterT . f))+  accept = mapWriterT accept++instance (ErrorControl e m n, Monoid w) => ErrorControl e (RWST r w s m) (RWST r w s n) where+  controlError rwsma f = RWST (\r s -> controlError (runRWST rwsma r s) (\e -> runRWST (f e) r s))+  accept = mapRWST accept++-- | Enhanced 'handleError'+intercept :: ErrorControl e m n => m a -> (e -> a) -> n a+intercept fa f = controlError fa (pure . f)++-- | Enhanced 'try'+trial :: ErrorControl e m n => m a -> n (Either e a)  -- try+trial fa = intercept (fmap Right fa) Left++trialT :: ErrorControl e m n => m a -> ExceptT e n a+trialT fa = ExceptT (trial fa)++absolve :: ErrorControl e m n => n (Either e a) -> m a+absolve gea = accept gea >>= (either throwError pure)++assure :: ErrorControl e m n => n a -> (a -> e) -> (a -> Bool) -> m a+assure ga err predicate =+  accept ga >>= (\a -> if predicate a then pure a else throwError (err a))
+ Extra/ErrorSet.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE ConstraintKinds, DataKinds, DeriveAnyClass, DeriveGeneric, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies #-}++-- | Type level "sets" as a cons list constructed of Eithers.++module Extra.ErrorSet+  ( Insert+  , Delete+  , Member(follow)+  , OneOf(OneOf, unOneOf)+  -- * Re-export+  -- , Void+  ) where++import Control.Lens+import Data.SafeCopy+import Data.Serialize+import Data.Typeable (Typeable)+import GHC.Generics++-- See SafeCopy issue #78+-- instance SafeCopy Void++type family Insert t s where+  Insert t (Either t a) = Either t a+  Insert t () = Either t ()+  Insert t (Either a b) = Either a (Insert t b)++type family Delete t s where+  Delete t (Either t a) = a+  Delete t () = ()+  Delete t (Either a b) = Either a (Delete t b)++class Member t set where follow :: Prism' set t+instance Member t (Either t a) where follow = _Left+instance {-# OVERLAPS #-} Member t b => Member t (Either a b) where follow = _Right . follow+instance Member t () where follow = error "Type Set Error"+instance Member t (OneOf set) where follow = iso OneOf unOneOf . follow++newtype OneOf (set :: *) = OneOf {unOneOf :: set} deriving (Show, Eq, Ord, Generic, Serialize, Typeable)+instance (SafeCopy set, Typeable set) => SafeCopy (OneOf set)
+ Extra/Errors.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Extra.Errors+  ( IsMember+  , Nub+  , OneOf(Empty, Val, NoVal)+  , Set(set)+  , Get(get)+  , oneOf+  , DeleteList+  , DeleteOneOf+  , Delete(delete)+  , Member+  , throwMember+  , liftMember+  , catchMember+  , test+  ) where++import Control.Lens (Prism', prism', review)+import Control.Monad.Except (MonadError, throwError)+--import Extra.Except (mapError)+import Data.Type.Bool+--import Data.Type.Equality+import Data.Word (Word8)+import Data.SafeCopy+import qualified Data.Serialize as S (Serialize(get, put), getWord8, Put, PutM, Get)+import Data.Typeable (Typeable, typeOf)+import Data.Proxy+import Extra.Except (tryError)++type family IsMember x ys where+  IsMember x '[] = 'False+  IsMember x (x ': ys) = 'True+  IsMember x (y ': ys) = IsMember x ys+  IsMember x ys = IsMember x ys++--type family Member x es where+--  Member' x (OneOf xs) = Member' x xs++type Member e es = (IsMember e es ~ 'True, Get e es, Set e es, Delete e es)++type family Nub xs where+  Nub '[] = '[]+  Nub (x ': ys) = If (IsMember x ys) ys (x ': Nub ys)++data OneOf (n :: [k]) where+  Empty :: OneOf s+  Val   :: e -> OneOf (e ': s)+  NoVal :: OneOf s -> OneOf (e ': s)++instance Show (OneOf '[]) where+  show Empty = "{}"++instance (Show e, Show (OneOf s)) => Show (OneOf (e ': s)) where+  show (Val e) = show e+  show (NoVal o) = show o+  show Empty  = "{}"++instance S.Serialize (OneOf '[]) where+  get :: S.Get (OneOf s)+  get = return Empty+  put :: OneOf s -> S.PutM ()+  put Empty = return ()+  put _ = error "fix warning"++instance (S.Serialize e, S.Serialize (OneOf s)) => S.Serialize (OneOf (e ': s)) where+  put :: OneOf (e ': s) -> S.PutM ()+  put (NoVal o) = S.put (0 :: Word8) >> S.put o+  put (Val e) = S.put (1 :: Word8) >> S.put e+  put _ = error "impossible"+  get :: S.Get (OneOf (e ': s))+  get = S.getWord8 >>= \case+    0 -> NoVal <$> S.get+    _ -> error "impossible"++instance SafeCopy (OneOf '[]) where+  version = 1+  kind = base+  getCopy :: S.Serialize (OneOf s) => Contained (S.Get (OneOf s))+  getCopy = contain S.get+  putCopy :: S.Serialize (OneOf s) => OneOf s -> Contained S.Put+  putCopy = contain . S.put+  errorTypeName _ = "()"++instance (SafeCopy e, S.Serialize e, Typeable e,  S.Serialize (OneOf s), Typeable s) => SafeCopy (OneOf (e ': s)) where+  version = 1+  kind = base+  getCopy :: Contained (S.Get (OneOf (e ': s)))+  getCopy = contain S.get+  putCopy :: OneOf (e ': s) -> Contained S.Put+  putCopy = contain . S.put+  errorTypeName = show . typeOf++class Set e xs where+  set :: e -> OneOf xs++instance Set e (e ': xs) where+  set e = Val e++instance {-# OVERLAPS #-} (IsMember e xs ~ 'True, Set e xs) => Set e (f ': xs) where+  set e = NoVal (set e)++class Get e xs where+  get :: OneOf xs -> Maybe e++instance {-# OVERLAPS #-} Get e (e ': xs) where+  get (Val e) = Just e+  get (NoVal _) = Nothing+  get Empty = error "impossible"++instance (IsMember e xs ~ 'True, Get e xs) => Get e (f ': xs) where+  get (NoVal o) = get o+  get (Val _e) = Nothing+  get Empty = error "impossible"++oneOf :: ({-IsMember e xs ~ 'True,-} Get e xs, Set e xs) => Prism' (OneOf xs) e+oneOf = prism' set get++type family DeleteList e xs where+  DeleteList x '[] = '[]+  DeleteList x (x ': ys) = ys+  DeleteList x (y ': ys) = (y ': (DeleteList x ys))++type family DeleteOneOf e xs where+  DeleteOneOf x (OneOf ys) = OneOf (DeleteList x ys)++class Delete e xs where+  delete :: Proxy e -> OneOf xs -> DeleteOneOf e (OneOf xs)++instance Delete e (e ': xs) where+  delete _ (Val _e) = Empty+  delete _ (NoVal o) = o+  delete _ Empty = Empty++instance {-# OVERLAPS #-} forall e f xs. (Delete e xs, DeleteList e (f:xs) ~ (f : DeleteList e xs)) => Delete e (f ': xs) where+   delete _p (Val v) = (Val v) -- :: OneOf (f ': (DeleteList e xs))+   delete p (NoVal o) = NoVal (delete p o)+   delete _p Empty = Empty++throwMember :: (Member e es, MonadError (OneOf es) m) => e -> m a+throwMember = throwError . review oneOf++liftMember :: (Member e es, MonadError (OneOf es) m) => Either e a -> m a+liftMember = either throwMember return++catchMember ::+  forall e es es' m n a.+  (Member e es, es' ~ DeleteList e es,+   MonadError (OneOf es) m, MonadError (OneOf es') n)+  => (forall b. (OneOf es -> OneOf es') -> m b -> n b)+  -> m a -> (e -> n a) -> n a+catchMember helper ma f =+  -- The idea here is that we use tryError to bring a copy of e into+  -- the return value, then we can just delete e from error monad.+  helper (delete @e Proxy) (tryError ma) >>= either handle return+  where handle :: OneOf es -> n a+        handle es = maybe (throwError (delete @e Proxy es)) f (get es :: Maybe e)++-- ** Example++data ErrorFoo = Foo deriving Show+data ErrorBar = Bar deriving Show+data ErrorBaz = Baz deriving Show++type AppErrors = OneOf '[ErrorFoo, ErrorBar, ErrorBaz]++handleBar :: (Member ErrorBar errors) => OneOf errors -> IO (DeleteOneOf ErrorBar (OneOf errors))+handleBar err =+  do case get err of+       Nothing -> putStrLn "no Bar error to handle"+       (Just Bar) -> putStrLn "took care of Bar"+     pure (delete @ErrorBar Proxy err)++handleFoo :: ({-IsMember ErrorFoo errors ~ 'True,-} Get ErrorFoo errors, Delete ErrorFoo errors) => OneOf errors -> IO (DeleteOneOf ErrorFoo (OneOf errors))+handleFoo err =+  do case get err of+       Nothing -> putStrLn "no Bar error to handle"+       (Just Foo) -> putStrLn "took care of Bar"+     pure (delete @ErrorFoo Proxy err)++{-+Generates the ouput:++current error = Foo+no Bar error to handle+current error = Foo+took care of Bar+current error = {}+-}+test :: IO ()+test =+  do let errAll = set Foo :: AppErrors+     putStrLn $ "current error = " ++ show errAll++     errNoBar <- handleBar errAll+     putStrLn $ "current error = " ++ show errNoBar++     errNoFoo <- handleFoo errNoBar+     putStrLn $ "current error = " ++ show errNoFoo++     -- this will not compile because ErrorFoo has already been handled+--     errNoFoFoo <- handleFoo errNoFoo++     pure ()
Extra/Except.hs view
@@ -1,4 +1,13 @@-{-# LANGUAGE CPP, DeriveAnyClass, FunctionalDependencies, OverloadedStrings, TemplateHaskell, UndecidableInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS -Wall -Wredundant-constraints -Wno-orphans #-}  module Extra.Except@@ -8,41 +17,54 @@       -- * Control.Monad.Except extensions     , tryError     , withError+    , withError'     , mapError     , handleError-    , HasIOException(fromIOException)+    , HasIOException(ioException)+    , HasNonIOException(nonIOException)+    , HasErrorCall(..)     , IOException'(..)-#if 1-    , Tried(unTried)-    , tryIO-    , logIOError-#else-    , LyftIO(lyftIO, IOMonad, ErrorType)-    , tryLiftIO-    , logLiftIO+    -- , HasSomeNonPseudoException(someNonPseudoException)+    , SomeNonPseudoException'+    -- , lyftIO+    -- , lyftIO'     , lyftIO'-    , LyftIO'-    , LyftIO2-    , lyftIO2--    , MonadIOError-    , liftIOError-    , tryIOError+    , lyftIO+#if !__GHCJS__     , logIOError #endif     , module Control.Monad.Except     ) where -import Control.Exception ({-evaluate,-} Exception, IOException, SomeException(..))+import Control.Applicative+import Control.Exception hiding (catch) -- ({-evaluate,-} Exception, IOException, SomeException(..))+import Control.Lens (iso, Prism', preview, prism, review, _Right) import Control.Monad.Catch import Control.Monad.Except---import Control.Monad.Reader (ReaderT)---import Control.Monad.RWS (RWST)---import Control.Monad.State (StateT)---import Control.Monad.Writer (WriterT)-import Data.Typeable (typeOf)+import Control.Monad.Trans (MonadTrans(lift), liftIO)+import Control.Monad.Except (ExceptT, runExceptT)+import Data.Maybe (fromJust)+import Data.Serialize+import Data.Typeable (Typeable, typeOf)+import Extra.ErrorControl+#if !__GHCJS__ import Extra.Log (logException, Priority(ERROR))+#endif+import Foreign.C.Types (CInt(..))+import GHC.Generics (Generic)+import GHC.IO.Exception (IOException(IOError), IOErrorType(..))+import UnexceptionalIO.Trans +deriving instance Generic CInt+deriving instance Serialize CInt+deriving instance Generic IOErrorType+deriving instance Serialize IOErrorType+deriving instance Generic IOException+instance Serialize IOException where+  put (IOError _handle a b c d e) = put a >> put b >> put c >> put d >> put e+  get = uncurry6 IOError (pure Nothing, get, get, get, get, get)+    where uncurry6 f (h, t, l, d, e, p) = f <$> h <*> t <*> l <*> d <*> e <*> p+ -- | Apply a function to whatever @Exception@ type is inside a -- @SomeException@: --@@ -63,9 +85,14 @@ tryError :: MonadError e m => m a -> m (Either e a) tryError action = (Right <$> action) `catchError` (pure . Left) +-- | Absorb an ExceptT e' action into another MonadError instance.+withError :: MonadError e m => (e' -> e) -> ExceptT e' m a -> m a+withError f action = runExceptT (withExceptT f action) >>= liftEither+ -- | Modify the value (but not the type) of an error-withError :: MonadError e m => (e -> e) -> m a -> m a-withError f action = tryError action >>= either (throwError . f) return+withError' :: MonadError e m => (e -> e) -> m a -> m a+withError' f action = tryError action >>= either (throwError . f) return+{-# DEPRECATED withError' "withError might to be able to do this job" #-}  handleError :: MonadError e m => (e -> m a) -> m a -> m a handleError = flip catchError@@ -104,105 +131,172 @@ -- -- >>> runExceptT (readFile' "/etc/nonexistant" :: ExceptT Error IO String) -- Left (Error /etc/nonexistant: openFile: does not exist (No such file or directory))-class HasIOException e where fromIOException :: IOException -> e+class HasIOException e where ioException :: Prism' e IOException+instance HasIOException IOException where ioException = id  newtype IOException' = IOException' IOException instance Show IOException' where show (IOException' e) = "(IOException' " <> show (show e) <> ")"-instance HasIOException IOException' where fromIOException = IOException' -#if 1---- Newtype wrapper around values that are the result of an IO--- operation invoked with try.  The Tried constructor is private--- so it can only appear as the result of the lyftIO operation.-newtype Tried a = Tried {unTried :: a} deriving Functor--tryIO :: (MonadIO m, MonadCatch m, Exception e, MonadError e m) => m a -> ExceptT e m (Tried a)-tryIO io = lift (try io >>= liftEither . fmap Tried)+class HasErrorCall e where fromErrorCall :: ErrorCall -> e+instance HasErrorCall ErrorCall where fromErrorCall = id +#if !__GHCJS__ logIOError :: (MonadIO m, MonadError e m) => m a -> m a logIOError = handleError (\e -> liftIO ($logException ERROR (pure e)) >> throwError e)+#endif -#else+instance MonadCatch UIO where+  catch uio f = unsafeFromIO $ catch (run uio) (\e -> run (f e))+instance MonadThrow UIO where+  throwM = unsafeFromIO . throwM -class (MonadIO (IOMonad m),-       -- The idea of LyftIO is to be a wrapper around a MonadIO-       -- instance that is not itself a MonadIO instance. that means-       -- you have to use lyftIO to run IO rather than liftIO, and-       -- lyftIO always catches exceptions.-       Exception (ErrorType m),-       MonadCatch m,-       MonadCatch (IOMonad m),-       MonadError (ErrorType m) m,-       MonadError (ErrorType m) (IOMonad m),-       -- IOMonad m must have the same error type as m, this is-       -- generally done through error constraints like-       -- HasIOException.-       HasIOException (ErrorType m)) => LyftIO m where-  type ErrorType m-  type IOMonad m :: * -> *-  lyftIO :: IOMonad m a -> m a+#if 0+instance Unexceptional m => Unexceptional (ServerPartT m) where+  lift = error "instance Unexceptional (ServerPartT m)"+#endif -instance {-# Overlapping #-} (MonadIO m,-                              e ~ ErrorType m,-                              Exception e,-                              MonadCatch m,-                              MonadError e (IOMonad (ExceptT e m)),-                              HasIOException e) => LyftIO (ExceptT e m) where-  type ErrorType (ExceptT e m) = e-  type IOMonad (ExceptT e m) = m-  lyftIO io = lift (try io >>= liftEither)+instance MonadPlus UIO where+  mzero = unsafeFromIO mzero+  mplus a b = unsafeFromIO (mplus (run a) (run b))+instance Alternative UIO where+  empty = unsafeFromIO empty+  a <|> b = unsafeFromIO (run a <|> run b) -instance LyftIO m => LyftIO (ReaderT r m) where-  type ErrorType (ReaderT r m) = ErrorType m-  type IOMonad (ReaderT r m) = IOMonad m-  lyftIO = lift . lyftIO-instance LyftIO m => LyftIO (StateT s m) where-  type ErrorType (StateT s m) = ErrorType m-  type IOMonad (StateT s m) = IOMonad m-  lyftIO = lift . lyftIO-instance (Monoid w, LyftIO m) => LyftIO (WriterT w m) where-  type ErrorType (WriterT w m) = ErrorType m-  type IOMonad (WriterT w m) = IOMonad m-  lyftIO = lift . lyftIO-instance (Monoid w, LyftIO m) => LyftIO (RWST r w s m) where-  type ErrorType (RWST r w s m) = ErrorType m-  type IOMonad (RWST r w s m) = IOMonad m-  lyftIO = lift . lyftIO+#if 0+-- | Like 'UnexceptionalIO.Trans.fromIO'', but lifts into any+-- 'MonadError' instance rather than only ExceptT.+lyftIO' ::+  (Unexceptional m, Exception e, MonadError e m)+  => (SomeNonPseudoException -> e)+  -> IO a+  -> m a+lyftIO' f io =+  runExceptT (fromIO' f io) >>= liftEither+  -- withError id (fromIO' (view someNonPseudoException) io) --- | LyftIO analog to the 'try' function.-tryLiftIO :: LyftIO m => IOMonad m a -> m (Either (ErrorType m) a)-tryLiftIO = tryError . lyftIO+-- | Like 'lyftIO' but gets the function argument from the type class+-- 'HasSomeNonPseudoException'.+lyftIO ::+  (Unexceptional m, Exception e, MonadError e m, HasSomeNonPseudoException e)+  => IO a+  -> m a+lyftIO = lyftIO' (review someNonPseudoException)+#endif -logLiftIO :: forall m a. LyftIO m => m a -> m a-logLiftIO = handleError (\e -> lyftIO ($logException ERROR (pure e) :: IOMonad m (ErrorType m)) >> throwError e)+lyftIO' ::+  forall e m a. (Unexceptional m, HasNonIOException e, HasIOException e, Exception e)+  => IO a+  -> ExceptT e m a+lyftIO' io =+  controlError+    (fromIO io :: ExceptT SomeNonPseudoException m a)+    (\(e :: SomeNonPseudoException) -> (maybe (throwError (review nonIOException e)) (\e' -> throwError (review ioException e')) (preview ioException e))) -type LyftIO' m = (LyftIO m, IOMonad m ~ ExceptT (ErrorType m) IO)+lyftIO ::+  (Unexceptional m, Exception e, MonadError e m, HasNonIOException e, HasIOException e)+  => IO a+  -> m a+lyftIO io = runExceptT (lyftIO' io) >>= either throwError return --- | Lift an IO action into any LyftIO instance.  Well, almost any--- LyftIO instance.-lyftIO' :: forall m a. (LyftIO' m) => IO a -> m a-lyftIO' io = lyftIO (withExceptT f (liftIO io))-  where f :: IOException' -> ErrorType m-        f = (fromIOException . (\(IOException' e) -> e))+class HasSomeNonPseudoException e where+  someNonPseudoException :: Prism' e SomeNonPseudoException+instance HasSomeNonPseudoException SomeNonPseudoException where+  someNonPseudoException = id -type LyftIO2 e m = (LyftIO' m, e ~ ErrorType m)+-- | This is an error that was caught by UnexceptionalIO and is not an+-- IO exception.  It is stored as a SomeNonPseudoException (or should+-- it be a SomeException?)+class HasNonIOException e where+  nonIOException :: Prism' e SomeNonPseudoException --- | Lift an @IOMonad m a@ action into @m a@.-lyftIO2 :: LyftIO2 e m => IOMonad m a -> m a-lyftIO2 action = lyftIO action+newtype NonIOException e = NonIOException {unNonIOException :: e} --- Backwards compatibiity+-- | A type we can derive from a 'SomeNonPseudoException' that has+-- IOException and NonIOException instances.+type SomeNonPseudoException' =+  Either (NonIOException SomeNonPseudoException) IOException -type MonadIOError e m = (LyftIO' m, e ~ ErrorType m)+-- | An example of a type that splits a 'SomeNonPseudoException' into+-- an IOException and a 'NonIOException'.  It happens to be an Iso'.+instance HasNonIOException SomeNonPseudoException' where+  nonIOException :: Prism' SomeNonPseudoException' SomeNonPseudoException+  nonIOException = iso f g+    where+      f :: SomeNonPseudoException' -> SomeNonPseudoException+      f = either unNonIOException (fromJust . fromException . toException)+      g :: SomeNonPseudoException -> SomeNonPseudoException'+      g e = maybe (Left (NonIOException e)) Right (fromException (toException e)) -liftIOError :: MonadIOError e m => IO a -> m a-liftIOError = lyftIO'+-- The HasIOException instance is easy.+instance HasIOException SomeNonPseudoException' where+  ioException = _Right -tryIOError :: MonadIOError e m => IO a -> m (Either e a)-tryIOError = tryError . liftIOError+instance HasIOException SomeNonPseudoException where+  ioException :: Prism' SomeNonPseudoException IOException+  ioException = prism f g+    where+      f :: IOException -> SomeNonPseudoException+      -- Because IOException is a non-pseudo exception this+      -- fromException will return a Just+      f = fromJust . fromException . toException+      g :: SomeNonPseudoException -> Either SomeNonPseudoException IOException+      g e = maybe (Left e) Right (fromException (toException e)) -logIOError :: MonadIOError e m => m a -> m a-logIOError = handleError (\e -> liftIOError ($logException ERROR (pure e)) >> throwError e)+-- Now use ErrorControl to handle the NonIOException and leave the IOException. +instance Monad m => ErrorControl SomeNonPseudoException' (ExceptT SomeNonPseudoException' m) (ExceptT IOException m) where+  controlError :: ExceptT SomeNonPseudoException' m a -> (SomeNonPseudoException' -> ExceptT IOException m a) -> ExceptT IOException m a+  controlError ma f = mapExceptT (\ma' -> ma' >>= either (runExceptT . f) (pure . Right)) ma+  accept :: ExceptT IOException m a -> ExceptT SomeNonPseudoException' m a+  accept = withExceptT Right++-- fromException :: Exception e => SomeException -> Maybe e+-- toException :: Exception e => e -> SomeException++-- | Convert a SomeNonPseudoException into any error type with+-- both IOException and NonIOException instances.  This has a+-- problem when you try to use 'accept' to convert an e back into+-- a SomeNonPseudoException, so best not to use accept.+#if 1+instance (Monad m, HasIOException e, HasNonIOException e, {-Typeable e, Show e,-} Exception e)+    => ErrorControl SomeNonPseudoException (ExceptT SomeNonPseudoException m) (ExceptT e m) where+  controlError :: ExceptT SomeNonPseudoException m a -> (SomeNonPseudoException -> ExceptT e m a) -> ExceptT e m a+  controlError ma f =+    mapExceptT (\ma' -> ma' >>= either+                                  (\e -> maybe+                                           (runExceptT (f e))+                                           (pure . Left . review ioException)+                                           (fromException (toException e) :: Maybe IOException))+                                  (pure . Right)) ma+  accept :: ExceptT e m a -> ExceptT SomeNonPseudoException m a+  accept = withExceptT convert+    where convert :: e -> SomeNonPseudoException+          convert e =+            case preview ioException e of+              Just ioe -> fromJust (fromException (toException ioe))+              Nothing ->+                case preview nonIOException e of+                  Just e' -> e'+                  -- If we can't use IOException or the NonIOException+                  -- use the Exception instance.  I'm not fully certain+                  -- what the implications of this happening are.+                  Nothing -> fromJust (fromException (toException e))++#else+instance Monad m => ErrorControl SomeNonPseudoException (ExceptT SomeNonPseudoException m) (ExceptT IOException m) where+  controlError :: ExceptT SomeNonPseudoException m a -> (SomeNonPseudoException -> ExceptT IOException m a) -> ExceptT IOException m a+  controlError ma f =+    -- My process...+    -- (undefined :: ExceptT IOException m a)+    -- mapExceptT (undefined :: m (Either SomeNonPseudoException a) -> m (Either IOException a)) ma+    -- mapExceptT (\ma' -> ma' >>= (undefined :: (Either SomeNonPseudoException a) -> m (Either IOException a))) ma+    -- mapExceptT (\ma' -> ma' >>= either (undefined :: SomeNonPseudoException -> m (Either IOException a)) (undefined :: a -> m (Either IOException a))) ma+    -- mapExceptT (\ma' -> ma' >>= either ((undefined :: SomeException -> m (Either IOException a)) . toException) (pure . Right)) ma+    -- mapExceptT (\ma' -> ma' >>= either (\e -> (undefined :: Maybe IOException -> m (Either IOException a)) $ fromException $ toException e) (pure . Right)) ma+    -- mapExceptT (\ma' -> ma' >>= either (\e -> (maybe (undefined :: m (Either IOException a)) (undefined :: IOException -> m (Either IOException a))) $ fromException $ toException e) (pure . Right)) ma+    -- mapExceptT (\ma' -> ma' >>= either (\(e :: SomeNonPseudoException) -> (maybe ((undefined :: ExceptT IOException m a -> m (Either IOException a)) (f e)) (pure . Left)) $ fromException $ toException e) (pure . Right)) ma+    mapExceptT (\ma' -> ma' >>= either (\e -> maybe (runExceptT (f e)) (pure . Left) $ fromException $ toException e) (pure . Right)) ma+  accept :: ExceptT IOException m a -> ExceptT SomeNonPseudoException m a+  -- This will work because IOException is a non-pseudo exception+  accept = withExceptT (fromJust . fromException . toException) #endif
Extra/Generics/Show.hs view
@@ -36,7 +36,7 @@ import Data.Proxy (Proxy(Proxy)) import Generic.Data (gconIndex) import GHC.Generics as G-import GHC.TypeLits+--import GHC.TypeLits import Text.Show.Combinators (PrecShowS, {-ShowFields,-} noFields, showField, showListWith, showInfix, showApp, showCon, showRecord) import qualified Text.Show.Combinators as Show (appendFields) @@ -77,7 +77,7 @@  class                                       DoFields p f           where doFields :: forall a. p (Rd a) -> TypeTuple -> ConstrTuple -> f a -> [S1Result] instance (DoFields p f, DoFields p g) =>    DoFields p (f :*: g)   where doFields p ti ci (x :*: y) = doFields p ti ci x <> doFields p ti ci y-instance (DoS1 p f, Selector s) =>          DoFields p (M1 S s f)  where doFields p ti ci (M1 x) = [doS1 p ti ci x]+instance (DoS1 p f{-, Selector s-}) =>      DoFields p (M1 S s f)  where doFields p ti ci (M1 x) = [doS1 p ti ci x] instance                                    DoFields p U1          where doFields _ _ _ U1 = []  class                                       DoNamed p f            where doNamed :: forall a. p (Rd a) -> TypeTuple -> ConstrTuple -> f a -> [(String, S1Result)]@@ -88,15 +88,15 @@ -- Its tempting to add the Constructor constraint here but it leads to -- a missing constraint on an unexported GHC.Generics class. class                                       DoConstructor p c f    where doConstructor :: forall a. p (Rd a) -> TypeTuple -> ConstrTuple -> M1 C c f a -> C1Result-instance (DoFields p f, KnownSymbol s) =>   DoConstructor p ('MetaCons s y 'False) f+instance (DoFields p f{-, KnownSymbol s-}) =>   DoConstructor p ('MetaCons s y 'False) f                                                                    where doConstructor p ti ci (M1 x) = doNormal ti ci (zip [0..] (doFields p ti ci x)) instance DoNamed p f =>   DoConstructor p ('MetaCons s y 'True) f  where doConstructor p ti ci (M1 x) = doRecord ti ci (zip [0..] (doNamed p ti ci x))  class                                       DoDatatype p d f       where doDatatype :: forall a. p (Rd a) -> TypeTuple -> M1 D d f a -> D1Result-instance (DoD1 p f, Datatype d) =>          DoDatatype p d f       where doDatatype p ti (M1 x) = doD1 p ti x+instance (DoD1 p f{-, Datatype d-}) =>          DoDatatype p d f       where doDatatype p ti (M1 x) = doD1 p ti x  class                                       DoD1 p f               where doD1 :: forall a. p (Rd a) -> TypeTuple -> f a -> D1Result-instance (DoDatatype p d f, Datatype d) =>  DoD1 p (M1 D d f)      where doD1 p ti x@(M1 _) = doDatatype p ti x+instance (DoDatatype p d f{-, Datatype d-}) =>  DoD1 p (M1 D d f)      where doD1 p ti x@(M1 _) = doDatatype p ti x instance (DoD1 p f, DoD1 p g) =>            DoD1 p (f :+: g)       where doD1 p ti (L1 x) = doD1 p ti x                                                                          doD1 p ti (R1 y) = doD1 p ti y instance (Constructor c, DoConstructor p c f) => DoD1 p (M1 C c f) where doD1 p ti x = doConstructor p ti (gconIndex x, G.conName x, G.conFixity x) x
Extra/Log.hs view
@@ -1,19 +1,24 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS -Wall #-}  module Extra.Log   ( alog   , Priority(..)+#if !__GHCJS__   , logException+  , logQ+#endif   ) where  import Control.Monad.Except (MonadError(catchError, throwError)) import Control.Monad.Trans (liftIO, MonadIO) import Data.Time (getCurrentTime) import Data.Time.Format (FormatTime(..), formatTime, defaultTimeLocale)+#if !__GHCJS__ import Language.Haskell.TH (ExpQ, Exp, Loc(..), location, pprint, Q)-import Language.Haskell.TH.Instances () import qualified Language.Haskell.TH.Lift as TH (Lift(lift))+import Language.Haskell.TH.Instances ()+#endif import System.Log.Logger (Priority(..), logM)  alog :: MonadIO m => String -> Priority -> String -> m ()@@ -38,6 +43,7 @@ formatTimeCombined :: FormatTime t => t -> String formatTimeCombined = formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z" +#if !__GHCJS__ -- | Create an expression of type (MonadIO m => Priority -> m a -> m -- a) that we can apply to an expression so that it catches, logs, and -- rethrows any exception.@@ -52,3 +58,11 @@  __LOC__ :: Q Exp __LOC__ = TH.lift =<< location++logQ :: ExpQ+logQ = do+  loc <- location+  [|\priority message ->+       alog $(TH.lift (show (loc_module loc))) priority+         ($(TH.lift (show (loc_module loc) <> ":" <> show (fst (loc_start loc)))) <> " - " <> message)|]+#endif
Extra/Monad/Supply.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -15,9 +16,12 @@ , evalSupply , runSupplyT , runSupply+, mapSupplyT , supplies ) where +import Control.Exception (throw)+import Control.Monad.Catch import Control.Monad.Fix import Control.Monad.Identity import Control.Monad.RWS@@ -27,6 +31,7 @@ import Control.Monad.Writer import Control.Monad.Morph (MFunctor(..)) import qualified Data.Semigroup as Sem+import Extra.ErrorControl  class Monad m => MonadSupply s m | m -> s where   supply :: m s@@ -96,6 +101,18 @@   mempty = return mempty   mappend = (<>) +instance ErrorControl e m n => ErrorControl e (SupplyT s m) (SupplyT s n) where+  controlError :: SupplyT s m a -> (e -> SupplyT s n a) -> SupplyT s n a+  controlError ma f = SupplyT (controlError (unSupplyT ma) (unSupplyT . f)) where unSupplyT (SupplyT s) = s+  accept (SupplyT n) = SupplyT (accept n)++instance (MonadCatch m, MonadIO m) => MonadCatch (SupplyT i m) where+  catch (SupplyT io) f = SupplyT (catch io (unSupplyT . f))+    where unSupplyT (SupplyT s) = s++instance (MonadThrow m, MonadIO m) => MonadThrow (SupplyT i m) where+  throwM = liftIO . throw+ -- | Get n supplies. supplies :: MonadSupply s m => Int -> m [s] supplies n = replicateM n supply@@ -111,3 +128,6 @@  runSupply :: Supply s a -> [s] -> (a,[s]) runSupply (Supply s) = runIdentity . runSupplyT s++mapSupplyT :: (m (a, [s]) -> n (b, [s])) -> SupplyT s m a -> SupplyT s n b+mapSupplyT f (SupplyT s) = SupplyT (mapStateT f s)
Extra/Orphans.hs view
@@ -46,7 +46,9 @@ #else #endif +#if !MIN_VERSION_network_uri(2,6,2) deriving instance Generic URIAuth+#endif  -- $(deriveLift ''UserId) instance Lift UserId where lift (UserId x0) = [|UserId $(lift x0)|]@@ -54,7 +56,7 @@ $(deriveLift ''G.Gr) $(deriveLift ''G.NodeMap) -instance Ppr UserId where ppr = ptext . show+instance Ppr UserId where ppr (UserId n) = ptext ("U" <> show n)  #if !__GHCJS__ instance Arbitrary T.Text where
Extra/Orphans2.hs view
@@ -14,7 +14,7 @@ import Data.Generics (TyCon, TypeRep, tyConFingerprint, tyConModule, tyConName, tyConPackage, splitTyConApp) import Data.Int (Int32) import Data.List (intercalate)-import Data.ListLike as LL+import Data.ListLike as LL hiding (show) import Data.Map as Map (Map, toList) import Data.SafeCopy (SafeCopy(..)) import Data.Set as Set (Set, toList)
Extra/Process.hs view
@@ -43,7 +43,7 @@ import Data.Text.Encoding (decodeUtf8) import Data.Time (diffUTCTime, getCurrentTime, NominalDiffTime) import Data.Typeable (typeOf)-import Extra.Except -- (LyftIO(lyftIO, ErrorType), LyftIO', lyftIO', withError, withException)+import Extra.Except import Extra.EnvPath (HasEnvRoot(envRootLens), rootPath) import Extra.Verbosity (ePutStrLn) import Extra.TH (here, prettyLocs)@@ -102,7 +102,7 @@     -> m (ExitCode, a, a) run opts p input = do   start " -> " p-  (result :: (ExitCode, a, a)) <- withError (withLoc $here) $ liftIO (readCreateProcessLazy p input) >>= overOutput >>= return . collectOutput+  (result :: (ExitCode, a, a)) <- withError' (withLoc $here) $ liftIO (readCreateProcessLazy p input) >>= overOutput >>= return . collectOutput   finish " <- " p result   return result     where
Extra/SafeCopy.hs view
@@ -4,7 +4,6 @@ -- message.  It also re-exports all other Data.Serialize symbols  {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-}@@ -24,30 +23,16 @@     ) where  import Control.Exception (ErrorCall(..), evaluate, )-import Control.Lens (Getter, _Left, over, Prism', prism, re)+import Control.Lens (Getter, Prism', prism, re) import Control.Monad.Catch (catch, MonadCatch) import Control.Monad.Except (MonadError, throwError) import Data.ByteString as B (ByteString, null)-#ifndef OMIT_DATA_INSTANCES-import Data.Data (Data)-#endif-import Data.Data (Proxy(Proxy), Typeable, typeRep)+import Data.Data (Proxy(Proxy), Typeable) import Data.SafeCopy (base, SafeCopy, safeGet, safePut) import Data.Serialize hiding (decode, encode)-import qualified Data.Serialize as Serialize (decode, encode)-import Data.Text as T hiding (concat, intercalate)-import Data.Text.Lazy as LT hiding (concat, intercalate)-import Data.Text.Encoding as TE-import Data.Text.Lazy.Encoding as TLE-import Data.Time (UTCTime(..), Day(ModifiedJulianDay), toModifiedJulianDay, DiffTime) import Data.UUID.Orphans ()-import Data.UUID (UUID)-import Data.UUID.Orphans () import Extra.Orphans ()-import Extra.Serialize (DecodeError(..), HasDecodeError(..))-import Extra.Time (Zulu(..))-import Language.Haskell.TH (Dec, Loc, TypeQ, Q)-import Network.URI (URI(..), URIAuth(..))+import Extra.Serialize (DecodeError(..), fakeTypeRep, HasDecodeError(fromDecodeError)) import System.IO.Unsafe (unsafePerformIO)  encode :: SafeCopy a => a -> ByteString@@ -61,12 +46,12 @@  -- | Monadic version of decode. decodeM ::-  forall a e m. (SafeCopy a, HasDecodeError e, MonadError e m)+  forall a e m. (SafeCopy a, Typeable a, HasDecodeError e, MonadError e m)   => ByteString   -> m a decodeM bs =   case decode bs of-    Left s -> throwError (fromDecodeError (DecodeError bs s))+    Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))     Right a -> return a  -- | Like 'decodeM', but also catches any ErrorCall thrown and lifts@@ -75,16 +60,16 @@ -- outside the serialize package, in which case this (and decode') are -- pointless. decodeM' ::-  forall e m a. (SafeCopy a, HasDecodeError e, MonadError e m, MonadCatch m)+  forall e m a. (SafeCopy a, Typeable a, HasDecodeError e, MonadError e m, MonadCatch m)   => ByteString   -> m a decodeM' bs = go `catch` handle   where     go = case decode bs of-           Left s -> throwError (fromDecodeError (DecodeError bs s))+           Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))            Right a -> return a     handle :: ErrorCall -> m a-    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs s+    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs (fakeTypeRep (Proxy @a)) s  -- | Version of decode that catches any thrown ErrorCall and modifies -- its message.
Extra/SafeCopyDebug.hs view
@@ -45,6 +45,7 @@ import Data.UUID.Orphans () import Extra.Orphans () import Extra.SafeCopy hiding (decode, decode', decodeM, decodeM')+import Extra.Serialize (fakeTypeRep) import Extra.SerializeDebug (Debug, DecodeError(..), HasDecodeError(..)) import Extra.Time (Zulu(..)) import Language.Haskell.TH (Dec, Loc, TypeQ, Q)@@ -64,7 +65,7 @@   -> m a decodeM bs =   case decode bs of-    Left s -> throwError (fromDecodeError (DecodeError bs s))+    Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))     Right a -> return a  -- | Like 'decodeM', but also catches any ErrorCall thrown and lifts@@ -79,10 +80,10 @@ decodeM' bs = go `catch` handle   where     go = case decode bs of-           Left s -> throwError (fromDecodeError (DecodeError bs s))+           Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))            Right a -> return a     handle :: ErrorCall -> m a-    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs s+    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs (fakeTypeRep (Proxy @a)) s  -- | Version of decode that catches any thrown ErrorCall and modifies -- its message.
Extra/Serialize.hs view
@@ -12,10 +12,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}  module Extra.Serialize     ( DecodeError(..)     , HasDecodeError(fromDecodeError)+    -- , HasDecodeFailure+    -- , decodeFailure, fromDecodeFailure     , module Data.Serialize     , decodePrism, deserializePrism     , encodeGetter, serializeGetter@@ -25,10 +28,11 @@     , decode'     , decodeM     , decodeM'+    , FakeTypeRep(..), fakeTypeRep     ) where  import Control.Exception (ErrorCall(..), evaluate, )-import Control.Lens (Getter, _Left, over, Prism', prism, re)+import Control.Lens (Getter, Prism', prism, re, review) import Control.Monad.Catch (catch, MonadCatch) import Control.Monad.Except (MonadError, throwError) import Data.ByteString as B (ByteString, null)@@ -36,17 +40,19 @@ import Data.Data (Data) #endif import Data.Data (Proxy(Proxy))-import Data.SafeCopy (base, SafeCopy(..), safeGet, safePut)+import Data.SafeCopy (SafeCopy(..), safeGet, safePut) import Data.Serialize hiding (decode, encode)-import qualified Data.Serialize as Serialize (decode, encode)+import qualified Data.Serialize as Serialize (encode) import Data.Text as T hiding (concat, intercalate) import Data.Text.Lazy as LT hiding (concat, intercalate) import Data.Text.Encoding as TE import Data.Text.Lazy.Encoding as TLE import Data.Time (UTCTime(..), Day(ModifiedJulianDay), toModifiedJulianDay, DiffTime)+import Data.Typeable (Typeable, typeRep) import Data.UUID.Orphans () import Data.UUID (UUID) import Data.UUID.Orphans ()+import qualified Extra.Errors as Errors import Extra.Orphans () import Extra.Time (Zulu(..)) import GHC.Generics (Generic)@@ -54,12 +60,29 @@ import Network.URI (URI(..), URIAuth(..)) import System.IO.Unsafe (unsafePerformIO) -data DecodeError = DecodeError ByteString String deriving (Generic, Eq, Ord)+newtype FakeTypeRep = FakeTypeRep String deriving (Generic, Eq, Ord, Serialize)+instance SafeCopy FakeTypeRep+fakeTypeRep :: forall a. Typeable a => Proxy a -> FakeTypeRep+fakeTypeRep a = FakeTypeRep (show (typeRep a)) +data DecodeError = DecodeError ByteString FakeTypeRep String deriving (Generic, Eq, Ord, Typeable)++instance Serialize DecodeError where get = safeGet; put = safePut+ class HasDecodeError e where fromDecodeError :: DecodeError -> e instance HasDecodeError DecodeError where fromDecodeError = id-instance Serialize DecodeError where get = safeGet; put = safePut +#if 0+-- New name for backwards compatibility, especially in appraisalscribe-migrate.+type HasDecodeFailure e = Errors.Member DecodeError e+decodeFailure :: Errors.Member DecodeError e => Prism' (Errors.OneOf e) DecodeError+decodeFailure = Errors.follow+fromDecodeFailure :: Errors.Member DecodeError e => DecodeError -> Errors.OneOf e+fromDecodeFailure = review decodeFailure+#endif++-- instance Member DecodeError DecodeError where follow = id+ encode :: Serialize a => a -> ByteString encode = Serialize.encode @@ -124,12 +147,12 @@  -- | Monadic version of decode. decodeM ::-  forall a e m. (Serialize a, HasDecodeError e, MonadError e m)+  forall a e m. (Serialize a, Typeable a, HasDecodeError e, MonadError e m)   => ByteString   -> m a decodeM bs =   case decode bs of-    Left s -> throwError (fromDecodeError (DecodeError bs s))+    Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))     Right a -> return a  -- | Like 'decodeM', but also catches any ErrorCall thrown and lifts@@ -138,16 +161,16 @@ -- outside the serialize package, in which case this (and decode') are -- pointless. decodeM' ::-  forall e m a. (Serialize a, HasDecodeError e, MonadError e m, MonadCatch m)+  forall e m a. (Serialize a, Typeable a, HasDecodeError e, MonadError e m, MonadCatch m)   => ByteString   -> m a decodeM' bs = go `catch` handle   where     go = case decode bs of-           Left s -> throwError (fromDecodeError (DecodeError bs s))+           Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))            Right a -> return a     handle :: ErrorCall -> m a-    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs s+    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs (fakeTypeRep (Proxy @a)) ("ErrorCall: " <> s)  -- | Version of decode that catches any thrown ErrorCall and modifies -- its message.@@ -178,9 +201,11 @@ instance SafeCopy DecodeError where version = 1  #ifndef OMIT_DATA_INSTANCES+deriving instance Data FakeTypeRep deriving instance Data DecodeError #endif  #ifndef OMIT_SHOW_INSTANCES+deriving instance Show FakeTypeRep deriving instance Show DecodeError #endif
Extra/SerializeDebug.hs view
@@ -16,7 +16,8 @@     ( module Extra.Serialize     , Debug     , DecodeError(..)-    , HasDecodeError(fromDecodeError)+    , HasDecodeError+    , fromDecodeError     , deserializePrism     , serializeGetter     , decode@@ -71,7 +72,7 @@   -> m a decodeM bs =   case decode bs of-    Left s -> throwError (fromDecodeError (DecodeError bs s))+    Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))     Right a -> return a  -- | Like 'decodeM', but also catches any ErrorCall thrown and lifts@@ -86,10 +87,10 @@ decodeM' bs = go `catch` handle   where     go = case decode bs of-           Left s -> throwError (fromDecodeError (DecodeError bs s))+           Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))            Right a -> return a     handle :: ErrorCall -> m a-    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs s+    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs (fakeTypeRep (Proxy @a)) s  -- | Version of decode that catches any thrown ErrorCall and modifies -- its message.
Extra/Text.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE CPP, RankNTypes #-}  module Extra.Text-    ( diffText+    ( Texty(textyString, textyText, textyLazy)+    , diffText     , camelWords     , capitalize     , Describe(describe')@@ -16,12 +17,39 @@ import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff) import Data.Char (isUpper, toUpper) import Data.ListLike (groupBy)+import Data.String (IsString) import Data.Text (split, Text, pack, unpack)+import qualified Data.Text.Lazy as Lazy ( fromStrict, pack, Text, toStrict, unpack ) #if !__GHCJS__ import Test.HUnit (assertEqual, Test(TestCase, TestList)) #endif import qualified Text.PrettyPrint as HPJ+-- * Texty +class (IsString a, Monoid a) => Texty a where+  textyString :: String -> a+  textyText :: Text -> a+  textyLazy :: Lazy.Text -> a++instance Texty Text where+  textyString = pack+  textyText = id+  textyLazy = Lazy.toStrict++instance Texty String where+  textyString = id+  textyText = unpack+  textyLazy = Lazy.unpack++instance Texty Lazy.Text where+  textyString = Lazy.pack+  textyText = Lazy.fromStrict+  textyLazy = id++-- | The ever needed, never available show that returns a Text.+textshow :: (Texty text, Show a) => a -> text+textshow = textyString . show+ -- | Output the difference between two string in the style of diff(1).  This -- can be used with Test.HUnit.assertString:  assertString (diffText ("a", "1\n2\n3\n"), ("b", "1\n3\n")) diffText :: (String, Text) -> (String, Text) -> String@@ -69,7 +97,3 @@ -- | Truncate a string to avoid writing monster lines into the log. trunc :: String -> String trunc s = if length s > 1000 then take 1000 s ++ "..." else s---- | The ever needed, never available show that returns a Text.-textshow :: Show a => a -> Text-textshow = pack . show
sr-extra.cabal view
@@ -1,5 +1,5 @@ Name:           sr-extra-Version:        1.64+Version:        1.72.1 License:        BSD3 License-File:   COPYING Author:         David Fox@@ -28,6 +28,10 @@    that we will use SafeCopy instances instead.   Default: False +flag omit-data+  Description: Omit all Data instances+  Default: False+ Library   GHC-Options: -Wall -Wredundant-constraints   Build-Depends:@@ -59,6 +63,8 @@     th-lift-instances,     th-orphans,     time >= 1.1,+    transformers,+    unexceptionalio-trans,     unix,     Unixutils >= 1.51,     userid,@@ -78,6 +84,9 @@     Extra.Debug2,     Extra.Either,     Extra.EnvPath,+    Extra.ErrorControl,+    Extra.Errors,+    Extra.ErrorSet,     Extra.Except,     Extra.Exit,     Extra.Files,@@ -127,6 +136,9 @@     Build-Depends: network-uri >= 2.6   else     Build-Depends: network >= 2.4++  if flag(omit-data)+    CPP-Options: -DOMIT_DATA_INSTANCES    if flag(omit-serialize)     CPP-Options: -DOMIT_SERIALIZE