packages feed

sr-extra 1.85.1 → 1.88

raw patch · 5 files changed

+180/−6 lines, 5 filesdep ~safecopydep ~template-haskell

Dependency ranges changed: safecopy, template-haskell

Files

Extra/Errors.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -34,8 +35,18 @@   , throwMember   , liftMember   , catchMember+  , liftExceptT   , tryMember   , mapMember++  , catchMember'+#if 0+  , IsSubset+  , throwMembers+  , liftMembers+  , liftExceptTs+#endif+   , runNullExceptT   , runNullExcept   , liftUIO@@ -52,8 +63,8 @@   ) where  import Control.Exception (fromException, IOException, toException)-import Control.Lens (Prism', prism', review)-import Control.Monad.Except (Except, ExceptT, MonadError, runExcept, runExceptT, throwError, withExceptT)+import Control.Lens (Prism', preview, prism', review)+import Control.Monad.Except (Except, ExceptT, lift, MonadError, runExcept, runExceptT, throwError, withExceptT) --import Extra.Except (mapError) import Data.Type.Bool --import Data.Type.Equality@@ -85,8 +96,9 @@   Empty :: OneOf s   Val   :: e -> OneOf (e ': s)   NoVal :: OneOf s -> OneOf (e ': s)-  deriving Typeable +deriving instance Typeable k => Typeable (OneOf (n :: [k]))+ instance Show (OneOf '[]) where   show Empty = "{}" @@ -113,7 +125,7 @@     1 -> Val <$> S.get     _ -> error "impossible" -instance SafeCopy (OneOf '[]) where+instance Typeable k => SafeCopy (OneOf ('[] :: [k])) where   version = 1   kind = base   getCopy :: S.Serialize (OneOf s) => Contained (S.Get (OneOf s))@@ -183,6 +195,9 @@ liftMember :: forall e es m a. (Member e es, MonadError (OneOf es) m) => Either e a -> m a liftMember = either throwMember return +liftExceptT :: (Member e es, MonadError (OneOf es) m) => ExceptT e m a -> m a+liftExceptT action = liftMember =<< runExceptT action+ -- | 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:@@ -201,6 +216,42 @@   helper (delete @e Proxy) (tryError ma) >>= either handle return   where handle :: OneOf esplus -> n a         handle es = maybe (throwError (delete @e Proxy es)) f (get es :: Maybe e)++catchMember'' ::+  forall e (es :: [*]) m a.+  (Monad m)+  => ExceptT (OneOf (e ': es)) m a+  -> ExceptT (OneOf es) m (Either e a)+catchMember'' m = do+  lift (runExceptT m) >>= either (\es -> maybe (throwError (delete (Proxy @e) es :: OneOf es)) (pure . Left) (preview oneOf es)) (pure . Right)++catchMember' ::+  forall e (es :: [*]) m a.+  (MonadError (OneOf es) m)+  => ExceptT (OneOf (e ': es)) m a+  -> (e -> m a)+  -> m a+catchMember' action handle =+  either throwError (either handle pure) =<< runExceptT (catchMember'' @e action)++#if 0+type family IsSubset xs ys where+  IsSubset '[] _ = 'True+  IsSubset xs '[] = 'False+  IsSubset (x ': xs) ys = (IsMember x ys) && (IsSubset xs ys)++liftExceptTs :: (IsSubset es' es ~ 'True, MonadError (OneOf es) m) => ExceptT (OneOf es') m a -> m a+liftExceptTs action = liftMembers =<< runExceptT action++liftMembers :: forall es' es m a. (IsSubset es' es ~ 'True, MonadError (OneOf es) m) => Either (OneOf es') a -> m a+liftMembers = either throwMembers return++-- Special case of what we would really like.+throwMembers :: forall e es' es m a. (IsSubset es' es ~ 'True, MonadError (OneOf es) m) => OneOf es' -> m a+throwMembers Empty = error "throwMembers"+throwMembers (Val e) = throwError (review oneOf e :: OneOf es)+throwMembers (NoVal o) = throwMembers o+#endif  -- | 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
+ Extra/Log.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP, TemplateHaskell #-}+{-# OPTIONS -Wall #-}++module Extra.Log+  ( -- * Logging+    alog+  , alogs+  , printLoc+  , putLoc+  , loc+  , loc'+  , logString+    -- * Elapsed time+  , HasSavedTime(..)+  , alog'+  , logString'+    -- * Re-exports+  , Priority(..)+  ) where++import Control.Lens((.=), ix, Lens', preview, to, use)+import Control.Monad.Except (when)+import Control.Monad.State (MonadState)+import Control.Monad.Trans (liftIO, MonadIO)+import Data.Bool (bool)+import Data.Maybe (fromMaybe)+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup((<>)))+#endif+import Data.Time (diffUTCTime, getCurrentTime, UTCTime)+#if MIN_VERSION_time(1,9,0)+import Data.Time.Format (formatTime, defaultTimeLocale)+#endif+import GHC.Stack (CallStack, callStack, getCallStack, HasCallStack, SrcLoc(..))+#if !__GHCJS__+import Language.Haskell.TH.Instances ()+#endif+import System.Log.Logger (getLevel, getLogger, getRootLogger, logL, Priority(..))+import Text.Printf (printf)++alog :: (MonadIO m, HasCallStack) => Priority -> String -> m ()+alog priority msg = liftIO $ do+  -- time <- getCurrentTime+  logger <- getRootLogger+  logL logger priority (logString msg)++alogs :: forall m. (MonadIO m, HasCallStack) => Priority -> [String] -> m ()+alogs priority msgs = alog priority (unwords msgs)++logString  :: HasCallStack => String -> String+logString msg =+#if defined(darwin_HOST_OS)+  take 2002 $+#else+  take 60000 $+#endif+  loc <> " - " <> msg++printLoc :: (Show a, HasCallStack, MonadIO m) => a -> m ()+printLoc x = putLoc >> liftIO (print x)++putLoc :: (HasCallStack, MonadIO m) => m ()+putLoc = liftIO (putStr (loc <> " - "))++-- | Format the location of the nth level up in a call stack+loc :: HasCallStack => String+loc =+  case dropWhile (\(_, SrcLoc {..}) -> srcLocModule == "Extra.Log") (getCallStack callStack) of+    [] -> "(no CallStack)"+    [(_alog, SrcLoc {..})] -> srcLocModule <> ":" <> show srcLocStartLine+    ((_, SrcLoc {..}) : (fn, _) : _) -> srcLocModule <> "." <> fn <> ":" <> show srcLocStartLine++-- | Format the location of the nth level up in a call stack+loc' :: CallStack -> Int -> Maybe String+loc' stack n =+  preview (to getCallStack . ix n . to prettyLoc) stack+  where+    prettyLoc (_s, SrcLoc {..}) =+      foldr (++) ""+        [ srcLocModule, ":"+        , show srcLocStartLine {-, ":"+        , show srcLocStartCol-} ]++class HasSavedTime s where savedTime :: Lens' s UTCTime+instance HasSavedTime UTCTime where savedTime = id++alog' :: forall s m. (MonadIO m, HasSavedTime s, HasCallStack, MonadState s m) => Priority -> String -> m ()+alog' priority msg = do+  level <- getLevel <$> liftIO (maybe getRootLogger getLogger (loc' callStack 1))+  prev <- use savedTime+  time <- liftIO getCurrentTime+  logger <- liftIO getRootLogger+  when (level <= Just priority) (savedTime .= time)+  liftIO $+    logL logger priority $+      logString' prev time priority msg++logString'  :: UTCTime -> UTCTime -> Priority -> String -> String+logString' prev time priority msg =+#if defined(darwin_HOST_OS)+  take 2002 $+#else+  take 60000 $+#endif+    unwords $ [timestring, fromMaybe "???" (loc' callStack 1), "-", msg] <> bool [] ["(" <> show priority <> ")"] (priority == DEBUG)+    where timestring =+#if MIN_VERSION_time(1,9,0)+            formatTime defaultTimeLocale "%T%4Q"+#else+            (("elapsed: " <>) . (printf "%.04f" :: Double -> String) . fromRational . toRational)+#endif+              (diffUTCTime time prev)
Extra/Orphans.hs view
@@ -17,6 +17,7 @@ import Data.Text as T hiding (concat, intercalate) import Data.Text.Lazy as LT hiding (concat, intercalate) import Data.Time (UTCTime(..), Day(ModifiedJulianDay), TimeOfDay(..), timeOfDayToTime, DiffTime)+import Data.Typeable (Typeable) import Data.UserId (UserId(..)) import Data.UUID.Orphans () import Data.UUID (UUID)@@ -34,7 +35,7 @@ import Test.QuickCheck (Arbitrary(arbitrary), choose, elements, Gen, listOf, listOf1, resize) #endif -instance SafeCopy (Proxy t) where+instance Typeable t => SafeCopy (Proxy t) where       putCopy Proxy = contain (do { return () })       getCopy = contain (label "Data.Proxy.Proxy:" (pure Proxy))       version = 0
Extra/Time.hs view
@@ -2,6 +2,7 @@ module Extra.Time     ( formatDebianDate     -- , myTimeDiffToString+    , prettyUTCTime     , Zulu(..), utcTime     ) where @@ -82,3 +83,10 @@  instance Show Zulu where   showsPrec d (Zulu t) = showParen (d > 10) $ showString ("Zulu (read " ++ show (show t) ++ ")")++prettyUTCTime :: TimeZone -> UTCTime -> String+prettyUTCTime = (\tz -> fmt . (utcToLocalTime tz))+  where fmt :: FormatTime t => t -> String+        fmt = formatTime defaultTimeLocale prettyTimeFormat+        prettyTimeFormat :: String+        prettyTimeFormat = "%Y-%m-%d %H:%M"
sr-extra.cabal view
@@ -1,5 +1,5 @@ Name:           sr-extra-Version:        1.85.1+Version:        1.88 License:        BSD3 License-File:   COPYING Author:         David Fox@@ -102,6 +102,7 @@     Extra.HughesPJ,     Extra.IO,     Extra.LocalStorageEncode,+    Extra.Log,     Extra.Misc,     Extra.Monad.Supply,     Extra.Net,