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.Exception (assert)
import Control.Monad (liftM, when, unless)
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 qualified Data.Sequence as Seq
import Data.Sequence (Seq, (|>), (><), ViewL (EmptyL, (:<)))
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode),
openFile, hClose, hGetLine, hPutStr, hIsEOF, hClose, isEOF)
import Control.Cofunctor.Ticker (tickPrefixOf)
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 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) . lineChar)
lineChar 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
lineEnd _ = error "Newline characters only please!"
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 >> mapMStream_ (\x-> put sink (Content x) >> put sink marker) source
where marker = Markup (Point (toEnum 1))
parseSubstring list@(first:_)
= Transducer $
\ source sink ->
let findFirst = pourUntil (== first) 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 i rest q = get source
>>= maybe (flush q) (advance i rest q)
advance _ [] _ _ = error "Can't advance on an empty list!"
advance i (head:tail) q x = let q' = q |> Content x
qh@Content{} :< qt = Seq.viewl q'
i' = succ i
in if x == head
then if null tail
then put sink (Markup (Start (toEnum i')))
>> put sink qh
>> (fallback i' (qt |> Markup (End (toEnum i'))))
else getNext i tail q'
else fallback i q'
fallback i q = case Seq.viewl q
of EmptyL -> findFirst
head@(Markup (End i')) :< tail -> put sink head
>> fallback
(if i == fromEnum i' then 0 else i)
tail
head@Content{} :< tail -> case stripPrefix (remainingContent q) list
of Just rest -> getNext i rest q
Nothing -> put sink head
>> fallback i tail
_ -> error "Only content and ends can be fallen back on!"
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@(first:_)
= Splitter $
\ source true false edge ->
let findFirst = pourUntil (== first) 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 [] _ _ _ = error "Can't advance on an empty list!"
advance (head:tail) qt qf x = let qf' = qf |> x
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