{- 
    Copyright 2008 Mario Blazevic

    This file is part of the Streaming Component Combinators (SCC) project.

    The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
    License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
    version.

    SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.

    You should have received a copy of the GNU General Public License along with SCC.  If not, see
    <http://www.gnu.org/licenses/>.
-}

-- | Module "Components" defines primitive components of 'Producer', 'Consumer', 'Transducer' and 'Splitter' types,
-- defined in the "Foundation" and "ComponentTypes" modules.

{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}

module Control.Concurrent.SCC.Components
   (-- * List producers and consumers
    fromList, toList,
    -- * I/O producers and consumers
    fromFile, fromHandle, fromStdIn,
    appendFile, toFile, toHandle, toStdOut, toPrint,
    -- * Generic consumers
    suppress, erroneous,
    -- * Generic transducers
    asis,
    -- * Generic splitters
    everything, nothing, one, substring, substringMatch,
    -- * List transducers
    -- | The following laws hold:
    --
    --    * 'group' '>->' 'concatenate' == 'asis'
    --
    --    * 'concatenate' == 'concatSeparate' []
    group, concatenate, concatSeparate,
    -- * Character stream components
    lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
    -- * Oddballs
    count, toString,
    ioCost
)
where

import Control.Concurrent.SCC.Foundation
import Control.Concurrent.SCC.ComponentTypes

import Prelude hiding (appendFile, last)
import Control.Monad (liftM, when)
import qualified Control.Monad as Monad
import Data.Char (isAlpha, isDigit, isPrint, isSpace, toLower, toUpper)
import Data.List (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 Data.Typeable (Typeable)
import Debug.Trace (trace)
import System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), openFile, hClose,
                  hGetChar, hPutChar, hFlush, hIsEOF, hClose, putChar, isEOF, stdout)

ioCost :: Int
ioCost = 5

-- | Consumer 'toList' copies the given source into a list.
toList :: forall m x. (Monad m, Typeable x) => Consumer m x [x]
toList = liftAtomicConsumer "toList" 1 getList

-- | 'fromList' produces the contents of the given list argument.
fromList :: forall m x. (Monad m, Typeable x) => [x] -> Producer m x [x]
fromList l = liftAtomicProducer "fromList" 1 (putList l)

-- | Consumer 'toStdOut' copies the given source into the standard output.
toStdOut :: Consumer IO Char ()
toStdOut = liftAtomicConsumer "toStdOut" ioCost $ \source-> let c = get source
                                                                    >>= maybe (return ()) (\x-> liftPipe (putChar x) >> c)
                                                            in c

toPrint :: forall x. (Show x, Typeable x) => Consumer IO x ()
toPrint = liftAtomicConsumer "toPrint" ioCost $ \source-> let c = getSuccess source (\x-> liftPipe (print x) >> c)
                                                          in c

-- | Producer 'fromStdIn' feeds the given sink from the standard input.
fromStdIn :: Producer IO Char ()
fromStdIn = liftAtomicProducer "fromStdIn" ioCost $ \sink-> let p = do readyInput <- liftM not (liftPipe isEOF)
                                                                       readyOutput <- canPut sink
                                                                       when (readyInput && readyOutput) (liftPipe getChar
                                                                                                         >>= put sink
                                                                                                         >> p)
                                                            in p

-- | Producer 'fromFile' opens the named file and feeds the given sink from its contents.
fromFile :: String -> Producer IO Char ()
fromFile path = liftAtomicProducer "fromFile" ioCost $ \sink-> do handle <- liftPipe (openFile path ReadMode)
                                                                  produce (fromHandle handle True) sink

-- | Producer 'fromHandle' feeds the given sink from the open file /handle/. The argument /doClose/ determines if
-- | /handle/ should be closed when the handle is consumed or the sink closed.
fromHandle :: Handle -> Bool -> Producer IO Char ()
fromHandle handle doClose = liftAtomicProducer "fromHandle" ioCost $
                            \sink-> (canPut sink
                                     >>= flip when (let p = do eof <- liftPipe (hIsEOF handle)
                                                               when (not eof) (liftPipe (hGetChar handle)
                                                                               >>= put sink
                                                                               >>= flip when p)
                                                    in p)
                                     >> when doClose (liftPipe $ hClose handle))

