├── cabal.project ├── src └── Data │ ├── Frame.hs │ ├── Lattice │ ├── Bounded.hs │ ├── Complete.hs │ ├── Modular.hs │ └── Distributive.hs │ ├── Order │ ├── Quasi.hs │ ├── Linear.hs │ ├── Well.hs │ ├── Total.hs │ ├── Complete.hs │ ├── Directed.hs │ ├── Partial.hs │ ├── Bounded.hs │ └── Pre.hs │ ├── Band.hs │ ├── Lattice.hs │ ├── Band │ └── Rectangular.hs │ ├── Heyting.hs │ └── Semilattice.hs ├── CHANGELOG.md ├── .github ├── dependabot.yml ├── mergify.yml └── workflows │ ├── haskell-ci.yml │ └── .haskell-ci.yml.~undo-tree~ ├── test └── doctests.hs ├── .gitignore ├── README.md ├── LICENSE.edkmett ├── LICENSE ├── order.cabal └── CONTRIBUTING.md /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . -------------------------------------------------------------------------------- /src/Data/Frame.hs: -------------------------------------------------------------------------------- 1 | module Data.Frame where 2 | -------------------------------------------------------------------------------- /src/Data/Lattice/Bounded.hs: -------------------------------------------------------------------------------- 1 | module Data.Lattice.Bounded where 2 | -------------------------------------------------------------------------------- /src/Data/Lattice/Complete.hs: -------------------------------------------------------------------------------- 1 | module Data.Lattice.Complete where 2 | -------------------------------------------------------------------------------- /src/Data/Lattice/Modular.hs: -------------------------------------------------------------------------------- 1 | module Data.Lattice.Modular where 2 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for order 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "daily" 7 | -------------------------------------------------------------------------------- /test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests (flags, pkgs, module_sources) 4 | import Test.DocTest (doctest) 5 | 6 | main :: IO () 7 | main = doctest $ flags ++ pkgs ++ module_sources 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | *.~undo-tree~ -------------------------------------------------------------------------------- /src/Data/Lattice/Distributive.hs: -------------------------------------------------------------------------------- 1 | module Data.Lattice.Distributive where 2 | import Data.Lattice 3 | 4 | -- | a distributive lattice. `join` and `meet` distribute over each other: 5 | -- 6 | -- Join distributes: 7 | -- forall a b c. a `join` (b `meet` c) = (a `join` b) `meet` (a `join` c) 8 | -- 9 | -- Meet distributes: 10 | -- forall a b c. a `meet` (b `join` c) = (a `meet` b) `join` (a `meet` c) 11 | class Lattice a => Distributive a where 12 | -------------------------------------------------------------------------------- /src/Data/Order/Quasi.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Order.Quasi 3 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 4 | -- License : BSD-style 5 | -- 6 | -- Maintainer : Emily Pillmore , 7 | -- Davean Scies , 8 | -- Siddharth Bhat 9 | -- Stability : stable 10 | -- Portability : non-portable 11 | -- 12 | -- 13 | module Data.Order.Quasi where 14 | -------------------------------------------------------------------------------- /src/Data/Order/Linear.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Order.Linear 3 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 4 | -- License : BSD-style 5 | -- 6 | -- Maintainer : Emily Pillmore , 7 | -- Davean Scies , 8 | -- Siddharth Bhat 9 | -- Stability : stable 10 | -- Portability : non-portable 11 | -- 12 | -- 13 | module Data.Order.Linear where 14 | -------------------------------------------------------------------------------- /.github/mergify.yml: -------------------------------------------------------------------------------- 1 | pull_request_rules: 2 | - name: Automatically merge pull requests 3 | actions: 4 | merge: 5 | strict: smart+fasttrack 6 | method: squash 7 | conditions: 8 | - label=merge me 9 | - '#approved-reviews-by>=1' 10 | - name: automatic merge of dependabot 11 | actions: 12 | merge: 13 | strict: smart 14 | method: rebase 15 | priority: low 16 | conditions: 17 | - author~=^dependabot(|-preview)\[bot\]$ 18 | - base=main -------------------------------------------------------------------------------- /src/Data/Order/Well.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Order.Well 3 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 4 | -- License : BSD-style 5 | -- 6 | -- Maintainer : Emily Pillmore , 7 | -- Davean Scies , 8 | -- Siddharth Bhat 9 | -- Stability : stable 10 | -- Portability : non-portable 11 | -- 12 | -- This module contains definitions for 'WellOrd', the class 13 | -- of types that have a well ordering. 14 | -- 15 | module Data.Order.Well where 16 | -------------------------------------------------------------------------------- /src/Data/Order/Total.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Order.Total 3 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 4 | -- License : BSD-style 5 | -- 6 | -- Maintainer : Emily Pillmore , 7 | -- Davean Scies , 8 | -- Siddharth Bhat 9 | -- Stability : stable 10 | -- Portability : non-portable 11 | -- 12 | -- This module contains definitions for 'TotalOrd', the class 13 | -- of types that have a total ordering. 14 | -- 15 | module Data.Order.Total where 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | order 2 | ========== 3 | 4 | [![Hackage](https://img.shields.io/hackage/v/order.svg)](https://hackage.haskell.org/package/order) ![Build Status](https://github.com/emilypi/order/actions/workflows/haskell-ci.yml/badge.svg) 5 | 6 | This is a package for exploring order-theory in Haskell. 7 | 8 | What This Works On 9 | ------------------ 10 | 11 | We support (and test in CI) the following major GHC versions: 12 | 13 | * 8.10 14 | * 9.0 15 | * 9.2 16 | * 9.4 17 | * 9.6 18 | 19 | We test on macOS and Linux. 20 | 21 | Contact Information 22 | ------------------- 23 | 24 | Contributions and bug reports are welcome! 25 | 26 | Maintained by Emily Pillmore (@topos). Please feel free to contact me through Github or on the #haskell IRC channel on irc.libera.chat. 27 | 28 | References 29 | ---------- 30 | 31 | A good introduction to order theory is 32 | [Introduction to Lattices and Order by Davey & Priestley](https://www.cambridge.org/core/books/introduction-to-lattices-and-order/946458CB6638AF86D85BA00F5787F4F4) 33 | -------------------------------------------------------------------------------- /src/Data/Band.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Band 3 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 4 | -- License : BSD-style 5 | -- 6 | -- Maintainer : Emily Pillmore , 7 | -- Davean Scies , 8 | -- Siddharth Bhat 9 | -- Stability : stable 10 | -- Portability : non-portable 11 | -- 12 | -- This module contains definitions for 'Band', the class 13 | -- of idempotent semigroups. 14 | -- 15 | module Data.Band 16 | ( Band(..) 17 | ) where 18 | 19 | 20 | import Data.Semigroup 21 | 22 | -- | @Band@s are type of idempotent semigroups. 23 | -- 24 | class Semigroup a => Band a 25 | 26 | instance Band All 27 | instance Band Any 28 | instance Band () 29 | instance Band a => Band (Dual a) 30 | instance (Band a, Band b) => Band (a, b) 31 | instance (Band a, Band b, Band c) => Band (a, b, c) 32 | instance (Band a, Band b, Band c, Band d) => Band (a, b, c, d) 33 | instance (Band a, Band b, Band c, Band d, Band e) => Band (a, b, c, d, e) 34 | -------------------------------------------------------------------------------- /src/Data/Lattice.hs: -------------------------------------------------------------------------------- 1 | {-# language Safe #-} 2 | -- | 3 | -- Module : Data.Lattice 4 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 5 | -- License : BSD-style 6 | -- 7 | -- Maintainer : Emily Pillmore , 8 | -- Davean Scies , 9 | -- Siddharth Bhat 10 | -- Stability : stable 11 | -- Portability : non-portable 12 | -- 13 | -- This module contains definitions for 'Lattice's and their 14 | -- bounded variants, along with associated combinators. 15 | -- 16 | module Data.Lattice 17 | ( -- * Lattices 18 | Lattice 19 | , BoundedLattice 20 | ) where 21 | 22 | 23 | import Data.Semilattice 24 | 25 | 26 | -- | A lattice is a 'Poset' that admits all finite 'meet's and 'join's. 27 | -- It can also be defined algebraically as having two binary operations, 28 | -- ∧ and ∨, which form a meet and join-semilattice respectively, along 29 | -- with their absorption laws: 30 | -- 31 | -- [Absorption 1] @a '∨' (a '∧' b) = a@ 32 | -- [Absorption 2] @a '∧' (a '∨' b) = a@ 33 | -- 34 | class (Join a, Meet a) => Lattice a where 35 | 36 | 37 | -- | A bounded lattice is a 'Lattice' that admits a top and bottom element 38 | -- such that the 'join' and 'meet' operations form 'BoundedJoin' and 39 | -- 'BoundedMeet' semilattices respectively. 40 | -- 41 | class (BoundedJoin a, BoundedMeet a) => BoundedLattice a where 42 | -------------------------------------------------------------------------------- /src/Data/Band/Rectangular.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | -- | 4 | -- Module : Data.Band.Rectangular 5 | -- Copyright : (c) 2011 Edward Kmett 6 | -- License : BSD-style 7 | -- 8 | -- Maintainer : Emily Pillmore , 9 | -- Davean Scies , 10 | -- Siddharth Bhat 11 | -- Stability : stable 12 | -- Portability : non-portable 13 | -- 14 | -- This module contains definitions for rectangular 'Band's, the class idempotent semigroups which are nowhere 15 | -- commutative. 16 | -- 17 | -- Copyright notice: The following code is copied from the package by Edward Kmett ((c) 2011), 18 | -- and slightly modified to fit the needs of this package. 19 | -- 20 | module Data.Band.Rectangular 21 | ( Band(..) 22 | ) where 23 | 24 | 25 | import Data.Data 26 | import Data.Band 27 | 28 | import GHC.Generics 29 | 30 | -- | a rectangular band is a nowhere commutative semigroup. 31 | -- That is to say, if ab = ba then a = b. From this it follows 32 | -- classically that aa = a and that such a band is isomorphic 33 | -- to the following structure 34 | -- 35 | data Rect i j = Rect i j 36 | deriving 37 | ( Eq, Ord, Show, Read 38 | , Generic, Generic1 39 | , Data, Typeable 40 | ) 41 | 42 | instance Semigroup (Rect i j) where 43 | Rect i _ <> Rect _ j = Rect i j 44 | 45 | instance Band (Rect i j) 46 | -------------------------------------------------------------------------------- /LICENSE.edkmett: -------------------------------------------------------------------------------- 1 | Copyright 2011 Edward Kmett 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 21 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2020-2023, Emily Pillmore and Davean Scies 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Emily Pillmore nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /order.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.4 2 | 3 | name: order 4 | version: 0.1.0.0 5 | synopsis: Order-theory 6 | description: Order theory for the working Haskell programmer 7 | bug-reports: https://github.com/emilypi/order 8 | license: BSD-3-Clause 9 | license-file: 10 | LICENSE 11 | LICENSE.edkmett 12 | author: Emily Pillmore, Siddharth Bhat, davean 13 | maintainer: emilypi@cohomolo.gy, davean@xkcd.com 14 | copyright: 2020-2023 (c) Emily Pillmore , Siddharth Bhat, davean, 2018 Edward A. Kmett 15 | category: Order, Algebra, Relational Calculus 16 | build-type: Simple 17 | extra-doc-files: 18 | CHANGELOG.md 19 | README.md 20 | 21 | tested-with: 22 | GHC ==8.10.7 23 | || ==9.0.2 24 | || ==9.2.8 25 | || ==9.4.7 26 | || ==9.6.2 27 | 28 | source-repository head 29 | type: git 30 | location: https://github.com/emilypi/order.git 31 | 32 | common base 33 | default-language: Haskell2010 34 | build-depends: 35 | array ^>= 0.5 36 | , base >=4.10 && <5 37 | , containers >=0.5 && <0.7 38 | , ghc-prim >=0.5.1.0 && <0.11 39 | 40 | library 41 | import: base 42 | hs-source-dirs: src 43 | exposed-modules: 44 | Data.Band 45 | Data.Band.Rectangular 46 | -- Data.Boolean 47 | -- Data.Boolean.Generalized 48 | -- Data.Frame 49 | Data.Heyting 50 | Data.Lattice 51 | Data.Lattice.Distributive 52 | -- Data.Lattice.Modular 53 | Data.Semilattice 54 | Data.Order.Bounded 55 | Data.Order.Directed 56 | -- Data.Order.Linear 57 | Data.Order.Partial 58 | Data.Order.Complete 59 | Data.Order.Pre 60 | -- Data.Order.Quasi 61 | -- Data.Order.Total 62 | -- Data.Order.Well 63 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributors Guide 2 | 3 | ## Bug Reports 4 | 5 | Please [open an issue](https://github.com/emilypi/order/issues/new) if you have a bug to report. 6 | 7 | The more detailed your report, the faster it can be resolved and will ensure it 8 | is resolved in the right way. I personally appreciate it when people not only open 9 | issues, but attempt to resolve them on their own by submitting a pull request. I am 10 | always open to constructive feedback, and I am by no means an expert, so guidance 11 | should always be considered welcome. 12 | 13 | ## Documentation 14 | 15 | If you would like to help with documentation, please remember to update any and 16 | all module headers with the appropriate copyright dates, ranges, and authorship. 17 | 18 | Expansions to the documentation are welcome, and appreciated. Every contribution counts. 19 | 20 | ## Code 21 | 22 | If you would like to contribute code to fix a bug, add a new feature, or 23 | otherwise improve `order`, pull requests are most welcome. It's a good idea to 24 | [submit an issue](https://github.com/emilypi/order/issues/new) to 25 | discuss the change before plowing into writing code. 26 | 27 | If relevant, any and all claims of "performance" should be backed up with benchmarks. You can 28 | add them to the existing benchmark suite in your PR, as long as you do not make 29 | unjustifiable changes to the existing code. 30 | 31 | ## Code Quality 32 | 33 | The `order` project intends to focus on integration and usability, 34 | balanced with maintainability. Please keep in mind that for a foundational 35 | library like this, usability, portability, and API are what matters before 36 | elegance. 37 | 38 | ## Testing 39 | 40 | All new code should be covered by tests. Additionally, if you find uncovered material 41 | in the existing codebase, tests are always appreciated as pull requests. 42 | -------------------------------------------------------------------------------- /src/Data/Heyting.hs: -------------------------------------------------------------------------------- 1 | {-# language Safe #-} 2 | -- | 3 | -- Module : Data.Heyting 4 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 5 | -- License : BSD-style 6 | -- 7 | -- Maintainer : Emily Pillmore , 8 | -- Davean Scies , 9 | -- Siddharth Bhat 10 | -- Stability : stable 11 | -- Portability : non-portable 12 | -- 13 | -- This module contains definitions for 'Heyting' algebras and their 14 | -- associated combinators. 15 | -- 16 | module Data.Heyting 17 | ( -- * Heyting algebras 18 | Heyting(..) 19 | , (→) 20 | , not 21 | , (¬) 22 | , const 23 | ) where 24 | 25 | import Prelude () 26 | 27 | import Data.Lattice 28 | import Data.Semilattice 29 | 30 | -- | A @Heyting@ algebra is a 'BoundedLattice' such that for every 31 | -- pair of elements in the algebra, there exists a unique greatest element 32 | -- @x@ such that @a ∧ x <= b@ holds. We call @x@ the /relative pseudo-complement/ 33 | -- of @a@ with respect to @b@, and it is denoted @a '→' b@. 34 | -- 35 | -- Generally, we call @('→')@ /implication/, and say that a @Heyting@ 36 | -- algebra is a 'BoundedLattice' for which implication holds. 37 | -- 38 | -- Implication is the weakest proposition for which /modus ponens/ 39 | -- is valid as an inference rule. 40 | -- 41 | -- Laws: 42 | -- 43 | -- [Relative pseudo-complement] @a ∧ x <= b@ 44 | -- 45 | class BoundedLattice a => Heyting a where 46 | implies :: a -> a -> a 47 | {-# minimal implies #-} 48 | 49 | 50 | -- | A unicode alias for 'implies' 51 | -- 52 | (→) :: Heyting a => a -> a -> a 53 | (→) = implies 54 | infixr 0 → 55 | 56 | -- | Negation in a 'Heyting' algebra is an implication @a '→' '⊥'@. 57 | -- 58 | not :: Heyting a => a -> a 59 | not a = implies a bottom 60 | 61 | -- | A unicode alias for 'not'. 62 | (¬) :: Heyting a => a -> a 63 | (¬) = not 64 | 65 | -- | The constant morphism from any element to the top element. 66 | -- 67 | const :: Heyting a => a -> a 68 | const _ = top 69 | -------------------------------------------------------------------------------- /src/Data/Order/Complete.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | -- | 3 | -- Module : Data.Order.Complete 4 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 5 | -- License : BSD-style 6 | -- 7 | -- Maintainer : Emily Pillmore , 8 | -- Davean Scies , 9 | -- Siddharth Bhat 10 | -- Stability : stable 11 | -- Portability : non-portable 12 | -- 13 | -- This module contains definitions for 'CompletePartialOrd', the class 14 | -- of types that form a complete partial order. 15 | -- 16 | module Data.Order.Complete 17 | ( -- * Complete partial orders 18 | CompletePartialOrd(..) 19 | ) where 20 | 21 | 22 | import Data.Order.Partial 23 | 24 | -- | Davey and Priestly, 2nd edition, Definition 7.7: Directed set: 25 | -- let S be a non-empty subset of an ordered set P. 26 | -- Then ∀ x, y ∈ S, ∃z ∈ S, z ∈ x ≤ z ∧ y ≤ z 27 | 28 | -- | Davey and Priestly, 2nd edition, Definition 8.1: a CPO is an ordered set with a bottom, 29 | -- where each directed set has a supremum. 30 | class PartialOrd a => CompletePartialOrd a where 31 | -- | conceivably, some types may have better encodings of directed subsets 32 | -- than others..? 33 | type Directed a -- associated type of directed subsets? 34 | bot :: a 35 | sup :: Directed a -> a 36 | 37 | -- @topos: I recall that it's enough to ask for all /chains/ to possess a sup, 38 | -- and not directed sets, and everything of value works out in this case. 39 | -- Davey and Priestly, 2nd edition, section 8.10 says: > It turns out that an 40 | -- ordered set is a CPO provided that each chain has a least upper bound in P. 41 | -- (Note that the join of the empty chain guarantess the existence of _|_) We 42 | -- omit the proof of this highly nontrivial result, which we record below as a 43 | -- t-heorem. Exercise 8.9 seeks a proof in the countable case; the general case 44 | -- requires the machinery of ordinals. 45 | -- 46 | -- @topos: What's a useful encoding of directed sets in the finite/computable 47 | -- case for us? 48 | -------------------------------------------------------------------------------- /src/Data/Order/Directed.hs: -------------------------------------------------------------------------------- 1 | {-# language GeneralizedNewtypeDeriving #-} 2 | {-# language DeriveDataTypeable #-} 3 | {-# language DeriveGeneric #-} 4 | {-# language Trustworthy #-} 5 | -- | 6 | -- Module : Data.Ordered.Directed 7 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 8 | -- License : BSD-style 9 | -- 10 | -- Maintainer : Emily Pillmore , 11 | -- Davean Scies , 12 | -- Siddharth Bhat 13 | -- Stability : stable 14 | -- Portability : non-portable 15 | -- 16 | -- This module contains definitions the newtype associated with 17 | -- the union (joins) of upwards directed sets and the intersection 18 | -- (meets) of downward directed sets. 19 | -- 20 | module Data.Order.Directed 21 | ( -- * The lattice of directed sets 22 | Directed(..) 23 | -- ** Aliases 24 | , Upwards 25 | , Downwards 26 | ) where 27 | 28 | 29 | import Data.Typeable (Typeable) 30 | import Data.Data (Data) 31 | import GHC.Generics (Generic) 32 | import Data.Semilattice 33 | import Data.Order.Pre 34 | import Data.Order.Partial 35 | import Data.Order.Bounded 36 | import Data.Lattice 37 | 38 | -- | Wrapper for the lattice of upwards and downwards directed sets. 39 | -- 40 | newtype Directed = Directed { getDirected :: Ordering } 41 | deriving 42 | ( Eq, Show, Read 43 | , Bounded, Enum 44 | , Data, Typeable 45 | , Generic 46 | ) 47 | 48 | instance PreOrd Directed where 49 | leq (Directed a) (Directed b) = a `leq` b 50 | 51 | instance PartialOrd Directed 52 | 53 | instance Join Directed where 54 | join (Directed LT) a = a 55 | join a (Directed LT) = a 56 | join (Directed EQ) a = a 57 | join a (Directed EQ) = a 58 | join a _ = a 59 | 60 | instance Infimum Directed where 61 | inf = Directed LT 62 | 63 | instance BoundedJoin Directed 64 | 65 | instance Meet Directed where 66 | meet (Directed GT) a = a 67 | meet a (Directed GT) = a 68 | meet (Directed EQ) a = a 69 | meet a (Directed EQ) = a 70 | meet a _ = a 71 | 72 | instance Supremum Directed where 73 | sup = Directed GT 74 | 75 | instance BoundedMeet Directed 76 | 77 | instance Lattice Directed 78 | 79 | instance BoundedLattice Directed 80 | 81 | -- | The semilattice of upwards directed sets, closed under joins (union) 82 | -- 83 | type Upwards = Joins Directed 84 | 85 | -- | The semilattice of downwards directed sets closed under meets 86 | -- (intersection) 87 | -- 88 | type Downwards = Meets Directed 89 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | name: ci 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: {} # Validate all PRs 7 | 8 | defaults: 9 | run: 10 | shell: bash 11 | 12 | jobs: 13 | build: 14 | runs-on: ${{ matrix.os }} 15 | strategy: 16 | fail-fast: true 17 | matrix: 18 | os: [ubuntu-latest] 19 | ghc: ['8.10', '9.0', '9.2', '9.4', '9.6'] 20 | include: 21 | - os: macOS-latest 22 | ghc: 'latest' 23 | steps: 24 | - uses: actions/checkout@v3 25 | - name: Install libncurses5 and libtinfo 26 | if: runner.os == 'Linux' && (matrix.ghc == '8.0' || matrix.ghc == '8.2') 27 | run: | 28 | sudo apt-get install libncurses5 libtinfo5 29 | - uses: haskell/actions/setup@v2 30 | id: setup-haskell-cabal 31 | with: 32 | ghc-version: ${{ matrix.ghc }} 33 | - name: Update cabal package database 34 | run: cabal update 35 | - uses: actions/cache@v2 36 | name: Cache cabal stuff 37 | with: 38 | path: | 39 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 40 | dist-newstyle 41 | key: ${{ runner.os }}-${{ matrix.ghc }} 42 | - name: Test 43 | run: | 44 | cabal sdist -z -o . 45 | cabal get order-*.tar.gz 46 | cd order-*/ 47 | cabal build order:tests --enable-tests --enable-benchmarks 48 | cabal test --enable-tests --enable-benchmarks --test-show-details=direct all 49 | - name: Haddock 50 | run: | 51 | cd order-*/ 52 | cabal haddock all 53 | - name: Cabal check 54 | run: | 55 | cd order-*/ 56 | cabal check 57 | 58 | bounds-checking: 59 | needs: build 60 | runs-on: ubuntu-latest 61 | steps: 62 | - uses: actions/checkout@v3 63 | - uses: haskell/actions/setup@v2 64 | id: setup-haskell-cabal 65 | with: 66 | ghc-version: 'latest' 67 | - name: Update cabal package database 68 | run: cabal update 69 | - uses: actions/cache@v2 70 | name: Cache cabal stuff 71 | with: 72 | path: | 73 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 74 | dist-newstyle 75 | key: ${{ runner.os }}-latest 76 | - name: Test 77 | run: cabal test --ghc-options='-fcheck-prim-bounds -fno-ignore-asserts' 78 | with: 79 | path: ${{ steps.setup-haskell.outputs.cabal-store }} 80 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 81 | restore-keys: ${{ runner.os }}-${{ matrix.ghc }}- 82 | - name: Build 83 | run: cabal new-build 84 | - name: Test 85 | run: cabal new-test --test-show-details=direct 86 | -------------------------------------------------------------------------------- /src/Data/Order/Partial.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Data.Order.Partial 3 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 4 | -- License : BSD-style 5 | -- 6 | -- Maintainer : Emily Pillmore , 7 | -- Davean Scies , 8 | -- Siddharth Bhat 9 | -- Stability : stable 10 | -- Portability : non-portable 11 | -- 12 | -- This module contains definitions for 'PartialOrd', the class 13 | -- of types that form a partial order. 14 | -- 15 | module Data.Order.Partial 16 | ( PartialOrd 17 | ) where 18 | 19 | 20 | import Data.Order.Pre 21 | import Data.Void 22 | import Data.Set 23 | import Data.IntSet 24 | 25 | -- | Adds a law to a preorder where we must have antisymmetry. 26 | -- Law: forall a b. (a <= b) => !(b <= a) 27 | -- @topos: if we are willing to have an `Eq` instance, then we can say: 28 | -- (a <= b /\ b <= a) => (a = b) 29 | class PreOrd a => PartialOrd a where 30 | 31 | instance PartialOrd Void 32 | instance PartialOrd () 33 | instance PartialOrd Bool 34 | instance Ord a => PartialOrd (Set a) 35 | instance PartialOrd IntSet 36 | instance PartialOrd a => PartialOrd (Maybe a) 37 | 38 | instance (PartialOrd a, PartialOrd b) => PartialOrd (a, b) 39 | instance (PartialOrd a, PartialOrd b, PartialOrd c) => PartialOrd (a, b, c) 40 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d) => PartialOrd (a, b, c, d) 41 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e) => PartialOrd (a, b, c, d, e) 42 | 43 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f) => PartialOrd (a, b, c, d, e, f) 44 | 45 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f, PartialOrd g) => 46 | PartialOrd (a, b, c, d, e, f, g) 47 | 48 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f, PartialOrd g, PartialOrd h) => 49 | PartialOrd (a, b, c, d, e, f, g, h) 50 | 51 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f, PartialOrd g, PartialOrd h, PartialOrd i) => 52 | PartialOrd (a, b, c, d, e, f, g, h, i) 53 | 54 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f, PartialOrd g, PartialOrd h, PartialOrd i, PartialOrd j) => 55 | PartialOrd (a, b, c, d, e, f, g, h, i, j) 56 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f, PartialOrd g, PartialOrd h, PartialOrd i, PartialOrd j, PartialOrd k) => 57 | PartialOrd (a, b, c, d, e, f, g, h, i, j, k) 58 | 59 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f, PartialOrd g, PartialOrd h, PartialOrd i, PartialOrd j, PartialOrd k, PartialOrd l) => 60 | PartialOrd (a, b, c, d, e, f, g, h, i, j, k, l) 61 | 62 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f, PartialOrd g, PartialOrd h, PartialOrd i, PartialOrd j, PartialOrd k, PartialOrd l, PartialOrd m) => 63 | PartialOrd (a, b, c, d, e, f, g, h, i, j, k, l, m) 64 | 65 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f, PartialOrd g, PartialOrd h, PartialOrd i, PartialOrd j, PartialOrd k, PartialOrd l, PartialOrd m, PartialOrd n) => 66 | PartialOrd (a, b, c, d, e, f, g, h, i, j, k, l, m, n) 67 | 68 | 69 | instance (PartialOrd a, PartialOrd b, PartialOrd c, PartialOrd d, PartialOrd e, PartialOrd f, PartialOrd g, PartialOrd h, PartialOrd i, PartialOrd j, PartialOrd k, PartialOrd l, PartialOrd m, PartialOrd n, PartialOrd o) => 70 | PartialOrd (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) 71 | -------------------------------------------------------------------------------- /.github/workflows/.haskell-ci.yml.~undo-tree~: -------------------------------------------------------------------------------- 1 | (undo-tree-save-format-version . 1) 2 | "a6b1b236ecfbd1ad5764d6da602969eb5c26d811" 3 | [nil nil nil nil (25850 3935 952960 0) 0 nil] 4 | ([nil nil (("8" . -333) (undo-tree-id35 . -1) (undo-tree-id36 . -1) (undo-tree-id37 . -1) 334 (t 25850 3432 17658 351000)) nil (25850 3935 952959 0) 0 nil]) 5 | ([nil nil ((333 . 335)) nil (25850 3935 952956 0) 0 nil]) 6 | ([nil nil (("'" . -338) (undo-tree-id27 . -1) ("8" . -339) (undo-tree-id28 . -1) ("." . -340) (undo-tree-id29 . -1) ("1" . -341) (undo-tree-id30 . -1) ("0" . -342) (undo-tree-id31 . -1) ("'" . -343) (undo-tree-id32 . -1) ("," . -344) (undo-tree-id33 . -1) (" " . -345) (undo-tree-id34 . -1) 346) nil (25850 3935 952955 0) 0 nil]) 7 | ([nil nil ((350 . 357)) nil (25850 3935 952949 0) 0 nil]) 8 | ([nil nil ((357 . 363)) nil (25850 3935 952948 0) 0 nil]) 9 | ([nil nil (("4" . -362) (undo-tree-id0 . -1) (undo-tree-id1 . -1) (undo-tree-id2 . -1) (undo-tree-id3 . -1) (undo-tree-id4 . -1) (undo-tree-id5 . -1) (undo-tree-id6 . -1) (undo-tree-id7 . -1) (undo-tree-id8 . -1) (undo-tree-id9 . -1) (undo-tree-id10 . -1) (undo-tree-id11 . -1) (undo-tree-id12 . -1) (undo-tree-id13 . -1) (undo-tree-id14 . -1) (undo-tree-id15 . -1) (undo-tree-id16 . -1) (undo-tree-id17 . -1) (undo-tree-id18 . -1) (undo-tree-id19 . -1) (undo-tree-id20 . -1) (undo-tree-id21 . -1) (undo-tree-id22 . -1) (undo-tree-id23 . -1) (undo-tree-id24 . -1) (undo-tree-id25 . -1) (undo-tree-id26 . -1) 363) nil (25850 3935 952946 0) 0 nil]) 10 | ([nil nil ((362 . 364)) nil (25850 3935 952920 0) 0 nil]) 11 | ([nil nil ((1 . 2058) (t 25850 3935 954417 485000)) nil (25850 4275 454414 0) 0 nil]) 12 | ([nil nil (("name: CI" . 2058)) nil (25850 4275 454413 0) 0 nil]) 13 | ([nil nil ((" 14 | " . 2058)) nil (25850 4275 454412 0) 0 nil]) 15 | ([nil nil ((" 16 | " . 2058)) nil (25850 4275 454412 0) 0 nil]) 17 | ([nil nil (("# Trigger the workflow on push or pull request, but only for the main branch" . 2058)) nil (25850 4275 454411 0) 0 nil]) 18 | ([nil nil ((" 19 | " . 2058)) nil (25850 4275 454411 0) 0 nil]) 20 | ([nil nil (("on:" . 2058)) nil (25850 4275 454410 0) 0 nil]) 21 | ([nil nil ((" 22 | " . 2058)) nil (25850 4275 454409 0) 0 nil]) 23 | ([nil nil ((" pull_request:" . 2058)) nil (25850 4275 454409 0) 0 nil]) 24 | ([nil nil ((" 25 | " . 2058)) nil (25850 4275 454408 0) 0 nil]) 26 | ([nil nil ((" push:" . 2058)) nil (25850 4275 454408 0) 0 nil]) 27 | ([nil nil ((" 28 | " . 2058)) nil (25850 4275 454407 0) 0 nil]) 29 | ([nil nil ((" branches: [\"main\"]" . 2058)) nil (25850 4275 454406 0) 0 nil]) 30 | ([nil nil ((" 31 | " . 2058)) nil (25850 4275 454406 0) 0 nil]) 32 | ([nil nil ((" 33 | " . 2058)) nil (25850 4275 454405 0) 0 nil]) 34 | ([nil nil (("jobs:" . 2058)) nil (25850 4275 454405 0) 0 nil]) 35 | ([nil nil ((" 36 | " . 2058)) nil (25850 4275 454404 0) 0 nil]) 37 | ([nil nil ((" ci:" . 2058)) nil (25850 4275 454403 0) 0 nil]) 38 | ([nil nil ((" 39 | " . 2058)) nil (25850 4275 454403 0) 0 nil]) 40 | ([nil nil ((" name: ${{ matrix.ghc }} on ${{ matrix.os }}" . 2058)) nil (25850 4275 454402 0) 0 nil]) 41 | ([nil nil ((" 42 | " . 2058)) nil (25850 4275 454402 0) 0 nil]) 43 | ([nil nil ((" runs-on: ${{ matrix.os }}" . 2058)) nil (25850 4275 454401 0) 0 nil]) 44 | ([nil nil ((" 45 | " . 2058)) nil (25850 4275 454400 0) 0 nil]) 46 | ([nil nil ((" strategy:" . 2058)) nil (25850 4275 454400 0) 0 nil]) 47 | ([nil nil ((" 48 | " . 2058)) nil (25850 4275 454399 0) 0 nil]) 49 | ([nil nil ((" matrix:" . 2058) (undo-tree-id44 . -13) (undo-tree-id45 . -13)) nil (25850 4275 454399 0) 0 nil]) 50 | ([nil nil ((" 51 | " . 2058)) nil (25850 4275 454397 0) 0 nil]) 52 | ([nil nil ((" os: [ubuntu-latest, macos-latest, windows-latest]" . 2058)) nil (25850 4275 454396 0) 0 nil]) 53 | ([nil nil ((" 54 | " . 2058)) nil (25850 4275 454396 0) 0 nil]) 55 | ([nil nil ((" ghc: ['8.10', '9.0', '9.2', '9.4', '9.6']" . 2058) (undo-tree-id42 . -17) (undo-tree-id43 . -17)) nil (25850 4275 454395 0) 0 nil]) 56 | ([nil nil ((" 57 | " . 2058)) nil (25850 4275 454394 0) 0 nil]) 58 | ([nil nil ((" steps:" . 2058)) nil (25850 4275 454393 0) 0 nil]) 59 | ([nil nil ((" 60 | " . 2058)) nil (25850 4275 454392 0) 0 nil]) 61 | ([nil nil ((" - name: Checkout base repo" . 2058)) nil (25850 4275 454392 0) 0 nil]) 62 | ([nil nil ((" 63 | " . 2058)) nil (25850 4275 454391 0) 0 nil]) 64 | ([nil nil ((" uses: actions/checkout@v3.1.0" . 2058)) nil (25850 4275 454390 0) 0 nil]) 65 | ([nil nil ((" 66 | " . 2058)) nil (25850 4275 454390 0) 0 nil]) 67 | ([nil nil ((" - name: Set up Haskell" . 2058)) nil (25850 4275 454389 0) 0 nil]) 68 | ([nil nil ((" 69 | " . 2058)) nil (25850 4275 454388 0) 0 nil]) 70 | ([nil nil ((" id: setup-haskell" . 2058) (undo-tree-id38 . -25) (undo-tree-id39 . -25) (undo-tree-id40 . -25) (undo-tree-id41 . -25)) nil (25850 4275 454387 0) 0 nil]) 71 | ([nil nil ((" 72 | " . 2058)) nil (25850 4275 454379 0) 0 nil]) 73 | ([nil nil ((" uses: haskell/actions/setup@v2" . 2058)) nil (25850 4275 454378 0) 0 nil]) 74 | ([nil nil ((" 75 | " . 2058)) nil (25850 4275 454378 0) 0 nil]) 76 | ([nil nil ((" with:" . 2058)) nil (25850 4275 454377 0) 0 nil]) 77 | ([nil nil ((" 78 | " . 2058)) nil (25850 4275 454377 0) 0 nil]) 79 | ([nil nil ((" ghc-version: ${{ matrix.ghc }}" . 2058)) nil (25850 4275 454376 0) 0 nil]) 80 | ([nil nil ((" 81 | " . 2058)) nil (25850 4275 454375 0) 0 nil]) 82 | ([nil nil ((" cabal-version: 'latest'" . 2058)) nil (25850 4275 454375 0) 0 nil]) 83 | ([nil nil ((" 84 | " . 2058)) nil (25850 4275 454374 0) 0 nil]) 85 | ([nil nil ((" - name: Configure" . 2058)) nil (25850 4275 454373 0) 0 nil]) 86 | ([nil nil ((" 87 | " . 2058)) nil (25850 4275 454372 0) 0 nil]) 88 | ([nil nil ((" run: cabal new-configure --enable-tests" . 2058)) nil (25850 4275 454371 0) 0 nil]) 89 | ([nil nil ((" 90 | " . 2058)) nil (25850 4275 454371 0) 0 nil]) 91 | ([nil nil ((" - name: Freeze" . 2058)) nil (25850 4275 454370 0) 0 nil]) 92 | ([nil nil ((" 93 | " . 2058)) nil (25850 4275 454369 0) 0 nil]) 94 | ([nil nil ((" run: cabal freeze" . 2058)) nil (25850 4275 454369 0) 0 nil]) 95 | ([nil nil ((" 96 | " . 2058)) nil (25850 4275 454368 0) 0 nil]) 97 | ([nil nil ((" - name: Cache" . 2058)) nil (25850 4275 454367 0) 0 nil]) 98 | ([nil nil ((" 99 | " . 2058)) nil (25850 4275 454366 0) 0 nil]) 100 | ([nil nil ((" uses: actions/cache@v3.2.1" . 2058)) nil (25850 4275 454360 0) 0 nil]) 101 | ([nil current (("nonempty-vector" . -1392) (1407 . 1412) ("nonempty-vector" . -1309) (1324 . 1329) ("nonempty-vector" . -1133) (1148 . 1153) ("nonempty-vector" . -1104) (1119 . 1124) ("nonempty-vector" . -1078) (t 25850 4275 456113 134000) (1093 . 1098) 13 (t 25850 4275 456113 134000)) nil (25850 4290 387242 0) 0 nil]) 102 | ([nil nil (("-" . -1314) (undo-tree-id46 . -1) (undo-tree-id47 . -1) (undo-tree-id48 . -1) (undo-tree-id49 . -1) (undo-tree-id50 . -1) (undo-tree-id51 . -1) (undo-tree-id52 . -1) (undo-tree-id53 . -1) (undo-tree-id54 . -1) (undo-tree-id55 . -1) (undo-tree-id56 . -1) (undo-tree-id57 . -1) (undo-tree-id58 . -1) (undo-tree-id59 . -1) (undo-tree-id60 . -1) (undo-tree-id61 . -1) (undo-tree-id62 . -1) (undo-tree-id63 . -1) (undo-tree-id64 . -1) (undo-tree-id65 . -1) (undo-tree-id66 . -1) (undo-tree-id67 . -1) (undo-tree-id68 . -1) (undo-tree-id69 . -1) (undo-tree-id70 . -1) (undo-tree-id71 . -1) (undo-tree-id72 . -1) 1315 (t 25850 4284 398968 711000)) ((1314 . 1315) (t 25850 4288 933725 216000)) (25850 4288 932196 0) 0 nil]) 103 | nil 104 | -------------------------------------------------------------------------------- /src/Data/Order/Bounded.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE PolyKinds #-} 8 | {-# LANGUAGE StandaloneDeriving #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE Trustworthy #-} 11 | -- | 12 | -- Module : Data.Order.Bounded 13 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 14 | -- License : BSD-style 15 | -- 16 | -- Maintainer : Emily Pillmore , 17 | -- Davean Scies , 18 | -- 19 | -- Stability : stable 20 | -- Portability : non-portable 21 | -- 22 | -- This module contains definitions for 'Infimum', the class of 23 | -- greatest lower bounds, and 'Superemum', the class of least 24 | -- upper bounds. 25 | -- 26 | module Data.Order.Bounded 27 | ( -- * Least upper bounds 28 | Supremum(..) 29 | -- * Greatest lower bounds 30 | , Infimum(..) 31 | )where 32 | 33 | import Control.Applicative 34 | import Control.Monad.ST 35 | 36 | import qualified Data.Functor.Contravariant as Functor 37 | import qualified Data.Functor.Identity as Functor 38 | import Data.Function (fix) 39 | import Data.Int 40 | import qualified Data.IntMap as IntMap 41 | import qualified Data.IntSet as IntSet 42 | import qualified Data.Map as Map 43 | import qualified Data.Monoid as Monoid 44 | import Data.Ord (Down(..)) 45 | import Data.Proxy 46 | import Data.Semigroup 47 | import qualified Data.Set as Set 48 | import Data.Void 49 | import Data.Word 50 | 51 | import GHC.Generics 52 | 53 | import Numeric.Natural 54 | 55 | import GHC.Event 56 | import GHC.Tuple 57 | 58 | 59 | 60 | -- | Infimum, also known as a "greatest lower bound", represents 61 | -- the largest element of an ordered set that is also smaller than 62 | -- all other inhabitants. 63 | -- 64 | -- The default instance is selected to coencode with the Monoid 65 | -- so that our BoundedJoin semilattices also coencide by default. 66 | class Infimum a where 67 | inf :: a 68 | default inf :: Monoid a => a 69 | inf = mempty 70 | 71 | -- | Supremum, also known as a "least upper bound", represents 72 | -- the smallest element of an ordered set that is also larger than 73 | -- all other inhabitants. 74 | -- 75 | class Supremum a where 76 | sup :: a 77 | default sup :: Bounded a => a 78 | sup = maxBound 79 | 80 | instance Infimum Ordering where 81 | inf = minBound 82 | instance Supremum Ordering where 83 | sup = maxBound 84 | 85 | instance Infimum Any 86 | instance Supremum Any 87 | 88 | instance Infimum All 89 | instance Supremum All 90 | 91 | 92 | instance Infimum Lifetime 93 | instance Supremum Lifetime where 94 | sup = MultiShot 95 | 96 | instance Infimum Event 97 | 98 | instance Infimum a => Infimum (Solo a) where 99 | inf = MkSolo inf 100 | instance Supremum a => Supremum (Solo a) where 101 | sup = MkSolo sup 102 | 103 | instance Infimum [a] 104 | 105 | instance Infimum a => Infimum (IO a) where 106 | inf = pure inf 107 | instance Supremum a => Supremum (IO a) where 108 | sup = pure sup 109 | 110 | instance Infimum a => Infimum (ST s a) where 111 | inf = pure inf 112 | instance Supremum a => Supremum (ST s a) where 113 | sup = pure sup 114 | 115 | deriving newtype instance Infimum a => Infimum (Par1 a) 116 | deriving newtype instance Supremum a => Supremum (Par1 a) 117 | 118 | instance Supremum a => Infimum (Down a) where 119 | inf = Down sup 120 | instance Infimum a => Supremum (Down a) where 121 | sup = Down inf 122 | 123 | deriving newtype instance Infimum a => Infimum (First a) 124 | 125 | deriving newtype instance Supremum a => Supremum (Last a) 126 | 127 | deriving newtype instance Infimum a => Infimum (Functor.Identity a) 128 | deriving newtype instance Supremum a => Supremum (Functor.Identity a) 129 | 130 | deriving newtype instance Infimum a => Infimum (Max a) 131 | deriving newtype instance Supremum a => Supremum (Max a) 132 | 133 | deriving newtype instance Infimum a => Infimum (Min a) 134 | deriving newtype instance Supremum a => Supremum (Min a) 135 | 136 | instance Infimum (Functor.Equivalence a) 137 | instance Infimum (Functor.Comparison a) 138 | instance Infimum (Functor.Predicate a) 139 | 140 | instance Infimum b => Infimum (a -> b) where 141 | inf = const inf 142 | instance Supremum b => Supremum (a -> b) where 143 | sup = const sup 144 | 145 | instance Infimum () 146 | instance Supremum () 147 | 148 | instance Infimum Bool where 149 | inf = minBound 150 | instance Supremum Bool 151 | 152 | instance Infimum a => Infimum (Proxy a) 153 | instance Supremum a => Supremum (Proxy a) 154 | 155 | instance Infimum Void where 156 | inf = fix absurd 157 | instance Supremum Void where 158 | sup = fix absurd 159 | 160 | deriving instance Infimum a => Infimum (Functor.Op a b) 161 | 162 | deriving instance Infimum (f p) => Infimum (Rec1 f p) 163 | deriving instance Supremum (f p) => Supremum (Rec1 f p) 164 | 165 | instance Alternative f => Infimum (Monoid.Alt f a) 166 | instance (Alternative f, Monoid a) => Infimum (Monoid.Ap f a) 167 | 168 | deriving instance Infimum a => Infimum (Const a b) 169 | deriving instance Supremum a => Supremum (Const a b) 170 | 171 | deriving instance Infimum c => Infimum (K1 i c p) 172 | deriving instance Supremum c => Supremum (K1 i c p) 173 | 174 | instance (Infimum (f p), Infimum (g p)) => Infimum ((f :*: g) p) where 175 | inf = inf :*: inf 176 | instance (Supremum (f p), Supremum (g p)) => Supremum ((f :*: g) p) where 177 | sup = sup :*: sup 178 | 179 | deriving instance Infimum (f (g p)) => Infimum ((f :.: g) p) 180 | deriving instance Supremum (f (g p)) => Supremum ((f :.: g) p) 181 | 182 | deriving instance Infimum (f p) => Infimum (M1 i c f p) 183 | 184 | instance (Infimum a, Infimum b) => Infimum (a, b) where 185 | inf = (inf, inf) 186 | instance (Supremum a, Supremum b) => Supremum (a, b) where 187 | sup = (sup, sup) 188 | 189 | instance (Infimum a, Infimum b, Infimum c) => Infimum (a, b, c) where 190 | inf = (inf, inf, inf) 191 | instance (Supremum a, Supremum b, Supremum c) => Supremum (a,b, c) where 192 | sup = (sup, sup, sup) 193 | 194 | instance (Infimum a, Infimum b, Infimum c, Infimum d) => Infimum (a, b, c, d) where 195 | inf = (inf, inf, inf, inf) 196 | instance (Supremum a, Supremum b, Supremum c, Supremum d) => Supremum (a, b, c, d) where 197 | sup = (sup, sup, sup, sup) 198 | 199 | instance (Infimum a, Infimum b, Infimum c, Infimum d, Infimum e) => Infimum (a, b, c, d, e) where 200 | inf = (inf, inf, inf, inf, inf) 201 | instance (Supremum a, Supremum b, Supremum c, Supremum d, Supremum e) => Supremum (a, b, c, d, e) where 202 | sup = (sup, sup, sup, sup, sup) 203 | 204 | instance Infimum (Maybe a) where 205 | inf = Nothing 206 | instance Supremum a => Supremum (Maybe a) where 207 | sup = Just sup 208 | 209 | instance Ord a => Infimum (Set.Set a) 210 | 211 | instance Infimum IntSet.IntSet 212 | 213 | instance Infimum (IntMap.IntMap v) 214 | 215 | instance Ord k => Infimum (Map.Map k v) 216 | 217 | instance Infimum Natural where 218 | inf = 0 219 | 220 | instance Infimum Char where 221 | inf = minBound 222 | instance Supremum Char where 223 | sup = maxBound 224 | 225 | instance Infimum Int where 226 | inf = minBound 227 | instance Supremum Int where 228 | sup = maxBound 229 | instance Infimum Int8 where 230 | inf = minBound 231 | instance Supremum Int8 where 232 | sup = maxBound 233 | instance Infimum Int16 where 234 | inf = minBound 235 | instance Supremum Int16 where 236 | sup = maxBound 237 | instance Infimum Int32 where 238 | inf = minBound 239 | instance Supremum Int32 where 240 | sup = maxBound 241 | instance Infimum Int64 where 242 | inf = minBound 243 | instance Supremum Int64 where 244 | sup = maxBound 245 | 246 | instance Infimum Word where 247 | inf = minBound 248 | instance Supremum Word where 249 | sup = maxBound 250 | instance Infimum Word8 where 251 | inf = minBound 252 | instance Supremum Word8 where 253 | sup = maxBound 254 | instance Infimum Word16 where 255 | inf = minBound 256 | instance Supremum Word16 where 257 | sup = maxBound 258 | instance Infimum Word32 where 259 | inf = minBound 260 | instance Supremum Word32 where 261 | sup = maxBound 262 | instance Infimum Word64 where 263 | inf = minBound 264 | instance Supremum Word64 where 265 | sup = maxBound 266 | -------------------------------------------------------------------------------- /src/Data/Semilattice.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE DeriveAnyClass #-} 7 | {-# LANGUAGE DeriveFoldable #-} 8 | {-# LANGUAGE DeriveTraversable #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | {-# LANGUAGE DeriveGeneric #-} 11 | {-# LANGUAGE DeriveDataTypeable #-} 12 | -- | 13 | -- Module : Data.Semilattice 14 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 15 | -- License : BSD-style 16 | -- 17 | -- Maintainer : Emily Pillmore , 18 | -- Davean Scies , 19 | -- Siddharth Bhat 20 | -- Stability : stable 21 | -- Portability : non-portable 22 | -- 23 | -- This module contains definitions for 'Join' and 'Meet' semilattices, 24 | -- along with their bounded variants, and associated combinators. 25 | -- 26 | module Data.Semilattice 27 | ( -- * Join semilattices 28 | Join(..) 29 | , Joins(..) 30 | , (\/) 31 | , (∨) 32 | -- ** Bounded join semilattices 33 | , BoundedJoin 34 | , bottom 35 | , (⊥) 36 | -- * Meet semilattices 37 | , Meet(..) 38 | , Meets(..) 39 | , (/\) 40 | , (∧) 41 | -- ** Bounded meet semilattices 42 | , BoundedMeet 43 | , top 44 | , (⊤) 45 | ) where 46 | 47 | import Control.Applicative 48 | import Control.Monad (liftM2) 49 | import Control.Monad.Fix 50 | import Control.Monad.Zip 51 | import Data.Bits 52 | import Data.Data 53 | import Data.Functor.Classes 54 | import qualified Data.Set as Set 55 | import qualified Data.IntSet as IntSet 56 | import Data.Ix 57 | import Data.List.NonEmpty (NonEmpty) 58 | import qualified Data.Map as Map 59 | import qualified Data.IntMap as IntMap 60 | import qualified Data.Monoid as Monoid 61 | import Data.Ord 62 | import Data.Order.Bounded 63 | import Data.Order.Pre 64 | import Data.Order.Partial 65 | import Data.Set 66 | import Data.Void 67 | import Foreign.Storable 68 | import GHC.Generics 69 | import Data.IntSet 70 | 71 | import GHC.Event 72 | import GHC.Tuple 73 | 74 | -- -------------------------------------------------------------------- -- 75 | -- Join Semilattices 76 | 77 | -- | A join-semilattice is a 'Poset' with an associative, idempotent, and 78 | -- commutative binary operation called @join@. 79 | -- 80 | -- Laws: 81 | -- 82 | -- [Associative] @a '∨' (b '∨' c) = (a '∨' b) '∨' c@ 83 | -- [Idempotent] @a '∨' a = a@ 84 | -- [Commutative] @a '∨' b = b '∨' a@ 85 | -- [Non-decreasing] @a <= a '∨' b@ 86 | -- 87 | -- Alternatively, one can view a join semilattice as a commutative 88 | -- 'Band' with respect to its 'join' operation. 89 | -- 90 | class Join a where 91 | -- | The join operation of a join-semilattice. 92 | -- 93 | join :: a -> a -> a 94 | default join :: Semigroup a => a -> a -> a 95 | join = (<>) 96 | {-# minimal join #-} 97 | 98 | -- | A infix alias for 'join' 99 | -- 100 | (\/) :: Join a => a -> a -> a 101 | (\/) = join 102 | infixr 6 \/ 103 | 104 | -- | An infix unicode alias for 'join' 105 | -- 106 | (∨) :: Join a => a -> a -> a 107 | (∨) = join 108 | infixr 6 ∨ 109 | 110 | -- | A bounded join-semilattice is a join-semilattice that is bounded, 111 | -- meaning that it admits a greatest lower bound (also known as a 112 | -- bottom element, infimum), which is a unit for the 'join' operation. 113 | -- 114 | -- Laws: 115 | -- 116 | -- [Two-sided unital element] @a '∨' '⊥' = '⊥' '∨' a = a@ 117 | -- 118 | class (Infimum a, Join a) => BoundedJoin a where 119 | 120 | -- | An alias for the bottom element of a 'BoundedJoin' semilattice. 121 | -- 122 | bottom :: BoundedJoin a => a 123 | bottom = inf 124 | 125 | -- | A unicode alias for the bottom element of a 126 | -- 'BoundedJoin' semilattice. 127 | -- 128 | (⊥) :: BoundedJoin a => a 129 | (⊥) = bottom 130 | 131 | -- | Newtype wrapper yielding the underlying 'Semigroup' 132 | -- and 'Monoid' instances for instances of 'Join'. 133 | -- 134 | newtype Joins a 135 | = Joins { unJoin :: a } 136 | deriving 137 | ( Read, Show, Eq, Ord 138 | , Functor, Foldable, Traversable 139 | , Generic, Generic1, Typeable, Data 140 | ) 141 | deriving anyclass (PreOrd, PartialOrd) 142 | deriving newtype 143 | ( Floating, Fractional, Num, Real, RealFloat, RealFrac 144 | , Ix, FiniteBits, Bits 145 | , Storable, Bounded, Enum 146 | ) 147 | 148 | instance Join a => Semigroup (Joins a) where 149 | Joins a <> Joins b = Joins (a \/ b) 150 | 151 | instance BoundedJoin a => Monoid (Joins a) where 152 | mempty = Joins bottom 153 | 154 | instance Applicative Joins where 155 | pure = Joins 156 | (Joins f) <*> (Joins v) = Joins (f v) 157 | 158 | instance Monad Joins where 159 | Joins a >>= k = k a 160 | 161 | instance MonadFix Joins where 162 | mfix f = Joins (fix (unJoin . f)) 163 | 164 | instance MonadZip Joins where 165 | mzipWith = liftM2 166 | 167 | instance Eq1 Joins where 168 | liftEq eq (Joins x) (Joins y) = eq x y 169 | 170 | instance Ord1 Joins where 171 | liftCompare comp (Joins x) (Joins y) = comp x y 172 | 173 | instance Read1 Joins where 174 | liftReadsPrec rp _ = readsData $ readsUnaryWith rp "Joins" Joins 175 | 176 | instance Show1 Joins where 177 | liftShowsPrec sp _ d (Joins x) = showsUnaryWith sp "Joins" d x 178 | 179 | -- -------------------------------------------------------------------- -- 180 | -- Meet Semilattices 181 | 182 | -- | A meet-semilattice is a 'Poset' with an associative, idempotent, and 183 | -- commutative operator called @meet@. 184 | -- 185 | -- Laws: 186 | -- 187 | -- [Associative] @a '∧' (b '∧' c) = (a '∧' b) '∧' c@ 188 | -- [Idempotent] @a '∧' a = a@ 189 | -- [Commutative] @a '∧' b = b '∧' a@ 190 | -- [Non-increasing] @a '∧' b '<=' a@ 191 | -- 192 | -- Alternatively, one can view a meet semilattice as a commutative 'Band' with 193 | -- respect to its 'meet' operation. 194 | -- 195 | class Meet a where 196 | -- | The meet operation of a meet-semilattice. 197 | -- 198 | meet :: a -> a -> a 199 | default meet :: Semigroup a => a -> a -> a 200 | meet = (<>) 201 | {-# minimal meet #-} 202 | 203 | -- | A infix alias for 'meet' 204 | -- 205 | (/\) :: Meet a => a -> a -> a 206 | (/\) = meet 207 | infixr 7 /\\ 208 | 209 | -- | A unicode infix alias for 'meet' 210 | -- 211 | (∧) :: Meet a => a -> a -> a 212 | (∧) = meet 213 | infixr 7 ∧ 214 | 215 | -- | A bounded meet-semilattice is a meet-semilattice that is bounded, 216 | -- meaning that it admits a least upper bound (also known as a 217 | -- top element, supremum), which is a unit for the 'meet' operation. 218 | -- 219 | -- Laws: 220 | -- 221 | -- [Two-sided unital element] @a '∧' '⊤' = '⊤' '∧' a = a@ 222 | -- 223 | class (Supremum a, Meet a) => BoundedMeet a where 224 | 225 | 226 | -- | An alias for the top element of a 'BoundedMeet' semilattice. 227 | -- 228 | top :: BoundedMeet a => a 229 | top = sup 230 | 231 | -- | A unicode alias for the top element of a 'BoundedMeet' 232 | -- semilattice. 233 | -- 234 | (⊤) :: BoundedMeet a => a 235 | (⊤) = top 236 | 237 | -- | Newtype wrapper yielding the underlying 'Semigroup' 238 | -- and 'Monoid' instances for instances of 'Meet'. 239 | -- 240 | newtype Meets a 241 | = Meets { unMeet :: a } 242 | deriving 243 | ( Read, Show, Eq, Ord 244 | , Functor, Foldable, Traversable 245 | , Generic, Generic1, Typeable, Data 246 | ) 247 | deriving anyclass (PreOrd, PartialOrd) 248 | deriving newtype 249 | ( Floating, Fractional, Num, Real, RealFloat, RealFrac 250 | , Ix, FiniteBits, Bits 251 | , Storable, Bounded, Enum 252 | ) 253 | 254 | instance Meet a => Semigroup (Meets a) where 255 | Meets a <> Meets b = Meets (a /\ b) 256 | 257 | instance BoundedMeet a => Monoid (Meets a) where 258 | mempty = Meets top 259 | 260 | instance Applicative Meets where 261 | pure = Meets 262 | (Meets f) <*> (Meets v) = Meets (f v) 263 | 264 | instance Monad Meets where 265 | Meets a >>= k = k a 266 | 267 | instance MonadFix Meets where 268 | mfix f = Meets (fix (unMeet . f)) 269 | 270 | instance MonadZip Meets where 271 | mzipWith = liftM2 272 | 273 | instance Eq1 Meets where 274 | liftEq eq (Meets x) (Meets y) = eq x y 275 | 276 | instance Ord1 Meets where 277 | liftCompare comp (Meets x) (Meets y) = comp x y 278 | 279 | instance Read1 Meets where 280 | liftReadsPrec rp _ = readsData $ readsUnaryWith rp "Meet" Meets 281 | 282 | instance Show1 Meets where 283 | liftShowsPrec sp _ d (Meets x) = showsUnaryWith sp "Meet" d x 284 | 285 | instance Join Void where 286 | join = const 287 | 288 | instance BoundedJoin Void 289 | 290 | instance Meet Void where 291 | meet = const 292 | 293 | instance BoundedMeet Void 294 | 295 | instance Join () where 296 | join _ _ = () 297 | 298 | instance BoundedJoin () 299 | 300 | instance Meet () where 301 | meet _ _ = () 302 | 303 | instance BoundedMeet () 304 | 305 | instance Join Bool where 306 | join = (||) 307 | 308 | instance BoundedJoin Bool 309 | 310 | instance Meet Bool where 311 | meet = (&&) 312 | 313 | instance BoundedMeet Bool 314 | 315 | instance Join Ordering where 316 | join LT a = a 317 | join EQ LT = EQ 318 | join EQ a = a 319 | join GT _ = GT 320 | instance BoundedJoin Ordering 321 | instance Meet Ordering where 322 | meet GT a = a 323 | meet EQ GT = EQ 324 | meet EQ a = a 325 | meet LT _ = LT 326 | instance BoundedMeet Ordering 327 | 328 | deriving newtype instance Join Monoid.Any 329 | instance Meet Monoid.Any where 330 | meet (Monoid.Any a) (Monoid.Any b) = Monoid.Any (a && b) 331 | instance BoundedJoin Monoid.Any 332 | instance BoundedMeet Monoid.Any 333 | 334 | deriving newtype instance Join Monoid.All 335 | instance Meet Monoid.All where 336 | meet (Monoid.All a) (Monoid.All b) = Monoid.All (a || b) 337 | instance BoundedJoin Monoid.All 338 | instance BoundedMeet Monoid.All 339 | 340 | #if (MIN_VERSION_base(4,15,0)) 341 | #ifndef mingw32_HOST_OS 342 | instance Join Lifetime where 343 | join = (<>) 344 | instance BoundedJoin Lifetime 345 | instance Meet Lifetime where 346 | meet MultiShot MultiShot = MultiShot 347 | meet _ _ = OneShot 348 | instance BoundedMeet Lifetime 349 | 350 | instance Join Event where 351 | join = (<>) 352 | instance BoundedJoin Event 353 | #endif 354 | #endif 355 | 356 | deriving newtype instance Join a => Join (Par1 a) 357 | 358 | instance (Join a, Infimum a) => BoundedJoin (Par1 a) 359 | 360 | instance Join (NonEmpty a) where 361 | join = (<>) 362 | 363 | instance Meet a => Join (Down a) where 364 | join (Down a) (Down b) = Down (meet a b) 365 | 366 | instance (Meet a, Supremum a) => BoundedJoin (Down a) 367 | 368 | instance Join a => Meet (Down a) where 369 | meet (Down a) (Down b) = Down (join a b) 370 | 371 | instance (Join a, Infimum a) => BoundedMeet (Down a) 372 | 373 | instance Ord a => Join (Set a) where 374 | join = Set.union 375 | 376 | instance Ord a => BoundedJoin (Set a) 377 | 378 | instance Ord a => Meet (Set a) where 379 | meet = Set.intersection 380 | 381 | instance Join IntSet.IntSet where 382 | join = IntSet.union 383 | 384 | instance BoundedJoin IntSet.IntSet 385 | 386 | instance Meet IntSet.IntSet where 387 | meet = IntSet.intersection 388 | 389 | instance Join v => Join (IntMap.IntMap v) where 390 | join = IntMap.unionWith join 391 | 392 | instance Join v => BoundedJoin (IntMap.IntMap v) 393 | 394 | instance Meet v => Meet (IntMap.IntMap v) where 395 | meet = IntMap.intersectionWith meet 396 | 397 | instance (Ord k, Join v) => Join (Map.Map k v) where 398 | join = Map.unionWith join 399 | 400 | instance (Ord k, Join v) => BoundedJoin (Map.Map k v) 401 | 402 | instance (Ord k, Meet v) => Meet (Map.Map k v) where 403 | meet = Map.intersectionWith meet 404 | 405 | instance Join a => Join (Maybe a) where 406 | join = liftA2 join 407 | 408 | instance Join a => BoundedJoin (Maybe a) 409 | 410 | instance Meet a => Meet (Maybe a) where 411 | meet = liftA2 meet 412 | 413 | instance BoundedMeet a => BoundedMeet (Maybe a) 414 | 415 | instance (Join a) => Join (Solo a) where 416 | join (MkSolo a1) (MkSolo a2) = MkSolo (join a1 a2) 417 | 418 | instance (Meet a) => Meet (Solo a) where 419 | meet (MkSolo a1) (MkSolo a2) = MkSolo (meet a1 a2) 420 | 421 | instance (Join a, Join b) => Join (a,b) where 422 | join (a1,b1) (a2,b2) = (join a1 a2, join b1 b2) 423 | 424 | instance (Meet a, Meet b) => Meet (a,b) where 425 | meet (a1,b1) (a2,b2) = (meet a1 a2, meet b1 b2) 426 | 427 | instance (Join a, Join b, Join c) => Join (a,b,c) where 428 | join (a1,b1,c1) (a2,b2,c2) = (join a1 a2, join b1 b2, join c1 c2) 429 | 430 | instance (Meet a, Meet b, Meet c) => Meet (a,b,c) where 431 | meet (a1,b1,c1) (a2,b2,c2) = (meet a1 a2, meet b1 b2, meet c1 c2) 432 | 433 | instance (Join a, Join b, Join c, Join d) => Join (a,b,c,d) where 434 | join (a1,b1,c1,d1) (a2,b2,c2,d2) = (join a1 a2, join b1 b2, join c1 c2, join d1 d2) 435 | 436 | instance (Meet a, Meet b, Meet c, Meet d) => Meet (a,b,c,d) where 437 | meet (a1,b1,c1,d1) (a2,b2,c2,d2) = (meet a1 a2, meet b1 b2, meet c1 c2, meet d1 d2) 438 | 439 | instance (Join a, Join b, Join c, Join d, Join e) => Join (a,b,c,d,e) where 440 | join (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = (join a1 a2, join b1 b2, join c1 c2, join d1 d2, join e1 e2) 441 | 442 | instance (Meet a, Meet b, Meet c, Meet d, Meet e) => Meet (a,b,c,d,e) where 443 | meet (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = (meet a1 a2, meet b1 b2, meet c1 c2, meet d1 d2, meet e1 e2) 444 | 445 | instance (BoundedMeet a, BoundedMeet b) => BoundedMeet (a,b) 446 | instance (BoundedMeet a, BoundedMeet b, BoundedMeet c) => BoundedMeet (a,b,c) 447 | instance (BoundedMeet a, BoundedMeet b, BoundedMeet c, BoundedMeet d) => BoundedMeet (a,b,c,d) 448 | instance (BoundedMeet a, BoundedMeet b, BoundedMeet c, BoundedMeet d, BoundedMeet e) => BoundedMeet (a,b,c,d,e) 449 | 450 | instance (BoundedJoin a, BoundedJoin b) => BoundedJoin (a,b) 451 | instance (BoundedJoin a, BoundedJoin b, BoundedJoin c) => BoundedJoin (a,b,c) 452 | instance (BoundedJoin a, BoundedJoin b, BoundedJoin c, BoundedJoin d) => BoundedJoin (a,b,c,d) 453 | instance (BoundedJoin a, BoundedJoin b, BoundedJoin c, BoundedJoin d, BoundedJoin e) => BoundedJoin (a,b,c,d,e) 454 | -------------------------------------------------------------------------------- /src/Data/Order/Pre.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE DerivingVia #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE KindSignatures #-} 8 | {-# LANGUAGE MultiWayIf #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE StandaloneDeriving #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE Trustworthy #-} 13 | -- | 14 | -- Module : Data.Order.Pre 15 | -- Copyright : (c) 2020-2023 Emily Pillmore, Davean Scies 16 | -- License : BSD-style 17 | -- 18 | -- Maintainer : Emily Pillmore , 19 | -- Davean Scies , 20 | -- Siddharth Bhat 21 | -- Stability : stable 22 | -- Portability : non-portable 23 | -- 24 | -- This module contains definitions for 'PreOrd', the class 25 | -- of types that form a preorder. 26 | -- 27 | module Data.Order.Pre 28 | ( -- * Preorders 29 | PreOrd(..) 30 | , geq 31 | , (>=) 32 | , (≧) 33 | , (<=) 34 | , (≦) 35 | -- * Lifted classes 36 | , PreOrd1(..) 37 | ) where 38 | 39 | import Prelude hiding ((<=), (>=)) 40 | 41 | import Control.Applicative 42 | import Control.Concurrent 43 | import Control.Exception 44 | 45 | import Data.Array 46 | import Data.Char 47 | import Data.Fixed 48 | import Data.Foldable 49 | import qualified Data.Functor.Compose as Functor 50 | import qualified Data.Functor.Const as Functor 51 | import qualified Data.Functor.Identity as Functor 52 | import qualified Data.Functor.Product as Functor 53 | import qualified Data.Functor.Sum as Functor 54 | import Data.Int 55 | import qualified Data.IntMap as IntMap 56 | import qualified Data.IntSet as IntSet 57 | import Data.List.NonEmpty (NonEmpty((:|))) 58 | import qualified Data.Map as Map 59 | import qualified Data.Monoid as Monoid 60 | import Data.Ord (Down(..)) 61 | import qualified Data.Ord as Ord 62 | import Data.Proxy 63 | import Data.Ratio 64 | import Data.Semigroup 65 | import qualified Data.Set as Set 66 | import Data.Type.Coercion 67 | import Data.Type.Equality 68 | import Data.Unique 69 | import Data.Version 70 | import Data.Void 71 | import Data.Word 72 | 73 | import Foreign.C.Types 74 | import Foreign.ForeignPtr 75 | import Foreign.Ptr 76 | 77 | import GHC.ByteOrder 78 | import GHC.Conc 79 | import GHC.Fingerprint.Type 80 | import GHC.Generics 81 | import GHC.TypeLits 82 | 83 | import Numeric.Natural 84 | 85 | import System.Exit 86 | import System.IO 87 | 88 | import System.Posix.Types 89 | 90 | import Type.Reflection 91 | 92 | import GHC.Event 93 | import GHC.Tuple 94 | 95 | 96 | -- | A preordered set (aka a /proset/) is a set with an ordering 97 | -- that is reflexive and transitive. 98 | -- 99 | -- Laws: 100 | -- 101 | -- [Reflexivity] @a '<=' a@ 102 | -- [Transitivity] @a '<=' b and b '<=' c implies a '<=' c 103 | -- 104 | -- These conditions are necessary and sufficient to define a thin category 105 | -- where reflexivity is the identity morphism, and between pairs 106 | -- of elements, there is a single morphism. 107 | -- 108 | -- Pre-orders differ from partial orders in that a pre-orders do not 109 | -- necessarily have to be anti-symmetric: that is, 110 | -- @a '<=' b and b '<=' a@ does not necessarily imply that @a '==' b@. 111 | -- 112 | class PreOrd a where 113 | leq :: a -> a -> Bool 114 | default leq :: Ord a => a -> a -> Bool 115 | leq = (Ord.<=) 116 | 117 | -- | Greater or equal 118 | -- 119 | geq :: PreOrd a => a -> a -> Bool 120 | geq a b = leq b a 121 | 122 | -- | Infix operator alias for 'leq'. 123 | -- 124 | (<=) :: PreOrd a => a -> a -> Bool 125 | (<=) = leq 126 | infix 4 <= 127 | 128 | -- | Unicode infix alias for 'leq'. 129 | -- 130 | (≦) :: PreOrd a => a -> a -> Bool 131 | (≦) = leq 132 | infix 4 ≦ 133 | 134 | -- | Infix operator alias for 'leq'. 135 | -- 136 | (>=) :: PreOrd a => a -> a -> Bool 137 | (>=) = geq 138 | infix 4 >= 139 | 140 | -- | Infix operator alias for 'leq'. 141 | -- 142 | (≧) :: PreOrd a => a -> a -> Bool 143 | (≧) = geq 144 | infix 4 ≧ 145 | 146 | 147 | class PreOrd1 f where 148 | liftLeq :: (a -> b -> Bool) -> f a -> f b -> Bool 149 | 150 | leq1 :: (PreOrd1 f, PreOrd a) => f a -> f a -> Bool 151 | leq1 = liftLeq leq 152 | 153 | instance PreOrd Void 154 | 155 | instance PreOrd () 156 | 157 | instance PreOrd Bool 158 | 159 | instance PreOrd Int 160 | instance PreOrd Int8 161 | instance PreOrd Int16 162 | instance PreOrd Int32 163 | instance PreOrd Int64 164 | instance PreOrd Integer 165 | 166 | instance PreOrd Word 167 | instance PreOrd Word8 168 | instance PreOrd Word16 169 | instance PreOrd Word32 170 | instance PreOrd Natural 171 | 172 | instance PreOrd Char 173 | 174 | instance PreOrd Ordering 175 | 176 | instance PreOrd SomeTypeRep 177 | 178 | instance PreOrd TyCon 179 | 180 | instance PreOrd Version 181 | 182 | instance PreOrd GeneralCategory 183 | 184 | instance PreOrd Fingerprint 185 | 186 | instance PreOrd IOMode 187 | 188 | instance PreOrd SomeNat 189 | 190 | instance PreOrd SomeSymbol 191 | 192 | instance PreOrd IntPtr 193 | instance PreOrd WordPtr 194 | instance PreOrd CUIntPtr 195 | instance PreOrd CIntPtr 196 | instance PreOrd CPtrdiff 197 | instance PreOrd (Ptr a) 198 | instance PreOrd (FunPtr a) 199 | instance PreOrd (ForeignPtr a) 200 | 201 | instance PreOrd CUIntMax 202 | instance PreOrd CIntMax 203 | 204 | instance PreOrd CSUSeconds 205 | instance PreOrd CUSeconds 206 | instance PreOrd CTime 207 | instance PreOrd CClock 208 | 209 | instance PreOrd CSigAtomic 210 | instance PreOrd CWchar 211 | 212 | instance PreOrd CSize 213 | 214 | instance PreOrd CBool 215 | 216 | instance PreOrd CULLong 217 | instance PreOrd CLLong 218 | instance PreOrd CULong 219 | instance PreOrd CLong 220 | instance PreOrd CUInt 221 | instance PreOrd CInt 222 | instance PreOrd CUShort 223 | instance PreOrd CShort 224 | instance PreOrd CUChar 225 | instance PreOrd CSChar 226 | instance PreOrd CChar 227 | 228 | instance PreOrd DecidedStrictness 229 | instance PreOrd SourceStrictness 230 | instance PreOrd SourceUnpackedness 231 | instance PreOrd Associativity 232 | instance PreOrd Fixity 233 | 234 | instance PreOrd Monoid.Any 235 | instance PreOrd Monoid.All 236 | 237 | instance PreOrd ArithException 238 | instance PreOrd ErrorCall 239 | instance PreOrd ArrayException 240 | instance PreOrd AsyncException 241 | 242 | instance PreOrd TimeoutKey 243 | 244 | instance PreOrd SeekMode 245 | instance PreOrd NewlineMode 246 | instance PreOrd Newline 247 | instance PreOrd BufferMode 248 | instance PreOrd ExitCode 249 | instance PreOrd Fd 250 | instance PreOrd CNfds 251 | instance PreOrd CSocklen 252 | 253 | #if defined(HTYPE_TIMER_T) 254 | instance PreOrd CTimer 255 | #endif 256 | 257 | instance PreOrd CKey 258 | instance PreOrd CId 259 | instance PreOrd CFsFilCnt 260 | instance PreOrd CFsBlkCnt 261 | instance PreOrd CClockId 262 | instance PreOrd CBlkSize 263 | instance PreOrd CRLim 264 | instance PreOrd CTcflag 265 | instance PreOrd CSpeed 266 | instance PreOrd CCc 267 | instance PreOrd CUid 268 | instance PreOrd CNlink 269 | instance PreOrd CGid 270 | instance PreOrd CSsize 271 | instance PreOrd CPid 272 | instance PreOrd COff 273 | instance PreOrd CMode 274 | instance PreOrd CIno 275 | instance PreOrd CDev 276 | 277 | instance PreOrd ThreadStatus 278 | instance PreOrd BlockReason 279 | instance PreOrd ThreadId 280 | 281 | instance PreOrd ByteOrder 282 | 283 | instance PreOrd Unique 284 | 285 | instance PreOrd a => PreOrd [a] where 286 | leq = leq1 287 | 288 | instance PreOrd a => PreOrd (Maybe a) where 289 | leq = leq1 290 | 291 | instance Integral a => PreOrd (Ratio a) 292 | 293 | instance PreOrd p => PreOrd (Par1 p) where 294 | leq (Par1 x) (Par1 y) = leq x y 295 | 296 | instance PreOrd a => PreOrd (NonEmpty a) where 297 | leq = leq1 298 | 299 | deriving newtype instance PreOrd a => PreOrd (Monoid.Product a) 300 | deriving newtype instance PreOrd a => PreOrd (Monoid.Sum a) 301 | deriving newtype instance PreOrd a => PreOrd (Monoid.Dual a) 302 | deriving newtype instance PreOrd a => PreOrd (Monoid.Last a) 303 | deriving newtype instance PreOrd a => PreOrd (Monoid.First a) 304 | deriving newtype instance PreOrd a => PreOrd (Functor.Identity a) 305 | deriving newtype instance (Eq a, PreOrd a) => PreOrd (ZipList a) 306 | deriving newtype instance PreOrd m => PreOrd (WrappedMonoid m) 307 | deriving newtype instance PreOrd a => PreOrd (Last a) 308 | deriving newtype instance PreOrd a => PreOrd (First a) 309 | deriving newtype instance PreOrd a => PreOrd (Max a) 310 | deriving newtype instance PreOrd a => PreOrd (Min a) 311 | deriving newtype instance PreOrd a => PreOrd (Functor.Const a b) 312 | deriving newtype instance PreOrd c => PreOrd (K1 i c p) 313 | 314 | instance (PreOrd a, PreOrd b) => PreOrd (Either a b) where 315 | leq (Left _) (Right _) = True 316 | leq (Right _) (Left _) = False 317 | leq (Left x) (Left y) = leq x y 318 | leq (Right x) (Right y) = leq x y 319 | 320 | instance PreOrd (V1 p) 321 | instance PreOrd (U1 p) 322 | instance PreOrd (TypeRep a) 323 | 324 | instance (Ix i, PreOrd i, PreOrd e) => PreOrd (Array i e) where 325 | leq arr1 arr2 = leq (assocs arr1) (assocs arr2) 326 | 327 | instance PreOrd a => PreOrd (Proxy a) 328 | 329 | instance PreOrd a => PreOrd (Arg a b) where 330 | leq (Arg x _) (Arg y _) = leq x y 331 | 332 | instance PreOrd (Fixed a) 333 | deriving newtype instance PreOrd (f p) => PreOrd (Rec1 f p) 334 | instance PreOrd (URec Word p) 335 | instance PreOrd (URec Int p) 336 | instance PreOrd (URec Char p) 337 | instance PreOrd (URec (Ptr ()) p) 338 | instance PreOrd (a :~: b) 339 | instance PreOrd (Coercion a b) 340 | deriving newtype instance PreOrd (f a) => PreOrd (Monoid.Alt f a) 341 | deriving newtype instance PreOrd (f a) => PreOrd (Monoid.Ap f a) 342 | 343 | instance (PreOrd (f p), PreOrd (g p)) => PreOrd ((f :+: g) p) where 344 | leq (L1 _) (R1 _) = True 345 | leq (R1 _) (L1 _) = False 346 | leq (L1 x) (L1 y) = leq x y 347 | leq (R1 x) (R1 y) = leq x y 348 | 349 | instance (PreOrd (f p), PreOrd (g p)) => PreOrd ((f :*: g) p) where 350 | leq (x1 :*: y1) (x2 :*: y2) = leq y1 y2 && leq x1 x2 351 | 352 | instance PreOrd (a :~~: b) 353 | 354 | instance (PreOrd1 f, PreOrd1 g, PreOrd a) => PreOrd (Functor.Sum f g a) where 355 | leq = leq1 356 | 357 | instance (PreOrd1 f, PreOrd1 g, PreOrd a) => PreOrd (Functor.Product f g a) where 358 | leq = leq1 359 | 360 | deriving newtype instance (PreOrd (f p)) => PreOrd (M1 i c f p) 361 | deriving newtype instance (PreOrd (f (g p))) => PreOrd ((f :.: g) p) 362 | 363 | instance (PreOrd1 f, PreOrd1 g, Eq a, PreOrd a) => PreOrd (Functor.Compose f g a) where 364 | leq = leq1 365 | 366 | instance PreOrd1 IntMap.IntMap where 367 | liftLeq cmp m n = liftLeq cmp (toList m) (toList n) 368 | 369 | instance (Eq v, PreOrd v) => PreOrd (IntMap.IntMap v) where 370 | leq m1 m2 = leq (toList m1) (toList m2) 371 | 372 | instance PreOrd1 (Map.Map k) where 373 | liftLeq cmp m n = liftLeq cmp (toList m) (toList n) 374 | 375 | instance (PreOrd k, Eq v, PreOrd v) => PreOrd (Map.Map k v) where 376 | leq m1 m2 = leq (toList m1) (toList m2) 377 | 378 | instance PreOrd IntSet.IntSet 379 | 380 | 381 | instance Ord a => PreOrd (Set.Set a) 382 | 383 | 384 | instance (PreOrd a, PreOrd b) => PreOrd (a, b) where 385 | leq = leq1 386 | 387 | instance (PreOrd a, PreOrd b, PreOrd c) => PreOrd (a, b, c) where 388 | leq (a1, b1, c1) (a2, b2, c2) = leq a1 a2 389 | && leq b1 b2 390 | && leq c1 c2 391 | 392 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d) => PreOrd (a, b, c, d) where 393 | leq (a1, b1, c1, d1) (a2, b2, c2, d2) = leq a1 a2 394 | && leq b1 b2 395 | && leq c1 c2 396 | && leq d1 d2 397 | 398 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e) => PreOrd (a, b, c, d, e) where 399 | leq (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) = leq a1 a2 400 | && leq b1 b2 401 | && leq c1 c2 402 | && leq d1 d2 403 | && leq e1 e2 404 | 405 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f) => PreOrd (a, b, c, d, e, f) where 406 | leq (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) = leq a1 a2 407 | && leq b1 b2 408 | && leq c1 c2 409 | && leq d1 d2 410 | && leq e1 e2 411 | && leq f1 f2 412 | 413 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f, PreOrd g) => 414 | PreOrd (a, b, c, d, e, f, g) where 415 | leq (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) = leq a1 a2 416 | && leq b1 b2 417 | && leq c1 c2 418 | && leq d1 d2 419 | && leq e1 e2 420 | && leq f1 f2 421 | && leq g1 g2 422 | 423 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f, PreOrd g, PreOrd h) => 424 | PreOrd (a, b, c, d, e, f, g, h) where 425 | leq (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) = leq a1 a2 426 | && leq b1 b2 427 | && leq c1 c2 428 | && leq d1 d2 429 | && leq e1 e2 430 | && leq f1 f2 431 | && leq g1 g2 432 | && leq h1 h2 433 | 434 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f, PreOrd g, PreOrd h, PreOrd i) => 435 | PreOrd (a, b, c, d, e, f, g, h, i) where 436 | leq (a1, b1, c1, d1, e1, f1, g1, h1, i1) (a2, b2, c2, d2, e2, f2, g2, h2, i2) = leq a1 a2 437 | && leq b1 b2 438 | && leq c1 c2 439 | && leq d1 d2 440 | && leq e1 e2 441 | && leq f1 f2 442 | && leq g1 g2 443 | && leq h1 h2 444 | && leq i1 i2 445 | 446 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f, PreOrd g, PreOrd h, PreOrd i, PreOrd j) => 447 | PreOrd (a, b, c, d, e, f, g, h, i, j) where 448 | leq (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = leq a1 a2 449 | && leq b1 b2 450 | && leq c1 c2 451 | && leq d1 d2 452 | && leq e1 e2 453 | && leq f1 f2 454 | && leq g1 g2 455 | && leq h1 h2 456 | && leq i1 i2 457 | && leq j1 j2 458 | 459 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f, PreOrd g, PreOrd h, PreOrd i, PreOrd j, PreOrd k) => 460 | PreOrd (a, b, c, d, e, f, g, h, i, j, k) where 461 | leq (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2) = leq a1 a2 462 | && leq b1 b2 463 | && leq c1 c2 464 | && leq d1 d2 465 | && leq e1 e2 466 | && leq f1 f2 467 | && leq g1 g2 468 | && leq h1 h2 469 | && leq i1 i2 470 | && leq j1 j2 471 | && leq k1 k2 472 | 473 | 474 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f, PreOrd g, PreOrd h, PreOrd i, PreOrd j, PreOrd k, PreOrd l) => 475 | PreOrd (a, b, c, d, e, f, g, h, i, j, k, l) where 476 | leq (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2) = leq a1 a2 477 | && leq b1 b2 478 | && leq c1 c2 479 | && leq d1 d2 480 | && leq e1 e2 481 | && leq f1 f2 482 | && leq g1 g2 483 | && leq h1 h2 484 | && leq i1 i2 485 | && leq j1 j2 486 | && leq k1 k2 487 | && leq l1 l2 488 | 489 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f, PreOrd g, PreOrd h, PreOrd i, PreOrd j, PreOrd k, PreOrd l, PreOrd m) => 490 | PreOrd (a, b, c, d, e, f, g, h, i, j, k, l, m) where 491 | leq (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2) = leq a1 a2 492 | && leq b1 b2 493 | && leq c1 c2 494 | && leq d1 d2 495 | && leq e1 e2 496 | && leq f1 f2 497 | && leq g1 g2 498 | && leq h1 h2 499 | && leq i1 i2 500 | && leq j1 j2 501 | && leq k1 k2 502 | && leq l1 l2 503 | && leq m1 m2 504 | 505 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f, PreOrd g, PreOrd h, PreOrd i, PreOrd j, PreOrd k, PreOrd l, PreOrd m, PreOrd n) => 506 | PreOrd (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where 507 | leq (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2) = leq a1 a2 508 | && leq b1 b2 509 | && leq c1 c2 510 | && leq d1 d2 511 | && leq e1 e2 512 | && leq f1 f2 513 | && leq g1 g2 514 | && leq h1 h2 515 | && leq i1 i2 516 | && leq j1 j2 517 | && leq k1 k2 518 | && leq l1 l2 519 | && leq m1 m2 520 | && leq n1 n2 521 | 522 | 523 | 524 | instance (PreOrd a, PreOrd b, PreOrd c, PreOrd d, PreOrd e, PreOrd f, PreOrd g, PreOrd h, PreOrd i, PreOrd j, PreOrd k, PreOrd l, PreOrd m, PreOrd n, PreOrd o) => 525 | PreOrd (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where 526 | leq (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2) = leq a1 a2 527 | && leq b1 b2 528 | && leq c1 c2 529 | && leq d1 d2 530 | && leq e1 e2 531 | && leq f1 f2 532 | && leq g1 g2 533 | && leq h1 h2 534 | && leq i1 i2 535 | && leq j1 j2 536 | && leq k1 k2 537 | && leq l1 l2 538 | && leq m1 m2 539 | && leq n1 n2 540 | && leq o1 o2 541 | 542 | instance PreOrd1 [] where 543 | liftLeq _ [] [] = True 544 | liftLeq _ [] (_:_) = True 545 | liftLeq _ (_:_) [] = False 546 | liftLeq f (x:xs) (y:ys) = f x y && liftLeq f xs ys 547 | 548 | instance PreOrd1 Maybe where 549 | liftLeq _ Nothing _ = True 550 | liftLeq _ _ Nothing = False 551 | liftLeq f (Just x) (Just y) = f x y 552 | 553 | 554 | instance PreOrd a => PreOrd (Solo a) where 555 | leq (MkSolo a) (MkSolo b) = leq a b 556 | instance PreOrd1 Solo where 557 | liftLeq cmp (MkSolo a) (MkSolo b) = cmp a b 558 | 559 | instance PreOrd1 NonEmpty where 560 | liftLeq cmp (x :| xs) (y :| ys) = cmp x y && liftLeq cmp xs ys 561 | 562 | instance PreOrd1 Down where 563 | liftLeq cmp (Down x) (Down y) = cmp x y 564 | 565 | instance PreOrd a => PreOrd1 ((,) a) where 566 | liftLeq f (a,b) (a',b') = leq a a' && f b b' 567 | 568 | instance PreOrd1 Functor.Identity where 569 | liftLeq cmp (Functor.Identity x) (Functor.Identity y) = cmp x y 570 | 571 | instance PreOrd1 Proxy where 572 | liftLeq _ _ _ = True 573 | 574 | instance (PreOrd1 f, PreOrd1 g) => PreOrd1 (Functor.Sum f g) where 575 | liftLeq cmp (Functor.InL x1) (Functor.InL x2) = liftLeq cmp x1 x2 576 | liftLeq _ (Functor.InL _) (Functor.InR _) = True 577 | liftLeq _ (Functor.InR _) (Functor.InL _) = False 578 | liftLeq cmp (Functor.InR y1) (Functor.InR y2) = liftLeq cmp y1 y2 579 | 580 | instance (PreOrd1 f, PreOrd1 g) => PreOrd1 (Functor.Product f g) where 581 | liftLeq cmp (Functor.Pair x1 y1) (Functor.Pair x2 y2) = 582 | liftLeq cmp x1 x2 && liftLeq cmp y1 y2 583 | 584 | instance (PreOrd1 f, PreOrd1 g) => PreOrd1 (Functor.Compose f g) where 585 | liftLeq cmp (Functor.Compose x) (Functor.Compose y) = 586 | liftLeq (liftLeq cmp) x y 587 | 588 | {- These instances maybe want PreOrd2? 589 | 590 | instance PreOrd a => PreOrd1 (Functor.Const a) where 591 | instance (Eq a, PreOrd a) => PreOrd1 (Either a) where 592 | liftLeq _ (Left _) (Right _) = PLT 593 | liftLeq _ (Right _) (Left _) = PFalse 594 | liftLeq _ (Left x) (Left y) = leqLEQ x y 595 | liftLeq cmp (Right x) (Right y) = cmp x y 596 | 597 | -} 598 | --------------------------------------------------------------------------------