module Highlight.Common.Monad.Output
( Output(..)
, handleInputData
, runOutputProducer
) where
import Prelude ()
import Prelude.Compat
import Control.Exception (IOException)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.State (MonadState, StateT, evalStateT, get)
import Control.Monad.Trans.Class (lift)
import Data.ByteString (ByteString)
import Pipes
(Consumer, Pipe, Producer, Producer', Proxy, (>->), await, each,
runEffect, yield)
import Pipes.ByteString (stdout)
import Highlight.Common.Monad.Input
(FilenameHandlingFromFiles, FileOrigin,
FileReader(FileReaderErr, FileReaderSuccess),
InputData(InputData), getFileOriginFromFileReader,
getFilePathFromFileReader)
import Highlight.Pipes (stderrConsumer)
import Highlight.Util
(convertStringToRawByteString, modify', whenNonNull)
type ColorNum = Int
data FileColorState
= FileColorState !(Maybe FileOrigin) !ColorNum
deriving (Eq, Read, Show)
defFileColorState :: FileColorState
defFileColorState = FileColorState Nothing 0
handleInputData
:: forall m.
MonadIO m
=> (ByteString -> m [ByteString])
-> (FilenameHandlingFromFiles
-> ByteString
-> Int
-> ByteString
-> m [ByteString]
)
-> (ByteString -> IOException -> Maybe IOException -> m [ByteString])
-> InputData m ()
-> Producer Output m ()
handleInputData stdinF nonErrF errF (InputData nameHandling producer) =
producer >-> evalStateT go defFileColorState
where
go :: StateT FileColorState (Pipe (FileReader ByteString) Output m) ()
go = do
fileReader <- lift await
let maybeFilePath = getFilePathFromFileReader fileReader
fileOrigin = getFileOriginFromFileReader fileReader
colorNumIfNewFile <- getColorNumIfNewFileM fileOrigin
case maybeFilePath of
Nothing ->
case fileReader of
FileReaderSuccess _ line -> do
outByteStrings <- lift . lift $ stdinF line
toStdoutWhenNonNull outByteStrings fileOrigin
FileReaderErr _ _ _ -> return ()
Just filePath -> do
byteStringFilePath <- convertStringToRawByteString filePath
case fileReader of
FileReaderErr _ ioerr maybeioerr -> do
outByteStrings <-
lift . lift $ errF byteStringFilePath ioerr maybeioerr
toStderrWhenNonNull outByteStrings
FileReaderSuccess _ inputLine -> do
outByteStrings <-
lift . lift $
nonErrF
nameHandling
byteStringFilePath
colorNumIfNewFile
inputLine
toStdoutWhenNonNull outByteStrings fileOrigin
go
toStdoutWhenNonNull
:: forall m x' x.
Monad m
=> [ByteString]
-> FileOrigin
-> StateT FileColorState (Proxy x' x () Output m) ()
toStdoutWhenNonNull outByteStrings fileOrigin =
whenNonNull outByteStrings $ do
lift $ toStdoutWithNewline outByteStrings
updateColorNumM fileOrigin
toStderrWhenNonNull
:: forall m s x' x.
Monad m
=> [ByteString] -> StateT s (Proxy x' x () Output m) ()
toStderrWhenNonNull outByteStrings =
whenNonNull outByteStrings . lift $ toStderrWithNewline outByteStrings
updateColorNumM
:: MonadState FileColorState m => FileOrigin -> m ()
updateColorNumM = modify' . updateColorNum
updateColorNum
:: FileOrigin
-> FileColorState
-> FileColorState
updateColorNum newFileOrigin (FileColorState Nothing colorNum) =
FileColorState (Just newFileOrigin) colorNum
updateColorNum newFileOrigin (FileColorState (Just prevFileOrigin) colorNum)
| prevFileOrigin == newFileOrigin =
FileColorState (Just newFileOrigin) colorNum
| otherwise = FileColorState (Just newFileOrigin) (colorNum + 1)
getColorNumIfNewFileM
:: MonadState FileColorState m
=> FileOrigin -> m ColorNum
getColorNumIfNewFileM newFileOrigin = do
fileColorState <- get
let (FileColorState _ colorNum) = updateColorNum newFileOrigin fileColorState
return colorNum
toStderrWithNewline :: Monad m => [ByteString] -> Producer' Output m ()
toStderrWithNewline = toOutputWithNewline OutputStderr
toStdoutWithNewline :: Monad m => [ByteString] -> Producer' Output m ()
toStdoutWithNewline = toOutputWithNewline OutputStdout
toOutputWithNewline
:: Monad m
=> (ByteString -> Output)
-> [ByteString]
-> Producer' Output m ()
toOutputWithNewline _ [] = return ()
toOutputWithNewline byteStringToOutput byteStrings = do
each $ fmap byteStringToOutput byteStrings
yield $ byteStringToOutput "\n"
data Output
= OutputStdout !ByteString
| OutputStderr !ByteString
deriving (Eq, Read, Show)
outputConsumer :: MonadIO m => Consumer Output m ()
outputConsumer = do
output <- await
case output of
OutputStdout byteString ->
yield byteString >-> stdout
OutputStderr byteString ->
yield byteString >-> stderrConsumer
outputConsumer
runOutputProducer :: forall m. MonadIO m => Producer Output m () -> m ()
runOutputProducer producer = runEffect $ producer >-> outputConsumer