-- | Consumer 'toFile' opens the named file and copies the given source into it.
toFile :: String -> Consumer IO Char ()
toFile path = liftAtomicConsumer "toFile" ioCost $ \source-> do handle <- liftPipe (openFile path WriteMode)
                                                                consume (toHandle handle True) source

-- | Consumer 'appendFile' opens the name file and appends the given source to it.
appendFile :: String -> Consumer IO Char ()
appendFile path = liftAtomicConsumer "appendFile" ioCost $ \source-> do handle <- liftPipe (openFile path AppendMode)
                                                                        consume (toHandle handle True) source

-- | Consumer 'toHandle' copies the given source into the open file /handle/. The argument /doClose/ determines if
-- | /handle/ should be closed once the entire source is consumed and copied.
toHandle :: Handle -> Bool -> Consumer IO Char ()
toHandle handle doClose = liftAtomicConsumer "toHandle" ioCost $ \source-> let c = get source
                                                                                   >>= maybe
                                                                                          (when doClose $ liftPipe $ hClose handle)
                                                                                          (\x-> liftPipe (hPutChar handle x) >> c)
                                                                           in c

-- | Transducer 'asis' passes its input through unmodified.
asis :: forall m x. (Monad m, Typeable x) => Transducer m x x
asis = lift121Transducer "asis" id

-- | The 'suppress' transducer suppresses all input it receives. It is equivalent to 'substitute' []
suppress :: forall m x y. (Monad m, Typeable x) => Consumer m x ()
suppress = liftAtomicConsumer "suppress" 1 consumeAndSuppress

-- | The 'erroneous' transducer reports an error if any input reaches it.
erroneous :: forall m x. (Monad m, Typeable x) => String -> Consumer m x ()
erroneous message = liftAtomicConsumer "erroneous" 0 $ \source-> get source >>= maybe (return ()) (const (error message))

-- | The 'lowercase' transforms all uppercase letters in the input to lowercase, leaving the rest unchanged.
lowercase :: forall m. Monad m => Transducer m Char Char
lowercase = lift121Transducer "lowercase" toLower

-- | The 'uppercase' transforms all lowercase letters in the input to uppercase, leaving the rest unchanged.
uppercase :: forall m. Monad m => Transducer m Char Char
uppercase = lift121Transducer "uppercase" toUpper

-- | The 'count' transducer counts all its input values and outputs the final tally.
count :: forall m x. (Monad m, Typeable x) => Transducer m x Integer
count = liftFoldTransducer "count" (\count _-> succ count) 0 id

toString :: forall m x. (Monad m, Show x, Typeable x) => Transducer m x String
toString = lift121Transducer "toString" show

-- | Transducer 'group' collects all its input values into a single list.
group :: forall m x. (Monad m, Typeable x) => Transducer m x [x]
group = liftFoldTransducer "group" (|>) Seq.empty Foldable.toList

-- | Transducer 'concatenate' flattens the input stream of lists of values into the output stream of values.
concatenate :: forall m x. (Monad m, Typeable x) => Transducer m [x] x
concatenate = liftStatelessTransducer "concatenate" id

concatSeparate :: forall m x. (Monad m, Typeable x) => [x] -> Transducer m [x] x
concatSeparate separator = liftStatefulTransducer "concatSeparate"
                                                  (\seen list-> (True, if seen then separator ++ list else list))
                                                  False 

-- | Splitter 'whitespace' feeds all white-space characters into its /true/ sink, all others into /false/.
whitespace :: forall m. ParallelizableMonad m => Splitter m Char
whitespace = liftStatelessSplitter "whitespace" isSpace

-- | Splitter 'letters' feeds all alphabetical characters into its /true/ sink, all other characters into /false/.
letters :: forall m. ParallelizableMonad m => Splitter m Char
letters = liftStatelessSplitter "letters" isAlpha

