module Control.Concurrent.SCC.Components
(
fromFile, fromHandle, fromStdIn,
appendFile, toFile, toHandle, toStdOut, toPrint,
asis, suppress, erroneous,
prepend, append, substitute,
allTrue, allFalse, one, substring, substringMatch,
group, concatenate, concatSeparate,
lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
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)
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)
fromStdIn :: Producer IO Char ()
fromStdIn sink = do readyInput <- liftM not (liftPipe isEOF)
readyOutput <- canPut sink
when (readyInput && readyOutput) (liftPipe getChar >>= put sink >> fromStdIn sink)
fromFile :: String -> Producer IO Char ()
fromFile path sink = liftPipe (openFile path ReadMode) >>= flip fromHandle sink
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)
toFile :: String -> Consumer IO Char ()
toFile path source = liftPipe (openFile path WriteMode) >>= flip toHandle source
appendFile :: String -> Consumer IO Char ()
appendFile path source = liftPipe (openFile path AppendMode) >>= flip toHandle source
toHandle :: Handle -> Consumer IO Char ()
toHandle handle source = getSuccess source (\x-> liftPipe (hPutChar handle x) >> toHandle handle source)
asis :: (Monad m, Typeable x) => Transducer m x x
asis = Transducer (\source sink-> pour source sink >> return [])
suppress :: (Monad m, Typeable x, Typeable y) => Transducer m x y
suppress = liftStatelessTransducer (const [])
erroneous :: (Monad m, Typeable x) => Transducer m x x
erroneous = liftStatelessTransducer (\x-> error "Erroneous.")
lowercase :: Monad m => Transducer m Char Char
lowercase = lift121Transducer toLower
uppercase :: Monad m => Transducer m Char Char
uppercase = lift121Transducer toUpper
prepend :: (Monad m, Typeable x) => [x] -> Transducer m x x
prepend prefix = Transducer (\source sink-> putList prefix sink >>= whenNull (pour source sink >> return []))
append :: (Monad m, Typeable x) => [x] -> Transducer m x x
append suffix = Transducer (\source sink-> do pour source sink
putList suffix sink
return [])
substitute :: (Monad m, Typeable x, Typeable y) => [y] -> Transducer m x y
substitute list = Transducer (\source sink-> consumeAndSuppress source >> putList list sink >> return [])
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
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)
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))
whitespace :: Monad m => Splitter m Char
whitespace = liftStatelessSplitter isSpace
letters :: Monad m => Splitter m Char
letters = liftStatelessSplitter isAlpha
digits :: Monad m => Splitter m Char
digits = liftStatelessSplitter isDigit
nonEmptyLine :: Monad m => Splitter m Char
nonEmptyLine = liftStatelessSplitter (\ch-> ch /= '\n' && ch /= '\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)
allTrue :: (Monad m, Typeable x) => Splitter m x
allTrue = liftStatelessSplitter (const True)
allFalse :: (Monad m, Typeable x) => Splitter m x
allFalse = liftStatelessSplitter (const False)
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)
substring :: (Monad m, Eq x, Typeable x) => [x] -> Splitter m x
substring = substringPrim False
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