module Control.Concurrent.SCC.Components
(
fromList, toList,
fromFile, fromHandle, fromStdIn,
appendFile, toFile, toHandle, toStdOut, toPrint,
suppress, erroneous,
asis,
everything, nothing, one, substring, substringMatch,
group, concatenate, concatSeparate,
lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
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
toList :: forall m x. (Monad m, Typeable x) => Consumer m x [x]
toList = liftAtomicConsumer "toList" 1 getList
fromList :: forall m x. (Monad m, Typeable x) => [x] -> Producer m x [x]
fromList l = liftAtomicProducer "fromList" 1 (putList l)
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
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
fromFile :: String -> Producer IO Char ()
fromFile path = liftAtomicProducer "fromFile" ioCost $ \sink-> do handle <- liftPipe (openFile path ReadMode)
produce (fromHandle handle True) sink
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))
toFile :: String -> Consumer IO Char ()
toFile path = liftAtomicConsumer "toFile" ioCost $ \source-> do handle <- liftPipe (openFile path WriteMode)
consume (toHandle handle True) source
appendFile :: String -> Consumer IO Char ()
appendFile path = liftAtomicConsumer "appendFile" ioCost $ \source-> do handle <- liftPipe (openFile path AppendMode)
consume (toHandle handle True) source
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
asis :: forall m x. (Monad m, Typeable x) => Transducer m x x
asis = lift121Transducer "asis" id
suppress :: forall m x y. (Monad m, Typeable x) => Consumer m x ()
suppress = liftAtomicConsumer "suppress" 1 consumeAndSuppress
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))
lowercase :: forall m. Monad m => Transducer m Char Char
lowercase = lift121Transducer "lowercase" toLower
uppercase :: forall m. Monad m => Transducer m Char Char
uppercase = lift121Transducer "uppercase" toUpper
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
group :: forall m x. (Monad m, Typeable x) => Transducer m x [x]
group = liftFoldTransducer "group" (|>) Seq.empty Foldable.toList
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
whitespace :: forall m. ParallelizableMonad m => Splitter m Char
whitespace = liftStatelessSplitter "whitespace" isSpace
letters :: forall m. ParallelizableMonad m => Splitter m Char
letters = liftStatelessSplitter "letters" isAlpha
digits :: forall m. ParallelizableMonad m => Splitter m Char
digits = liftStatelessSplitter "digits" isDigit
nonEmptyLine :: forall m. ParallelizableMonad m => Splitter m Char
nonEmptyLine = liftStatelessSplitter "nonEmptyLine" (\ch-> ch /= '\n' && ch /= '\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
everything :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
everything = liftStatelessSplitter "everything" (const True)
nothing :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
nothing = liftStatelessSplitter "nothing" (const False)
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
substring :: forall m x. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x
substring = substringPrim "substring" False
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