[added syntax highlighted documentation to archive ekmett@gmail.com**20090322210732] { adddir ./dist/doc/html/lexical-monoids/src hunk ./dist/doc/html/lexical-monoids/Data-Monoid-Generator.html 24 +>Source code
Source
Source
Source
Source
Source
Source
Source
Source
Source code
Source
Source
Source
Source
Source
Source
Source
Source code
Source
Source
Source code
Source
Source
Source
Source
Source
Source
Source
Source
Source code
Source
Source
Source
Source
Source
Source code
Source
Source
Source
Source code
Source
Source
Source
Source
Source
Source
Source
+ + + +Data/Monoid/Generator.hs + + + +
{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}
+module Data.Monoid.Generator
+    ( module Data.Monoid
+    , Generator
+    , Elem
+    , mapreduce
+    , mapreducer
+    , mapreducel
+    ) where
+
+import Prelude hiding (lex)
+import Data.Word (Word8)
+import Data.Text (Text)
+import Data.Foldable (fold,foldMap)
+import qualified Data.Text as Text
+import qualified Data.ByteString as Strict
+import qualified Data.ByteString.Lazy as Lazy
+import Control.Parallel.Strategies
+import Data.Monoid
+import Data.Monoid.Reducer
+
+-- minimal definition mapreduce or affixMapReduce
+class Generator c where
+    type Elem c :: * 
+    mapreduce   :: (e `Reducer` m) => (Elem c -> e) -> c -> m
+    mapreducer  :: (e `Reducer` m) => (Elem c -> e) -> m -> c -> m 
+    mapreducel  :: (e `Reducer` m) => (Elem c -> e) -> c -> m -> m
+
+    mapreduce  f = mapreducer f mempty
+    mapreducer f m = mappend m . mapreduce f
+    mapreducel f = mappend . mapreduce f
+
+instance Generator Strict.ByteString where
+    type Elem Strict.ByteString = Word8
+    mapreducer f = Strict.foldl' (\a -> reducer a . f)
+
+instance Generator Lazy.ByteString where
+    type Elem Lazy.ByteString = Elem Strict.ByteString
+    mapreduce f = fold . parMap rwhnf (mapreduce f) . Lazy.toChunks
+
+instance Generator Text where
+    type Elem Text = Char
+    mapreducer f = Text.foldl' (\a -> reducer a . f)
+
+instance Generator [c] where
+    type Elem [c] = c
+    mapreduce f = foldMap (reduce . f)
+
+ addfile ./dist/doc/html/lexical-monoids/src/Data-Monoid-Lexical-SourcePosition.html hunk ./dist/doc/html/lexical-monoids/src/Data-Monoid-Lexical-SourcePosition.html 1 + + + + +Data/Monoid/Lexical/SourcePosition.hs + + + +
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+module Data.Monoid.Lexical.SourcePosition
+    ( module Data.Monoid.Reducer.Char
+    , SourcePosition
+    , SourceLine
+    , SourceColumn
+    , sourceLine
+    , sourceColumn
+    , startOfFile
+    , showSourcePosition
+    ) where
+
+import Prelude hiding (lex)
+import Control.Functor.Extras
+import Control.Functor.Pointed
+import Data.Monoid.Reducer.Char
+
+type SourceLine = Int
+type SourceColumn = Int
+
+data SourcePosition file = Pos file {-# UNPACK #-} !SourceLine !SourceColumn
+         | Lines {-# UNPACK #-} !SourceLine !SourceColumn
+         | Columns {-# UNPACK #-} !SourceColumn
+         | Tab {-# UNPACK #-} !SourceColumn !SourceColumn -- cols before and after an unresolved tab
+    deriving (Read,Show,Eq)
+
+nextTab :: Int -> Int
+nextTab x = x + (8 - (x-1) `mod` 8)
+
+instance Functor SourcePosition where
+    fmap g (Pos f l c) = Pos (g f) l c
+    fmap _ (Lines l c) = Lines l c
+    fmap _ (Columns c) = Columns c
+    fmap _ (Tab x y) = Tab x y
+
+instance Pointed SourcePosition where
+    point f = Pos f 1 1
+
+instance FunctorZero SourcePosition where
+    fzero = mempty
+
+instance FunctorPlus SourcePosition where
+    fplus = mappend
+
+instance Monoid (SourcePosition file) where
+    mempty = Columns 0
+
+    Pos f l _ `mappend` Lines m d = Pos f (l + m) d
+    Pos f l c `mappend` Columns d = Pos f l (c + d)
+    Pos f l c `mappend` Tab x y   = Pos f l (nextTab (c + x) + y)
+    Lines l _ `mappend` Lines m d = Lines (l + m) d
+    Lines l c `mappend` Columns d = Lines l (c + d)
+    Lines l c `mappend` Tab x y   = Lines l (nextTab (c + x) + y)
+    Columns c `mappend` Columns d  = Columns (c + d)
+    Columns c `mappend` Tab x y    = Tab (c + x) y
+    Tab _ _   `mappend` Lines m d  = Lines m d
+    Tab x y   `mappend` Columns d  = Tab x (y + d)
+    Tab x y   `mappend` Tab x' y'  = Tab x (nextTab (y + x') + y')
+    _         `mappend` pos        = pos
+
+instance Reducer Char (SourcePosition file) where
+    reduce '\n' = Lines 1 1
+    reduce '\t' = Tab 0 0 
+    reduce _    = Columns 1
+
+instance CharReducer (SourcePosition file)
+    
+startOfFile :: f -> SourcePosition f
+startOfFile = point
+
+sourceColumn :: SourcePosition f -> Maybe SourceColumn
+sourceColumn (Pos _ _ c) = Just c
+sourceColumn (Lines _ c) = Just c
+sourceColumn _ = Nothing
+
+sourceLine :: SourcePosition f -> Maybe SourceLine
+sourceLine (Pos _ l _) = Just l
+sourceLine _ = Nothing
+
+showSourcePosition :: SourcePosition String -> String
+showSourcePosition pos = showSourcePosition' (point "-" `mappend` pos) where
+    showSourcePosition' (Pos f l c) = f ++ ":" ++ show l ++ ":" ++ show c
+    showSourcePosition' _ = undefined
+
+ addfile ./dist/doc/html/lexical-monoids/src/Data-Monoid-Lexical-UTF8-Decoder.html hunk ./dist/doc/html/lexical-monoids/src/Data-Monoid-Lexical-UTF8-Decoder.html 1 + + + + +Data/Monoid/Lexical/UTF8/Decoder.hs + + + +
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+module Data.Monoid.Lexical.UTF8.Decoder 
+    ( module Data.Monoid.Reducer.Char
+    , UTF8
+    , runUTF8
+    ) where
+    
+import Data.Bits (shiftL,(.&.),(.|.))
+import Data.Word (Word8)
+
+import Control.Functor.Pointed
+
+import Data.Monoid.Reducer.Char
+
+-- Incrementally reduce canonical RFC3629 UTF-8 Characters
+
+-- utf8 characters are at most 4 characters long, so we need only retain state for 3 of them
+-- moreover their length is able to be determined a priori, so lets store that intrinsically in the constructor
+data H = H0
+       | H2_1 {-# UNPACK #-} !Word8 
+       | H3_1 {-# UNPACK #-} !Word8
+       | H3_2 {-# UNPACK #-} !Word8 !Word8
+       | H4_1 {-# UNPACK #-} !Word8
+       | H4_2 {-# UNPACK #-} !Word8 !Word8
+       | H4_3 {-# UNPACK #-} !Word8 !Word8 !Word8
+
+-- words expressing the tail of a character, each between 0x80 and 0xbf
+-- this is arbitrary length to simplify making the parser truly monoidal
+-- this probably means we have O(n^2) worst case performance in the face of very long runs of chars that look like 10xxxxxx
+type T = [Word8]
+
+-- S is a segment that contains a possible tail of a character, the result of reduceing some full characters, and the start of another character
+-- T contains a list of bytes each between 0x80 and 0xbf
+data UTF8 m = S T m !H
+            | T T
+
+-- flush any extra characters in a head, when the next character isn't between 0x80 and 0xbf
+flushH :: CharReducer m => H -> m
+flushH (H0) = mempty
+flushH (H2_1 x) = invalidChar [x]
+flushH (H3_1 x) = invalidChar [x]
+flushH (H3_2 x y) = invalidChar [x,y]
+flushH (H4_1 x) = invalidChar [x]
+flushH (H4_2 x y) = invalidChar [x,y]
+flushH (H4_3 x y z) = invalidChar [x,y,z]
+
+-- flush a character tail 
+flushT :: CharReducer m => [Word8] -> m
+flushT = invalidChar
+
+reducerH :: CharReducer m => H -> Word8 -> (m -> H -> UTF8 m) -> m -> UTF8 m
+reducerH H0 c k m 
+    | c < 0x80 = k (m `mappend` b1 c) H0
+    | c < 0xc0 = k (m `mappend` invalidChar [c]) H0
+    | c < 0xe0 = k m (H2_1 c)
+    | c < 0xf0 = k m (H3_1 c)
+    | c < 0xf5 = k m (H4_1 c)
+    | otherwise = k (m `mappend` invalidChar [c]) H0
+reducerH (H2_1 c) d k m
+    | d >= 0x80 && d < 0xc0 = k (m `mappend` b2 c d) H0
+    | otherwise = k (m `mappend` invalidChar [c]) H0
+reducerH (H3_1 c) d k m 
+    | d >= 0x80 && d < 0xc0 = k m (H3_2 c d)
+    | otherwise = k (m `mappend` invalidChar [c]) H0
+reducerH (H3_2 c d) e k m 
+    | d >= 0x80 && d < 0xc0 = k (m `mappend` b3 c d e) H0
+    | otherwise = k (m `mappend` invalidChar [c,d]) H0
+reducerH (H4_1 c) d k m 
+    | d >= 0x80 && d < 0xc0 = k m (H4_2 c d)
+    | otherwise = k (m `mappend` invalidChar [c,d]) H0
+reducerH (H4_2 c d) e k m 
+    | d >= 0x80 && d < 0xc0 = k m (H4_3 c d e)
+    | otherwise = k (m `mappend` invalidChar [c,d,e]) H0
+reducerH (H4_3 c d e) f k m 
+    | d >= 0x80 && d < 0xc0 = k (m `mappend` b4 c d e f) H0
+    | otherwise = k (m `mappend` invalidChar [c,d,e,f]) H0
+
+mask :: Word8 -> Word8 -> Int
+mask c m = fromEnum (c .&. m) 
+
+combine :: Int -> Word8 -> Int
+combine a r = shiftL a 6 .|. fromEnum (r .&. 0x3f)
+
+b1 :: CharReducer m => Word8 -> m
+b1 c | c < 0x80 = reduceChar . toEnum $ fromEnum c
+     | otherwise = invalidChar [c]
+
+b2 :: CharReducer m => Word8 -> Word8 -> m
+b2 c d | valid_b2 c d = reduceChar (toEnum (combine (mask c 0x1f) d))
+       | otherwise = invalidChar [c,d]
+
+b3 :: CharReducer m => Word8 -> Word8 -> Word8 -> m
+b3 c d e | valid_b3 c d e = reduceChar (toEnum (combine (combine (mask c 0x0f) d) e))
+         | otherwise = invalidChar [c,d,e]
+
+
+b4 :: CharReducer m => Word8 -> Word8 -> Word8 -> Word8 -> m
+b4 c d e f | valid_b4 c d e f = reduceChar (toEnum (combine (combine (combine (mask c 0x07) d) e) f))
+           | otherwise = invalidChar [c,d,e,f]
+
+valid_b2 :: Word8 -> Word8 -> Bool
+valid_b2 c d = (c >= 0xc2 && c <= 0xdf && d >= 0x80 && d <= 0xbf)
+
+valid_b3 :: Word8 -> Word8 -> Word8 -> Bool
+valid_b3 c d e = (c == 0xe0 && d >= 0xa0 && d <= 0xbf && e >= 0x80 && e <= 0xbf) || 
+                 (c >= 0xe1 && c <= 0xef && d >= 0x80 && d <= 0xbf && e >= 0x80 && e <= 0xbf)
+
+valid_b4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
+valid_b4 c d e f = (c == 0xf0 && d >= 0x90 && d <= 0xbf && e >= 0x80 && e <= 0xbf && f >= 0x80 && f <= 0xbf) ||
+      (c >= 0xf1 && c <= 0xf3 && d >= 0x80 && d <= 0xbf && e >= 0x80 && e <= 0xbf && f >= 0x80 && f <= 0xbf) ||
+                   (c == 0xf4 && d >= 0x80 && d <= 0x8f && e >= 0x80 && e <= 0xbf && f >= 0x80 && f <= 0xbf)
+
+reducelT :: CharReducer m => Word8 -> T -> (H -> UTF8 m) -> (m -> UTF8 m) -> (T -> UTF8 m) -> UTF8 m
+reducelT c cs h m t
+             | c < 0x80 = m $ b1 c `mappend` invalidChars cs
+             | c < 0xc0 = t (c:cs)
+             | c < 0xe0 = case cs of
+                        [] -> h $ H2_1 c
+                        (d:ds) -> m $ b2 c d `mappend` invalidChars ds
+             | c < 0xf0 = case cs of
+                        [] -> h $ H3_1 c
+                        [d] -> h $ H3_2 c d
+                        (d:e:es) -> m $ b3 c d e `mappend` invalidChars es
+             | c < 0xf5 = case cs of
+                        [] -> h $ H4_1 c
+                        [d] -> h $ H4_2 c d 
+                        [d,e] -> h $ H4_3 c d e 
+                        (d:e:f:fs) -> m $ b4 c d e f `mappend` invalidChars fs
+             | otherwise = mempty
+
+invalidChars :: CharReducer m => [Word8] -> m
+invalidChars = foldr (mappend . invalidChar . return) mempty
+
+merge :: CharReducer m => H -> T -> (m -> a) -> (H -> a) -> a
+merge H0 cs k _               = k $ invalidChars cs
+merge (H2_1 c) [] _ p         = p $ H2_1 c
+merge (H2_1 c) (d:ds) k _     = k $ b2 c d `mappend` invalidChars ds
+merge (H3_1 c) [] _ p         = p $ H3_1 c
+merge (H3_1 c) [d] _ p        = p $ H3_2 c d
+merge (H3_1 c) (d:e:es) k _   = k $ b3 c d e `mappend` invalidChars es
+merge (H3_2 c d) [] _ p       = p $ H3_2 c d
+merge (H3_2 c d) (e:es) k _   = k $ b3 c d e `mappend` invalidChars es
+merge (H4_1 c) [] _ p         = p $ H4_1 c
+merge (H4_1 c) [d] _ p        = p $ H4_2 c d
+merge (H4_1 c) [d,e] _ p      = p $ H4_3 c d e
+merge (H4_1 c) (d:e:f:fs) k _ = k $ b4 c d e f `mappend` invalidChars fs
+merge (H4_2 c d) [] _ p       = p $ H4_2 c d 
+merge (H4_2 c d) [e] _ p      = p $ H4_3 c d e
+merge (H4_2 c d) (e:f:fs) k _ = k $ b4 c d e f `mappend` invalidChars fs
+merge (H4_3 c d e) [] _ p     = p $ H4_3 c d e
+merge (H4_3 c d e) (f:fs) k _ = k $ b4 c d e f `mappend` invalidChars fs
+
+instance CharReducer m => Monoid (UTF8 m) where
+    mempty = T []
+    T c `mappend` T d = T (c ++ d)
+    T c `mappend` S l m r = S (c ++ l) m r
+    S l m c `mappend` S c' m' r = S l (m `mappend` merge c c' id flushH `mappend` m') r
+    s@(S _ _ _) `mappend` T [] = s
+    S l m c `mappend` T c' = merge c c' k (S l m) where
+        k m' = S l (m `mappend` m') H0
+
+instance CharReducer m => Reducer Word8 (UTF8 m) where
+    S t m h `reducer` c        = reducerH h c (S t) m
+    T t     `reducer` c        | c >= 0x80 && c < 0xc0 = T (t ++ [c])
+                               | otherwise = reducerH H0 c (S t) mempty
+
+    c       `reducel` T cs     = reducelT c cs (S [] mempty) (flip (S []) H0) T
+    c       `reducel` S cs m h = reducelT c cs k1 k2 k3 where
+        k1 h' = S [] (flushH h' `mappend` m) h
+        k2 m' = S [] (m' `mappend` m) h
+        k3 t' = S t' m h
+    
+instance Functor UTF8 where
+    fmap f (S t x h) = S t (f x) h
+    fmap _ (T t) = T t
+
+instance Pointed UTF8 where
+    point f = S [] f H0
+
+runUTF8 :: CharReducer m => UTF8 m -> m 
+runUTF8 (T t) = flushT t
+runUTF8 (S t m h) = flushT t `mappend` m `mappend` flushH h
+
+ addfile ./dist/doc/html/lexical-monoids/src/Data-Monoid-Lexical-Words.html hunk ./dist/doc/html/lexical-monoids/src/Data-Monoid-Lexical-Words.html 1 + + + + +Data/Monoid/Lexical/Words.hs + + + +
{-# 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
+    reduce c | isSpace c = Segment (Just (reduce c)) [] mempty
+          | otherwise = Chunk (Just (reduce 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
+    reduce '\n' = Lines $ Segment (Just (reduce '\n')) [] mempty
+    reduce c = Lines $ Chunk (Just (reduce 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
+    reduce c | isSpace c = mempty
+          | otherwise = Unspaced (reduce 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
+    reduce '\n' = mempty
+    reduce c = Unlined (reduce 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))
+
+ addfile ./dist/doc/html/lexical-monoids/src/Data-Monoid-Reducer-Char.html hunk ./dist/doc/html/lexical-monoids/src/Data-Monoid-Reducer-Char.html 1 + + + + +Data/Monoid/Reducer/Char.hs + + + +
{-# LANGUAGE UndecidableInstances, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
+module Data.Monoid.Reducer.Char
+    ( module Data.Monoid.Reducer
+    , CharReducer
+    , invalidChar
+    , reduceChar
+    ) where
+
+import Data.Monoid.Reducer
+import Data.Word (Word8)
+
+class Reducer Char m => CharReducer m where
+    reduceChar :: Char -> m 
+    reduceChar = reduce
+
+    invalidChar :: [Word8] -> m
+    invalidChar = const mempty
+
+instance (CharReducer m, CharReducer m') =>  CharReducer (m,m') where
+    invalidChar bs = (invalidChar bs, invalidChar bs)
+
+instance (CharReducer m, CharReducer m', CharReducer m'') =>  CharReducer (m,m',m'') where
+    invalidChar bs = (invalidChar bs, invalidChar bs, invalidChar bs)
+
+instance (CharReducer m, CharReducer m', CharReducer m'', CharReducer m''') =>  CharReducer (m,m',m'',m''') where
+    invalidChar bs = (invalidChar bs, invalidChar bs, invalidChar bs, invalidChar bs)
+
+instance CharReducer [Char]
+
+instance CharReducer ()
+
+ addfile ./dist/doc/html/lexical-monoids/src/Data-Monoid-Reducer-With.html hunk ./dist/doc/html/lexical-monoids/src/Data-Monoid-Reducer-With.html 1 + + + + +Data/Monoid/Reducer/With.hs + + + +
{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
+module Data.Monoid.Reducer.With
+    ( module Data.Monoid.Reducer
+    , WithReducer(runWithReducer)
+    , withReducer
+    , withoutReducer
+    ) where
+
+import Data.Monoid.Reducer
+import Data.FingerTree
+
+newtype WithReducer c m = WithReducer { runWithReducer :: (m,c) } 
+
+withReducer :: (c `Reducer` m) => c -> c `WithReducer` m
+withReducer x = d `seq` WithReducer (d, x) where d = reduce x
+
+withoutReducer :: c `WithReducer` m -> c
+withoutReducer = snd . runWithReducer
+
+instance (c `Reducer` m) => Reducer (c `WithReducer` m) m where
+    reduce = fst . runWithReducer 
+
+instance (c `Reducer` m) => Measured m (c `WithReducer` m) where
+    measure = fst . runWithReducer
+
+ addfile ./dist/doc/html/lexical-monoids/src/Data-Monoid-Reducer.html hunk ./dist/doc/html/lexical-monoids/src/Data-Monoid-Reducer.html 1 + + + + +Data/Monoid/Reducer.hs + + + +
{-# LANGUAGE UndecidableInstances, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
+module Data.Monoid.Reducer
+    ( module Data.Monoid
+    , Reducer
+    , reduce, reducer, reducel
+    ) where
+
+import Data.Monoid (Monoid, mempty, mappend)
+
+-- minimal definition reduce or reducer
+class Monoid m => Reducer c m where
+    reduce :: c -> m 
+    reducer :: m -> c -> m
+    reducel :: c -> m -> m 
+
+    reduce = reducer mempty 
+    reducer m = mappend m . reduce
+    reducel = mappend . reduce
+
+instance (Reducer c m, Reducer c m') => Reducer c (m,m') where
+    reduce x = (reduce x,reduce x)
+    reducer (m,m') x = (reducer m x, reducer m' x)
+    reducel x (m,m') = (reducel x m, reducel x m')
+
+instance (Reducer c m, Reducer c m', Reducer c m'') => Reducer c (m,m',m'') where
+    reduce x = (reduce x,reduce x, reduce x)
+    reducer (m,m',m'') x = (reducer m x, reducer m' x, reducer m'' x)
+    reducel x (m,m',m'') = (reducel x m, reducel x m', reducel x m'')
+
+instance (Reducer c m, Reducer c m', Reducer c m'', Reducer c m''') => Reducer c (m,m',m'',m''') where
+    reduce x = (reduce x,reduce x, reduce x, reduce x)
+    reducer (m,m',m'',m''') x = (reducer m x, reducer m' x, reducer m'' x, reducer m''' x)
+    reducel x (m,m',m'',m''') = (reducel x m, reducel x m', reducel x m'', reducel x m''')
+
+instance Reducer c [c] where
+    reduce = return
+    reducel = (:)
+    reducer xs x = xs ++ [x]
+
+instance Reducer c () where
+    reduce _ = ()
+    reducer _ _ = ()
+    reducel _ _ = ()
+
+ addfile ./dist/doc/html/lexical-monoids/src/hscolour.css hunk ./dist/doc/html/lexical-monoids/src/hscolour.css 1 +.hs-keyglyph, .hs-layout {color: red;} +.hs-keyword {color: blue;} +.hs-comment, .hs-comment a {color: green;} +.hs-str, .hs-chr {color: teal;} +.hs-keyword, .hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {} }