Debug.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Convenience module for debugging streams. Provides stream transformers
-- that wrap 'InputStream's and 'OutputStream's, sending a description of all
-- data to an 'OutputStream' for debugging.

module System.IO.Streams.Debug
 ( -- * Debuggers
   debugInput
 , debugOutput
 , debugInputBS
 , debugOutputBS
 ) where

------------------------------------------------------------------------------
import           Data.ByteString.Char8      (ByteString)
import qualified Data.ByteString.Char8      as S
------------------------------------------------------------------------------
import           System.IO.Streams.Internal (InputStream (..), OutputStream)
import qualified System.IO.Streams.Internal as Streams


------------------------------------------------------------------------------
debugInput ::
     (a -> ByteString)         -- ^ function to convert stream elements to
                               --   'ByteString'
  -> ByteString                -- ^ name of this debug stream, will be
                               --   prepended to debug output
  -> OutputStream ByteString   -- ^ stream the debug info will be sent to
  -> InputStream a             -- ^ input stream
  -> IO (InputStream a)
debugInput toBS name debugStream inputStream = return $ InputStream produce pb
  where
    produce = do
        m <- Streams.read inputStream
        Streams.write (Just $! describe m) debugStream
        return m

    pb c = do
        let s = S.concat [name, ": pushback: ", toBS c, "\n"]
        Streams.write (Just s) debugStream
        Streams.unRead c inputStream

    describe m = S.concat [name, ": got ", describeChunk m, "\n"]

    describeChunk Nothing = "EOF"
    describeChunk (Just s) = S.concat [ "chunk: ", toBS s ]


------------------------------------------------------------------------------
debugInputBS ::
     ByteString                -- ^ name of this debug stream, will be
                               --   prepended to debug output
  -> OutputStream ByteString   -- ^ stream the debug info will be sent to
  -> InputStream ByteString    -- ^ input stream
  -> IO (InputStream ByteString)
debugInputBS = debugInput condense


------------------------------------------------------------------------------
debugOutput :: (a -> ByteString)        -- ^ function to convert stream
                                        --   elements to 'ByteString'
            -> ByteString               -- ^ name of this debug stream, will be
                                        --   prepended to debug output
            -> OutputStream ByteString  -- ^ debug stream
            -> OutputStream a           -- ^ output stream
            -> IO (OutputStream a)
debugOutput toBS name debugStream outputStream =
    Streams.makeOutputStream f
  where
    f m = do
        Streams.write (Just $ describe m) debugStream
        Streams.write m outputStream

    describe m = S.concat [name, ": got ", describeChunk m, "\n"]

    describeChunk Nothing = "EOF"
    describeChunk (Just s) = S.concat [ "chunk: ", toBS s]


------------------------------------------------------------------------------
debugOutputBS ::
     ByteString                -- ^ name of this debug stream, will be
                               --   prepended to debug output
  -> OutputStream ByteString   -- ^ stream the debug info will be sent to
  -> OutputStream ByteString    -- ^ output stream
  -> IO (OutputStream ByteString)
debugOutputBS = debugOutput condense


------------------------------------------------------------------------------
condense :: ByteString -> ByteString
condense s | l < 32 = S.concat [ "\"", s, "\"" ]
           | otherwise = S.concat [
                           "\""
                         , S.take k s
                         , " ... "
                         , S.drop (l - k) s
                         , "\" ("
                         , S.pack (show l)
                         , " bytes)"
                         ]
  where
    k = 14
    l = S.length s