module Shelly
(
ShIO, shelly, sub, silently, verbosely, escaping, print_stdout, print_commands
, run, run_, cmd, (-|-), lastStderr, setStdin
, command, command_, command1, command1_
, sshPairs, sshPairs_
, setenv, getenv, getenv_def, appendToPath
, cd, chdir, pwd
, echo, echo_n, echo_err, echo_n_err, inspect
, tag, trace, show_command
, ls, ls', test_e, test_f, test_d, test_s, which, find
, path, absPath, (</>), (<.>)
, mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p
, readfile, writefile, appendfile, withTmpDir
, jobs, background, getBgResult, BgResult
, exit, errorExit, terror
, (<$>), (<$$>), grep, whenM, unlessM, canonic
, catchany, catch_sh, ShellyHandler(..), catches_sh, catchany_sh
, Timing(..), time
, RunFailed(..)
, toTextIgnore, toTextWarn, fromText
, liftIO, when, unless, FilePath
) where
import Prelude hiding ( catch, readFile, FilePath )
import Data.List( isInfixOf )
import Data.Char( isAlphaNum, isSpace )
import Data.Typeable
import Data.IORef
import Data.Maybe
import System.IO hiding ( readFile, FilePath )
import System.Exit
import System.Environment
import Control.Applicative
import Control.Exception hiding (handle)
import Control.Monad.Reader
import Control.Concurrent
import qualified Control.Concurrent.MSem as Sem
import Data.Time.Clock( getCurrentTime, diffUTCTime )
import qualified Data.Text.Lazy.IO as TIO
import qualified Data.Text.IO as STIO
import System.Process( CmdSpec(..), StdStream(CreatePipe), CreateProcess(..), createProcess, waitForProcess, ProcessHandle )
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text as T
import Data.Monoid (mappend)
import Filesystem.Path.CurrentOS hiding (concat, fromText, (</>), (<.>))
import Filesystem
import qualified Filesystem.Path.CurrentOS as FP
import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )
import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory, findExecutable )
class ShellArg a where toTextArg :: a -> Text
instance ShellArg Text where toTextArg = id
instance ShellArg FilePath where toTextArg = toTextIgnore
class ShellCommand t where
cmdAll :: FilePath -> [Text] -> t
instance ShellCommand (ShIO Text) where
cmdAll fp args = run fp args
instance (s ~ Text, Show s) => ShellCommand (ShIO s) where
cmdAll fp args = run fp args
instance ShellCommand (ShIO ()) where
cmdAll fp args = run_ fp args >> liftIO (throwIO CmdError)
data CmdError = CmdError deriving Typeable
instance Show CmdError where
show (CmdError) = "Sorry! You are running up against some of the magic from using the variadic argument function 'cmd'. Please report this issue so we can fix it."
instance Exception CmdError
instance (ShellArg arg, ShellCommand result) => ShellCommand (arg -> result) where
cmdAll fp acc = \x -> cmdAll fp (acc ++ [toTextArg x])
cmd :: (ShellCommand result) => FilePath -> result
cmd fp = cmdAll fp []
class ToFilePath a where
toFilePath :: a -> FilePath
instance ToFilePath FilePath where toFilePath = id
instance ToFilePath Text where toFilePath = fromText
instance ToFilePath T.Text where toFilePath = FP.fromText
instance ToFilePath String where toFilePath = FP.fromText . T.pack
(</>) :: (ToFilePath filepath1, ToFilePath filepath2) => filepath1 -> filepath2 -> FilePath
x </> y = toFilePath x FP.</> toFilePath y
(<.>) :: (ToFilePath filepath) => filepath -> Text -> FilePath
x <.> y = toFilePath x FP.<.> LT.toStrict y
toTextIgnore :: FilePath -> Text
toTextIgnore fp = LT.fromStrict $ case toText fp of
Left f -> f
Right f -> f
toTextWarn :: FilePath -> ShIO Text
toTextWarn efile = fmap lazy $ case toText efile of
Left f -> encodeError f >> return f
Right f -> return f
where
encodeError f = echo ("Invalid encoding for file: " `mappend` lazy f)
lazy = LT.fromStrict
fromText :: Text -> FilePath
fromText = FP.fromText . LT.toStrict
printGetContent :: Handle -> Handle -> IO Text
printGetContent rH wH =
fmap B.toLazyText $ printFoldHandleLines (B.fromText "") foldBuilder rH wH
getContent :: Handle -> IO Text
getContent h = fmap B.toLazyText $ foldHandleLines (B.fromText "") foldBuilder h
type FoldCallback a = ((a, Text) -> a)
printFoldHandleLines :: a -> FoldCallback a -> Handle -> Handle -> IO a
printFoldHandleLines start foldLine readHandle writeHandle = go start
where
go acc = do
line <- TIO.hGetLine readHandle
TIO.hPutStrLn writeHandle line >> go (foldLine (acc, line))
`catchany` \_ -> return acc
foldHandleLines :: a -> FoldCallback a -> Handle -> IO a
foldHandleLines start foldLine readHandle = go start
where
go acc = do
line <- TIO.hGetLine readHandle
go $ foldLine (acc, line)
`catchany` \_ -> return acc
data State = State { sCode :: Int
, sStdin :: Maybe Text
, sStderr :: Text
, sDirectory :: FilePath
, sPrintStdout :: Bool
, sPrintCommands :: Bool
, sRun :: FilePath -> [Text] -> ShIO (Handle, Handle, Handle, ProcessHandle)
, sEnvironment :: [(String, String)]
, sTrace :: B.Builder
}
tag :: ShIO a -> Text -> ShIO a
tag action msg = do
trace msg
result <- action
return result
trace :: Text -> ShIO ()
trace msg = modify $ \st -> st { sTrace = sTrace st `mappend` B.fromLazyText msg `mappend` "\n" }
type ShIO a = ReaderT (IORef State) IO a
get :: ShIO State
get = do
stateVar <- ask
liftIO (readIORef stateVar)
put :: State -> ShIO ()
put newState = do
stateVar <- ask
liftIO (writeIORef stateVar newState)
modify :: (State -> State) -> ShIO ()
modify f = do
state <- ask
liftIO (modifyIORef state f)
gets :: (State -> a) -> ShIO a
gets f = f <$> get
runCommand :: FilePath -> [Text] -> ShIO (Handle, Handle, Handle, ProcessHandle)
runCommand exe args = do
st <- get
shellyProcess st $
RawCommand (unpack exe) (map LT.unpack args)
runCommandNoEscape :: FilePath -> [Text] -> ShIO (Handle, Handle, Handle, ProcessHandle)
runCommandNoEscape exe args = do
st <- get
shellyProcess st $
ShellCommand $ LT.unpack $ LT.intercalate " " (toTextIgnore exe : args)
shellyProcess :: State -> CmdSpec -> ShIO (Handle, Handle, Handle, ProcessHandle)
shellyProcess st cmdSpec = do
(Just hin, Just hout, Just herr, pHandle) <- liftIO $
createProcess $ CreateProcess {
cmdspec = cmdSpec
, cwd = Just $ unpack $ sDirectory st
, env = Just $ sEnvironment st
, std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe
, close_fds = False
#if MIN_VERSION_process(1,1,0)
, create_group = False
#endif
}
return (hin, hout, herr, pHandle)
catchany :: IO a -> (SomeException -> IO a) -> IO a
catchany = catch
catch_sh :: (Exception e) => ShIO a -> (e -> ShIO a) -> ShIO a
catch_sh action handle = do
ref <- ask
liftIO $ catch (runReaderT action ref) (\e -> runReaderT (handle e) ref)
data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> ShIO a)
catches_sh :: ShIO a -> [ShellyHandler a] -> ShIO a
catches_sh action handlers = do
ref <- ask
let runner a = runReaderT a ref
liftIO $ catches (runner action) $ map (toHandler runner) handlers
where
toHandler :: (ShIO a -> IO a) -> ShellyHandler a -> Handler a
toHandler runner (ShellyHandler handle) = Handler (\e -> runner (handle e))
catchany_sh :: ShIO a -> (SomeException -> ShIO a) -> ShIO a
catchany_sh = catch_sh
cd :: FilePath -> ShIO ()
cd dir = do dir' <- absPath dir
trace $ "cd " `mappend` toTextIgnore dir'
modify $ \st -> st { sDirectory = dir' }
chdir :: FilePath -> ShIO a -> ShIO a
chdir dir action = do
d <- pwd
cd dir
r <- action `catchany_sh` (\e ->
cd d >> liftIO (throwIO e)
)
cd d
return r
path :: FilePath -> ShIO FilePath
path = canonic
absPath :: FilePath -> ShIO FilePath
absPath p | relative p = (FP.</> p) <$> gets sDirectory
| otherwise = return p
unpack :: FilePath -> String
unpack = encodeString
pack :: String -> FilePath
pack = decodeString
mv :: FilePath -> FilePath -> ShIO ()
mv a b = do a' <- absPath a
b' <- absPath b
trace $ "mv " `mappend` toTextIgnore a' `mappend` " " `mappend` toTextIgnore b'
liftIO $ rename a' b'
ls' :: FilePath -> ShIO [Text]
ls' fp = do
trace $ "ls " `mappend` toTextIgnore fp
efiles <- ls fp
mapM toTextWarn efiles
ls :: FilePath -> ShIO [FilePath]
ls = path >=> \fp -> (liftIO $ listDirectory fp) `tag` ("ls " `mappend` toTextIgnore fp)
find :: FilePath -> ShIO [FilePath]
find dir = do trace ("find " `mappend` toTextIgnore dir)
bits <- ls dir
subDir <- forM bits $ \x -> do
ex <- test_d $ dir FP.</> x
sym <- test_s $ dir FP.</> x
if ex && not sym then find (dir FP.</> x)
else return []
return $ map (dir FP.</>) bits ++ concat subDir
pwd :: ShIO FilePath
pwd = gets sDirectory `tag` "pwd"
echo, echo_n, echo_err, echo_n_err :: Text -> ShIO ()
echo = traceLiftIO TIO.putStrLn
echo_n = traceLiftIO $ (>> hFlush System.IO.stdout) . TIO.putStr
echo_err = traceLiftIO $ TIO.hPutStrLn stderr
echo_n_err = traceLiftIO $ (>> hFlush stderr) . TIO.hPutStr stderr
traceLiftIO :: (Text -> IO ()) -> Text -> ShIO ()
traceLiftIO f msg = trace ("echo " `mappend` "'" `mappend` msg `mappend` "'") >> liftIO (f msg)
exit :: Int -> ShIO ()
exit 0 = liftIO (exitWith ExitSuccess) `tag` "exit 0"
exit n = liftIO (exitWith (ExitFailure n)) `tag` ("exit " `mappend` LT.pack (show n))
errorExit :: Text -> ShIO ()
errorExit msg = echo msg >> exit 1
terror :: Text -> ShIO a
terror = fail . LT.unpack
inspect :: (Show s) => s -> ShIO ()
inspect x = do
(trace . LT.pack . show) x
liftIO $ print x
mkdir :: FilePath -> ShIO ()
mkdir = absPath >=> \fp -> do
trace $ "mkdir " `mappend` toTextIgnore fp
liftIO $ createDirectory False fp `catchany` (\e -> throwIO e >> return ())
mkdir_p :: FilePath -> ShIO ()
mkdir_p = absPath >=> \fp -> do
trace $ "mkdir -p " `mappend` toTextIgnore fp
liftIO $ createTree fp
which :: FilePath -> ShIO (Maybe FilePath)
which fp = do
(trace . mappend "which " . toTextIgnore) fp
(liftIO . findExecutable . unpack >=> return . fmap pack) fp
canonic :: FilePath -> ShIO FilePath
canonic = absPath >=> liftIO . canonicalizePath
whenM :: Monad m => m Bool -> m () -> m ()
whenM c a = c >>= \res -> when res a
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c a = c >>= \res -> unless res a
test_e :: FilePath -> ShIO Bool
test_e f = do
fs <- absPath f
liftIO $ do
file <- isFile fs
if file then return True else isDirectory fs
test_f :: FilePath -> ShIO Bool
test_f = absPath >=> liftIO . isFile
test_d :: FilePath -> ShIO Bool
test_d = absPath >=> liftIO . isDirectory
test_s :: FilePath -> ShIO Bool
test_s = absPath >=> liftIO . \f -> do
stat <- getSymbolicLinkStatus (unpack f)
return $ isSymbolicLink stat
rm_rf :: FilePath -> ShIO ()
rm_rf f = absPath f >>= \f' -> do
trace $ "rm -rf " `mappend` toTextIgnore f
whenM (test_d f) $ do
_<- find f' >>= mapM (\file -> liftIO_ $ fixPermissions (unpack file) `catchany` \_ -> return ())
liftIO_ $ removeTree f'
whenM (test_f f) $ rm_f f'
where fixPermissions file =
do permissions <- liftIO $ getPermissions file
let deletable = permissions { readable = True, writable = True, executable = True }
liftIO $ setPermissions file deletable
rm_f :: FilePath -> ShIO ()
rm_f f = do
trace $ "rm -f " `mappend` toTextIgnore f
whenM (test_e f) $ absPath f >>= liftIO . removeFile
rm :: FilePath -> ShIO ()
rm f = do
trace $ "rm" `mappend` toTextIgnore f
absPath f >>= liftIO . removeFile
setenv :: Text -> Text -> ShIO ()
setenv k v =
let (kStr, vStr) = (LT.unpack k, LT.unpack v)
wibble environment = (kStr, vStr) : filter ((/=kStr).fst) environment
in modify $ \x -> x { sEnvironment = wibble $ sEnvironment x }
appendToPath :: FilePath -> ShIO ()
appendToPath filepath = do
tp <- toTextWarn filepath
pe <- getenv path_env
setenv path_env $ pe `mappend` ":" `mappend` tp
where
path_env = "PATH"
getenv :: Text -> ShIO Text
getenv k = getenv_def k ""
getenv_def :: Text -> Text -> ShIO Text
getenv_def k d = gets sEnvironment >>=
return . LT.pack . fromMaybe (LT.unpack d) . lookup (LT.unpack k)
silently :: ShIO a -> ShIO a
silently a = sub $ modify (\x -> x { sPrintStdout = False, sPrintCommands = False }) >> a
verbosely :: ShIO a -> ShIO a
verbosely a = sub $ modify (\x -> x { sPrintStdout = True, sPrintCommands = True }) >> a
print_stdout :: Bool -> ShIO a -> ShIO a
print_stdout shouldPrint a = sub $ modify (\x -> x { sPrintStdout = shouldPrint }) >> a
jobs :: Int -> (BgJobManager -> ShIO a) -> ShIO a
jobs limit action = do
unless (limit > 0) $ terror "expected limit to be > 0"
availableJobsSem <- liftIO $ Sem.new limit
res <- action $ BgJobManager availableJobsSem
liftIO $ waitForJobs availableJobsSem
return res
where
waitForJobs sem = do
avail <- Sem.peekAvail sem
if avail == limit then return () else waitForJobs sem
newtype BgJobManager = BgJobManager (Sem.MSem Int)
newtype BgResult a = BgResult (MVar a)
getBgResult :: BgResult a -> ShIO a
getBgResult (BgResult mvar) = liftIO $ takeMVar mvar
background :: BgJobManager -> ShIO a -> ShIO (BgResult a)
background (BgJobManager manager) proc = do
state <- get
liftIO $ do
Sem.wait manager
mvar <- newEmptyMVar
_<- forkIO $ do
result <- shelly $ (put state >> proc)
Sem.signal manager
liftIO $ putMVar mvar result
return $ BgResult mvar
print_commands :: Bool -> ShIO a -> ShIO a
print_commands shouldPrint a = sub $ modify (\st -> st { sPrintCommands = shouldPrint }) >> a
sub :: ShIO a -> ShIO a
sub a = do
oldState <- get
modify $ \st -> st { sTrace = B.fromText "" }
r <- a `catchany_sh` (\e -> do
restoreState oldState
liftIO $ throwIO e)
restoreState oldState
return r
where
restoreState oldState = do
newState <- get
put oldState { sTrace = sTrace oldState `mappend` sTrace newState }
escaping :: Bool -> ShIO a -> ShIO a
escaping shouldEscape action = sub $ do
modify $ \st -> st { sRun =
if shouldEscape
then runCommand
else runCommandNoEscape
}
action
shelly :: MonadIO m => ShIO a -> m a
shelly action = do
environment <- liftIO getEnvironment
dir <- liftIO getWorkingDirectory
let def = State { sCode = 0
, sStdin = Nothing
, sStderr = LT.empty
, sPrintStdout = True
, sPrintCommands = False
, sRun = runCommand
, sEnvironment = environment
, sTrace = B.fromText ""
, sDirectory = dir }
stref <- liftIO $ newIORef def
let caught =
action `catches_sh` [
ShellyHandler (\ex ->
case ex of
ExitSuccess -> liftIO $ throwIO ex
ExitFailure _ -> throwExplainedException ex
)
, ShellyHandler (\(ex::SomeException) -> throwExplainedException ex)
]
liftIO $ runReaderT caught stref
where
throwExplainedException ex = get >>=
liftIO . throwIO . ReThrownException ex . errorMsg . LT.unpack . B.toLazyText . sTrace
errorMsg trc = "Ran commands: \n" `mappend` trc
data RunFailed = RunFailed FilePath [Text] Int Text deriving (Typeable)
instance Show RunFailed where
show (RunFailed exe args code errs) =
let codeMsg = case code of
127 -> ". exit code 127 usually means the command does not exist (in the PATH)"
_ -> ""
in "error running: " ++ LT.unpack (show_command exe args) ++
"\nexit status: " ++ show code ++ codeMsg ++ "\nstderr: " ++ LT.unpack errs
instance Exception RunFailed
show_command :: FilePath -> [Text] -> Text
show_command exe args =
LT.intercalate " " $ map quote (toTextIgnore exe : args)
where
quote t = if LT.any (== '\'') t then t
else if LT.any isSpace t then surround '\'' t else t
surround :: Char -> Text -> Text
surround c t = LT.cons c $ LT.snoc t c
sshPairs_ :: Text -> [(FilePath, [Text])] -> ShIO ()
sshPairs_ _ [] = return ()
sshPairs_ server cmds = sshPairs' run_ server cmds
sshPairs :: Text -> [(FilePath, [Text])] -> ShIO Text
sshPairs _ [] = return ""
sshPairs server cmds = sshPairs' run server cmds
sshPairs' :: (FilePath -> [Text] -> ShIO a) -> Text -> [(FilePath, [Text])] -> ShIO a
sshPairs' run' server actions = do
escaping False $ do
let ssh_commands = surround '\'' $ foldl1 ((mappend) . (mappend " && ")) (map toSSH actions)
run' "ssh" $ [server, ssh_commands]
where
toSSH (exe,args) = show_command exe args
data Exception e => ReThrownException e = ReThrownException e String deriving (Typeable)
instance Exception e => Exception (ReThrownException e)
instance Exception e => Show (ReThrownException e) where
show (ReThrownException ex msg) = "\n" ++
msg ++ "\n" ++ "Exception: " ++ show ex
run :: FilePath -> [Text] -> ShIO Text
run exe args = fmap B.toLazyText $ runFoldLines (B.fromText "") foldBuilder exe args
foldBuilder :: (B.Builder, Text) -> B.Builder
foldBuilder (b, line) = b `mappend` B.fromLazyText line `mappend` B.singleton '\n'
command :: FilePath -> [Text] -> [Text] -> ShIO Text
command com args more_args = run com (args ++ more_args)
command_ :: FilePath -> [Text] -> [Text] -> ShIO ()
command_ com args more_args = run_ com (args ++ more_args)
command1 :: FilePath -> [Text] -> Text -> [Text] -> ShIO Text
command1 com args one_arg more_args = run com ([one_arg] ++ args ++ more_args)
command1_ :: FilePath -> [Text] -> Text -> [Text] -> ShIO ()
command1_ com args one_arg more_args = run_ com ([one_arg] ++ args ++ more_args)
run_ :: FilePath -> [Text] -> ShIO ()
run_ = runFoldLines () (\(_, _) -> ())
liftIO_ :: IO a -> ShIO ()
liftIO_ action = liftIO action >> return ()
runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> ShIO a
runFoldLines start cb exe args = do
origstate <- get
let mStdin = sStdin origstate
put $ origstate { sStdin = Nothing, sCode = 0, sStderr = LT.empty }
state <- get
let cmdString = show_command exe args
when (sPrintCommands state) $ echo cmdString
trace cmdString
(inH,outH,errH,procH) <- sRun state exe args
case mStdin of
Just input ->
liftIO $ TIO.hPutStr inH input >> hClose inH
Nothing -> return ()
errV <- liftIO newEmptyMVar
outV <- liftIO newEmptyMVar
if sPrintStdout state
then do
liftIO_ $ forkIO $ printGetContent errH stderr >>= putMVar errV
liftIO_ $ forkIO $ printFoldHandleLines start cb outH stdout >>= putMVar outV
else do
liftIO_ $ forkIO $ getContent errH >>= putMVar errV
liftIO_ $ forkIO $ foldHandleLines start cb outH >>= putMVar outV
errs <- liftIO $ takeMVar errV
ex <- liftIO $ waitForProcess procH
let code = case ex of
ExitSuccess -> 0
ExitFailure n -> n
put $ state { sStderr = errs , sCode = code }
liftIO $ case ex of
ExitSuccess -> takeMVar outV
ExitFailure n -> throwIO $ RunFailed exe args n errs
lastStderr :: ShIO Text
lastStderr = gets sStderr
setStdin :: Text -> ShIO ()
setStdin input = modify $ \st -> st { sStdin = Just input }
(-|-) :: ShIO Text -> ShIO b -> ShIO b
one -|- two = do
res <- (print_stdout False) one
setStdin res
two
cp_r :: FilePath -> FilePath -> ShIO ()
cp_r from to = do
trace $ "cp -r " `mappend` toTextIgnore from `mappend` " " `mappend` toTextIgnore to
from_d <- (test_d from)
if not from_d then cp from to else do
let fromName = filename from
let toDir = if filename to == fromName then to else to FP.</> fromName
unlessM (test_d toDir) $ mkdir toDir
ls from >>= mapM_
(\item -> cp_r (from FP.</> filename item) (toDir FP.</> filename item))
cp :: FilePath -> FilePath -> ShIO ()
cp from to = do
from' <- absPath from
to' <- absPath to
trace $ "cp " `mappend` toTextIgnore from' `mappend` " " `mappend` toTextIgnore to'
to_dir <- test_d to
let to_loc = if to_dir then to' FP.</> filename from else to'
liftIO $ copyFile from' to_loc `catchany` (\e -> throwIO $
ReThrownException e (extraMsg to_loc from')
)
where
extraMsg t f = "during copy from: " ++ unpack f ++ " to: " ++ unpack t
class PredicateLike pattern hay where
match :: pattern -> hay -> Bool
instance PredicateLike (a -> Bool) a where
match = id
instance (Eq a) => PredicateLike [a] [a] where
match pat = (pat `isInfixOf`)
grep :: (PredicateLike pattern hay) => pattern -> [hay] -> [hay]
grep p = filter (match p)
(<$$>) :: (Functor m) => (b -> c) -> (a -> m b) -> a -> m c
f <$$> v = fmap f . v
withTmpDir :: (FilePath -> ShIO a) -> ShIO a
withTmpDir act = do
trace "withTmpDir"
dir <- liftIO getTemporaryDirectory
tid <- liftIO myThreadId
(pS, handle) <- liftIO $ openTempFile dir ("tmp"++filter isAlphaNum (show tid))
let p = pack pS
liftIO $ hClose handle
rm_f p
mkdir p
a <- act p `catchany_sh` \e -> do
rm_rf p >> liftIO (throwIO e)
rm_rf p
return a
writefile :: FilePath -> Text -> ShIO ()
writefile f bits = absPath f >>= \f' -> do
trace $ "writefile " `mappend` toTextIgnore f'
liftIO (TIO.writeFile (unpack f') bits)
appendfile :: FilePath -> Text -> ShIO ()
appendfile f bits = absPath f >>= \f' -> do
trace $ "appendfile " `mappend` toTextIgnore f'
liftIO (TIO.appendFile (unpack f') bits)
readfile :: FilePath -> ShIO Text
readfile = absPath >=> \fp -> do
trace $ "readfile " `mappend` toTextIgnore fp
(fmap LT.fromStrict . liftIO . STIO.readFile . unpack) fp
data Timing = Timing Double deriving (Read, Show, Ord, Eq)
time :: ShIO a -> ShIO (Timing, a)
time what = sub $ do
trace "time"
t <- liftIO getCurrentTime
res <- what
t' <- liftIO getCurrentTime
let mt = Timing (realToFrac $ diffUTCTime t' t)
return (mt, res)