module Control.Concurrent.SCC.Primitives
(
OccurenceTag,
fromList, toList,
fromFile, fromHandle, fromStdIn,
appendFile, toFile, toHandle, toStdOut,
suppress, erroneous,
asis, 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.Concurrent.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 [x]
fromList l = Producer (putList l)
toStdOut :: Consumer IO Char ()
toStdOut = Consumer $
\source-> let c = get source
>>= maybe (return ()) (\x-> lift (putChar x) >> c)
in c
fromStdIn :: Producer IO Char ()
fromStdIn = Producer $
\sink-> let p = do readyInput <- liftM not (lift isEOF)
readyOutput <- canPut sink
when (readyInput && readyOutput) (lift getChar
>>= put sink
>> p)
in p
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-> (canPut sink
>>= flip when (let p = do eof <- lift (hIsEOF handle)
when (not eof) (lift (hGetChar handle)
>>= put sink
>>= flip when p)
in p)
>> when doClose (lift $ hClose 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-> let c = get source
>>= maybe
(when doClose $ lift $ hClose handle)
(\x-> lift (hPutChar handle x) >> c)
in c
asis :: forall m x. Monad m => Transducer m x x
asis = oneToOneTransducer id
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 consumeAndSuppress
erroneous :: forall m x. Monad m => String -> Consumer m x ()
erroneous message = Consumer $
\source-> get source >>= maybe (return ()) (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 = foldingTransducer (\count _-> succ count) 0 id
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 = foldingTransducer (|>) Seq.empty 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 split0 = get source >>= maybe (return []) split1
split1 x = if x == '\n' || x == '\r'
then split2 x
else lineChar x
split2 x = put false 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 x
>>= cond
(get source
>>= maybe
(return [])
(\y-> if y == '\n' || y == '\r'
then emptyLine y
else lineChar y))
(return [x])
emptyLine x = put boundaries () >>= cond (split2 x) (return [])
lineChar x = put true x >>= cond split0 (return [x])
in split0
everything :: forall m x. Monad m => Splitter m x ()
everything = Splitter $
\source true false edge-> do put edge ()
pour source true
return []
nothing :: forall m x. Monad m => Splitter m x ()
nothing = Splitter $
\source true false edge-> do pour source false
return []
one :: forall m x. Monad m => Splitter m x ()
one = Splitter $
\source true false edge-> let s = get source
>>= maybe
(return [])
(\x-> put edge ()
>>= cond
(put true x
>>= cond s (return [x]))
(return [x]))
in s
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 -> let next = get source
>>= maybe (return []) wrap
wrap x = put sink (Content x) >>= cond prepend (return [x])
prepend = put sink (Markup (Point (toEnum 1))) >>= cond next (return [])
in prepend
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')))
>>= cond
(put sink qh
>>= cond
(fallback id' (qt
|> Markup (End (toEnum id'))))
(return $ remainingContent q'))
(return $ remainingContent q')
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
>>= cond
(fallback
(if id == fromEnum id' then 0 else id)
tail)
(return $ remainingContent tail)
view@(head@Content{} :< tail) -> case stripPrefix (remainingContent q) list
of Just rest -> getNext id rest q
Nothing -> put sink head
>>= cond
(fallback id tail)
(return $ remainingContent q)
flush q = liftM extractContent $ putList (Foldable.toList $ Seq.viewl 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 -> do rest <- split one source false true edge
put edge ()
return rest
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
>>= cond
(fallback qqt Seq.empty)
(return $ Foldable.toList view)
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
>>= cond
(fallback Seq.empty tail)
(return $ Foldable.toList view)
else put true head
>>= cond
(fallback (Seq.drop 1 qt) qf)
(return $ Foldable.toList view)
in getNext list Seq.empty Seq.empty