-- | Splitter 'digits' feeds all digits into its /true/ sink, all other characters into /false/.
digits :: forall m. ParallelizableMonad m => Splitter m Char
digits = liftStatelessSplitter "digits" isDigit

-- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.
nonEmptyLine :: forall m. ParallelizableMonad m => Splitter m Char
nonEmptyLine = liftStatelessSplitter "nonEmptyLine" (\ch-> ch /= '\n' && ch /= '\r')

-- | The sectioning splitter 'line' feeds line-ends into its /false/ sink, and line contents into /true/. A single
-- line-end can be formed by any of the character sequences \"\\n\", \"\\r\", \"\\r\\n\", or \"\\n\\r\".
line :: forall m. ParallelizableMonad m => Splitter m Char
line = liftAtomicSectionSplitter "line" 1 $
       \source true false-> let split0 = get source >>= maybe (return []) split1
                                split1 x = if x == '\n' || x == '\r'
                                           then split2 x
                                           else lineChar x
                                split2 x = put false (Just 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 (Just x)
                                           >>= cond
                                                  (get source
                                                   >>= maybe
                                                          (return [])
                                                          (\y-> if y == '\n' || y == '\r'
                                                                then emptyLine y
                                                                else lineChar y))
                                                  (return [x])
                                emptyLine x = put true Nothing >>= cond (split2 x) (return [])
                                lineChar x = put true (Just x) >>= cond split0 (return [x])
                            in split0

-- | Splitter 'everything' feeds its entire input into its /true/ sink.
everything :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
everything = liftStatelessSplitter "everything" (const True)

-- | Splitter 'nothing' feeds its entire input into its /false/ sink.
nothing :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
nothing = liftStatelessSplitter "nothing" (const False)

-- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
one :: forall m x. (ParallelizableMonad m, Typeable x) => Splitter m x
one = liftAtomicSectionSplitter "one" 1 $
      \source true false-> let split x = put true (Just x)
                                         >>= cond (get source
                                                   >>= maybe
                                                          (return [])
                                                          (\x-> put false Nothing >> split x))
                                                  (return [x])
                           in get source >>= maybe (return []) split

-- | Splitter 'substring' feeds to its /true/ sink all input parts that match the contents of the given list
-- argument. If two overlapping parts of the input both match the argument, only the first one wins.
substring :: forall m x. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x
substring = substringPrim "substring" False

-- | Splitter 'substringMatch' feeds to its /true/ sink all input parts that match the contents of the given list
-- argument. If two overlapping parts of the input match the argument, both are considered /true/.
substringMatch :: forall m x. (ParallelizableMonad m, Eq x, Typeable x) => [x] -> Splitter m x
substringMatch = substringPrim "substringMatch" True

substringPrim name _ [] = liftAtomicSectionSplitter name 1 $
                          \ source true false -> do put true Nothing
                                                    rest <- splitSections one source false true
                                                    put true Nothing
                                                    return rest
substringPrim name overlap list
   = liftAtomicSectionSplitter name 1 $
     \ source true false ->
        let getNext rest q separate = get source
                                      >>= maybe
                                             (liftM (map fromJust) $
                                                    putList (map Just $ Foldable.toList (Seq.viewl q)) false)
                                             (\x-> do when separate (put false Nothing >> return ())
                                                      advance rest q x)
            advance rest@(head:tail) q x = if x == head
                                           then if null tail
                                                then liftM (map fromJust) (putList (map Just list) true)
                                                        >>= whenNull (if overlap
                                                                      then fallback True (Seq.drop 1 q)
                                                                      else getNext list Seq.empty True)
                                                else getNext tail (q |> x) False
                                           else fallback False (q |> x)
            fallback committed q = case stripPrefix (Foldable.toList (Seq.viewl q)) list
                                   of Just rest -> getNext rest q committed
                                      Nothing -> let view@(head :< tail) = Seq.viewl q
                                                 in if committed
                                                    then fallback committed tail
                                                    else put false (Just head)
                                                            >>= cond
                                                                   (fallback committed tail)
                                                                   (return (Foldable.toList view))
        in getNext list Seq.empty False