{- 
    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
   (-- * IO components
    fromFile, fromHandle, fromStdIn,
    appendFile, toFile, toHandle, toStdOut, toPrint,
    -- * Generic transducers
    asis, suppress, erroneous,
    prepend, append, substitute,
    -- * Generic splitters
    allTrue, allFalse, 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
)
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)


-- | Consumer 'toStdOut' copies the given source into the standard output.
toStdOut :: Consumer IO Char ()
toStdOut source = getSuccess source (\x-> liftPipe (putChar x) >> toStdOut source)

toPrint :: forall x. (Show x, Typeable x) => Consumer IO x ()
toPrint source = getSuccess source (\x-> liftPipe (print x) >> toPrint source)

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

-- | Producer 'fromFile' opens the named file and feeds the given sink from its contents.
fromFile :: String -> Producer IO Char ()
fromFile path sink = liftPipe (openFile path ReadMode) >>= flip fromHandle sink

-- | Producer 'fromHandle' feeds the given sink from the open file /handle/.
fromHandle :: Handle -> Producer IO Char ()
fromHandle handle sink = producer
   where producer = do readyInput <- liftM not (liftPipe (hIsEOF handle))
                       readyOutput <- canPut sink
                       when (readyInput && readyOutput) (liftPipe (hGetChar handle) >>= put sink >> producer)

-- | Consumer 'toFile' opens the named file and copies the given source into it.
toFile :: String -> Consumer IO Char ()
toFile path source = liftPipe (openFile path WriteMode) >>= flip toHandle source

-- | Consumer 'appendFile' opens the name file and appends the given source to it.
appendFile :: String -> Consumer IO Char ()
appendFile path source = liftPipe (openFile path AppendMode) >>= flip toHandle source

-- | Consumer 'toHandle' copies the given source into the open file /handle/.
toHandle :: Handle -> Consumer IO Char ()
toHandle handle source = getSuccess source (\x-> liftPipe (hPutChar handle x) >> toHandle handle source)

-- | Transducer 'asis' passes its input through unmodified.
asis :: (Monad m, Typeable x) => Transducer m x x
asis = Transducer (\source sink-> pour source sink >> return [])

-- | The 'suppress' transducer suppresses all input it receives. It is equivalent to 'substitute' []
suppress :: (Monad m, Typeable x, Typeable y) => Transducer m x y
suppress = liftStatelessTransducer (const [])

-- | The 'erroneous' transducer reports an error if any input reaches it.
erroneous :: (Monad m, Typeable x) => Transducer m x x
erroneous = liftStatelessTransducer (\x-> error "Erroneous.")

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

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

-- | Transducer 'prepend' passes its input unmodified, except for prepending contents of the given list parameter before
-- it.
prepend :: (Monad m, Typeable x) => [x] -> Transducer m x x
prepend prefix = Transducer (\source sink-> putList prefix sink >>= whenNull (pour source sink >> return []))

-- | Transducer 'append' passes its input unmodified, except for appending contents of the given list parameter to
-- its end.
append :: (Monad m, Typeable x) => [x] -> Transducer m x x
append suffix = Transducer (\source sink-> do pour source sink
                                              putList suffix sink
                                              return [])

-- | The 'substitute' transducer replaces its whole input by its parameter.
substitute :: (Monad m, Typeable x, Typeable y) => [y] -> Transducer m x y
substitute list = Transducer (\source sink-> consumeAndSuppress source >> putList list sink >> return [])

-- | The 'count' transducer counts all its input values and outputs the final tally.
count :: (Monad m, Typeable x) => Transducer m x Integer
count = Transducer (\source sink-> let t count = get source
                                                 >>= maybe
                                                        (put sink count >> return [])
                                                        (\_-> t (succ count))
                                   in canPut sink >>= cond (t 0) (return []))

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

-- | Transducer 'group' collects all its input values into a single list.
group :: (Monad m, Typeable x) => Transducer m x [x]
group = Transducer (\source sink-> let group q = get source
                                                 >>= maybe
                                                        (let list = Foldable.toList (Seq.viewl q)
                                                         in put sink list
                                                               >>= cond
                                                                      (return [])
                                                                      (return list))
                                                        (\x-> group (q |> x))
                                   in group Seq.empty)

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

concatSeparate :: (Monad m, Typeable x) => [x] -> Transducer m [x] x
concatSeparate separator = Transducer (\source sink-> let t = canPut sink
                                                              >>= cond
                                                                     (get source
                                                                      >>= maybe
                                                                             (return [])
                                                                             (\xs-> do putList separator sink
                                                                                       putList xs sink
                                                                                       t))
                                                                     (return [])
                                                      in get source
                                                            >>= maybe
                                                                   (return [])
                                                                   (\xs-> putList xs sink >> t))

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

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

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

-- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.
nonEmptyLine :: Monad m => Splitter m Char
nonEmptyLine = liftStatelessSplitter (\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 :: Monad m => Splitter m Char
line = liftSectionSplitter (\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 'allTrue' feeds its entire input into its /true/ sink.
allTrue :: (Monad m, Typeable x) => Splitter m x
allTrue = liftStatelessSplitter (const True)

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

-- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
one :: (Monad m, Typeable x) => Splitter m x
one = liftSectionSplitter (\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 :: (Monad m, Eq x, Typeable x) => [x] -> Splitter m x
substring = substringPrim 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 :: (Monad m, Eq x, Typeable x) => [x] -> Splitter m x
substringMatch = substringPrim True

substringPrim _ [] = liftSectionSplitter (\ source true false ->
                                             do put true Nothing
                                                rest <- splitSections one source false true
                                                put true Nothing
                                                return rest)
substringPrim overlap list
   = liftSectionSplitter $
     \ 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