highlight-0.1.0.0: src/Highlight/Common/Monad/Input.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
module Highlight.Common.Monad.Input
( FileOrigin(..)
, FileReader(..)
, getFileOriginFromFileReader
, getFilePathFromFileReader
, InputData(..)
, createInputData
, FilenameHandlingFromFiles(..)
) where
import Prelude ()
import Prelude.Compat
import Control.Exception (IOException, try)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.ByteString (ByteString)
import Data.List (sort)
import Pipes
(Pipe, Producer, Producer', Proxy, (>->), await, each, for, next,
yield)
import Pipes.Prelude (toListM)
import qualified Pipes.Prelude as Pipes
import System.IO (Handle)
import Highlight.Common.Options
(InputFilename(unInputFilename), Recursive(Recursive))
import Highlight.Pipes (childOf, fromHandleLines)
import Highlight.Util (combineApplicatives, openFilePathForReading)
-----------
-- Pipes --
-----------
-- | Place where a file originally came from.
data FileOrigin
= FileSpecifiedByUser FilePath
-- ^ File was specified on the command line by the user.
| FileFoundRecursively FilePath
-- ^ File was found recursively (not directly specified by the user).
| Stdin
-- ^ Standard input. It was either specified on the command line as @-@, or
-- used as default because the user did not specify any files.
deriving (Eq, Read, Show)
-- | Get a 'FilePath' from a 'FileOrigin'.
--
-- >>> getFilePathFromFileOrigin $ FileSpecifiedByUser "hello.txt"
-- Just "hello.txt"
-- >>> getFilePathFromFileOrigin $ FileFoundRecursively "bye.txt"
-- Just "bye.txt"
-- >>> getFilePathFromFileOrigin Stdin
-- Nothing
getFilePathFromFileOrigin :: FileOrigin -> Maybe FilePath
getFilePathFromFileOrigin (FileSpecifiedByUser fp) = Just fp
getFilePathFromFileOrigin (FileFoundRecursively fp) = Just fp
getFilePathFromFileOrigin Stdin = Nothing
-- | This is used in two different places.
--
-- One is in 'fileListProducer', where @a@ becomes 'Handle'. This represents a
-- single file that has been opened. 'FileReaderSuccess' contains the
-- 'FileOrigin' and the 'Handle'. 'FileReaderErr' contains the 'FileOrigin'
-- and any errors that occurred when trying to open the 'Handle'.
--
-- The other is in 'fileReaderHandleToLine' and 'InputData', where @a@ becomes
-- 'ByteString'. This represents a single 'ByteString' line from a file, or an
-- error that occurred when trying to read the file.
--
-- 'FileReader' is usually wrapped in a 'Producer'. This is a stream of either
-- 'Handle's or 'ByteString' lines (with any errors that have occurred).
data FileReader a
= FileReaderSuccess !FileOrigin !a
| FileReaderErr !FileOrigin !IOException !(Maybe IOException)
deriving (Eq, Show)
-- | Get a 'FileOrigin' from a 'FileReader'.
--
-- >>> let fileOrigin1 = FileSpecifiedByUser "hello.txt"
-- >>> let fileReader1 = FileReaderSuccess fileOrigin1 "some line"
-- >>> getFileOriginFromFileReader fileReader1
-- FileSpecifiedByUser "hello.txt"
--
-- >>> let fileOrigin2 = FileFoundRecursively "bye.txt"
-- >>> let fileReader2 = FileReaderErr fileOrigin2 (userError "err") Nothing
-- >>> getFileOriginFromFileReader fileReader2
-- FileFoundRecursively "bye.txt"
getFileOriginFromFileReader :: FileReader a -> FileOrigin
getFileOriginFromFileReader (FileReaderSuccess origin _) = origin
getFileOriginFromFileReader (FileReaderErr origin _ _) = origin
-- | This is just
-- @'getFilePathFromFileOrigin' '.' 'getFileOriginFromFileReader'@.
--
-- >>> let fileOrigin1 = Stdin
-- >>> let fileReader1 = FileReaderSuccess fileOrigin1 "some line"
-- >>> getFilePathFromFileReader fileReader1
-- Nothing
--
-- >>> let fileOrigin2 = FileFoundRecursively "bye.txt"
-- >>> let fileReader2 = FileReaderErr fileOrigin2 (userError "err") Nothing
-- >>> getFilePathFromFileReader fileReader2
-- Just "bye.txt"
getFilePathFromFileReader :: FileReader a -> Maybe FilePath
getFilePathFromFileReader =
getFilePathFromFileOrigin . getFileOriginFromFileReader
-- | This wraps up two pieces of information.
--
-- One is the value of 'FilenameHandlingFromFiles'. This signals as to whether
-- or not we need to print the filename when printing each line of output.
--
-- This other is a 'Producer' of 'FileReader' 'ByteString's. This is a
-- 'Producer' for each line of each input file.
--
-- The main job of this module is to define 'createInputData', which produces
-- 'InputData'. 'InputData' is what is processed to figure out what to output.
data InputData m a
= InputData
!FilenameHandlingFromFiles
!(Producer (FileReader ByteString) m a)
-- | Create 'InputData' based 'InputFilename' list.
--
-- Setup for examples:
--
-- >>> :set -XOverloadedStrings
-- >>> import Highlight.Common.Options (InputFilename(InputFilename))
-- >>> import Highlight.Common.Options (Recursive(NotRecursive))
--
-- If the 'InputFilename' list is empty, just create an 'InputData' with
-- 'NoFilename' and the standard input 'Producer' passed in.
--
-- >>> let stdinProd = yield ("hello" :: ByteString)
-- >>> let create = createInputData NotRecursive [] stdinProd
-- >>> InputData NoFilename prod <- create
-- >>> toListM prod
-- [FileReaderSuccess Stdin "hello"]
--
-- If the 'InputFilename' list is not empty, create an 'InputData' with lines
-- from each file found on the command line.
--
-- >>> let inFiles = [InputFilename "test/golden/test-files/file1"]
-- >>> let create = createInputData NotRecursive inFiles stdinProd
-- >>> InputData NoFilename prod <- create
-- >>> Pipes.head prod
-- Just (FileReaderSuccess (FileSpecifiedByUser "test/golden/test-files/file1") "The...")
createInputData
:: forall m.
MonadIO m
=> Recursive
-- ^ Whether or not to recursively read in files.
-> [InputFilename]
-- ^ List of files passed in on the command line.
-> Producer ByteString m ()
-- ^ A producer for standard input
-> m (InputData m ())
createInputData recursive inputFilenames stdinProducer = do
let fileOrigins = FileSpecifiedByUser . unInputFilename <$> inputFilenames
case fileOrigins of
[] ->
return $
InputData NoFilename (stdinProducerToFileReader stdinProducer)
_ -> do
let fileListProducers = fmap (fileListProducer recursive) fileOrigins
fileProducer = foldl1 combineApplicatives fileListProducers
(filenameHandling, newFileProducer) <-
computeFilenameHandlingFromFiles fileProducer
let fileLineProducer = fileReaderHandleToLine newFileProducer
return $ InputData filenameHandling fileLineProducer
-- | Change a given 'Producer' into a 'FileReader' 'Producer' with the
-- 'FileOrigin' set to 'Stdin'.
--
-- You can think of this function as having the following type:
--
-- @
-- 'stdinProducerToFileReader'
-- :: 'Monad' m
-- => 'Producer' a m r
-- -> 'Producer' ('FileReader' a) m r
-- @
--
-- >>> Pipes.head . stdinProducerToFileReader $ yield "hello"
-- Just (FileReaderSuccess Stdin "hello")
stdinProducerToFileReader
:: forall x' x a m r.
Monad m
=> Proxy x' x () a m r
-> Proxy x' x () (FileReader a) m r
stdinProducerToFileReader producer = producer >-> Pipes.map go
where
go :: a -> FileReader a
go = FileReaderSuccess Stdin
{-# INLINABLE stdinProducerToFileReader #-}
-- | Convert a 'Producer' of 'FileReader' 'Handle' into a 'Producer' of
-- 'FileReader' 'ByteString', where each line from the 'Handle' is 'yield'ed.
--
-- You can think of this function as having the following type:
--
-- @
-- 'fileReaderHandleToLine'
-- :: 'MonadIO' m
-- => 'Producer' ('FileReader' 'Handle') m r
-- -> 'Producer' ('FileReader' 'ByteString') m r
-- @
--
-- >>> let fileOrigin = FileSpecifiedByUser "test/golden/test-files/file2"
-- >>> let producer = fileListProducer Recursive fileOrigin
-- >>> Pipes.head $ fileReaderHandleToLine producer
-- Just (FileReaderSuccess (FileSpecifiedByUser "test/golden/test-files/file2") "Pr...
fileReaderHandleToLine
:: forall m x' x r.
MonadIO m
=> Proxy x' x () (FileReader Handle) m r
-> Proxy x' x () (FileReader ByteString) m r
fileReaderHandleToLine producer = producer >-> pipe
where
pipe :: Pipe (FileReader Handle) (FileReader ByteString) m r
pipe = do
fileReaderHandle <- await
case fileReaderHandle of
FileReaderErr fileOrigin fileErr dirErr ->
yield $ FileReaderErr fileOrigin fileErr dirErr
FileReaderSuccess fileOrigin handle -> do
let linesProducer = fromHandleLines handle
linesProducer >-> Pipes.map (FileReaderSuccess fileOrigin)
pipe
-- | Create a 'Producer' of 'FileReader' 'Handle' for a given 'FileOrigin'.
--
-- Setup for examples:
--
-- >>> import Highlight.Common.Options (Recursive(NotRecursive, Recursive))
--
-- If 'NoRecursive' is specified, just try to read 'FileOrigin' as a file.
--
-- >>> let fileOrigin1 = FileSpecifiedByUser "test/golden/test-files/file2"
-- >>> toListM $ fileListProducer NotRecursive fileOrigin1
-- [FileReaderSuccess (FileSpecifiedByUser "test/.../file2") {handle: test/.../file2}]
--
-- If the file cannot be read, return an error.
--
-- >>> let fileOrigin2 = FileSpecifiedByUser "thisfiledoesnotexist"
-- >>> toListM $ fileListProducer NotRecursive fileOrigin2
-- [FileReaderErr (FileSpecifiedByUser "thisfiledoesnotexist") thisfiledoesnotexist: openBinaryFile: does not exist (No such file or directory) Nothing]
--
-- If 'Recursive' is specified, then try to read 'FileOrigin' as a directory'.
--
-- >>> let fileOrigin3 = FileSpecifiedByUser "test/golden/test-files/dir2"
-- >>> toListM $ fileListProducer Recursive fileOrigin3
-- [FileReaderSuccess (FileFoundRecursively "test/.../dir2/file6") {handle: test/.../dir2/file6}]
--
-- If the directory cannot be read, return an error.
--
-- >>> let fileOrigin4 = FileSpecifiedByUser "thisdirdoesnotexist"
-- >>> toListM $ fileListProducer Recursive fileOrigin4
-- [FileReaderErr (FileSpecifiedByUser "thisdirdoesnotexist") thisdirdoesnotexist: openBinaryFile: does not exist (No such file or directory) (Just ...)]
fileListProducer
:: forall m.
MonadIO m
=> Recursive
-> FileOrigin
-> Producer' (FileReader Handle) m ()
fileListProducer recursive = go
where
go :: FileOrigin -> Producer' (FileReader Handle) m ()
go fileOrigin = do
let maybeFilePath = getFilePathFromFileOrigin fileOrigin
case maybeFilePath of
-- This is standard input. We don't currently handle this, so just
-- return unit.
Nothing -> return ()
-- This is a normal file. Not standard input.
Just filePath -> do
eitherHandle <- openFilePathForReading filePath
case eitherHandle of
Right handle -> yield $ FileReaderSuccess fileOrigin handle
Left fileIOErr ->
if recursive == Recursive
then do
let fileListM = toListM $ childOf filePath
eitherFileList <- liftIO $ try fileListM
case eitherFileList of
Left dirIOErr ->
yield $
FileReaderErr fileOrigin fileIOErr (Just dirIOErr)
Right fileList -> do
let sortedFileList = sort fileList
let fileOrigins = fmap FileFoundRecursively sortedFileList
let lalas =
fmap
(fileListProducer recursive)
fileOrigins
for (each lalas) id
else
yield $ FileReaderErr fileOrigin fileIOErr Nothing
-----------------------
-- Filename Handling --
-----------------------
-- | This data type specifies how printing filenames will be handled, along
-- with the 'computeFilenameHandlingFromFiles' function.
data FilenameHandlingFromFiles
= NoFilename -- ^ Do not print the filename on stdout.
| PrintFilename -- ^ Print the filename on stdout.
deriving (Eq, Read, Show)
-- | Given a 'Producer' of 'FileReader's, figure out whether or not we should
-- print the filename of the file to stdout.
--
-- The following examples walk through possible command lines using @highlight@, and the corresponding return values of this function.
--
-- @
-- $ highlight expression
-- @
--
-- We want to read from stdin. There should be no 'FileReaders' in the
-- 'Producer'. Do not print the filename.
--
-- >>> let producerStdin = each []
-- >>> (fhStdin, _) <- computeFilenameHandlingFromFiles producerStdin
-- >>> fhStdin
-- NoFilename
--
-- @
-- $ highlight expression file1
-- @
--
-- We want to highlight a single file. There should only be a single
-- 'FileReader' in the 'Producer', and it should be 'FileSpecifiedByUser'. Do
-- not print the filename.
--
-- >>> let fileOriginSingleFile = FileSpecifiedByUser "file1"
-- >>> let fileReaderSingleFile = FileReaderSuccess fileOriginSingleFile "hello"
-- >>> let producerSingleFile = each [fileReaderSingleFile]
-- >>> (fhSingleFile, _) <- computeFilenameHandlingFromFiles producerSingleFile
-- >>> fhSingleFile
-- NoFilename
--
-- @
-- $ highlight expression file1 file2
-- @
--
-- We want to highlight two files. Print the filename.
--
-- >>> let fileOriginMulti1 = FileSpecifiedByUser "file1"
-- >>> let fileReaderMulti1 = FileReaderSuccess fileOriginMulti1 "hello"
-- >>> let fileOriginMulti2 = FileSpecifiedByUser "file2"
-- >>> let fileReaderMulti2 = FileReaderSuccess fileOriginMulti2 "bye"
-- >>> let producerMultiFile = each [fileReaderMulti1, fileReaderMulti2]
-- >>> (fhMultiFile, _) <- computeFilenameHandlingFromFiles producerMultiFile
-- >>> fhMultiFile
-- PrintFilename
--
-- @
-- $ highlight -r expression dir1
-- @
--
-- We want to highlight all files found in @dir1\/@. Print filenames.
--
-- >>> let fileOriginRec = FileFoundRecursively "dir1/file1"
-- >>> let fileReaderRec = FileReaderSuccess fileOriginRec "cat"
-- >>> let producerRec = each [fileReaderRec]
-- >>> (fhRec, _) <- computeFilenameHandlingFromFiles producerRec
-- >>> fhRec
-- PrintFilename
computeFilenameHandlingFromFiles
:: forall a m r.
Monad m
=> Producer (FileReader a) m r
-> m (FilenameHandlingFromFiles, Producer (FileReader a) m r)
computeFilenameHandlingFromFiles producer1 = do
eitherFileReader1 <- next producer1
case eitherFileReader1 of
Left ret ->
return (NoFilename, return ret)
Right (fileReader1, producer2) -> do
let fileOrigin1 = getFileOriginFromFileReader fileReader1
case fileOrigin1 of
Stdin -> error "Not currenty handling stdin..."
FileSpecifiedByUser _ -> do
eitherSecondFile <- next producer2
case eitherSecondFile of
Left ret2 ->
return (NoFilename, yield fileReader1 *> return ret2)
Right (fileReader2, producer3) ->
return
( PrintFilename
, yield fileReader1 *> yield fileReader2 *> producer3
)
FileFoundRecursively _ ->
return (PrintFilename, yield fileReader1 *> producer2)