{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, ParallelListComp, TypeFamilies #-}
module Data.Monoid.Lexical.Words 
    ( module Data.Monoid.Reducer.Char
    , Words
    , runWords
    , Lines
    , runLines
    , Unspaced(runUnspaced)
    , Unlined(runUnlined)
    , wordsFrom
    , linesFrom
    ) where

import Data.Char (isSpace)
import Data.Maybe (maybeToList)
import Data.Monoid.Reducer.Char
import Data.Monoid.Generator
import Control.Functor.Pointed

data Words m = Chunk (Maybe m)
             | Segment (Maybe m) [m] (Maybe m)
    deriving (Show,Read)

runWords :: Words m -> [m]
runWords (Chunk m) = maybeToList m
runWords (Segment l m r) = maybeToList l ++ m ++ maybeToList r

instance Monoid m => Monoid (Words m) where
    mempty = Chunk mempty
    Chunk l `mappend` Chunk r = Chunk (l `mappend` r)
    Chunk l `mappend` Segment l' m r = Segment (l `mappend` l') m r
    Segment l m r `mappend` Chunk r' = Segment l m (r `mappend` r')
    Segment l m r `mappend` Segment l' m' r' = Segment l (m ++ maybeToList (r `mappend` l') ++ m') r'

instance Reducer Char m => Reducer Char (Words m) where
    unit c | isSpace c = Segment (Just (unit c)) [] mempty
           | otherwise = Chunk (Just (unit c))

instance Functor Words where
    fmap f (Chunk m) = Chunk (fmap f m)
    fmap f (Segment m ms m') = Segment (fmap f m) (fmap f ms) (fmap f m')

-- abuse the same machinery to handle lines as well

newtype Lines m = Lines (Words m) deriving (Show,Read,Monoid,Functor)

instance Reducer Char m => Reducer Char (Lines m) where
    unit '\n' = Lines $ Segment (Just (unit '\n')) [] mempty
    unit c = Lines $ Chunk (Just (unit c))

runLines :: Lines m -> [m]
runLines (Lines x) = runWords x

newtype Unspaced m = Unspaced { runUnspaced :: m }  deriving (Eq,Ord,Show,Read,Monoid)

instance Reducer Char m => Reducer Char (Unspaced m) where
    unit c | isSpace c = mempty
           | otherwise = Unspaced (unit c)

instance CharReducer m => CharReducer (Unspaced m) where
    invalidChar = Unspaced . invalidChar

instance Functor Unspaced where
    fmap f (Unspaced x) = Unspaced (f x)

instance Pointed Unspaced where
    point = Unspaced

instance Copointed Unspaced where
    extract = runUnspaced

newtype Unlined m = Unlined { runUnlined :: m }  deriving (Eq,Ord,Show,Read,Monoid)

instance Reducer Char m => Reducer Char (Unlined m) where
    unit '\n' = mempty
    unit c = Unlined (unit c)

instance CharReducer m => CharReducer (Unlined m) where
    invalidChar = Unlined . invalidChar

instance Functor Unlined where
    fmap f (Unlined x) = Unlined (f x)

instance Pointed Unlined where
    point = Unlined

instance Copointed Unlined where
    extract = runUnlined

-- accumulator, inside-word, and until-next-word monoids
wordsFrom :: (Generator c, Elem c ~ Char, Char `Reducer` m, Char `Reducer` n, Char `Reducer` o) => m -> c -> [(m,n,o)]
wordsFrom s c = [(x,runUnlined y,z) | x <- scanl mappend s ls | (y,z) <- rs ] where
    (ls,rs) = unzip (runWords (mapReduce id c))

-- accumulator, inside-line, and until-next-line monoids
linesFrom :: (Generator c, Elem c ~ Char, Char `Reducer` m, Char `Reducer` n, Char `Reducer` o) => m -> c -> [(m,n,o)]
linesFrom s c = [(x,runUnlined y,z) | x <- scanl mappend s ls | (y,z) <- rs ] where
    (ls,rs) = unzip (runLines (mapReduce id c))