From c9b893cd0343aab8b68b5a2c1e5400c164bb2ba6 Mon Sep 17 00:00:00 2001
From: defanor <defanor@uberspace.net>
Date: Wed, 20 Dec 2017 05:43:32 +0300
Subject: Add Coalpit.IO

---
 Coalpit.hs     |  2 ++
 Coalpit/DSV.hs |  2 +-
 Coalpit/IO.hs  | 96 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 coalpit.cabal  |  2 ++
 4 files changed, 101 insertions(+), 1 deletion(-)
 create mode 100644 Coalpit/IO.hs

diff --git a/Coalpit.hs b/Coalpit.hs
index 6eb7f06..fda836a 100644
--- a/Coalpit.hs
+++ b/Coalpit.hs
@@ -59,7 +59,9 @@ Then, in a shell:
 
 module Coalpit ( module Coalpit.Core
                , module Coalpit.DSV
+               , module Coalpit.IO
                ) where
 
 import Coalpit.Core
 import Coalpit.DSV
+import Coalpit.IO
diff --git a/Coalpit/DSV.hs b/Coalpit/DSV.hs
index 2ba9464..890399d 100644
--- a/Coalpit/DSV.hs
+++ b/Coalpit/DSV.hs
@@ -52,7 +52,7 @@ parseDSVLine fs l = case parse (pDSVLine fs) "line" l of
 
 -- | Shows values in DSV format.
 showDSV :: Coalpit a => Options -> a -> String
-showDSV opt = composeDSVLine (fieldSeparator opt) . (toArgs opt)
+showDSV opt = composeDSVLine (fieldSeparator opt) . toArgs opt
 
 -- | Reads values from DSV format.
 readDSV :: Coalpit a => Options -> String -> Either String a
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 ()
diff --git a/coalpit.cabal b/coalpit.cabal
index 1d91ea7..6fa969f 100644
--- a/coalpit.cabal
+++ b/coalpit.cabal
@@ -27,12 +27,14 @@ library
   exposed-modules:     Coalpit
                      , Coalpit.Core
                      , Coalpit.DSV
+                     , Coalpit.IO
                      , Coalpit.Parsing
   build-depends:       base >= 4.9 && < 5
                      , megaparsec >= 6.2 && < 7
                      , scientific >= 0.3 && < 1
                      , time >= 1.6 && < 2
                      , network-uri >= 2.6 && < 3
+                     , pipes >= 4.3 && < 5
   default-language:    Haskell2010
   ghc-options:         -Wall
 
-- 
cgit v1.2.3