packages feed

sr-extra 1.46.3.2 → 1.64

raw patch · 39 files changed

+2941/−458 lines, 39 filesdep +Cabaldep +Diffdep +ListLikedep −old-localedep −old-timedep −regex-compatdep ~basedep ~mtldep ~network-uri

Dependencies added: Cabal, Diff, ListLike, cereal, exceptions, fgl, filemanip, generic-data, hslogger, lens, mmorph, process-extras, safecopy, show-combinators, show-please, syb, template-haskell, text, th-lift, th-lift-instances, th-orphans, userid, uuid, uuid-orphans, uuid-types

Dependencies removed: old-locale, old-time, regex-compat

Dependency ranges changed: base, mtl, network-uri

Files

− Extra/CIO.hs 
@@ -1,308 +0,0 @@--- |CIO is a type class for the TIO monad, which tracks the cursor--- position of the console so that indentation and prefixes can be--- added to the output.  TIO also has a style component which lets you--- control the output verbosity and the appearance of the prefix.--- There is an instance for the regular IO monad which doesn't use any--- of these features, to allow functions which do not use the TIO--- monad call functions in the Debian library.------ NOTE: a copy of this library is in the Extra library as--- well. Please update both locations.--- --- This code is provided for backwards compatibility, I don't--- endorse its use in new projects.-module Extra.CIO  {-# DEPRECATED "Use System.Unix.QIO in Unixutils." #-}-    ( -- * The CIO class-      CIO(..)--    -- * Style constructors and transformers-    , TStyle(..)-    , defStyle-    , withStyle--    , setVerbosity-    , addVerbosity-    , setPrefix-    , addPrefix-    , appPrefix-    , setPrefixes-    , addPrefixes-    , appPrefixes-    , hGetPrefix--    -- * Output functions-    , putStr-    , ePutStr-    , vPutStr-    , vEPutStr--    , hPutChar-    , putChar-    , ePutChar-    , vHPutChar-    , vPutChar-    , vEPutChar--    , hPutStrBl-    , putStrBl-    , ePutStrBl-    , vHPutStrBl-    , vPutStrBl-    , vEPutStrBl--    , hPutStrLn-    , putStrLn-    , ePutStrLn-    , vHPutStrLn-    , vPutStrLn-    , vEPutStrLn--    , bol-    , eBOL-    , vHBOL-    , vBOL-    , vEBOL--    , hColor-    , blue-    , green-    , red-    , magenta-    ) where--import Prelude hiding (putStr, putChar, putStrLn)-import qualified System.IO as IO-import Control.Monad.Trans-import Control.Exception---- |Class representing ways of doing console (terminal?) output.-class MonadIO m => CIO m where-    -- |Write output to a handle.-    hPutStr :: IO.Handle -> String -> m ()-    -- |If we are not already at the beginning of a line, move the cursor-    -- to the beginning of the next one.-    hBOL :: IO.Handle -> m ()-    -- |Return the \"effective verbosity\" for a task.  If the argument-    -- is 2 it means the caller is computing ev for a task that-    -- normally does output when the verbosity level is 2 or higher.-    -- If the verbosity of the current style is 1, then the ev or-    -- effective verbosity is 2-1 = -1, so the output should be-    -- quieter.-    ev :: Int -> m Int-    -- |Modify the current output style.-    setStyle :: (TStyle -> TStyle) -> m a -> m a-    -- |Implementation of try for this monad-    tryCIO :: m a -> m (Either SomeException a)---- |A record used to hold the output style information for a task.--- This The prefixes that will appear at the beginning of each line,--- and the desired verbosity level.  Suggested verbosity level policy:------  * -1: No output of any kind, as if you were directing all output to /dev/null--- ---  * 0: Error output only, suitable for a run whose log you might examine later--- ---  * 1: casual progress reporting - if you were running on a console but didn't---      expect anything to go wrong------  * 2: detailed progress reporting - show more progress, particularly things---      that might fail during the normal operation of the autobuilder: patches---      that fail to apply, dpkg-buildpackage runs that return errors, etc.------  * 3: Debugging output - use this level or higher if you suspect the---      autobuilder itself is failing, or you are doing development work on---      the autobuilder.-data TStyle-    = TStyle { prefix :: String			-- ^ Add this string at the beginning of each line-             , verbosity :: Int			-- ^ Ignore v functions whose argument is more than this-             , hPrefix :: [(IO.Handle, String)]	-- ^ Per-handle prefix-             } deriving Show--defStyle :: TStyle-defStyle = TStyle { prefix = ": "-                  , hPrefix = []-                  , verbosity = 0-                  }---- |Use a new style for the TIO action-withStyle :: CIO m => TStyle -> m a -> m a-withStyle newStyle = setStyle (const newStyle)--setVerbosity :: Int -> TStyle -> TStyle-setVerbosity n style = style {verbosity = n}-addVerbosity :: Int -> TStyle -> TStyle-addVerbosity n style = setVerbosity (n + verbosity style) style---- |Set the output style for a handle to prefixed.-setPrefix :: String -> TStyle -> TStyle-setPrefix prefix style = style {prefix = prefix}---- | Prepend some text to the prefix.-addPrefix :: String -> TStyle -> TStyle-addPrefix newPrefix style = style {prefix = newPrefix ++ prefix style}---- | Append some text to the prefix.-appPrefix :: String -> TStyle -> TStyle-appPrefix newPrefix style = style {prefix = prefix style ++ newPrefix}--hSetPrefix :: IO.Handle -> String -> TStyle -> TStyle-hSetPrefix handle string style =-    style {hPrefix = (handle, string) : filter ((/= handle) . fst) (hPrefix style)}--hAddPrefix :: IO.Handle -> String -> TStyle -> TStyle-hAddPrefix handle string style =-    hSetPrefix handle (string ++ prefix) style-    where prefix = maybe "" id (lookup handle (hPrefix style))--hAppPrefix :: IO.Handle -> String -> TStyle -> TStyle-hAppPrefix handle string style =-    hSetPrefix handle (prefix ++ string) style-    where prefix = maybe "" id (lookup handle (hPrefix style))---- |Get the current prefix for a particular handle-hGetPrefix :: IO.Handle -> TStyle -> String-hGetPrefix handle style = prefix style ++ maybe "" id (lookup handle (hPrefix style))---- |Set the output style for the stdout and stderr handle to prefixed,--- using whatever prefixes were most recently set (default is [1] and [2].)-setPrefixes :: String -> String -> TStyle -> TStyle-setPrefixes stdoutPrefix stderrPrefix style =-    hSetPrefix IO.stdout stdoutPrefix . hSetPrefix IO.stderr stderrPrefix $ style---- |Switch to prefixed mode and modify both the stdout and stderr prefixes.-addPrefixes :: String -> String -> TStyle -> TStyle-addPrefixes oPrefix ePrefix style =-    hAddPrefix IO.stdout oPrefix . hAddPrefix IO.stderr ePrefix $ style--appPrefixes :: String -> String -> TStyle -> TStyle-appPrefixes oPrefix ePrefix style =-    hAppPrefix IO.stdout oPrefix . hAppPrefix IO.stderr ePrefix $ style---- |Perform an action if the effective verbosity level is >= 0,--- otherwise return the default value d.-vIO :: CIO m => Int -> a -> m a -> m a-vIO v d f =-    do v' <- ev v-       if v' >= 0 then f else return d---- |Write a string to stdout.-putStr :: CIO m => String -> m ()-putStr = hPutStr IO.stdout---- |Write a string to stderr.-ePutStr :: CIO m => String -> m ()-ePutStr = hPutStr IO.stderr---- |Verbosity controlled version of ePutStr-vEPutStr :: CIO m => Int -> String -> m ()-vEPutStr = vHPutStr IO.stderr---- |Write a string to stdout depending on the verbosity level.-vPutStr :: CIO m => Int -> String -> m ()-vPutStr = vHPutStr IO.stdout---- |Write a character.-hPutChar :: CIO m => IO.Handle -> Char -> m ()-hPutChar h c = hPutStr h [c]---- |Write a character to stdout.-putChar :: CIO m => Char -> m ()-putChar = hPutChar IO.stdout---- |Write a character to stderr.-ePutChar :: CIO m => Char -> m ()-ePutChar = hPutChar IO.stderr---- |Verbosity controlled version of hPutStr-vHPutStr :: CIO m => IO.Handle -> Int -> String -> m ()-vHPutStr h v s = vIO v () (hPutStr h s)---- |Verbosity controlled version of hPutChar.-vHPutChar :: CIO m => IO.Handle -> Int -> Char -> m ()-vHPutChar h v c = vHPutStr h v [c]---- |Verbosity controlled version of putChar-vPutChar :: CIO m => Int -> Char -> m ()-vPutChar = vHPutChar IO.stdout---- |Verbosity controlled version of ePutChar-vEPutChar :: CIO m => Int -> Char -> m ()-vEPutChar = vHPutChar IO.stderr---- |Move to beginning of next line (if necessary) and output a string.-hPutStrBl :: CIO m => IO.Handle -> String -> m ()-hPutStrBl h s = hBOL h >> hPutStr h s---- |hPutStrBl to stdout.-putStrBl :: CIO m => String -> m ()-putStrBl = hPutStrBl IO.stdout---- |hPutStrBl to stderr.-ePutStrBl :: CIO m => String -> m ()-ePutStrBl = hPutStrBl IO.stderr---- |Verbosity controlled version of hPutStrBl-vHPutStrBl :: CIO m => IO.Handle -> Int -> String -> m ()-vHPutStrBl h v s = vHBOL h v >> vHPutStr h v s---- |Verbosity controlled version of putStrBl-vPutStrBl :: CIO m => Int -> String -> m ()-vPutStrBl = vHPutStrBl IO.stdout          ---- |Verbosity controlled version of ePutStrBl-vEPutStrBl :: CIO m => Int -> String -> m ()-vEPutStrBl = vHPutStrBl IO.stderr---- |Write a newline character and a string.-hPutStrLn :: CIO m => IO.Handle -> String -> m ()-hPutStrLn h s = hBOL h >> hPutStr h s---- |hPutStrLn to stdout.-putStrLn :: CIO m => String -> m ()-putStrLn s = hPutStrLn IO.stdout s---- |hPutStrLn to stderr.-ePutStrLn :: CIO m => String -> m ()-ePutStrLn = hPutStrLn IO.stderr---- |Verbosity controlled version of hPutStrLn.-vHPutStrLn :: CIO m => IO.Handle -> Int -> String -> m ()-vHPutStrLn h v s = vHBOL h v >> vHPutStr h v s---- |Verbosity controlled version of putStrLn-vPutStrLn :: CIO m => Int -> String -> m ()-vPutStrLn = vHPutStrLn IO.stdout          ---- |Verbosity controlled version of ePutStrLn-vEPutStrLn :: CIO m => Int -> String -> m ()-vEPutStrLn = vHPutStrLn IO.stderr---- |hBOL to stdout.-bol :: CIO m => m ()-bol = hBOL IO.stdout---- |hBOL to stderr.-eBOL :: CIO m => m ()-eBOL = hBOL IO.stderr--vHBOL :: CIO m => IO.Handle -> Int -> m ()-vHBOL h v = vIO v () (hBOL h)---- |Verbosity controlled version of BOL-vBOL :: CIO m => Int -> m ()-vBOL = vHBOL IO.stdout---- |Verbosity controlled version of eBOL-vEBOL :: CIO m => Int -> m ()-vEBOL = vHBOL IO.stderr---- These only work in a terminal, not in an emacs shell.-hColor h s = case h of-               _ | h == IO.stdout -> green s-               _ | h == IO.stdout -> red s-               _ -> magenta s--blue s = "\ESC[34m" ++ s ++ "\ESC[30m"-green s = "\ESC[32m" ++ s ++ "\ESC[30m"-red s = "\ESC[31m" ++ s ++ "\ESC[30m"-magenta s = "\ESC[35m" ++ s ++ "\ESC[30m"
+ Extra/Debug.hs view
@@ -0,0 +1,85 @@+-- | Declarations pulled out of th-unify++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Extra.Debug+    ( HasMessageInfo(..)+    , Verbosity(message)+    , quietly, noisily, indented+    , R(..))+    where++import Control.Lens (Lens', makeLenses, over, view)+import Control.Monad (when)+import Control.Monad.Reader (local, MonadReader, ReaderT)+import Control.Monad.RWS (RWST)+import Control.Monad.Trans (MonadIO(liftIO))+import Data.Char (isSpace)+import Data.List (dropWhileEnd, intercalate)+import Instances.TH.Lift ()+import Language.Haskell.TH.Instances ()+import System.IO (hPutStrLn, stderr)++class HasMessageInfo a where+    verbosity :: Lens' a Int+    prefix :: Lens' a String++-- | Class of monads with a verbosity level and a stored indentation string.+class (HasMessageInfo r, MonadReader r m) => Verbosity r m where+  message :: Int -> String -> m ()+  -- ^ If the monad's verbosity level exceeds the verbosity argument,+  -- prepend the current indentation string to the lines of a message+  -- and output it.++instance (MonadIO m, HasMessageInfo r, Monoid w) => Verbosity r (RWST r w s m) where+  message minv s = do+    v <- view verbosity+    p <- view prefix+    when (v >= minv) $ (liftIO . hPutStrLn stderr . indent p) s++instance (MonadIO m, HasMessageInfo r) => Verbosity r (ReaderT r m) where+  message minv s = do+    v <- view verbosity+    p <- view prefix+    liftIO $ putStrLn ("v=" ++ show v ++ " vmin=" ++ show minv)+    when (v >= minv) $ (liftIO . putStrLn . indent p) s++-- | Indent the lines of a message with a prefix+indent :: String -> String -> String+indent pre s = intercalate "\n" $ fmap (dropWhileEnd isSpace . (pre ++)) (lines s)++-- | If the current verbosity level is >= minv perform the action with+-- additional indentation.+indented :: (HasMessageInfo r, MonadReader r m) => Int -> m a -> m a+indented minv action = do+  (v :: Int) <- view verbosity+  if v >= minv then local (over prefix ("  " ++)) action else action++-- | Perform the action with reduced verbosity+quietly :: (HasMessageInfo r, MonadReader r m) => Int -> m a -> m a+quietly n = local (over verbosity (\i -> i - n))++-- | Perform the action with increased verbosity+noisily :: (HasMessageInfo r, MonadReader r m) => Int -> m a -> m a+noisily n = local (over verbosity (+ n))++-- | A type with a HasMessageInfo instance to use in the Reader or RWS monad.+data R+    = R+      { _verbosityR :: Int+      , _prefixR :: String+      }++$(makeLenses ''R)++instance HasMessageInfo R where+    verbosity = verbosityR+    prefix = prefixR
+ Extra/Debug2.hs view
@@ -0,0 +1,61 @@+-- | Generate debug messages - verbosity controls, indentation.++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS -Wall -Wredundant-constraints #-}++module Extra.Debug2+    ( HasTraceInfo(verbosityLens, prefixLens)+    , message+    , trace+    , indented+    , verbosity+    ) where++import Control.Lens ((%=), (.=), Lens', use)+import Control.Monad (when)+import Control.Monad.RWS+import Data.List (intercalate)+import qualified Debug.Trace+import Language.Haskell.TH.Instances ()+import System.Log.Logger (Priority(..))++-- Perform an action with modified state.+bracketState :: MonadState s m => Lens' s a -> (a -> a) -> m r -> m r+bracketState lns f action = do+  a0 <- use lns+  lns %= f+  r <- action+  lns .= a0+  return r++class HasTraceInfo a where+    verbosityLens :: Lens' a Priority+    prefixLens :: Lens' a String++-- | If the verbosity argument monad's verbosity level exceeds the verbosity argument,+-- prepend the current indentation string to the lines of a message+-- and output it.+message :: (HasTraceInfo s, MonadState s m) => (String -> m ()) -> Priority -> String -> m ()+message f p s = do+  v <- use verbosityLens+  when (p >= v) $ do+    i <- use prefixLens+    f (intercalate "\n" $ fmap (i ++) (lines s))++trace :: (HasTraceInfo s, MonadState s m) => String -> m ()+trace = message (\s -> Debug.Trace.trace s (return ())) DEBUG++-- | Perform an action with added indentation+indented :: (HasTraceInfo s, MonadState s m) => String -> m r -> m r+indented s action = bracketState prefixLens (<> s) action++-- | Perform an action with modified verbosity+verbosity :: (HasTraceInfo s, MonadState s m) => Priority -> m r -> m r+verbosity v action = bracketState verbosityLens (const v) action
Extra/Either.hs view
@@ -1,20 +1,11 @@ module Extra.Either where -import Data.Either (partitionEithers, rights)--isRight (Right _) = True-isRight (Left _) = False--isLeft = not . isRight+import Data.Either  -- |Turn a list of eithers into an either of lists concatEithers :: [Either a b] -> Either [a] [b] concatEithers xs =-    case partitionEithers xs of +    case partitionEithers xs of       ([], rs) -> Right rs       (ls, _) -> Left ls--{-# DEPRECATED rightOnly "Use rights" #-}-rightOnly = rights-{-# DEPRECATED eitherFromList "Use concatEithers" #-}-eitherFromList = concatEithers+{-# DEPRECATED concatEithers "This is terrible.  Delete your account." #-}
+ Extra/EnvPath.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleInstances, StandaloneDeriving, TemplateHaskell, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Extra.EnvPath+    ( EnvRoot(..), rootPath+    , EnvPath(..), envRoot, envPath+    , outsidePath+    , appendPath+    , rootEnvPath+    , HasEnvRoot(envRootLens)+    ) where++import Control.Lens (Lens', makeLenses, over)+import Extra.Pretty (PP(PP))+import Text.PrettyPrint.HughesPJClass (text)+import Distribution.Pretty (Pretty(pretty))++-- |The root directory of an OS image.+data EnvRoot = EnvRoot { _rootPath :: FilePath } deriving (Ord, Eq, Read, Show)++-- |A directory inside of an OS image.+data EnvPath = EnvPath { _envRoot :: EnvRoot+                       , _envPath :: FilePath+                       } deriving (Ord, Eq, Read, Show)++$(makeLenses ''EnvRoot)+$(makeLenses ''EnvPath)++outsidePath :: EnvPath -> FilePath+outsidePath path = _rootPath (_envRoot path) ++ _envPath path++appendPath :: FilePath -> EnvPath -> EnvPath+appendPath suff path = over envPath (++ suff) path++rootEnvPath :: FilePath -> EnvPath+rootEnvPath s = EnvPath { _envRoot = EnvRoot "", _envPath = s }++instance Pretty (PP EnvRoot) where+    pretty (PP x) = text (_rootPath x)++-- | Class used to access an EnvRoot in a value, typically in a reader+-- monad.+class HasEnvRoot r where envRootLens :: Lens' r EnvRoot+instance HasEnvRoot EnvRoot where envRootLens = id+
+ Extra/Except.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP, DeriveAnyClass, FunctionalDependencies, OverloadedStrings, TemplateHaskell, UndecidableInstances #-}+{-# OPTIONS -Wall -Wredundant-constraints -Wno-orphans #-}++module Extra.Except+    ( -- * Control.Exception extensions+      withException+    , displaySomeExceptionType+      -- * Control.Monad.Except extensions+    , tryError+    , withError+    , mapError+    , handleError+    , HasIOException(fromIOException)+    , IOException'(..)+#if 1+    , Tried(unTried)+    , tryIO+    , logIOError+#else+    , LyftIO(lyftIO, IOMonad, ErrorType)+    , tryLiftIO+    , logLiftIO+    , lyftIO'+    , LyftIO'+    , LyftIO2+    , lyftIO2++    , MonadIOError+    , liftIOError+    , tryIOError+    , logIOError+#endif+    , module Control.Monad.Except+    ) where++import Control.Exception ({-evaluate,-} Exception, IOException, SomeException(..))+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 Extra.Log (logException, Priority(ERROR))++-- | Apply a function to whatever @Exception@ type is inside a+-- @SomeException@:+--+-- >>> catch (readFile "/tmp/nonexistant") (withException (return . show . typeOf))+-- "IOException"+withException :: forall r. (forall e. Exception e => e -> r) -> SomeException -> r+withException f (SomeException e) = f e++-- | Use 'withException' to obtain the exception's type name (similar+-- to 'Control.Exception.displayException')+--+-- >>> catch (readFile "/tmp/nonexistant") (return . displaySomeExceptionType)+-- "IOException"+displaySomeExceptionType :: SomeException -> String+displaySomeExceptionType = withException (show . typeOf)++-- | MonadError analog to the 'try' function.+tryError :: MonadError e m => m a -> m (Either e a)+tryError action = (Right <$> action) `catchError` (pure . Left)++-- | 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++handleError :: MonadError e m => (e -> m a) -> m a -> m a+handleError = flip catchError++-- | MonadError analogue of the 'mapExceptT' function.+mapError :: (MonadError e m, MonadError e' n) => (m (Either e a) -> n (Either e' b)) -> m a -> n b+mapError f action = f (tryError action) >>= liftEither++-- | In order to guarantee IOException is caught, do NOT create this+-- 'HasIOException' instance for IOException.+--+-- > instance HasIOException IOException where fromIOException = id+--+-- Because there is an @instance MonadError IOException IO@ in+-- @Control.Monad.Except@, "thrown" IOexceptions are not be caught by+-- 'runExceptT':+--+-- >>> runExceptT (liftIO (readFile "/etc/nonexistant") :: ExceptT IOException IO String)+-- *** Exception: /etc/nonexistant: openFile: does not exist (No such file or directory)+--+--  (*** means the exception reached the top level.)  However, if we+-- use 'liftIOError' to implement a version of 'readFile' that has a+-- 'MonadIOError' constraint:+--+-- >>> let readFile' path = liftIOError (readFile path)+-- >>> :type readFile'+-- readFile' :: MonadIOError e m => FilePath -> m String+--+-- and then create a suitable error type+--+-- >>> newtype Error = Error IOException deriving Show+-- >>> instance MonadIOError Error where liftIOError io = liftIO (try io) >>= either (throwError . fromIOException) return+--+-- Now the thrown 'IOException' will always be caught and lifted into+-- the 'MonadError':+--+-- >>> 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++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)++logIOError :: (MonadIO m, MonadError e m) => m a -> m a+logIOError = handleError (\e -> liftIO ($logException ERROR (pure e)) >> throwError e)++#else++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++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 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++-- | LyftIO analog to the 'try' function.+tryLiftIO :: LyftIO m => IOMonad m a -> m (Either (ErrorType m) a)+tryLiftIO = tryError . lyftIO++logLiftIO :: forall m a. LyftIO m => m a -> m a+logLiftIO = handleError (\e -> lyftIO ($logException ERROR (pure e) :: IOMonad m (ErrorType m)) >> throwError e)++type LyftIO' m = (LyftIO m, IOMonad m ~ ExceptT (ErrorType m) IO)++-- | 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))++type LyftIO2 e m = (LyftIO' m, e ~ ErrorType m)++-- | Lift an @IOMonad m a@ action into @m a@.+lyftIO2 :: LyftIO2 e m => IOMonad m a -> m a+lyftIO2 action = lyftIO action++-- Backwards compatibiity++type MonadIOError e m = (LyftIO' m, e ~ ErrorType m)++liftIOError :: MonadIOError e m => IO a -> m a+liftIOError = lyftIO'++tryIOError :: MonadIOError e m => IO a -> m (Either e a)+tryIOError = tryError . liftIOError++logIOError :: MonadIOError e m => m a -> m a+logIOError = handleError (\e -> liftIOError ($logException ERROR (pure e)) >> throwError e)++#endif
Extra/Exit.hs view
@@ -4,7 +4,7 @@ import System.Environment import System.Exit import System.IO-import Text.PrettyPrint.HughesPJ+import Text.PrettyPrint  -- |exitFailure with nicely formatted help text on stderr exitWithHelp :: (String -> Doc) -- ^ generate help text, the argument is the result of getProgName
+ Extra/FP.hs view
@@ -0,0 +1,71 @@+-- | Copied from packman.  Tried to use the library but got a compile error:+--+-- <no location info>: error:+--     <command line>: can't load .so/.DLL for: /usr/lib/haskell-packages/ghc/lib/x86_64-linux-ghc-8.4.3/libHSpackman-0.5.0-Fv7reuyLHo03M7x4FerNmn-ghc8.4.3.so (/usr/lib/haskell-packages/ghc/lib/x86_64-linux-ghc-8.4.3/libHSpackman-0.5.0-Fv7reuyLHo03M7x4FerNmn-ghc8.4.3.so: undefined symbol: mblock_address_space)++{-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DeriveGeneric, TemplateHaskell #-}++module Extra.FP+    ( FP(..)+    , matches+    , toFP+    , typeFP+    , typeRepFP+    ) where+++--import Data.Binary (Binary(..), Get)+import Data.Data (Data, Proxy, typeRep)+import Data.SafeCopy (base, deriveSafeCopy)+import Extra.Serialize (Serialize)+import Data.Typeable (Typeable, typeOf)+import Data.Typeable (typeRepFingerprint)+import Data.Word (Word64)+import qualified GHC.Fingerprint+import GHC.Generics (Generic)++------------------------------------------------------------------+-- $ComparingTypes+-----------------------------------------------+-- Helper functions to compare types at runtime:+--   We use type "fingerprints" defined in 'GHC.Fingerprint.Type'++-- This should ensure (as of GHC.7.8) that types with the same name+-- but different definition get different hashes.  (however, we also+-- require the executable to be exactly the same, so this is not+-- strictly necessary anyway).++-- Typeable context for dynamic type checks. ++-- | The module uses a custom GHC fingerprint type with its two Word64+--   fields, to be able to /read/ fingerprints+data FP = FP Word64 Word64 deriving (Read, Show, Eq, Data, Typeable, Ord, Generic, Serialize)++-- | checks whether the type of the given expression matches the given Fingerprint+matches :: Typeable a => a -> FP -> Bool+matches x (FP c1 c2) = f1 == c1 && f2 == c2+  where  (GHC.Fingerprint.Fingerprint f1 f2) = typeRepFingerprint (typeOf x)++-- | creates an 'FP' from a GHC 'Fingerprint'+toFP :: GHC.Fingerprint.Fingerprint -> FP+toFP (GHC.Fingerprint.Fingerprint f1 f2) = FP f1 f2++-- | returns the type fingerprint of an expression+typeFP :: Typeable a => a -> FP+typeFP = toFP . typeRepFingerprint . typeOf++typeRepFP :: Typeable a => Proxy a -> FP+typeRepFP p = toFP (typeRepFingerprint (typeRep p))++{-+-- | Binary instance for fingerprint data (encoding TypeRep and+--   executable in binary-encoded @Serialized a@)+instance Binary FP where+  put (FP f1 f2) = do put f1+                      put f2+  get            = do f1 <- get :: Get Word64+                      f2 <- get :: Get Word64+                      return (FP f1 f2)+-}++$(deriveSafeCopy 1 'base ''FP)
Extra/Files.hs view
@@ -5,7 +5,7 @@ -- An example of an inconsistant state would be if we got a failure -- when writing out a file, but were unable to restore the original -- file to its original position.-module Extra.Files +module Extra.Files     ( getSubDirectories     , renameAlways     , renameMissing@@ -15,7 +15,7 @@     , writeAndZipFile     , backupFile     , writeFileIfMissing-    , maybeWriteFile		-- writeFileUnlessSame+    , maybeWriteFile            -- writeFileUnlessSame     , createSymbolicLinkIfMissing     , prepareSymbolicLink     , forceRemoveLink@@ -24,16 +24,16 @@  import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.BZip as BZip-import		 Control.Exception-import		 Control.Monad+import           Control.Exception+import           Control.Monad import qualified Data.ByteString.Lazy as B-import		 Data.List-import		 Data.Maybe-import		 Extra.Misc-import		 System.Unix.Directory-import		 System.Directory-import		 System.IO.Error hiding (try, catch)-import		 System.Posix.Files as SPF+import           Data.List+import           Data.Maybe+import           Extra.Misc+import           System.Unix.Directory+import           System.Directory+import           System.IO.Error+import           System.Posix.Files as SPF  -- | Return the list of subdirectories, omitting . and .. and ignoring -- symbolic links.@@ -52,7 +52,7 @@ installFiles pairs =     do backedUp <- mapM (uncurry renameAlways) (zip originalFiles backupFiles)        case lefts backedUp of-         [] -> +         [] ->              do renamed <- mapM (uncurry renameAlways) (zip replacementFiles originalFiles)                 case lefts renamed of                   [] -> return $ Right ()@@ -63,9 +63,9 @@                       -- files back into place.                       do restored <- mapM (uncurry renameAlways) (zip backupFiles originalFiles)                          case lefts restored of-	                   -- We succeeded in failing.+                           -- We succeeded in failing.                            [] -> return . Left . concat . lefts $ renamed-	                   -- Restore failed.  Throw an exception.+                           -- Restore failed.  Throw an exception.                            _ -> error ("installFiles: Couldn't restore original files after write failure:" ++                                        concat (map message (zip3 replacementFiles originalFiles renamed)) ++                                        concat (map message (zip3 originalFiles backupFiles restored)))@@ -75,9 +75,9 @@              -- Restore the backup for any missing original files.              do restored <- mapM (uncurry renameMissing) (zip backupFiles originalFiles)                 case lefts restored of-	          -- We succeeded in failing.+                  -- We succeeded in failing.                   [] -> return . Left . concat . lefts $ backedUp-		  -- Restore failed.  Throw an exception.+                  -- Restore failed.  Throw an exception.                   _ -> error ("installFiles: Couldn't restore original files after write failure: " ++                               concat (map message (zip3 originalFiles backupFiles backedUp)) ++                               concat (map message (zip3 backupFiles originalFiles restored)))@@ -126,7 +126,7 @@          False -> return $ Right ()          True ->              do status <- getSymbolicLinkStatus path-		-- To do: should we remove the directory contents?+                -- To do: should we remove the directory contents?                 let rm = if isDirectory status then removeDirectory else removeLink                 try (rm path) >>= return . either (\ (e :: SomeException) -> Left ["Couldn't remove " ++ path ++ ": " ++ show e]) (const . Right $ ()) @@ -152,18 +152,18 @@ -- |like removeLink, but does not fail if link did not exist forceRemoveLink :: FilePath -> IO () forceRemoveLink fp = removeLink fp `Control.Exception.catch` (\e -> unless (isDoesNotExistError e) (ioError e))-                 + -- | Write out three versions of a file, regular, gzipped, and bzip2ed. writeAndZipFileWithBackup :: FilePath -> B.ByteString -> IO (Either [String] ()) writeAndZipFileWithBackup path text =     backupFile path >>=     either (\ e -> return (Left ["Failure renaming " ++ path ++ " -> " ++ path ++ "~: " ++ show e]))            (\ _ -> try (B.writeFile path text) >>=-                   either (\ (e :: SomeException) ->+                   either (\(e :: SomeException) ->                                restoreBackup path >>=-                               either (\ e -> error ("Failed to restore backup: " ++ path ++ "~ -> " ++ path ++ ": " ++ show e))+                               either (\ex -> error ("Failed to restore backup: " ++ path ++ "~ -> " ++ path ++ ": " ++ show ex))                                       (\ _ -> return (Left ["Failure writing " ++ path ++ ": " ++ show e])))-                          (\ _ -> zipFile path))+                          (\_ -> zipFile path))  -- | Write out three versions of a file, regular, gzipped, and bzip2ed. -- This new version assumes the files are written to temporary locations,@@ -207,7 +207,7 @@       maybeWrite (Left (e :: IOException)) | isDoesNotExistError e = writeFile path text       maybeWrite (Left e) = error ("maybeWriteFile: " ++ show e)       maybeWrite (Right old) | old == text = return ()-      maybeWrite (Right _old) = +      maybeWrite (Right _old) =           --hPutStrLn stderr ("Old text: " ++ show old) >>           --hPutStrLn stderr ("New text: " ++ show text) >>           replaceFile path text@@ -238,7 +238,7 @@ -- isAlreadyBusyError exceptions before the writeFile succeeds. replaceFile :: FilePath -> String -> IO () replaceFile path text =-    --tries 100 10 f	-- There is now a fix for this problem, see ghc ticket 2122.+    --tries 100 10 f    -- There is now a fix for this problem, see ghc ticket 2122.     f     where       f :: IO ()
Extra/GPGSign.hs view
@@ -20,7 +20,7 @@  sign :: PGPKey'' -> FilePath -> IO FilePath sign keyname path =-    do (_, _,err,pid) <- runInteractiveProcess cmd args workingDir env+    do (_, _,err,pid) <- runInteractiveProcess cmd args workingDir Nothing        status <- waitForProcess pid        case status of          ExitSuccess -> return outputPath@@ -39,7 +39,6 @@                 ]          outputPath = path ++ ".gpg"          workingDir = Nothing -- Just (dirName path)-         env = Nothing  data PGPKey = Key String | Default deriving Show @@ -48,7 +47,7 @@  pgpSignFile :: PGPKey -> FilePath -> IO Bool pgpSignFile keyname path =-    do (_, _,err,pid) <- runInteractiveProcess cmd args workingDir env+    do (_, _,err,pid) <- runInteractiveProcess cmd args workingDir Nothing        status <- waitForProcess pid        case status of          ExitSuccess -> return True@@ -69,4 +68,3 @@          defaultKey = case keyname of Key name -> ["--default-key", name]; Default -> []          outputPath = path ++ ".gpg"          workingDir = Nothing -- Just (dirName path)-         env = Nothing
+ Extra/Generics.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ConstraintKinds, FlexibleContexts #-}++module Extra.Generics+    ( gFind+    , Extra.Generics.GShow+    , gshow+    , gshows+    , gshowsPrec+    ) where++import Control.Monad (MonadPlus, msum)+import Data.Generics (Data, listify, Proxy, Typeable)+import Generic.Data (gshowsPrec)+import Generic.Data.Internal.Show (GShow)+import GHC.Generics (Generic, Rep)++-- | @gFind a@ will extract any elements of type @b@ from+-- @a@'s structure in accordance with the MonadPlus+-- instance, e.g. Maybe Foo will return the first Foo+-- found while [Foo] will return the list of Foos found.+gFind :: (MonadPlus m, Data a, Typeable b) => a -> m b+gFind = msum . map return . listify (const True)++type GShow a = (Generic a, Generic.Data.Internal.Show.GShow Proxy (Rep a))++-- | Generic version of show based on generic-data's gshowsPrec function.+gshow :: (Generic a, Generic.Data.Internal.Show.GShow Proxy (Rep a)) => a -> String+gshow x = gshows x ""++gshows :: (Generic a, Generic.Data.Internal.Show.GShow Proxy (Rep a)) => a -> ShowS+gshows x = gshowsPrec 0 x
+ Extra/Generics/Show.hs view
@@ -0,0 +1,278 @@+-- | This is a both a working implementation of Generic Show and a+-- template for using GHC.Generics to implement similar functions+-- without requiring that every type it can operate on have a Show+-- instance.  It does require an instance for each base type.++{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+-- {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+-- {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS -Wall -Wredundant-constraints #-}++module Extra.Generics.Show+  ( GShow0, gprecShows, gshowsPrec+  , GShow1, gLiftPrecShows, gLiftShowsPrec+  , GShow, gshow, gshows+  , myshow+  ) where++--import Debug.Trace+import Data.Foldable (foldl')+import Data.Functor.Classes (Show1(..))+import Data.Functor.Identity (Identity(Identity))+import Data.Proxy (Proxy(Proxy))+import Generic.Data (gconIndex)+import GHC.Generics as G+import GHC.TypeLits+import Text.Show.Combinators (PrecShowS, {-ShowFields,-} noFields, showField, showListWith, showInfix, showApp, showCon, showRecord)+import qualified Text.Show.Combinators as Show (appendFields)++-- For primitive instances+-- import Data.Typeable (Typeable, typeOf)++-- For tests+#if !__GHCJS__+import Test.HUnit+import Language.Haskell.TH (location)+import Language.Haskell.TH.Lift (lift)+import Language.Haskell.TH.Instances ()+#endif++-- for debug+-- import Debug.Trace+--import GHC.TypeLits++-- The K1 instance had constraint Show a, which means that every field+-- traversed must have a Show instance.  I removed this constraint,+-- and then also had to remove it from doK1.  Now I needed doK1 to Use+-- the Show instance for a set of base types and otherwise use the+-- Generic instance.  This can be done by creating a new class DoK1+-- and using overlapping instances.++type TypeTuple = (String, String, String, Bool)+type ConstrTuple = (Int, String, Fixity)++-- Constraints for doing recusion into subtypes+type DoRep a = (Generic a, DoM1 Proxy (Rep a))+type DoRep1 f = (Generic1 f, DoM1 Identity (Rep1 f))++class                                       DoS1 p f               where doS1 :: forall a. p (Rd a) -> TypeTuple -> ConstrTuple -> f a -> S1Result+instance {-# OVERLAPPABLE #-} DoRep a =>    DoS1 p (K1 R a)        where doS1 p ti ci (K1 a) = doRecursion p ti ci a+instance DoRep1 f =>                        DoS1 Identity (Rec1 f) where doS1 (Identity st) ti ci (Rec1 r) = doRec1 st ti ci r+instance                                    DoS1 Identity Par1     where doS1 (Identity st) ti ci (Par1 a) = doPar1 st ti ci a+instance (Show1 f, DoS1 p g) =>             DoS1 p (f :.: g)       where doS1 p ti ci (Comp1 c) = doComp1 p ti ci c++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                                    DoFields p U1          where doFields _ _ _ U1 = []++class                                       DoNamed p f            where doNamed :: forall a. p (Rd a) -> TypeTuple -> ConstrTuple -> f a -> [(String, S1Result)]+instance (DoNamed p f, DoNamed p g) =>      DoNamed p (f :*: g)    where doNamed p ti ci (x :*: y) = doNamed p ti ci x <> doNamed p ti ci y+instance (Selector c, DoS1 p f) =>          DoNamed p (M1 S c f)   where doNamed p ti ci x'@(M1 x) = [(G.selName x', doS1 p ti ci x)]+instance                                    DoNamed p U1           where doNamed _ _ _ U1 = []++-- 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+                                                                   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++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 (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+instance                                    DoD1 p V1              where doD1 _ _ v = case v of {}++class                                       DoM1 p f               where doM1 :: forall a. p (Rd a) -> f a -> D1Result+instance (DoDatatype p d f, Datatype d) =>  DoM1 p (M1 D d f)      where doM1 p x@(M1 _) = let ti = (G.datatypeName x, G.moduleName x, G.packageName x, G.isNewtype x) in doD1 p ti x++-- customization for generic Show --++-- Instances for primitive types+instance                      DoS1 p (K1 R Int)      where doS1 p ti ci (K1 a) = doLeaf p ti ci a+instance                      DoS1 p (K1 R Char)     where doS1 p ti ci (K1 a) = doLeaf p ti ci a+instance {-# OVERLAPPING #-}  DoS1 p (K1 R String)   where doS1 p ti ci (K1 a) = doLeaf p ti ci a -- overlaps [a]+instance DoS1 Proxy (K1 R a) =>+                              DoS1 p (K1 R [a])      where doS1 p ti ci (K1 xs) = doList p ti ci (fmap myshows xs)+instance                      DoS1 p (K1 R ())       where doS1 p ti ci (K1 ()) = doTuple p ti ci []+instance (DoS1 Proxy (K1 R a),+          DoS1 Proxy (K1 R b)) => DoS1 p (K1 R (a, b))+                                                     where doS1 p ti ci (K1 (a, b)) = doTuple p ti ci [myshows a, myshows b]+instance (DoS1 Proxy (K1 R a),+          DoS1 Proxy (K1 R b),+          DoS1 Proxy (K1 R c)) => DoS1 p (K1 R (a, b, c))+                                                     where doS1 p ti ci (K1 (a, b, c)) = doTuple p ti ci [myshows a, myshows b, myshows c]+instance (DoS1 Proxy (K1 R a),+          DoS1 Proxy (K1 R b),+          DoS1 Proxy (K1 R c),+          DoS1 Proxy (K1 R d)) => DoS1 p (K1 R (a, b, c, d))+                                                     where doS1 p ti ci (K1 (a, b, c, d)) = doTuple p ti ci [myshows a, myshows b, myshows c, myshows d]+instance (DoS1 Proxy (K1 R a),+          DoS1 Proxy (K1 R b),+          DoS1 Proxy (K1 R c),+          DoS1 Proxy (K1 R d),+          DoS1 Proxy (K1 R e)) => DoS1 p (K1 R (a, b, c, d, e))+                                                     where doS1 p ti ci (K1 (a, b, c, d, e)) = doTuple p ti ci [myshows a, myshows b, myshows c, myshows d, myshows e]++type Rd a = (Int -> a -> ShowS, [a] -> ShowS) -- Like a Reader monad+type S1Result = PrecShowS -- The result of a single field of a constructor+type C1Result = PrecShowS -- Result of processing one constructors+type D1Result = PrecShowS -- Result of processing a type value++doLeaf :: Show a => p -> TypeTuple -> ConstrTuple -> a -> S1Result+doLeaf _p _ti _ci a _prec = shows a++doList :: p -> TypeTuple -> ConstrTuple -> [ShowS] -> S1Result+doList _ _ _ [] = \_ -> showChar '[' . showChar ']'+doList _ _ _ xs = \_ -> showChar '[' . foldl1 (\a b -> a . showString "," . b) xs . showChar ']'++doTuple :: p -> TypeTuple -> ConstrTuple -> [ShowS] -> S1Result+doTuple _ _ _ [] = \_ -> showString "()"+doTuple _ _ _ ks = \_ -> showChar '(' . foldl1 (\a b -> a . showString "," . b) ks . showChar ')'++doUnboxed :: Show a => p -> TypeTuple -> ConstrTuple -> a -> S1Result+doUnboxed _p _ti _ci a _prec s = show a <> s++doRecursion :: (Generic a, DoM1 Proxy (Rep a)) => p -> TypeTuple -> ConstrTuple -> a -> S1Result+doRecursion _p _ti _ci a = flip gshowsPrec a++-- Rec1 marks a field (S1) which is itself a record+doRec1 :: (Generic1 f, DoM1 Identity (Rep1 f)) => forall a. Rd a -> TypeTuple -> ConstrTuple -> f a -> S1Result+doRec1 sp _ti _ci r = flip (uncurry gLiftShowsPrec sp) r++-- Par1 marks a field (S1) which is just a type parameter+doPar1 :: Rd a -> TypeTuple -> ConstrTuple -> a -> S1Result+doPar1 (op1', _) _ti _ci a = flip op1' a++-- Comp1 is the marks a field (S1) of type (:.:), composition+doComp1 :: (Show1 f, DoS1 p g) => p (Rd a) -> TypeTuple -> ConstrTuple -> f (g a) -> S1Result+doComp1 p ti ci c = flip (liftShowsPrec (flip (doS1 p ti ci)) (showListWith (flip (doS1 p ti ci) 0))) c++-- Handle the unnamed fields of a constructor (C1)+doNormal :: TypeTuple -> ConstrTuple -> [(Int, S1Result)] -> C1Result+doNormal _ (_, name, Infix _ fy) (k1 : k2 : ks) = foldl' showApp (showInfix name fy (snd k1) (snd k2)) (fmap snd ks)+doNormal _ (_, name, Infix _ _) ks =              foldl' showApp (showCon ("(" ++ name ++ ")")) (fmap snd ks)+doNormal _ (_, name, Prefix) ks =                   foldl' showApp (showCon         name        ) (fmap snd ks)++-- Handle the named fields of a constructor (C1)+doRecord :: TypeTuple -> ConstrTuple -> [(Int, (String, S1Result))] -> C1Result+doRecord _ (_, cname, _) [] = showRecord cname noFields+-- Do not render the Top type, it is private to this module and is+-- only used to get the recursion to work.+doRecord ("Top", "Extra.Generics.Show", _, _) _ [(_, (_, r))] = r+doRecord _ (_, cname, Prefix) ks = showRecord cname (foldl1 Show.appendFields (fmap (uncurry showField) (fmap snd ks)))+doRecord _ (_, cname, Infix _ _) ks = showRecord ("(" ++ cname ++ ")") (foldl1 Show.appendFields (fmap (uncurry showField) (fmap snd ks)))++---------------------------------------------------++-- | Generic representation of 'Show' types.+type GShow0 = DoM1 Proxy++newtype Top a = Top {unTop :: a} deriving Generic+infixr 0 `Top`++-- | Generic 'showsPrec'.+--+-- @+-- instance 'Show' MyType where+--   'showsPrec' = 'gshowsPrec'+-- @+gprecShows :: forall a. GShow a => a -> PrecShowS+gprecShows = doM1 (Proxy :: Proxy (Rd a)) . from++gshowsPrec :: GShow a => Int -> a -> ShowS+gshowsPrec = flip gprecShows++-- | Generic representation of 'Data.Functor.Classes.Show1' types.+-- class Show1 (f :: * -> *) where+--   liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS+--   liftShowsList :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS+type GShow1 = DoM1 Identity++gLiftPrecShows ::+  (GShow1 f)+  => (Int -> a -> ShowS)+  -> ([a] -> ShowS)+  -> f a -> PrecShowS+gLiftPrecShows = curry (doM1 . Identity)++-- | Generic 'liftShowsPrec'.+gLiftShowsPrec ::+  (Generic1 f, GShow1 (Rep1 f))+  => (Int -> a -> ShowS)+  -> ([a] -> ShowS)+  -> Int+  -> f a -> ShowS+gLiftShowsPrec op1' op2' =+  flip (gLiftPrecShows op1' op2' . from1)++type GShow a = (Generic a, GShow0 (Rep a))++gshow :: GShow a => a -> String+gshow x = gshows x ""+gshows :: GShow a => a -> ShowS+gshows = gshowsPrec 0++#if 0+class MyShow a where+  myshows :: a -> ShowS+  default myshows :: (Generic a, GShow (Rep a)) => a -> ShowS+  myshows a = gshows (Top a)+  myshow :: a -> String+  default myshow :: (Generic a, GShow (Rep a)) => a -> String+  myshow a = gshow+#else+myshow :: (DoS1 Proxy (K1 R a)) => a -> String+myshow a = gshow (Top a)++myshows :: (DoS1 Proxy (K1 R a)) => a -> ShowS+myshows a = gshows (Top a)+#endif++#if !__GHCJS__+data Foo = Foo {n :: Int, ch :: Char} deriving (Generic, Show)+data Bar = Bar [Foo] String deriving (Generic, Show)+data Rose a = Fork a [Rose a] deriving (Generic, Show)+data Tree a = Leaf a | Node (Tree a) (Tree a) deriving (Generic, Show)+data WithInt a = WithInt Int a deriving (Generic, Show)++_tests :: IO ()+_tests = do+  r@Counts{..} <-+    runTestTT+      (TestList+       [ TestCase (assertEqual "T1" "Foo {n = 1, ch = 'x'}" (myshow (Foo 1 'x')))+       , TestCase (assertEqual "T2" "Bar [Foo {n = 1, ch = 'x'}] \"hello\"" (myshow (Bar [Foo 1 'x'] "hello")))+       , TestCase (assertEqual "T3" "Fork 'a' [Fork 'b' []]" (myshow (Fork 'a' [Fork 'b' []])))+       , TestCase (assertEqual "T4" "Node (Leaf 'a') (Node (Leaf 'b') (Leaf 'c'))" (myshow (Node (Leaf 'a') (Node (Leaf 'b') (Leaf 'c')))))+       , TestCase (assertEqual "T5" "WithInt 5 (WithInt 2 'a')" (myshow (WithInt 5 (WithInt 2 'a'))))+       , let (expected, loc) = $(lift =<< (\x -> (show x, x)) <$> location) in+           TestCase (assertEqual "T6" expected (myshow loc))+       , TestCase (assertEqual "T7" "[1,2,3]" (myshow ([1,2,3] :: [Int])))+       , TestCase (assertEqual "T8" "[1]" (myshow ([1] :: [Int])))+       , TestCase (assertEqual "T9" "1" (myshow (1 :: Int)))+       , TestCase (assertEqual "T10" "('x',2,\"abc\")" (myshow ('x',(2 :: Int),("abc" :: String))))+       ])+  case (errors, failures) of+    (0, 0) -> return ()+    _ -> error (show r)+#endif
Extra/HughesPJ.hs view
@@ -2,7 +2,7 @@  import Data.Maybe import Extra.Terminal-import Text.PrettyPrint.HughesPJ+import Text.PrettyPrint  -- |render a Doc using the current terminal width renderWidth :: Doc -> IO String
Extra/IO.hs view
@@ -1,20 +1,113 @@-module Extra.IO {-# DEPRECATED "CIO is deprecated" #-} where+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS -Wall #-} -import Extra.CIO-import qualified System.IO as IO-import Control.Exception (try)+module Extra.IO+    ( -- * IO functions to write files and notice when they change.+      testAndWriteDotNew+    , testAndWriteBackup+    , testAndWriteFile+    , testAndWrite+    , writeFileWithBackup+    , findHaskellFiles+    , timeComputation+    ) where --- |Use this module to call functions in the CIO module from the--- regular IO monad.  This instance ignores all style and state--- information.  The verbosity controlled output functions will ignore--- any calls when v is greater than zero.  This allows you to call the--- functions in the haskell-debian package from the regular IO monad.--- --- This is in a separate module from CIO so you don't accidentally do--- a liftIO of some other CIO operation and get this instance.-instance CIO IO where-    hPutStr h s = IO.hPutStr h s-    hBOL h = IO.hPutStr h "\n"-    ev v = return (- v)-    setStyle _ f = f-    tryCIO = try+import Control.Exception as E (IOException, throw, try)+import Control.Monad (when)+import Control.Monad.Trans (liftIO, MonadIO)+import Data.Monoid ((<>))+import Data.Text as Text (length, take, Text)+import Data.Text.IO as Text (readFile, writeFile)+import Data.Time (getCurrentTime, diffUTCTime, getCurrentTime, NominalDiffTime)+import Extra.Log (alog)+import Extra.Text (diffText)+import System.Directory (getCurrentDirectory, removeFile, renameFile)+import System.FilePath.Find as Find+    ((==?), (&&?), always, extension, fileType, FileType(RegularFile), find)+import System.IO.Error (isDoesNotExistError)+import System.Log.Logger ({-logM,-} Priority(DEBUG, ERROR))++testAndWriteDotNew :: FilePath -> Text -> IO ()+testAndWriteDotNew dest new = testAndWrite writeDotNew dest new++testAndWriteBackup :: FilePath -> Text -> IO ()+testAndWriteBackup dest new = testAndWrite (\dest' _ new' -> writeFileWithBackup dest' new') dest new++testAndWriteFile :: FilePath -> Text -> IO ()+testAndWriteFile = testAndWriteDotNew+{-# DEPRECATED testAndWriteFile "Use testAndWriteDotNew" #-}++-- | See if the new Paths code matches the old, if not write it to a+-- file with the suffix ".new" and throw an error so the new code can+-- be inspected and checked in.  If the new file does match, the+-- existing .new file is removed.+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 <> ")")+  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"+                  Text.writeFile dest new+                False -> do+                  alog "Extra.IO" ERROR ("testAndWriteFile " <> show dest <> " - IOException " ++ show e)+                  throw e)+           return++-- | Shorten a string to a maximum length by replacing its suffix with "..."+shorten :: Int -> Text -> Text+shorten n t | n <= 3 = Text.take n t -- no room for an ellipsis+shorten n t | Text.length t > n - 3 = Text.take (n - 3) t <> "..."+shorten _ t = t++-- | 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"))+  Text.writeFile (dest <> ".new") new+  error ("Generated " <> dest <> ".new does not match existing " <> dest <> ":\n" <>+         diffText (dest, old) (dest <> ".new", new) <>+         "\nIf these changes look reasonable move " <> dest <> ".new to " <> dest <> " and retry.")+++-- | Rename existing file with suffix "~" and write a new file+writeFileWithBackup :: FilePath -> Text -> IO ()+writeFileWithBackup dest text = do+  removeFileMaybe (dest <> "~")+  renameFileMaybe dest (dest <> "~")+  removeFileMaybe dest+  Text.writeFile dest text++-- | Remove a file if it exists+removeFileMaybe :: FilePath -> IO ()+removeFileMaybe p =+    try (removeFile p) >>=+    either (\(e :: IOException) -> case isDoesNotExistError e of+                                     True -> pure ()+                                     False -> throw e) pure++-- | Rename a file if it exists+renameFileMaybe :: FilePath -> FilePath -> IO ()+renameFileMaybe oldpath newpath =+    try (renameFile oldpath newpath) >>=+    either (\(e :: IOException) -> case isDoesNotExistError e of+                                     True -> pure ()+                                     False -> throw e) pure++-- | Find all regular files with extension .hs+findHaskellFiles :: FilePath -> IO [FilePath]+findHaskellFiles dir = find always (Find.extension ==? ".hs" &&? fileType ==? RegularFile) dir++-- | Perform an IO operation and return the elapsed time along with the result.+timeComputation :: MonadIO m => m r -> m (r, NominalDiffTime)+timeComputation a = do+  !start <- liftIO getCurrentTime+  !r <- a+  !end <- liftIO getCurrentTime+  return (r, diffUTCTime end start)
Extra/IOThread.hs view
@@ -21,9 +21,9 @@        tid <- forkIO $ ioThread f c        return (tid, IOThread c)     where-      ioThread f c =+      ioThread f' c =           forever $ do (a, mvar) <- readChan c-                       b <- try $ f a+                       b <- try $ f' a                        putMVar mvar b  -- |issue a request to the IO thread and get back the result
Extra/List.hs view
@@ -43,13 +43,13 @@ cartesianProduct [xs] = map (: []) xs cartesianProduct (xs : yss) =     distribute xs (cartesianProduct yss)-    where distribute xs yss = concat (map (\ x -> map (x :) yss) xs)+    where distribute xs' yss' = concat (map (\ x -> map (x :) yss') xs')  -- |FIXME: implement for a string wordsBy :: Eq a => (a -> Bool) -> [a] -> [[a]] wordsBy p s =      case (break p s) of-      (s, []) -> [s]+      (s', []) -> [s']       (h, t) -> h : wordsBy p (drop 1 t)  -- |Like maybe, but with empty vs. non-empty list@@ -61,18 +61,18 @@ -- over f.  This is like "sortBy (\ a b -> compare (f a) (f b))" -- except that f is applied O(n) times instead of O(n log n) sortByMapped :: (a -> b) -> (b -> b -> Ordering) -> [a] -> [a]-sortByMapped f compare list =+sortByMapped f cmp list =     map fst sorted     where-      sorted = sortBy (\ (_, x) (_, y) -> compare x y) pairs+      sorted = sortBy (\ (_, x) (_, y) -> cmp x y) pairs       pairs = zip list (map f list)  -- |Monadic version of sortByMapped sortByMappedM :: (a -> IO b) -> (b -> b -> Ordering) -> [a] -> IO [a]-sortByMappedM f compare list =+sortByMappedM f cmp list =     do       pairs <- mapM f list >>= return . (zip list)-      let sorted = sortBy (\ (_, x) (_, y) -> compare x y) pairs+      let sorted = sortBy (\ (_, x) (_, y) -> cmp x y) pairs       return (map fst sorted)  partitionM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a])
Extra/Lock.hs view
@@ -6,10 +6,9 @@  import Control.Exception import Control.Monad.RWS-import Prelude hiding (catch) import System.Directory import System.IO-import System.IO.Error hiding (try, catch)+import System.IO.Error import System.Posix.Files import System.Posix.IO import System.Posix.Unistd@@ -48,9 +47,10 @@ -- |Like withLock, but instead of giving up immediately, try n times -- with a wait between each. --awaitLock :: (MonadIO m) => Int -> Int -> FilePath -> m a -> m (Either Exception a)+awaitLock :: (Ord a, Num a) => a -> Int -> [Char] -> IO a -> IO a awaitLock tries usecs path task =     attempt 0-    where +    where       attempt n | n >= tries = error "awaitLock: too many failures"       attempt n = withLock path task `catch` checkLockError           where@@ -60,4 +60,5 @@ processID :: IO String processID = readSymbolicLink "/proc/self" +lockedBy :: String -> FilePath -> IOError lockedBy pid path = mkIOError alreadyInUseErrorType ("Locked by " ++ pid) Nothing (Just path)
+ Extra/Log.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -Wall #-}++module Extra.Log+  ( alog+  , Priority(..)+  , logException+  ) 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)+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 System.Log.Logger (Priority(..), logM)++alog :: MonadIO m => String -> Priority -> String -> m ()+alog modul priority msg = liftIO $ do+  time <- getCurrentTime+  logM modul priority $ unwords [formatTimeCombined time, 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"++-- | 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.+logException :: ExpQ+logException =+    [| \priority action ->+         action `catchError` (\e -> do+                                liftIO (logM (loc_module $__LOC__)+                                             priority+                                             ("Logging exception: " <> (pprint $__LOC__) <> " -> " ++ show e))+                                throwError e) |]++__LOC__ :: Q Exp+__LOC__ = TH.lift =<< location
Extra/Misc.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Extra.Misc     (     -- * String functions@@ -7,40 +9,38 @@     , mapSnd     -- * FilePath functions     , parentPath-    , canon+    -- , canon     -- * Map and Set functions     , listMap     , listDiff     -- * System.Posix-    , checkSuperUser     , md5sum-    , sameInode     , sameMd5sum-    , tarDir-    -- * Processes-    -- , splitOutput-    -- * ByteString-    , cd-    -- * Debugging     , read'+#if !__GHCJS__+    , sameInode+    , cd+    , checkSuperUser+    , tarDir+#endif     ) where -import		 Control.Exception import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Digest.Pure.MD5-import		 Data.List+import           Data.List import qualified Data.Map as Map-import		 Data.Maybe+import           Data.Maybe import qualified Data.Set as Set-import		 Extra.List+import           System.FilePath+#if !__GHCJS__+import           Control.Exception+import           Extra.List (wordsBy)+import           System.Directory import           System.Exit-import		 System.FilePath-import		 System.Directory-import		 System.Posix.Files-import		 System.Posix.User (getEffectiveUserID)+import           System.Posix.Files+import           System.Posix.User (getEffectiveUserID) import           System.Process (readProcessWithExitCode)--- import System.Process.Progress (keepStdout, keepStderr, keepResult)-import		 Text.Regex+#endif  mapSnd :: (b -> c) -> (a, b) -> (a, c) mapSnd f (a, b) = (a, f b)@@ -62,10 +62,10 @@ justify s n =     foldr doWord [[]] (words s)     where doWord w [] = [[w]]-	  doWord w (ws : etc) = -	      if length (concat (intersperse " " (w:ws))) <= n then-		 (w : ws) : etc else-		 [w] : ws : etc+          doWord w (ws : etc) =+              if length (concat (intersperse " " (w:ws))) <= n then+                 (w : ws) : etc else+                 [w] : ws : etc  -- |dirname parentPath :: FilePath -> FilePath@@ -82,6 +82,7 @@ listDiff :: Ord a => [a] -> [a] -> [a] listDiff a b = Set.toList (Set.difference (Set.fromList a) (Set.fromList b)) +#if 0 -- | Weak attempt at canonicalizing a file path. canon :: FilePath -> FilePath canon path =@@ -95,12 +96,14 @@       merge (x : "." : xs) = (merge (x : xs))       merge (x : xs) = x : merge xs       merge [] = []+#endif  {-# DEPRECATED md5sum "Use Data.ByteString.Lazy.Char8.readFile path >>= return . show . Data.Digest.Pure.MD5.md5" #-} -- | Run md5sum on a file and return the resulting checksum as text. md5sum :: FilePath -> IO String md5sum path = B.readFile path >>= return . show . Data.Digest.Pure.MD5.md5 +#if !__GHCJS__ -- | Predicate to decide if two files have the same inode. sameInode :: FilePath -> FilePath -> IO Bool sameInode a b =@@ -108,6 +111,7 @@       aStatus <- getFileStatus a       bStatus <- getFileStatus b       return (deviceID aStatus == deviceID bStatus && fileID aStatus == fileID bStatus)+#endif  -- | Predicate to decide if two files have the same md5 checksum. sameMd5sum :: FilePath -> FilePath -> IO Bool@@ -123,11 +127,13 @@ -}  -- |A version of read with a more helpful error message.+read' :: Read p => String -> p read' s =     case reads s of       [] -> error $ "read - no parse: " ++ show s       ((x, _s) : _) -> x +#if !__GHCJS__ checkSuperUser :: IO Bool checkSuperUser = getEffectiveUserID >>= return . (== 0) @@ -146,10 +152,11 @@                          (s : _) -> Just s  cd :: FilePath -> IO a -> IO a-cd name m = -    bracket +cd name m =+    bracket         (do cwd <- getCurrentDirectory             setCurrentDirectory name             return cwd)         (\oldwd -> do setCurrentDirectory oldwd)         (const m)+#endif
+ Extra/Monad/Supply.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | Support for computations which consume values from a (possibly infinite)+-- supply. See <http://www.haskell.org/haskellwiki/New_monads/MonadSupply> for+-- details.+module Extra.Monad.Supply+( MonadSupply (..)+, SupplyT+, Supply+, evalSupplyT+, evalSupply+, runSupplyT+, runSupply+, supplies+) where++import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.RWS+import Control.Monad.State+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.Morph (MFunctor(..))+import qualified Data.Semigroup as Sem++class Monad m => MonadSupply s m | m -> s where+  supply :: m s+  peek :: m s+  exhausted :: m Bool++-- | Supply monad transformer.+newtype SupplyT s m a = SupplyT (StateT [s] m a)+  deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadFix)++instance MonadError e m => MonadError e (SupplyT s m) where+  throwError = SupplyT . lift . throwError+  catchError (SupplyT action) handler = SupplyT (action `catchError` (\e -> (\(SupplyT m) -> m) $ handler e))++-- | Supply monad.+newtype Supply s a = Supply (SupplyT s Identity a)+  deriving (Functor, Applicative, Monad, MonadSupply s)+++instance Monad m => MonadSupply s (SupplyT s m) where+  supply = SupplyT $ do ~(x:xs) <- get+                        put xs+                        return x+  peek = SupplyT $ gets head+  exhausted = SupplyT $ gets null++-- Monad transformer instances+instance (MonadSupply s m) => MonadSupply s (ExceptT e m) where+  supply = lift supply+  peek = lift peek+  exhausted = lift exhausted++instance MonadSupply s m => MonadSupply s (StateT st m) where+  supply = lift supply+  peek = lift peek+  exhausted = lift exhausted++instance MonadSupply s m => MonadSupply s (ReaderT r m) where+  supply = lift supply+  peek = lift peek+  exhausted = lift exhausted++instance (Monoid w, MonadSupply s m) => MonadSupply s (WriterT w m) where+  supply = lift supply+  peek = lift peek+  exhausted = lift exhausted++instance (MonadSupply s m, Monoid w) => MonadSupply s (RWST r w st m) where+  supply = lift supply+  peek = lift peek+  exhausted = lift exhausted++instance MFunctor (SupplyT a) where+  hoist f (SupplyT s) = SupplyT (hoist f s)++-- | Monoid instance for the supply monad. Actually any monad/monoid pair+-- gives rise to this monoid instance, but we can't write its type like that+-- because it would conflict with existing instances provided by Data.Monoid.+--instance (Monoid a, Monad m) => Monoid (m a) where+instance Sem.Semigroup a => Sem.Semigroup (Supply s a) where+  m1 <> m2 = do+    x1 <- m1+    x2 <- m2+    return (x1 Sem.<> x2)++instance (Monoid a) => Monoid (Supply s a) where+  mempty = return mempty+  mappend = (<>)++-- | Get n supplies.+supplies :: MonadSupply s m => Int -> m [s]+supplies n = replicateM n supply++evalSupplyT :: Monad m => SupplyT s m a -> [s] -> m a+evalSupplyT (SupplyT s) = evalStateT s++evalSupply :: Supply s a -> [s] -> a+evalSupply (Supply s) = runIdentity . evalSupplyT s++runSupplyT :: SupplyT s m a -> [s] -> m (a,[s])+runSupplyT (SupplyT s) = runStateT s++runSupply :: Supply s a -> [s] -> (a,[s])+runSupply (Supply s) = runIdentity . runSupplyT s
Extra/Net.hs view
@@ -1,7 +1,8 @@-module Extra.Net-    ( webServerDirectoryContents-    ) where+{-# LANGUAGE CPP #-} +module Extra.Net where++#if 0 import qualified Data.ByteString.Lazy.Char8 as L import		 Data.Maybe import		 Text.Regex@@ -18,3 +19,4 @@       re = mkRegex "( <A HREF|<a href)=\"([^/][^\"]*)/\""       second (Just [_, b]) = Just b       second _ = Nothing+#endif
+ Extra/Orphans.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -Wno-orphans #-}++module Extra.Orphans where++import Data.Graph.Inductive as G+import Data.List (intercalate)+import Data.Proxy (Proxy(Proxy))+import Data.SafeCopy (base, contain,+                      SafeCopy(errorTypeName, getCopy, kind, putCopy, version))+import Data.Serialize.Get (label)+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.UserId (UserId(..))+import Data.UUID.Orphans ()+import Data.UUID (UUID)+import Data.UUID.V4 as UUID (nextRandom)+import Data.UUID.Orphans ({-instance SafeCopy UUID-})+import Extra.Orphans2 ()+import GHC.Generics (Generic)+import Instances.TH.Lift ()+import Language.Haskell.TH (Ppr(ppr))+import Language.Haskell.TH.Lift -- (deriveLift, deriveLiftMany)+import Language.Haskell.TH.PprLib (ptext)+import Network.URI (URI(..), URIAuth(..), uriToString)+import System.IO.Unsafe (unsafePerformIO)+#if !__GHCJS__+import Test.QuickCheck (Arbitrary(arbitrary), choose, elements, Gen, listOf, listOf1, resize)+#endif++instance SafeCopy (Proxy t) where+      putCopy Proxy = contain (do { return () })+      getCopy = contain (label "Data.Proxy.Proxy:" (pure Proxy))+      version = 0+      kind = base+      errorTypeName _ = "Data.Proxy.Proxy"++#if 1+deriving instance Generic Day+deriving instance Generic UTCTime+#else+#endif++deriving instance Generic URIAuth++-- $(deriveLift ''UserId)+instance Lift UserId where lift (UserId x0) = [|UserId $(lift x0)|]++$(deriveLift ''G.Gr)+$(deriveLift ''G.NodeMap)++instance Ppr UserId where ppr = ptext . show++#if !__GHCJS__+instance Arbitrary T.Text where+    arbitrary = T.pack <$> arbitrary++instance Arbitrary LT.Text where+    arbitrary = LT.pack <$> arbitrary++instance Arbitrary UUID where+    arbitrary = pure (unsafePerformIO UUID.nextRandom)++instance Arbitrary UserId where+    arbitrary = UserId <$> choose (0, 20)++instance Arbitrary UTCTime where arbitrary = UTCTime <$> arbitrary <*> arbitrary+instance Arbitrary Day where arbitrary = ModifiedJulianDay <$> arbitrary+instance Arbitrary DiffTime where arbitrary = timeOfDayToTime <$> arbitrary+instance Arbitrary TimeOfDay where arbitrary = TimeOfDay <$> choose (0,23) <*> choose (0,59) <*> (fromInteger <$> choose (0,60999999999999))++-- from https://gist.github.com/roman++newtype URIPair+  = URIPair { fromPair :: (String, String) }+  deriving (Show)++genWord :: Gen String+genWord = listOf1 (choose ('a', 'z'))++genCanonicalURI :: Gen URI+genCanonicalURI =+    URI <$> elements ["http:", "https:"]+        <*> (Just <$> genURIAuthority)+        <*> (('/':) <$> genPaths)+        <*> pure ""+        <*> pure ""+  where+    genURIAuthority =+      URIAuth <$> pure ""+              <*> genRegName+              <*> pure ""+    genRegName = do+      domainName <- elements ["noomii", "google", "yahoo"]+      return $ mconcat ["www.", domainName, ".com"]+    genPaths = resize 10 (intercalate "/" <$> listOf genWord)++genNormalURI :: URI -> Gen URI+genNormalURI uri = do+    qs  <- genQueryString+    fragment <-  genFragment+    return $ uri { uriQuery = qs, uriFragment = fragment }+  where+    genParam = do+      name  <- genWord+      value <- genWord+      return $ name ++ "=" ++ value+    genQueryString = resize 10 $+      ('?':) <$> (intercalate "&" <$> listOf genParam)+    genFragment = ('#':) <$> genWord++instance Arbitrary URIPair where+    arbitrary = do+      canonical <- genCanonicalURI+      normal    <- genNormalURI canonical+      return (URIPair (uriToString id canonical "", uriToString id normal ""))++instance Arbitrary URI where+    arbitrary = genCanonicalURI >>= genNormalURI+#endif++instance SafeCopy URI where version = 0+instance SafeCopy URIAuth where version = 0++$(concat <$>+  sequence+  [ deriveLiftMany [''URI, ''URIAuth] ])
+ Extra/Orphans2.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -Wall -fno-warn-orphans #-}++module Extra.Orphans2 where++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.Map as Map (Map, toList)+import Data.SafeCopy (SafeCopy(..))+import Data.Set as Set (Set, toList)+#if !__GHCJS__+import Debug.Show (V(V))+#endif+import Language.Haskell.TH+import Language.Haskell.TH.PprLib (Doc, hcat, ptext, vcat)+import Language.Haskell.TH.Syntax (ModName, NameFlavour, OccName, PkgName)+import Prelude hiding (concat, foldl1)++instance Ppr (Type, Int32) where+  ppr (t, n) = pprPair (t, n)++instance Ppr Int32 where ppr = ptext . show++instance Ppr (Name, [Type]) where+    ppr (name, params) = ppr (foldl1 AppT (ConT name : params))++pprPair :: (Ppr a, Ppr b) => (a, b) -> Doc+pprPair (a, b) = hcat [ptext "(", ppr a, ptext ",", ppr b, ptext ")"]++pprList :: [Doc] -> Doc+pprList xs = hcat [ptext "[", hcat (intersperse (ptext ",") xs), ptext "]"]++-- deriving instance Data CmdSpec++#if 0+instance Arbitrary ReportImageID where arbitrary = ReportImageID <$> arbitrary+instance Arbitrary ReportElemID where arbitrary = ReportElemID <$> arbitrary+instance (Arbitrary v, Enum k, Ord k) => Arbitrary (Order k v) where+    arbitrary = sized $ \n -> do+      vs <- vectorOf n (arbitrary :: Gen v)+      ks <- shuffle (take n [toEnum 0..] :: [k])+      fromPairs <$> shuffle (zip ks vs)+#endif++instance Ppr Char where ppr = ptext . show+instance Ppr Float where ppr = ptext . show+-- instance Ppr ReportElemID where ppr = ptext . show+-- instance Ppr ReportImageID where ppr = ptext . show+instance (Ppr k, Ppr v) => Ppr (Map k v) where ppr = pprList . fmap pprPair . Map.toList+#if 0+instance (Ppr k, Ppr v) => Ppr (Order k v) where ppr = pprList . fmap pprPair . LL.toList . toPairs+#endif+instance Ppr (Int, Char) where ppr = ptext . show++instance Ppr Bool where+    ppr True = ptext "True"+    ppr False = ptext "False"++#if !__GHCJS__+instance Show (V TyCon) where+    show (V c) =+        "TyCon {" +++        "module=" ++ show (tyConModule c) +++        " name=" ++ show (tyConName c) +++        " package=" ++ show (tyConPackage c) +++        " fingerprint=" ++ show (tyConFingerprint c) ++ "}"++instance Show (V TypeRep) where+    show (V r) =+        case splitTyConApp r of+          (c, rs) -> "[" ++ intercalate "," (show (V c) : fmap (show . V) rs) ++ "]"+#endif++instance Ppr TypeRep where+  ppr = ptext . show++instance Ppr () where+    ppr () = ptext "()"++-- | 'Int' is the 'Data.Path.Index.ContainerKey' type for all lists, so+-- we need to make sure all the required instances exist.+instance Ppr Int where+    ppr = ptext . show++instance Ppr (Set Type, Set Type) where+    ppr (extra, missing) = vcat [ptext "extra:", ppr extra, ptext "missing:", ppr missing]++instance Ppr (Set Type) where+    ppr s = hcat [ptext "Set.fromList [", ppr (Set.toList s), ptext "]"]++instance SafeCopy OccName where version = 0+instance SafeCopy NameSpace where version = 0+instance SafeCopy PkgName where version = 0+instance SafeCopy ModName where version = 0+instance SafeCopy NameFlavour where version = 0+instance SafeCopy Name where version = 0+instance SafeCopy Loc where version = 1
+ Extra/Orphans3.hs view
@@ -0,0 +1,247 @@+-- | Serialize and SafeCopy instances for the template haskell Exp type.+-- Some Arbitrary, Lift, and Ppr instances.++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -Wall -Wredundant-constraints -Wno-orphans #-}++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.Proxy (Proxy(Proxy))+import Data.SafeCopy (SafeCopy(..))+import Extra.Serialize (Serialize)+import Extra.Orphans ()+import Language.Haskell.TH+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.PprLib (Doc, hcat, ptext)+import Language.Haskell.TH.Syntax+import Prelude hiding (concat, foldl1)+#if !__GHCJS__+import Network.URI+import Test.QuickCheck (Arbitrary(arbitrary), elements, Gen, oneof)+#endif++pprPair :: (Ppr a, Ppr b) => (a, b) -> Doc+pprPair (a, b) = hcat [ptext "(", ppr a, ptext ",", ppr b, ptext ")"]++pprList :: [Doc] -> Doc+pprList xs = hcat [ptext "[", hcat (intersperse (ptext ",") xs), ptext "]"]++#if 0+instance (Ppr k, Ord k, Enum k, Show k, Ppr v) => Ppr (Order k v) where+  ppr = pprList . toList . fmap pprPair . toPairs+#endif++#if __GLASGOW_HASKELL__ >= 802+instance Data TypeRep where+  toConstr _   = error "toConstr"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "Data.Typeable.TypeRep"+#endif++deriving instance Serialize (Proxy a)++#if !__GHCJS__+instance Lift (Proxy a) where lift Proxy = [|Proxy|]++instance Arbitrary NameSpace where+    arbitrary = elements [VarName, DataName, TcClsName]++instance Arbitrary Type where+    arbitrary = oneof [ ForallT <$> arbitrary <*> arbitrary <*> arbitrary+                      , AppT <$> arbitrary <*> arbitrary+                      , SigT <$> arbitrary <*> arbitrary+                      , VarT <$> arbitraryTypeVariableName+                      , ConT <$> arbitrary+                      , PromotedT <$> arbitrary+                      , TupleT <$> arbitrary+                      , UnboxedTupleT <$> arbitrary+                      , pure ArrowT+                      , pure EqualityT+                      , pure ListT+                      , PromotedTupleT <$> arbitrary+                      , pure PromotedNilT+                      , pure PromotedConsT+                      , pure StarT+                      , pure ConstraintT+                      , LitT <$> arbitrary ]++instance Arbitrary (Proxy a) where arbitrary = elements [Proxy]+instance Arbitrary Name where arbitrary = pure (mkName "aName")+instance Arbitrary TyLit where arbitrary = oneof [NumTyLit <$> arbitrary, StrTyLit <$> arbitraryConstructorName]+instance Arbitrary TyVarBndr where arbitrary = oneof [PlainTV <$> arbitraryTypeVariableName, KindedTV <$> arbitraryTypeVariableName <*> arbitraryKind]++instance Arbitrary URIAuth where+    arbitrary =+      URIAuth <$> pure ""+              <*> genRegName+              <*> pure ""+        where+          genRegName = do+            domainName <- elements ["noomii", "google", "yahoo"]+            return $ concat ["www.", domainName, ".com"]++arbitraryKind :: Gen Kind+arbitraryKind = oneof [pure StarT {-, finish me -}]++arbitraryConstructorName :: Gen String+arbitraryConstructorName = pure "AConstructor"++arbitraryTypeVariableName :: Gen Name+arbitraryTypeVariableName = pure (mkName "aTyVarName")++-- s = $(location >>= \Loc{loc_module=m, loc_start=(sl,sc), loc_end=(el,ec)} -> lift (m <> ":" <> show sl))+#endif++deriving instance Serialize AnnTarget+deriving instance Serialize Bang+deriving instance Serialize Body+deriving instance Serialize Callconv+deriving instance Serialize Clause+deriving instance Serialize Con+deriving instance Serialize Dec+deriving instance Serialize DerivClause+deriving instance Serialize DerivStrategy+deriving instance Serialize Exp+deriving instance Serialize FamilyResultSig+deriving instance Serialize Fixity+deriving instance Serialize FixityDirection+deriving instance Serialize Foreign+deriving instance Serialize FunDep+deriving instance Serialize Guard+deriving instance Serialize InjectivityAnn+deriving instance Serialize Inline+deriving instance Serialize Lit+deriving instance Serialize Match+deriving instance Serialize ModName+deriving instance Serialize Name+deriving instance Serialize NameFlavour+deriving instance Serialize NameSpace+deriving instance Serialize OccName+deriving instance Serialize Overlap+deriving instance Serialize Pat+deriving instance Serialize PatSynArgs+deriving instance Serialize PatSynDir+deriving instance Serialize Phases+deriving instance Serialize PkgName+deriving instance Serialize Pragma+deriving instance Serialize Range+deriving instance Serialize Role+deriving instance Serialize RuleBndr+deriving instance Serialize RuleMatch+deriving instance Serialize Safety+deriving instance Serialize SourceStrictness+deriving instance Serialize SourceUnpackedness+deriving instance Serialize Stmt+deriving instance Serialize TyLit+deriving instance Serialize Type+deriving instance Serialize TypeFamilyHead+deriving instance Serialize TySynEqn+deriving instance Serialize TyVarBndr++#if 0+deriving instance NFData AnnTarget+deriving instance NFData Bang+deriving instance NFData Body+deriving instance NFData Callconv+deriving instance NFData Clause+deriving instance NFData Con+deriving instance NFData Dec+deriving instance NFData DerivClause+deriving instance NFData DerivStrategy+deriving instance NFData Exp+deriving instance NFData FamilyResultSig+deriving instance NFData Fixity+deriving instance NFData FixityDirection+deriving instance NFData Foreign+deriving instance NFData FunDep+deriving instance NFData Guard+deriving instance NFData InjectivityAnn+deriving instance NFData Inline+deriving instance NFData Lit+deriving instance NFData Match+deriving instance NFData ModName+deriving instance NFData Name+deriving instance NFData NameFlavour+deriving instance NFData NameSpace+deriving instance NFData OccName+deriving instance NFData Overlap+deriving instance NFData Pat+deriving instance NFData PatSynArgs+deriving instance NFData PatSynDir+deriving instance NFData Phases+deriving instance NFData PkgName+deriving instance NFData Pragma+deriving instance NFData Range+deriving instance NFData Role+deriving instance NFData RuleBndr+deriving instance NFData RuleMatch+deriving instance NFData Safety+deriving instance NFData TH.SourceStrictness+deriving instance NFData TH.SourceUnpackedness+deriving instance NFData Stmt+deriving instance NFData TyLit+deriving instance NFData Type+deriving instance NFData TypeFamilyHead+deriving instance NFData TySynEqn+deriving instance NFData TyVarBndr+#endif++instance SafeCopy AnnTarget where version = 1+instance SafeCopy Bang where version = 1+instance SafeCopy Body where version = 1+instance SafeCopy Callconv where version = 1+instance SafeCopy Clause where version = 1+instance SafeCopy Con where version = 1+instance SafeCopy Dec where version = 1+instance SafeCopy DerivClause where version = 1+instance SafeCopy DerivStrategy where version = 1+instance SafeCopy Exp where version = 1+instance SafeCopy FamilyResultSig where version = 1+instance SafeCopy Fixity where version = 1+instance SafeCopy FixityDirection where version = 1+instance SafeCopy Foreign where version = 1+instance SafeCopy FunDep where version = 1+instance SafeCopy Guard where version = 1+instance SafeCopy InjectivityAnn where version = 1+instance SafeCopy Inline where version = 1+instance SafeCopy Lit where version = 1+instance SafeCopy Match where version = 1+-- instance SafeCopy ModName where version = 1+-- instance SafeCopy Name where version = 1+-- instance SafeCopy NameFlavour where version = 1+-- instance SafeCopy NameSpace where version = 1+-- instance SafeCopy OccName where version = 1+instance SafeCopy Overlap where version = 1+instance SafeCopy Pat where version = 1+instance SafeCopy PatSynArgs where version = 1+instance SafeCopy PatSynDir where version = 1+instance SafeCopy Phases where version = 1+-- instance SafeCopy PkgName where version = 1+instance SafeCopy Pragma where version = 1+instance SafeCopy Range where version = 1+instance SafeCopy Role where version = 1+instance SafeCopy RuleBndr where version = 1+instance SafeCopy RuleMatch where version = 1+instance SafeCopy Safety where version = 1+instance SafeCopy SourceStrictness where version = 1+instance SafeCopy SourceUnpackedness where version = 1+instance SafeCopy Stmt where version = 1+instance SafeCopy TyLit where version = 1+instance SafeCopy Type where version = 1+instance SafeCopy TypeFamilyHead where version = 1+instance SafeCopy TySynEqn where version = 1+instance SafeCopy TyVarBndr where version = 1
+ Extra/Pretty.hs view
@@ -0,0 +1,104 @@+-- | A constructor we can wrap around values to avoid any built in+-- Pretty instance - for example, instance Pretty [a].+--+--  * display is now prettyShow+--  * display' is now prettyText+--  * ppDisplay is now ppShow+--  * ppDisplay' is now ppText++{-# LANGUAGE DeriveFunctor, FlexibleContexts, FlexibleInstances, OverloadedStrings, TypeSynonymInstances #-}++module Extra.Pretty+    ( PP(PP, unPP)+    , prettyText+    , ppPrint+    , pprPair+    , pprSet+    , ppShow+    , ppText+    , pprint1, pprint1', render1+    , pprintW+    , friendlyNames+    -- * Re-export+    , prettyShow+    , renderW+    ) where++import Data.Data (Data)+import Data.Generics (everywhere, mkT)+import Data.Set as Set (Set, toList)+import Data.Text (Text, unpack, pack)+import Distribution.Pretty (Pretty(pretty), prettyShow)+import Language.Haskell.TH+import Language.Haskell.TH.PprLib as TH (Doc, hcat, hsep, ptext, to_HPJ_Doc)+import Language.Haskell.TH.Syntax+import qualified Text.PrettyPrint as HPJ+import Text.PrettyPrint.HughesPJClass as HPJ (Doc, text, empty)++-- | This type is wrapped around values before we pretty print them so+-- we can write our own Pretty instances for common types without+-- polluting the name space of clients of this package with instances+-- they don't want.+newtype PP a = PP {unPP :: a} deriving (Functor)++instance Pretty (PP Text) where+    pretty = text . unpack . unPP++instance Pretty (PP String) where+    pretty = text . unPP++instance Pretty (PP a) => Pretty (PP (Maybe a)) where+    pretty = maybe empty ppPrint . unPP++prettyText :: Pretty a => a -> Text+prettyText = pack . prettyShow++ppPrint :: Pretty (PP a) => a -> HPJ.Doc+ppPrint = pretty . PP++ppShow :: Pretty (PP a) => a -> String+ppShow = prettyShow . PP++ppText :: Pretty (PP a) => a -> Text+ppText = pack . prettyShow . PP++-- | Make a template haskell value more human reader friendly.  The+-- result may or may not be compilable.  That's ok, though, because+-- the input is usually uncompilable - it imports hidden modules, uses+-- infix operators in invalid positions, puts module qualifiers in+-- places where they are not allowed, and maybe other things.+friendlyNames :: Data a => a -> a+friendlyNames =+    everywhere (mkT friendlyName)+    where+      friendlyName (Name x _) = Name x NameS -- Remove all module qualifiers++-- | Render a 'Doc' on a single line.+render1 :: TH.Doc -> String+render1 = HPJ.renderStyle (HPJ.style {HPJ.mode = HPJ.OneLineMode}) . to_HPJ_Doc++-- | Render a 'Doc' with the given width.+renderW :: Int -> TH.Doc -> String+renderW w = HPJ.renderStyle (HPJ.style {HPJ.lineLength = w}) . to_HPJ_Doc++-- | Pretty print the result of 'render1'.+pprint1' :: Ppr a => a -> [Char]+pprint1' = render1 . ppr++-- | 'pprint1'' with friendlyNames.+pprint1 :: (Ppr a, Data a) => a -> [Char]+pprint1 = pprint1' . friendlyNames++-- | Pretty print the result of 'renderW'.+pprintW' :: Ppr a => Int -> a -> [Char]+pprintW' w = renderW w . ppr++-- | 'pprintW'' with friendly names.+pprintW :: (Ppr a, Data a) => Int -> a -> [Char]+pprintW w = pprintW' w . friendlyNames++pprPair :: (Ppr a, Ppr b) => (a, b) -> TH.Doc+pprPair (a, b) = hcat [ptext "(", ppr a, ptext ", ", ppr b, ptext ")"]++pprSet :: Ppr a => Set a -> TH.Doc+pprSet s = hcat [ptext "[", hsep (fmap ppr (Set.toList s)), ptext "]"]
+ Extra/Process.hs view
@@ -0,0 +1,325 @@+-- | Various redundant versions of shell command running code+-- collected here from several different places.++{-# LANGUAGE CPP, FlexibleContexts, RankNTypes, ScopedTypeVariables, TemplateHaskell, TypeFamilies #-}+{-# OPTIONS_GHC -Wall -Wredundant-constraints #-}+module Extra.Process+    ( CreateProcess+    , timeTask+    , RunOptions(..)+    -- * builders for RunOptions+    , showCommand+    , showCommandAndResult+    , putIndented+    -- * Simple process runners+    , run+    , runV, runVE+    , runQ, runQE+    , runIO+    , testExit+    , processException+    , insertProcessEnv+    , modifyProcessEnv+    , HasLoc(withLoc)+    -- * Refugees+    , runV2, runVE2, runQ2, runQE2+    , run2+    , runV3, runQE3+    ) where++import Control.Arrow (second)+import Control.Exception (evaluate, Exception, IOException, throw)+import Control.Lens (view)+import Control.Monad.Catch (catch, MonadCatch, try)+import Control.Monad.Except (throwError)+import Control.Monad.Reader (MonadReader)+import Control.Monad.State (evalState, StateT, get, put)+import Control.Monad.Trans (liftIO, MonadIO)+import qualified Data.ByteString.Lazy.Char8 as L+import Data.ListLike (break, head, hPutStr, null, singleton, tail)+import Data.Semigroup (Semigroup((<>)))+import Data.String (IsString(fromString))+import Data.Text (unpack)+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.EnvPath (HasEnvRoot(envRootLens), rootPath)+import Extra.Verbosity (ePutStrLn)+import Extra.TH (here, prettyLocs)+import GHC.IO.Exception (IOErrorType(OtherError))+import Language.Haskell.TH.Syntax (Loc)+import Prelude hiding (break, head, null, tail)+import System.Environment (getEnvironment)+import System.Exit (ExitCode(..))+import System.IO (hPutStrLn, stdout, stderr)+import System.IO.Error (mkIOError)+import System.Process (CreateProcess(cwd, env))+import System.Process.ListLike (Chunk(..), collectOutput, ListLikeProcessIO, readCreateProcessLazy, readCreateProcessWithExitCode, showCreateProcessForUser)++-- | Run a task and return the elapsed time along with its result.+timeTask :: MonadIO m => m a -> m (a, NominalDiffTime)+timeTask x =+    do start <- liftIO $ getCurrentTime+       result <- x >>= liftIO . evaluate+       finish <- liftIO $ getCurrentTime+       return (result, diffUTCTime finish start)++data RunOptions a m+    = StartMessage (String -> CreateProcess -> m ())+    | OverOutput ([Chunk a] -> m [Chunk a]) -- e.g. putIndented+    | FinishMessage (String -> CreateProcess -> (ExitCode, a, a) -> m ())+    -- | Verbosity Int+    | RunOptions [RunOptions a m]++instance Semigroup (RunOptions a m) where+    RunOptions a <> RunOptions b = RunOptions (a <> b)+    RunOptions a <> b = RunOptions (a <> [b])+    a <> RunOptions b = RunOptions ([a] <> b)+    a <> b = RunOptions [a, b]++showCommand :: MonadIO m => String -> CreateProcess -> m ()+showCommand prefix p = liftIO $ ePutStrLn (prefix ++ showCreateProcessForUser p)++showCommandAndResult :: MonadIO m => [Char] -> CreateProcess -> (ExitCode, a, a) -> m ()+showCommandAndResult prefix p (code, _, _) =+    liftIO $ ePutStrLn (prefix ++ showCreateProcessForUser p ++ " -> " ++ show code)++putIndented :: forall a c m. (Eq c, ListLikeProcessIO a c, IsString a, MonadIO m) => [Chunk a] -> m [Chunk a]+putIndented chunks =+    liftIO $ mapM_ echo (indentChunks "     1> " "     2> " chunks) >> return chunks+    where+      echo :: Chunk a -> IO (Chunk a)+      echo c@(Stdout x) = hPutStr stdout x >> return c+      echo c@(Stderr x) = hPutStr stderr x >> return c+      echo c = return c++run ::+    forall a c e m. (HasLoc e, MonadIO m, MonadError e m, ListLikeProcessIO a c)+    => RunOptions a m+    -> CreateProcess+    -> a+    -> 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+  finish " <- " p result+  return result+    where+      -- We need the options as a Foldable type+      opts' :: [RunOptions a m]+      opts' = case opts of RunOptions xs -> xs; x -> [x]+      start :: String -> CreateProcess -> m ()+      start = foldr (\o f -> case o of (StartMessage f') -> f'; _ -> f) (\_ _ -> pure ()) opts'+      finish :: String -> CreateProcess -> (ExitCode, a, a) -> m ()+      finish = foldr (\o f -> case o of (FinishMessage f') -> f'; _ -> f) (\_ _ _ -> pure ()) opts'+      overOutput :: [Chunk a] -> m [Chunk a]+      overOutput = foldr (\o f -> case o of (OverOutput f') -> f'; _ -> f) return opts'++--runVE :: (Eq c, IsString a, ListLikeProcessIO a c, MonadIO m, MonadCatch m) => CreateProcess -> a -> m (Either SomeException (ExitCode, a, a))+--runVE p input = try $ runV p input++runV ::+    (Eq c, IsString a, ListLikeProcessIO a c, HasLoc e, MonadIO m, MonadError e m)+    => CreateProcess -> a -> m (ExitCode, a, a)+runV p input = run (StartMessage showCommand <> OverOutput putIndented <> FinishMessage showCommandAndResult) p input++runVE ::+    (Eq c, IsString a, ListLikeProcessIO a c, MonadCatch m, HasLoc e, Exception e, MonadError e m, MonadIO m)+    => CreateProcess -> a -> m (Either e (ExitCode, a, a))+runVE p i = try $ runV p i++--runQE :: (ListLikeProcessIO a c, MonadIO m, MonadCatch m) => CreateProcess -> a -> m (Either SomeException (ExitCode, a, a))+--runQE p input = try $ runQ p input++runQ ::+    (ListLikeProcessIO a c, HasLoc e, MonadIO m, MonadError e m)+    => CreateProcess -> a -> m (ExitCode, a, a)+runQ p input = run (StartMessage showCommand <> FinishMessage showCommandAndResult) p input++runQE ::+    (ListLikeProcessIO a c, MonadCatch m, HasLoc e, MonadIO m, MonadError e m, Exception e)+    => CreateProcess -> a -> m (Either e (ExitCode, a, a))+runQE p i = try $ runQ p i++runIO :: CreateProcess -> IO L.ByteString+runIO cp = do+  (code, out, err) <- readCreateProcessWithExitCode cp L.empty+  case code of+    ExitSuccess -> return out+    ExitFailure _ -> throwError $ userError $ unlines $+                                       [ show code+                                       , " command: " ++ showCreateProcessForUser cp+                                       , " stderr: " ++ unpack (decodeUtf8 (L.toStrict err))+                                       , " stdout: " ++ unpack (decodeUtf8 (L.toStrict out)) ]++-- | Pure function to indent the text of a chunk list.+indentChunks :: forall a c. (ListLikeProcessIO a c, Eq c, IsString a) => String -> String -> [Chunk a] -> [Chunk a]+indentChunks outp errp chunks =+    evalState (Prelude.concat <$> mapM (indentChunk nl (fromString outp) (fromString errp)) chunks) BOL+    where+      nl :: c+      nl = Data.ListLike.head (fromString "\n" :: a)++-- | The monad state, are we at the beginning of a line or the middle?+data BOL = BOL | MOL deriving (Eq)++-- | Indent the text of a chunk with the prefixes given for stdout and+-- stderr.  The state monad keeps track of whether we are at the+-- beginning of a line - when we are and more text comes we insert one+-- of the prefixes.+indentChunk :: forall a c m. (Monad m, ListLikeProcessIO a c, Eq c) => c -> a -> a -> Chunk a -> StateT BOL m [Chunk a]+indentChunk nl outp errp chunk =+    case chunk of+      Stdout x -> doText Stdout outp x+      Stderr x -> doText Stderr errp x+      _ -> return [chunk]+    where+      doText :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]+      doText con pre x = do+        let (hd, tl) = break (== nl) x+        (<>) <$> doHead con pre hd <*> doTail con pre tl+      doHead :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]+      doHead _ _ x | null x = return []+      doHead con pre x = do+        bol <- get+        case bol of+          BOL -> put MOL >> return [con (pre <> x)]+          MOL -> return [con x]+      doTail :: (a -> Chunk a) -> a -> a -> StateT BOL m [Chunk a]+      doTail _ _ x | null x = return []+      doTail con pre x = do+        bol <- get+        put BOL+        tl <- doText con pre (tail x)+        return $ (if bol == BOL then [con pre] else []) <> [con (singleton nl)] <> tl++-- | Turn process exit codes into exceptions.+{-+throwProcessResult' :: (ExitCode -> Maybe IOError) -> CreateProcess -> [Chunk a] -> IO [Chunk a]+throwProcessResult' f p chunks = mapResultM (\ code -> maybe (return $ Result code) (throw $ processException p code) (f code)) chunks++-- | Turn process exit codes into exceptions with access to the+-- original CreateProcess record.+throwProcessResult'' :: Exception e => (CreateProcess -> ExitCode -> Maybe e) -> CreateProcess -> [Chunk a] -> IO [Chunk a]+throwProcessResult'' f p chunks = mapResultM (\ code -> maybe (return $ Result code) throw (f p code)) chunks++throwProcessFailure :: CreateProcess -> [Chunk a] -> IO [Chunk a]+throwProcessFailure p = throwProcessResult' (testExit Nothing (Just . processException p . ExitFailure)) p++mapResultM :: Monad m => (ExitCode -> m (Chunk a)) -> [Chunk a] -> m [Chunk a]+mapResultM f chunks = mapM (\ x -> case x of Result code -> f code; _ -> return x) chunks+-}++testExit :: a -> (Int -> a) -> ExitCode -> a+testExit s _ ExitSuccess = s+testExit _ f (ExitFailure n) = f n++-- | Copied from "System.Process", the exception thrown when the+-- process started by 'System.Process.readProcess' gets an+-- 'ExitFailure'.+processException :: CreateProcess -> ExitCode -> IOError+processException p code =+    mkIOError OtherError (showCreateProcessForUser p ++ maybe "" (\ d -> "(in " ++ show d ++ ")") (cwd p) ++ " -> " ++ show code) Nothing Nothing++-- | Set an environment variable in the CreateProcess, initializing it+-- with what is in the current environment.+insertProcessEnv :: [(String, String)] -> CreateProcess -> IO CreateProcess+insertProcessEnv pairs = modifyProcessEnv (map (second Just) pairs)++modEnv1 :: [(String, String)] -> (String, Maybe String) -> [(String, String)]+modEnv1 env0 (name, mvalue) = maybe [] (\ v -> [(name, v)]) mvalue ++ filter ((/= name) . fst) env0++modifyProcessEnv :: MonadIO m => [(String, Maybe String)] -> CreateProcess -> m CreateProcess+modifyProcessEnv pairs p = do+  env0 <- liftIO $ maybe getEnvironment return (env p)+  let env' = foldl modEnv1 env0 pairs+  return $ p {env = Just env'}++runV2 ::+    (MonadIO m, MonadCatch m, Eq c, IsString a, ListLikeProcessIO a c)+    => [Loc] -> CreateProcess -> a -> m (ExitCode, a, a)+runV2 locs p input =+    run2 locs (StartMessage (showCommand' locs) <> OverOutput putIndented <> FinishMessage showCommandAndResult) p input++runVE2 ::+    forall a c e m. (Eq c, IsString a, ListLikeProcessIO a c, MonadIO m, MonadCatch m, Exception e)+    => [Loc] -> CreateProcess -> a -> m (Either e (ExitCode, a, a))+runVE2 locs p input = do+    try (runV2 locs p input)++runQ2 ::+    (MonadIO m, MonadCatch m, ListLikeProcessIO a c)+    => [Loc] -> CreateProcess -> a -> m (ExitCode, a, a)+runQ2 locs p input =+    run2 locs (StartMessage (showCommand' locs) <> FinishMessage showCommandAndResult) p input++runQE2 ::+    (ListLikeProcessIO a c, MonadIO m, MonadCatch m, Exception e)+    => [Loc] -> CreateProcess -> a -> m (Either e (ExitCode, a, a))+runQE2 locs p input =+    try (runQ2 locs p input)++showCommand' :: MonadIO m => [Loc] -> String -> CreateProcess -> m ()+showCommand' locs prefix p = do+  -- key <- view osKey+  liftIO $ ePutStrLn (prefix ++ showCreateProcessForUser p ++ " (" ++ {-"in " ++ show key ++ ", " ++-} "called from " ++ show (prettyLocs ($here : locs)) ++ ")")++run2 ::+    forall a c m. (MonadIO m, ListLikeProcessIO a c, MonadCatch m)+    => [Loc]+    -> RunOptions a m+    -> CreateProcess+    -> a+    -> m (ExitCode, a, a)+run2 locs opts p input = do+  start " -> " p+  (result :: (ExitCode, a, a)) <- catch (liftIO (readCreateProcessLazy p input) >>= overOutput >>= return . collectOutput)+                                        (\se -> withException (\e -> liftIO (hPutStrLn stderr ("(at " ++ show (prettyLocs ($here : locs)) ++ ": " ++ show e ++ ") :: " ++ show (typeOf e)))) se >> throw se)+  finish " <- " p result+  liftIO $ evaluate result+    where+      -- We need the options as a Foldable type+      opts' :: [RunOptions a m]+      opts' = case opts of RunOptions xs -> xs; x -> [x]+      start :: String -> CreateProcess -> m ()+      start = foldr (\o f -> case o of (StartMessage f') -> f'; _ -> f) (\_ _ -> pure ()) opts'+      finish :: String -> CreateProcess -> (ExitCode, a, a) -> m ()+      finish = foldr (\o f -> case o of (FinishMessage f') -> f'; _ -> f) (\_ _ _ -> pure ()) opts'+      overOutput :: [Chunk a] -> m [Chunk a]+      overOutput = foldr (\o f -> case o of (OverOutput f') -> f'; _ -> f) return opts'++-- stray copies of the stuff above that I moved here, with MonadApt constraints++runV3 ::+    (Eq c, IsString a, ListLikeProcessIO a c, HasEnvRoot r, MonadReader r m, MonadIO m, MonadCatch m)+    => [Loc] -> CreateProcess -> a -> m (ExitCode, a, a)+runV3 locs p input =+    run2 locs (StartMessage showCommand3' <> OverOutput putIndented <> FinishMessage showCommandAndResult) p input++{-+runVE3 ::+    (Eq c, IsString a, ListLikeProcessIO a c, MonadApt r m, MonadError e m, MonadIO m, MonadCatch m)+    => [Loc] -> CreateProcess -> a -> m (Either IOException (ExitCode, a, a))+runVE3 locs p input = try $ runV3 locs p input+-}++runQ3 ::+    (ListLikeProcessIO a c, HasEnvRoot r, MonadReader r m, MonadIO m, MonadCatch m)+    => [Loc] -> CreateProcess -> a -> m (ExitCode, a, a)+runQ3 locs p input =+    run2 locs (StartMessage showCommand3' <> FinishMessage showCommandAndResult) p input++runQE3 ::+    (ListLikeProcessIO a c, HasEnvRoot r, MonadReader r m, MonadIO m, MonadCatch m)+    => [Loc] -> CreateProcess -> a -> m (Either IOException (ExitCode, a, a))+runQE3 locs p input = try $ runQ3 locs p input++showCommand3' :: (HasEnvRoot r, MonadReader r m, MonadIO m) => String -> CreateProcess -> m ()+showCommand3' prefix p = do+  key <- view (envRootLens . rootPath)+  liftIO $ ePutStrLn (prefix ++ showCreateProcessForUser p ++ " (in " ++ show key ++ ")")++-- | Modify a value (typically an exception) to include a source code+-- location: e.g. @withError (withLoc $here) $ tryError action@.+class HasLoc e where withLoc :: Loc -> e -> e
Extra/SSH.hs view
@@ -4,13 +4,12 @@     , sshCopy     ) where -import System.Cmd import System.Directory import System.Posix.User import System.Environment import System.Exit import System.IO-import System.Process (readProcessWithExitCode, showCommandForUser)+import System.Process (readProcessWithExitCode, showCommandForUser, system) -- |Set up access to destination (user\@host). sshExportDeprecated :: String -> Maybe Int -> IO (Either String ()) sshExportDeprecated dest port =@@ -42,12 +41,12 @@ -- |See if we already have access to the destination (user\@host). sshVerify :: String -> Maybe Int -> IO Bool sshVerify dest port =-    do result <- system (sshTestCmd dest port)+    do result <- system sshTestCmd        return $ case result of-                  ExitSuccess -> True		-- We do-                  ExitFailure _ -> False	-- We do not+                  ExitSuccess -> True           -- We do+                  ExitFailure _ -> False        -- We do not     where-      sshTestCmd dest port =+      sshTestCmd =           ("ssh -o 'PreferredAuthentications hostbased,publickey' " ++            (maybe "" (("-p " ++) . show) port) ++ " " ++ show dest ++ " pwd > /dev/null && exit 0") @@ -68,15 +67,15 @@        (code, out, err) <- readFile keypath >>= readProcessWithExitCode "ssh" args        case code of          ExitFailure n -> return . Left $ "Failure: " ++ showCommandForUser "ssh" args ++ " -> " ++ show n ++-	                                  "\n\nstdout: " ++ out ++ "\n\nstderr: " ++ err+                                          "\n\nstdout: " ++ out ++ "\n\nstderr: " ++ err          _ -> return . Right $ ()     where       sshOpenRemoteCmd =-          ("chmod g-w . && " ++				-- Ssh will not work if the permissions aren't just so+          ("chmod g-w . && " ++                         -- Ssh will not work if the permissions aren't just so            "chmod o-rwx . && " ++            "mkdir -p .ssh && " ++            "chmod 700 .ssh && " ++-           "cat >> .ssh/authorized_keys2 && " ++	-- Add the key to the authorized key list+           "cat >> .ssh/authorized_keys2 && " ++        -- Add the key to the authorized key list            "chmod 600 .ssh/authorized_keys2")  -- This used to be main.
+ Extra/SafeCopy.hs view
@@ -0,0 +1,104 @@+-- | 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.SafeCopy+    ( module Data.SafeCopy+    , DecodeError(..)+    , HasDecodeError(fromDecodeError)+    , decode+    , encode+    , 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.Serialize (DecodeError(..), HasDecodeError(..))+import Extra.Time (Zulu(..))+import Language.Haskell.TH (Dec, Loc, TypeQ, Q)+import Network.URI (URI(..), URIAuth(..))+import System.IO.Unsafe (unsafePerformIO)++encode :: SafeCopy a => a -> ByteString+encode = 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)++-- | Monadic version of decode.+decodeM ::+  forall a e m. (SafeCopy a, HasDecodeError e, MonadError e m)+  => ByteString+  -> m a+decodeM bs =+  case decode bs of+    Left s -> throwError (fromDecodeError (DecodeError bs 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, 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))+           Right a -> return a+    handle :: ErrorCall -> m a+    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs 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)++-- | Serialize/deserialize prism.+deserializePrism :: forall a. (SafeCopy 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) => Getter a ByteString+serializeGetter = re deserializePrism
+ Extra/SafeCopyDebug.hs view
@@ -0,0 +1,102 @@+-- | 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.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 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 s))+           Right a -> return a+    handle :: ErrorCall -> m a+    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs 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
@@ -0,0 +1,186 @@+-- | 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 DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module Extra.Serialize+    ( DecodeError(..)+    , HasDecodeError(fromDecodeError)+    , module Data.Serialize+    , decodePrism, deserializePrism+    , encodeGetter, serializeGetter+    , deriveSerializeViaSafeCopy+    , decode+    , Serialize.encode+    , 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))+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.Time (Zulu(..))+import GHC.Generics (Generic)+import Language.Haskell.TH (Dec, Loc, TypeQ, Q)+import Network.URI (URI(..), URIAuth(..))+import System.IO.Unsafe (unsafePerformIO)++data DecodeError = DecodeError ByteString String deriving (Generic, Eq, Ord)++class HasDecodeError e where fromDecodeError :: DecodeError -> e+instance HasDecodeError DecodeError where fromDecodeError = id+instance Serialize DecodeError where get = safeGet; put = safePut++encode :: Serialize a => a -> ByteString+encode = Serialize.encode++-- | 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.  Not sure if this is in use anywhere.+--+--   > Extra.Serialize.decode (encode 'x' <> encode 'y') :: Either String Char+--   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 =+  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)++-- | A Serialize instance based on safecopy.  This means that+-- migrations will be performed upon deserialization, which is handy+-- if the value is stored in the browser's local storage.  Thus, zero+-- downtime upgrades!+deriveSerializeViaSafeCopy :: TypeQ -> Q [Dec]+deriveSerializeViaSafeCopy typ =+    [d|instance {-SafeCopy $typ =>-} Serialize $typ where+          get = safeGet+          put = safePut|]++instance Serialize T.Text where+    put = put . TE.encodeUtf8+    get = TE.decodeUtf8 <$> get++instance Serialize LT.Text where+    put = put . TLE.encodeUtf8+    get = TLE.decodeUtf8 <$> get++-- | This is private, we can't create a Generic instance for it.+instance Serialize DiffTime where+    get = fromRational <$> get+    put = put . toRational++instance Serialize UTCTime where+    get = uncurry UTCTime <$> get+    put (UTCTime day time) = put (day, time)++instance Serialize Day where+    get = ModifiedJulianDay <$> get+    put = put . toModifiedJulianDay++-- deriving instance Generic UUID deriving instance Serialize UUID Use+-- the SafeCopy methods to implement Serialize.  This is a pretty neat+-- trick, it automatically does SafeCopy migration on any deserialize+-- of a type with this implementation.+instance Serialize UUID where+    get = safeGet+    put = safePut++deriving instance Serialize Loc+deriving instance Serialize URI+deriving instance Serialize URIAuth+deriving instance Serialize Zulu++-- | Monadic version of decode.+decodeM ::+  forall a e m. (Serialize a, HasDecodeError e, MonadError e m)+  => ByteString+  -> m a+decodeM bs =+  case decode bs of+    Left s -> throwError (fromDecodeError (DecodeError bs 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, 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))+           Right a -> return a+    handle :: ErrorCall -> m a+    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs s++-- | Version of decode that catches any thrown ErrorCall and modifies+-- its message.+decode' :: forall a. (Serialize 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) => 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++instance SafeCopy DecodeError where version = 1++#ifndef OMIT_DATA_INSTANCES+deriving instance Data DecodeError+#endif++#ifndef OMIT_SHOW_INSTANCES+deriving instance Show DecodeError+#endif
+ Extra/SerializeDebug.hs view
@@ -0,0 +1,109 @@+-- | 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 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 s))+           Right a -> return a+    handle :: ErrorCall -> m a+    handle (ErrorCall s) = throwError $ fromDecodeError $ DecodeError bs 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
+ Extra/TH.hs view
@@ -0,0 +1,93 @@+-- | Pretty print Loc info for stack traces++{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, TemplateHaskell #-}+{-# OPTIONS -Wall -Wno-orphans #-}++module Extra.TH+    ( here+    , Loc+    , noLoc+    , prettyLocs+    , addConstraints+    , addConstraint+    , removeConstraints+    ) where++import Control.Lens (_1, over)+import Data.Generics (everywhere, mkT)+import Data.List (intersperse, nub)+import Data.Map as Map (findWithDefault, fromList, fromListWith, lookup, Map, toList)+import Data.Maybe (mapMaybe)+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif+import Data.Tuple (swap)+import Extra.Generics (gFind)+import Language.Haskell.TH (appT, conT, Dec(InstanceD), ExpQ, Loc(..), location, Name, nameBase, newName, Q, Type(..), TypeQ, varT)+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.Lift (lift)+import Text.PrettyPrint.HughesPJClass (Doc, hcat, Pretty(..), text)++here :: ExpQ+here = lift =<< location++instance Pretty Loc where+    pPrint = prettyLoc++noLoc :: Loc+noLoc = Loc "" "" "" (0, 0) (0, 0)++prettyLoc :: Loc -> Doc+prettyLoc (Loc _filename _package modul (line, col) _) = text (modul <> ":" ++ show line ++ ":" ++ show col)++prettyLocs :: [Loc] -> Doc+prettyLocs locs = text "[" <> hcat (intersperse (text " ← ") (fmap prettyLoc locs)) <> text "]"++-- | Add some simple constraints to a 'Dec'. The Dec is typically one+-- emitted by a function such as makeAcidic or deriveSafeCopy.+addConstraints :: [(Name, String)] -> Dec -> Q Dec+addConstraints cs (InstanceD mo cxt typ decs) = do+  let mp :: Map String [Name]+      mp = Map.fromListWith (<>) (fmap (swap . over _1 (: [])) cs)+  (extra :: [Type]) <- concat <$> mapM (uncurry constrain) (Map.toList mp)+  return $ InstanceD mo (cxt ++ extra) typ decs+    where+      -- Apply some type constraints to a type variable+      constrain vstring tnames = do+        vname <- newName vstring+        mapM (\tname -> appT (conT tname) (varT vname)) tnames+addConstraints _ d = return d++-- | Unify the type variables in the existing constraints with those+-- in the new constraint based on nameBase.  If the type variable does+-- not appear in the declaration it is an error.+addConstraint :: Name -> TypeQ -> Dec -> Q Dec+addConstraint tname typeq (InstanceD mo cxt inst decs) = do+  let vnames = nub $ mapMaybe isVar (gFind (inst : cxt) :: [Type])+      mp :: Map String Name+      mp = Map.fromList (fmap (\n -> (nameBase n, n)) vnames)+  (extra :: Type) <- everywhere (mkT (fixTypeVar mp)) <$> appT (conT tname) typeq+  return $ InstanceD mo (cxt ++ [extra]) inst decs+    where+      isVar :: Type -> Maybe Name+      isVar (VarT name) = Just name+      isVar _ = Nothing+      fixTypeVar :: Map String Name -> Type -> Type+      fixTypeVar mp (VarT n) = VarT (maybe n id (Map.lookup (nameBase n) mp))+      fixTypeVar _mp t = t+addConstraint _ _ d = return d++-- | Remove simple constraints from a 'Dec' based on type class name+-- and type variable name.+removeConstraints :: [(Name, String)] -> Dec -> Q Dec+removeConstraints cs (InstanceD mo cxt typ decs) = do+  let mp :: Map String [Name]+      mp = Map.fromListWith (<>) (fmap (swap . over _1 (: [])) cs)+  return $ InstanceD mo (filter (testPred mp) cxt) typ decs+    where+      testPred :: Map String [Name] -> Type -> Bool+      -- Discard any predicate that matches a map element+      testPred mp (AppT (ConT tname) (VarT vname)) =+          not (elem tname (Map.findWithDefault [] (nameBase vname) mp))+      testPred _ _ = True -- keep anything else+removeConstraints _ d = return d
+ Extra/Text.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE CPP, RankNTypes #-}++module Extra.Text+    ( diffText+    , camelWords+    , capitalize+    , Describe(describe')+    , describe+    , textshow+    , trunc+#if !__GHCJS__+    , tests+#endif+    ) where++import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff)+import Data.Char (isUpper, toUpper)+import Data.ListLike (groupBy)+import Data.Text (split, Text, pack, unpack)+#if !__GHCJS__+import Test.HUnit (assertEqual, Test(TestCase, TestList))+#endif+import qualified Text.PrettyPrint as HPJ++-- | 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+diffText (nameA, textA) (nameB, textB) =+    show (prettyContextDiff+          (HPJ.text nameA)+          (HPJ.text nameB)+          (HPJ.text . unpack)+          (getContextDiff 2 (split (== '\n') textA) (split (== '\n') textB)))++-- | Convert a camel case string (no whitespace) into a natural+-- language looking phrase:+--   camelWords "aCamelCaseFOObar123" -> "A Camel Case FOObar123"+camelWords :: String -> String+camelWords s =+    case groupBy (\ a b -> isUpper a == isUpper b) (dropWhile (== '_') s) of -- "aCamelCaseFOObar123"+      (x : xs) -> concat $ capitalize x : map (\ (c : cs) -> if isUpper c then ' ' : c : cs else c : cs) xs+      [] -> ""++#if !__GHCJS__+-- Most of these fail.+tests :: Test+tests =+    TestList+    [ TestCase (assertEqual "camel words 0" "A Camel Case FOO Bar 123" (camelWords "aCamelCaseFOOBar123"))+    , TestCase (assertEqual "camel words 1" "My Generator" (camelWords "myGenerator"))+    , TestCase (assertEqual "camel words 2" "PDF Generator" (camelWords "pDFGenerator"))+    , TestCase (assertEqual "camel words 3" "PDF Generator" (camelWords "PDFGenerator"))+    , TestCase (assertEqual "camel words 4" "Report PDF Generator" (camelWords "reportPDFGenerator")) ]+#endif++capitalize :: String -> String+capitalize [] = []+capitalize (c:cs) = (toUpper c) : cs++-- | Override the default description associated with the type of @a@.+-- The first argument indicates the field of the parent record that+-- contains the @a@ value, if any.+class Describe a where+    describe' :: Maybe String -> a -> Maybe String++describe :: Describe a => a -> Maybe String+describe = describe' Nothing++-- | 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
Extra/Time.hs view
@@ -1,20 +1,20 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, DeriveAnyClass, DeriveDataTypeable, DeriveGeneric, TemplateHaskell #-} module Extra.Time     ( formatDebianDate-    , myTimeDiffToString+    -- , myTimeDiffToString+    , Zulu(..), utcTime     ) where  import Control.Exception-import Data.List+import Control.Lens (makeLenses)+import Data.Data (Data)+import Data.SafeCopy (base, SafeCopy(..)) import Data.Time-#if MIN_VERSION_time(1,5,0)-import qualified System.Locale as Old (defaultTimeLocale)-import qualified System.Time as Old (formatTimeDiff, tdPicosec)-#else-import System.Locale as Old-import System.Time as Old+import Extra.Orphans ()+import GHC.Generics+#if !__GHCJS__+import Test.QuickCheck #endif-import Text.Printf  {- This function is so complicated because there seems to be no way    to get the Data.Time to format seconds without the fractional part,@@ -51,6 +51,8 @@           testsecond = 15.29           teststring = "Tue, 19 Dec 2006 17:19:15 UTC" +#if 0+-- | Retired due to use of old-time. myTimeDiffToString diff =     do       case () of@@ -63,3 +65,20 @@       ms = ps2ms ps       ps2ms ps = quot (ps + 500000000) 1000000000       ps = Old.tdPicosec diff+#endif++-- | A version of UTCTime with a Show instance that returns a Haskell+-- expression.+newtype Zulu = Zulu {_utcTime :: UTCTime} deriving (Eq, Ord, Data, Generic)++$(makeLenses ''Zulu)+instance SafeCopy Zulu where version = 1; kind = base++#if !__GHCJS__+instance Arbitrary Zulu where arbitrary = Zulu <$> arbitrary+#endif+-- instance ParseTime Zulu+-- instance FormatTime Zulu++instance Show Zulu where+  showsPrec d (Zulu t) = showParen (d > 10) $ showString ("Zulu (read " ++ show (show t) ++ ")")
Extra/URI.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- |Make URI an instance of Read and Ord, and add functions to -- manipulate the uriQuery. module Extra.URI@@ -12,15 +14,14 @@     ) where  import Network.URI -- (URIAuth(..), URI(..), parseURI, uriToString, escapeURIString, isUnreserved, unEscapeString)-import Data.List(intersperse, groupBy, inits)-import Data.Maybe(isJust, isNothing, catMaybes)+import Data.List(intersperse, groupBy) import Control.Arrow(second)  -- |Create a relative URI with the given query. relURI :: FilePath -> [(String, String)] -> URI-relURI path pairs = URI {uriScheme = "",+relURI upath pairs = URI {uriScheme = "",                    uriAuthority = Nothing,-                   uriPath = path,+                   uriPath = upath,                    uriQuery = formatURIQuery pairs,                    uriFragment = ""} @@ -70,6 +71,7 @@ -- Everything else gets escaped. escapeURIForQueryValue = escapeURIString isUnreserved +#if 0 -- Make URI an instance of Read.  This will throw an error if no -- prefix up to ten characters long of the argument string looks like -- a URI.  If such a prefix is found, it will continue trying longer@@ -89,3 +91,4 @@                                (a : _) -> a                 goodURIs = takeWhile isJust moreURIs                 (badURIs, moreURIs) = span isNothing allURIs+#endif
+ Extra/Verbosity.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE CPP, RankNTypes #-}+{-# OPTIONS_GHC -Wall #-}+module Extra.Verbosity+    ( modifyEnv+    , qPutStr+    , qPutStrLn+    , ePutStr+    , ePutStrLn+    , eBracket+    , quieter+    , noisier+    , withVerbosity+    , withModifiedVerbosity+    , verbosity+    ) where++import Control.Monad (when)+import Control.Monad.Catch (bracket_, MonadMask)+#ifndef FIXED_VERBOSITY_LEVEL+import Control.Monad.Catch (bracket)+#endif+import Control.Monad.Trans (liftIO, MonadIO)+import System.IO (hPutStr, hPutStrLn, stderr)+import System.Posix.Env (getEnv, setEnv, unsetEnv)++-- | Generalization of Posix setEnv/unSetEnv.+modifyEnv :: String -> (Maybe String -> Maybe String) -> IO ()+modifyEnv name f =+    getEnv name >>= maybe (unsetEnv name) (\ x -> setEnv name x True) . f++ePutStr :: MonadIO m => String -> m ()+ePutStr = liftIO . hPutStr stderr+ePutStrLn :: MonadIO m => String -> m ()+ePutStrLn = liftIO . hPutStrLn stderr++qPutStr :: MonadIO m => String -> m ()+qPutStr s = do+  v <- verbosity+  when (v > 0) (ePutStr s)++qPutStrLn :: MonadIO m => String -> m ()+qPutStrLn s = do+  v <- verbosity+  when (v > 0) (ePutStrLn s)++quieter :: (MonadIO m, MonadMask m) => Int -> m a -> m a+quieter n action = withModifiedVerbosity (\ v -> v - n) action++noisier :: (MonadIO m, MonadMask m) => Int -> m a -> m a+noisier n action = withModifiedVerbosity (\ v -> v + n) action++withVerbosity :: MonadIO m => Int -> m a -> m a+withVerbosity v action = liftIO (setEnv "VERBOSITY" (show v) True) >> action++withModifiedVerbosity :: (MonadIO m, MonadMask m) => (Int -> Int) -> m a -> m a+#ifdef FIXED_VERBOSITY_LEVEL+withModifiedVerbosity _f action =+    action+#else+withModifiedVerbosity f action =+    bracket verbosity -- acquire+            (\ v0 -> liftIO (modifyEnv "VERBOSITY" (const (Just (show v0))))) -- release+            (\ v0 -> liftIO (modifyEnv "VERBOSITY" (const (Just (show (f v0))))) >> action)+#endif++verbosity :: MonadIO m => m Int+#ifdef NO_VERBOSITY_CONTROL+verbosity = return 1000+#else+verbosity = liftIO $ getEnv "VERBOSITY" >>= return . maybe 1 read+#endif++eBracket :: (MonadIO m, MonadMask m) => String -> m a -> m a+eBracket message action =+    bracket_ (ePutStrLn (" -> " ++ message))+             (ePutStrLn (" <- " ++ message))+             action
Test/QUnit.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module      :  Test.QUnit@@ -64,3 +64,6 @@          QC.GaveUp{} -> let ntest = QC.numTests result in HU.assertFailure $ "Arguments exhausted after" ++ show ntest ++ (if ntest == 1 then " test." else " tests.")          QC.Failure{} -> let reason = QC.reason result in HU.assertFailure reason          QC.NoExpectedFailure{} -> HU.assertFailure $ "No Expected Failure"+#if !MIN_VERSION_QuickCheck(2,11,0)+         QC.InsufficientCoverage{} -> HU.assertFailure $ "Insufficient Coverage"+#endif
Test/QuickCheck/Properties.hs view
@@ -2,7 +2,7 @@  import Test.QuickCheck -isIdempotentBy :: (Arbitrary a, Eq a, Show a) => (a -> a) -> Gen a -> Property+isIdempotentBy :: ({-Arbitrary a,-} Eq a, Show a) => (a -> a) -> Gen a -> Property isIdempotentBy f src = forAll src $ \a -> f a == f (f a)  isIdempotent :: (Arbitrary a, Eq a, Show a) => (a -> a) -> Property
sr-extra.cabal view
@@ -1,67 +1,136 @@ Name:           sr-extra-Version:        1.46.3.2+Version:        1.64 License:        BSD3-License-File:	COPYING+License-File:   COPYING Author:         David Fox Category:       Unclassified-Description:    A hodge-podge of functions and modules that do not have a better home+Synopsis:       Module limbo+Description:+  A hodge-podge of functions, modules, and instances.  These+  generally end up here because+     1. they are needed in two unrelated packages,+     2. they belong in some upstream module,+     3. they can't be moved to an upstream module because+        they would add dependencies, or+     4. they are deprecated but still in use Maintainer:     David Fox <dsf@seereason.com> Homepage:       https://github.com/seereason/sr-extra-Synopsis:       A grab bag of modules. Build-Type:     Simple-Cabal-Version:  >= 1.2+Cabal-Version:  >= 1.4+ flag network-uri- Description: Get Network.URI from the network-uri package- Default: True+  Description: Get Network.URI from the network-uri package rather than the+   full network package.+  Default: True +flag omit-serialize+  Description: Omit all the Serialize instances, on the assumption+   that we will use SafeCopy instances instead.+  Default: False+ Library+  GHC-Options: -Wall -Wredundant-constraints   Build-Depends:     base < 5,     bytestring,     bzlib,+    Cabal,     containers,+    Diff,     directory,+    exceptions,+    fgl,     filepath,-    HUnit,+    generic-data,+    hslogger,+    lens,+    ListLike,+    mmorph,     mtl,-    old-locale,-    old-time,     pretty,-    process,     pureMD5,-    QuickCheck >= 2 && < 3,     random,-    regex-compat,+    safecopy >= 0.9.5,+    show-combinators,+    syb,+    template-haskell,+    text,+    th-lift,+    th-lift-instances,+    th-orphans,     time >= 1.1,     unix,     Unixutils >= 1.51,+    userid,+    uuid,+    uuid-orphans,+    uuid-types,     zlib-  if flag(network-uri)-    Build-Depends: network-uri >= 2.6-  else-    Build-Depends: network >= 2.4-  ghc-options:	-O2 -W-  C-Sources:	     cbits/gwinsz.c+  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   Exposed-modules:     Extra.Bool,-    Extra.CIO,+    Extra.Debug,+    Extra.Debug2,     Extra.Either,+    Extra.EnvPath,+    Extra.Except,     Extra.Exit,     Extra.Files,-    Extra.GPGSign,+    Extra.FP,+    Extra.Generics,+    Extra.Generics.Show,+    Extra.IOThread     Extra.List,     Extra.HughesPJ,-    Extra.Lock,+    Extra.Log,     Extra.Misc,+    Extra.Monad.Supply,     Extra.Net,-    Extra.SSH,+    Extra.Orphans,+    Extra.Orphans2,+    Extra.Orphans3,+    Extra.Pretty,+    Extra.SafeCopy,+    Extra.SafeCopyDebug,+    Extra.Serialize,+    Extra.SerializeDebug,+    Extra.Text,+    Extra.TH,     Extra.Time,     Extra.Terminal,-    Extra.IO,     Extra.URI,     Extra.URIQuery,-    Test.QUnit,-    Test.QuickCheck.Properties,-    Extra.IOThread+    Extra.Verbosity+  if !impl(ghcjs)+    Build-Depends:+      show-please,+      filemanip,+      HUnit,+      process,+      process-extras,+      QuickCheck >= 2 && < 3+    Exposed-Modules:+      Extra.GPGSign,+      Extra.Lock,+      Extra.IO,+      Extra.Process,+      Extra.SSH,+      Test.QUnit,+      Test.QuickCheck.Properties++  if flag(network-uri)+    Build-Depends: network-uri >= 2.6+  else+    Build-Depends: network >= 2.4++  if flag(omit-serialize)+    CPP-Options: -DOMIT_SERIALIZE+    -- We still need cereal to implement instance SafeCopy Proxy+    Build-Depends: cereal+  else+    Build-Depends: cereal