monoids 0.1.36 → 0.2.0
raw patch · 39 files changed
+80/−3182 lines, 39 filesdep −QuickCheckdep −category-extrasdep −mtldep ~basedep ~fingertreedep ~text
Dependencies removed: QuickCheck, category-extras, mtl, parsec, reflection, stm
Dependency ranges changed: base, fingertree, text
Files
- Data/Generator.hs +4/−50
- Data/Generator/Combinators.hs +7/−5
- Data/Generator/Compressive/LZ78.hs +0/−114
- Data/Generator/Compressive/RLE.hs +0/−101
- Data/Generator/Free.hs +0/−114
- Data/Group.hs +5/−32
- Data/Group/Combinators.hs +2/−9
- Data/Group/Sugar.hs +1/−0
- Data/Monoid/Additive.hs +3/−4
- Data/Monoid/Applicative.hs +12/−17
- Data/Monoid/Categorical.hs +0/−62
- Data/Monoid/Combinators.hs +2/−2
- Data/Monoid/FromString.hs +0/−47
- Data/Monoid/Instances.hs +0/−162
- Data/Monoid/Lexical/SourcePosition.hs +0/−119
- Data/Monoid/Lexical/UTF8/Decoder.hs +0/−224
- Data/Monoid/Lexical/Words.hs +0/−139
- Data/Monoid/Monad.hs +12/−19
- Data/Monoid/Multiplicative.hs +5/−124
- Data/Monoid/Ord.hs +4/−23
- Data/Monoid/Reducer.hs +1/−20
- Data/Monoid/Reducer/Char.hs +0/−42
- Data/Monoid/Reducer/With.hs +0/−32
- Data/Monoid/Self.hs +3/−11
- Data/Monoid/Sugar.hs +8/−10
- Data/Monoid/Union.hs +3/−9
- Data/Ring.hs +0/−154
- Data/Ring/Boolean.hs +0/−85
- Data/Ring/FromNum.hs +0/−49
- Data/Ring/ModularArithmetic.hs +0/−72
- Data/Ring/Module.hs +0/−107
- Data/Ring/Module/AutomaticDifferentiation.hs +0/−87
- Data/Ring/Semi/BitSet.hs +0/−460
- Data/Ring/Semi/Kleene.hs +0/−10
- Data/Ring/Semi/Natural.hs +0/−276
- Data/Ring/Semi/Near/Trie.hs +0/−50
- Data/Ring/Semi/Ord.hs +0/−139
- Data/Ring/Semi/Tropical.hs +0/−97
- monoids.cabal +8/−105
Data/Generator.hs view
@@ -19,9 +19,9 @@ ----------------------------------------------------------------------------- module Data.Generator- ( module Data.Monoid.Reducer+ ( -- * Generators- , Generator+ Generator , Elem , mapReduce , mapTo@@ -36,30 +36,17 @@ , reduceWith ) where -#ifdef M_ARRAY-import Data.Array -#endif-+import Data.Monoid (Monoid, mappend, mempty) -#ifdef M_TEXT+import Data.Array import Data.Text (Text) import qualified Data.Text as Text-#endif---#ifdef M_BYTESTRING import qualified Data.ByteString as Strict (ByteString, foldl') import qualified Data.ByteString.Char8 as Strict8 (foldl') import qualified Data.ByteString.Lazy as Lazy (ByteString, toChunks) import qualified Data.ByteString.Lazy.Char8 as Lazy8 (toChunks) import Data.Word (Word8)-#endif--#ifdef M_FINGERTREE import Data.FingerTree (Measured, FingerTree)-#endif--#ifdef M_CONTAINERS import qualified Data.Sequence as Seq import Data.Sequence (Seq) import qualified Data.Set as Set@@ -70,12 +57,7 @@ import Data.IntMap (IntMap) import qualified Data.Map as Map import Data.Map (Map)-#endif--#ifdef M_PARALLEL import Control.Parallel.Strategies-#endif- import Data.Foldable (fold,foldMap) import Data.Monoid.Reducer @@ -90,7 +72,6 @@ mapTo f m = mappend m . mapReduce f mapFrom f = mappend . mapReduce f -#ifdef M_BYTESTRING instance Generator Strict.ByteString where type Elem Strict.ByteString = Word8 mapTo f = Strict.foldl' (\a -> snoc a . f)@@ -98,25 +79,19 @@ instance Generator Lazy.ByteString where type Elem Lazy.ByteString = Word8 mapReduce f = fold . parMap rwhnf (mapReduce f) . Lazy.toChunks-#endif -#ifdef M_TEXT instance Generator Text where type Elem Text = Char mapTo f = Text.foldl' (\a -> snoc a . f)-#endif instance Generator [c] where type Elem [c] = c mapReduce f = foldr (cons . f) mempty -#ifdef M_FINGERTREE instance Measured v e => Generator (FingerTree v e) where type Elem (FingerTree v e) = e mapReduce f = foldMap (unit . f)-#endif -#ifdef M_CONTAINERS instance Generator (Seq c) where type Elem (Seq c) = c mapReduce f = foldMap (unit . f)@@ -136,18 +111,14 @@ instance Generator (Map k v) where type Elem (Map k v) = (k,v) mapReduce f = mapReduce f . Map.toList-#endif -#ifdef M_ARRAY instance Ix i => Generator (Array i e) where type Elem (Array i e) = (i,e) mapReduce f = mapReduce f . assocs-#endif -- | a 'Generator' transformer that asks only for the keys of an indexed container newtype Keys c = Keys { getKeys :: c } -#ifdef M_CONTAINERS instance Generator (Keys (IntMap v)) where type Elem (Keys (IntMap v)) = Int mapReduce f = mapReduce f . IntMap.keys . getKeys@@ -155,18 +126,14 @@ instance Generator (Keys (Map k v)) where type Elem (Keys (Map k v)) = k mapReduce f = mapReduce f . Map.keys . getKeys-#endif -#ifdef M_ARRAY instance Ix i => Generator (Keys (Array i e)) where type Elem (Keys (Array i e)) = i mapReduce f = mapReduce f . range . bounds . getKeys-#endif -- | a 'Generator' transformer that asks only for the values contained in an indexed container newtype Values c = Values { getValues :: c } -#ifdef M_CONTAINERS instance Generator (Values (IntMap v)) where type Elem (Values (IntMap v)) = v mapReduce f = mapReduce f . IntMap.elems . getValues@@ -174,19 +141,15 @@ instance Generator (Values (Map k v)) where type Elem (Values (Map k v)) = v mapReduce f = mapReduce f . Map.elems . getValues-#endif -#ifdef M_ARRAY instance Ix i => Generator (Values (Array i e)) where type Elem (Values (Array i e)) = e mapReduce f = mapReduce f . elems . getValues-#endif -- | a 'Generator' transformer that treats 'Word8' as 'Char' -- This lets you use a 'ByteString' as a 'Char' source without going through a 'Monoid' transformer like 'UTF8' newtype Char8 c = Char8 { getChar8 :: c } -#ifdef M_BYTESTRING instance Generator (Char8 Strict.ByteString) where type Elem (Char8 Strict.ByteString) = Char mapTo f m = Strict8.foldl' (\a -> snoc a . f) m . getChar8@@ -194,25 +157,17 @@ instance Generator (Char8 Lazy.ByteString) where type Elem (Char8 Lazy.ByteString) = Char mapReduce f = fold . parMap rwhnf (mapReduce f . Char8) . Lazy8.toChunks . getChar8-#endif -- | Apply a 'Reducer' directly to the elements of a 'Generator' reduce :: (Generator c, Elem c `Reducer` m) => c -> m reduce = mapReduce id-#ifdef M_BYTESTRING {-# SPECIALIZE reduce :: (Word8 `Reducer` m) => Strict.ByteString -> m #-} {-# SPECIALIZE reduce :: (Word8 `Reducer` m) => Lazy.ByteString -> m #-} {-# SPECIALIZE reduce :: (Char `Reducer` m) => Char8 Strict.ByteString -> m #-} {-# SPECIALIZE reduce :: (Char `Reducer` m) => Char8 Lazy.ByteString -> m #-}-#endif {-# SPECIALIZE reduce :: (c `Reducer` m) => [c] -> m #-}-#ifdef M_FINGERTREE {-# SPECIALIZE reduce :: (Generator (FingerTree v e), e `Reducer` m) => FingerTree v e -> m #-}-#endif-#ifdef M_TEXT {-# SPECIALIZE reduce :: (Char `Reducer` m) => Text -> m #-}-#endif-#ifdef M_CONTAINERS {-# SPECIALIZE reduce :: (e `Reducer` m) => Seq e -> m #-} {-# SPECIALIZE reduce :: (Int `Reducer` m) => IntSet -> m #-} {-# SPECIALIZE reduce :: (a `Reducer` m) => Set a -> m #-}@@ -222,7 +177,6 @@ {-# SPECIALIZE reduce :: (k `Reducer` m) => Keys (Map k v) -> m #-} {-# SPECIALIZE reduce :: (v `Reducer` m) => Values (IntMap v) -> m #-} {-# SPECIALIZE reduce :: (v `Reducer` m) => Values (Map k v) -> m #-}-#endif mapReduceWith :: (Generator c, e `Reducer` m) => (m -> n) -> (Elem c -> e) -> c -> n mapReduceWith f g = f . mapReduce g
Data/Generator/Combinators.hs view
@@ -17,9 +17,9 @@ ----------------------------------------------------------------------------- module Data.Generator.Combinators- ( module Data.Generator+ ( -- * Monadic Reduction- , mapM_+ mapM_ , forM_ , msum -- * Applicative Reduction@@ -50,9 +50,11 @@ import Control.Applicative import Control.Monad (MonadPlus) import Data.Generator-import Data.Monoid.Applicative-import Data.Monoid.Self-import Data.Monoid.Monad+import Data.Monoid (Monoid, mempty, Sum(..), Product(..), All(..), Any(..), First(..))+import Data.Monoid.Applicative (Alt(..), Traversal(..))+import Data.Monoid.Self (Self(..))+import Data.Monoid.Monad (MonadSum(..), Action(..))+import Data.Monoid.Reducer (Reducer, unit) -- | Efficiently 'mapReduce' a 'Generator' using the 'Traversal' monoid. A specialized version of its namesake from "Data.Foldable" --
− Data/Generator/Compressive/LZ78.hs
@@ -1,114 +0,0 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}---------------------------------------------------------------------------------- |--- Module : Data.Generator.Compressive.LZ78--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : portable------ Compression algorithms are all about exploiting redundancy. When applying--- an expensive 'Reducer' to a redundant source, it may be better to --- extract the structural redundancy that is present. 'LZ78' is a compression--- algorithm that does so, without requiring the dictionary to be populated--- with all of the possible values of a data type unlike its later --- refinement LZW, and which has fewer comparison reqirements during encoding--- than its earlier counterpart LZ77. Since we aren't storing these as a --- bitstream the LZSS refinement of only encoding pointers once you cross--- the break-even point is a net loss. ---------------------------------------------------------------------------------module Data.Generator.Compressive.LZ78 - ( module Data.Generator- -- * Lempel-Ziv 78 - , LZ78- -- * Decoding- , decode- -- * Encoding- , encode- , encodeEq- -- * QuickCheck Properties- , prop_decode_encode- , prop_decode_encodeEq- ) where--import qualified Data.Sequence as Seq-import Data.Sequence (Seq,(|>))-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.List as List-import Data.Generator-import Data.Foldable-import Data.Monoid.Self---- | An LZ78 compressing 'Generator', which supports efficient 'mapReduce' operations--data Token a = Token a {-# UNPACK #-} !Int - deriving (Eq,Ord,Show,Read)---- after using the Functor instance the encoding may no longer be minimal-instance Functor Token where- fmap f (Token a n) = Token (f a) n--newtype LZ78 a = LZ78 { getLZ78 :: [Token a] } - deriving (Eq,Ord,Show)--emptyDict :: Monoid m => Seq m-emptyDict = Seq.singleton mempty--instance Generator (LZ78 a) where- type Elem (LZ78 a) = a- mapTo f m (LZ78 xs) = mapTo' f m emptyDict xs--instance Functor LZ78 where- fmap f = LZ78 . fmap (fmap f) . getLZ78--instance Foldable LZ78 where- foldMap f = getSelf . mapReduce f- fold = getSelf . reduce- -mapTo' :: (e `Reducer` m) => (a -> e) -> m -> Seq m -> [Token a] -> m-mapTo' _ m _ [] = m-mapTo' f m s (Token c w:ws) = m `mappend` mapTo' f v (s |> v) ws - where - v = Seq.index s w `mappend` unit (f c)---- | a type-constrained 'reduce' operation- -decode :: LZ78 a -> [a]-decode = reduce---- | contruct an LZ78-compressed 'Generator' using a 'Map' internally, requires an instance of Ord.--encode :: Ord a => [a] -> LZ78 a-encode = LZ78 . encode' Map.empty 1 0--encode' :: Ord a => Map (Token a) Int -> Int -> Int -> [a] -> [Token a]-encode' _ _ p [c] = [Token c p]-encode' d f p (c:cs) = let t = Token c p in case Map.lookup t d of- Just p' -> encode' d f p' cs- Nothing -> t : encode' (Map.insert t f d) (succ f) 0 cs-encode' _ _ _ [] = []---- | contruct an LZ78-compressed 'Generator' using a list internally, requires an instance of Eq.--encodeEq :: Eq a => [a] -> LZ78 a-encodeEq = LZ78 . encodeEq' [] 1 0--encodeEq' :: Eq a => [(Token a,Int)] -> Int -> Int -> [a] -> [Token a]-encodeEq' _ _ p [c] = [Token c p]-encodeEq' d f p (c:cs) = let t = Token c p in case List.lookup t d of- Just p' -> encodeEq' d f p' cs- Nothing -> t : encodeEq' ((t,f):d) (succ f) 0 cs-encodeEq' _ _ _ [] = []---- | QuickCheck property: decode . encode = id-prop_decode_encode :: Ord a => [a] -> Bool-prop_decode_encode xs = decode (encode xs) == xs---- | QuickCheck property: decode . encodeEq = id-prop_decode_encodeEq :: Eq a => [a] -> Bool-prop_decode_encodeEq xs = decode (encodeEq xs) == xs
− Data/Generator/Compressive/RLE.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, TypeOperators, FlexibleInstances, FlexibleContexts #-}---------------------------------------------------------------------------------- |--- Module : Data.Generator.Compressive.RLE--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : portable------ Compression algorithms are all about exploiting redundancy. When applying--- an expensive 'Reducer' to a redundant source, it may be better to --- extract the structural redundancy that is present. Run length encoding--- can do so for long runs of identical inputs.--------------------------------------------------------------------------------module Data.Generator.Compressive.RLE- ( module Data.Generator- , RLE(RLE, getRLE)- , Run(Run)- , decode- , encode- , encodeList- , prop_decode_encode- , prop_decode_encodeList- ) where--import qualified Data.Sequence as Seq-import Data.Sequence (Seq,(|>),(<|),ViewL(..),ViewR(..),(><),viewl,viewr)-import Data.Foldable-import Data.Generator-import qualified Data.Monoid.Combinators as Monoid -import Control.Functor.Pointed---- | A single run with a strict length.-data Run a = Run a {-# UNPACK #-} !Int--instance Functor Run where- fmap f (Run a n) = Run (f a) n--instance Pointed Run where- point a = Run a 1---- | A 'Generator' which supports efficient 'mapReduce' operations over run-length encoded data.-newtype RLE f a = RLE { getRLE :: f (Run a) } --instance Functor f => Functor (RLE f) where- fmap f = RLE . fmap (fmap f) . getRLE--instance Foldable f => Generator (RLE f a) where- type Elem (RLE f a) = a- mapReduce f = foldMap run . getRLE where- run (Run a n) = unit (f a) `Monoid.replicate` n--decode :: Foldable f => RLE f a -> [a]-decode = reduce---- | naive left to right encoder, which can handle infinite data--encodeList :: Eq a => [a] -> RLE [] a-encodeList [] = RLE []-encodeList (a:as) = RLE (point a `before` as)--before :: Eq a => Run a -> [a] -> [Run a]-r `before` [] = [r]-r@(Run a n) `before` (b:bs) | a == b = Run a (n+1) `before` bs- | otherwise = r : point b `before` bs---- | QuickCheck property: decode . encode = id-prop_decode_encodeList :: Eq a => [a] -> Bool-prop_decode_encodeList xs = decode (encode xs) == xs---- One nice property that run-length encoding has is that it can be computed monoidally as follows--- However, this monoid cannot be used to handle infinite sources.--instance Eq a => Monoid (RLE Seq a) where- mempty = RLE Seq.empty- RLE l `mappend` RLE r = viewr l `merge` viewl r where- (l' :> Run a m) `merge` (Run b n :< r')- | a == b = RLE ((l' |> Run a (m+n)) >< r')- | otherwise = RLE (l >< r)- EmptyR `merge` _ = RLE r- _ `merge` EmptyL = RLE l--instance Eq a => Reducer a (RLE Seq a) where- unit = RLE . Seq.singleton . point- cons a (RLE r) = case viewl r of- Run b n :< r' | a == b -> RLE (Run a (n+1) <| r')- | otherwise -> RLE (Run a 1 <| r )- EmptyL -> RLE (return (point a))- snoc (RLE l) a = case viewr l of- l' :> Run b n | a == b -> RLE (l' |> Run b (n+1))- | otherwise -> RLE (l |> Run a 1 )- EmptyR -> RLE (return (point a))--encode :: (Generator c, Eq (Elem c)) => c -> RLE Seq (Elem c)-encode = reduce--prop_decode_encode :: (Generator c, Eq (Elem c)) => c -> Bool-prop_decode_encode xs = decode (encode xs) == reduce xs
− Data/Generator/Free.hs
@@ -1,114 +0,0 @@-{-# LANGUAGE UndecidableInstances , FlexibleContexts , MultiParamTypeClasses , FlexibleInstances , GeneralizedNewtypeDeriving, ExistentialQuantification, TypeFamilies #-}---------------------------------------------------------------------------------- |--- Module : Data.Generator.Free--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (MPTCs)-----------------------------------------------------------------------------------module Data.Generator.Free- ( module Data.Generator- , module Data.Monoid.Reducer- , Free (AnyGenerator)- ) where--import Control.Functor.Pointed-import Control.Monad-import Data.Generator-import Data.Foldable-import Data.Monoid.Reducer-import Data.Monoid.Additive-import qualified Data.Generator.Combinators as Generator-import Data.Monoid.Self--data Free a - = a `Cons` Free a- | Free a `Snoc` a- | Free a `Plus` Free a- | Unit a- | Empty- | forall c. (Generator c, Elem c ~ a) => AnyGenerator c--instance Eq a => Eq (Free a) where- a == b = Generator.toList a == Generator.toList b- a /= b = Generator.toList a == Generator.toList b--instance Ord a => Ord (Free a) where- a <= b = Generator.toList a <= Generator.toList b- a >= b = Generator.toList a >= Generator.toList b- a < b = Generator.toList a < Generator.toList b- a > b = Generator.toList a > Generator.toList b- a `compare` b = Generator.toList a `compare` Generator.toList b--instance Monoid (Free a) where- mempty = Empty- mappend = Plus--instance Reducer a (Free a) where- unit = Unit-- snoc Empty a = Unit a- snoc a b = Snoc a b-- cons b Empty = Unit b- cons a b = Cons a b --instance Functor Free where- fmap f (a `Cons` b) = f a `Cons` fmap f b- fmap f (a `Snoc` b) = fmap f a `Snoc` f b- fmap f (a `Plus` b) = fmap f a `Plus` fmap f b- fmap f (Unit a) = Unit (f a)- fmap _ Empty = Empty- fmap f (AnyGenerator c) = mapReduce f c--instance Pointed Free where- point = Unit--instance Monad Free where- return = Unit- a `Cons` b >>= k = k a `Plus` (b >>= k)- a `Snoc` b >>= k = (a >>= k) `Plus` k b- a `Plus` b >>= k = (a >>= k) `Plus` (b >>= k)- Unit a >>= k = k a- Empty >>= _ = Empty- AnyGenerator c >>= k = getSelf (mapReduce k c)--instance MonadPlus Free where- mzero = Empty- mplus = Plus--instance Foldable Free where- foldMap f (a `Cons` b) = f a `mappend` foldMap f b- foldMap f (a `Snoc` b) = foldMap f a `mappend` f b- foldMap f (a `Plus` b) = foldMap f a `mappend` foldMap f b- foldMap f (Unit a) = f a - foldMap _ Empty = mempty- foldMap f (AnyGenerator c) = Generator.foldMap f c--instance Generator (Free a) where- type Elem (Free a) = a- mapReduce f (a `Cons` b) = f a `cons` mapReduce f b- mapReduce f (a `Snoc` b) = mapReduce f a `snoc` f b- mapReduce f (a `Plus` b) = mapReduce f a `plus` mapReduce f b- mapReduce f (Unit a) = unit (f a)- mapReduce _ Empty = mempty- mapReduce f (AnyGenerator c) = mapReduce f c- - mapTo f m (a `Cons` b) = m `plus` (f a `cons` mapReduce f b)- mapTo f m (a `Snoc` b) = mapTo f m a `snoc` f b- mapTo f m (a `Plus` b) = mapTo f m a `plus` mapReduce f b- mapTo f m (Unit a) = m `snoc` f a- mapTo _ m Empty = m - mapTo f m (AnyGenerator c) = mapTo f m c- - mapFrom f (a `Cons` b) m = f a `cons` mapFrom f b m - mapFrom f (a `Snoc` b) m = mapFrom f a (f b `cons` m)- mapFrom f (a `Plus` b) m = mapReduce f a `plus` mapFrom f b m- mapFrom f (Unit a) m = f a `cons` m- mapFrom _ Empty m = m - mapFrom f (AnyGenerator c) m = mapFrom f c m
Data/Group.hs view
@@ -12,8 +12,7 @@ ----------------------------------------------------------------------------- module Data.Group - ( module Data.Monoid.Multiplicative- , Group+ ( Group , gnegate , gsubtract , minus@@ -23,12 +22,10 @@ , grecip ) where -import Data.Monoid.Multiplicative-import Data.Monoid.Self--#ifdef X_OverloadedStrings-import Data.Monoid.FromString-#endif+import Data.Monoid (Monoid, Sum(..), Product(..), Dual(..))+import Data.Monoid.Additive (plus, zero)+import Data.Monoid.Multiplicative (Multiplicative, one, times, Log(..), Exp(..))+import Data.Monoid.Self (Self(Self,getSelf)) infixl 6 `minus` @@ -85,30 +82,6 @@ Self x `under` Self y = Self (x `under` y) grecip (Self x) = Self (grecip x) -#ifdef M_REFLECTION-instance MultiplicativeGroup g => MultiplicativeGroup (ReducedBy g s) where- Reduction x `over` Reduction y = Reduction (x `over` y)- Reduction x `under` Reduction y = Reduction (x `under` y)- grecip (Reduction x) = Reduction (grecip x)--instance Group a => Group (ReducedBy a s) where- gnegate = Reduction . gnegate . getReduction- Reduction a `minus` Reduction b = Reduction (a `minus` b)- Reduction a `gsubtract` Reduction b = Reduction (a `gsubtract` b)-#endif- instance MultiplicativeGroup a => MultiplicativeGroup (Dual a) where grecip = Dual . grecip . getDual--#ifdef X_OverloadedStrings-instance MultiplicativeGroup g => MultiplicativeGroup (FromString g) where- FromString x `over` FromString y = FromString (x `over` y)- FromString x `under` FromString y = FromString (x `under` y)- grecip (FromString x) = FromString (grecip x)--instance Group a => Group (FromString a) where- gnegate = FromString . gnegate . getFromString- FromString a `minus` FromString b = FromString (a `minus` b)- FromString a `gsubtract` FromString b = FromString (a `gsubtract` b)-#endif
Data/Group/Combinators.hs view
@@ -16,16 +16,12 @@ ----------------------------------------------------------------------------- module Data.Group.Combinators- ( module Data.Group- -- * Combinators- , replicate- -- * QuickCheck Properties- , prop_replicate_right_distributive+ ( replicate ) where import Prelude hiding (replicate)+import Data.Monoid (mappend, mempty) import Data.Group-import Test.QuickCheck -- shamelessly stolen from Lennart Augustsson's post: -- http://augustss.blogspot.com/2008/07/lost-and-found-if-i-write-108-in.html@@ -45,6 +41,3 @@ | y == 1 = x `mappend` z | otherwise = g (x `mappend` x) ((y - 1) `quot` 2) (x `mappend` z) -prop_replicate_right_distributive :: (Eq g, Group g, Arbitrary g, Integral n) => g -> n -> n -> Bool-prop_replicate_right_distributive g x y - = replicate g (x + y) == replicate g x `mappend` replicate g y
Data/Group/Sugar.hs view
@@ -27,6 +27,7 @@ ) where import Data.Monoid.Sugar+import Data.Monoid.Multiplicative (Log(..)) import Data.Group.Combinators as Group import Data.Group import Prelude hiding ((-), (+), (*), (/), (^^), negate, subtract, recip)
Data/Monoid/Additive.hs view
@@ -7,16 +7,15 @@ -- Stability : experimental -- Portability : portable ----- More easily understood aliases for "mappend" and "mempty" +-- More easily understood aliases for "mappend" and "mempty", chosen for+-- symmetry with Data.Monoid.Multiplicative -- -- > import Data.Monoid.Additive -- ----------------------------------------------------------------------------- module Data.Monoid.Additive- ( module Data.Monoid - , plus- , zero+ ( plus, zero ) where import Data.Monoid
Data/Monoid/Applicative.hs view
@@ -14,18 +14,17 @@ ----------------------------------------------------------------------------- module Data.Monoid.Applicative - ( module Data.Monoid.Reducer- , module Data.Ring.Module- , Traversal(Traversal,getTraversal)+ ( Traversal(Traversal,getTraversal) , Alt(Alt,getAlt) , App(App,getApp) , snocTraversal ) where import Control.Applicative-import Data.Monoid.Reducer-import Data.Ring.Module-import Control.Functor.Pointed+import Data.Group (Group, gnegate, minus, gsubtract)+import Data.Monoid (Monoid, mempty, mappend)+import Data.Monoid.Multiplicative (Multiplicative, one, times)+import Data.Monoid.Reducer (Reducer, unit, snoc, cons) -- | A 'Traversal' uses an glues together 'Applicative' actions with (*>) -- in the manner of 'traverse_' from "Data.Foldable". Any values returned by @@ -41,7 +40,6 @@ a `cons` Traversal b = Traversal (a *> b) Traversal a `snoc` b = Traversal (a *> b *> pure ()) - -- | Efficiently avoid needlessly rebinding when using 'snoc' on an action that already returns () -- A rewrite rule automatically applies this when possible snocTraversal :: Reducer (f ()) (Traversal f) => Traversal f -> f () -> Traversal f@@ -55,7 +53,7 @@ -- under these operations. newtype Alt f a = Alt { getAlt :: f a } - deriving (Eq,Ord,Show,Read,Functor,Applicative,Alternative,Copointed)+ deriving (Eq,Ord,Show,Read,Functor,Applicative,Alternative) instance Alternative f => Monoid (Alt f a) where mempty = empty @@ -65,20 +63,17 @@ one = pure mempty times = liftA2 mappend -instance Applicative f => Pointed (Alt f) where- point = pure- instance Alternative f => Reducer (f a) (Alt f a) where unit = Alt -instance (Alternative f, Monoid a) => Ringoid (Alt f a)+-- instance (Alternative f, Monoid a) => Ringoid (Alt f a) -instance (Alternative f, Monoid a) => RightSemiNearRing (Alt f a)+-- instance (Alternative f, Monoid a) => RightSemiNearRing (Alt f a) -- | if @m@ is a 'Module' over @r@ and @f@ is a 'Applicative' then @f `App` m@ is a 'Module' over @r@ as well newtype App f m = App { getApp :: f m } - deriving (Eq,Ord,Show,Read,Functor,Applicative,Alternative,Pointed,Copointed)+ deriving (Eq,Ord,Show,Read,Functor,Applicative,Alternative) instance (Monoid m, Applicative f) => Monoid (f `App` m) where mempty = pure mempty@@ -92,6 +87,6 @@ instance (c `Reducer` m, Applicative f) => Reducer c (f `App` m) where unit = pure . unit -instance (LeftModule r m, Applicative f) => LeftModule r (f `App` m) where x *. m = (x *.) <$> m-instance (RightModule r m, Applicative f) => RightModule r (f `App` m) where m .* y = (.* y) <$> m-instance (Module r m, Applicative f) => Module r (f `App` m)+-- instance (LeftModule r m, Applicative f) => LeftModule r (f `App` m) where x *. m = (x *.) <$> m+-- instance (RightModule r m, Applicative f) => RightModule r (f `App` m) where m .* y = (.* y) <$> m+-- instance (Module r m, Applicative f) => Module r (f `App` m)
− Data/Monoid/Categorical.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE GADTs, FlexibleInstances, MultiParamTypeClasses #-}---------------------------------------------------------------------------------- |--- Module : Data.Monoid.Categorical--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : portable-----------------------------------------------------------------------------------module Data.Monoid.Categorical- ( module Data.Monoid.Reducer- , module Control.Category- -- * Generalized Endo- , GEndo(GEndo, getGEndo)- -- * Monoids as Categories- , CMonoid- , categoryToMonoid- , monoidToCategory- ) where--import Prelude hiding ((.),id)-import Data.Monoid.Reducer-import Control.Category---- | The 'Monoid' of the endomorphisms over some object in an arbitrary 'Category'.-data GEndo k a = GEndo { getGEndo :: k a a } --instance Category k => Monoid (GEndo k a) where- mempty = GEndo id- GEndo f `mappend` GEndo g = GEndo (f . g)---- | A 'Monoid' is just a 'Category' with one object. This fakes that with a GADT-data CMonoid m n o where- M :: Monoid m => m -> CMonoid m a a---- | Extract the 'Monoid' from its representation as a 'Category'-categoryToMonoid :: CMonoid m m m -> m -categoryToMonoid (M m) = m-{-# INLINE categoryToMonoid #-}---- | Convert a value in a 'Monoid' into an arrow in a 'Category'.-monoidToCategory :: Monoid m => m -> CMonoid m m m -monoidToCategory = M -{-# INLINE monoidToCategory #-}--instance Monoid m => Category (CMonoid m) where- id = M mempty- M a . M b = M (a `mappend` b)--instance Monoid m => Monoid (CMonoid m m m) where- mempty = id- mappend = (.)--instance (c `Reducer` m) => Reducer c (CMonoid m m m) where- unit = M . unit--instance Monoid m => Reducer (CMonoid m m m) m where- unit (M m) = m
Data/Monoid/Combinators.hs view
@@ -17,8 +17,7 @@ ----------------------------------------------------------------------------- module Data.Monoid.Combinators- ( - -- * List-Like Monoid Production+ ( -- * List-Like Monoid Production repeat , replicate , cycle@@ -29,6 +28,7 @@ ) where import Prelude hiding (replicate, cycle, repeat)+import Data.Monoid import Data.Monoid.Reducer #ifdef M_QUICKCHECK
− Data/Monoid/FromString.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Monoid.FromString--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (overloaded strings, MPTCs)------ Transform any 'Char' 'Reducer' into an 'IsString' instance so it can be--- used directly with overloaded string literals.-----------------------------------------------------------------------------------module Data.Monoid.FromString - ( module Data.Monoid.Reducer- , FromString(FromString,getFromString)- ) where--import Control.Functor.Pointed-import Data.Generator-import Data.Monoid.Reducer-import Data.Monoid.Instances ()-import Data.String--data FromString m = FromString { getFromString :: m } --instance Monoid m => Monoid (FromString m) where- mempty = FromString mempty- FromString a `mappend` FromString b = FromString (a `mappend` b)--instance (Char `Reducer` m) => Reducer Char (FromString m) where- unit = FromString . unit--instance (Char `Reducer` m) => IsString (FromString m) where- fromString = FromString . reduce--instance Pointed FromString where- point = FromString--instance Copointed FromString where- extract = getFromString--instance Functor FromString where- fmap f (FromString x) = FromString (f x)
− Data/Monoid/Instances.hs
@@ -1,162 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, OverloadedStrings, CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---------------------------------------------------------------------------------- |--- Module : Data.Monoid.Instances--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : portable------ A collection of orphan instance declarations for Monoids that should--- eventually be pushed back down to the source packages.------ Every package that uses these instances includes this package internally.------ Includes:------ * 'Monoid' instances for the 'Monad' transformers from the mtl package------ * A 'Monoid' instance for the 'ParsecT' 'Monad' from parsec-3.------ * 'IsString' instances for tuples of 'IsString' for overloaded string support.------ * A 'Monoid' instance for the 'FingerTree' in the fingertree package ------ * 'Monoid' instances for 'Int', 'Integer', and 'Ratio' using @(+,0)@------ * 'Num' and 'Bits' instances for 'Bool' as a 'Boolean' `&&`/`||` 'SemiRing'------ This module is automatically included everywhere this functionality is required--- within this package. You should only have to import this module yourself if you --- want these instances for your own purposes.--------------------------------------------------------------------------------module Data.Monoid.Instances () where--#ifdef M_MTL-import Control.Monad.Reader-import qualified Control.Monad.RWS.Lazy as LRWS-import qualified Control.Monad.RWS.Strict as SRWS-import qualified Control.Monad.State.Lazy as LState-import qualified Control.Monad.State.Strict as SState-import Control.Monad.Writer-import qualified Control.Monad.Writer.Strict as SWriter-#endif--#ifdef X_OverloadedStrings-import Data.String-#endif--import Data.Bits-import Data.Ratio--#ifdef M_FINGERTREE-import Data.FingerTree-#endif--#ifdef M_PARSEC-import Text.Parsec.Prim-#endif--#ifdef M_MTL-instance (MonadPlus m, Monoid w) => Monoid (SWriter.WriterT w m n) where- mempty = mzero- mappend = mplus--instance (MonadPlus m, Monoid w) => Monoid (WriterT w m n) where- mempty = mzero- mappend = mplus--instance (MonadPlus m, Monoid w) => Monoid (SRWS.RWST r w s m n) where - mempty = mzero- mappend = mplus--instance (MonadPlus m, Monoid w) => Monoid (LRWS.RWST r w s m n) where - mempty = mzero- mappend = mplus--instance MonadPlus m => Monoid (ReaderT e m n) where- mempty = mzero- mappend = mplus--instance MonadPlus m => Monoid (SState.StateT s m n) where- mempty = mzero- mappend = mplus--instance MonadPlus m => Monoid (LState.StateT s m n) where- mempty = mzero- mappend = mplus-#endif--#ifdef M_FINGERTREE-instance Measured v a => Monoid (FingerTree v a) where- mempty = empty- mappend = (><)-#endif--#ifdef M_PARSEC-instance Stream s m t => Monoid (ParsecT s u m a) where- mempty = mzero- a `mappend` b = try a <|> b-#endif--#ifdef X_OverloadedStrings-instance (IsString a, IsString b) => IsString (a,b) where- fromString a = (fromString a, fromString a)--instance (IsString a, IsString b, IsString c) => IsString (a,b,c) where- fromString a = (fromString a, fromString a, fromString a)--instance (IsString a, IsString b, IsString c, IsString d) => IsString (a,b,c,d) where- fromString a = (fromString a, fromString a, fromString a, fromString a)--instance (IsString a, IsString b, IsString c, IsString d, IsString e) => IsString (a,b,c,d,e) where- fromString a = (fromString a, fromString a, fromString a, fromString a, fromString a)-#endif--instance Monoid Int where- mempty = 0- mappend = (+)--instance Monoid Integer where- mempty = 0- mappend = (+)--instance Integral m => Monoid (Ratio m) where- mempty = 0- mappend = (+)--instance Monoid Bool where- mempty = 0- mappend = (||)---- boolean semiring-instance Num Bool where- (+) = (||)- (*) = (&&)- x - y = x && not y- negate = not- abs = id- signum = id- fromInteger 0 = False- fromInteger _ = True--instance Bits Bool where- (.&.) = (&&)- (.|.) = (||)- xor True True = False- xor False False = False- xor _ _ = True- complement = not- shiftL a b = a && (b == 0)- shiftR a b = a && (b == 0)- shift a b = a && (b == 0)- rotate a _ = a- bit = (==0)- setBit a b = a || (b == 0)- testBit a b = a && (b == 0)- bitSize _ = 1- isSigned _ = False
− Data/Monoid/Lexical/SourcePosition.hs
@@ -1,119 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, BangPatterns #-}---------------------------------------------------------------------------------- |--- Module : Data.Monoid.Lexical.SourcePosition--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (MPTCs, OverloadedStrings)------ Incrementally determine locations in a source file through local information--- This allows for efficient recomputation of line #s and token locations--- while the file is being interactively updated by storing this as a supplemental--- measure on a 'FingerTree'.------ The general idea is to use this as part of a measure in a 'FingerTree' so you can--- use `mappend` to prepend a 'startOfFile' with the file information.--------------------------------------------------------------------------------module Data.Monoid.Lexical.SourcePosition- ( module Data.Monoid.Reducer.Char- , nextTab- , SourcePosition(Pos,Lines,Columns,Tab)- , SourceLine- , SourceColumn- , sourceLine- , sourceColumn- , startOfFile- , showSourcePosition- ) where--import Control.Functor.Extras-import Control.Functor.Pointed-import Data.Monoid.Reducer.Char-import Data.Generator-import Data.String----type SourceLine = Int-type SourceColumn = Int---- | A 'Monoid' of partial information about locations in a source file.--- This is polymorphic in the kind of information you want to maintain about each source file.-data SourcePosition file - = Pos file {-# UNPACK #-} !SourceLine {-# UNPACK #-} !SourceColumn -- ^ An absolute position in a file is known, or an overriding #line directive has been seen- | Lines {-# UNPACK #-} !SourceLine {-# UNPACK #-} !SourceColumn -- ^ We've seen some carriage returns.- | Columns {-# UNPACK #-} !SourceColumn -- ^ We've only seen part of a line.- | Tab {-# UNPACK #-} !SourceColumn {-# UNPACK #-} !SourceColumn -- ^ We have an unhandled tab to deal with.- deriving (Read,Show,Eq)---- | Compute the location of the next standard 8-column aligned tab-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 IsString (SourcePosition file) where- fromString = reduce---- accumulate partial information-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- unit '\n' = Lines 1 1- unit '\t' = Tab 0 0 - unit _ = Columns 1---- Indicate that we ignore invalid characters to the UTF8 parser-instance CharReducer (SourcePosition file)- --- | lift information about a source file into a starting 'SourcePosition' for that file-startOfFile :: f -> SourcePosition f-startOfFile = point---- | extract partial information about the current column, even in the absence of knowledge of the source file-sourceColumn :: SourcePosition f -> Maybe SourceColumn-sourceColumn (Pos _ _ c) = Just c-sourceColumn (Lines _ c) = Just c-sourceColumn _ = Nothing---- | extract partial information about the current line number if possible-sourceLine :: SourcePosition f -> Maybe SourceLine-sourceLine (Pos _ l _) = Just l-sourceLine _ = Nothing---- | extract the standard format for an absolute source position-showSourcePosition :: SourcePosition String -> String-showSourcePosition pos = showSourcePosition' (point "-" `mappend` pos) where- showSourcePosition' (Pos f l c) = f ++ ":" ++ show l ++ ":" ++ show c- showSourcePosition' _ = undefined
− Data/Monoid/Lexical/UTF8/Decoder.hs
@@ -1,224 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}---------------------------------------------------------------------------------- |--- Module : Data.Monoid.Lexical.UTF8.Decoder--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (MPTCs)------ UTF8 encoded unicode characters can be parsed both forwards and backwards,--- since the start of each 'Char' is clearly marked. This 'Monoid' accumulates--- information about the characters represented and reduces that information--- using a 'CharReducer', which is just a 'Reducer' 'Monoid' that knows what --- it wants to do about an 'invalidChar' -- a string of 'Word8' values that --- don't form a valid UTF8 character.------ As this monoid parses chars it just feeds them upstream to the underlying--- CharReducer. Efficient left-to-right and right-to-left traversals are --- supplied so that a lazy 'ByteString' can be parsed efficiently by --- chunking it into strict chunks, and batching the traversals over each--- before stitching the edges together.------ Because this needs to be a 'Monoid' and should return the exact same result--- regardless of forward or backwards parsing, it chooses to parse only --- canonical UTF8 unlike most Haskell UTF8 parsers, which will blissfully --- accept illegal alternative long encodings of a character. ------ This actually fixes a potential class of security issues in some scenarios:------ <http://prowebdevelopmentblog.com/content/big-overhaul-java-utf-8-charset>------ NB: Due to naive use of a list to track the tail of an unfinished character --- this may exhibit @O(n^2)@ behavior parsing backwards along an invalid sequence --- of a large number of bytes that all claim to be in the tail of a character.------------------------------------------------------------------------------------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 reducing 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--snocH :: CharReducer m => H -> Word8 -> (m -> H -> UTF8 m) -> m -> UTF8 m-snocH 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-snocH (H2_1 c) d k m- | d >= 0x80 && d < 0xc0 = k (m `mappend` b2 c d) H0- | otherwise = k (m `mappend` invalidChar [c]) H0-snocH (H3_1 c) d k m - | d >= 0x80 && d < 0xc0 = k m (H3_2 c d)- | otherwise = k (m `mappend` invalidChar [c]) H0-snocH (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-snocH (H4_1 c) d k m - | d >= 0x80 && d < 0xc0 = k m (H4_2 c d)- | otherwise = k (m `mappend` invalidChar [c,d]) H0-snocH (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-snocH (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 = fromChar . toEnum $ fromEnum c- | otherwise = invalidChar [c]--b2 :: CharReducer m => Word8 -> Word8 -> m-b2 c d | valid_b2 c d = fromChar (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 = fromChar (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 = fromChar (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)--consT :: CharReducer m => Word8 -> T -> (H -> UTF8 m) -> (m -> UTF8 m) -> (T -> UTF8 m) -> UTF8 m-consT 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- unit c | c >= 0x80 && c < 0xc0 = T [c]- | otherwise = snocH H0 c (S []) mempty- S t m h `snoc` c = snocH h c (S t) m- T t `snoc` c | c >= 0x80 && c < 0xc0 = T (t ++ [c])- | otherwise = snocH H0 c (S t) mempty-- c `cons` T cs = consT c cs (S [] mempty) (flip (S []) H0) T- c `cons` S cs m h = consT 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
− Data/Monoid/Lexical/Words.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, GeneralizedNewtypeDeriving, ParallelListComp, TypeFamilies, OverloadedStrings, UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Monoid.Lexical.Words--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (MPTCs, OverloadedStrings)------ A simple demonstration of tokenizing a 'Generator' into distinct words --- and/or lines using a word-parsing 'Monoid' that accumulates partial --- information about words and then builds up a token stream.-----------------------------------------------------------------------------------module Data.Monoid.Lexical.Words - ( module Data.Monoid.Reducer.Char- -- * Words- , Words- , runWords- , Unspaced(runUnspaced)- , wordsFrom- -- * Lines- , 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---- | A 'CharReducer' transformer that breaks a 'Char' 'Generator' into distinct words, feeding a 'Char' 'Reducer' each line in turn-data Words m = Chunk (Maybe m)- | Segment (Maybe m) [m] (Maybe m)- deriving (Show,Read)---- | Extract the matched words from the 'Words' 'Monoid'-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---- | A 'CharReducer' transformer that breaks a 'Char' 'Generator' into distinct lines, feeding a 'Char' 'Reducer' each line in turn.-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---- | Extract the matched lines from the 'Lines' 'Monoid'-runLines :: Lines m -> [m]-runLines (Lines x) = runWords x---- | A 'CharReducer' transformer that strips out any character matched by `isSpace`-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---- | A 'CharReducer' transformer that strips out newlines-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---- | Utility function to extract words using 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))---- | Utility function to extract lines using 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))
Data/Monoid/Monad.hs view
@@ -14,10 +14,9 @@ ----------------------------------------------------------------------------- module Data.Monoid.Monad - ( module Data.Monoid.Reducer- , module Data.Ring.Module+ ( -- * Actions- , Action(Action,getAction)+ Action(Action,getAction) , snocAction -- * MonadPlus Monoid , MonadSum(MonadSum, getMonadSum)@@ -26,10 +25,11 @@ ) where import Control.Applicative-import Control.Functor.Pointed-import Data.Monoid.Reducer-import Data.Ring.Module import Control.Monad+import Data.Monoid (Monoid, mappend, mempty)+import Data.Monoid.Multiplicative (Multiplicative, one, times)+import Data.Monoid.Reducer (Reducer, unit, cons, snoc)+import Data.Group (Group, gnegate, minus, gsubtract) -- | An 'Action' uses glues together 'Monad' actions with (>>) -- in the manner of 'mapM_' from "Data.Foldable". Any values returned by @@ -76,20 +76,17 @@ pure = return (<*>) = ap -instance Monad m => Pointed (MonadSum m) where- point = return- instance MonadPlus m => Reducer (m a) (MonadSum m a) where unit = MonadSum -instance (MonadPlus m, Monoid a) => Ringoid (MonadSum m a)+-- instance (MonadPlus m, Monoid a) => Ringoid (MonadSum m a) -instance (MonadPlus m, Monoid a) => RightSemiNearRing (MonadSum m a)+-- instance (MonadPlus m, Monoid a) => RightSemiNearRing (MonadSum m a) -- | if @m@ is a 'Module' over @r@ and @f@ is a 'Monad' then @f `Mon` m@ is a 'Module' as well newtype Mon f m = Mon { getMon :: f m } - deriving (Eq,Ord,Show,Read,Functor,Pointed, Monad,MonadPlus)+ deriving (Eq,Ord,Show,Read,Functor,Monad,MonadPlus) instance (Monoid m, Monad f) => Monoid (f `Mon` m) where mempty = return mempty@@ -103,10 +100,6 @@ instance (c `Reducer` m, Monad f) => Reducer c (f `Mon` m) where unit = return . unit -instance (LeftModule r m, Monad f) => LeftModule r (f `Mon` m) where- x *. m = liftM (x *.) m--instance (RightModule r m, Monad f) => RightModule r (f `Mon` m) where- m .* y = liftM (.* y) m--instance (Module r m, Monad f) => Module r (f `Mon` m)+-- instance (LeftModule r m, Monad f) => LeftModule r (f `Mon` m) where x *. m = liftM (x *.) m+-- instance (RightModule r m, Monad f) => RightModule r (f `Mon` m) where m .* y = liftM (.* y) m+-- instance (Module r m, Monad f) => Module r (f `Mon` m)
Data/Monoid/Multiplicative.hs view
@@ -30,9 +30,7 @@ ----------------------------------------------------------------------------- module Data.Monoid.Multiplicative - ( module Data.Monoid.Additive- -- * Multiplicative Monoids- , Multiplicative+ ( Multiplicative , one, times -- * Multiplicative to Monoid , Log(Log, getLog)@@ -41,47 +39,16 @@ ) where import Control.Applicative-import Data.Monoid.Additive+import Control.Monad (liftM2)+import Data.Monoid (Monoid, mappend, mempty, Dual(..)) import Data.Generator-import Data.Monoid.Instances () import Data.Monoid.Self import Data.Ratio -#ifdef M_STM-import Control.Concurrent.STM-#endif--#ifdef M_MTL-import Control.Monad.Cont-import Control.Monad.Identity-import Control.Monad.Reader-import qualified Control.Monad.RWS.Lazy as LRWS-import qualified Control.Monad.RWS.Strict as SRWS-import qualified Control.Monad.State.Lazy as LState-import qualified Control.Monad.State.Strict as SState-import qualified Control.Monad.Writer.Lazy as LWriter-import qualified Control.Monad.Writer.Strict as SWriter-import qualified Control.Monad.ST.Lazy as LST-import qualified Control.Monad.ST.Strict as SST-#endif--#ifdef M_FINGERTREE import Data.FingerTree-#endif--#ifdef M_CONTAINERS import qualified Data.Sequence as Seq import Data.Sequence (Seq)-#endif -#ifdef M_PARSEC-import Text.Parsec.Prim-#endif--#ifdef X_OverloadedStrings-import Data.Monoid.FromString-#endif- class Multiplicative m where one :: m times :: m -> m -> m@@ -90,10 +57,6 @@ one = Dual one Dual x `times` Dual y = Dual (y `times` x) -instance Multiplicative m => Multiplicative (m `ReducedBy` s) where- one = Reduction one- Reduction x `times` Reduction y = Reduction (x `times` y)- -- | Convert a 'Multiplicative' into a 'Monoid'. Mnemonic: @Log a + Log b = Log (a * b)@ data Log m = Log { getLog :: m } @@ -112,22 +75,16 @@ one = Self one Self a `times` Self b = Self (a `times` b) --- Monad instances instance Monoid m => Multiplicative [m] where one = return mempty times = liftM2 mappend+ instance Monoid m => Multiplicative (Maybe m) where one = return mempty times = liftM2 mappend instance Monoid n => Multiplicative (IO n) where one = return mempty times = liftM2 mappend-instance Monoid n => Multiplicative (SST.ST s n) where- one = return mempty- times = liftM2 mappend-instance Monoid n => Multiplicative (LST.ST s n) where- one = return mempty- times = liftM2 mappend -- Applicative instances instance Monoid n => Multiplicative (ZipList n) where@@ -151,87 +108,11 @@ one = 1 times = (*) -#ifdef M_CONTAINERS instance Monoid m => Multiplicative (Seq m) where one = return mempty times = liftM2 mappend-#endif -#ifdef M_FINGERTREE--- and things that can't quite be a Monad in Haskell+-- not quite be a Monad in Haskell instance (Measured v m, Monoid m) => Multiplicative (FingerTree v m) where one = singleton mempty xss `times` yss = getSelf $ mapReduce (flip fmap' yss . mappend) xss-#endif--#ifdef M_MTL-instance Monoid m => Multiplicative (Identity m) where- one = return mempty- times = liftM2 mappend-instance (Monoid m) => Multiplicative (Cont r m) where- one = return mempty- times = liftM2 mappend-instance (Monoid w, Monoid m) => Multiplicative (SRWS.RWS r w s m) where- one = return mempty- times = liftM2 mappend-instance (Monoid w, Monoid m) => Multiplicative (LRWS.RWS r w s m) where- one = return mempty- times = liftM2 mappend-instance Monoid m => Multiplicative (SState.State s m) where- one = return mempty- times = liftM2 mappend-instance Monoid m => Multiplicative (LState.State s m) where- one = return mempty- times = liftM2 mappend-instance Monoid m => Multiplicative (Reader e m) where- one = return mempty- times = liftM2 mappend-instance (Monoid w, Monoid m) => Multiplicative (SWriter.Writer w m) where- one = return mempty- times = liftM2 mappend-instance (Monoid w, Monoid m) => Multiplicative (LWriter.Writer w m) where- one = return mempty- times = liftM2 mappend-instance (Monad m, Monoid n) => Multiplicative (ContT r m n) where- one = return mempty - times = liftM2 mappend-instance (Monad m, Monoid w, Monoid n) => Multiplicative (SRWS.RWST r w s m n) where - one = return mempty - times = liftM2 mappend-instance (Monad m, Monoid w, Monoid n) => Multiplicative (LRWS.RWST r w s m n) where - one = return mempty - times = liftM2 mappend-instance (Monad m, Monoid n) => Multiplicative (SState.StateT s m n) where- one = return mempty- times = liftM2 mappend-instance (Monad m, Monoid n) => Multiplicative (LState.StateT s m n) where- one = return mempty- times = liftM2 mappend-instance (Monad m, Monoid n) => Multiplicative (ReaderT e m n) where- one = return mempty- times = liftM2 mappend-instance (Monad m, Monoid w, Monoid n) => Multiplicative (SWriter.WriterT w m n) where- one = return mempty - times = liftM2 mappend-instance (Monad m, Monoid w, Monoid n) => Multiplicative (LWriter.WriterT w m n) where- one = return mempty - times = liftM2 mappend-#endif--#ifdef M_STM-instance Monoid n => Multiplicative (STM n) where- one = return mempty- times = liftM2 mappend-#endif--#ifdef M_PARSEC-instance (Stream s m t, Monoid n) => Multiplicative (ParsecT s u m n) where- one = return mempty- times = liftM2 mappend-#endif--#ifdef X_OverloadedStrings -instance Multiplicative m => Multiplicative (FromString m) where- one = FromString one- FromString a `times` FromString b = FromString (a `times` b)-#endif
Data/Monoid/Ord.hs view
@@ -13,9 +13,9 @@ ----------------------------------------------------------------------------- module Data.Monoid.Ord - ( module Data.Monoid.Reducer+ ( -- * Max- , Max(Max,getMax)+ Max(Max,getMax) -- * Min , Min(Min,getMin) -- * MaxPriority: Max semigroup w/ added bottom@@ -26,9 +26,8 @@ , infinity ) where -import Control.Functor.Pointed-import Data.Monoid.Reducer (Reducer, unit, Monoid, mappend, mempty)-import Data.Ring+import Data.Monoid (Monoid, mappend, mempty)+import Data.Monoid.Reducer (Reducer, unit) -- | The 'Monoid' @('max','minBound')@ newtype Max a = Max { getMax :: a } deriving (Eq,Ord,Show,Read,Bounded)@@ -43,12 +42,6 @@ instance Functor Max where fmap f (Max a) = Max (f a) -instance Pointed Max where- point = Max--instance Copointed Max where- extract = getMax- -- | The 'Monoid' given by @('min','maxBound')@ newtype Min a = Min { getMin :: a } deriving (Eq,Ord,Show,Read,Bounded) @@ -62,12 +55,6 @@ instance Functor Min where fmap f (Min a) = Min (f a) -instance Pointed Min where- point = Min--instance Copointed Min where- extract = getMin- minfinity :: MaxPriority a minfinity = MaxPriority Nothing @@ -84,9 +71,6 @@ instance Functor MaxPriority where fmap f (MaxPriority a) = MaxPriority (fmap f a) -instance Pointed MaxPriority where- point = MaxPriority . Just- infinity :: MinPriority a infinity = MinPriority Nothing @@ -108,6 +92,3 @@ instance Functor MinPriority where fmap f (MinPriority a) = MinPriority (fmap f a)--instance Pointed MinPriority where- point = MinPriority . Just
Data/Monoid/Reducer.hs view
@@ -16,22 +16,18 @@ ----------------------------------------------------------------------------- module Data.Monoid.Reducer- ( module Data.Monoid- , Reducer+ ( Reducer , unit, snoc, cons , foldMapReduce , foldReduce , pureUnit , returnUnit- , ReducedBy(Reduction,getReduction) ) where import Control.Applicative import Control.Monad import Data.Monoid-import Data.Monoid.Instances ()- import Data.Foldable #ifdef M_FINGERTREE@@ -51,10 +47,6 @@ import Data.Map (Map) #endif -#ifdef M_REFLECTION-import Data.Reflection-#endif- #ifdef M_PARSEC import Text.Parsec.Prim #endif@@ -195,15 +187,4 @@ unit = uncurry Map.singleton cons = uncurry Map.insert snoc = flip . uncurry . Map.insertWith $ const id-#endif--#ifdef M_REFLECTION-data (m `ReducedBy` s) = Reduction { getReduction :: m } --instance Monoid m => Monoid (m `ReducedBy` s) where- mempty = Reduction mempty- Reduction a `mappend` Reduction b = Reduction (a `mappend` b)--instance (s `Reflects` (a -> m), Monoid m) => Reducer a (m `ReducedBy` s) where- unit = Reduction . reflect (undefined :: s) #endif
− Data/Monoid/Reducer/Char.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE UndecidableInstances, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Monoid.Reducer.Char--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (MPTCs)-----------------------------------------------------------------------------------module Data.Monoid.Reducer.Char- ( module Data.Monoid.Reducer- , CharReducer- , invalidChar- , fromChar- ) where--import Data.Monoid.Reducer-import Data.Word (Word8)---- | Provides a mechanism for the UTF8 'Monoid' to report invalid characters to one or more monoids.--class Reducer Char m => CharReducer m where- fromChar :: Char -> m - fromChar = unit-- 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]
− Data/Monoid/Reducer/With.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Monoid.Reducer.With--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (MPTCs)-----------------------------------------------------------------------------------module Data.Monoid.Reducer.With- ( module Data.Monoid.Reducer- , WithReducer(WithReducer,withoutReducer)- ) where--import Data.Monoid.Reducer-import Data.FingerTree---- | If @m@ is a @c@-"Reducer", then m is @(c `WithReducer` m)@-"Reducer"--- This can be used to quickly select a "Reducer" for use as a 'FingerTree'--- 'measure'.--newtype WithReducer c m = WithReducer { withoutReducer :: c } --instance (c `Reducer` m) => Reducer (c `WithReducer` m) m where- unit = unit . withoutReducer --instance (c `Reducer` m) => Measured m (c `WithReducer` m) where- measure = unit . withoutReducer
Data/Monoid/Self.hs view
@@ -19,13 +19,11 @@ ----------------------------------------------------------------------------- module Data.Monoid.Self- ( module Data.Monoid.Reducer- , Self(Self, getSelf)+ ( Self(Self, getSelf) ) where -import Control.Functor.Pointed-import Data.Monoid.Reducer-import Data.Generator+import Data.Monoid (Monoid)+import Data.Monoid.Reducer (Reducer, unit) newtype Self m = Self { getSelf :: m } deriving (Monoid) @@ -34,9 +32,3 @@ instance Functor Self where fmap f (Self x) = Self (f x)--instance Pointed Self where- point = Self--instance Copointed Self where- extract = getSelf
Data/Monoid/Sugar.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Module : Data.Monoid.Additive.Sugar+-- Module : Data.Monoid.Sugar -- Copyright : (c) Edward Kmett 2009 -- License : BSD-style -- Maintainer : ekmett@gmail.com@@ -16,16 +16,14 @@ ----------------------------------------------------------------------------- -- module Data.Monoid.Sugar- ( module Data.Monoid.Multiplicative- , module Data.Ring.Semi.Natural- , (+)+ ( (+) , (*)- , (^)+ , (^) ) where -import Prelude hiding ((*),(^),(+))-import Data.Monoid.Multiplicative-import Data.Ring.Semi.Natural+import Prelude hiding ((*),(+),(^))+import Data.Monoid (Monoid, mappend)+import Data.Monoid.Multiplicative (Multiplicative, times, Log(..)) import qualified Data.Monoid.Combinators as Monoid infixl 6 + @@ -37,5 +35,5 @@ (*) :: Multiplicative r => r -> r -> r (*) = times -(^) :: Multiplicative r => r -> Natural -> r-r ^ n = getLog (Monoid.replicate (Log r) n)+(^) :: (Multiplicative r, Integral b) => r -> b -> r+m ^ n = getLog (Monoid.replicate (Log m) n)
Data/Monoid/Union.hs view
@@ -13,6 +13,7 @@ , UnionWith(UnionWith,getUnionWith) ) where + import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) @@ -27,8 +28,7 @@ import qualified Data.List as List -import Control.Functor.Pointed-+import Data.Monoid import Data.Monoid.Reducer -- | A Container suitable for the 'Union' 'Monoid'@@ -75,12 +75,6 @@ instance Functor Union where fmap f (Union a) = Union (f a) -instance Pointed Union where - point = Union--instance Copointed Union where- extract = getUnion- -- | Polymorphic containers that we can supply an operation to handle unions with class Functor f => HasUnionWith f where {-# SPECIALIZE unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a #-}@@ -98,7 +92,7 @@ -- | The 'Monoid' @('unionWith mappend','empty')@ for containers full of monoids. newtype UnionWith f m = UnionWith { getUnionWith :: f m } - deriving (Eq,Ord,Show,Read,Functor,Pointed,Monad)+ deriving (Eq,Ord,Show,Read,Functor,Monad) instance (HasUnionWith f, Monoid m) => Monoid (UnionWith f m) where mempty = UnionWith emptyWith
− Data/Ring.hs
@@ -1,154 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module : Data.Ring--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : portable (instances use MPTCs)--------- Defines left- and right- seminearrings. Every 'MonadPlus' wrapped around--- a 'Monoid' qualifies due to the distributivity of (>>=) over 'mplus'.------ See <http://conway.rutgers.edu/~ccshan/wiki/blog/posts/WordNumbers1/>-----------------------------------------------------------------------------------module Data.Ring- ( module Data.Group- , Ringoid- , LeftSemiNearRing- , RightSemiNearRing- , SemiRing- , Ring- , DivisionRing- , Field- ) where--import Data.Group-import Data.Monoid.Self--#ifdef X_OverloadedStrings-import Data.Monoid.FromString-#endif--#ifdef M_MTL-import Control.Monad.Reader-import qualified Control.Monad.RWS.Lazy as LRWS-import qualified Control.Monad.RWS.Strict as SRWS-import qualified Control.Monad.State.Lazy as LState-import qualified Control.Monad.State.Strict as SState-import qualified Control.Monad.Writer.Lazy as LWriter-import qualified Control.Monad.Writer.Strict as SWriter-#endif--#ifdef M_FINGERTREE-import Data.FingerTree-#endif--#ifdef M_CONTAINERS-import qualified Data.Sequence as Seq-import Data.Sequence (Seq)-#endif--#ifdef M_PARSEC-import Text.Parsec.Prim-#endif--#ifdef X_OverloadedStrings-import Data.Monoid.FromString-#endif---- | @0@ annihilates `times`-class (Multiplicative m, Monoid m) => Ringoid m-instance Ringoid Integer-instance Ringoid Int-instance Ringoid m => Ringoid (Self m)-instance Ringoid m => Ringoid (Dual m)-instance Monoid m => Ringoid [m]-instance Monoid m => Ringoid (Maybe m)---- | @a * (b + c) = (a * b) + (a * c)@-class Ringoid m => LeftSemiNearRing m -instance LeftSemiNearRing m => LeftSemiNearRing (Self m)-instance RightSemiNearRing m => LeftSemiNearRing (Dual m)---- | @(a + b) * c = (a * c) + (b * c)@-class Ringoid m => RightSemiNearRing m -instance RightSemiNearRing m => RightSemiNearRing (Self m)-instance LeftSemiNearRing m => RightSemiNearRing (Dual m)-instance Monoid m => RightSemiNearRing [m]-instance Monoid m => RightSemiNearRing (Maybe m)---- | A 'SemiRing' is an instance of both 'Multiplicative' and 'Monoid' where --- 'times' distributes over 'plus'.-class (RightSemiNearRing a, LeftSemiNearRing a) => SemiRing a-instance SemiRing r => SemiRing (Self r)-instance SemiRing r => SemiRing (Dual r)--class (Group a, SemiRing a) => Ring a-instance Ring r => Ring (Self r)-instance Ring r => Ring (Dual r)--class (Ring a, MultiplicativeGroup a) => DivisionRing a-instance DivisionRing r => DivisionRing (Self r)-instance DivisionRing r => DivisionRing (Dual r)--class (Ring a, MultiplicativeGroup a) => Field a-instance Field f => Field (Dual f)-instance Field f => Field (Self f)--#ifdef M_REFLECTION-instance Ringoid m => Ringoid (ReducedBy m s)-instance LeftSemiNearRing m => LeftSemiNearRing (ReducedBy m s)-instance RightSemiNearRing m => RightSemiNearRing (ReducedBy m s)-instance SemiRing r => SemiRing (ReducedBy r s)-instance Ring r => Ring (ReducedBy r s)-instance DivisionRing r => DivisionRing (ReducedBy r s)-instance Field f => Field (ReducedBy f s)-#endif--#ifdef M_PARSEC-instance (Stream s m t, Monoid a) => Ringoid (ParsecT s u m a)-instance (Stream s m t, Monoid a) => RightSemiNearRing (ParsecT s u m a)-#endif--#ifdef M_MTL-instance (MonadPlus m, Monoid n) => Ringoid (SState.StateT s m n)-instance (MonadPlus m, Monoid n) => Ringoid (LState.StateT s m n)-instance (MonadPlus m, Monoid n) => Ringoid (ReaderT e m n)-instance (MonadPlus m, Monoid w, Monoid n) => Ringoid (SRWS.RWST r w s m n)-instance (MonadPlus m, Monoid w, Monoid n) => Ringoid (LRWS.RWST r w s m n)-instance (MonadPlus m, Monoid w, Monoid n) => Ringoid (SWriter.WriterT w m n)-instance (MonadPlus m, Monoid w, Monoid n) => Ringoid (LWriter.WriterT w m n)-instance (MonadPlus m, Monoid n) => RightSemiNearRing (SState.StateT s m n)-instance (MonadPlus m, Monoid n) => RightSemiNearRing (LState.StateT s m n)-instance (MonadPlus m, Monoid n) => RightSemiNearRing (ReaderT e m n)-instance (MonadPlus m, Monoid w, Monoid n) => RightSemiNearRing (SRWS.RWST r w s m n)-instance (MonadPlus m, Monoid w, Monoid n) => RightSemiNearRing (LRWS.RWST r w s m n)-instance (MonadPlus m, Monoid w, Monoid n) => RightSemiNearRing (SWriter.WriterT w m n)-instance (MonadPlus m, Monoid w, Monoid n) => RightSemiNearRing (LWriter.WriterT w m n)-#endif--#ifdef M_FINGERTREE-instance (Measured v m, Monoid m) => Ringoid (FingerTree v m)-instance (Measured v m, Monoid m) => RightSemiNearRing (FingerTree v m)-#endif--#ifdef M_CONTAINERS-instance Monoid m => Ringoid (Seq m)-instance Monoid m => RightSemiNearRing (Seq m)-#endif--#ifdef X_OverloadedStrings-instance Ringoid m => Ringoid (FromString m)-instance RightSemiNearRing m => RightSemiNearRing (FromString m)-instance LeftSemiNearRing m => LeftSemiNearRing (FromString m)-instance SemiRing r => SemiRing (FromString r)-instance Ring r => Ring (FromString r)-instance DivisionRing r => DivisionRing (FromString r)-instance Field f => Field (FromString f)-#endif
− Data/Ring/Boolean.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}---------------------------------------------------------------------------------- |--- Module : Data.Ring.Boolean--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (MPTCs)------ A Boolean 'Ring' over any Bits instance. Note well that the 'mappend' of this ring is xor.--- You should use use 'Ord' from "Data.Ring.Semi.Ord.Order" on 'Bool' to get the '&&'/'||'-based --- distributive-lattice 'SemiRing'.------ Also note that @gnegate = id@ in a Boolean Ring!--------------------------------------------------------------------------------module Data.Ring.Boolean- ( module Data.Ring- , Boolean(Boolean, getBoolean)- ) where--import Data.Bits-import Data.Ring-import Data.Ring.Module-import Data.Ring.Semi.Natural-import Data.Monoid.Reducer-import Test.QuickCheck hiding ((.&.))--newtype Boolean a = Boolean { getBoolean :: a } deriving (Eq,Ord,Show,Read,Arbitrary,CoArbitrary)---- | @xor@-instance Bits a => Monoid (Boolean a) where- mempty = Boolean 0 - Boolean a `mappend` Boolean b = Boolean ((a .|. b) .&. complement (a .&. b))---- | @id@, since @x `xor` x = zero@-instance Bits a => Group (Boolean a) where- gnegate = Boolean . id . getBoolean---- | @and@-instance Bits a => Multiplicative (Boolean a) where- one = Boolean (complement 0)- Boolean a `times` Boolean b = Boolean (a .&. b)---- | the boolean ring (using symmetric difference as addition) is a ring-instance Bits a => Ringoid (Boolean a)-instance Bits a => LeftSemiNearRing (Boolean a)-instance Bits a => RightSemiNearRing (Boolean a)-instance Bits a => SemiRing (Boolean a)-instance Bits a => Ring (Boolean a)---- | it reduces boolean values-instance Bits a => Reducer a (Boolean a) where- unit = Boolean---- | every monoid is a module over the naturals, boolring is idempotent-instance Bits a => Module Natural (Boolean a)-instance Bits a => LeftModule Natural (Boolean a) where- 0 *. _ = mempty- _ *. m = m-instance Bits a => RightModule Natural (Boolean a) where- _ .* 0 = mempty- m .* _ = m-instance Bits a => Bimodule Natural (Boolean a)---- | every group is a module over the integers, boolring is idempotent-instance Bits a => Module Integer (Boolean a)-instance Bits a => LeftModule Integer (Boolean a) where- 0 *. _ = mempty- _ *. m = m-instance Bits a => RightModule Integer (Boolean a) where- _ .* 0 = mempty- m .* _ = m-instance Bits a => Bimodule Integer (Boolean a)---- | every ring is a module over itself-instance Bits a => Module (Boolean a) (Boolean a)-instance Bits a => LeftModule (Boolean a) (Boolean a) where - (*.) = times-instance Bits a => RightModule (Boolean a) (Boolean a) where - (.*) = times-instance Bits a => Bimodule (Boolean a) (Boolean a)-instance Bits a => Normed (Boolean a) (Boolean a) where mabs = id
− Data/Ring/FromNum.hs
@@ -1,49 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}---------------------------------------------------------------------------------- |--- Module : Data.Ring.FromNum--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (MPTCs)------ A wrapper that lies for you and claims any instance of 'Num' is a 'Ring'.--- Who knows, for your type it might even be telling the truth!-----------------------------------------------------------------------------------module Data.Ring.FromNum - ( module Data.Ring- , FromNum(FromNum, getFromNum)- ) where--import Data.Ring-import Data.Monoid.Reducer-import Test.QuickCheck--newtype FromNum a = FromNum { getFromNum :: a } deriving (Eq,Show,Num,Arbitrary,CoArbitrary)--instance Num a => Monoid (FromNum a) where- mempty = fromInteger 0- mappend = (+)--instance Num a => Group (FromNum a) where- minus = (-)- gnegate = negate- -instance Num a => Multiplicative (FromNum a) where- one = fromInteger 1- times = (*)---- you can assume these, but you're probably lying to yourself-instance Num a => Ringoid (FromNum a)-instance Num a => LeftSemiNearRing (FromNum a)-instance Num a => RightSemiNearRing (FromNum a)-instance Num a => SemiRing (FromNum a)-instance Num a => Ring (FromNum a)- -instance Num a => Reducer Integer (FromNum a) where- unit = fromInteger-
− Data/Ring/ModularArithmetic.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE RankNTypes, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, EmptyDataDecls, FunctionalDependencies, TypeOperators #-}--------------------------------------------------------------------------------- |--- Module : Data.Ring.ModularArithmetic--- Copyright : Edward Kmett 2009, Oleg Kiselyov and Chung-chieh Shan 2004--- --- License : BSD-style--- Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : non-portable (MPTCs, scoped types, empty decls, type operators)-----------------------------------------------------------------------------------module Data.Ring.ModularArithmetic- ( module Data.Ring- , Mod(getMod), Modular, modulus- , withIntegralModulus- ) where--import Data.Ring-import Data.Reflection--newtype (a `Mod` s) = M { getMod :: a } - deriving (Eq,Show)--class Modular s a | s -> a where- modulus :: s -> a--normalize :: (Modular s a, Integral a) => a -> (a `Mod` s)-normalize = normalize' undefined where- normalize' :: (Modular s a, Integral a) => s -> a -> (a `Mod` s)- normalize' s a = M (a `mod` modulus s)--data ModulusNum s a--instance (ReflectedNum s, Num a) => Modular (ModulusNum s a) a where- modulus _ = reflectNum (undefined :: s)--withIntegralModulus :: Integral a => a -> (forall s. Modular s a => w `Mod` s) -> w-withIntegralModulus = withIntegralModulus' undefined where- withIntegralModulus' :: Integral a => w -> a -> (forall s. Modular s a => w `Mod` s) -> w- withIntegralModulus' (_ :: w) (i :: a) k = - reifyIntegral i (\(_ :: t) -> - getMod (k :: w `Mod` ModulusNum t a))--instance (Modular s a, Integral a) => Num (a `Mod` s) where- M a + M b = normalize (a + b)- M a - M b = normalize (a - b)- M a * M b = normalize (a * b)- negate (M a) = normalize (negate a)- fromInteger i = normalize (fromInteger i)- signum = error "broken numerical type tower"- abs = error "broken numerical type tower"--instance (Modular s a, Integral a) => Monoid (a `Mod` s) where- mempty = 0- mappend = (+)--instance (Modular s a, Integral a) => Multiplicative (a `Mod` s) where- one = 1- times = (*)--instance (Modular s a, Integral a) => Group (a `Mod` s) where- gnegate = negate- minus = (-)- gsubtract = subtract--instance (Modular s a, Integral a) => Ringoid (a `Mod` s)-instance (Modular s a, Integral a) => LeftSemiNearRing (a `Mod` s)-instance (Modular s a, Integral a) => RightSemiNearRing (a `Mod` s)-instance (Modular s a, Integral a) => SemiRing (a `Mod` s)-instance (Modular s a, Integral a) => Ring (a `Mod` s)
− Data/Ring/Module.hs
@@ -1,107 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}--------------------------------------------------------------------------------- |--- Module : Data.Ring.Module--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (MPTCs)------ Left- and right- modules over rings, semirings, and Seminearrings.--- To avoid a proliferation of classes. These only require that there--- be an addition and multiplication operation for the 'Ring'-----------------------------------------------------------------------------------module Data.Ring.Module - ( module Data.Ring- -- * R-Modules- , Module- , LeftModule, (*.)- , RightModule, (.*)- , Bimodule- -- * R-Normed Modules- , Normed, mabs- -- * Vector Spaces- , VectorSpace- -- * R-Algebras- , Algebra- ) where--import Data.Ring-import Data.Monoid.Union---- import qualified Data.Monoid.Combinators as Monoid---class (Ringoid r, Monoid m) => Module r m where---- | @ (x * y) *. m = x * (y *. m) @-class (Module r m) => LeftModule r m where- (*.) :: r -> m -> m- --- | @ (m .* x) * y = m .* (x * y) @-class (Module r m) => RightModule r m where- (.*) :: m -> r -> m---- | @ (x *. m) .* y = x *. (m .* y) @-class (LeftModule r m, RightModule r m) => Bimodule r m --class (Field f, Module f g) => VectorSpace f g---- | An r-normed module m satisfies:------ (1) @mabs m >= 0@------ 2 @mabs m == zero{-_r-} => m == zero{-_m-}@------ 3 @mabs (m + n) <= mabs m + mabs n@------ 4 @r * mabs m = mabs (r *. m) -- if m is an r-LeftModule@------ 5 @mabs m * r = mabs (m .* r) -- if m is an r-RightModule@-class Module r m => Normed r m where- mabs :: m -> r---- | Algebra over a (near) (semi) ring.--- @r *. (x * y) = (r *. x) * y = x * (r *. y)@--- @(x * y) .* r = y * (x .* r) = (y .* r) * x@-class (r `Bimodule` m, Multiplicative m) => Algebra r m --instance (Module r m, Module r n) => Module r (m,n)-instance (Module r m, Module r n, Module r o) => Module r (m,n,o)-instance (Module r m, Module r n, Module r o, Module r p) => Module r (m,n,o,p)-instance (Module r m, Module r n, Module r o, Module r p, Module r q) => Module r (m,n,o,p,q)--instance (LeftModule r m, LeftModule r n) => LeftModule r (m,n) where- r *. (m,n) = (r *. m, r *. n)-instance (LeftModule r m, LeftModule r n, LeftModule r o) => LeftModule r (m,n,o) where- r *. (m,n,o) = (r *. m, r *. n, r *. o)-instance (LeftModule r m, LeftModule r n, LeftModule r o, LeftModule r p) => LeftModule r (m,n,o,p) where- r *. (m,n,o,p) = (r *. m, r *. n, r *. o, r *. p)-instance (LeftModule r m, LeftModule r n, LeftModule r o, LeftModule r p, LeftModule r q) => LeftModule r (m,n,o,p,q) where- r *. (m,n,o,p,q) = (r *. m, r *. n, r *. o, r *. p, r *. q)--instance (RightModule r m, RightModule r n) => RightModule r (m,n) where- (m,n) .* r = (m .* r, n .* r)-instance (RightModule r m, RightModule r n, RightModule r o) => RightModule r (m,n,o) where- (m,n,o) .* r = (m .* r, n .* r, o .* r)-instance (RightModule r m, RightModule r n, RightModule r o, RightModule r p ) => RightModule r (m,n,o,p) where- (m,n,o,p) .* r = (m .* r, n .* r, o .* r, p .* r)-instance (RightModule r m, RightModule r n, RightModule r o, RightModule r p, RightModule r q ) => RightModule r (m,n,o,p,q) where- (m,n,o,p,q) .* r = (m .* r, n .* r, o .* r, p .* r, q .* r)--instance (Bimodule r m, Bimodule r n) => Bimodule r (m,n)-instance (Bimodule r m, Bimodule r n, Bimodule r o) => Bimodule r (m,n,o)-instance (Bimodule r m, Bimodule r n, Bimodule r o, Bimodule r p) => Bimodule r (m,n,o,p)-instance (Bimodule r m, Bimodule r n, Bimodule r o, Bimodule r p, Bimodule r q) => Bimodule r (m,n,o,p,q)---- we want an absorbing 0, for that we need a seminearring and a notion of equality-instance (HasUnionWith f, Ord r, Eq r, RightSemiNearRing r) => LeftModule r (UnionWith f r) where- r *. m | r == zero = zero- | otherwise = fmap (r `times`) m-instance (HasUnionWith f, Ord r, Eq r, RightSemiNearRing r) => RightModule r (UnionWith f r) where- m .* r | r == zero = zero- | otherwise = fmap (`times` r) m-instance (HasUnionWith f, Ord r, Eq r, RightSemiNearRing r) => Module r (UnionWith f r) where
− Data/Ring/Module/AutomaticDifferentiation.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, RankNTypes, FunctionalDependencies, UndecidableInstances, FlexibleContexts #-}---------------------------------------------------------------------------------- |--- Module : Data.Ring.Module.AutomaticDifferentiation--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : portable (instances use MPTCs)-----------------------------------------------------------------------------------module Data.Ring.Module.AutomaticDifferentiation - ( module Data.Ring.Module- , D- , d- , lift- ) where--import Prelude-import Data.Ring.Module-import Data.Monoid.Reducer-import Test.QuickCheck-import Control.Monad--data D s r m = D r m deriving (Show,Read)--lift :: (r `Bimodule` m) => r -> D s r m-lift x = D x zero--infinitesimal :: (r `Bimodule` m, Ringoid m) => D s r m-infinitesimal = D zero one--instance Eq r => Eq (D s r m) where- D x _ == D y _ = x == y--instance Ord r => Ord (D s r m) where- D x _ `compare` D y _ = compare x y--instance (r `Bimodule` m) => Monoid (D s r m) where- mempty = D mempty mempty- D x m `mappend` D y n = D (x `mappend` y) (m `mappend` n)--instance (r `Bimodule` m) => Multiplicative (D s r m) where- one = D one zero- D x m `times` D y n = D (x `times` y) (x *. n `plus` m .* y)--instance (Group r, r `Bimodule` m, Group m) => Group (D s r m) where- gnegate (D x m) = D (gnegate x) (gnegate m)- D x m `minus` D y n = D (x `minus` y) (m `minus` n)- D x m `gsubtract` D y n = D (x `gsubtract` y) (m `gsubtract` n)--instance Num a => Num (D s a a) where- D x x' + D y y' = D (x + y) (x' + y')- D x x' * D y y' = D (x * y) (x * y' + x' * y)- D x x' - D y y' = D (x - y) (x' - y')- negate (D x x') = D (negate x) (negate x')- abs (D x x') = D (abs x) (signum x * x')- signum (D x _) = D (signum x) 0- fromInteger x = D (fromInteger x) 0--instance Fractional a => Fractional (D s a a) where- recip (D x x') = D (recip x) (-x'/x/x)- fromRational x = D (fromRational x) 0--instance (Ringoid r, r `Bimodule` m) => Ringoid (D s r m)-instance (LeftSemiNearRing r, Bimodule r m) => LeftSemiNearRing (D s r m)-instance (RightSemiNearRing r, Bimodule r m) => RightSemiNearRing (D s r m)-instance (SemiRing r, r `Bimodule` m) => SemiRing (D s r m)-instance (Ring r, r `Bimodule` m, Group m) => Ring (D s r m)--instance (r `Bimodule` m, c `Reducer` r, c `Reducer` m) => Reducer c (D s r m) where- unit c = D (unit c) (unit c)- c `cons` D x m = D (c `cons` x) (c `cons` m)- D x m `snoc` c = D (x `snoc` c) (m `snoc` c)--instance (Arbitrary r, Arbitrary m) => Arbitrary (D s r m) where- arbitrary = liftM2 D arbitrary arbitrary- shrink (D r m) = liftM2 D (shrink r) (shrink m)--instance (CoArbitrary r, CoArbitrary m) => CoArbitrary (D s r m) where- coarbitrary (D r m) = coarbitrary r >< coarbitrary m--d :: (r `Bimodule` m, Ringoid m) => (forall s. D s r m -> D s r m) -> (r,m)-d f = (y,y') where D y y' = f infinitesimal-
− Data/Ring/Semi/BitSet.hs
@@ -1,460 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, DeriveDataTypeable, BangPatterns, PatternGuards, TypeFamilies #-}---------------------------------------------------------------------------------- |--- Module : Data.Ring.Semi.BitSet--- Copyright : (c) Edward Kmett 2009. --- Based on Data.BitSet (c) Denis Bueno 2008-2009--- License : BSD3--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : portable (instances use MPTCs)------ Replacement for "Data.BitSet" extended to handle enumerations where fromEnum--- can return negative values, support efficient intersection and union--- and allow complementing of the set with respect to the bounds of the--- enumeration. Treated as a Boolean semiring over `.&.`/`.|.`. To get a--- 'Boolean' 'Ring', use @'Boolean' ('BitSet' a)@.-------------------------------------------------------------------------------------module Data.Ring.Semi.BitSet- ( module Data.Monoid.Reducer- , module Data.Ring- -- * BitSet- , BitSet- -- * Manipulation- , empty- , singleton- , full- , union- , intersection- , complement- , insert- , delete- , (\\)- , fromList- , fromDistinctAscList- -- * Acessors- , member- , null- , size- , isComplemented- , toInteger- ) where--import Prelude hiding ( null, exponent, toInteger, foldl, foldr, foldl1, foldr1 )-import Data.Bits-import Data.Foldable hiding ( toList )-import Data.Data-import Data.Ring.Semi.Natural-import Data.Ring-import Data.Monoid.Reducer-import Data.Generator-import Data.Ring.Module-import Text.Read-import Text.Show---- | Set operations optimized for tightly grouped sets or nearly universal sets with a close by group of elements missing.--- Stores itself like an arbitrary precision floating point number, tracking the least valued member of the set and an--- Integer comprised of the members. -data BitSet a = BS - { _countAtLeast :: {-# UNPACK #-} !Int -- ^ A conservative upper bound on the element count.- -- If negative, we are complemented with respect to the universe- , _countAtMost :: {-# UNPACK #-} !Int -- ^ A conservative lower bound on the element count.- -- If negative, we are complemented with respect to the universe- , _count :: Int -- ^ Lazy element count used when the above two disagree. O(1) environment size- , exponent :: {-# UNPACK #-} !Int -- ^ Low water mark. index of the least element potentially in the set.- , _hwm :: {-# UNPACK #-} !Int -- ^ High water mark. index of the greatest element potentially in the set.- , mantissa :: {-# UNPACK #-} !Integer -- ^ the set of bits starting from the exponent.- -- if negative, then we are complmenented with respect to universe- , _universe :: (Int,Int) -- ^ invariant: whenever mantissa < 0, universe = (fromEnum minBound,fromEnum maxBound)- , _fromEnum :: Int -> a -- ^ self-contained extraction behavior, enables Foldable- } deriving (Typeable)---- | omit reflection to preserve abstraction-instance (Enum a, Data a) => Data (BitSet a) where- gfoldl f z im = z fromList `f` toList im- toConstr _ = error "toConstr"- gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNorepType "Data.Ring.Semi.BitSet.BitSet"- dataCast1 f = gcast1 f ---- | Internal smart constructor. Forces count whenever it is pigeonholed.-bs :: Enum a => Int -> Int -> Int -> Int -> Int -> Integer -> (Int,Int) -> BitSet a-bs !a !b c !l !h !m u | a == b = BS a a a l h m u toEnum- | otherwise = BS a b c l h m u toEnum-{-# INLINE bs #-}---- | /O(d)/ where /d/ is absolute deviation in the output of fromEnum over the set-toList :: BitSet a -> [a]-toList (BS _ _ _ l h m u f) - | m < 0 = map f [ul..max (pred l) ul] ++ toList' l (map f [min (succ h) uh..uh])- | otherwise = toList' 0 []- where- ~(ul,uh) = u- toList' !n t - | n > h = t- | testBit m (n - l) = f n : toList' (n+1) t- | otherwise = toList' (n+1) t-{-# INLINE toList #-}---- | /O(1)/ The empty set. Permits /O(1)/ null and size.-empty :: Enum a => BitSet a-empty = BS 0 0 0 0 0 0 undefined toEnum-{-# INLINE empty #-}---- | /O(1)/ Construct a @BitSet@ with a single element. Permits /O(1)/ null and size-singleton :: Enum a => a -> BitSet a -singleton x = BS 1 1 1 e e 1 undefined toEnum where e = fromEnum x-{-# INLINE singleton #-}---- | /O(1)/ amortized cost. Is the 'BitSet' empty? May be faster than checking if @'size' == 0@.-null :: BitSet a -> Bool-null (BS a b c _ _ _ _ _) - | a > 0 = False- | b == 0 = True- | otherwise = c == 0 -{-# INLINE null #-}---- | /O(1)/ amortized cost. The number of elements in the bit set.-size :: BitSet a -> Int-size (BS a b c _ _ m (ul,uh) _) - | a == b, m >= 0 = a- | a == b = uh - ul - a - | m >= 0 = c- | otherwise = uh - ul - c -{-# INLINE size #-}---- | /O(d)/ A 'BitSet' containing every member of the enumeration of @a@.-full :: (Enum a, Bounded a) => BitSet a-full = complement' empty -{-# INLINE full #-}----- | /O(d)/ unsafe internal method: complement a set that has already been complemented at least once.-recomplement :: BitSet a -> BitSet a -recomplement (BS a b c l h m u f) = BS (complement b) (complement a) (complement c) l h (complement m) u f-{-# INLINE recomplement #-}---- | /O(d)/ unsafe internal method: complement a set that has already been complemented at least once.-pseudoComplement :: BitSet a -> (Int,Int) -> BitSet a -pseudoComplement (BS a b c l h m _ f) u = BS (complement b) (complement a) (complement c) l h (complement m) u f-{-# INLINE pseudoComplement #-}---- | /O(d * n)/ Make a 'BitSet' from a list of items.-fromList :: Enum a => [a] -> BitSet a-fromList = foldr insert empty -{-# INLINE fromList #-}---- | /O(d * n)/ Make a 'BitSet' from a distinct ascending list of items-fromDistinctAscList :: Enum a => [a] -> BitSet a -fromDistinctAscList [] = empty-fromDistinctAscList (c:cs) = fromDistinctAscList' cs 1 0 1 - where- l = fromEnum c- fromDistinctAscList' :: Enum a => [a] -> Int -> Int -> Integer -> BitSet a- fromDistinctAscList' [] !n !h !m = BS n n n l h m undefined toEnum- fromDistinctAscList' (c':cs') !n _ !m = - let h' = fromEnum c' in - fromDistinctAscList' cs' (n+1) h' (setBit m (h' - l))-{-# INLINE fromDistinctAscList #-}---- | /O(d)/ Insert a single element of type @a@ into the 'BitSet'. Preserves order of 'null' and 'size'-insert :: Enum a => a -> BitSet a -> BitSet a-insert x r@(BS a b c l h m u _) - | m < 0, e < l = r - | m < 0, e > h = r- | b == 0 = singleton x- | a == -1 = r- | e < l = bs (a+1) (b+1) (c+1) e h (shiftL m (l - e) .|. 1) u- | e > h = bs (a+1) (b+1) (c+1) l p (setBit m p) u- | testBit m p = r - | otherwise = bs (a+1) (b+1) (c+1) l h (setBit m p) u- where - e = fromEnum x- p = e - l -{-# INLINE insert #-}---- | /O(d)/ Delete a single item from the 'BitSet'. Preserves order of 'null' and 'size'-delete :: Enum a => a -> BitSet a -> BitSet a-delete x r@(BS a b c l h m u _) - | m < 0, e < l = bs (a+1) (b+1) (c+1) e h (shiftL m (l - e) .&. complement 1) u- | m < 0, e > h = bs (a+1) (b+1) (c+1) l p (clearBit m p) u- | b == 0 = r- | a == -1 = pseudoComplement (singleton x) u- | e < l = r- | e > h = r- | testBit m p = bs (a-1) (b-1) (c-1) l h (clearBit m p) u- | otherwise = r- where - e = fromEnum x- p = e - l-{-# INLINE delete #-}---- | /O(1)/ Test for membership in a 'BitSet'-member :: Enum a => a -> BitSet a -> Bool-member x (BS _ _ _ l h m _ _) - | e < l = m < 0 - | e > h = m > 0- | otherwise = testBit m (e - l)- where - e = fromEnum x-{-# INLINE member #-}---- | /O(d)/ convert to an Integer representation. Discards negative elements-toInteger :: BitSet a -> Integer-toInteger x = mantissa x `shift` exponent x-{-# INLINE toInteger #-}---- | /O(d)/.-union :: Enum a => BitSet a -> BitSet a -> BitSet a -union x@(BS a b c l h m u f) y@(BS a' b' c' l' h' m' u' _)- | l' < l = union y x -- ensure left side has lower exponent- | b == 0 = y -- fast empty union- | b' == 0 = x -- fast empty union- | a == -1 = entire u -- fast full union, recomplement obligation met by negative size- | a' == -1 = entire u' -- fast full union, recomplement obligation met by negative size- | m < 0, m' < 0 = recomplement (intersection (recomplement x) (recomplement y)) -- appeal to intersection, recomplement obligation met by 2s complement- | m' < 0 = recomplement (diff (recomplement y) x u') -- union with complement, recomplement obligation met by 2s complement- | m < 0 = recomplement (diff (recomplement x) y u) -- union with complement, recomplement obligation met by 2s complement- | h < l' = bs (a + a') (b + b') (c + c') l h' m'' u -- disjoint positive ranges- | otherwise = bs (a `max` a') (b + b') (recount m'') l (h `max` h') m'' u -- overlapped positives- where - m'' = m .|. shiftL m' (l' - l)- entire u'' = BS (-1) (-1) (-1) 0 0 (-1) u'' f---- | /O(1)/ Check to see if we are represented as a complemented 'BitSet'. -isComplemented :: Enum a => BitSet a -> Bool-isComplemented = (<0) . mantissa -{-# INLINE isComplemented #-}---- | /O(d)/ -intersection :: Enum a => BitSet a -> BitSet a -> BitSet a -intersection x@(BS a b _ l h m u _) y@(BS a' b' _ l' h' m' u' _)- | l' < l = intersection y x - | b == 0 = empty- | b' == 0 = empty- | a == -1 = y- | a' == -1 = x- | m < 0, m' < 0 = recomplement (union (recomplement x) (recomplement y))- | m' < 0 = diff x (recomplement y) u'- | m < 0 = diff y (recomplement x) u- | h < l' = empty - | otherwise = bs 0 (b `min` b') (recount m'') l'' (h `min` h') m'' u- where- l'' = max l l'- m'' = shift m (l'' - l) .&. shift m' (l'' - l')---- | Unsafe internal method for computing differences in a known universe of discourse.------ Preconditions:------ (1) @m >= 0@--- 2 @m' >= 0@--- 3 @a /= -1@--- 4 @a' /= -1@--- 5 @b /= 0@--- 6 @b' /= 0@--- 7 @u''@ is a previously obtained copy of @(fromEnum minBound, fromEnum maxBound)@----diff :: Enum a => BitSet a -> BitSet a -> (Int,Int) -> BitSet a -diff x@(BS a _ _ l h m _ _) (BS _ b' _ l' h' m' _ _) u''- | h < l' = x- | h' < l = x- | otherwise = bs (max (a - b') 0) a (recount m'') l h m'' u''- where - m'' = m .&. shift (complement m') (l' - l)-{-# INLINE diff #-}---- | /O(d)/ Remove all elements present in the second bitset from the first-difference :: Enum a => BitSet a -> BitSet a -> BitSet a -difference x@(BS a b _ _ _ m u _) y@(BS a' b' _ _ _ m' _ _) - | a == -1 = pseudoComplement y u- | a' == -1 = empty- | b == 0 = empty- | b' == 0 = x- | m < 0, m' < 0 = diff (recomplement y) (recomplement x) u- | m < 0 = pseudoComplement (recomplement x `union` y) u- | m' < 0 = x `union` recomplement y - | otherwise = diff x y u- --- | /O(d)/ Infix 'difference'-(\\) :: Enum a => BitSet a -> BitSet a -> BitSet a -(\\) = difference-{-# INLINE (\\) #-}--instance Eq (BitSet a) where- x@(BS _ _ _ l _ m u _) == y@(BS _ _ _ l' _ m' _ _)- | signum m == signum m' = shift m (l - l'') == shift m' (l' - l'') - | m' < 0 = y == x- | otherwise = mask .&. shift m (l - ul) == shift m' (l - ul)- where - l'' = min l l'- mask = setBit 0 (uh - ul + 1) - 1- ul = fst u- uh = snd u--instance (Enum a, Bounded a) => Bounded (BitSet a) where- minBound = empty- maxBound = result where- result = BS n n n l h m (l,h) toEnum- n = h - l + 1- l = fromEnum (minBound `asArgTypeOf` result)- h = fromEnum (maxBound `asArgTypeOf` result)- m = setBit 0 n - 1---- | Utility function to avoid requiring ScopedTypeVariables-asArgTypeOf :: a -> f a -> a-asArgTypeOf = const-{-# INLINE asArgTypeOf #-}---- | /O(d)/-recount :: Integer -> Int-recount !n - | n < 0 = complement (recount (complement n))- | otherwise = recount' 0 0 - where- h = hwm n- recount' !i !c- | i > h = c- | otherwise = recount' (i+1) (if testBit n i then c+1 else c)---- | /O(d)/. Computes the equivalent of (truncate . logBase 2 . abs) extended with 0 at 0-hwm :: Integer -> Int-hwm !n - | n < 0 = hwm (-n)- | n > 1 = scan p (2*p) - | otherwise = 0- where- p = probe 1- -- incrementally compute 2^(2^(i+1)) until it exceeds n- probe :: Int -> Int- probe !i- | bit (2*i) > n = i- | otherwise = probe (2*i)-- -- then scan the powers for the highest set bit- scan :: Int -> Int -> Int- scan !l !h- | l == h = l- | bit (m+1) > n = scan l m- | otherwise = scan (m+1) h- where - m = l + (h - l) `div` 2- -instance Show a => Show (BitSet a) where- showsPrec d x@(BS _ _ _ _ _ m u _)- | m < 0 = showParen (d > 10) $ showString "pseudoComplement " . showsPrec 11 (recomplement x) . showString " " . showsPrec 11 u- | otherwise = showParen (d > 10) $ showString "fromDistinctAscList " . showsPrec 11 (toList x)--instance (Enum a, Read a) => Read (BitSet a) where- readPrec = parens $ complemented +++ normal where- complemented = prec 10 $ do - Ident "pseudoComplement" <- lexP- x <- step readPrec- pseudoComplement x `fmap` step readPrec- normal = prec 10 $ do- Ident "fromDistinctAscList" <- lexP- fromDistinctAscList `fmap` step readPrec---- note that operations on values generated by toEnum are pretty slow because the bounds are suboptimal-instance (Enum a, Bounded a) => Enum (BitSet a) where- fromEnum b@(BS _ _ _ l _ m _ _) = fromInteger (shiftL m (l - l'))- where - l' = fromEnum (minBound `asArgTypeOf` b)- toEnum i = result - where- result = BS a i (recount m) l h m undefined toEnum -- n <= 2^n, so i serves as a valid upper bound- l = fromEnum (minBound `asArgTypeOf` result)- h = fromEnum (maxBound `asArgTypeOf` result)- m = fromIntegral i- a | m /= 0 = 1 -- allow a fast null check, but not much else- | otherwise = 0--instance Foldable BitSet where- fold = fold . toList- foldMap f = foldMap f . toList- foldr f z = foldr f z . toList- foldl f z = foldl f z . toList- foldr1 f = foldr1 f . toList- foldl1 f = foldl1 f . toList- -instance Enum a => Monoid (BitSet a) where- mempty = empty- mappend = union--instance Enum a => Reducer a (BitSet a) where- unit = singleton- snoc = flip insert- cons = insert--instance (Bounded a, Enum a) => Multiplicative (BitSet a) where- one = full- times = intersection--instance (Bounded a, Enum a) => Ringoid (BitSet a)-instance (Bounded a, Enum a) => LeftSemiNearRing (BitSet a)-instance (Bounded a, Enum a) => RightSemiNearRing (BitSet a)-instance (Bounded a, Enum a) => SemiRing (BitSet a)---- idempotent monoid-instance Enum a => Module Natural (BitSet a)-instance Enum a => LeftModule Natural (BitSet a) where- 0 *. _ = empty- _ *. m = m-instance Enum a => RightModule Natural (BitSet a) where- _ .* 0 = empty- m .* _ = m-instance Enum a => Bimodule Natural (BitSet a)-instance (Bounded a, Enum a) => Algebra Natural (BitSet a)--instance (Bounded a, Enum a) => Module (BitSet a) (BitSet a)-instance (Bounded a, Enum a) => LeftModule (BitSet a) (BitSet a) where (*.) = times-instance (Bounded a, Enum a) => RightModule (BitSet a) (BitSet a) where (.*) = times-instance (Bounded a, Enum a) => Bimodule (BitSet a) (BitSet a)-instance (Bounded a, Enum a) => Algebra (BitSet a) (BitSet a)- -instance Generator (BitSet a) where- type Elem (BitSet a) = a- mapReduce f = mapReduce f . toList--instance (Show a, Bounded a, Enum a) => Num (BitSet a) where- (+) = union- (-) = difference- (*) = intersection- fromInteger m = r where- r = BS c c c 0 (hwm m) m u toEnum where- c = recount m- u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r))- abs b | mantissa b < 0 = recomplement b- | otherwise = b- signum = error "BitSet.signum undefined"--instance (Show a, Bounded a, Enum a) => Bits (BitSet a) where- (.&.) = intersection- (.|.) = union- a `xor` b = (a .|. b) .&. complement (a .&. b)-- -- | /O(d)/ Complements a 'BitSet' with respect to the bounds of @a@. Preserves order of 'null' and 'size'- complement r@(BS a b c l h m _ _) = BS (complement b) (complement a) (complement c) l h (complement m) u toEnum where- u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r))- {-# INLINE complement #-}- {-- shift (BS a b c l h m _ f) n = BS a b c ((l + r) `max` uh) ((h + r) `max` uh) m (ul,uh) toEnum) where- ul = fromEnum (minBound `asArgTypeOf` r)- uh = fromEnum (maxBound `asArgTypeOf` r)- -}- shift = error "BitSet.shift undefined"- rotate = error "BitSet.rotate undefined"- bit = singleton . toEnum- setBit s b = s `union` singleton (toEnum b)- clearBit s b = s `difference` singleton (toEnum b)- complementBit s b = s `xor` singleton (toEnum b)- testBit s b = member (toEnum b) s - bitSize r = fromEnum (maxBound `asArgTypeOf` r) - fromEnum (minBound `asArgTypeOf` r)- isSigned _ = True--complement' :: (Bounded a, Enum a) => BitSet a -> BitSet a-complement' r@(BS a b c l h m _ _) = BS (complement b) (complement a) (complement c) l h (complement m) u toEnum where- u = (fromEnum (minBound `asArgTypeOf` r), fromEnum (maxBound `asArgTypeOf` r))
− Data/Ring/Semi/Kleene.hs
@@ -1,10 +0,0 @@-module Data.Ring.Semi.Kleene - ( module Data.Ring- , KleeneAlgebra- , star- ) where--import Data.Ring--class SemiRing r => KleeneAlgebra r where- star :: r -> r
− Data/Ring/Semi/Natural.hs
@@ -1,276 +0,0 @@-{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeFamilies #-}---------------------------------------------------------------------------------- |--- Module : Data.Ring.Semi.Natural--- Copyright : (c) Edward Kmett 2009--- License : BSD-style--- Maintainer : ekmett@gmail.com--- Stability : experimental--- Portability : non-portable (type families, MPTCs)------ Monoids for non-negative integers ('Natural') and ints ('Nat')------ The naturals form a module over any of our monoids.--------------------------------------------------------------------------------module Data.Ring.Semi.Natural- ( module Data.Ring- , Natural- , toNatural- , fromNatural- ) where--import Prelude hiding (id,(.))-import Numeric (readDec, showInt)-import Control.Applicative-import Control.Monad-import Data.Ring-import qualified Data.Monoid.Combinators as Monoid--- import Data.Word-import Data.Monoid.Monad-import Data.Monoid.Applicative-import Data.Monoid.Multiplicative-import Data.Monoid.Categorical-import Data.Monoid.Self-import Data.Monoid.Lexical.SourcePosition-import Data.Monoid.Lexical.UTF8.Decoder-import Data.Generator.Free--#ifdef M_CONTAINERS--- used with Seq-import Data.Generator.Compressive.RLE-import Data.Sequence (Seq)-#endif--#ifdef X_OverloadedStrings-import Data.Monoid.FromString-#endif--toNatural :: Integer -> Natural-toNatural = fromInteger--fromNatural :: Ringoid r => Natural -> r-fromNatural = Monoid.replicate one . getNatural--newtype Natural = Natural { getNatural :: Integer } - deriving (Eq,Ord)--instance Read Natural where- readsPrec = const readDec--instance Show Natural where- showsPrec = const showInt--instance Num Natural where- Natural a + Natural b = Natural (a + b)- Natural a - Natural b = fromInteger (a - b) - Natural a * Natural b = Natural (a * b)- abs = id- signum = Natural . signum . getNatural- fromInteger x | x < 0 = error "Natural < 0"- | otherwise = Natural x- negate 0 = 0 - negate _ = error "Natural < 0"--instance Enum Natural where- succ (Natural n) = Natural (n + 1)- pred (Natural 0) = error "Natural < 0"- pred (Natural n) = Natural (n - 1)- toEnum n | n < 0 = error "Natural < 0"- toEnum n = Natural (fromIntegral n)- fromEnum = fromIntegral- enumFrom (Natural n) = Natural `map` enumFrom n- enumFromThen (Natural n) (Natural np) - | np < n = Natural `map` enumFromThenTo n np 0- | otherwise = Natural `map` enumFromThen n np- enumFromTo (Natural n) (Natural m) = Natural `map` enumFromTo n m- enumFromThenTo (Natural n) (Natural m) (Natural o) = Natural `map` enumFromThenTo n m o--instance Real Natural where- toRational = toRational . getNatural--instance Integral Natural where- toInteger = getNatural- Natural a `quot` Natural b = Natural (a `quot` b)- Natural a `rem` Natural b = Natural (a `rem` b)- Natural a `div` Natural b = Natural (a `div` b)- Natural a `mod` Natural b = Natural (a `mod` b)- Natural a `quotRem` Natural b = (Natural q,Natural r) where ~(q,r) = a `quotRem` b- Natural a `divMod` Natural b = (Natural q,Natural r) where ~(q,r) = a `divMod` b--instance Monoid Natural where- mempty = 0- mappend = (+)--instance Multiplicative Natural where- one = 1- times = (*)--instance Ringoid Natural-instance LeftSemiNearRing Natural-instance RightSemiNearRing Natural-instance SemiRing Natural--instance LeftModule Natural () where _ *. _ = ()-instance RightModule Natural () where _ .* _ = ()-instance Module Natural ()---- idempotent monoids-instance LeftModule Natural Any where - 0 *. _ = mempty- _ *. m = m-instance RightModule Natural Any where - _ .* 0 = mempty- m .* _ = m -instance Module Natural Any --instance LeftModule Natural All where - 0 *. _ = mempty- _ *. m = m-instance RightModule Natural All where - _ .* 0 = mempty- m .* _ = m-instance Module Natural All--instance LeftModule Natural (First a) where - 0 *. _ = mempty- _ *. m = m-instance RightModule Natural (First a) where - _ .* 0 = mempty- m .* _ = m-instance Module Natural (First a) --instance LeftModule Natural (Last a) where - 0 *. _ = mempty- _ *. m = m-instance RightModule Natural (Last a) where - _ .* 0 = mempty- m .* _ = m-instance Module Natural (Last a)--instance LeftModule Natural Ordering where - 0 *. _ = mempty- _ *. m = m-instance RightModule Natural Ordering where - _ .* 0 = mempty- m .* _ = m -instance Module Natural Ordering---- other monoids--instance LeftModule Natural [a] where (*.) = flip Monoid.replicate-instance RightModule Natural [a] where (.*) = Monoid.replicate-instance Module Natural [a]--instance Monoid m => LeftModule Natural (a -> m) where (*.) = flip Monoid.replicate-instance Monoid m => RightModule Natural (a -> m) where (.*) = Monoid.replicate-instance Monoid m => Module Natural (a -> m)--instance Num a => LeftModule Natural (Sum a) where (*.) = flip Monoid.replicate-instance Num a => RightModule Natural (Sum a) where (.*) = Monoid.replicate-instance Num a => Module Natural (Sum a)--instance Num a => LeftModule Natural (Product a) where (*.) = flip (.*)-instance Num a => RightModule Natural (Product a) where Product m .* Natural n = Product (m ^ n)-instance Num a => Module Natural (Product a)--instance LeftModule Natural (Endo a) where (*.) = flip Monoid.replicate-instance RightModule Natural (Endo a) where (.*) = Monoid.replicate-instance Module Natural (Endo a)--instance Monoid m => LeftModule Natural (Dual m) where (*.) = flip Monoid.replicate-instance Monoid m => RightModule Natural (Dual m) where (.*) = Monoid.replicate-instance Monoid m => Module Natural (Dual m)---- Self-instance Monoid m => LeftModule Natural (Self m) where (*.) = flip Monoid.replicate-instance Monoid m => RightModule Natural (Self m) where (.*) = Monoid.replicate-instance Monoid m => Module Natural (Self m)---- Free Generator-instance LeftModule Natural (Free a) where (*.) = flip Monoid.replicate-instance RightModule Natural (Free a) where (.*) = Monoid.replicate-instance Module Natural (Free a)---- Categorical-instance Category k => LeftModule Natural (GEndo k a) where (*.) = flip Monoid.replicate-instance Category k => RightModule Natural (GEndo k a) where (.*) = Monoid.replicate-instance Category k => Module Natural (GEndo k a)--instance Monoid m => LeftModule Natural (CMonoid m m m) where (*.) = flip Monoid.replicate-instance Monoid m => RightModule Natural (CMonoid m m m) where (.*) = Monoid.replicate-instance Monoid m => Module Natural (CMonoid m m m)---- Alternative-instance Applicative f => LeftModule Natural (Traversal f) where (*.) = flip Monoid.replicate-instance Applicative f => RightModule Natural (Traversal f) where (.*) = Monoid.replicate-instance Applicative f => Module Natural (Traversal f) --instance Alternative f => LeftModule Natural (Alt f a) where (*.) = flip Monoid.replicate-instance Alternative f => RightModule Natural (Alt f a) where (.*) = Monoid.replicate-instance Alternative f => Module Natural (Alt f a) ----instance (Alternative f, Monoid m) => LeftModule Natural (App f m) where (*.) = flip Monoid.replicate---instance (Alternative f, Monoid m) => RightModule Natural (App f m) where (.*) = Monoid.replicate---instance (Alternative f, Monoid m) => Module Natural (App f m) ---- Monad-instance Monad f => LeftModule Natural (Action f) where (*.) = flip Monoid.replicate-instance Monad f => RightModule Natural (Action f) where (.*) = Monoid.replicate-instance Monad f => Module Natural (Action f) --instance MonadPlus f => LeftModule Natural (MonadSum f a) where (*.) = flip Monoid.replicate-instance MonadPlus f => RightModule Natural (MonadSum f a) where (.*) = Monoid.replicate-instance MonadPlus f => Module Natural (MonadSum f a) ----instance (MonadPlus f, Monoid m) => LeftModule Natural (Mon f m) where (*.) = flip Monoid.replicate---instance (MonadPlus f, Monoid m) => RightModule Natural (Mon f m) where (.*) = Monoid.replicate---instance (MonadPlus f, Monoid m) => Module Natural (Mon f m) ---- Lexical -instance LeftModule Natural (SourcePosition f) where - 0 *. _ = mempty- n *. Columns x = Columns (fromIntegral n * x) - n *. Lines l c = Lines (fromIntegral n * l) c- _ *. Pos f l c = Pos f l c - n *. t = Monoid.replicate t n --instance RightModule Natural (SourcePosition f) where (.*) = flip (*.)-instance Module Natural (SourcePosition f) --instance CharReducer m => LeftModule Natural (UTF8 m) where (*.) = flip Monoid.replicate-instance CharReducer m => RightModule Natural (UTF8 m) where (.*) = Monoid.replicate-instance CharReducer m => Module Natural (UTF8 m) --instance Multiplicative m => LeftModule Natural (Log m) where (*.) = flip Monoid.replicate-instance Multiplicative m => RightModule Natural (Log m) where (.*) = Monoid.replicate-instance Multiplicative m => Module Natural (Log m) --#ifdef M_CONTAINERS--- RLE Seq-instance Eq a => LeftModule Natural (RLE Seq a) where (*.) = flip Monoid.replicate-instance Eq a => RightModule Natural (RLE Seq a) where (.*) = Monoid.replicate-instance Eq a => Module Natural (RLE Seq a)-#endif--#ifdef X_OverloadedStrings--- FromString-instance Monoid m => LeftModule Natural (FromString m) where (*.) = flip Monoid.replicate-instance Monoid m => RightModule Natural (FromString m) where (.*) = Monoid.replicate-instance Monoid m => Module Natural (FromString m)-#endif---- TODO------ Control.Monad.*--- ParsecT--- FingerTree--- Int, Integer, Ratio--- SourcePosition--- Replace Natural here with some other notion of NonNegative a --- Words, Lines, Unspaced, Unlined--- Union/UnionWith, Map, Set, etc.--- Max, Min, MaxPriority, MinPriority idempotent--- BoolRing--- Seq
− Data/Ring/Semi/Near/Trie.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}-module Data.Ring.Semi.Near.Trie - ( module Data.Ring- , Trie(Trie, total, label, children)- , singleton- , empty- , null- ) where- -import Data.Map (Map)-import qualified Data.Map as Map-import Data.Monoid.Union hiding (empty)-import Data.Ring-import Prelude hiding (null)--singleton :: (Ord c, c `Reducer` m) => c -> Trie c m -singleton = unit--empty :: (Ord c, Monoid m) => Trie c m-empty = zero--null :: Ord c => Trie c m -> Bool-null = Map.null . getUnionWith . children--data Trie c m = Trie { total :: m, label :: m, children :: UnionWith (Map c) (Trie c m) }- deriving (Eq,Show)--instance Functor (Trie c) where- fmap f (Trie t e r) = Trie (f t) (f e) (fmap (fmap f) r)--instance (Ord c, Monoid m) => Monoid (Trie c m) where- mempty = Trie mempty mempty mempty- Trie x y z `mappend` Trie x' y' z' = Trie (x `mappend` x') (y `mappend` y') (z `mappend` z')--instance (Ord c, c `Reducer` m) => Reducer c (Trie c m) where- unit c = Trie r zero . UnionWith $ flip Map.singleton (Trie r r zero) c where r = unit c--{--instance (Ord c, Eq r, RightSemiNearRing r) => Multiplicative (Trie c r) where- one = Trie one one zero- Trie t e r `times` rhs@(Trie t' e' r') = - Trie (t `times` t') (e `times` e') (r .* rhs `plus` lhs *. r') where- lhs = Trie e e zero `asTypeOf` rhs--instance (Ord c, Eq r, RightSemiNearRing r) => RightSemiNearRing (Trie c r)--toList :: (Ord c, c `Reducer` [c]) => Trie c m -> [[c]]-toList = fmap merge . Map.assocs . getUnionWith . children where- merge (k,t) = k `times` toList t--}
− Data/Ring/Semi/Ord.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}-------------------------------------------------------------------------- |--- Module : Data.Ring.Semi.Ord--- Copyright : (c) Edward Kmett 2009, Conal Elliott 2008--- License : BSD3--- --- Maintainer : ekmett@gmail.com--- Stability : experimental--- --- Turn an instance of 'Ord' into a 'SemiRing' over 'max' and 'min'---------------------------------------------------------------------------module Data.Ring.Semi.Ord- ( module Data.Ring- , Order(Order,getOrder)- , Priority(MinBound,Priority,MaxBound)- ) where---- import Control.Applicative-import Control.Functor.Pointed-import Data.Ring-import Data.Monoid.Ord-import Data.Monoid.Reducer--#ifdef M_QUICKCHECK-import Test.QuickCheck-#endif---- | A 'SemiRing' using a type's built-in Bounded instance.-newtype Order a = Order { getOrder :: a } deriving - ( Eq- , Ord- , Read- , Show- , Bounded-#ifdef M_QUICKCHECK- , Arbitrary- , CoArbitrary-#endif- )--instance (Bounded a, Ord a) => Monoid (Order a) where- mappend = max- mempty = minBound--instance (Bounded a, Ord a) => Multiplicative (Order a) where- times = min- one = maxBound- -instance (Bounded a, Ord a) => Ringoid (Order a)-instance (Bounded a, Ord a) => RightSemiNearRing (Order a)-instance (Bounded a, Ord a) => LeftSemiNearRing (Order a)-instance (Bounded a, Ord a) => SemiRing (Order a)-instance (Bounded a, Ord a) => Reducer a (Order a) where- unit = Order--instance Functor Order where- fmap f (Order a) = Order (f a)--instance Pointed Order where- point = Order--instance Copointed Order where- extract = getOrder---- | A 'SemiRing' which adds 'minBound' and 'maxBound' to a pre-existing type.-data Priority a = MinBound | Priority a | MaxBound deriving (Eq,Read,Show)--instance Bounded (Priority a) where- minBound = MinBound- maxBound = MaxBound--instance Ord a => Ord (Priority a) where- MinBound <= _ = True- Priority _ <= MinBound = False- Priority a <= Priority b = a <= b- Priority _ <= MaxBound = True- MaxBound <= MaxBound = True- MaxBound <= _ = False-- MinBound `min` _ = MinBound- _ `min` MinBound = MinBound- Priority a `min` Priority b = Priority (a `min` b)- u `min` MaxBound = u- MaxBound `min` v = v- - MinBound `max` v = v- u `max` MinBound = u- Priority a `max` Priority b = Priority (a `max` b)- _ `max` MaxBound = MaxBound- MaxBound `max` _ = MaxBound--#ifdef M_QUICKCHECK-instance Arbitrary a => Arbitrary (Priority a) where- arbitrary = frequency [ (1 ,return MinBound)- , (10, fmap Priority arbitrary)- , (1 ,return MaxBound) ]- shrink (Priority x) = MinBound : MaxBound : fmap Priority (shrink x)- shrink MinBound = []- shrink MaxBound = []--instance CoArbitrary a => CoArbitrary (Priority a) where- coarbitrary MinBound = variant (0 :: Int)- coarbitrary (Priority a) = variant (1 :: Int) . coarbitrary a- coarbitrary MaxBound = variant (2 :: Int)-#endif--instance Ord a => Monoid (Priority a) where- mappend = max- mempty = minBound--instance Ord a => Multiplicative (Priority a) where- times = min- one = maxBound--instance Ord a => Ringoid (Priority a)-instance Ord a => LeftSemiNearRing (Priority a)-instance Ord a => RightSemiNearRing (Priority a)-instance Ord a => SemiRing (Priority a)--instance Ord a => Reducer a (Priority a) where- unit = Priority--instance Ord a => Reducer (MinPriority a) (Priority a) where- unit (MinPriority Nothing) = MaxBound- unit (MinPriority (Just x)) = Priority x--instance Ord a => Reducer (MaxPriority a) (Priority a) where- unit (MaxPriority Nothing) = MinBound- unit (MaxPriority (Just x)) = Priority x--instance Functor Priority where- fmap _ MaxBound = MaxBound- fmap f (Priority a) = Priority (f a)- fmap _ MinBound = MinBound--instance Pointed Priority where- point = Priority
− Data/Ring/Semi/Tropical.hs
@@ -1,97 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}----------------------------------------------------------------------------------- |----- Module : Data.Ring.Semi.Tropical----- Copyright : (c) Edward Kmett 2009----- License : BSD-style----- Maintainer : ekmett@gmail.com----- Stability : experimental----- Portability : portable-------------------------------------------------------------------------------------module Data.Ring.Semi.Tropical- ( module Data.Monoid.Reducer- , module Data.Ring- -- * Tropical Semirings- , infinity- , Tropical(Tropical,getTropical)- ) where--import Control.Functor.Pointed-import Data.Monoid.Reducer-import Data.Monoid.Combinators as Monoid-import Data.Ring.Semi.Natural-import Data.Ring-import Data.Ring.Module-import Data.Monoid.Ord hiding (infinity)--#ifdef M_QUICKCHECK-import Test.QuickCheck-#endif--infinity :: Tropical a-infinity = Tropical Nothing---- | The 'SemiRing' @('min','+')@ over @'a' extended with 'infinity'@.--- When @a@ has a Num instance with an addition that respects order, then this is --- transformed into a tropical semiring. It is assumed that 0 is the least element--- of a.------ <http://hal.archives-ouvertes.fr/docs/00/11/37/79/PDF/Tropical.pdf>--newtype Tropical a = Tropical { getTropical :: Maybe a } deriving - ( Eq- , Show- , Read-#ifdef M_QUICKCHECK- , Arbitrary- , CoArbitrary-#endif- )--instance Ord a => Ord (Tropical a) where- Tropical Nothing `compare` Tropical Nothing = EQ- Tropical Nothing `compare` _ = GT- _ `compare` Tropical Nothing = LT- Tropical (Just a) `compare` Tropical (Just b) = a `compare` b--instance Ord a => Monoid (Tropical a) where- mempty = infinity- mappend = min--instance Ord a => Reducer a (Tropical a) where- unit = Tropical . Just--instance Ord a => Reducer (Maybe a) (Tropical a) where- unit = Tropical--instance Ord a => Reducer (MinPriority a) (Tropical a) where- unit = Tropical . getMinPriority--instance Functor Tropical where- fmap f (Tropical a) = Tropical (fmap f a)--instance Pointed Tropical where- point = Tropical . Just--instance Num a => Multiplicative (Tropical a) where- one = point $ fromInteger 0- Tropical Nothing `times` _ = infinity- Tropical (Just a) `times` Tropical (Just b) = point (a + b)- _ `times` Tropical Nothing = infinity--instance (Ord a, Num a) => Ringoid (Tropical a)-instance (Ord a, Num a) => LeftSemiNearRing (Tropical a)-instance (Ord a, Num a) => RightSemiNearRing (Tropical a)-instance (Ord a, Num a) => SemiRing (Tropical a)--instance (Ord a, Num a) => Module (Tropical a) (Tropical a)-instance (Ord a, Num a) => LeftModule (Tropical a) (Tropical a) where (*.) = times-instance (Ord a, Num a) => RightModule (Tropical a) (Tropical a) where (.*) = times-instance (Ord a, Num a) => Bimodule (Tropical a) (Tropical a)--instance (Ord a, Num a) => Module Natural (Tropical a)-instance (Ord a, Num a) => LeftModule Natural (Tropical a) where (*.) = flip Monoid.replicate-instance (Ord a, Num a) => RightModule Natural (Tropical a) where (.*) = Monoid.replicate-instance (Ord a, Num a) => Bimodule Natural (Tropical a)
monoids.cabal view
@@ -1,147 +1,50 @@ name: monoids-version: 0.1.36+version: 0.2.0 license: BSD3 license-file: LICENSE author: Edward A. Kmett maintainer: Edward A. Kmett <ekmett@gmail.com> stability: experimental homepage: http://comonad.com/reader-category: Data, Math, Numerical, Natural Language Processing, Parsing+category: Data, Math, Numerical synopsis: Monoids, specialized containers and a general map/reduce framework description: Monoids, specialized containers and a general map/reduce framework copyright: (c) 2009 Edward A. Kmett build-type: Simple cabal-version: >=1.2.3 --- packages we can extend with new instances-flag bytestring- description: Data.ByteString is available (bytestring)--flag fingertree- description: Data.Fingertree is available (fingertree)--flag parallel- description: Control.Parallel.Strategies is available (parallel)- -flag stm- description: Control.Concurrent.STM is available (stm)--flag QuickCheck- description: Test.QuickCheck is available (QuickCheck)- -flag text- description: Data.Text is available (text)--flag reflection- description: Data.Reflection is available (reflection)--flag parsec- description: Text.Parsec is available (parsec >= 3)--flag mtl- description: Control.Monad.* is available (mtl)---- optional extensions-flag overloaded-strings- description: OverloadedStrings extension is available (extension)---- compilation options flag optimize description: Enable optimizations default: False library build-depends: - base >= 4 && < 4.2, - category-extras >= 0.53 && < 0.60,+ base >= 4 && < 5, array >= 0.2 && < 0.3,- containers >= 0.2 && < 0.3-- extensions:- CPP+ containers >= 0.2 && < 0.3,+ bytestring >= 0.9 && < 1.0,+ fingertree >= 0.0.1 && < 0.3,+ text >= 0.1 && < 0.3,+ parallel >= 1.1 && < 1.2 exposed-modules: Data.Generator Data.Generator.Combinators- Data.Generator.Compressive.LZ78- Data.Generator.Compressive.RLE- Data.Generator.Free Data.Group Data.Group.Combinators Data.Group.Sugar Data.Monoid.Additive Data.Monoid.Applicative- Data.Monoid.Categorical Data.Monoid.Combinators- Data.Monoid.Instances- Data.Monoid.Lexical.SourcePosition- Data.Monoid.Lexical.UTF8.Decoder- Data.Monoid.Lexical.Words Data.Monoid.Monad Data.Monoid.Multiplicative Data.Monoid.Ord Data.Monoid.Reducer- Data.Monoid.Reducer.Char- Data.Monoid.Reducer.With Data.Monoid.Self Data.Monoid.Sugar Data.Monoid.Union- Data.Ring- Data.Ring.Boolean- Data.Ring.FromNum- Data.Ring.Module- Data.Ring.Module.AutomaticDifferentiation- Data.Ring.Semi.BitSet- Data.Ring.Semi.Kleene- Data.Ring.Semi.Near.Trie- Data.Ring.Semi.Natural- Data.Ring.Semi.Ord- Data.Ring.Semi.Tropical - if flag (bytestring)- build-depends: bytestring >= 0.9 && < 1.0 - cpp-options: -DM_BYTESTRING=1-- if flag (fingertree)- build-depends: fingertree >= 0.0 && < 0.1- cpp-options: -DM_FINGERTREE=1-- if flag (parallel)- build-depends: parallel >= 1.1 && < 1.2- cpp-options: -DM_PARALLEL=1-- if flag (text)- build-depends: text >= 0.1 && < 0.2- cpp-options: -DM_TEXT=1-- if flag (stm)- build-depends: stm >= 2.1 && < 2.2- cpp-options: -DM_STM=1-- if flag (QuickCheck)- build-depends: QuickCheck >= 2.1 && < 2.2- cpp-options: -DM_QUICKCHECK=1-- if flag (reflection)- build-depends: reflection >= 0.1 && < 0.2- cpp-options: -DM_REFLECTION=1- exposed-modules: Data.Ring.ModularArithmetic-- if flag (parsec)- build-depends: parsec >= 3.0 && < 3.1- cpp-options: -DM_PARSEC=3-- if flag (overloaded-strings)- extensions: OverloadedStrings- cpp-options: -DX_OverloadedStrings=1- exposed-modules: Data.Monoid.FromString-- if flag (mtl) - build-depends: mtl >= 1.0 && < 1.2 - cpp-options: -DM_MTL=1- ghc-options: -Wall -fno-warn-duplicate-exports- cpp-options -DM_ARRAY=1 -DM_CONTAINERS=1 if flag (optimize) ghc-options: -funbox-strict-fields -O2 -fdicts-cheap