diff options
author | defanor <defanor@uberspace.net> | 2017-12-20 10:12:52 +0300 |
---|---|---|
committer | defanor <defanor@uberspace.net> | 2017-12-20 10:12:52 +0300 |
commit | b2435e1e37b9def481761a00c704d280ef2deb96 (patch) | |
tree | 165aa7466248700d9820eaabb3e507ac06225822 /examples/Pipes.hs | |
parent | 3350f07b88a4628d83abaf9eaea2f0dfc2e44edf (diff) |
Remove Coalpit.IO
Better to focus on printing and parsing here, at least for now;
besides, pipes are nice, but some may prefer other methods.
The code is moved into an example instead.
Diffstat (limited to 'examples/Pipes.hs')
-rw-r--r-- | examples/Pipes.hs | 66 |
1 files changed, 66 insertions, 0 deletions
diff --git a/examples/Pipes.hs b/examples/Pipes.hs new file mode 100644 index 0000000..7b50f93 --- /dev/null +++ b/examples/Pipes.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, DeriveGeneric, + DeriveAnyClass #-} + +module Coalpit.IO (runMain, runMain', handleErrors) 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) +import GHC.Generics + +-- | 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'. +runMain :: 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 () +runMain 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 'runMain', but just prints errors into 'stderr'. +runMain' :: forall m a i o. (MonadIO m, Coalpit a, Coalpit i, Coalpit o) + => (a -> Pipe i o m ()) + -- ^ Main function. + -> m () +runMain' = runMain (\e -> liftIO $ hPutStrLn stderr e >> pure []) + + +data Args = Args { arg1 :: Maybe Int, arg2 :: Double } + deriving (Generic, Coalpit) +data Input = Input Double deriving (Generic, Coalpit) +data Output = Foo Double | Bar deriving (Generic, Coalpit) + +main :: IO () +main = runMain' $ \a -> PP.mapM $ \(Input i) -> + pure $ Foo $ maybe (arg2 a) fromIntegral (arg1 a) + i |