module Control.Concurrent.SCC.Primitives (
fromFile, fromHandle, fromStdIn, fromBinaryHandle,
appendFile, toFile, toHandle, toStdOut, toBinaryHandle,
fromList,
suppress, erroneous, toList,
parse, unparse, parseSubstring, OccurenceTag, count, toString,
group, concatenate, concatSeparate,
everything, nothing, marked, markedContent, markedWith, contentMarkedWith, one, substring,
lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
)
where
import Prelude hiding (appendFile, head, tail)
import Control.Applicative (Alternative ((<|>)))
import Control.Exception (assert)
import Control.Monad (forM_, unless, when)
import Control.Monad.Trans.Class (lift)
import Data.ByteString (ByteString)
import Data.Char (isAlpha, isDigit, isSpace, toLower, toUpper)
import Data.List (delete, stripPrefix)
import qualified Data.ByteString as ByteString
import qualified Data.Foldable as Foldable
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode),
openFile, hClose, hGetLine, hPutStr, hIsEOF, hClose, isEOF)
import Text.ParserCombinators.Incremental (string, takeWhile, (<<|>))
import Control.Concurrent.SCC.Streams
import Control.Concurrent.SCC.Types
import Debug.Trace (trace)
toList :: forall m x. Monad m => Consumer m x [x]
toList = Consumer getList
fromList :: forall m x. Monad m => [x] -> Producer m x ()
fromList l = Producer ((>> return ()) . putList l)
toStdOut :: Consumer IO Char ()
toStdOut = Consumer (mapMStreamChunks_ (lift . putStr))
fromStdIn :: Producer IO Char ()
fromStdIn = Producer (unmapMStreamChunks_ (lift $ isEOF >>= cond (return []) (fmap (++ "\n") getLine)))
fromFile :: String -> Producer IO Char ()
fromFile path = Producer $ \sink-> do handle <- lift (openFile path ReadMode)
produce (fromHandle handle) sink
lift (hClose handle)
fromHandle :: Handle -> Producer IO Char ()
fromHandle handle = Producer (unmapMStreamChunks_
(lift $ hIsEOF handle >>= cond (return []) (fmap (++ "\n") $ hGetLine handle)))
fromBinaryHandle :: Handle -> Int -> Producer IO ByteString ()
fromBinaryHandle handle chunkSize = Producer p
where p sink = lift (ByteString.hGet handle chunkSize)
>>= \chunk-> unless (ByteString.null chunk) (tryPut sink chunk >>= flip when (p sink))
toFile :: String -> Consumer IO Char ()
toFile path = Consumer $ \source-> do handle <- lift (openFile path WriteMode)
consume (toHandle handle) source
lift (hClose handle)
appendFile :: String -> Consumer IO Char ()
appendFile path = Consumer $ \source-> do handle <- lift (openFile path AppendMode)
consume (toHandle handle) source
lift (hClose handle)
toHandle :: Handle -> Consumer IO Char ()
toHandle handle = Consumer (mapMStreamChunks_ (lift . hPutStr handle))
toBinaryHandle :: Handle -> Consumer IO ByteString ()
toBinaryHandle handle = Consumer (mapMStream_ (lift . ByteString.hPut handle))
unparse :: forall m x b. Monad m => Transducer m (Markup b x) x
unparse = statelessTransducer removeTag
where removeTag (Content x) = [x]
removeTag _ = []
parse :: forall m x y. Monad m => Transducer m x (Markup y x)
parse = oneToOneTransducer Content
suppress :: forall m x. Monad m => Consumer m x ()
suppress = Consumer (\(src :: Source m a x)-> pour src (nullSink :: Sink m a x))
erroneous :: forall m x. Monad m => String -> Consumer m x ()
erroneous message = Consumer (getWith (const (error message)))
lowercase :: forall m. Monad m => Transducer m Char Char
lowercase = oneToOneTransducer toLower
uppercase :: forall m. Monad m => Transducer m Char Char
uppercase = oneToOneTransducer toUpper
count :: forall m x. Monad m => Transducer m x Integer
count = Transducer (\source sink-> foldStream (\n _-> succ n) 0 source >>= put sink)
toString :: forall m x. (Monad m, Show x) => Transducer m x String
toString = oneToOneTransducer show
group :: forall m x. Monad m => Transducer m x [x]
group = Transducer (\source sink-> getList source >>= put sink)
concatenate :: forall m x. Monad m => Transducer m [x] x
concatenate = statelessTransducer id
concatSeparate :: forall m x. Monad m => [x] -> Transducer m [x] x
concatSeparate separator = statefulTransducer (\seen list-> (True, if seen then separator ++ list else list))
False
whitespace :: forall m. Monad m => Splitter m Char ()
whitespace = statelessSplitter isSpace
letters :: forall m. Monad m => Splitter m Char ()
letters = statelessSplitter isAlpha
digits :: forall m. Monad m => Splitter m Char ()
digits = statelessSplitter isDigit
nonEmptyLine :: forall m. Monad m => Splitter m Char ()
nonEmptyLine = statelessSplitter (\ch-> ch /= '\n' && ch /= '\r')
line :: forall m. Monad m => Splitter m Char ()
line = Splitter $ \source true false boundaries->
let loop = peek source >>= maybe (return ()) (( >> loop) . splitLine)
lineChar c = c /= '\r' && c /= '\n'
lineEndParser = string "\r\n" <<|> string "\n\r" <<|> string "\r" <<|> string "\n"
splitLine c = put boundaries ()
>> when (lineChar c) (pourWhile lineChar source true)
>> pourTicked lineEndParser source false
in loop
everything :: forall m x. Monad m => Splitter m x ()
everything = Splitter (\source true _false edge-> put edge () >> pour source true)
nothing :: forall m x. Monad m => Splitter m x ()
nothing = Splitter (\source _true false _edge-> pour source false)
one :: forall m x. Monad m => Splitter m x ()
one = Splitter (\source true _false edge-> mapMStream_ (\x-> put edge () >> put true x) source)
marked :: forall m x y. (Monad m, Eq y) => Splitter m (Markup y x) ()
marked = markedWith (const True)
markedContent :: forall m x y. (Monad m, Eq y) => Splitter m (Markup y x) ()
markedContent = contentMarkedWith (const True)
markedWith :: forall m x y. (Monad m, Eq y) => (y -> Bool) -> Splitter m (Markup y x) ()
markedWith select = statefulSplitter transition ([], False)
where transition s@([], _) Content{} = (s, False)
transition s@(_, truth) Content{} = (s, truth)
transition s@([], _) (Markup (Point y)) = (s, select y)
transition s@(_, truth) (Markup (Point _)) = (s, truth)
transition ([], _) (Markup (Start y)) = (([y], select y), select y)
transition (open, truth) (Markup (Start y)) = ((y:open, truth), truth)
transition (open, truth) (Markup (End y)) = assert (elem y open) ((delete y open, truth), truth)
contentMarkedWith :: forall m x y. (Monad m, Eq y) => (y -> Bool) -> Splitter m (Markup y x) ()
contentMarkedWith select = statefulSplitter transition ([], False)
where transition s@(_, truth) Content{} = (s, truth)
transition s@(_, truth) (Markup Point{}) = (s, truth)
transition ([], _) (Markup (Start y)) = (([y], select y), False)
transition (open, truth) (Markup (Start y)) = ((y:open, truth), truth)
transition (open, truth) (Markup (End y)) = assert (elem y open) (let open' = delete y open
truth' = not (null open') && truth
in ((open', truth'), truth'))
data OccurenceTag = Occurence Int deriving (Eq, Show)
instance Enum OccurenceTag where
succ (Occurence n) = Occurence (succ n)
pred (Occurence n) = Occurence (pred n)
toEnum = Occurence
fromEnum (Occurence n) = n
parseSubstring :: forall m x. (Monad m, Eq x) => [x] -> Parser m x OccurenceTag
parseSubstring [] = Transducer $
\ source sink -> put sink marker >> concatMapStream (\x-> [Content x, marker]) source sink
where marker = Markup (Point (toEnum 1))
parseSubstring list@(first:rest)
= Transducer $
\ source sink ->
let findFirst = pourWhile (/= first) source (mapSink Content sink)
>> test
test = getTicked (string list) source
>>= \s-> case s
of [] -> get source >>= maybe (return ()) (\x-> put sink (Content x) >> findFirst)
_ -> put sink (Markup (Start (toEnum 0)))
>> putList prefixContent sink
>> if null shared then put sink (Markup (End (toEnum 0))) >> findFirst
else testOverlap 0
testOverlap n = getTicked (string postfix) source
>>= \s-> case s
of [] -> forM_ [n maxOverlaps + 1 .. n]
(\i-> putList sharedContent sink
>> put sink (Markup (End (toEnum i))))
>> findFirst
_ -> let n' = succ n
in put sink (Markup (Start (toEnum n')))
>> putList prefixContent sink
>> when (n' >= maxOverlaps)
(put sink (Markup (End (toEnum (n' maxOverlaps)))))
>> testOverlap n'
(prefix, shared, postfix) = overlap list list
maxOverlaps = (length list 1) `div` length prefix
prefixContent = map Content prefix
sharedContent = map Content shared
in findFirst
substring :: forall m x. (Monad m, Eq x) => [x] -> Splitter m x ()
substring [] = Splitter $ \ source true false edge -> split one source false true edge >> put edge ()
substring list@(first:rest)
= Splitter $
\ source true false edge ->
let findFirst = pourWhile (/= first) source false
>> test
test = getTicked (string list) source
>>= \s-> case s
of [] -> get source >>= maybe (return ()) (\x-> put false x >> findFirst)
_ -> put edge ()
>> putList prefix true
>> if null shared then findFirst else testOverlap
testOverlap = getTicked (string postfix) source
>>= \s-> case s
of [] -> putList shared true >> findFirst
_ -> put edge ()
>> putList prefix true
>> testOverlap
(prefix, shared, postfix) = overlap list list
in findFirst
overlap :: Eq x => [x] -> [x] -> ([x], [x], [x])
overlap [] s = ([], [], s)
overlap (head:tail) s2 = case stripPrefix tail s2
of Just rest -> ([head], tail, rest)
Nothing -> let (o1, o2, o3) = overlap tail s2
in (head:o1, o2, o3)
cond :: a -> a -> Bool -> a
cond x y test = if test then x else y