module Control.Concurrent.SCC.Primitives
(
OccurenceTag,
fromList, toList,
fromFile, fromHandle, fromStdIn,
appendFile, toFile, toHandle, toStdOut,
suppress, erroneous,
parse, unparse, parseSubstring,
everything, nothing, marked, markedContent, markedWith, contentMarkedWith, one, substring,
group, concatenate, concatSeparate,
lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
count, toString
)
where
import Prelude hiding (appendFile)
import Control.Monad.Coroutine
import Control.Concurrent.SCC.Streams
import Control.Concurrent.SCC.Types
import Control.Exception (assert)
import Control.Monad (liftM, when)
import Control.Monad.Trans (lift)
import qualified Control.Monad as Monad
import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)
import Data.List (delete, 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 Debug.Trace (trace)
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
hGetChar, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)
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 (putList l)
toStdOut :: Consumer IO Char ()
toStdOut = Consumer (mapMStream_ (\x-> lift (putChar x)))
fromStdIn :: Producer IO Char ()
fromStdIn = Producer (unmapMStream_ (lift isEOF >>= cond (return Nothing) (lift (liftM Just getChar))))
fromFile :: String -> Producer IO Char ()
fromFile path = Producer $ \sink-> do handle <- lift (openFile path ReadMode)
produce (fromHandle handle True) sink
fromHandle :: Handle -> Bool -> Producer IO Char ()
fromHandle handle doClose = Producer (\sink-> unmapMStream_ (lift hGetCharMaybe) sink
>> when doClose (lift $ hClose handle))
where hGetCharMaybe = hIsEOF handle >>= cond (return Nothing) (liftM Just $ hGetChar handle)
toFile :: String -> Consumer IO Char ()
toFile path = Consumer $ \source-> do handle <- lift (openFile path WriteMode)
consume (toHandle handle True) source
appendFile :: String -> Consumer IO Char ()
appendFile path = Consumer $ \source-> do handle <- lift (openFile path AppendMode)
consume (toHandle handle True) source
toHandle :: Handle -> Bool -> Consumer IO Char ()
toHandle handle doClose = Consumer (\source-> mapMStream_ (lift . hPutChar handle) source
>> when doClose (lift $ hClose handle))
unparse :: forall m x y. Monad m => Transducer m (Markup y 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 (mapMStream_ (const $ return ()))
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-> foldStream (|>) Seq.empty source >>= put sink . Foldable.toList)
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 split Nothing x = put boundaries () >> handle x
split (Just '\n') x@'\r' = put false x >> return Nothing
split (Just '\r') x@'\n' = put false x >> return Nothing
split (Just '\n') x = split Nothing x
split (Just '\r') x = split Nothing x
split (Just _) x = handle x
handle x = (if x == '\n' || x == '\r'
then put false x
else put true x)
>> return (Just x)
in foldMStream_ split Nothing source
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 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 -> getNext id list q
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
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 getNext 0 list Seq.empty
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 getNext rest qt qf = get source
>>= maybe
(putList (Foldable.toList (Seq.viewl qt)) true
>> putList (Foldable.toList (Seq.viewl qf)) false)
(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 -> getNext list Seq.empty Seq.empty
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 getNext list Seq.empty Seq.empty