{- 
    Copyright 2008-2011 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 "Primitives" defines primitive components of 'Producer', 'Consumer', 'Transducer' and 'Splitter' types,
-- defined in the "Types" module.

{-# LANGUAGE ScopedTypeVariables, Rank2Types #-}
{-# OPTIONS_HADDOCK hide #-}

module Control.Concurrent.SCC.Primitives (
   -- * I/O components
   -- ** I/O producers
   fromFile, fromHandle, fromStdIn, fromBinaryHandle,
   -- ** I/O consumers
   appendFile, toFile, toHandle, toStdOut, toBinaryHandle,
   -- * Generic components
   fromList, 
   -- ** Generic consumers
   suppress, erroneous, toList,
   -- ** Generic transducers
   parse, unparse, parseSubstring, OccurenceTag, count, toString,
   -- *** List stream transducers
   -- | The following laws hold:
   --
   --    * 'group' '>>>' 'concatenate' == 'id'
   --
   --    * 'concatenate' == 'concatSeparate' []
   group, concatenate, concatSeparate,
   -- ** Generic splitters
   everything, nothing, marked, markedContent, markedWith, contentMarkedWith, one, substring,
   -- * Character stream components
   lowercase, uppercase, whitespace, letters, digits, line, nonEmptyLine,
   )
where

import Prelude hiding (appendFile, head, tail)

import Control.Applicative (Alternative ((<|>)))
import Control.Exception (assert)
import Control.Monad (forM_, unless, when)
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 System.IO (Handle, IOMode (ReadMode, WriteMode, AppendMode), 
                  openFile, hClose, hGetLine, hPutStr, hIsEOF, hClose, isEOF)

import Text.ParserCombinators.Incremental (string, takeWhile, (<<|>))

import Control.Concurrent.SCC.Streams
import Control.Concurrent.SCC.Types

import Debug.Trace (trace)

-- | Collects the entire input source into a list.
toList :: forall m x. Monad m => Consumer m x [x]
toList = Consumer getList

-- | Produces the contents of the given list argument.
fromList :: forall m x. Monad m => [x] -> Producer m x ()
fromList l = Producer ((>> return ()) . putList l)

-- | Consumer 'toStdOut' copies the given source into the standard output.
toStdOut :: Consumer IO Char ()
toStdOut = Consumer (mapMStreamChunks_ (lift . putStr))

-- | Producer 'fromStdIn' feeds the given sink from the standard input.
fromStdIn :: Producer IO Char ()
fromStdIn = Producer (unmapMStreamChunks_ (lift $ isEOF >>= cond (return []) (fmap (++ "\n") getLine)))

-- | Reads the named file and feeds the given sink from its contents.
fromFile :: String -> Producer IO Char ()
fromFile path = Producer $ \sink-> do handle <- lift (openFile path ReadMode)
                                      produce (fromHandle handle) sink
                                      lift (hClose handle)

-- | Feeds the given sink from the open text file /handle/.
fromHandle :: Handle -> Producer IO Char ()
fromHandle handle = Producer (unmapMStreamChunks_
                                 (lift $ hIsEOF handle >>= cond (return []) (fmap (++ "\n") $ hGetLine handle)))

-- | Feeds the given sink from the open binary file /handle/. The argument /chunkSize/ determines the size of the chunks
-- read from the 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))

-- | Creates the named text file and writes the entire given source to it.
toFile :: String -> Consumer IO Char ()
toFile path = Consumer $ \source-> do handle <- lift (openFile path WriteMode)
                                      consume (toHandle handle) source
                                      lift (hClose handle)

-- | Appends the given source to the named text file.
appendFile :: String -> Consumer IO Char ()
appendFile path = Consumer $ \source-> do handle <- lift (openFile path AppendMode)
                                          consume (toHandle handle) source
                                          lift (hClose handle)

-- | Copies the given source into the open text file /handle/.
toHandle :: Handle -> Consumer IO Char ()
toHandle handle = Consumer (mapMStreamChunks_ (lift . hPutStr handle))

-- | Copies the given source into the open binary file /handle/.
toBinaryHandle :: Handle -> Consumer IO ByteString ()
toBinaryHandle handle = Consumer (mapMStream_ (lift . ByteString.hPut handle))

-- | Transducer 'unparse' removes all markup from its input and passes the content through.
unparse :: forall m x b. Monad m => Transducer m (Markup b x) x
unparse = statelessTransducer removeTag
   where removeTag (Content x) = [x]
         removeTag _ = []

-- | Transducer 'parse' prepares input content for subsequent parsing.
parse :: forall m x y. Monad m => Transducer m x (Markup y x)
parse = oneToOneTransducer Content

-- | The 'suppress' consumer suppresses all input it receives. It is equivalent to 'substitute' []
suppress :: forall m x. Monad m => Consumer m x ()
suppress = Consumer (\(src :: Source m a x)-> pour src (nullSink :: Sink m a x))

-- | The 'erroneous' consumer reports an error if any input reaches it.
erroneous :: forall m x. Monad m => String -> Consumer m x ()
erroneous message = Consumer (getWith (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 = oneToOneTransducer 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 = oneToOneTransducer toUpper

-- | The 'count' transducer counts all its input values and outputs the final tally.
count :: forall m x. Monad m => Transducer m x Integer
count = Transducer (\source sink-> foldStream (\n _-> succ n) 0 source >>= put sink)

-- | Converts each input value @x@ to @show x@.
toString :: forall m x. (Monad m, Show x) => Transducer m x String
toString = oneToOneTransducer show

-- | Transducer 'group' collects all its input values into a single list.
group :: forall m x. Monad m => Transducer m x [x]
group = Transducer (\source sink-> getList source >>= put sink)

-- | Transducer 'concatenate' flattens the input stream of lists of values into the output stream of values.
concatenate :: forall m x. Monad m => Transducer m [x] x
concatenate = statelessTransducer id

-- | Same as 'concatenate' except it inserts the given separator list between every two input lists.
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

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

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

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

-- | Splitter 'nonEmptyLine' feeds line-ends into its /false/ sink, and all other characters into /true/.
nonEmptyLine :: forall m. Monad m => Splitter m Char ()
nonEmptyLine = statelessSplitter (\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. Monad m => Splitter m Char ()
line = Splitter $ \source true false boundaries->
       let loop = peek source >>= maybe (return ()) (( >> loop) . splitLine)
           lineChar c = c /= '\r' && c /= '\n'
           lineEndParser = string "\r\n" <<|> string "\n\r" <<|> string "\r" <<|> string "\n"
           splitLine c = put boundaries ()
                         >> when (lineChar c) (pourWhile lineChar source true)
                         >> pourTicked lineEndParser source false
       in loop

-- | Splitter 'everything' feeds its entire input into its /true/ sink.
everything :: forall m x. Monad m => Splitter m x ()
everything = Splitter (\source true _false edge-> put edge () >> pour source true)

-- | Splitter 'nothing' feeds its entire input into its /false/ sink.
nothing :: forall m x. Monad m => Splitter m x ()
nothing = Splitter (\source _true false _edge-> pour source false)

-- | Splitter 'one' feeds all input values to its /true/ sink, treating every value as a separate section.
one :: forall m x. Monad m => Splitter m x ()
one = Splitter (\source true _false edge-> mapMStream_ (\x-> put edge () >> put true x) source)

-- | Splitter 'marked' passes all marked-up input sections to its /true/ sink, and all unmarked input to its
-- /false/ sink.
marked :: forall m x y. (Monad m, Eq y) => Splitter m (Markup y x) ()
marked = markedWith (const True)

-- | Splitter 'markedContent' passes the content of all marked-up input sections to its /true/ sink, takeWhile the
-- outermost tags and all unmarked input go to its /false/ sink.
markedContent :: forall m x y. (Monad m, Eq y) => Splitter m (Markup y x) ()
markedContent = contentMarkedWith (const True)

-- | Splitter 'markedWith' passes input sections marked-up with the appropriate tag to its /true/ sink, and the
-- rest of the input to its /false/ sink. The argument /select/ determines if the tag is appropriate.
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)

-- | Splitter 'contentMarkedWith' passes the content of input sections marked-up with the appropriate tag to
-- its /true/ sink, and the rest of the input to its /false/ sink. The argument /select/ determines if the tag is
-- appropriate.
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'))

-- | Used by 'parseSubstring' to distinguish between overlapping substrings.
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

-- | Performs the same task as the 'substring' splitter, but instead of splitting it outputs the input as @'Markup' x
-- 'OccurenceTag'@ in order to distinguish overlapping strings.
parseSubstring :: forall m x. (Monad m, Eq x) => [x] -> Parser m x OccurenceTag
parseSubstring [] = Transducer $ 
                    \ source sink -> put sink marker >> concatMapStream (\x-> [Content x, marker]) source sink
   where marker = Markup (Point (toEnum 1))
parseSubstring list@(first:rest)
   = Transducer $
     \ source sink ->
        let findFirst = pourWhile (/= first) source (mapSink Content sink)
                        >> test
            test = getTicked (string list) source
                   >>= \s-> case s
                            of [] -> get source >>= maybe (return ()) (\x-> put sink (Content x) >> findFirst)
                               _ -> put sink (Markup (Start (toEnum 0)))
                                    >> putList prefixContent sink
                                    >> if null shared then put sink (Markup (End (toEnum 0))) >> findFirst
                                       else testOverlap 0
            testOverlap n = getTicked (string postfix) source
                            >>= \s-> case s
                                     of [] -> forM_ [n - maxOverlaps + 1 .. n]
                                                    (\i-> putList sharedContent sink
                                                          >> put sink (Markup (End (toEnum i))))
                                              >> findFirst
                                        _ -> let n' = succ n
                                             in put sink (Markup (Start (toEnum n')))
                                                >> putList prefixContent sink
                                                >> when (n' >= maxOverlaps) 
                                                        (put sink (Markup (End (toEnum (n' - maxOverlaps)))))
                                                >> testOverlap n'
            (prefix, shared, postfix) = overlap list list
            maxOverlaps = (length list - 1) `div` length prefix
            prefixContent = map Content prefix
            sharedContent = map Content shared
        in findFirst

-- | 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, both are sent to /true/ and each is preceded
-- by an edge.
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:rest)
   = Splitter $
     \ source true false edge ->
        let findFirst = pourWhile (/= first) source false
                        >> test
            test = getTicked (string list) source
                   >>= \s-> case s
                            of [] -> get source >>= maybe (return ()) (\x-> put false x >> findFirst)
                               _ -> put edge ()
                                    >> putList prefix true
                                    >> if null shared then findFirst else testOverlap
            testOverlap = getTicked (string postfix) source
                          >>= \s-> case s
                                   of [] -> putList shared true >> findFirst
                                      _ -> put edge ()
                                           >> putList prefix true 
                                           >> testOverlap
            (prefix, shared, postfix) = overlap list list
        in findFirst

overlap :: Eq x => [x] -> [x] -> ([x], [x], [x])
overlap [] s = ([], [], s)
overlap (head:tail) s2 = case stripPrefix tail s2
                         of Just rest -> ([head], tail, rest)
                            Nothing -> let (o1, o2, o3) = overlap tail s2
                                       in (head:o1, o2, o3)

-- | A utility function wrapping if-then-else, useful for handling monadic truth values
cond :: a -> a -> Bool -> a
cond x y test = if test then x else y