scc-0.1: 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
(-- * IO components
fromFile, fromHandle, fromStdIn,
appendFile, toFile, toHandle, toStdOut, toPrint,
-- * Generic transducers
asis, suppress, erroneous,
prepend, append, substitute,
-- * Generic splitters
allTrue, allFalse, 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
)
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)
-- | Consumer 'toStdOut' copies the given source into the standard output.
toStdOut :: Consumer IO Char ()
toStdOut source = getSuccess source (\x-> liftPipe (putChar x) >> toStdOut source)
toPrint :: forall x. (Show x, Typeable x) => Consumer IO x ()
toPrint source = getSuccess source (\x-> liftPipe (print x) >> toPrint source)
-- | Producer 'fromStdIn' feeds the given sink from the standard input.
fromStdIn :: Producer IO Char ()
fromStdIn sink = do readyInput <- liftM not (liftPipe isEOF)
readyOutput <- canPut sink
when (readyInput && readyOutput) (liftPipe getChar >>= put sink >> fromStdIn sink)
-- | Producer 'fromFile' opens the named file and feeds the given sink from its contents.
fromFile :: String -> Producer IO Char ()
fromFile path sink = liftPipe (openFile path ReadMode) >>= flip fromHandle sink
-- | Producer 'fromHandle' feeds the given sink from the open file /handle/.
fromHandle :: Handle -> Producer IO Char ()
fromHandle handle sink = producer
where producer = do readyInput <- liftM not (liftPipe (hIsEOF handle))
readyOutput <- canPut sink
when (readyInput && readyOutput) (liftPipe (hGetChar handle) >>= put sink >> producer)
-- | Consumer 'toFile' opens the named file and copies the given source into it.
toFile :: String -> Consumer IO Char ()
toFile path source = liftPipe (openFile path WriteMode) >>= flip toHandle source
-- | Consumer 'appendFile' opens the name file and appends the given source to it.
appendFile :: String -> Consumer IO Char ()
appendFile path source = liftPipe (openFile path AppendMode) >>= flip toHandle source
-- | Consumer 'toHandle' copies the given source into the open file /handle/.
toHandle :: Handle -> Consumer IO Char ()
toHandle handle source = getSuccess source (\x-> liftPipe (hPutChar handle x) >> toHandle handle source)
-- | Transducer 'asis' passes its input through unmodified.
asis :: (Monad m, Typeable x) => Transducer m x x
asis = Transducer (\source sink-> pour source sink >> return [])
-- | The 'suppress' transducer suppresses all input it receives. It is equivalent to 'substitute' []
suppress :: (Monad m, Typeable x, Typeable y) => Transducer m x y
suppress = liftStatelessTransducer (const [])
-- | The 'erroneous' transducer reports an error if any input reaches it.
erroneous :: (Monad m, Typeable x) => Transducer m x x
erroneous = liftStatelessTransducer (\x-> error "Erroneous.")
-- | The 'lowercase' transforms all uppercase letters in the input to lowercase, leaving the rest unchanged.
lowercase :: Monad m => Transducer m Char Char
lowercase = lift121Transducer toLower
-- | The 'uppercase' transforms all lowercase letters in the input to uppercase, leaving the rest unchanged.
uppercase :: Monad m => Transducer m Char Char
uppercase = lift121Transducer toUpper
-- | Transducer 'prepend' passes its input unmodified, except for prepending contents of the given list parameter before
-- it.
prepend :: (Monad m, Typeable x) => [x] -> Transducer m x x
prepend prefix = Transducer (\source sink-> putList prefix sink >>= whenNull (pour source sink >> return []))
-- | Transducer 'append' passes its input unmodified, except for appending contents of the given list parameter to
-- its end.
append :: (Monad m, Typeable x) => [x] -> Transducer m x x
append suffix = Transducer (\source sink-> do pour source sink
putList suffix sink
return [])
-- | The 'substitute' transducer replaces its whole input by its parameter.
substitute :: (Monad m, Typeable x, Typeable y) => [y] -> Transducer m x y
substitute list = Transducer (\source sink-> consumeAndSuppress source >> putList list sink >> return [])
-- | The 'count' transducer counts all its input values and outputs the final tally.
count :: (Monad m, Typeable x) => Transducer m x Integer
count = Transducer (\source sink-> let t count = get source
>>= maybe
(put sink count >> return [])
(\_-> t (succ count))
in canPut sink >>= cond (t 0) (return []))
toString :: (Monad m, Show x, Typeable x) => Transducer m x String
toString = lift121Transducer show
-- | Transducer 'group' collects all its input values into a single list.
group :: (Monad m, Typeable x) => Transducer m x [x]
group = Transducer (\source sink-> let group q = get source
>>= maybe
(let list = Foldable.toList (Seq.viewl q)
in put sink list
>>= cond
(return [])
(return list))
(\x-> group (q |> x))
in group Seq.empty)
-- | Transducer 'concatenate' flattens the input stream of lists of values into the output stream of values.
concatenate :: (Monad m, Typeable x) => Transducer m [x] x
concatenate = liftStatelessTransducer id
concatSeparate :: (Monad m, Typeable x) => [x] -> Transducer m [x] x
concatSeparate separator = Transducer (\source sink-> let t = canPut sink
>>= cond
(get source
>>= maybe
(return [])
(\xs-> do putList separator sink
putList xs sink
t))
(return [])
in get source
>>= maybe
(return [])
(\xs-> putList xs sink >> t))
-- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.
whitespace :: Monad m => Splitter m Char
whitespace = liftStatelessSplitter isSpace
-- | Splitter 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into /false/.
letters :: Monad m => Splitter m Char
letters = liftStatelessSplitter isAlpha
-- | Splitter 'digits' feeds all digits into its /true/ sink, all other characters into /false/.
digits :: Monad m => Splitter m Char
digits = liftStatelessSplitter isDigit
-- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.
nonEmptyLine :: Monad m => Splitter m Char
nonEmptyLine = liftStatelessSplitter (\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 :: Monad m => Splitter m Char
line = liftSectionSplitter (\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 'allTrue' feeds its entire input into its /true/ sink.
allTrue :: (Monad m, Typeable x) => Splitter m x
allTrue = liftStatelessSplitter (const True)
-- | Splitter 'allFalse' feeds its entire input into its /false/ sink.
allFalse :: (Monad m, Typeable x) => Splitter m x
allFalse = liftStatelessSplitter (const False)
-- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
one :: (Monad m, Typeable x) => Splitter m x
one = liftSectionSplitter (\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 :: (Monad m, Eq x, Typeable x) => [x] -> Splitter m x
substring = substringPrim 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 :: (Monad m, Eq x, Typeable x) => [x] -> Splitter m x
substringMatch = substringPrim True
substringPrim _ [] = liftSectionSplitter (\ source true false ->
do put true Nothing
rest <- splitSections one source false true
put true Nothing
return rest)
substringPrim overlap list
= liftSectionSplitter $
\ 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