diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# 0.0.0.0 + +Initial release on hackage. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Rob Rix + +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 Rob Rix 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# `semilattices` + +This Haskell package defines typeclasses for join- and meet-semilattices, and for upper and lower bounds, and a variety of instances for each. + + +## Usage + +Semilattices are idempotent commutative semigroups, and come in two flavours: `Join` and `Meet`. This presentation of them doesn’t inherit from `Semigroup` however, since `Semigroup`s already exist and the relationships between the various classes here warrant their own operators. + +Join semilattices can be combined using the `\/` operator (pronounced “lub,” for “least upper bound”). Meet semilattices can be combined with the `/\` operator (pronounced “glb,” for “greatest lower bound”). They have opposite relationships to `Lower` and `Upper` bounds (which are optional; in general, there are more lower bounds than upper ones). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/semilattices.cabal b/semilattices.cabal new file mode 100644 --- /dev/null +++ b/semilattices.cabal @@ -0,0 +1,47 @@ +name: semilattices +version: 0.0.0.0 +synopsis: Semilattices +description: Join- and meet-semilattices, with optional upper and lower bounds, and a variety of instances for each. +homepage: https://github.com/robrix/semilattices +license: BSD3 +license-file: LICENSE +author: Rob Rix +maintainer: rob.rix@me.com +copyright: 2017 Rob Rix +category: Algebra, Data, Data Structures, Math +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: + README.md + ChangeLog.md + +library + exposed-modules: Data.Semilattice.Bound + , Data.Semilattice.Join + , Data.Semilattice.Lower + , Data.Semilattice.Meet + , Data.Semilattice.Order + , Data.Semilattice.Tumble + , Data.Semilattice.Upper + build-depends: base >=4.9 && <4.12 + , containers >=0.5 && <0.6 + , hashable >=1.2 && <1.3 + , unordered-containers >=0.2 && <0.3 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-name-shadowing + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Doctests.hs + default-language: Haskell2010 + build-depends: base + , doctest >= 0.7 && < 1.0 + , QuickCheck >= 2.7 && < 2.12 + , quickcheck-instances == 0.3.* + +source-repository head + type: git + location: https://github.com/robrix/semilattices diff --git a/src/Data/Semilattice/Bound.hs b/src/Data/Semilattice/Bound.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semilattice/Bound.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-} +-- | 'Lower' and 'Upper' bounds from 'Bounded' instances. +module Data.Semilattice.Bound where + +import Data.Semilattice.Lower +import Data.Semilattice.Upper + +-- | A convenience bridging 'Bounded' to 'Lower' and 'Upper'. +newtype Bound a = Bound { getBound :: a } + deriving (Bounded, Enum, Eq, Foldable, Functor, Num, Ord, Read, Show, Traversable) + +instance Bounded a => Lower (Bound a) +instance Bounded a => Upper (Bound a) diff --git a/src/Data/Semilattice/Join.hs b/src/Data/Semilattice/Join.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semilattice/Join.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-} +-- | Join semilattices, related to 'Lower' and 'Upper'. +module Data.Semilattice.Join +( Join(..) +, Joining(..) +, LessThan(..) +) where + +import Data.Hashable +import Data.HashMap.Lazy as HashMap +import Data.HashSet as HashSet +import Data.IntMap as IntMap +import Data.IntSet as IntSet +import Data.Map as Map +import Data.Semigroup +import Data.Semilattice.Lower +import Data.Set as Set + +-- | A join semilattice is an idempotent commutative semigroup. +class Join s where + -- | The join operation. + -- + -- Laws: + -- + -- Idempotence: + -- + -- @ + -- x '\/' x = x + -- @ + -- + -- Associativity: + -- + -- @ + -- a '\/' (b '\/' c) = (a '\/' b) '\/' c + -- @ + -- + -- Commutativity: + -- + -- @ + -- a '\/' b = b '\/' a + -- @ + -- + -- Additionally, if @s@ has a 'Lower' bound, then 'lowerBound' must be its identity: + -- + -- @ + -- 'lowerBound' '\/' a = a + -- a '\/' 'lowerBound' = a + -- @ + -- + -- If @s@ has an 'Upper' bound, then 'upperBound' must be its absorbing element: + -- + -- @ + -- 'upperBound' '\/' a = 'upperBound' + -- a '\/' 'upperBound' = 'upperBound' + -- @ + (\/) :: s -> s -> s + + infixr 6 \/ + + +-- Prelude + +instance Join () where + _ \/ _ = () + +-- | Boolean disjunction forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: Bool) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: Bool) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: Bool) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: Bool) +-- +-- Absorption: +-- +-- prop> upperBound \/ a == (upperBound :: Bool) +instance Join Bool where + (\/) = (||) + +-- | Orderings form a semilattice. +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: Ordering) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: Ordering) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: Ordering) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: Ordering) +-- +-- Absorption: +-- +-- prop> upperBound \/ a == (upperBound :: Ordering) +instance Join Ordering where + GT \/ _ = GT + _ \/ GT = GT + LT \/ b = b + a \/ LT = a + _ \/ _ = EQ + +-- | Functions with semilattice codomains form a semilattice. +-- +-- Idempotence: +-- +-- prop> \ (Fn x) -> x \/ x ~= (x :: Int -> Bool) +-- +-- Associativity: +-- +-- prop> \ (Fn a) (Fn b) (Fn c) -> a \/ (b \/ c) ~= (a \/ b) \/ (c :: Int -> Bool) +-- +-- Commutativity: +-- +-- prop> \ (Fn a) (Fn b) -> a \/ b ~= b \/ (a :: Int -> Bool) +-- +-- Identity: +-- +-- prop> \ (Fn a) -> lowerBound \/ a ~= (a :: Int -> Bool) +-- +-- Absorption: +-- +-- prop> \ (Fn a) -> upperBound \/ a ~= (upperBound :: Int -> Bool) +instance Join b => Join (a -> b) where + f \/ g = (\/) <$> f <*> g + + +-- Data.Semigroup + +-- | The least upperBound bound gives rise to a join semilattice. +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: Max Int) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: Max Int) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: Max Int) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: Max Int) +-- +-- Absorption: +-- +-- prop> upperBound \/ a == (upperBound :: Max Int) +instance Ord a => Join (Max a) where + (\/) = (<>) + + +-- containers + +-- | IntMap union with 'Join'able values forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: IntMap (Set Char)) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: IntMap (Set Char)) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: IntMap (Set Char)) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: IntMap (Set Char)) +instance Join a => Join (IntMap a) where + (\/) = IntMap.unionWith (\/) + +-- | IntSet union forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: IntSet) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: IntSet) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: IntSet) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: IntSet) +instance Join IntSet where + (\/) = IntSet.union + +-- | Map union with 'Join'able values forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: Map Char (Set Char)) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: Map Char (Set Char)) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: Map Char (Set Char)) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: Map Char (Set Char)) +instance (Ord k, Join a) => Join (Map k a) where + (\/) = Map.unionWith (\/) + +-- | Set union forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: Set Char) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: Set Char) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: Set Char) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: Set Char) +instance Ord a => Join (Set a) where + (\/) = Set.union + + +-- unordered-containers + +-- | HashMap union with 'Join'able values forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: HashMap Char (Set Char)) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: HashMap Char (Set Char)) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: HashMap Char (Set Char)) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: HashMap Char (Set Char)) +instance (Eq k, Hashable k, Join a) => Join (HashMap k a) where + (\/) = HashMap.unionWith (\/) + +-- | HashSet union forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: HashSet Char) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: HashSet Char) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: HashSet Char) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: HashSet Char) +instance (Eq a, Hashable a) => Join (HashSet a) where + (\/) = HashSet.union + + +-- | A 'Semigroup' for any 'Join' semilattice. +-- +-- If the semilattice has a 'Lower' bound, there is additionally a 'Monoid' instance. +newtype Joining a = Joining { getJoining :: a } + deriving (Bounded, Enum, Eq, Foldable, Functor, Join, Lower, Num, Ord, Read, Show, Traversable) + +-- | 'Joining' '<>' is associative. +-- +-- prop> \ a b c -> Joining a <> (Joining b <> Joining c) == (Joining a <> Joining b) <> Joining (c :: IntSet) +instance Join a => Semigroup (Joining a) where + (<>) = (\/) + +-- | 'Joining' 'mempty' is the left- and right-identity. +-- +-- prop> \ x -> let (l, r) = (mappend mempty (Joining x), mappend (Joining x) mempty) in l == Joining x && r == Joining (x :: IntSet) +instance (Lower a, Join a) => Monoid (Joining a) where + mappend = (<>) + mempty = lowerBound + + +-- | 'Join' semilattices give rise to a partial 'Ord'ering. +newtype LessThan a = LessThan { getLessThan :: a } + deriving (Enum, Eq, Foldable, Functor, Join, Num, Read, Show, Traversable) + +instance (Eq a, Join a) => Ord (LessThan a) where + compare a b + | a == b = EQ + | a \/ b == b = LT + | otherwise = GT + + a <= b = a \/ b == b + + +-- $setup +-- >>> import Data.Semilattice.Upper +-- >>> import Test.QuickCheck +-- >>> import Test.QuickCheck.Function +-- >>> import Test.QuickCheck.Instances.UnorderedContainers () +-- >>> instance Arbitrary a => Arbitrary (Max a) where arbitrary = Max <$> arbitrary +-- >>> :{ +-- infix 4 ~= +-- f ~= g = (==) <$> f <*> g +-- :} diff --git a/src/Data/Semilattice/Lower.hs b/src/Data/Semilattice/Lower.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semilattice/Lower.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP, DefaultSignatures, PolyKinds, TypeFamilies, TypeOperators #-} +-- | Lower bounds, related to 'Bounded', 'Join', 'Meet', and 'Ord'. +module Data.Semilattice.Lower where + +import Data.Char +import Data.Coerce +import Data.Functor.Const +import Data.Functor.Identity +import Data.Int +import Data.HashMap.Lazy as HashMap +import Data.HashSet as HashSet +import Data.IntMap as IntMap +import Data.IntSet as IntSet +import Data.Map as Map +import Data.Monoid as Monoid +import Data.Proxy +import Data.Semigroup as Semigroup +import Data.Set as Set +import Data.Type.Coercion +import Data.Type.Equality +import Data.Word +import Foreign.C.Types +import Foreign.Ptr +import GHC.Generics +import System.Posix.Types + +-- | The greatest lower bound of @s@. +-- +-- Laws: +-- +-- If @s@ is 'Bounded', we require 'lowerBound' and 'minBound' to agree: +-- +-- @ +-- 'lowerBound' = 'minBound' +-- @ +-- +-- If @s@ is a 'Join' semilattice, 'lowerBound' must be the identity of '\/': +-- +-- @ +-- 'lowerBound' '\/' a = a +-- @ +-- +-- If @s@ is a 'Meet' semilattice, 'lowerBound' must be the absorbing element of '/\': +-- +-- @ +-- 'lowerBound' '/\' a = 'lowerBound' +-- @ +-- +-- If @s@ is 'Ord'ered, 'lowerBound' must be at least as small as every terminating value: +-- +-- @ +-- 'compare' 'lowerBound' a /= 'GT' +-- @ +class Lower s where + lowerBound :: s + default lowerBound :: Bounded s => s + lowerBound = minBound + + +-- Prelude +instance Lower () + +-- $ +-- +-- Bounded: +-- +-- prop> lowerBound == (minBound :: Bool) +-- +-- Identity of '\/': +-- +-- prop> lowerBound \/ a == (a :: Bool) +-- +-- Absorbing element of '/\': +-- +-- prop> lowerBound /\ a == (lowerBound :: Bool) +-- +-- Ord: +-- +-- prop> compare lowerBound (a :: Bool) /= GT +instance Lower Bool +instance Lower Ordering +instance Lower Char +instance Lower Int +instance (Lower a, Lower b) => Lower (a, b) where lowerBound = (lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c) => Lower (a, b, c) where lowerBound = (lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d) => Lower (a, b, c, d) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e) => Lower (a, b, c, d, e) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f) => Lower (a, b, c, d, e, f) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f, Lower g) => Lower (a, b, c, d, e, f, g) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f, Lower g, Lower h) => Lower (a, b, c, d, e, f, g, h) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f, Lower g, Lower h, Lower i) => Lower (a, b, c, d, e, f, g, h, i) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f, Lower g, Lower h, Lower i, Lower j) => Lower (a, b, c, d, e, f, g, h, i, j) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f, Lower g, Lower h, Lower i, Lower j, Lower k) => Lower (a, b, c, d, e, f, g, h, i, j, k) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f, Lower g, Lower h, Lower i, Lower j, Lower k, Lower l) => Lower (a, b, c, d, e, f, g, h, i, j, k, l) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f, Lower g, Lower h, Lower i, Lower j, Lower k, Lower l, Lower m) => Lower (a, b, c, d, e, f, g, h, i, j, k, l, m) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f, Lower g, Lower h, Lower i, Lower j, Lower k, Lower l, Lower m, Lower n) => Lower (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance (Lower a, Lower b, Lower c, Lower d, Lower e, Lower f, Lower g, Lower h, Lower i, Lower j, Lower k, Lower l, Lower m, Lower n, Lower o) => Lower (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where lowerBound = (lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound, lowerBound) +instance Lower b => Lower (a -> b) where lowerBound = const lowerBound + +instance Lower (Maybe a) where lowerBound = Nothing +instance Lower [a] where lowerBound = [] + + +-- Data.Char +instance Lower GeneralCategory + +-- Data.Int +instance Lower Int8 +instance Lower Int16 +instance Lower Int32 +instance Lower Int64 + +-- Data.Functor.Const +instance Lower a => Lower (Const a b) where lowerBound = Const lowerBound + +-- Data.Functor.Identity +instance Lower a => Lower (Identity a) where lowerBound = Identity lowerBound + +-- Data.Monoid +instance Lower All +instance Lower Any +instance Lower a => Lower (Product a) where lowerBound = Product lowerBound +instance Lower a => Lower (Sum a) where lowerBound = Sum lowerBound +instance Lower a => Lower (Dual a) where lowerBound = Dual lowerBound + +-- Data.Proxy +instance Lower (Proxy a) + +-- Data.Semigroup +instance Lower a => Lower (Semigroup.First a) where lowerBound = Semigroup.First lowerBound +instance Lower a => Lower (Semigroup.Last a) where lowerBound = Semigroup.Last lowerBound +instance Lower a => Lower (Max a) where lowerBound = Max lowerBound +instance Lower a => Lower (Min a) where lowerBound = Min lowerBound +instance Lower a => Lower (WrappedMonoid a) where lowerBound = WrapMonoid lowerBound + +-- Data.Type.Coercion +instance Coercible a b => Lower (Coercion a b) + +-- Data.Type.Equality +instance (a ~ b) => Lower (a :~: b) +#if MIN_VERSION_base(4,10,0) +instance (a ~~ b) => Lower (a :~~: b) +#endif + +-- Data.Word +instance Lower Word8 +instance Lower Word16 +instance Lower Word32 +instance Lower Word64 + +-- Foreign.C.Types +instance Lower CUIntMax +instance Lower CIntMax +instance Lower CUIntPtr +instance Lower CIntPtr +instance Lower CSigAtomic +instance Lower CWchar +instance Lower CSize +instance Lower CPtrdiff + +instance Lower CULLong +instance Lower CLLong +instance Lower CULong +instance Lower CLong +instance Lower CUInt +instance Lower CInt +instance Lower CUShort +instance Lower CShort +instance Lower CUChar +instance Lower CSChar +instance Lower CChar + +#if MIN_VERSION_base(4,10,0) +instance Lower CBool +#endif + +-- Foreign.Ptr +instance Lower IntPtr +instance Lower WordPtr + +-- GHC.Generics +instance Lower DecidedStrictness +instance Lower SourceStrictness +instance Lower SourceUnpackedness +instance Lower Associativity + +-- System.Posix.Types +instance Lower Fd +instance Lower CRLim +instance Lower CTcflag +instance Lower CUid +instance Lower CNlink +instance Lower CGid +instance Lower CSsize +instance Lower CPid +instance Lower COff +instance Lower CMode +instance Lower CIno +instance Lower CDev + +#if MIN_VERSION_base(4,10,0) +instance Lower CKey +instance Lower CId +instance Lower CFsFilCnt +instance Lower CFsBlkCnt +instance Lower CClockId +instance Lower CBlkCnt +instance Lower CBlkSize +#endif + +-- containers +instance Lower (IntMap a) where lowerBound = IntMap.empty +instance Lower IntSet where lowerBound = IntSet.empty +instance Lower (Map k a) where lowerBound = Map.empty +instance Lower (Set a) where lowerBound = Set.empty + +-- unordered-containers +instance Lower (HashMap k a) where lowerBound = HashMap.empty +instance Lower (HashSet a) where lowerBound = HashSet.empty + + +-- $setup +-- >>> import Data.Semilattice.Join +-- >>> import Data.Semilattice.Meet +-- >>> import Test.QuickCheck (Arbitrary(..)) +-- >>> import Test.QuickCheck.Function diff --git a/src/Data/Semilattice/Meet.hs b/src/Data/Semilattice/Meet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semilattice/Meet.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-} +-- | Join semilattices, related to 'Lower' and 'Upper'. +module Data.Semilattice.Meet +( Meet(..) +, Meeting(..) +, GreaterThan(..) +) where + +import Data.Hashable +import Data.HashMap.Lazy as HashMap +import Data.HashSet as HashSet +import Data.IntMap as IntMap +import Data.IntSet as IntSet +import Data.Map as Map +import Data.Semigroup +import Data.Semilattice.Upper +import Data.Set as Set + +-- | A meet semilattice is an idempotent commutative semigroup. +class Meet s where + -- | The meet operation. + -- + -- Laws: + -- + -- Idempotence: + -- + -- @ + -- x '/\' x = x + -- @ + -- + -- Associativity: + -- + -- @ + -- a '/\' (b '/\' c) = (a '/\' b) '/\' c + -- @ + -- + -- Commutativity: + -- + -- @ + -- a '/\' b = b '/\' a + -- @ + -- + -- Additionally, if @s@ has an 'Upper' bound, then 'upperBound' must be its identity: + -- + -- @ + -- 'upperBound' '/\' a = a + -- a '/\' 'upperBound' = a + -- @ + -- + -- If @s@ has a 'Lower' bound, then 'lowerBound' must be its absorbing element: + -- + -- @ + -- 'lowerBound' '/\' a = 'lowerBound' + -- a '/\' 'lowerBound' = 'lowerBound' + -- @ + (/\) :: s -> s -> s + + infixr 7 /\ + + +-- Prelude + +instance Meet () where + _ /\ _ = () + +-- | Boolean conjunction forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: Bool) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: Bool) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: Bool) +-- +-- Identity: +-- +-- prop> upperBound /\ a == (a :: Bool) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: Bool) +instance Meet Bool where + (/\) = (&&) + +-- | Orderings form a semilattice. +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: Ordering) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: Ordering) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: Ordering) +-- +-- Identity: +-- +-- prop> upperBound /\ a == (a :: Ordering) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: Ordering) +instance Meet Ordering where + LT /\ _ = LT + _ /\ LT = LT + GT /\ b = b + a /\ GT = a + _ /\ _ = EQ + +-- | Functions with semilattice codomains form a semilattice. +-- +-- Idempotence: +-- +-- prop> \ (Fn x) -> x /\ x ~= (x :: Int -> Bool) +-- +-- Associativity: +-- +-- prop> \ (Fn a) (Fn b) (Fn c) -> a /\ (b /\ c) ~= (a /\ b) /\ (c :: Int -> Bool) +-- +-- Commutativity: +-- +-- prop> \ (Fn a) (Fn b) -> a /\ b ~= b /\ (a :: Int -> Bool) +-- +-- Identity: +-- +-- prop> \ (Fn a) -> upperBound /\ a ~= (a :: Int -> Bool) +-- +-- Absorption: +-- +-- prop> \ (Fn a) -> lowerBound /\ a ~= (lowerBound :: Int -> Bool) +instance Meet b => Meet (a -> b) where + f /\ g = (/\) <$> f <*> g + + +-- Data.Semigroup + +-- | The greatest lowerBound bound gives rise to a meet semilattice. +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: Min Int) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: Min Int) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: Min Int) +-- +-- Identity: +-- +-- prop> upperBound /\ a == (a :: Min Int) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: Min Int) +instance Ord a => Meet (Min a) where + (/\) = (<>) + + +-- containers + +-- | IntMap union with 'Meet'able values forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: IntMap (Set Char)) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: IntMap (Set Char)) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: IntMap (Set Char)) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: IntMap (Set Char)) +instance Meet a => Meet (IntMap a) where + (/\) = IntMap.intersectionWith (/\) + +-- | IntSet intersection forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: IntSet) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: IntSet) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: IntSet) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: IntSet) +instance Meet IntSet where + (/\) = IntSet.intersection + +-- | Map union with 'Meet'able values forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: Map Char (Set Char)) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: Map Char (Set Char)) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: Map Char (Set Char)) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: Map Char (Set Char)) +instance (Ord k, Meet a) => Meet (Map k a) where + (/\) = Map.intersectionWith (/\) + +-- | Set intersection forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: Set Char) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: Set Char) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: Set Char) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: Set Char) +instance Ord a => Meet (Set a) where + (/\) = Set.intersection + + +-- unordered-containers + +-- | HashMap union with 'Meet'able values forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: HashMap Char (Set Char)) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: HashMap Char (Set Char)) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: HashMap Char (Set Char)) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: HashMap Char (Set Char)) +instance (Eq k, Hashable k, Meet a) => Meet (HashMap k a) where + (/\) = HashMap.intersectionWith (/\) + +-- | HashSet intersection forms a semilattice. +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: HashSet Char) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: HashSet Char) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: HashSet Char) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: HashSet Char) +instance (Eq a, Hashable a) => Meet (HashSet a) where + (/\) = HashSet.intersection + + +-- | A 'Semigroup' for any 'Meet' semilattice. +-- +-- If the semilattice has an 'Upper' bound, there is additionally a 'Monoid' instance. +newtype Meeting a = Meeting { getMeeting :: a } + deriving (Bounded, Enum, Eq, Foldable, Functor, Meet, Num, Ord, Read, Show, Traversable, Upper) + +-- | 'Meeting' '<>' is associative. +-- +-- prop> Meeting a <> (Meeting b <> Meeting c) == (Meeting a <> Meeting b) <> Meeting (c :: IntSet) +instance Meet a => Semigroup (Meeting a) where + (<>) = (/\) + +-- | 'Meeting' 'mempty' is the left- and right-identity. +-- +-- prop> let (l, r) = (mappend mempty (Meeting x), mappend (Meeting x) mempty) in l == Meeting x && r == Meeting (x :: Bool) +instance (Upper a, Meet a) => Monoid (Meeting a) where + mappend = (<>) + mempty = upperBound + + +-- | 'Meet' semilattices give rise to a partial 'Ord'ering. +newtype GreaterThan a = GreaterThan { getGreaterThan :: a } + deriving (Enum, Eq, Foldable, Functor, Meet, Num, Read, Show, Traversable) + +instance (Eq a, Meet a) => Ord (GreaterThan a) where + compare a b + | a == b = EQ + | a /\ b == a = LT + | otherwise = GT + + a <= b = a /\ b == a + + +-- $setup +-- >>> import Data.Semilattice.Lower +-- >>> import Test.QuickCheck +-- >>> import Test.QuickCheck.Function +-- >>> import Test.QuickCheck.Instances.UnorderedContainers () +-- >>> instance Arbitrary a => Arbitrary (Min a) where arbitrary = Min <$> arbitrary +-- >>> :{ +-- infix 4 ~= +-- f ~= g = (==) <$> f <*> g +-- :} diff --git a/src/Data/Semilattice/Order.hs b/src/Data/Semilattice/Order.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semilattice/Order.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-} +-- | Total 'Ord'erings give rise to 'Join' and 'Meet' semilattices. +module Data.Semilattice.Order where + +import Data.Semilattice.Join +import Data.Semilattice.Lower +import Data.Semilattice.Meet +import Data.Semilattice.Upper + +-- | A 'Join'- and 'Meet'-semilattice for any total 'Ord'ering. +newtype Order a = Order { getOrder :: a } + deriving (Bounded, Enum, Eq, Foldable, Functor, Lower, Num, Ord, Read, Show, Traversable, Upper) + +-- | Total 'Ord'erings give rise to a join semilattice satisfying: +-- +-- Idempotence: +-- +-- prop> Order x \/ Order x == Order x +-- +-- Associativity: +-- +-- prop> Order a \/ (Order b \/ Order c) == (Order a \/ Order b) \/ Order c +-- +-- Commutativity: +-- +-- prop> Order a \/ Order b == Order b \/ Order a +-- +-- Identity: +-- +-- prop> lowerBound \/ Order a == Order (a :: Int) +-- +-- Absorption: +-- +-- prop> upperBound \/ Order a == (upperBound :: Order Int) +-- +-- Distributivity: +-- +-- prop> Order a \/ Order b /\ Order c == (Order a \/ Order b) /\ (Order a \/ Order c) +instance Ord a => Join (Order a) where + a \/ b + | a <= b = b + | otherwise = a + +-- | Total 'Ord'erings give rise to a meet semilattice satisfying: +-- +-- Idempotence: +-- +-- prop> Order x /\ Order x == Order x +-- +-- Associativity: +-- +-- prop> Order a /\ (Order b /\ Order c) == (Order a /\ Order b) /\ Order c +-- +-- Commutativity: +-- +-- prop> Order a /\ Order b == Order b /\ Order a +-- +-- Identity: +-- +-- prop> upperBound /\ Order a == Order (a :: Int) +-- +-- Absorption: +-- +-- prop> lowerBound /\ Order a == (lowerBound :: Order Int) +-- +-- Distributivity: +-- +-- prop> Order a /\ (Order b \/ Order c) == Order a /\ Order b \/ Order a /\ Order c +instance Ord a => Meet (Order a) where + a /\ b + | a <= b = a + | otherwise = b + + +-- $setup +-- >>> import Test.QuickCheck diff --git a/src/Data/Semilattice/Tumble.hs b/src/Data/Semilattice/Tumble.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semilattice/Tumble.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DeriveTraversable, GeneralizedNewtypeDeriving #-} +-- | Inverting a 'Join' semilattice gives rise to a 'Meet' semilattice, and vice versa. +module Data.Semilattice.Tumble where + +import Data.Semilattice.Join +import Data.Semilattice.Lower +import Data.Semilattice.Meet +import Data.Semilattice.Upper + +-- | 'Tumble' gives a 'Join' semilattice for any 'Meet' semilattice and vice versa, 'Lower' bounds for 'Upper' bounds and vice versa, and swaps the bounds of 'Bounded' instances. +newtype Tumble a = Tumble { getTumble :: a } + deriving (Enum, Eq, Foldable, Functor, Num, Read, Show, Traversable) + +-- $ +-- +-- Idempotence: +-- +-- prop> x /\ x == (x :: Tumble Bool) +-- +-- Associativity: +-- +-- prop> a /\ (b /\ c) == (a /\ b) /\ (c :: Tumble Bool) +-- +-- Commutativity: +-- +-- prop> a /\ b == b /\ (a :: Tumble Bool) +-- +-- Identity: +-- +-- prop> upperBound /\ a == (a :: Tumble Bool) +-- +-- Absorption: +-- +-- prop> lowerBound /\ a == (lowerBound :: Tumble Bool) +instance Join a => Meet (Tumble a) where + Tumble a /\ Tumble b = Tumble (a \/ b) + +-- $ +-- +-- Idempotence: +-- +-- prop> x \/ x == (x :: Tumble Bool) +-- +-- Associativity: +-- +-- prop> a \/ (b \/ c) == (a \/ b) \/ (c :: Tumble Bool) +-- +-- Commutativity: +-- +-- prop> a \/ b == b \/ (a :: Tumble Bool) +-- +-- Identity: +-- +-- prop> lowerBound \/ a == (a :: Tumble Bool) +-- +-- Absorption: +-- +-- prop> upperBound \/ a == (upperBound :: Tumble Bool) +instance Meet a => Join (Tumble a) where + Tumble a \/ Tumble b = Tumble (a /\ b) + +instance Bounded a => Bounded (Tumble a) where + minBound = Tumble maxBound + maxBound = Tumble minBound + +-- $ +-- +-- Bounded: +-- +-- prop> upperBound == (maxBound :: Tumble Bool) +-- +-- Identity of '/\': +-- +-- prop> upperBound /\ a == (a :: Tumble Bool) +-- +-- Absorbing element of '\/': +-- +-- prop> upperBound \/ a == (upperBound :: Tumble Bool) +-- +-- Ord: +-- +-- prop> compare upperBound (a :: Tumble Bool) /= LT +instance Lower a => Upper (Tumble a) where + upperBound = Tumble lowerBound + +-- $ +-- +-- Bounded: +-- +-- prop> lowerBound == (minBound :: Tumble Bool) +-- +-- Identity of '\/': +-- +-- prop> lowerBound \/ a == (a :: Tumble Bool) +-- +-- Absorbing element of '/\': +-- +-- prop> lowerBound /\ a == (lowerBound :: Tumble Bool) +-- +-- Ord: +-- +-- prop> compare lowerBound (a :: Tumble Bool) /= GT +instance Upper a => Lower (Tumble a) where + lowerBound = Tumble upperBound + + +instance Ord a => Ord (Tumble a) where + compare (Tumble a) (Tumble b) = compare b a + + +-- $setup +-- >>> import Test.QuickCheck +-- >>> instance Arbitrary a => Arbitrary (Tumble a) where arbitrary = Tumble <$> arbitrary ; shrink (Tumble a) = Tumble <$> shrink a diff --git a/src/Data/Semilattice/Upper.hs b/src/Data/Semilattice/Upper.hs new file mode 100644 --- /dev/null +++ b/src/Data/Semilattice/Upper.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE CPP, DefaultSignatures, PolyKinds, TypeFamilies, TypeOperators #-} +-- | Upper bounds, related to 'Bounded', 'Join', 'Meet', and 'Ord'. +module Data.Semilattice.Upper where + +import Data.Char +import Data.Coerce +import Data.Functor.Const +import Data.Functor.Identity +import Data.Int +import Data.Monoid as Monoid +import Data.Proxy +import Data.Semigroup as Semigroup +import Data.Type.Coercion +import Data.Type.Equality +import Data.Word +import Foreign.C.Types +import Foreign.Ptr +import GHC.Generics +import System.Posix.Types + +-- | The least upper bound of @s@. +-- +-- Laws: +-- +-- If @s@ is 'Bounded', we require 'upperBound' and 'maxBound' to agree: +-- +-- @ +-- 'upperBound' = 'maxBound' +-- @ +-- +-- If @s@ is a 'Meet' semilattice, 'upperBound' must be the identity of '/\': +-- +-- @ +-- 'upperBound' '\/' a = a +-- @ +-- +-- If @s@ is a 'Join' semilattice, 'upperBound' must be the absorbing element of '\/': +-- +-- @ +-- 'upperBound' '\/' a = 'upperBound' +-- @ +-- +-- If @s@ is 'Ord'ered, 'upperBound' must be at least as large as every terminating value: +-- +-- @ +-- 'compare' 'upperBound' a /= 'LT' +-- @ +class Upper s where + upperBound :: s + default upperBound :: Bounded s => s + upperBound = maxBound + + +-- Prelude +instance Upper () + +-- $ +-- +-- Bounded: +-- +-- prop> upperBound == (maxBound :: Bool) +-- +-- Identity of '/\': +-- +-- prop> upperBound /\ a == (a :: Bool) +-- +-- Absorbing element of '\/': +-- +-- prop> upperBound \/ a == (upperBound :: Bool) +-- +-- Ord: +-- +-- prop> compare upperBound (a :: Bool) /= LT +instance Upper Bool +instance Upper Ordering +instance Upper Char +instance Upper Int +instance (Upper a, Upper b) => Upper (a, b) where upperBound = (upperBound, upperBound) +instance (Upper a, Upper b, Upper c) => Upper (a, b, c) where upperBound = (upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d) => Upper (a, b, c, d) where upperBound = (upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e) => Upper (a, b, c, d, e) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f) => Upper (a, b, c, d, e, f) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f, Upper g) => Upper (a, b, c, d, e, f, g) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f, Upper g, Upper h) => Upper (a, b, c, d, e, f, g, h) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f, Upper g, Upper h, Upper i) => Upper (a, b, c, d, e, f, g, h, i) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f, Upper g, Upper h, Upper i, Upper j) => Upper (a, b, c, d, e, f, g, h, i, j) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f, Upper g, Upper h, Upper i, Upper j, Upper k) => Upper (a, b, c, d, e, f, g, h, i, j, k) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f, Upper g, Upper h, Upper i, Upper j, Upper k, Upper l) => Upper (a, b, c, d, e, f, g, h, i, j, k, l) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f, Upper g, Upper h, Upper i, Upper j, Upper k, Upper l, Upper m) => Upper (a, b, c, d, e, f, g, h, i, j, k, l, m) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f, Upper g, Upper h, Upper i, Upper j, Upper k, Upper l, Upper m, Upper n) => Upper (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance (Upper a, Upper b, Upper c, Upper d, Upper e, Upper f, Upper g, Upper h, Upper i, Upper j, Upper k, Upper l, Upper m, Upper n, Upper o) => Upper (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where upperBound = (upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound, upperBound) +instance Upper b => Upper (a -> b) where upperBound = const upperBound + + +-- Data.Char +instance Upper GeneralCategory + +-- Data.Int +instance Upper Int8 +instance Upper Int16 +instance Upper Int32 +instance Upper Int64 + +-- Data.Functor.Const +instance Upper a => Upper (Const a b) where upperBound = Const upperBound + +-- Data.Functor.Identity +instance Upper a => Upper (Identity a) where upperBound = Identity upperBound + +-- Data.Monoid +instance Upper All +instance Upper Any +instance Upper a => Upper (Product a) where upperBound = Product upperBound +instance Upper a => Upper (Sum a) where upperBound = Sum upperBound +instance Upper a => Upper (Dual a) where upperBound = Dual upperBound + +-- Data.Proxy +instance Upper (Proxy a) + +-- Data.Semigroup +instance Upper a => Upper (Semigroup.First a) where upperBound = Semigroup.First upperBound +instance Upper a => Upper (Semigroup.Last a) where upperBound = Semigroup.Last upperBound +instance Upper a => Upper (Max a) where upperBound = Max upperBound +instance Upper a => Upper (Min a) where upperBound = Min upperBound +instance Upper a => Upper (WrappedMonoid a) where upperBound = WrapMonoid upperBound + +-- Data.Type.Coercion +instance Coercible a b => Upper (Coercion a b) + +-- Data.Type.Equality +instance (a ~ b) => Upper (a :~: b) +#if MIN_VERSION_base(4,10,0) +instance (a ~~ b) => Upper (a :~~: b) +#endif + +-- Data.Word +instance Upper Word8 +instance Upper Word16 +instance Upper Word32 +instance Upper Word64 + +-- Foreign.C.Types +instance Upper CUIntMax +instance Upper CIntMax +instance Upper CUIntPtr +instance Upper CIntPtr +instance Upper CSigAtomic +instance Upper CWchar +instance Upper CSize +instance Upper CPtrdiff +instance Upper CULLong +instance Upper CLLong +instance Upper CULong +instance Upper CLong +instance Upper CUInt +instance Upper CInt +instance Upper CUShort +instance Upper CShort +instance Upper CUChar +instance Upper CSChar +instance Upper CChar + +#if MIN_VERSION_base(4,10,0) +instance Upper CBool +#endif + +-- Foreign.Ptr +instance Upper IntPtr +instance Upper WordPtr + +-- GHC.Generics +instance Upper DecidedStrictness +instance Upper SourceStrictness +instance Upper SourceUnpackedness +instance Upper Associativity + +-- System.Posix.Types +instance Upper Fd +instance Upper CRLim +instance Upper CTcflag +instance Upper CUid +instance Upper CNlink +instance Upper CGid +instance Upper CSsize +instance Upper CPid +instance Upper COff +instance Upper CMode +instance Upper CIno +instance Upper CDev + +#if MIN_VERSION_base(4,10,0) +instance Upper CKey +instance Upper CId +instance Upper CFsFilCnt +instance Upper CFsBlkCnt +instance Upper CClockId +instance Upper CBlkCnt +instance Upper CBlkSize +#endif + +-- $setup +-- >>> import Data.Semilattice.Join +-- >>> import Data.Semilattice.Meet +-- >>> import Test.QuickCheck (Arbitrary(..)) +-- >>> import Test.QuickCheck.Function diff --git a/test/Doctests.hs b/test/Doctests.hs new file mode 100644 --- /dev/null +++ b/test/Doctests.hs @@ -0,0 +1,11 @@ +module Main +( main +) where + +import System.Environment +import Test.DocTest + +main :: IO () +main = do + args <- getArgs + doctest ("-isrc" : "--fast" : if null args then ["src"] else args)