diff options
author | defanor <defanor@uberspace.net> | 2017-12-20 05:43:32 +0300 |
---|---|---|
committer | defanor <defanor@uberspace.net> | 2017-12-20 05:43:32 +0300 |
commit | c9b893cd0343aab8b68b5a2c1e5400c164bb2ba6 (patch) | |
tree | 28340df5fcf83fb49ff1f45c38da0d35af3fa201 /Coalpit/IO.hs | |
parent | e7489043d8bf2a406a910adcb93280e83d6d2faa (diff) |
Add Coalpit.IO
Diffstat (limited to 'Coalpit/IO.hs')
-rw-r--r-- | Coalpit/IO.hs | 96 |
1 files changed, 96 insertions, 0 deletions
diff --git a/Coalpit/IO.hs b/Coalpit/IO.hs new file mode 100644 index 0000000..b0a074a --- /dev/null +++ b/Coalpit/IO.hs @@ -0,0 +1,96 @@ +{- | +Module : Coalpit.IO +Description : Helper IO functions +Maintainer : defanor <defanor@uberspace.net> +Stability : unstable +Portability : non-portable (uses GHC extensions) + +These are basic utility functions for pipes-based IO. + +An example: + +@ +\{\-\# LANGUAGE DeriveGeneric, DeriveAnyClass \#\-\} +import GHC.Generics +import "Coalpit" + +data Output = Foo Double | Bar deriving (Generic, 'Coalpit') +data Args = Args { arg1 :: Maybe Int, arg2 :: Double } + deriving (Generic, 'Coalpit') + +main :: IO () +main = 'pipe' $ \a i -> pure $ Foo $ maybe (arg2 a) fromIntegral (arg1 a) + i +@ + +-} + +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +module Coalpit.IO ( run, run', handleErrors + , pipe, consumer, producer) where + +import Data.Proxy (Proxy(..)) +import System.Environment (getProgName, getArgs) +import Control.Monad.IO.Class (MonadIO, liftIO) +import System.Exit (die) +import System.IO (hPutStrLn, stderr) +import Pipes ((>->), Pipe, yield, await, lift, runEffect) +import Control.Monad (mapM_, forever) +import qualified Pipes.Prelude as PP +import Coalpit.Core (Coalpit, fromArgs, defOpt, usage) +import Coalpit.DSV (readDSV, showDSV) + +-- | Runs a given action on each 'Left' value, embedding that action's +-- result into the data stream. +handleErrors :: MonadIO m => (e -> m [a]) -> Pipe (Either e a) a m () +handleErrors e = forever $ do + v <- await + case v of + Left err -> do + vs <- lift $ e err + mapM_ yield vs + Right x -> yield x + +-- | Runs a given 'Pipe' between input producer and output consumer. +-- Prints an error and usage instructions if it fails to parse the +-- arguments, and passes the input through 'handleErrors'. +run :: forall m a i o. (MonadIO m, Coalpit a, Coalpit i, Coalpit o) + => (String -> m [i]) + -- ^ An action to run on error (see 'handleErrors'). + -> (a -> Pipe i o m ()) + -- ^ Main function. + -> m () +run e f = do + pn <- liftIO getProgName + let u = Prelude.concat ["Usage: ", pn, " ", usage defOpt (Proxy :: Proxy a)] + args <- liftIO getArgs + a <- either (liftIO . die . (++ u)) pure $ fromArgs defOpt args + runEffect $ + PP.stdinLn + >-> PP.map (readDSV defOpt) + >-> handleErrors e + >-> f a + >-> PP.map (showDSV defOpt) + >-> PP.stdoutLn + +-- | Same as 'run', but just prints errors into 'stderr'. +run' :: forall m a i o. (MonadIO m, Coalpit a, Coalpit i, Coalpit o) + => (a -> Pipe i o m ()) + -- ^ Main function. + -> m () +run' = run (\e -> liftIO $ hPutStrLn stderr e >> pure []) + +-- | Similar to 'interact' in the approach, a wrapper around 'run''. +pipe :: (MonadIO m, Coalpit a, Coalpit i, Coalpit o) + => (a -> i -> m o) -> m () +pipe f = run' $ \a -> forever $ await >>= lift . f a >>= yield + +-- | A version of 'pipe' that doesn't 'await' any input. +producer :: forall m a o. (MonadIO m, Coalpit a, Coalpit o) + => (a -> m o) -> m () +producer f = run' $ \a -> forever $ lift (f a) >>= yield :: Pipe () o m () + +-- | A version of 'pipe' that doesn't 'yield' any output. +consumer :: forall m a i. (MonadIO m, Coalpit a, Coalpit i) + => (a -> i -> m ()) -> m () +consumer f = run' $ \a -> forever $ await >>= lift . f a :: Pipe i () m () |