├── cabal.project ├── readme.md ├── .gitignore ├── flake.nix ├── partial-semigroup ├── license.txt ├── test │ ├── Test │ │ └── PartialSemigroup │ │ │ └── Hedgehog.hs │ ├── properties.hs │ ├── generics.hs │ └── examples.hs ├── changelog.md ├── partial-semigroup.cabal ├── src │ └── Data │ │ ├── PartialSemigroup │ │ └── Generics.hs │ │ └── PartialSemigroup.hs └── readme.md ├── default.nix ├── nix └── default.nix └── flake.lock /cabal.project: -------------------------------------------------------------------------------- 1 | packages: partial-semigroup 2 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | To build and test with all supported compiler versions: 2 | 3 | nix build .#testConfigurations.all --no-link 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.config 2 | cabal.project.local 3 | cabal.sandbox.config 4 | dist/ 5 | dist-newstyle/ 6 | .cabal-sandbox/ 7 | .stack-work/ 8 | result 9 | result-* 10 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:NixOS/nixpkgs/nixos-24.05"; 4 | flake-utils.url = "github:numtide/flake-utils"; 5 | }; 6 | 7 | outputs = inputs: 8 | inputs.flake-utils.lib.eachDefaultSystem (system: 9 | let 10 | pkgs = import inputs.nixpkgs { inherit system; }; 11 | in 12 | import ./nix { inherit pkgs; } 13 | ); 14 | } 15 | -------------------------------------------------------------------------------- /partial-semigroup/license.txt: -------------------------------------------------------------------------------- 1 | Copyright 2017 Mission Valley Software LLC 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /partial-semigroup/test/Test/PartialSemigroup/Hedgehog.hs: -------------------------------------------------------------------------------- 1 | -- | Utilities for testing partial semigroups using the @hedgehog@ property 2 | -- testing library. 3 | module Test.PartialSemigroup.Hedgehog 4 | ( assoc, 5 | ) 6 | where 7 | 8 | import Data.PartialSemigroup (PartialSemigroup (..)) 9 | import Hedgehog (Gen, Property, forAll, property, (===)) 10 | 11 | -- | The partial semigroup associativity axiom: 12 | -- 13 | -- For all @x@, @y@, @z@: If @x '<>?' y = 'Just' xy@ and @y '<>?' z = 'Just' yz@, 14 | -- then @x '<>?' yz = xy '<>?' z@. 15 | assoc :: (PartialSemigroup a, Eq a, Show a) => Gen a -> Property 16 | assoc gen = property $ do 17 | x <- forAll gen 18 | y <- forAll gen 19 | z <- forAll gen 20 | 21 | sequence_ $ 22 | do 23 | xy <- x <>? y 24 | yz <- y <>? z 25 | 26 | return (x <>? yz === xy <>? z) 27 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let 2 | 3 | sources = import ./nix/sources.nix; 4 | nixos-22-11 = import sources."nixos-22.11" {}; 5 | inherit (nixos-22-11) haskell lib symlinkJoin; 6 | inherit (lib) fold composeExtensions concatMap attrValues; 7 | 8 | combineOverrides = old: 9 | fold composeExtensions (old.overrides or (_: _: { })); 10 | 11 | sourceOverrides = haskell.lib.packageSourceOverrides { 12 | partial-semigroup = ./partial-semigroup; 13 | }; 14 | 15 | depOverrides = new: old: { 16 | # package-name = new.callPackage ./nix/package-name-0.0.0.0.nix {}; 17 | }; 18 | 19 | ghc."9.2" = nixos-22-11.haskell.packages.ghc92.override (old: { 20 | overrides = combineOverrides old [ sourceOverrides depOverrides ]; 21 | }); 22 | 23 | ghc."9.4" = nixos-22-11.haskell.packages.ghc94.override (old: { 24 | overrides = combineOverrides old [ sourceOverrides depOverrides ]; 25 | }); 26 | 27 | in 28 | 29 | symlinkJoin { 30 | name = "partial-semigroup"; 31 | paths = concatMap (x: [x.partial-semigroup]) (attrValues ghc); 32 | } // { 33 | inherit ghc; 34 | pkgs = nixos-22-11; 35 | } 36 | -------------------------------------------------------------------------------- /nix/default.nix: -------------------------------------------------------------------------------- 1 | { pkgs }: 2 | 3 | let 4 | inherit (pkgs.lib) fold composeExtensions concatMap attrValues; 5 | 6 | hls = pkgs.haskell-language-server.override { 7 | supportedGhcVersions = [ "96" ]; 8 | }; 9 | 10 | combineOverrides = old: 11 | fold composeExtensions (old.overrides or (_: _: { })); 12 | 13 | testConfigurations = 14 | let 15 | makeTestConfiguration = { ghcVersion, overrides ? new: old: { } }: 16 | let 17 | inherit (pkgs.haskell.lib) dontCheck packageSourceOverrides; 18 | in 19 | (pkgs.haskell.packages.${ghcVersion}.override (old: { 20 | overrides = 21 | combineOverrides old [ 22 | (packageSourceOverrides { partial-semigroup = ../partial-semigroup; }) 23 | overrides 24 | ]; 25 | })).partial-semigroup; 26 | in 27 | rec { 28 | ghc-9-2 = makeTestConfiguration { 29 | ghcVersion = "ghc92"; 30 | }; 31 | ghc-9-4 = makeTestConfiguration { 32 | ghcVersion = "ghc94"; 33 | }; 34 | ghc-9-6 = makeTestConfiguration { 35 | ghcVersion = "ghc96"; 36 | overrides = new: old: { 37 | # x = new.callPackage ./haskell/x.nix { }; 38 | }; 39 | }; 40 | all = pkgs.symlinkJoin { 41 | name = "partial-semigroup-tests"; 42 | paths = [ ghc-9-2 ghc-9-4 ghc-9-6 ]; 43 | }; 44 | }; 45 | 46 | in 47 | { 48 | 49 | packages = { inherit testConfigurations; }; 50 | 51 | devShells.default = pkgs.mkShell { 52 | inputsFrom = [ testConfigurations.ghc-9-6.env ]; 53 | buildInputs = [ hls pkgs.cabal-install ]; 54 | }; 55 | 56 | } 57 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "inputs": { 5 | "systems": "systems" 6 | }, 7 | "locked": { 8 | "lastModified": 1726560853, 9 | "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", 10 | "owner": "numtide", 11 | "repo": "flake-utils", 12 | "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "numtide", 17 | "repo": "flake-utils", 18 | "type": "github" 19 | } 20 | }, 21 | "nixpkgs": { 22 | "locked": { 23 | "lastModified": 1728328465, 24 | "narHash": "sha256-a0a0M1TmXMK34y3M0cugsmpJ4FJPT/xsblhpiiX1CXo=", 25 | "owner": "NixOS", 26 | "repo": "nixpkgs", 27 | "rev": "1bfbbbe5bbf888d675397c66bfdb275d0b99361c", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "NixOS", 32 | "ref": "nixos-24.05", 33 | "repo": "nixpkgs", 34 | "type": "github" 35 | } 36 | }, 37 | "root": { 38 | "inputs": { 39 | "flake-utils": "flake-utils", 40 | "nixpkgs": "nixpkgs" 41 | } 42 | }, 43 | "systems": { 44 | "locked": { 45 | "lastModified": 1681028828, 46 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 47 | "owner": "nix-systems", 48 | "repo": "default", 49 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 50 | "type": "github" 51 | }, 52 | "original": { 53 | "owner": "nix-systems", 54 | "repo": "default", 55 | "type": "github" 56 | } 57 | } 58 | }, 59 | "root": "root", 60 | "version": 7 61 | } 62 | -------------------------------------------------------------------------------- /partial-semigroup/changelog.md: -------------------------------------------------------------------------------- 1 | 0.6.0.2 - 2023 June 26 2 | 3 | * Raise language version to GHC2021 4 | 5 | 0.6.0.1 - 2023 Jan 10 6 | 7 | * Support GHC 9.4 8 | 9 | 0.6.0.0 - 2022 Mar 21 10 | 11 | * Raise minimum bound for `base` to 4.13 (GHC 8.8) 12 | * Raise supported `hedgehog` range to 1.0, 1.1 13 | * Remove all cabal flags 14 | * Remove doctest test-suite 15 | 16 | 0.5.1.14 - 2022 Jan 10 17 | 18 | * Support GHC 9.2 19 | 20 | 0.5.1.12 - 2021 May 27 21 | 22 | * Add support for GHC 9.0 23 | 24 | 0.5.1.10 - 2021 May 27 25 | 26 | * Drop support for GHC 7.10 27 | 28 | 0.5.1.8 - 2020 Jun 2 29 | 30 | * Support `doctest-0.17` 31 | 32 | 0.5.1.6 - 2020 May 20 33 | 34 | * Support GHC 8.10 35 | 36 | 0.5.1.4 - 2020 Apr 1 37 | 38 | * Support GHC 8.8 39 | 40 | 0.5.1.1 - 2019 May 14 41 | 42 | * Bump upper version bound to allow building with Hedgehog 1.0 43 | 44 | 0.5.1.0 - 2019 Feb 13 45 | 46 | * Add `One` and `AtMostOne` 47 | 48 | 0.5.0.0 - 2018 Nov 21 49 | 50 | * Drop support for GHC 7.8 and below 51 | 52 | 0.4.0.1 - 2018 Sep 27 53 | 54 | * Support GHC up to 8.6 55 | 56 | 0.4.0.0 - 2018 Sep 27 57 | 58 | * Remove the `Monoid` instance on `Partial` 59 | * Support GHC up to 8.4 60 | 61 | 0.3.0.3 - 2018 Feb 13 62 | 63 | * Bump upper version on doctest dependency 64 | 65 | 0.3.0.2 - 2017 Oct 23 66 | 67 | * Remove the `Generics` module when building with GHC 7.4 68 | 69 | 0.3.0.1 - 2017 Oct 23 70 | 71 | * Add the `Data.PartialSemigroup.Generics` module 72 | 73 | 0.2.0.1 - 2017 Oct 23 74 | 75 | * Add support for GHC versions 7.4 through 8.2 76 | 77 | 0.1.0.3 - 2017 Oct 17 78 | 79 | * Very minor code style and cabal metadata changes 80 | 81 | 0.1.0.1 - 2017 Oct 17 82 | 83 | * Rename `appendMaybe` to `(<>?)` 84 | 85 | 0.0.0.1 - 2017 Oct 17 86 | 87 | * Initial release 88 | -------------------------------------------------------------------------------- /partial-semigroup/partial-semigroup.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | 3 | name: partial-semigroup 4 | version: 0.6.0.2 5 | synopsis: A partial binary associative operator 6 | category: Algebra 7 | 8 | description: A partial semigroup is like a semigroup, but 9 | the operator is partial. We represent this in Haskell 10 | as a total function @(<>?) :: a -> a -> Maybe a@. 11 | 12 | homepage: https://github.com/typeclasses/partial-semigroup 13 | bug-reports: https://github.com/typeclasses/partial-semigroup/issues 14 | 15 | author: Chris Martin 16 | maintainer: Chris Martin, Julie Moronuki 17 | 18 | copyright: 2021 Mission Valley Software LLC 19 | license: Apache-2.0 20 | license-file: license.txt 21 | 22 | extra-source-files: *.md 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/typeclasses/partial-semigroup 27 | 28 | common base 29 | default-language: GHC2021 30 | ghc-options: -Wall 31 | build-depends: 32 | , base ^>= 4.16 || ^>= 4.17 || ^>= 4.18 33 | 34 | common test 35 | import: base 36 | ghc-options: -threaded 37 | default-extensions: TemplateHaskell 38 | build-depends: 39 | , partial-semigroup 40 | , hedgehog ^>= 1.1.2 || ^>= 1.2 || ^>= 1.3 || ^>= 1.4 41 | 42 | library 43 | import: base 44 | hs-source-dirs: src 45 | default-extensions: 46 | NoImplicitPrelude 47 | exposed-modules: 48 | Data.PartialSemigroup 49 | Data.PartialSemigroup.Generics 50 | 51 | test-suite examples 52 | import: test 53 | type: exitcode-stdio-1.0 54 | hs-source-dirs: test 55 | main-is: examples.hs 56 | 57 | test-suite properties 58 | import: test 59 | type: exitcode-stdio-1.0 60 | hs-source-dirs: test 61 | main-is: properties.hs 62 | other-modules: 63 | Test.PartialSemigroup.Hedgehog 64 | 65 | test-suite generics 66 | import: test 67 | type: exitcode-stdio-1.0 68 | hs-source-dirs: test 69 | main-is: generics.hs 70 | other-modules: 71 | Test.PartialSemigroup.Hedgehog 72 | -------------------------------------------------------------------------------- /partial-semigroup/test/properties.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative (ZipList (..)) 2 | import Control.Monad (unless) 3 | import Data.Foldable (for_) 4 | import Data.Functor.Identity (Identity (..)) 5 | import Data.Monoid (Sum (..)) 6 | import Data.PartialSemigroup 7 | ( AppendLeft (..), 8 | AppendRight (..), 9 | AtMostOne (..), 10 | One (..), 11 | Total (..), 12 | ) 13 | import Hedgehog (Gen, Property) 14 | import Hedgehog qualified 15 | import Hedgehog.Gen qualified as Gen 16 | import Hedgehog.Range qualified as Range 17 | import System.Exit qualified as Exit 18 | import System.IO qualified as IO 19 | import Test.PartialSemigroup.Hedgehog (assoc) 20 | 21 | main :: IO () 22 | main = do 23 | for_ [IO.stdout, IO.stderr] $ \h -> do 24 | IO.hSetEncoding h IO.utf8 25 | IO.hSetBuffering h IO.LineBuffering 26 | success <- Hedgehog.checkParallel $$(Hedgehog.discover) 27 | unless success Exit.exitFailure 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Properties 31 | -------------------------------------------------------------------------------- 32 | 33 | prop_unit_assoc :: Property 34 | prop_unit_assoc = 35 | assoc (Gen.constant ()) 36 | 37 | prop_identity_assoc :: Property 38 | prop_identity_assoc = 39 | assoc (Identity <$> genStr) 40 | 41 | prop_list_assoc :: Property 42 | prop_list_assoc = 43 | assoc genStr 44 | 45 | prop_list_total_assoc :: Property 46 | prop_list_total_assoc = 47 | assoc (Total <$> genStr) 48 | 49 | prop_zipList_assoc :: Property 50 | prop_zipList_assoc = 51 | assoc (ZipList <$> Gen.list (Range.linear 0 3) genEither) 52 | 53 | prop_either_assoc :: Property 54 | prop_either_assoc = 55 | assoc genEither 56 | 57 | prop_tuple2_assoc :: Property 58 | prop_tuple2_assoc = 59 | assoc ((,) <$> genStr <*> genEither) 60 | 61 | prop_tuple3_assoc :: Property 62 | prop_tuple3_assoc = 63 | assoc ((,,) <$> genStr <*> genEither <*> genSum) 64 | 65 | prop_appendLeft_assoc :: Property 66 | prop_appendLeft_assoc = 67 | assoc (AppendLeft <$> genEither) 68 | 69 | prop_appendRight_assoc :: Property 70 | prop_appendRight_assoc = 71 | assoc (AppendRight <$> genEither) 72 | 73 | prop_one_assoc :: Property 74 | prop_one_assoc = 75 | assoc (One <$> genMaybe) 76 | 77 | prop_atMostOne_assoc :: Property 78 | prop_atMostOne_assoc = 79 | assoc (AtMostOne <$> genMaybe) 80 | 81 | -------------------------------------------------------------------------------- 82 | -- Generators 83 | -------------------------------------------------------------------------------- 84 | 85 | genStr :: Gen String 86 | genStr = 87 | Gen.string (Range.linear 0 5) Gen.alpha 88 | 89 | genSum :: Gen (Sum Integer) 90 | genSum = 91 | Sum <$> Gen.integral (Range.linear 0 10) 92 | 93 | genMaybe :: Gen (Maybe String) 94 | genMaybe = 95 | Gen.maybe genStr 96 | 97 | genEither :: Gen (Either String (Sum Integer)) 98 | genEither = 99 | Gen.choice 100 | [ Left <$> genStr, 101 | Right <$> genSum 102 | ] 103 | -------------------------------------------------------------------------------- /partial-semigroup/test/generics.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad (unless) 2 | import Data.Foldable (for_) 3 | import Data.PartialSemigroup (PartialSemigroup (..)) 4 | import Data.PartialSemigroup.Generics (genericPartialSemigroupOp) 5 | import GHC.Generics (Generic) 6 | import Hedgehog 7 | ( Gen, 8 | Property, 9 | property, 10 | withDiscards, 11 | withTests, 12 | (===), 13 | ) 14 | import Hedgehog qualified 15 | import Hedgehog.Gen qualified as Gen 16 | import Hedgehog.Range qualified as Range 17 | import System.Exit qualified as Exit 18 | import System.IO qualified as IO 19 | import Test.PartialSemigroup.Hedgehog (assoc) 20 | 21 | main :: IO () 22 | main = do 23 | for_ [IO.stdout, IO.stderr] $ \h -> do 24 | IO.hSetEncoding h IO.utf8 25 | IO.hSetBuffering h IO.LineBuffering 26 | success <- Hedgehog.checkParallel $$(Hedgehog.discover) 27 | unless success Exit.exitFailure 28 | 29 | -------------------------------------------------------------------------------- 30 | -- The type whose partial semigroup instance we'll be testing 31 | -------------------------------------------------------------------------------- 32 | 33 | data T 34 | = A String (Either String String) 35 | | B String 36 | deriving (Eq, Generic, Show) 37 | 38 | instance PartialSemigroup T where 39 | (<>?) = genericPartialSemigroupOp 40 | 41 | -------------------------------------------------------------------------------- 42 | -- Generators 43 | -------------------------------------------------------------------------------- 44 | 45 | genStr :: Gen String 46 | genStr = 47 | Gen.string (Range.linear 0 5) Gen.alpha 48 | 49 | genT :: Gen T 50 | genT = 51 | Gen.choice 52 | [ A <$> genStr <*> Gen.choice [Left <$> genStr, Right <$> genStr], 53 | B <$> genStr 54 | ] 55 | 56 | -------------------------------------------------------------------------------- 57 | -- Associative property 58 | -------------------------------------------------------------------------------- 59 | 60 | prop_assoc :: Property 61 | prop_assoc = 62 | withDiscards 1000 $ 63 | assoc genT 64 | 65 | -------------------------------------------------------------------------------- 66 | -- Examples 67 | -------------------------------------------------------------------------------- 68 | 69 | prop_example_1 :: Property 70 | prop_example_1 = 71 | withTests 1 $ 72 | property $ 73 | let x = A "s" (Left "x") 74 | y = A "t" (Left "y") 75 | in x <>? y === Just (A "st" (Left "xy")) 76 | 77 | prop_example_2 :: Property 78 | prop_example_2 = 79 | withTests 1 $ 80 | property $ 81 | let x = B "x" 82 | y = B "y" 83 | in x <>? y === Just (B "xy") 84 | 85 | prop_example_3 :: Property 86 | prop_example_3 = 87 | withTests 1 $ 88 | property $ 89 | let x = A "s" (Left "x") 90 | y = A "t" (Right "y") 91 | in x <>? y === Nothing 92 | 93 | prop_example_4 :: Property 94 | prop_example_4 = 95 | withTests 1 $ 96 | property $ 97 | let x = A "x" (Left "y") 98 | y = B "z" 99 | in x <>? y === Nothing 100 | -------------------------------------------------------------------------------- /partial-semigroup/src/Data/PartialSemigroup/Generics.hs: -------------------------------------------------------------------------------- 1 | -- | If a type derives 'Generic' and all of its fields have 'PartialSemigroup' 2 | -- instances, you can get a 'PartialSemigroup' for free using 3 | -- 'genericPartialSemigroupOp'. 4 | -- 5 | -- == Example 6 | -- 7 | -- For this demonstration we'll define a contrived example type @T@ with two 8 | -- constructors, @A@ and @B@. 9 | -- 10 | -- >>> data T = A String (Either String String) | B String deriving (Generic, Show) 11 | -- 12 | -- And then define its 'PartialSemigroup' instance using 13 | -- 'genericPartialSemigroupOp'. 14 | -- 15 | -- >>> instance PartialSemigroup T where (<>?) = genericPartialSemigroupOp 16 | -- 17 | -- This gives us an implementation of '<>?' which combines values only if they have 18 | -- the same structure. 19 | -- 20 | -- >>> A "s" (Left "x") <>? A "t" (Left "y") 21 | -- Just (A "st" (Left "xy")) 22 | -- 23 | -- >>> B "x" <>? B "y" 24 | -- Just (B "xy") 25 | -- 26 | -- For values that do /not/ have the same structure, '<>?' produces 'Nothing'. 27 | -- 28 | -- >>> A "s" (Left "x") <>? A "t" (Right "y") 29 | -- Nothing 30 | -- 31 | -- >>> A "x" (Left "y") <>? B "z" 32 | -- Nothing 33 | module Data.PartialSemigroup.Generics 34 | ( -- * The generic PartialSemigroup operator 35 | genericPartialSemigroupOp, 36 | 37 | -- * Implementation details 38 | PartialSemigroupRep (..), 39 | 40 | -- * Re-exports 41 | Generic, 42 | PartialSemigroup (..), 43 | ) 44 | where 45 | 46 | import Control.Applicative ((<$>), (<*>)) 47 | import Data.Maybe (Maybe (..)) 48 | import Data.PartialSemigroup 49 | import GHC.Generics 50 | ( Generic, 51 | K1 (..), 52 | M1 (..), 53 | Rep, 54 | from, 55 | to, 56 | (:*:) (..), 57 | (:+:) (..), 58 | ) 59 | 60 | -- $setup 61 | -- 62 | -- >>> :set -XDeriveGeneric 63 | -- 64 | -- >>> import Data.Either (Either (..)) 65 | -- >>> import Data.String (String) 66 | -- >>> import Text.Show (Show) 67 | 68 | genericPartialSemigroupOp :: 69 | (Generic a, PartialSemigroupRep (Rep a)) => 70 | a -> 71 | a -> 72 | Maybe a 73 | genericPartialSemigroupOp x y = 74 | to <$> repPartialSemigroupOp (from x) (from y) 75 | 76 | -- | 77 | -- 78 | -- The class of generic type 'Rep's for which we can automatically derive 79 | -- 'PartialSemigroup': 80 | -- 81 | -- * 'K1' - a single value 82 | -- * 'M1' - a value with some additional metadata (which we simply discard) 83 | -- * ':+:' - sum types 84 | -- * ':*:' - product types 85 | class PartialSemigroupRep rep where 86 | repPartialSemigroupOp :: rep a -> rep a -> Maybe (rep a) 87 | 88 | instance PartialSemigroup a => PartialSemigroupRep (K1 i a) where 89 | repPartialSemigroupOp (K1 x) (K1 y) = K1 <$> (x <>? y) 90 | 91 | instance PartialSemigroupRep rep => PartialSemigroupRep (M1 i meta rep) where 92 | repPartialSemigroupOp (M1 x) (M1 y) = M1 <$> repPartialSemigroupOp x y 93 | 94 | instance 95 | (PartialSemigroupRep rep1, PartialSemigroupRep rep2) => 96 | PartialSemigroupRep (rep1 :*: rep2) 97 | where 98 | repPartialSemigroupOp (x1 :*: x2) (y1 :*: y2) = 99 | (:*:) 100 | <$> repPartialSemigroupOp x1 y1 101 | <*> repPartialSemigroupOp x2 y2 102 | 103 | instance 104 | (PartialSemigroupRep rep1, PartialSemigroupRep rep2) => 105 | PartialSemigroupRep (rep1 :+: rep2) 106 | where 107 | repPartialSemigroupOp (L1 x) (L1 y) = L1 <$> repPartialSemigroupOp x y 108 | repPartialSemigroupOp (R1 x) (R1 y) = R1 <$> repPartialSemigroupOp x y 109 | repPartialSemigroupOp _ _ = Nothing 110 | -------------------------------------------------------------------------------- /partial-semigroup/readme.md: -------------------------------------------------------------------------------- 1 | A partial semigroup is like a semigroup, but the operator is partial. 2 | We represent this in Haskell as a total function: 3 | 4 | ```haskell 5 | (<>?) :: a -> a -> Maybe a 6 | ``` 7 | 8 | The [partial-semigroup-hedgehog] companion package provides support for checking 9 | the partial semigroup associativity axiom using the [hedgehog] package. 10 | 11 | ## Semigroups (background) 12 | 13 | A *semigroup* is a set with a binary associative operator. In Haskell we 14 | represent semigroups as instances of the `Semigroup` typeclass, which looks 15 | something like this: 16 | 17 | ```haskell 18 | class Semigroup a where (<>) :: a -> a -> a 19 | ``` 20 | 21 | This was once provided by the [semigroups] package, but is now in the Haskell 22 | standard library as of `base 4.9.0.0` in 2016. 23 | 24 | ### The semigroup associativity axiom 25 | 26 | The semigroup *associativity* axiom is stated as: 27 | 28 | ```haskell 29 | (a <> b) <> c = a <> (b <> c) 30 | ``` 31 | 32 | ## Partial semigroups 33 | 34 | A *partial semigroup* can be defined in two equivalent ways: 35 | 36 | 1. As a semigroup where `<>` is a *partial function* (that is, we admit the 37 | possibility that `x <> y = ⊥` for some `x` and `y`) 38 | 2. As a new kind of algebraic structure where the operation is *total* (not 39 | partial) but returns `Maybe a` instead of `a`. 40 | 41 | The second definition is the approach we take here (though we will refer back to 42 | this first definition when we discuss the associativity axiom). The 43 | `partial-semigroup` package defines the `PartialSemigroup` class, which looks 44 | like this: 45 | 46 | ```haskell 47 | class PartialSemigroup a where (<>?) :: a -> a -> Maybe a 48 | ``` 49 | 50 | ### The partial semigroup associativity axiom 51 | 52 | The partial semigroup associativity axiom is a natural adaptation of the 53 | semigroup associativity axiom, with a slight modification to accommodate 54 | the situations wherein `x <> y = ⊥`. First we'll express the axiom in terms 55 | of `Semigroup` and `⊥`, and then we'll rephrase it in terms of 56 | `PartialSemigroup`. 57 | 58 | #### Definition 1: In terms of `Semigroup` and `⊥` 59 | 60 | For all `x`, `y`, `z`: 61 | 62 | * If `x <> y ≠ ⊥` and `y <> z ≠ ⊥`, then 63 | 64 | * `x <> (y <> z) = ⊥` if and only if `(x <> y) <> z = ⊥`, and 65 | 66 | * where none of the terms are ⊥, the axiom for total semigroups 67 | `x <> (y <> z) = (x <> y) <> z` must hold. 68 | 69 | #### Definition 2: In terms of `PartialSemigroup` 70 | 71 | For all `x`, `y`, `z`: 72 | 73 | * If `x <>? y = Just xy` and `y <>? z = Just yz`, then 74 | 75 | * `x <>? yz = xy <>? z`. 76 | 77 | ## Deriving using GHC generics 78 | 79 | If a type derives `Generic` and all of its fields have `PartialSemigroup` 80 | instances, you can get a `PartialSemigroup` for free. 81 | 82 | ```haskell 83 | {-# LANGUAGE DeriveGeneric #-} 84 | 85 | import Data.PartialSemigroup.Generics 86 | 87 | data T 88 | = A String (Either String String) 89 | | B String 90 | deriving (Eq, Generic, Show) 91 | 92 | instance PartialSemigroup T where 93 | (<>?) = genericPartialSemigroupOp 94 | ``` 95 | 96 | This gives us an implementation of `<>?` which combines values only if they have 97 | the same structure. 98 | 99 | ```haskell 100 | λ> A "s" (Left "x") <>? A "t" (Left "y") 101 | Just (A "st" (Left "xy")) 102 | 103 | >>> B "x" <>? B "y" 104 | Just (B "xy") 105 | ``` 106 | 107 | For values that do *not* have the same structure, `<>?` produces `Nothing`. 108 | 109 | ```haskell 110 | >>> A "s" (Left "x") <>? A "t" (Right "y") 111 | Nothing 112 | 113 | >>> A "x" (Left "y") <>? B "z" 114 | Nothing 115 | ``` 116 | 117 | [partial-semigroup-hedgehog]: https://hackage.haskell.org/package/partial-semigroup-hedgehog 118 | 119 | [hedgehog]: https://hackage.haskell.org/package/hedgehog 120 | 121 | [semigroups]: https://hackage.haskell.org/package/semigroups 122 | -------------------------------------------------------------------------------- /partial-semigroup/test/examples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 3 | 4 | import Control.Monad (unless) 5 | import Data.Foldable (for_) 6 | import Data.List.NonEmpty (NonEmpty (..)) 7 | import Data.Monoid (Product (..)) 8 | import Data.PartialSemigroup 9 | ( AppendLeft (..), 10 | AppendRight (..), 11 | PartialSemigroup ((<>?)), 12 | Total (..), 13 | groupAndConcat, 14 | partialConcat, 15 | partialConcat1, 16 | partialZip, 17 | partialZip1, 18 | ) 19 | import Hedgehog (Property, PropertyT, property, withTests, (===)) 20 | import Hedgehog qualified 21 | import System.Exit qualified as Exit 22 | import System.IO qualified as IO 23 | 24 | main :: IO () 25 | main = do 26 | for_ [IO.stdout, IO.stderr] $ \h -> do 27 | IO.hSetEncoding h IO.utf8 28 | IO.hSetBuffering h IO.LineBuffering 29 | success <- Hedgehog.checkParallel $$(Hedgehog.discover) 30 | unless success Exit.exitFailure 31 | 32 | example :: PropertyT IO () -> Property 33 | example = withTests 1 . property 34 | 35 | -------------------------------------------------------------------------------- 36 | -- Examples 37 | -------------------------------------------------------------------------------- 38 | 39 | prop_Left_Left :: Property 40 | prop_Left_Left = 41 | example $ 42 | Left "ab" <>? Left "cd" === Just (Left "abcd") 43 | 44 | prop_Left_Right :: Property 45 | prop_Left_Right = 46 | example $ 47 | Left "ab" <>? Right [1, 2] === Nothing 48 | 49 | prop_tuple_Just :: Property 50 | prop_tuple_Just = 51 | example $ 52 | let x = (Left "ab", Right "hi") 53 | y = (Left "cd", Right "jk") 54 | in x <>? y === Just (Left "abcd", Right "hijk") 55 | 56 | prop_tuple_Nothing :: Property 57 | prop_tuple_Nothing = 58 | example $ 59 | let x = (Left "ab", Right "hi") 60 | y = (Left "cd", Left "jk") 61 | in x <>? y === Nothing 62 | 63 | prop_groupAndConcat :: Property 64 | prop_groupAndConcat = 65 | example $ 66 | let xs = [Left "a", Right "b", Right "c", Left "d", Left "e", Left "f"] 67 | in groupAndConcat xs === [Left "a", Right "bc", Left "def"] 68 | 69 | prop_partialConcat_Just :: Property 70 | prop_partialConcat_Just = 71 | example $ 72 | partialConcat [Left "a", Left "b", Left "c"] === Just (Left "abc") 73 | 74 | prop_partialConcat_item'mismatch :: Property 75 | prop_partialConcat_item'mismatch = 76 | example $ 77 | partialConcat [Left "a", Left "b", Right "c"] === Nothing 78 | 79 | prop_partialConcat_empty :: Property 80 | prop_partialConcat_empty = 81 | example $ 82 | partialConcat [] === Nothing 83 | 84 | prop_partialConcat1_Just :: Property 85 | prop_partialConcat1_Just = 86 | example $ 87 | partialConcat1 (Left "a" :| [Left "b", Left "c"]) === Just (Left "abc") 88 | 89 | prop_partialConcat1_item'mismatch :: Property 90 | prop_partialConcat1_item'mismatch = 91 | example $ 92 | partialConcat1 (Left "a" :| [Left "b", Right "c"]) === Nothing 93 | 94 | prop_partialZip_Just :: Property 95 | prop_partialZip_Just = 96 | example $ 97 | let xs = [Left "a", Left "b", Right "c"] 98 | ys = [Left "1", Left "2", Right "3"] 99 | in partialZip xs ys === Just [Left "a1", Left "b2", Right "c3"] 100 | 101 | prop_partialZip_item'mismatch :: Property 102 | prop_partialZip_item'mismatch = 103 | example $ 104 | let xs = [Left "a", Left "b", Right "c"] 105 | ys = [Left "1", Right "2", Right "3"] 106 | in partialZip xs ys === Nothing 107 | 108 | prop_partialZip_empty :: Property 109 | prop_partialZip_empty = 110 | example $ 111 | let xs = [Left "a", Left "b", Right "c"] 112 | ys = [Left "1", Left "2"] 113 | in partialZip xs ys === Nothing 114 | 115 | prop_partialZip1_Just :: Property 116 | prop_partialZip1_Just = 117 | example $ 118 | let xs = Left "a" :| [Left "b", Right "c"] 119 | ys = Left "1" :| [Left "2", Right "3"] 120 | in partialZip1 xs ys === Just (Left "a1" :| [Left "b2", Right "c3"]) 121 | 122 | prop_partialZip1_item'mismatch :: Property 123 | prop_partialZip1_item'mismatch = 124 | example $ 125 | let xs = Left "a" :| [Left "b", Right "c"] 126 | ys = Left "1" :| [Right "2", Right "3"] 127 | in partialZip1 xs ys === Nothing 128 | 129 | prop_partialZip1_length'mismatch :: Property 130 | prop_partialZip1_length'mismatch = 131 | example $ 132 | let xs = Left "a" :| [Left "b", Right "c"] 133 | ys = Left "1" :| [Left "2"] 134 | in partialZip1 xs ys === Nothing 135 | 136 | prop_Total_Just :: Property 137 | prop_Total_Just = 138 | example $ 139 | Total "ab" <>? Total "cd" === Just (Total "abcd") 140 | 141 | prop_Total_partialConcat :: Property 142 | prop_Total_partialConcat = 143 | example $ 144 | let f = getProduct . unTotal 145 | g = Total . Product 146 | in (fmap f . partialConcat . fmap g) [1 .. 4] === Just 24 147 | 148 | prop_AppendLeft_Just :: Property 149 | prop_AppendLeft_Just = 150 | example $ 151 | let x = AppendLeft (Left "ab") 152 | y = AppendLeft (Left "cd") 153 | in x <>? y === Just (AppendLeft (Left "abcd")) 154 | 155 | prop_AppendLeft_Nothing :: Property 156 | prop_AppendLeft_Nothing = 157 | example $ 158 | let x = AppendLeft (Right "ab") 159 | y = AppendLeft (Right "cd") 160 | in x <>? y === Nothing 161 | 162 | prop_AppendLeft_groupAndConcat :: Property 163 | prop_AppendLeft_groupAndConcat = 164 | example $ 165 | let xs = [Left "a", Left "b", Right "c", Right "d", Left "e", Left "f"] 166 | f = fmap unAppendLeft . groupAndConcat . fmap AppendLeft 167 | in f xs === [Left "ab", Right "c", Right "d", Left "ef"] 168 | 169 | prop_AppendRight_Just :: Property 170 | prop_AppendRight_Just = 171 | example $ 172 | let x = AppendRight (Right "ab") 173 | y = AppendRight (Right "cd") 174 | in x <>? y === Just (AppendRight (Right "abcd")) 175 | 176 | prop_AppendRight_Nothing :: Property 177 | prop_AppendRight_Nothing = 178 | example $ 179 | let x = AppendRight (Left "ab") 180 | y = AppendRight (Left "cd") 181 | in x <>? y === Nothing 182 | 183 | prop_AppendRight_groupAndConcat :: Property 184 | prop_AppendRight_groupAndConcat = 185 | example $ 186 | let xs = [Left "a", Left "b", Right "c", Right "d", Left "e", Left "f"] 187 | f = fmap unAppendRight . groupAndConcat . fmap AppendRight 188 | in f xs === [Left "a", Left "b", Right "cd", Left "e", Left "f"] 189 | -------------------------------------------------------------------------------- /partial-semigroup/src/Data/PartialSemigroup.hs: -------------------------------------------------------------------------------- 1 | -- | A /semigroup/ ('Semigroup') is a set with a binary associative operation (@<>@). 2 | -- 3 | -- This module defines a /partial semigroup/ ('PartialSemigroup'), a 4 | -- semigroup for which @<>@ is not required to be defined over all inputs. 5 | module Data.PartialSemigroup 6 | ( -- * Partial semigroup 7 | PartialSemigroup (..), 8 | 9 | -- * Either 10 | -- $either 11 | AppendLeft (..), 12 | AppendRight (..), 13 | 14 | -- * Tuples 15 | -- $tuple 16 | 17 | -- * Concatenation 18 | groupAndConcat, 19 | partialConcat, 20 | partialConcat1, 21 | 22 | -- * Zipping 23 | partialZip, 24 | partialZip1, 25 | 26 | -- * Total to partial 27 | -- $total 28 | Total (..), 29 | 30 | -- * Partial to total 31 | -- $partial 32 | Partial (..), 33 | 34 | -- * Refusing to combine 35 | -- $refusing 36 | One (..), 37 | AtMostOne (..), 38 | ) 39 | where 40 | 41 | import Control.Applicative (ZipList (..), (<$>), (<*>)) 42 | import Control.Monad ((>>=)) 43 | import Data.Either (Either (..)) 44 | import Data.Function ((.)) 45 | import Data.Functor.Identity (Identity (..)) 46 | import Data.List.NonEmpty (NonEmpty (..), nonEmpty) 47 | import Data.Maybe (Maybe (..)) 48 | import Data.Monoid (Product (..), Sum (..)) 49 | import Data.Semigroup (Semigroup (..)) 50 | import Prelude (Eq, Num (..), Ord, Read, Show) 51 | 52 | -- $setup 53 | -- 54 | -- >>> import Data.Function (($)) 55 | -- >>> import Data.Functor (fmap) 56 | 57 | -- The same fixity as <> 58 | infixr 6 <>? 59 | 60 | -- | A 'PartialSemigroup' is like a 'Semigroup', but with an operator returning 61 | -- @'Maybe' a@ rather than @a@. 62 | -- 63 | -- For comparison: 64 | -- 65 | -- @ 66 | -- ('<>') :: 'Semigroup' a => a -> a -> a 67 | -- ('<>?') :: 'PartialSemigroup' a => a -> a -> 'Maybe' a 68 | -- @ 69 | -- 70 | -- === The associativity axiom for partial semigroups 71 | -- 72 | -- For all @x@, @y@, @z@: 73 | -- 74 | -- * If @x '<>?' y = 'Just' xy@ and @y '<>?' z = 'Just' yz@, then 75 | -- 76 | -- * @x '<>?' yz = xy '<>?' z@. 77 | -- 78 | -- ==== Relationship to the semigroup associativity axiom 79 | -- 80 | -- The partial semigroup associativity axiom is a natural adaptation of the 81 | -- semigroup associativity axiom 82 | -- 83 | -- @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ 84 | -- 85 | -- with a slight modification to accommodate situations where '<>' is undefined. We 86 | -- may gain some insight into the connection between 'Semigroup' and 87 | -- 'PartialSemigroup' by rephrasing the partial semigroup associativity in terms of 88 | -- a partial '<>' operator thusly: 89 | -- 90 | -- For all @x@, @y@, @z@: 91 | -- 92 | -- * If @x '<>' y@ and @y '<>' z@ are both defined, then 93 | -- 94 | -- * @x '<>' (y '<>' z)@ is defined if and only if @(x '<>' y) '<>' z@ is 95 | -- defined, and 96 | -- 97 | -- * if these things /are/ all defined, then the axiom for total semigroups 98 | -- @x '<>' (y '<>' z) = (x '<>' y) '<>' z@ must hold. 99 | class PartialSemigroup a where 100 | (<>?) :: a -> a -> Maybe a 101 | 102 | -------------------------------------------------------------------------------- 103 | 104 | instance PartialSemigroup () where 105 | () <>? () = Just () 106 | 107 | -------------------------------------------------------------------------------- 108 | 109 | instance PartialSemigroup [a] where 110 | x <>? y = Just (x <> y) 111 | 112 | -------------------------------------------------------------------------------- 113 | 114 | instance Num a => PartialSemigroup (Sum a) where 115 | x <>? y = Just (x <> y) 116 | 117 | instance Num a => PartialSemigroup (Product a) where 118 | x <>? y = Just (x <> y) 119 | 120 | -------------------------------------------------------------------------------- 121 | 122 | instance PartialSemigroup a => PartialSemigroup (Identity a) where 123 | Identity x <>? Identity y = Identity <$> (x <>? y) 124 | 125 | -------------------------------------------------------------------------------- 126 | 127 | instance 128 | (PartialSemigroup a, PartialSemigroup b) => 129 | PartialSemigroup (Either a b) 130 | where 131 | Left x <>? Left y = Left <$> (x <>? y) 132 | Right x <>? Right y = Right <$> (x <>? y) 133 | _ <>? _ = Nothing 134 | 135 | -- $either 136 | -- 137 | -- The exemplary nontrivial 'PartialSemigroup' is 'Either', for which the append 138 | -- operator produces a 'Just' result only if both arguments are 'Left' or both 139 | -- arguments are 'Right'. 140 | -- 141 | -- >>> Left "ab" <>? Left "cd" 142 | -- Just (Left "abcd") 143 | -- 144 | -- >>> Left "ab" <>? Right [1, 2] 145 | -- Nothing 146 | 147 | -------------------------------------------------------------------------------- 148 | 149 | -- $tuple 150 | -- 151 | -- A tuple forms a partial semigroups when all of its constituent parts have 152 | -- partial semigroups. The append operator returns a 'Just' value when /all/ of the 153 | -- fields' append operators must return 'Just' values. 154 | -- 155 | -- >>> x = (Left "ab", Right "hi") 156 | -- >>> y = (Left "cd", Right "jk") 157 | -- >>> x <>? y 158 | -- Just (Left "abcd",Right "hijk") 159 | -- 160 | -- >>> x = (Left "ab", Right "hi") 161 | -- >>> y = (Left "cd", Left "jk") 162 | -- >>> x <>? y 163 | -- Nothing 164 | 165 | instance (PartialSemigroup a, PartialSemigroup b) => PartialSemigroup (a, b) where 166 | (a, b) <>? (a', b') = 167 | (,) 168 | <$> (a <>? a') 169 | <*> (b <>? b') 170 | 171 | instance 172 | (PartialSemigroup a, PartialSemigroup b, PartialSemigroup c) => 173 | PartialSemigroup (a, b, c) 174 | where 175 | (a, b, c) <>? (a', b', c') = 176 | (,,) 177 | <$> (a <>? a') 178 | <*> (b <>? b') 179 | <*> (c <>? c') 180 | 181 | -------------------------------------------------------------------------------- 182 | 183 | -- | Apply a semigroup operation to any pairs of consecutive list elements where 184 | -- the semigroup operation is defined over them. 185 | -- 186 | -- ==== Examples 187 | -- 188 | -- For 'Either', 'groupAndConcat' combines contiguous sublists of 'Left' and 189 | -- contiguous sublists of 'Right'. 190 | -- 191 | -- >>> xs = [Left "a", Right "b", Right "c", Left "d", Left "e", Left "f"] 192 | -- >>> groupAndConcat xs 193 | -- [Left "a",Right "bc",Left "def"] 194 | groupAndConcat :: PartialSemigroup a => [a] -> [a] 195 | groupAndConcat [] = [] 196 | groupAndConcat [x] = [x] 197 | groupAndConcat (x : y : zs) = 198 | case x <>? y of 199 | Nothing -> x : groupAndConcat (y : zs) 200 | Just a -> groupAndConcat (a : zs) 201 | 202 | -- | If @xs@ is nonempty and the partial semigroup operator is defined for all 203 | -- pairs of values in @xs@, then @'partialConcat' xs@ produces a 'Just' result with 204 | -- the combination of all the values. Otherwise, returns 'Nothing'. 205 | -- 206 | -- ==== Examples 207 | -- 208 | -- When all values can combine, we get a 'Just' of their combination. 209 | -- 210 | -- >>> partialConcat [Left "a", Left "b", Left "c"] 211 | -- Just (Left "abc") 212 | -- 213 | -- When some values cannot be combined, we get 'Nothing'. 214 | -- 215 | -- >>> partialConcat [Left "a", Left "b", Right "c"] 216 | -- Nothing 217 | -- 218 | -- When the list is empty, we get 'Nothing'. 219 | -- 220 | -- >>> partialConcat [] 221 | -- Nothing 222 | partialConcat :: PartialSemigroup a => [a] -> Maybe a 223 | partialConcat x = 224 | nonEmpty x >>= partialConcat1 225 | 226 | -- | Like 'partialConcat', but for non-empty lists. 227 | -- 228 | -- ==== Examples 229 | -- 230 | -- When all values can combine, we get a 'Just' of their combination. 231 | -- 232 | -- >>> partialConcat1 (Left "a" :| [Left "b", Left "c"]) 233 | -- Just (Left "abc") 234 | -- 235 | -- When some values cannot be combined, we get 'Nothing'. 236 | -- 237 | -- >>> partialConcat1 (Left "a" :| [Left "b", Right "c"]) 238 | -- Nothing 239 | partialConcat1 :: PartialSemigroup a => NonEmpty a -> Maybe a 240 | partialConcat1 (x :| []) = Just x 241 | partialConcat1 (x :| (y : zs)) = 242 | do 243 | a <- x <>? y 244 | partialConcat1 (a :| zs) 245 | 246 | -- | ==== Examples 247 | -- 248 | -- If lists are the same length and each pair of elements successfully, then we get 249 | -- a 'Just' result. 250 | -- 251 | -- >>> xs = [Left "a", Left "b", Right "c"] 252 | -- >>> ys = [Left "1", Left "2", Right "3"] 253 | -- >>> partialZip xs ys 254 | -- Just [Left "a1",Left "b2",Right "c3"] 255 | -- 256 | -- If the pairs do not all combine, then we get 'Nothing'. 257 | -- 258 | -- >>> xs = [Left "a", Left "b", Right "c"] 259 | -- >>> ys = [Left "1", Right "2", Right "3"] 260 | -- >>> partialZip xs ys 261 | -- Nothing 262 | -- 263 | -- If the lists have different lengths, then we get 'Nothing'. 264 | -- 265 | -- >>> xs = [Left "a", Left "b", Right "c"] 266 | -- >>> ys = [Left "1", Left "2"] 267 | -- >>> partialZip xs ys 268 | -- Nothing 269 | partialZip :: PartialSemigroup a => [a] -> [a] -> Maybe [a] 270 | partialZip [] [] = Just [] 271 | partialZip [] _ = Nothing 272 | partialZip _ [] = Nothing 273 | partialZip (x : xs) (y : ys) = 274 | (:) <$> (x <>? y) <*> partialZip xs ys 275 | 276 | -- | Like 'partialZip', but for non-empty lists. 277 | -- 278 | -- ==== Examples 279 | -- 280 | -- If lists are the same length and each pair of elements successfully, then we get 281 | -- a 'Just' result. 282 | -- 283 | -- >>> xs = Left "a" :| [Left "b", Right "c"] 284 | -- >>> ys = Left "1" :| [Left "2", Right "3"] 285 | -- >>> partialZip1 xs ys 286 | -- Just (Left "a1" :| [Left "b2",Right "c3"]) 287 | -- 288 | -- If the pairs do not all combine, then we get 'Nothing'. 289 | -- 290 | -- >>> xs = Left "a" :| [Left "b", Right "c"] 291 | -- >>> ys = Left "1" :| [Right "2", Right "3"] 292 | -- >>> partialZip1 xs ys 293 | -- Nothing 294 | -- 295 | -- If the lists have different lengths, then we get 'Nothing'. 296 | -- 297 | -- >>> xs = Left "a" :| [Left "b", Right "c"] 298 | -- >>> ys = Left "1" :| [Left "2"] 299 | -- >>> partialZip1 xs ys 300 | -- Nothing 301 | partialZip1 :: 302 | PartialSemigroup a => 303 | NonEmpty a -> 304 | NonEmpty a -> 305 | Maybe (NonEmpty a) 306 | partialZip1 (x :| xs) (y :| ys) = 307 | (:|) <$> (x <>? y) <*> partialZip xs ys 308 | 309 | -- | 'partialZip' 310 | instance PartialSemigroup a => PartialSemigroup (ZipList a) where 311 | ZipList x <>? ZipList y = ZipList <$> partialZip x y 312 | 313 | -------------------------------------------------------------------------------- 314 | 315 | -- $partial 316 | -- 317 | -- For every type @a@ with a 'PartialSemigroup', we can construct a total 318 | -- 'Semigroup' for @'Maybe' a@ as: 319 | -- 320 | -- @ 321 | -- 'Just' x <> 'Just' y = x '<>?' y 322 | -- _ '<>' _ = 'Nothing' 323 | -- @ 324 | -- 325 | -- We don't actually define this instance for 'Maybe' because it already has a 326 | -- different 'Semigroup' defined over it, but we do provide the 'Partial' wrapper 327 | -- which has this instance. 328 | 329 | -- | A wrapper for 'Maybe' with an error-propagating 'Semigroup'. 330 | newtype Partial a = Partial {unPartial :: Maybe a} 331 | deriving (Eq, Ord, Read, Show) 332 | 333 | instance PartialSemigroup a => Semigroup (Partial a) where 334 | Partial (Just x) <> Partial (Just y) = Partial (x <>? y) 335 | _ <> _ = Partial Nothing 336 | 337 | -------------------------------------------------------------------------------- 338 | 339 | -- $total 340 | -- 341 | -- For every type with a 'Semigroup', we can trivially construct a 342 | -- 'PartialSemigroup' as: 343 | -- 344 | -- @ 345 | -- x '<>?' y = 'Just' (x '<>' y) 346 | -- @ 347 | -- 348 | -- Additionally, any type with a 'Semigroup' can be treated as a 'PartialSemigroup' 349 | -- by lifting it into 'Total'. 350 | 351 | -- | A wrapper to turn any value with a 'Semigroup' instance into a value with a 352 | -- 'PartialSemigroup' instance whose '<>?' operator always returns 'Just'. 353 | -- 354 | -- ==== Examples 355 | -- 356 | -- >>> Total "ab" <>? Total "cd" 357 | -- Just (Total {unTotal = "abcd"}) 358 | -- 359 | -- >>> f = getProduct . unTotal 360 | -- >>> g = Total . Product 361 | -- >>> fmap f . partialConcat . fmap g $ [1..4] 362 | -- Just 24 363 | newtype Total a = Total {unTotal :: a} 364 | deriving (Eq, Ord, Read, Show) 365 | 366 | instance Semigroup a => PartialSemigroup (Total a) where 367 | Total x <>? Total y = Just (Total (x <> y)) 368 | 369 | -------------------------------------------------------------------------------- 370 | 371 | -- | A wrapper for 'Either' where the 'PartialSemigroup' operator is defined 372 | -- only over 'Left' values. 373 | -- 374 | -- ==== Examples 375 | -- 376 | -- Two 'Left's make a 'Just'. 377 | -- 378 | -- >>> AppendLeft (Left "ab") <>? AppendLeft (Left "cd") 379 | -- Just (AppendLeft {unAppendLeft = Left "abcd"}) 380 | -- 381 | -- Anything else produces 'Nothing' 382 | -- 383 | -- >>> AppendLeft (Right "ab") <>? AppendLeft (Right "cd") 384 | -- Nothing 385 | -- 386 | -- 'groupAndConcat' combines consecutive 'Left' values, leaving the 'Right' values 387 | -- unmodified. 388 | -- 389 | -- >>> xs = [Left "a", Left "b", Right "c", Right "d", Left "e", Left "f"] 390 | -- >>> fmap unAppendLeft . groupAndConcat . fmap AppendLeft $ xs 391 | -- [Left "ab",Right "c",Right "d",Left "ef"] 392 | newtype AppendLeft a b = AppendLeft {unAppendLeft :: Either a b} 393 | deriving (Eq, Ord, Read, Show) 394 | 395 | instance PartialSemigroup a => PartialSemigroup (AppendLeft a b) where 396 | AppendLeft (Left x) <>? AppendLeft (Left y) = 397 | AppendLeft . Left <$> (x <>? y) 398 | _ <>? _ = Nothing 399 | 400 | -------------------------------------------------------------------------------- 401 | 402 | -- | A wrapper for 'Either' where the 'PartialSemigroup' operator is defined 403 | -- only over 'Right' values. 404 | -- 405 | -- ==== Examples 406 | -- 407 | -- Two 'Right's make a 'Just'. 408 | -- 409 | -- >>> AppendRight (Right "ab") <>? AppendRight (Right "cd") 410 | -- Just (AppendRight {unAppendRight = Right "abcd"}) 411 | -- 412 | -- Anything else produces 'Nothing' 413 | -- 414 | -- >>> AppendRight (Left "ab") <>? AppendRight (Left "cd") 415 | -- Nothing 416 | -- 417 | -- 'groupAndConcat' combines consecutive 'Right' values, leaving the 'Left' values 418 | -- unmodified. 419 | -- 420 | -- >>> xs = [Left "a", Left "b", Right "c", Right "d", Left "e", Left "f"] 421 | -- >>> fmap unAppendRight . groupAndConcat . fmap AppendRight $ xs 422 | -- [Left "a",Left "b",Right "cd",Left "e",Left "f"] 423 | newtype AppendRight a b = AppendRight {unAppendRight :: Either a b} 424 | deriving (Eq, Ord, Read, Show) 425 | 426 | instance PartialSemigroup b => PartialSemigroup (AppendRight a b) where 427 | AppendRight (Right x) <>? AppendRight (Right y) = 428 | AppendRight . Right <$> (x <>? y) 429 | _ <>? _ = Nothing 430 | 431 | -------------------------------------------------------------------------------- 432 | 433 | -- $refusing 434 | -- 435 | -- These are 'PartialSemigroup' instances that don't really combine their values 436 | -- at all; whenever more than one thing is present, '<>?' fails. 437 | 438 | -- | A partial semigroup operation which always fails. 439 | newtype One a = One {theOne :: a} 440 | deriving (Eq, Ord, Read, Show) 441 | 442 | instance PartialSemigroup (One a) where 443 | _ <>? _ = Nothing 444 | 445 | -- | A wrapper for 'Maybe' whose partial semigroup operation fails when two 446 | -- 'Just's are combined. 447 | newtype AtMostOne a = AtMostOne {theOneMaybe :: Maybe a} 448 | deriving (Eq, Ord, Read, Show) 449 | 450 | instance PartialSemigroup (AtMostOne a) where 451 | AtMostOne Nothing <>? x = Just x 452 | x <>? AtMostOne Nothing = Just x 453 | _ <>? _ = Nothing 454 | --------------------------------------------------------------------------------