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)
import Control.Category ((>>>))
import Control.Exception (assert)
import Control.Monad (liftM, when, unless)
import Control.Monad.Trans.Class (lift)
import qualified Control.Monad as Monad
import Data.ByteString (ByteString)
import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)
import Data.List (delete, isPrefixOf, stripPrefix)
import Data.Maybe (fromJust)
import qualified Data.ByteString as ByteString
import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq
import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)), ViewR (EmptyR, (:>)))
import Debug.Trace (trace)
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
getLine, hGetLine, hPutStr, hFlush, hIsEOF, hClose, putStr, isEOF, stdout)
import Control.Cofunctor.Ticker (tickPrefixOf)
import Control.Monad.Coroutine
import Control.Monad.Coroutine.SuspensionFunctors
import Control.Monad.Coroutine.Nested
import Control.Concurrent.SCC.Streams
import Control.Concurrent.SCC.Types
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 []) (liftM (++ "\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 []) (liftM (++ "\n") $ hGetLine handle)))
fromBinaryHandle :: Handle -> Int -> Producer IO ByteString ()
fromBinaryHandle handle chunkSize = Producer produce
where produce sink = lift (ByteString.hGet handle chunkSize)
>>= \chunk-> unless (ByteString.null chunk) (tryPut sink chunk >>= flip when (produce 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 y. 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 (\count _-> succ count) 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) . line)
line c = put boundaries ()
>> if c == '\r' || c == '\n'
then lineEnd c
else pourUntil (\x-> x == '\n' || x == '\r') source true
>>= maybe (return ()) lineEnd
lineEnd '\n' = pourTicked (tickPrefixOf "\n\r") source false
lineEnd '\r' = pourTicked (tickPrefixOf "\r\n") 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 y)) = (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 y. (Monad m, Eq x) => [x] -> Parser m x OccurenceTag
parseSubstring [] = Transducer $ \ source sink ->
put sink marker >> mapMStream_ (\x-> put sink (Content x) >> put sink marker) source
where marker = Markup (Point (toEnum 1))
parseSubstring list
= Transducer $
\ source sink ->
let findFirst = pourUntil (== head list) source (mapSink Content sink)
>>= maybe (return ()) (const test)
test = getTicked (tickPrefixOf list) source
>>= \prefix-> let Just rest = stripPrefix prefix list
head:tail = map Content list
in if null rest
then put sink (Markup (Start (toEnum 0)))
>> put sink head
>> fallback 0 (Seq.fromList tail |> Markup (End (toEnum 0)))
else getNext 0 rest (Seq.fromList $ map Content prefix)
getNext id rest q = get source
>>= maybe
(flush q)
(advance id rest q)
advance id rest@(head:tail) q x = let q' = q |> Content x
view@(qh@Content{} :< qt) = Seq.viewl q'
id' = succ id
in if x == head
then if null tail
then put sink (Markup (Start (toEnum id')))
>> put sink qh
>> (fallback id' (qt |> Markup (End (toEnum id'))))
else getNext id tail q'
else fallback id q'
fallback id q = case Seq.viewl q
of EmptyL -> findFirst
head@(Markup (End id')) :< tail -> put sink head
>> fallback
(if id == fromEnum id' then 0 else id)
tail
view@(head@Content{} :< tail) -> case stripPrefix (remainingContent q) list
of Just rest -> getNext id rest q
Nothing -> put sink head
>> fallback id tail
flush q = putQueue q sink >> return ()
remainingContent :: Seq (Markup OccurenceTag x) -> [x]
remainingContent q = extractContent (Seq.viewl q)
extractContent :: Foldable.Foldable f => f (Markup b x) -> [x]
extractContent = Foldable.concatMap (\e-> case e of {Content x -> [x]; _ -> []})
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
= Splitter $
\ source true false edge ->
let findFirst = pourUntil (== head list) source false
>>= maybe (return ()) (const test)
test = getTicked (tickPrefixOf list) source
>>= \prefix-> let Just rest = stripPrefix prefix list
head:tail = list
in if null rest
then put edge () >> put true head >> fallback (Seq.fromList tail) Seq.empty
else getNext rest Seq.empty (Seq.fromList prefix)
getNext rest qt qf = get source
>>= maybe
(putQueue qt true >> putQueue qf false >> return ())
(advance rest qt qf)
advance rest@(head:tail) qt qf x = let qf' = qf |> x
view@(qqh :< qqt) = Seq.viewl (qt >< qf')
in if x == head
then if null tail
then put edge ()
>> put true qqh
>> fallback qqt Seq.empty
else getNext tail qt qf'
else fallback qt qf'
fallback qt qf = case Seq.viewl (qt >< qf)
of EmptyL -> findFirst
view@(head :< tail) -> case stripPrefix (Foldable.toList view) list
of Just rest -> getNext rest qt qf
Nothing -> if Seq.null qt
then put false head
>> fallback Seq.empty tail
else put true head
>> fallback (Seq.drop 1 qt) qf
in findFirst
cond :: a -> a -> Bool -> a
cond x y test = if test then x else y