module Data.Monoid.Lexical.Words
( module Data.Monoid.Reducer.Char
, Words
, runWords
, Unspaced(runUnspaced)
, wordsFrom
, Lines
, runLines
, Unlined(runUnlined)
, linesFrom
) where
import Data.String
import Data.Char (isSpace)
import Data.Maybe (maybeToList)
import Data.Monoid.Reducer.Char
import Data.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')
instance (CharReducer m) => CharReducer (Words m) where
invalidChar xs = Segment (Just (invalidChar xs)) [] mempty
instance Reducer Char m => IsString (Words m) where
fromString = reduce
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))
instance (CharReducer m) => CharReducer (Lines m) where
invalidChar xs = Lines $ Segment (Just (invalidChar xs)) [] mempty
instance Reducer Char m => IsString (Lines m) where
fromString = reduce
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
instance Reducer Char m => IsString (Unspaced m) where
fromString = reduce
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
instance Reducer Char m => IsString (Unlined m) where
fromString = reduce
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))
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))