packages feed

sr-extra 1.72.3 → 1.80

raw patch · 12 files changed

+251/−499 lines, 12 filesdep +base64-bytestringdep ~network-uridep ~template-haskell

Dependencies added: base64-bytestring

Dependency ranges changed: network-uri, template-haskell

Files

Extra/Errors.hs view
@@ -34,11 +34,15 @@   , throwMember   , liftMember   , catchMember+  , tryMember+  , mapMember+  , runNullExceptT+  , runNullExcept   , test   ) where  import Control.Lens (Prism', prism', review)-import Control.Monad.Except (MonadError, throwError)+import Control.Monad.Except (Except, ExceptT, MonadError, runExcept, runExceptT, throwError) --import Extra.Except (mapError) import Data.Type.Bool --import Data.Type.Equality@@ -164,6 +168,12 @@ liftMember :: (Member e es, MonadError (OneOf es) m) => Either e a -> m a liftMember = either throwMember return +-- | Run an action with @e@ added to the current error set @es@.+-- Typically this is used by forcing the action into ExceptT with+-- the augmented error type:+-- @@+--   catchMember withExceptT (fileIO @(FileError ': e) (Right <$> query st (LookValue key))) (return . Left)+-- @@ catchMember ::   forall e es es' m n a.   (Member e es, es' ~ DeleteList e es,@@ -176,6 +186,21 @@   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)++-- | Simplified catchMember where the monad doesn't change.+tryMember :: forall e es m a. (Member e es, MonadError (OneOf es) m) => m a -> (e -> m a) -> m a+tryMember ma f = tryError ma >>= either (\es -> maybe ma f (get es :: Maybe e)) return++-- | Annotate a member error that has been thrown.+mapMember :: forall e es m a. (Member e es, MonadError (OneOf es) m) => (e -> m e) -> m a -> m a+mapMember f ma =+  tryError ma >>= either (\es -> maybe (throwError es) (\e -> f e >>= throwMember) (get es :: Maybe e)) return++runNullExceptT :: Functor m => ExceptT (OneOf '[]) m a -> m a+runNullExceptT m = (\(Right a) -> a) <$> runExceptT m++runNullExcept :: Except (OneOf '[]) a -> a+runNullExcept m = (\(Right a) -> a) (runExcept m)  -- ** Example
Extra/Except.hs view
@@ -21,14 +21,12 @@     , mapError     , handleError     , HasIOException(ioException)+    , NonIOException(NonIOException)     , HasNonIOException(nonIOException)+    , splitException     , HasErrorCall(..)     , IOException'(..)-    -- , HasSomeNonPseudoException(someNonPseudoException)-    , SomeNonPseudoException'-    -- , lyftIO-    -- , lyftIO'-    , lyftIO'+    , MonadUIO     , lyftIO #if !__GHCJS__     , logIOError@@ -38,15 +36,13 @@  import Control.Applicative import Control.Exception hiding (catch) -- ({-evaluate,-} Exception, IOException, SomeException(..))-import Control.Lens (iso, Prism', preview, prism, review, _Right)+import Control.Lens (Prism', review) import Control.Monad.Catch import Control.Monad.Except 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+import Data.Typeable (typeOf) #if !__GHCJS__ import Extra.Log (logException, Priority(ERROR)) #endif@@ -150,11 +146,6 @@ instance MonadThrow UIO where   throwM = unsafeFromIO . throwM -#if 0-instance Unexceptional m => Unexceptional (ServerPartT m) where-  lift = error "instance Unexceptional (ServerPartT m)"-#endif- instance MonadPlus UIO where   mzero = unsafeFromIO mzero   mplus a b = unsafeFromIO (mplus (run a) (run b))@@ -162,141 +153,19 @@   empty = unsafeFromIO empty   a <|> b = unsafeFromIO (run a <|> run b) -#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)---- | 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--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)))--lyftIO ::-  (Unexceptional m, Exception e, MonadError e m, HasNonIOException e, HasIOException e)-  => IO a-  -> m a-lyftIO io = runExceptT (lyftIO' io) >>= either throwError return--class HasSomeNonPseudoException e where-  someNonPseudoException :: Prism' e SomeNonPseudoException-instance HasSomeNonPseudoException SomeNonPseudoException where-  someNonPseudoException = id---- | 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--newtype NonIOException e = NonIOException {unNonIOException :: e}---- | A type we can derive from a 'SomeNonPseudoException' that has--- IOException and NonIOException instances.-type SomeNonPseudoException' =-  Either (NonIOException SomeNonPseudoException) IOException---- | 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))---- The HasIOException instance is easy.-instance HasIOException SomeNonPseudoException' where-  ioException = _Right--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))---- 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+type MonadUIO = Unexceptional --- fromException :: Exception e => SomeException -> Maybe e--- toException :: Exception e => e -> SomeException+lyftIO :: (Unexceptional m, MonadError e m, HasIOException e, HasNonIOException e) => IO a -> m a+lyftIO io = runExceptT (fromIO io) >>= either (throwError . splitException) return --- | 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))+-- | If 'fromIO' throws a SomeNonPseudoException, 'splitException'+-- decides whether it was an 'IOException' or something else, this+-- wrapper indicates it was something else.+newtype NonIOException = NonIOException SomeNonPseudoException deriving Show+class HasNonIOException e where nonIOException :: Prism' e NonIOException+instance HasNonIOException NonIOException where nonIOException = id -#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+splitException :: (HasIOException e, HasNonIOException e) => SomeNonPseudoException -> e+splitException e =+  maybe (review nonIOException (NonIOException e)) (review ioException)+    (fromException (toException e) :: Maybe IOException)
Extra/IO.hs view
@@ -46,17 +46,17 @@ testAndWrite :: (FilePath -> Text -> Text -> IO ()) -> FilePath -> Text -> IO () testAndWrite changeAction dest new = do   here <- getCurrentDirectory-  alog "Extra.IO" DEBUG ("testAndWriteFile " <> show dest <> " " <> show (shorten 50 new) <> " (cwd=" <> show here <> ")")+  alog DEBUG ("testAndWriteFile " <> show dest <> " " <> show (shorten 50 new) <> " (cwd=" <> show here <> ")")   removeFileMaybe (dest <> ".new")   try (Text.readFile dest >>= \old ->        when (old /= new) (changeAction dest old new)) >>=     either (\(e :: IOException) ->               case isDoesNotExistError e of                 True -> do-                  alog "Extra.IO" DEBUG "testAndWriteFile - no existing version"+                  alog DEBUG "testAndWriteFile - no existing version"                   Text.writeFile dest new                 False -> do-                  alog "Extra.IO" ERROR ("testAndWriteFile " <> show dest <> " - IOException " ++ show e)+                  alog ERROR ("testAndWriteFile " <> show dest <> " - IOException " ++ show e)                   throw e)            return @@ -69,7 +69,7 @@ -- | If the new file does not match the old, write it to file.new and error. writeDotNew :: FilePath -> Text -> Text -> IO () writeDotNew dest old new = do-  alog "Extra.IO" DEBUG ("testAndWriteFile - mismatch, writing " <> show (dest <> ".new"))+  alog DEBUG ("testAndWriteFile - mismatch, writing " <> show (dest <> ".new"))   Text.writeFile (dest <> ".new") new   error ("Generated " <> dest <> ".new does not match existing " <> dest <> ":\n" <>          diffText (dest, old) (dest <> ".new", new) <>
+ Extra/LocalStorageEncode.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Extra.LocalStorageEncode (encode, decode, encodeS, decodeS, urlEncode, urlDecode) where++import Control.Monad.Except+import qualified Data.Serialize as Serialize (decode)+import Extra.Serialize as Serialize (DecodeError(..), fakeTypeRep, Serialize)+import qualified Extra.Serialize as Serialize (encode)+import Data.Text as Text (Text, pack, unpack)+import qualified Data.Text.Encoding as Text (encodeUtf8, decodeUtf8)+import Data.Typeable (Proxy(Proxy), Typeable)+import qualified Data.ByteString.Base64 as Base64 (encode, decode)+import Network.URI (escapeURIString, isUnreserved, unEscapeString)++encode :: Serialize a => a -> Text+encode = Text.decodeUtf8 . Base64.encode . Serialize.encode++decode :: forall a. (Serialize a, Typeable a) => Text -> Either DecodeError a+#if 0+decode = either fail return . join . fmap Serialize.decode . Base64.decode . Text.encodeUtf8+#else+decode t =+  case Base64.decode (Text.encodeUtf8 t) of+    Left s -> throwError (DecodeError (Text.encodeUtf8 t) (fakeTypeRep (Proxy :: Proxy a)) s)+    Right b ->+      case Serialize.decode b of+        Left s -> throwError (DecodeError (Text.encodeUtf8 t) (fakeTypeRep (Proxy :: Proxy a)) s)+        Right a -> return a+#endif++encodeS :: Serialize a => a -> String+encodeS =  Text.unpack . encode++decodeS :: (Serialize a, Typeable a) => String -> Either DecodeError a+decodeS = decode . Text.pack++urlEncode :: Serialize a => a -> String+urlEncode = escape . encodeS+  where escape = escapeURIString isUnreserved++urlDecode :: (Serialize a, Typeable a) => String -> Either DecodeError a+urlDecode = decodeS . unEscapeString
Extra/Log.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP, TemplateHaskell #-} {-# OPTIONS -Wall #-} @@ -10,38 +11,44 @@ #endif   ) where +import Control.Lens(ix, preview, to) import Control.Monad.Except (MonadError(catchError, throwError)) import Control.Monad.Trans (liftIO, MonadIO)-import Data.Time (getCurrentTime)-import Data.Time.Format (FormatTime(..), formatTime, defaultTimeLocale)+import Data.Bool (bool)+import Data.List (intercalate)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Time (getCurrentTime, UTCTime)+import Data.Time.Format (formatTime, defaultTimeLocale)+import GHC.Stack (CallStack, callStack, getCallStack, HasCallStack, SrcLoc(..)) #if !__GHCJS__ import Language.Haskell.TH (ExpQ, Exp, Loc(..), location, pprint, Q) import qualified Language.Haskell.TH.Lift as TH (Lift(lift)) import Language.Haskell.TH.Instances () #endif-import System.Log.Logger (Priority(..), logM)+import System.Log.Logger (Priority(..), logM, rootLoggerName) -alog :: MonadIO m => String -> Priority -> String -> m ()-alog modul priority msg = liftIO $ do+alog :: (MonadIO m, HasCallStack) => Priority -> String -> m ()+alog priority msg = liftIO $ do   time <- getCurrentTime-  logM modul priority $ unwords [formatTimeCombined time, msg]+  logM (modul callStack) priority $+    logString time priority msg --- | Format the time as describe in the Apache combined log format.---   http://httpd.apache.org/docs/2.2/logs.html#combined------ The format is:---   [day/month/year:hour:minute:second zone]---    day = 2*digit---    month = 3*letter---    year = 4*digit---    hour = 2*digit---    minute = 2*digit---    second = 2*digit---    zone = (`+' | `-') 4*digit------ (Copied from happstack-server)-formatTimeCombined :: FormatTime t => t -> String-formatTimeCombined = formatTime defaultTimeLocale "%d/%b/%Y:%H:%M:%S %z"+logString  :: HasCallStack => UTCTime -> Priority -> String -> String+logString time priority msg =+#if defined(darwin_HOST_OS)+  take 2002 $+#else+  take 60000 $+#endif+    msg++-- | Format the location of the nth level up in a call stack+modul :: CallStack -> String+modul stack =+  case dropWhile (\(_, SrcLoc {..}) -> srcLocModule == "Extra.Log") (getCallStack stack) of+    [] -> "???"+    [(_alog, SrcLoc {..})] -> srcLocModule <> ":" <> show srcLocStartLine+    ((_, SrcLoc {..}) : (fn, _) : _) -> srcLocModule <> "." <> fn <> ":" <> show srcLocStartLine  #if !__GHCJS__ -- | Create an expression of type (MonadIO m => Priority -> m a -> m
Extra/Orphans3.hs view
@@ -15,11 +15,8 @@ module Extra.Orphans3 where  import Data.Data (Data, dataTypeOf, gunfold, mkNoRepType, toConstr, TypeRep)-import Data.Foldable---import Data.Function.Memoize (deriveMemoizable) import Data.Generics.Instances ()-import Data.ListLike as LL hiding (concat, sequence, toList)--- import Data.Order (Order, toPairs)+import Data.ListLike as LL hiding (sequence, toList) import Data.Proxy (Proxy(Proxy)) import Data.SafeCopy (SafeCopy(..)) import Extra.Serialize (Serialize)@@ -28,7 +25,7 @@ import Language.Haskell.TH.Instances () import Language.Haskell.TH.PprLib (Doc, hcat, ptext) import Language.Haskell.TH.Syntax-import Prelude hiding (concat, foldl1)+import Prelude hiding (foldl1) #if !__GHCJS__ import Network.URI import Test.QuickCheck (Arbitrary(arbitrary), elements, Gen, oneof)@@ -92,7 +89,7 @@         where           genRegName = do             domainName <- elements ["noomii", "google", "yahoo"]-            return $ concat ["www.", domainName, ".com"]+            return $ mconcat ["www.", domainName, ".com"]  arbitraryKind :: Gen Kind arbitraryKind = oneof [pure StarT {-, finish me -}]@@ -245,3 +242,9 @@ instance SafeCopy TypeFamilyHead where version = 1 instance SafeCopy TySynEqn where version = 1 instance SafeCopy TyVarBndr where version = 1++#if MIN_VERSION_template_haskell(2,15,0)+deriving instance Serialize Bytes+instance SafeCopy Bytes where version = 1+deriving instance NFData Bytes+#endif
+ Extra/QuickCheck.hs view
@@ -0,0 +1,42 @@+module Extra.QuickCheck+  ( throwResult+  ) where++import Control.Exception+import Test.QuickCheck++instance Exception Result++instance Semigroup Result where+  (Success numTests1 numDiscarded1 labels1 classes1 tables1 output1) <>+      (Success numTests2 numDiscarded2 labels2 classes2 tables2 output2) =+    Success (numTests1 + numTests2) (numDiscarded1 + numDiscarded2) (labels1 <> labels2)+            (classes1 <> classes2) (tables1 <> tables2) (output1 <> "\n" <> output2)+  (Success _ _ _ _ _ _) <> failure = failure+  failure <> _ = failure++instance Monoid Result where+  mempty = Success 0 0 mempty mempty mempty mempty+  mappend = (<>)++throwResult :: Result -> IO Result+throwResult result@(Success {}) = return result+throwResult result = throw result++{-+Example use:++tests :: IO Result+tests = do+  mconcat <$> sequence+       [quickCheckResult prop_next,+        quickCheckResult prop_keys,+        quickCheckResult prop_next,+        quickCheckResult prop_lookup,+        quickCheckResult prop_lookupKey,+        quickCheckResult prop_lookupPair,+        quickCheckResult prop_splitAt,+        quickCheckResult prop_uncons,+        quickCheckResult prop_null,+        quickCheckResult prop_singleton] >>= throwResult+-}
Extra/SafeCopy.hs view
@@ -14,44 +14,46 @@ module Extra.SafeCopy     ( module Data.SafeCopy     , DecodeError(..)-    , HasDecodeError(fromDecodeError)-    , decode-    , encode-    , decode'-    , decodeM-    , decodeM'+    , encodeSafe+    , decodeAllSafe+    , decodeMSafe+    , decodeMSafe'+    , decodePrismSafe+    , encodeGetterSafe     ) where -import Control.Exception (ErrorCall(..), evaluate, )+import Control.Exception (ErrorCall(..)) import Control.Lens (Getter, Prism', prism, re) import Control.Monad.Catch (catch, MonadCatch)-import Control.Monad.Except (MonadError, throwError)+import Control.Monad.Except (MonadError) import Data.ByteString as B (ByteString, null) import Data.Data (Proxy(Proxy), Typeable) import Data.SafeCopy (base, SafeCopy, safeGet, safePut) import Data.Serialize hiding (decode, encode) import Data.UUID.Orphans ()+import Extra.Errors (Member, OneOf, throwMember) import Extra.Orphans ()-import Extra.Serialize (DecodeError(..), fakeTypeRep, HasDecodeError(fromDecodeError))-import System.IO.Unsafe (unsafePerformIO)+import Extra.Serialize (DecodeError(..), fakeTypeRep) -encode :: SafeCopy a => a -> ByteString-encode = runPut . safePut+encodeSafe :: SafeCopy a => a -> ByteString+encodeSafe = runPut . safePut -decode :: forall a. (SafeCopy a) => ByteString -> Either String a-decode b = case runGetState safeGet b 0 of-             Left s -> Left s-             Right (a, remaining) | B.null remaining -> Right a-             Right (a, remaining) -> Left ("decode " <> show b <> " failed to consume " <> show remaining)+-- Version of decode that errors if all input is not consumed.+decodeAllSafe :: forall a. (SafeCopy a) => ByteString -> Either String a+decodeAllSafe b =+  case runGetState safeGet b 0 of+    Left s -> Left s+    Right (a, more) | B.null more -> Right a+    Right (_, more) -> Left ("decode " <> show b <> " failed to consume " <> show more)  -- | Monadic version of decode.-decodeM ::-  forall a e m. (SafeCopy a, Typeable a, HasDecodeError e, MonadError e m)+decodeMSafe ::+  forall a e m. (SafeCopy a, Typeable a, Member DecodeError e, MonadError (OneOf e) m)   => ByteString   -> m a-decodeM bs =-  case decode bs of-    Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))+decodeMSafe bs =+  case decodeAllSafe bs of+    Left s -> throwMember (DecodeError bs (fakeTypeRep (Proxy @a)) s)     Right a -> return a  -- | Like 'decodeM', but also catches any ErrorCall thrown and lifts@@ -59,31 +61,22 @@ -- actually happen.  What I'm seeing is probably an error call from -- outside the serialize package, in which case this (and decode') are -- pointless.-decodeM' ::-  forall e m a. (SafeCopy a, Typeable a, HasDecodeError e, MonadError e m, MonadCatch m)+decodeMSafe' ::+  forall e m a. (SafeCopy a, Typeable a, Member DecodeError e, MonadError (OneOf e) m, MonadCatch m)   => ByteString   -> m a-decodeM' bs = go `catch` handle+decodeMSafe' bs = go `catch` handle   where-    go = case decode bs of-           Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))+    go = case decodeAllSafe bs of+           Left s -> throwMember (DecodeError bs (fakeTypeRep (Proxy @a)) s)            Right a -> return a     handle :: ErrorCall -> m a-    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs (fakeTypeRep (Proxy @a)) s---- | Version of decode that catches any thrown ErrorCall and modifies--- its message.-decode' :: forall a. (SafeCopy a) => ByteString -> Either String a-decode' b =-  unsafePerformIO (evaluate (decode b :: Either String a) `catch` handle)-  where-    handle :: ErrorCall -> IO (Either String a)-    handle e = return $ Left (show e)+    handle (ErrorCall s) = throwMember (DecodeError bs (fakeTypeRep (Proxy @a)) s)  -- | Serialize/deserialize prism.-deserializePrism :: forall a. (SafeCopy a) => Prism' ByteString a-deserializePrism = prism encode (\s -> either (\_ -> Left s) Right (decode s :: Either String a))+decodePrismSafe :: forall a. (SafeCopy a) => Prism' ByteString a+decodePrismSafe = prism encodeSafe (\s -> either (\_ -> Left s) Right (decodeAllSafe s :: Either String a))  -- | Inverting a prism turns it into a getter.-serializeGetter :: forall a. (SafeCopy a) => Getter a ByteString-serializeGetter = re deserializePrism+encodeGetterSafe :: forall a. (SafeCopy a) => Getter a ByteString+encodeGetterSafe = re decodePrismSafe
− Extra/SafeCopyDebug.hs 
@@ -1,103 +0,0 @@--- | This module exports a template haskell function to create--- Serialize instances based on the SafeCopy instance, and an--- alternative decode function that puts the decode type in the error--- message.  It also re-exports all other Data.Serialize symbols--{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}--module Extra.SafeCopyDebug-    ( module Extra.SafeCopy-    , Debug-    , DecodeError(..)-    , HasDecodeError(fromDecodeError)-    , decode-    , decode'-    , decodeM-    , decodeM'-    ) where--import Control.Exception (ErrorCall(..), evaluate, )-import Control.Lens (Getter, _Left, over, 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.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.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)-import Network.URI (URI(..), URIAuth(..))-import System.IO.Unsafe (unsafePerformIO)--decode :: forall a. (SafeCopy a, Debug a) => ByteString -> Either String a-decode b = case runGetState safeGet b 0 of-             Left s -> Left s-             Right (a, remaining) | B.null remaining -> Right a-             Right (a, remaining) -> Left ("decode " <> show b <> " :: " <> show (typeRep (Proxy :: Proxy a)) <> " failed to consume " <> show remaining)---- | Monadic version of decode.-decodeM ::-  forall a e m. (SafeCopy a, Debug a, HasDecodeError e, MonadError e m)-  => ByteString-  -> m a-decodeM bs =-  case decode bs of-    Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))-    Right a -> return a---- | Like 'decodeM', but also catches any ErrorCall thrown and lifts--- it into the MonadError instance.  I'm not sure whether this can--- actually happen.  What I'm seeing is probably an error call from--- outside the serialize package, in which case this (and decode') are--- pointless.-decodeM' ::-  forall e m a. (SafeCopy a, Debug 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 (fakeTypeRep (Proxy @a)) s))-           Right a -> return a-    handle :: ErrorCall -> m a-    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs (fakeTypeRep (Proxy @a)) s---- | Version of decode that catches any thrown ErrorCall and modifies--- its message.-decode' :: forall a. (SafeCopy a, Debug a) => ByteString -> Either String a-decode' b =-  unsafePerformIO (evaluate (decode b :: Either String a) `catch` handle)-  where-    handle :: ErrorCall -> IO (Either String a)-    handle e = return $ Left (show e)---- | Serialize/deserialize prism.-deserializePrism :: forall a. (SafeCopy a, Debug a) => Prism' ByteString a-deserializePrism = prism encode (\s -> either (\_ -> Left s) Right (decode s :: Either String a))---- | Inverting a prism turns it into a getter.-serializeGetter :: forall a. (SafeCopy a, Debug a) => Getter a ByteString-serializeGetter = re deserializePrism
Extra/Serialize.hs view
@@ -16,33 +16,30 @@  module Extra.Serialize     ( DecodeError(..)-    , HasDecodeError(fromDecodeError)-    -- , HasDecodeFailure-    -- , decodeFailure, fromDecodeFailure     , module Data.Serialize-    , decodePrism, deserializePrism-    , encodeGetter, serializeGetter     , deriveSerializeViaSafeCopy-    , decode-    , Serialize.encode+    , decodeAll     , decode'     , decodeM     , decodeM'-    , FakeTypeRep(..), fakeTypeRep+    , FakeTypeRep(..)+    , fakeTypeRep+    , decodePrism+    , encodeGetter+    , HasDecodeError(fromDecodeError)     ) where  import Control.Exception (ErrorCall(..), evaluate, )-import Control.Lens (Getter, Prism', prism, re, review)+import Control.Lens (Getter, Prism', prism, re) import Control.Monad.Catch (catch, MonadCatch)-import Control.Monad.Except (MonadError, throwError)+import Control.Monad.Except (MonadError) import Data.ByteString as B (ByteString, null) #ifndef OMIT_DATA_INSTANCES import Data.Data (Data) #endif import Data.Data (Proxy(Proxy)) import Data.SafeCopy (SafeCopy(..), safeGet, safePut)-import Data.Serialize hiding (decode, encode)-import qualified Data.Serialize as Serialize (encode)+import Data.Serialize import Data.Text as T hiding (concat, intercalate) import Data.Text.Lazy as LT hiding (concat, intercalate) import Data.Text.Encoding as TE@@ -52,7 +49,7 @@ import Data.UUID.Orphans () import Data.UUID (UUID) import Data.UUID.Orphans ()-import qualified Extra.Errors as Errors+import Extra.Errors (Member, OneOf, throwMember) import Extra.Orphans () import Extra.Time (Zulu(..)) import GHC.Generics (Generic)@@ -60,31 +57,22 @@ import Network.URI (URI(..), URIAuth(..)) import System.IO.Unsafe (unsafePerformIO) +#if 0+-- We can't make a Data instance for TypeRep because part of it is in+-- Data.Typeable.Internal, a hidden module in base.+instance SafeCopy TypeRep+deriving instance Data TypeRep+data DecodeError = DecodeError ByteString TypeRep String deriving (Generic, Eq, Ord, Typeable)+#else 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--#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+instance Serialize DecodeError where get = safeGet; put = safePut  -- | Decode a value from a strict ByteString, reconstructing the original -- structure.  Unlike Data.Serialize.decode, this function only succeeds@@ -94,12 +82,12 @@ --   Left "decode \"xy\" failed to consume \"y\"" --   > Data.Serialize.decode (encode 'x' <> encode 'y') :: Either String Char --   Right 'x'-decode :: forall a. Serialize a => ByteString -> Either String a-decode b =+decodeAll :: forall a. Serialize a => ByteString -> Either String a+decodeAll b =   case runGetState get b 0 of     Left s -> Left s-    Right (a, remaining) | B.null remaining -> Right a-    Right (a, remaining) -> Left ("decode " <> show b <> " failed to consume " <> show remaining)+    Right (a, more) | B.null more -> Right a+    Right (_, more) -> Left ("decode " <> show b <> " failed to consume " <> show more)  -- | A Serialize instance based on safecopy.  This means that -- migrations will be performed upon deserialization, which is handy@@ -146,13 +134,12 @@ deriving instance Serialize Zulu  -- | Monadic version of decode.-decodeM ::-  forall a e m. (Serialize a, Typeable a, HasDecodeError e, MonadError e m)+decodeM :: forall a e m. (Serialize a, Typeable a, Member DecodeError e, MonadError (OneOf e) m)   => ByteString   -> m a decodeM bs =   case decode bs of-    Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))+    Left s -> throwMember (DecodeError bs (fakeTypeRep (Proxy @a)) s)     Right a -> return a  -- | Like 'decodeM', but also catches any ErrorCall thrown and lifts@@ -161,16 +148,16 @@ -- outside the serialize package, in which case this (and decode') are -- pointless. decodeM' ::-  forall e m a. (Serialize a, Typeable a, HasDecodeError e, MonadError e m, MonadCatch m)+  forall e m a. (Serialize a, Typeable a, Member DecodeError e, MonadError (OneOf e) m, MonadCatch m)   => ByteString   -> m a decodeM' bs = go `catch` handle   where     go = case decode bs of-           Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))+           Left s -> throwMember (DecodeError bs (fakeTypeRep (Proxy @a)) s)            Right a -> return a     handle :: ErrorCall -> m a-    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs (fakeTypeRep (Proxy @a)) ("ErrorCall: " <> s)+    handle (ErrorCall s) = throwMember $ DecodeError bs (fakeTypeRep (Proxy @a)) ("ErrorCall: " <> s)  -- | Version of decode that catches any thrown ErrorCall and modifies -- its message.@@ -181,22 +168,11 @@     handle :: ErrorCall -> IO (Either String a)     handle e = return $ Left (show e) --- | Serialize/deserialize prism.-deserializePrism :: forall a. (Serialize a) => Prism' ByteString a-deserializePrism = decodePrism-{-# DEPRECATED deserializePrism "dumb name - use decodePrism" #-}---- | Serialize/deserialize prism. decodePrism :: forall a. (Serialize a) => Prism' ByteString a decodePrism = prism encode (\s -> either (\_ -> Left s) Right (decode s :: Either String a)) --- | Inverting a prism turns it into a getter.-serializeGetter :: forall a. (Serialize a) => Getter a ByteString-serializeGetter = re deserializePrism-{-# DEPRECATED serializeGetter "dumb name - use encodeGetter" #-}- encodeGetter :: forall a. (Serialize a) => Getter a ByteString-encodeGetter = re deserializePrism+encodeGetter = re decodePrism  instance SafeCopy DecodeError where version = 1 @@ -209,3 +185,9 @@ deriving instance Show FakeTypeRep deriving instance Show DecodeError #endif++-- Required by appraisalscribe-migrate+class HasDecodeError e where fromDecodeError :: DecodeError -> e+{-# DEPRECATED HasDecodeError "use Member DecodeError" #-}+{-# DEPRECATED fromDecodeError "use throwMember or review oneOf" #-}+instance HasDecodeError DecodeError where fromDecodeError = id
− Extra/SerializeDebug.hs 
@@ -1,110 +0,0 @@--- | This module exports a template haskell function to create--- Serialize instances based on the SafeCopy instance, and an--- alternative decode function that puts the decode type in the error--- message.  It also re-exports all other Data.Serialize symbols--{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}--module Extra.SerializeDebug-    ( module Extra.Serialize-    , Debug-    , DecodeError(..)-    , HasDecodeError-    , fromDecodeError-    , deserializePrism-    , serializeGetter-    , decode-    , decode'-    , decodeM-    , decodeM'-    ) where--import Control.Exception (ErrorCall(..), evaluate, )-import Control.Lens (Getter, _Left, over, 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.SafeCopy (base, SafeCopy, safeGet, safePut)-import Data.Serialize hiding (decode)-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 hiding (decode, decode', decodeM, decodeM', deserializePrism, serializeGetter)-import Extra.Time (Zulu(..))-import Language.Haskell.TH (Dec, Loc, TypeQ, Q)-import Network.URI (URI(..), URIAuth(..))-import System.IO.Unsafe (unsafePerformIO)--type Debug a = (Typeable a, Show a)---- | Decode a value from a strict ByteString, reconstructing the original--- structure.  Unlike Data.Serialize.decode, this function only succeeds--- if all the input is consumed.-decode :: forall a. (Serialize a, Debug a) => ByteString -> Either String a-decode b =-  case runGetState get b 0 of-    Left s -> Left s-    Right (a, remaining) | B.null remaining -> Right a-    Right (a, remaining) -> Left ("decode " <> show b <> " :: " <> show (typeRep (Proxy :: Proxy a)) <> " failed to consume " <> show remaining)---- | Monadic version of decode.-decodeM ::-  forall a e m. (Serialize a, Debug a, HasDecodeError e, MonadError e m)-  => ByteString-  -> m a-decodeM bs =-  case decode bs of-    Left s -> throwError (fromDecodeError (DecodeError bs (fakeTypeRep (Proxy @a)) s))-    Right a -> return a---- | Like 'decodeM', but also catches any ErrorCall thrown and lifts--- it into the MonadError instance.  I'm not sure whether this can--- actually happen.  What I'm seeing is probably an error call from--- outside the serialize package, in which case this (and decode') are--- pointless.-decodeM' ::-  forall e m a. (Serialize a, Debug 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 (fakeTypeRep (Proxy @a)) s))-           Right a -> return a-    handle :: ErrorCall -> m a-    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs (fakeTypeRep (Proxy @a)) s---- | Version of decode that catches any thrown ErrorCall and modifies--- its message.-decode' :: forall a. (Serialize a, Debug a) => ByteString -> Either String a-decode' b =-  unsafePerformIO (evaluate (decode b :: Either String a) `catch` handle)-  where-    handle :: ErrorCall -> IO (Either String a)-    handle e = return $ Left (show e)---- | Serialize/deserialize prism.-deserializePrism :: forall a. (Serialize a, Debug a) => Prism' ByteString a-deserializePrism = prism encode (\s -> either (\_ -> Left s) Right (decode s :: Either String a))---- | Inverting a prism turns it into a getter.-serializeGetter :: forall a. (Serialize a, Debug a) => Getter a ByteString-serializeGetter = re deserializePrism
sr-extra.cabal view
@@ -1,5 +1,5 @@ Name:           sr-extra-Version:        1.72.3+Version:        1.80 License:        BSD3 License-File:   COPYING Author:         David Fox@@ -16,13 +16,12 @@ Maintainer:     David Fox <dsf@seereason.com> Homepage:       https://github.com/seereason/sr-extra Build-Type:     Simple-Cabal-Version:  >= 1.4+Cabal-Version:  >= 1.10  flag network-uri   Description: Get Network.URI from the network-uri package rather than the    full network package.   Default: True-  Manual: True  flag omit-serialize   Description: Omit all the Serialize instances, on the assumption@@ -34,9 +33,11 @@   Default: False  Library+  default-language: Haskell2010   GHC-Options: -Wall -Wredundant-constraints   Build-Depends:     base < 5,+    base64-bytestring,     bytestring,     bzlib,     Cabal,@@ -54,6 +55,7 @@     mtl,     pretty,     pureMD5,+    QuickCheck >= 2 && < 3,     random,     safecopy >= 0.9.5,     show-combinators,@@ -76,9 +78,9 @@   C-Sources:         cbits/gwinsz.c   Include-Dirs:        cbits   Install-Includes:    gwinsz.h-  Extensions: ConstraintKinds, CPP, DataKinds, DeriveDataTypeable, DeriveFunctor, DeriveGeneric-  Extensions: FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, RankNTypes-  Extensions: ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies+  Default-Extensions: ConstraintKinds, CPP, DataKinds, DeriveDataTypeable, DeriveFunctor, DeriveGeneric+  Default-Extensions: FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, RankNTypes+  Default-Extensions: ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeApplications, TypeFamilies   Exposed-modules:     Extra.Bool,     Extra.Debug,@@ -97,6 +99,7 @@     Extra.IOThread     Extra.List,     Extra.HughesPJ,+    Extra.LocalStorageEncode,     Extra.Log,     Extra.Misc,     Extra.Monad.Supply,@@ -105,10 +108,9 @@     Extra.Orphans2,     Extra.Orphans3,     Extra.Pretty,+    Extra.QuickCheck,     Extra.SafeCopy,-    Extra.SafeCopyDebug,     Extra.Serialize,-    Extra.SerializeDebug,     Extra.Text,     Extra.TH,     Extra.Time,@@ -122,8 +124,7 @@       filemanip,       HUnit,       process,-      process-extras,-      QuickCheck >= 2 && < 3+      process-extras     Exposed-Modules:       Extra.GPGSign,       Extra.Lock,@@ -134,7 +135,7 @@       Test.QuickCheck.Properties    if flag(network-uri)-    Build-Depends: network-uri >= 2.6.3+    Build-Depends: network-uri >= 2.6   else     Build-Depends: network >= 2.4