scc-0.2: Control/Concurrent/SCC/Components.hs
{-
Copyright 2008 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
version.
SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with SCC. If not, see
<http://www.gnu.org/licenses/>.
-}
-- | Module "Components" defines primitive components of 'Producer', 'Consumer', 'Transducer' and 'Splitter' types,
-- defined in the "Foundation" and "ComponentTypes" modules.
{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}
module Control.Concurrent.SCC.Components
(-- * List producers and consumers
fromList, toList,
-- * I/O producers and consumers
fromFile, fromHandle, fromStdIn,
appendFile, toFile, toHandle, toStdOut, toPrint,
-- * Generic consumers
suppress, erroneous,
-- * Generic transducers
asis,
-- * Generic splitters
everything, nothing, one, substring, substringMatch,
-- * List transducers
-- | The following laws hold:
--
-- * 'group' '>->' 'concatenate' == 'asis'
--
-- * 'concatenate' == 'concatSeparate' []
group, concatenate, concatSeparate,
-- * Character stream components
lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
-- * Oddballs
count, toString,
ioCost
)
where
import Control.Concurrent.SCC.Foundation
import Control.Concurrent.SCC.ComponentTypes
import Prelude hiding (appendFile, last)
import Control.Monad (liftM, when)
import qualified Control.Monad as Monad
import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)
import Data.List (isPrefixOf, stripPrefix)
import Data.Maybe (fromJust)
import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
import Data.Sequence (Seq, (|>), ViewL (EmptyL, (:<)))
import Data.Typeable (Typeable)
import Debug.Trace (trace)
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
hGetChar, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)
ioCost :: Int
ioCost = 5
-- | Consumer 'toList' copies the given source into a list.
toList :: forall m x. (Monad m, Typeable x) => Consumer m x [x]
toList = liftAtomicConsumer "toList" 1 getList
-- | 'fromList' produces the contents of the given list argument.
fromList :: forall m x. (Monad m, Typeable x) => [x] -> Producer m x [x]
fromList l = liftAtomicProducer "fromList" 1 (putList l)
-- | Consumer 'toStdOut' copies the given source into the standard output.
toStdOut :: Consumer IO Char ()
toStdOut = liftAtomicConsumer "toStdOut" ioCost $ \source-> let c = get source
>>= maybe (return ()) (\x-> liftPipe (putChar x) >> c)
in c
toPrint :: forall x. (Show x, Typeable x) => Consumer IO x ()
toPrint = liftAtomicConsumer "toPrint" ioCost $ \source-> let c = getSuccess source (\x-> liftPipe (print x) >> c)
in c
-- | Producer 'fromStdIn' feeds the given sink from the standard input.
fromStdIn :: Producer IO Char ()
fromStdIn = liftAtomicProducer "fromStdIn" ioCost $ \sink-> let p = do readyInput <- liftM not (liftPipe isEOF)
readyOutput <- canPut sink
when (readyInput && readyOutput) (liftPipe getChar
>>= put sink
>> p)
in p
-- | Producer 'fromFile' opens the named file and feeds the given sink from its contents.
fromFile :: String -> Producer IO Char ()
fromFile path = liftAtomicProducer "fromFile" ioCost $ \sink-> do handle <- liftPipe (openFile path ReadMode)
produce (fromHandle handle True) sink
-- | Producer 'fromHandle' feeds the given sink from the open file /handle/. The argument /doClose/ determines if
-- | /handle/ should be closed when the handle is consumed or the sink closed.
fromHandle :: Handle -> Bool -> Producer IO Char ()
fromHandle handle doClose = liftAtomicProducer "fromHandle" ioCost $
\sink-> (canPut sink
>>= flip when (let p = do eof <- liftPipe (hIsEOF handle)
when (not eof) (liftPipe (hGetChar handle)
>>= put sink
>>= flip when p)
in p)
>> when doClose (liftPipe $ hClose handle))
-- | Consumer 'toFile' opens the named file and copies the given source into it.
toFile :: String -> Consumer IO Char ()
toFile path = liftAtomicConsumer "toFile" ioCost $ \source-> do handle <- liftPipe (openFile path WriteMode)
consume (toHandle handle True) source
-- | Consumer 'appendFile' opens the name file and appends the given source to it.
appendFile :: String -> Consumer IO Char ()
appendFile path = liftAtomicConsumer "appendFile" ioCost $ \source-> do handle <- liftPipe (openFile path AppendMode)
consume (toHandle handle True) source
-- | Consumer 'toHandle' copies the given source into the open file /handle/. The argument /doClose/ determines if
-- | /handle/ should be closed once the entire source is consumed and copied.
toHandle :: Handle -> Bool -> Consumer IO Char ()
toHandle handle doClose = liftAtomicConsumer "toHandle" ioCost $ \source-> let c = get source
>>= maybe
(when doClose $ liftPipe $ hClose handle)
(\x-> liftPipe (hPutChar handle x) >> c)
in c
-- | Transducer 'asis' passes its input through unmodified.
asis :: forall m x. (Monad m, Typeable x) => Transducer m x x
asis = lift121Transducer "asis" id
-- | The 'suppress' transducer suppresses all input it receives. It is equivalent to 'substitute' []
suppress :: forall m x y. (Monad m, Typeable x) => Consumer m x ()
suppress = liftAtomicConsumer "suppress" 1 consumeAndSuppress
-- | The 'erroneous' transducer reports an error if any input reaches it.
erroneous :: forall m x. (Monad m, Typeable x) => String -> Consumer m x ()
erroneous message = liftAtomicConsumer "erroneous" 0 $ \source-> get source >>= maybe (return ()) (const (error message))
-- | The 'lowercase' transforms all uppercase letters in the input to lowercase, leaving the rest unchanged.
lowercase :: forall m. Monad m => Transducer m Char Char
lowercase = lift121Transducer "lowercase" toLower
-- | The 'uppercase' transforms all lowercase letters in the input to uppercase, leaving the rest unchanged.
uppercase :: forall m. Monad m => Transducer m Char Char
uppercase = lift121Transducer "uppercase" toUpper
-- | The 'count' transducer counts all its input values and outputs the final tally.
count :: forall m x. (Monad m, Typeable x) => Transducer m x Integer
count = liftFoldTransducer "count" (\count _-> succ count) 0 id
toString :: forall m x. (Monad m, Show x, Typeable x) => Transducer m x String
toString = lift121Transducer "toString" show
-- | Transducer 'group' collects all its input values into a single list.
group :: forall m x. (Monad m, Typeable x) => Transducer m x [x]
group = liftFoldTransducer "group" (|>) Seq.empty Foldable.toList
-- | Transducer 'concatenate' flattens the input stream of lists of values into the output stream of values.
concatenate :: forall m x. (Monad m, Typeable x) => Transducer m [x] x
concatenate = liftStatelessTransducer "concatenate" id
concatSeparate :: forall m x. (Monad m, Typeable x) => [x] -> Transducer m [x] x
concatSeparate separator = liftStatefulTransducer "concatSeparate"
(\seen list-> (True, if seen then separator ++ list else list))
False
-- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.
whitespace :: forall m. ParallelizableMonad m => Splitter m Char
whitespace = liftStatelessSplitter "whitespace" isSpace
-- | Splitter 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into /false/.
letters :: forall m. ParallelizableMonad m => Splitter m Char
letters = liftStatelessSplitter "letters" isAlpha
-- | Splitter 'digits' feeds all digits into its /true/ sink, all other characters into /false/.
digits :: forall m. ParallelizableMonad m => Splitter m Char
digits = liftStatelessSplitter "digits" isDigit
-- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.
nonEmptyLine :: forall m. ParallelizableMonad m => Splitter m Char
nonEmptyLine = liftStatelessSplitter "nonEmptyLine" (\ch-> ch /= '\n' && ch /= '\r')
-- | The sectioning splitter 'line' feeds line-ends into its /false/ sink, and line contents into /true/. A single
-- line-end can be formed by any of the character sequences \"\\n\", \"\\r\", \"\\r\\n\", or \"\\n\\r\".
line :: forall m. ParallelizableMonad m => Splitter m Char
line = liftAtomicSectionSplitter "line" 1 $
\source true false-> let split0 = get source >>= maybe (return []) split1
split1 x = if x == '\n' || x == '\r'
then split2 x
else lineChar x
split2 x = put false (Just x)
>>= cond
(get source
>>= maybe
(return [])
(\y-> if x == y
then emptyLine x
else if y == '\n' || y == '\r'
then split3 x
else lineChar y))
(return [x])
split3 x = put false (Just x)
>>= cond
(get source
>>= maybe
(return [])
(\y-> if y == '\n' || y == '\r'
then emptyLine y
else lineChar y))
(return [x])
emptyLine x = put true Nothing >>= cond (split2 x) (return [])
lineChar x = put true (Just x) >>= cond split0 (return [x])
in split0
-- | Splitter 'everything' feeds its entire input into its /true/ sink.
everything :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
everything = liftStatelessSplitter "everything" (const True)
-- | Splitter 'nothing' feeds its entire input into its /false/ sink.
nothing :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
nothing = liftStatelessSplitter "nothing" (const False)
-- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
one :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
one = liftAtomicSectionSplitter "one" 1 $
\source true false-> let split x = put true (Just x)
>>= cond (get source
>>= maybe
(return [])
(\x-> put false Nothing >> split x))
(return [x])
in get source >>= maybe (return []) split
-- | Splitter 'substring' feeds to its /true/ sink all input parts that match the contents of the given list
-- argument. If two overlapping parts of the input both match the argument, only the first one wins.
substring :: forall m x. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x
substring = substringPrim "substring" False
-- | Splitter 'substringMatch' feeds to its /true/ sink all input parts that match the contents of the given list
-- argument. If two overlapping parts of the input match the argument, both are considered /true/.
substringMatch :: forall m x. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x
substringMatch = substringPrim "substringMatch" True
substringPrim name _ [] = liftAtomicSectionSplitter name 1 $
\ source true false -> do put true Nothing
rest <- splitSections one source false true
put true Nothing
return rest
substringPrim name overlap list
= liftAtomicSectionSplitter name 1 $
\ source true false ->
let getNext rest q separate = get source
>>= maybe
(liftM (map fromJust) $
putList (map Just $ Foldable.toList (Seq.viewl q)) false)
(\x-> do when separate (put false Nothing >> return ())
advance rest q x)
advance rest@(head:tail) q x = if x == head
then if null tail
then liftM (map fromJust) (putList (map Just list) true)
>>= whenNull (if overlap
then fallback True (Seq.drop 1 q)
else getNext list Seq.empty True)
else getNext tail (q |> x) False
else fallback False (q |> x)
fallback committed q = case stripPrefix (Foldable.toList (Seq.viewl q)) list
of Just rest -> getNext rest q committed
Nothing -> let view@(head :< tail) = Seq.viewl q
in if committed
then fallback committed tail
else put false (Just head)
>>= cond
(fallback committed tail)
(return (Foldable.toList view))
in getNext list Seq.empty False