packages feed

monus (empty) → 0.1.0.0

raw patch · 9 files changed

+377/−0 lines, 9 filesdep +basedep +containersdep +monussetup-changed

Dependencies added: base, containers, monus, smallcheck, tasty, tasty-quickcheck, tasty-smallcheck

Files

+ ChangeLog.md view
@@ -0,0 +1,1 @@+# ChangeLog
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# subtraction-semigroups
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ monus.cabal view
@@ -0,0 +1,45 @@+cabal-version:  2.2+name:           monus+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/andrewthad/monus#readme>+homepage:       https://github.com/andrewthad/monus#readme+bug-reports:    https://github.com/andrewthad/monus/issues+author:         Andrew Martin+maintainer:     andrew.thaddeus@gmail.com+copyright:      2018 Andrew Martin+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/andrewthad/monus++library+  exposed-modules:+    Data.Monoid.Monus+    Data.Monoid.Monus.Generic+    Data.Map.Annihilate+  hs-source-dirs: src+  build-depends:+    , base >=4.5 && <5+    , containers >= 0.4.2.1+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+    , base+    , containers+    , smallcheck+    , monus+    , tasty+    , tasty-smallcheck+    , tasty-quickcheck+  default-language: Haskell2010
+ src/Data/Map/Annihilate.hs view
@@ -0,0 +1,74 @@+{-# language CPP #-}+{-# language GeneralizedNewtypeDeriving #-}++#if !MIN_VERSION_containers(0,5,9)+module Data.Map.Annihilate+  (+  ) where+#else++module Data.Map.Annihilate+  ( Map+  , singleton+  , lookup+  ) where++import Prelude hiding (lookup)++import Data.Semigroup (Semigroup((<>)))+import Data.Monoid (Monoid(mempty))+import Data.Monoid.Monus (Monus(monus))+import Data.Maybe (fromMaybe)++import qualified Data.Map.Strict as M+import qualified Data.Map.Merge.Strict as MM++-- todo: manually write Show instance+newtype Map k v = Map (M.Map k v)+  deriving (Eq,Ord,Functor,Foldable,Show)++singleton :: (Monoid v, Eq v) => k -> v -> Map k v+singleton k v = if v == mempty+  then Map M.empty+  else Map (M.singleton k v)++lookup :: (Ord k, Monoid v) => k -> Map k v -> v+lookup k (Map m) = fromMaybe mempty (M.lookup k m)++instance (Ord k, Monoid v, Eq v) => Semigroup (Map k v) where+  Map x <> Map y = Map+    ( MM.merge+      MM.dropMissing+      MM.dropMissing+      ( MM.zipWithMaybeMatched+        (\_ a b ->+          let c = a `mappend` b+           in if c == mempty then Nothing else Just c+        )+      )+      x +      y+    )++instance (Ord k, Monoid v, Eq v) => Monoid (Map k v) where+  mempty = Map M.empty+#if !MIN_VERSION_base(4,11,0)+  mappend x y = x <> y+#endif++instance (Ord k, Monus v, Eq v) => Monus (Map k v) where+  monus (Map x) (Map y) = Map+    ( MM.merge+      MM.dropMissing+      MM.dropMissing+      ( MM.zipWithMaybeMatched+        (\_ a b ->+          let c = monus a b+           in if c == mempty then Nothing else Just c+        )+      )+      x +      y+    )++#endif
+ src/Data/Monoid/Monus.hs view
@@ -0,0 +1,106 @@+{-# language TypeFamilies #-}+{-# language ScopedTypeVariables #-}+{-# language RankNTypes #-}++-- | A <https://en.wikipedia.org/wiki/Monus commutative monoid with monus>+-- is a 'Monoid' equipped with a subtraction operator.+module Data.Monoid.Monus+  ( Monus(..)+  , (-)+  ) where++import Prelude hiding ((-))+import Data.Set (Set)+import Data.Complex (Complex(..))+import Data.Monoid (Any(..),All(..),Sum(..), Endo(..))+import Control.Applicative (liftA2)+import Numeric.Natural (Natural)+import Data.Foldable+import Data.Coerce++import qualified Prelude as P+import qualified Data.Set as S++infixl 6 -++-- | A commutative monoid that supports subtraction. The following+-- laws must hold:+--+-- > x <> (y - x) = y <> (x - y)+-- > (x - y) - z = x - (y <> z)+-- > x - x = mempty+-- > mempty - x = mempty+class Monoid a => Monus a where+  monus :: a -> a -> a++-- | An infix synonym for 'subtraction'.+(-) :: Monus a => a -> a -> a+(-) = monus+{-# INLINE (-) #-}++instance Ord a => Monus (Set a) where+  monus = S.difference+  {-# INLINE monus #-}++-- | Unlike the subtraction provided by the 'Num' instance of+-- 'Natural', this subtraction is total.+instance (a ~ Natural) => Monus (Sum a) where+  monus (Sum x) (Sum y) = Sum (if x > y then x P.- y else 0)+  {-# INLINE monus #-}++-- | Defined as @P - Q = P ∧ ¬Q@+instance Monus Any where+  monus (Any x) (Any y) = case x of+    False -> Any False+    True -> Any (not y)+  {-# INLINE monus #-}++-- | Defined as @P - Q = P ∨ ¬Q@+instance Monus All where+  monus (All x) (All y) = case x of+    False -> All (not y)+    True -> All True+  {-# INLINE monus #-}++instance forall a. Monus a => Monus (Endo a) where+  monus = coerce (liftA2 monus :: (a -> a) -> (a -> a) -> (a -> a))+  {-# INLINE monus #-}++instance Monus () where+  monus _ _ = ()+  {-# INLINE monus #-}++instance (Monus a, Monus b) => Monus (a,b) where+  monus (a1,b1) (a2,b2) = (monus a1 a2,monus b1 b2)+  {-# INLINE monus #-}++instance (Monus a, Monus b, Monus c) => Monus (a,b,c) where+  monus (a1,b1,c1) (a2,b2,c2) = (monus a1 a2,monus b1 b2,monus c1 c2)+  {-# INLINE monus #-}++instance (Monus a, Monus b, Monus c,Monus d) => Monus (a,b,c,d) where+  monus (a1,b1,c1,d1) (a2,b2,c2,d2) =+    (monus a1 a2,monus b1 b2,monus c1 c2,monus d1 d2)+  {-# INLINE monus #-}++instance (Monus a, Monus b, Monus c,Monus d,Monus e) => Monus (a,b,c,d,e) where+  monus (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = +    (monus a1 a2,monus b1 b2,monus c1 c2,monus d1 d2,monus e1 e2)+  {-# INLINE monus #-}++instance Monus b => Monus (a -> b) where+  monus = liftA2 monus+  {-# INLINE monus #-}++instance Monus a => Monus (IO a) where+  monus = liftA2 monus+  {-# INLINE monus #-}++instance Monus a => Monus [a] where+  monus [] _ = []+  monus x [] = x+  monus (x:xs) (y:ys) = monus x y : monus xs ys++instance Monus a => Monus (Maybe a) where+  monus = liftA2 monus+  {-# INLINE monus #-}
+ src/Data/Monoid/Monus/Generic.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++module Data.Monoid.Monus.Generic+  ( GMonus(..)+  , gmonus+  , WrappedMonus(..)+  ) where++import Data.Semigroup (Semigroup)+import GHC.Generics+import Data.Monoid.Monus+import Prelude hiding (Num(..))++-- | Useful with -XDerivingVia.+newtype WrappedMonus a = WrappedMonus a+  deriving (Generic, Semigroup, Monoid)++instance Monus a => Monus (WrappedMonus a) where+  monus = gmonus;++gmonus :: (Generic a, GMonus (Rep a)) => a -> a -> a+gmonus x y = to (from x `gmonus'` from y)++class GMonus f where+  {-# MINIMAL gmonus' #-}+  gmonus' :: f a -> f a -> f a++instance GMonus U1 where+  gmonus' _ _ = U1++instance (GMonus a, GMonus b) => GMonus (a :*: b) where+  gmonus' (a :*: b) (c :*: d) = gmonus' a c :*: gmonus' b d++instance GMonus a => GMonus (M1 i c a) where+  gmonus' (M1 x) (M1 y) = M1 (gmonus' x y)++instance Monus a => GMonus (K1 i a) where+  gmonus' (K1 x) (K1 y) = K1 (monus x y)
+ test/Main.hs view
@@ -0,0 +1,76 @@+{-# language GeneralizedNewtypeDeriving #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language FlexibleContexts #-}+{-# language StandaloneDeriving #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}++import Prelude hiding ((-))++import Test.Tasty+import Test.Tasty.SmallCheck as SC+import Test.Tasty.QuickCheck as QC+import Test.SmallCheck.Series (Serial(series))++import Data.Proxy (Proxy(..))+import Data.Monoid (Any(..),All(..),Sum(..))+import Data.Set (Set)+import Data.Monoid.Monus (Monus,(-))+import Type.Reflection (typeRep,TypeRep)+import Numeric.Natural (Natural)++import qualified Data.Set as S+import qualified Data.Map.Annihilate as MA++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Monus"+  [ props (typeRep @Any)+  , props (typeRep @All)+  , props (typeRep @(Set Bool))+  , qcProps (typeRep @(Sum Natural))+  , qcProps (typeRep @(MA.Map Int (Set Int)))+  ]++props :: forall m a. (Serial IO a, Monus a, Eq a, Show a) => TypeRep a -> TestTree+props r = testGroup (show r)+  [ SC.testProperty "x <> (y - x) = y <> (x - y)" $+      \(x :: a) y -> x <> (y - x) == y <> (x - y)+  , SC.testProperty "(x - y) - z = x - (y <> z)" $+      \(x :: a) y z -> (x - y) - z == x - (y <> z)+  , SC.testProperty "x - x = mempty" $+      \(x :: a) -> x - x == mempty+  , SC.testProperty "mempty - x = mempty" $+      \(x :: a) -> mempty - x == mempty+  ]++qcProps :: forall m a. (Arbitrary a, Monus a, Eq a, Show a) => TypeRep a -> TestTree+qcProps r = testGroup (show r)+  [ QC.testProperty "x <> (y - x) = y <> (x - y)" $+      \(x :: a) y -> x <> (y - x) == y <> (x - y)+  , QC.testProperty "(x - y) - z = x - (y <> z)" $+      \(x :: a) y z -> (x - y) - z == x - (y <> z)+  , QC.testProperty "x - x = mempty" $+      \(x :: a) -> x - x == mempty+  , QC.testProperty "mempty - x = mempty" $+      \(x :: a) -> mempty - x == mempty+  ]++instance Monad m => Serial m Any where+  series = fmap Any series++instance Monad m => Serial m All where+  series = fmap All series++instance (Monad m, Ord a, Serial m a) => Serial m (Set a) where+  series = fmap S.fromList series++instance Arbitrary Natural where+  arbitrary = fmap (fromIntegral . abs) (arbitrary @Integer)++instance (Arbitrary k, Ord k, Arbitrary v, Monoid v, Eq v) => Arbitrary (MA.Map k v) where+  arbitrary = fmap (foldMap (\(k,v) -> MA.singleton k v)) (arbitrary @[(k,v)])+