diff --git a/LICENCE b/LICENCE --- a/LICENCE +++ b/LICENCE @@ -1,4 +1,4 @@ -Copyright (c) 2020-2026, System F +Copyright (c) 2018-2026 Tony Morris All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of QFPL nor the names of other + * Neither the name of Tony Morris nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,92 @@ +# natural + +Safe natural number, positive integer, and non-zero integer types with lens integration. + +## Types + +| Type | Range | Semigroup | Monoid identity | +|------|-------|-----------|-----------------| +| `Natural` | >= 0 | addition | 0 | +| `Positive` | >= 1 | multiplication | — | +| `NotZero` | /= 0 | addition | — | + +Each type has corresponding newtype wrappers for alternative semigroups: + +| Wrapper | Operation | +|---------|-----------| +| `ProductNatural` | multiplication | +| `MaxNatural` / `MinNatural` | max / min | +| `SumPositive` | addition | +| `MaxPositive` / `MinPositive` | max / min | +| `SumNotZero` | addition | +| `MaxNotZero` / `MinNotZero` | max / min | + +## Optics + +The library uses `lens` for type-safe conversions: + +```haskell +-- Prisms for safe construction from integral types +(5 :: Integer) ^? _Natural -- Just (Natural 5) +(-1 :: Integer) ^? _Natural -- Nothing + +(3 :: Integer) ^? _Positive -- Just (Positive 3) +(0 :: Integer) ^? _Positive -- Nothing + +(7 :: Integer) ^? _NotZero -- Just (NotZero True (Positive 7)) +(0 :: Integer) ^? _NotZero -- Nothing + +-- Structural prisms +Natural 5 ^? successor -- Just (Natural 4) +Natural 0 ^? successor -- Nothing + +Positive 3 ^? successor1 -- Just (Positive 2) +Positive 1 ^? successor1 -- Nothing + +-- Isos between related types +Natural 4 ^. successorW -- Positive 5 +Natural 3 ^. naturalPositive -- Just (Positive 3) +Natural 3 ^. list -- [(), (), ()] +``` + +## Type classes + +Each type has `Has*` (lens) and `As*` (prism) classes with instances for +standard integral types (`Int`, `Integer`, `Word`, `Const`, `Identity`): + +```haskell +class HasNatural a where + natural :: Lens' a Natural + +class AsNatural a where + _Natural :: Prism' a Natural +``` + +## NotZero + +A non-zero integer represented as a sign (`Bool`: `True` = positive) and a +magnitude (`Positive`): + +```haskell +data NotZero = NotZero Bool Positive + +positiveNotZero (Positive 5) -- NotZero True (Positive 5) +negativeNotZero (Positive 3) -- NotZero False (Positive 3) +notZeroInteger (NotZero False (Positive 3)) -- -3 + +-- Multiplication is always total +multiplyNZ (NotZero False (Positive 3)) (NotZero False (Positive 4)) + -- NotZero True (Positive 12) + +-- Addition can produce zero +plusNZ (NotZero True (Positive 3)) (NotZero False (Positive 3)) + -- Nothing +``` + +## Building + +``` +cabal build +cabal test doctest +cabal bench +``` diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,8 @@ -import Distribution.Simple +{-# OPTIONS_GHC -Wall -Werror #-} + +module Main (main) where + +import Distribution.Simple (defaultMain) + +main :: IO () main = defaultMain diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,24 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +module Main (main) where + +import Test.Tasty.Bench (bench, bgroup, defaultMain, whnf) +import Natural (Natural, zero', successor', plus, multiply) + +n :: Int +n = 1000 + +nat :: Int -> Natural +nat 0 = zero' +nat k = successor' (nat (k - 1)) + +main :: IO () +main = + defaultMain + [ bgroup + "Natural" + [ bench "successor" $ whnf (iterate successor' zero' !!) n, + bench "plus" $ whnf (plus (nat 100)) (nat 100), + bench "multiply" $ whnf (multiply (nat 50)) (nat 50) + ] + ] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,38 @@ +0.5.0.1 + +* Hide `Natural` and `Positive` constructors from export +* Rewrite doctests to use prism-based construction for external module compatibility + +0.5.0.0 + +* Add `NotZero` data type for non-zero integers (positive or negative) + with `HasNotZero`, `AsNotZero` classes, `SumNotZero`, `MaxNotZero`, + `MinNotZero` newtype wrappers, and functions: `positiveNotZero`, + `negativeNotZero`, `notZeroPositive`, `notZeroInteger`, `isPositive`, + `isNegative`, `negateNZ`, `absoluteNZ`, `signumNZ`, `plusNZ`, + `multiplyNZ`, `notZeroOr` +* Add `AsPositive NotZero` instance +* Add `ToJSON` and `FromJSON` instances for `Natural`, `Positive`, + `NotZero`, and all newtype wrappers (`ProductNatural`, `MaxNatural`, + `MinNatural`, `SumPositive`, `MaxPositive`, `MinPositive`, + `SumNotZero`, `MaxNotZero`, `MinNotZero`) +* Add `toJsonNatural`, `parseJsonNatural`, `toJsonPositive`, + `parseJsonPositive`, `toJsonNotZero`, `parseJsonNotZero` functions +* Add `aeson` dependency +* Change `Semigroup Positive` from addition to multiplication +* Remove `Monoid Positive` (no additive identity for positives) +* Add `SumPositive` wrapper for addition of positives +* Remove redundant `notZero` function (identical to `_Positive` on `Natural`) +* Rename `square` to `power`, `square1` to `power1` +* Fix `(!!)` returning `Nothing` for index zero +* Fix `(!!!)` off-by-one indexing +* Fix `minus1` producing `Positive 0` when arguments are equal +* Fix `length` using lazy `foldl` (now strict `foldl'`) +* Add doctests to all functions and instances +* Modernise cabal file to cabal-version 2.4 +* Add doctest test-suite and benchmarks +* Update repository to https://gitlab.com/system-f/code/natural + 0.4.0.0 * Add `ToJSON` and `FromJSON` instances for `Natural`, `Positive`, and all newtype wrappers (`ProductNatural`, `MaxNatural`, `MinNatural`, `SumPositive`, `MaxPositive`, `MinPositive`). diff --git a/natural.cabal b/natural.cabal --- a/natural.cabal +++ b/natural.cabal @@ -1,45 +1,69 @@ cabal-version: 2.4 name: natural -version: 0.4.0.0 +version: 0.5.0.1 synopsis: Natural number description: - Natural number + Natural number with lens integration. . <> license: BSD-3-Clause license-file: LICENCE -author: Queensland Functional Programming Lab -maintainer: Queensland Functional Programming Lab -copyright: Copyright (C) 2020-2026 System F -category: Control +author: Tony Morris +maintainer: Tony Morris +category: Data build-type: Simple extra-doc-files: changelog.md -homepage: https://github.com/system-f/natural -bug-reports: https://github.com/system-f/natural/issues -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1, GHC == 8.8.1, GHC == 8.6.5, GHC == 8.10.1, GHC == 9.4.8 + , README.md +homepage: https://gitlab.com/system-f/code/natural +bug-reports: https://gitlab.com/system-f/code/natural/-/issues +tested-with: GHC == 9.6.7 -source-repository head - type: git - location: git@github.com:system-f/natural.git +flag dev + description: Enable development warnings (-Werror, -O2 for benchmarks) + manual: True + default: False +source-repository head + type: git + location: https://gitlab.com/system-f/code/natural.git + library - exposed-modules: Natural - build-depends: base >= 4.8 && < 6 - , aeson >= 2.2 && < 3 - , lens >= 4.15 && < 6 - , semigroupoids >= 5 && < 7 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - if impl(ghc<8.0.1) - build-depends: semigroups >= 0.9 && < 1 + exposed-modules: + Natural -test-suite doctest - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs build-depends: base >= 4.8 && < 6 - , process >= 1 && < 2 - build-tool-depends: doctest:doctest >= 0.22 - default-language: Haskell2010 - ghc-options: -Wall + , aeson >= 1.4 && < 3 + , lens >= 4.15 && < 6 + , semigroupoids >= 5 && < 7 + + hs-source-dirs: src + + default-language: Haskell2010 + + ghc-options: -Wall + + if flag(dev) + ghc-options: -Werror + +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Main.hs + build-depends: base >= 4.8 && < 6 + , tasty-bench >= 0.3 && < 1 + , natural + default-language: Haskell2010 + ghc-options: -Wall + + if flag(dev) + ghc-options: -Werror -O2 + +test-suite doctest + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base >= 4.8 && < 6 + , process >= 1 && < 2 + build-tool-depends: doctest:doctest >= 0.22 && < 1 + default-language: Haskell2010 + ghc-options: -Wall diff --git a/src/Natural.hs b/src/Natural.hs --- a/src/Natural.hs +++ b/src/Natural.hs @@ -11,1603 +11,2275 @@ ProductNatural (..), MaxNatural (..), MinNatural (..), - toJsonNatural, - parseJsonNatural, - zero, - zero', - successor, - successor', - plus, - multiply, - power, - zeroOr, - length, - replicate, - take, - drop, - splitAt, - (!!), - findIndices, - findIndex, - elemIndices, - elemIndex, - minus, - list, - Positive, - HasPositive (..), - AsPositive (..), - SumPositive (..), - MaxPositive (..), - MinPositive (..), - toJsonPositive, - parseJsonPositive, - naturalPositive, - one, - one', - successor1, - successor1', - successorW, - plus1, - multiply1, - power1, - oneOr, - notZero, - length1, - replicate1, - take1, - drop1, - splitAt1, - (!!!), - findIndices1, - findIndex1, - elemIndices1, - elemIndex1, - minus1, - list1, - plusone, - minusone, - ) -where - -import Control.Applicative (Const, pure) -import Control.Category (id, (.)) -import Control.Lens (Iso', Lens', Prism', Rewrapped, Wrapped (Unwrapped, _Wrapped'), iso, prism', view, (#), (^.), (^?), _Wrapped) -import Control.Monad ((>>=)) -import Data.Aeson.Types - ( FromJSON (parseJSON), - Parser, - ToJSON (toEncoding, toJSON), - Value, - ) -import Data.Bool (Bool) -import Data.Eq (Eq ((==))) -import Data.Foldable (Foldable (foldl)) -import Data.Function (const) -import Data.Functor.Identity (Identity) -import Data.Int (Int) -import Data.List (filter, iterate, map, repeat, zip) -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NonEmpty (filter, iterate, zip) -import Data.Maybe (Maybe (Just, Nothing), fromMaybe, listToMaybe) -import Data.Monoid (Monoid (mappend, mempty)) -import Data.Ord (Ord ((<), (<=)), max, min) -import Data.Semigroup (Semigroup ((<>))) -import Data.Semigroup.Foldable (Foldable1 (foldMap1)) -import Data.Tuple (fst, snd) -import Data.Word (Word) -import Prelude (Integer, Integral, Show, fail, fromIntegral, (*), (+), (-), (^)) - --- $setup --- >>> import Data.Aeson --- >>> import Data.Aeson.Types (parse) --- >>> :set -XOverloadedStrings - --- | A natural number (non-negative integer: 0, 1, 2, ...). --- --- >>> Natural 0 --- Natural 0 --- --- >>> Natural 42 --- Natural 42 -newtype Natural - = Natural - Integer - deriving (Eq, Ord, Show) - --- | Natural numbers form a semigroup under addition. --- --- >>> Natural 3 <> Natural 4 --- Natural 7 -instance Semigroup Natural where - Natural x <> Natural y = - Natural (x + y) - --- | The additive monoid of natural numbers with identity 0. --- --- >>> mempty :: Natural --- Natural 0 --- --- >>> mappend (Natural 3) (Natural 4) --- Natural 7 -instance Monoid Natural where - mappend = - (<>) - mempty = - Natural 0 - --- | Typeclass for types that have a 'Natural' lens. --- --- >>> Natural 5 ^. natural --- Natural 5 -class HasNatural a where - natural :: - Lens' - a - Natural - --- | >>> Natural 5 ^. natural --- Natural 5 -instance HasNatural Natural where - natural = - id - --- | Typeclass for types that can be converted to/from 'Natural' via a prism. --- --- >>> (5 :: Integer) ^? _Natural --- Just (Natural 5) --- --- >>> (-1 :: Integer) ^? _Natural --- Nothing -class AsNatural a where - _Natural :: - Prism' - a - Natural - --- | >>> Natural 5 ^? _Natural --- Just (Natural 5) -instance AsNatural Natural where - _Natural = - id - --- | Prism for converting an integral value to a 'Natural'. --- --- >>> (5 :: Integer) ^? integralPrism --- Just (Natural 5) --- --- >>> (-1 :: Integer) ^? integralPrism --- Nothing -integralPrism :: - (Integral a) => - Prism' - a - Natural -integralPrism = - prism' - (\(Natural n) -> fromIntegral n) - (\n -> if n < 0 then Nothing else Just (Natural (fromIntegral n))) - --- | >>> (5 :: Int) ^? _Natural --- Just (Natural 5) --- --- >>> (-1 :: Int) ^? _Natural --- Nothing -instance AsNatural Int where - _Natural = - integralPrism - --- | >>> (5 :: Integer) ^? _Natural --- Just (Natural 5) --- --- >>> (-1 :: Integer) ^? _Natural --- Nothing -instance AsNatural Integer where - _Natural = - integralPrism - --- | >>> (5 :: Word) ^? _Natural --- Just (Natural 5) -instance AsNatural Word where - _Natural = - integralPrism - --- | >>> (Const 5 :: Const Integer Bool) ^? _Natural --- Just (Natural 5) -instance (Integral a) => AsNatural (Const a b) where - _Natural = - integralPrism - --- | >>> (Identity 5 :: Identity Integer) ^? _Natural --- Just (Natural 5) -instance (Integral a) => AsNatural (Identity a) where - _Natural = - integralPrism - --- | Natural numbers under multiplication. --- --- >>> ProductNatural (Natural 3) <> ProductNatural (Natural 4) --- ProductNatural (Natural 12) --- --- >>> mempty :: ProductNatural --- ProductNatural (Natural 1) -newtype ProductNatural - = ProductNatural - Natural - deriving (Eq, Ord, Show) - --- | >>> ProductNatural (Natural 5) ^. natural --- Natural 5 -instance HasNatural ProductNatural where - natural = - _Wrapped . natural - --- | >>> ProductNatural (Natural 5) ^? _Natural --- Just (Natural 5) -instance AsNatural ProductNatural where - _Natural = - _Wrapped . _Natural - -instance - (ProductNatural ~ a) => - Rewrapped ProductNatural a - --- | >>> ProductNatural (Natural 5) ^. _Wrapped' --- Natural 5 -instance Wrapped ProductNatural where - type Unwrapped ProductNatural = Natural - _Wrapped' = - iso - (\(ProductNatural x) -> x) - ProductNatural - --- | >>> ProductNatural (Natural 3) <> ProductNatural (Natural 4) --- ProductNatural (Natural 12) -instance Semigroup ProductNatural where - ProductNatural (Natural x) <> ProductNatural (Natural y) = - ProductNatural (Natural (x * y)) - --- | >>> mempty :: ProductNatural --- ProductNatural (Natural 1) -instance Monoid ProductNatural where - mappend = - (<>) - mempty = - ProductNatural (Natural 1) - --- | Natural numbers under maximum. --- --- >>> MaxNatural (Natural 3) <> MaxNatural (Natural 7) --- MaxNatural (Natural 7) -newtype MaxNatural - = MaxNatural - Natural - deriving (Eq, Ord, Show) - --- | >>> MaxNatural (Natural 5) ^. natural --- Natural 5 -instance HasNatural MaxNatural where - natural = - _Wrapped . natural - --- | >>> MaxNatural (Natural 5) ^? _Natural --- Just (Natural 5) -instance AsNatural MaxNatural where - _Natural = - _Wrapped . _Natural - -instance - (MaxNatural ~ a) => - Rewrapped MaxNatural a - --- | >>> MaxNatural (Natural 5) ^. _Wrapped' --- Natural 5 -instance Wrapped MaxNatural where - type Unwrapped MaxNatural = Natural - _Wrapped' = - iso - (\(MaxNatural x) -> x) - MaxNatural - --- | >>> MaxNatural (Natural 3) <> MaxNatural (Natural 7) --- MaxNatural (Natural 7) -instance Semigroup MaxNatural where - MaxNatural (Natural x) <> MaxNatural (Natural y) = - MaxNatural (Natural (x `max` y)) - --- | Natural numbers under minimum. --- --- >>> MinNatural (Natural 3) <> MinNatural (Natural 7) --- MinNatural (Natural 3) -newtype MinNatural - = MinNatural - Natural - deriving (Eq, Ord, Show) - --- | >>> MinNatural (Natural 5) ^. natural --- Natural 5 -instance HasNatural MinNatural where - natural = - _Wrapped . natural - --- | >>> MinNatural (Natural 5) ^? _Natural --- Just (Natural 5) -instance AsNatural MinNatural where - _Natural = - _Wrapped . _Natural - -instance - (MinNatural ~ a) => - Rewrapped MinNatural a - --- | >>> MinNatural (Natural 5) ^. _Wrapped' --- Natural 5 -instance Wrapped MinNatural where - type Unwrapped MinNatural = Natural - _Wrapped' = - iso - (\(MinNatural x) -> x) - MinNatural - --- | >>> MinNatural (Natural 3) <> MinNatural (Natural 7) --- MinNatural (Natural 3) -instance Semigroup MinNatural where - MinNatural (Natural x) <> MinNatural (Natural y) = - MinNatural (Natural (x `min` y)) - --- | Serialises a 'Natural' to a JSON number. --- --- >>> toJSON (Natural 0) --- Number 0.0 --- --- >>> toJSON (Natural 42) --- Number 42.0 --- --- >>> encode (Natural 0) --- "0" --- --- >>> encode (Natural 42) --- "42" -instance ToJSON Natural where - toJSON = - toJsonNatural - toEncoding (Natural n) = - toEncoding n - --- | Serialises any value with a 'HasNatural' instance to a JSON 'Value'. --- --- >>> toJsonNatural (Natural 42) --- Number 42.0 --- --- >>> toJsonNatural (ProductNatural (Natural 12)) --- Number 12.0 --- --- >>> toJsonNatural (MaxNatural (Natural 7)) --- Number 7.0 --- --- >>> toJsonNatural (MinNatural (Natural 3)) --- Number 3.0 -{-# SPECIALIZE toJsonNatural :: - Natural -> - Value - #-} -{-# INLINE toJsonNatural #-} -toJsonNatural :: - (HasNatural a) => - a -> - Value -toJsonNatural a = - let Natural n = view natural a - in toJSON n - --- | Parses a 'Natural' from a JSON number, failing on negative values. --- --- >>> fromJSON (Number 0) :: Result Natural --- Success (Natural 0) --- --- >>> fromJSON (Number 42) :: Result Natural --- Success (Natural 42) --- --- >>> decode "42" :: Maybe Natural --- Just (Natural 42) --- --- >>> decode "0" :: Maybe Natural --- Just (Natural 0) --- --- >>> decode "-1" :: Maybe Natural --- Nothing -instance FromJSON Natural where - parseJSON = - parseJsonNatural - --- | Parses a JSON value into a 'Natural', failing on negative values. --- --- >>> parse parseJsonNatural (Number 42) --- Success (Natural 42) --- --- >>> parse parseJsonNatural (Number 0) --- Success (Natural 0) --- --- >>> parse parseJsonNatural (Number (-1)) --- Error "parse failed, Natural: expected non-negative integer" -{-# INLINE parseJsonNatural #-} -parseJsonNatural :: - Value -> - Parser Natural -parseJsonNatural v = - parseJSON v >>= \n -> - if n < 0 - then fail "parse failed, Natural: expected non-negative integer" - else pure (Natural n) - --- | Serialises a 'ProductNatural' to a JSON number. --- --- >>> encode (ProductNatural (Natural 12)) --- "12" -instance ToJSON ProductNatural where - toJSON = - toJsonNatural - toEncoding (ProductNatural n) = - toEncoding n - --- | Parses a 'ProductNatural' from a JSON number, failing on negative values. --- --- >>> decode "12" :: Maybe ProductNatural --- Just (ProductNatural (Natural 12)) --- --- >>> decode "-1" :: Maybe ProductNatural --- Nothing -instance FromJSON ProductNatural where - parseJSON v = - parseJsonNatural v >>= \n -> pure (ProductNatural n) - --- | Serialises a 'MaxNatural' to a JSON number. --- --- >>> encode (MaxNatural (Natural 7)) --- "7" -instance ToJSON MaxNatural where - toJSON = - toJsonNatural - toEncoding (MaxNatural n) = - toEncoding n - --- | Parses a 'MaxNatural' from a JSON number, failing on negative values. --- --- >>> decode "7" :: Maybe MaxNatural --- Just (MaxNatural (Natural 7)) --- --- >>> decode "-1" :: Maybe MaxNatural --- Nothing -instance FromJSON MaxNatural where - parseJSON v = - parseJsonNatural v >>= \n -> pure (MaxNatural n) - --- | Serialises a 'MinNatural' to a JSON number. --- --- >>> encode (MinNatural (Natural 3)) --- "3" -instance ToJSON MinNatural where - toJSON = - toJsonNatural - toEncoding (MinNatural n) = - toEncoding n - --- | Parses a 'MinNatural' from a JSON number, failing on negative values. --- --- >>> decode "3" :: Maybe MinNatural --- Just (MinNatural (Natural 3)) --- --- >>> decode "-1" :: Maybe MinNatural --- Nothing -instance FromJSON MinNatural where - parseJSON v = - parseJsonNatural v >>= \n -> pure (MinNatural n) - --- | A prism for the zero natural number. --- --- >>> zero # () --- Natural 0 --- --- >>> Natural 0 ^? zero --- Just () --- --- >>> Natural 5 ^? zero --- Nothing -zero :: - Prism' - Natural - () -zero = - prism' - (\() -> Natural 0) - (\(Natural n) -> if n == 0 then Just () else Nothing) - --- | The zero natural number. --- --- >>> zero' --- Natural 0 -zero' :: - Natural -zero' = - zero # () - --- | A prism for the successor of a natural number. --- --- >>> successor # Natural 0 --- Natural 1 --- --- >>> successor # Natural 4 --- Natural 5 --- --- >>> Natural 5 ^? successor --- Just (Natural 4) --- --- >>> Natural 0 ^? successor --- Nothing -successor :: - Prism' - Natural - Natural -successor = - prism' - (\(Natural n) -> Natural (n + 1)) - (\(Natural n) -> if n == 0 then Nothing else Just (Natural (n - 1))) - --- | The successor of a natural number. --- --- >>> successor' (Natural 0) --- Natural 1 --- --- >>> successor' (Natural 4) --- Natural 5 -successor' :: - Natural -> - Natural -successor' = - (successor #) - --- | Add two natural numbers. --- --- >>> plus (Natural 3) (Natural 4) --- Natural 7 --- --- >>> plus (Natural 0) (Natural 5) --- Natural 5 -plus :: - Natural -> - Natural -> - Natural -plus = - (<>) - --- | Multiply two natural numbers. --- --- >>> multiply (Natural 3) (Natural 4) --- Natural 12 --- --- >>> multiply (Natural 0) (Natural 5) --- Natural 0 -multiply :: - Natural -> - Natural -> - Natural -multiply x y = - (_Wrapped # x <> (_Wrapped # y :: ProductNatural)) ^. _Wrapped - --- | Raise a natural number to a power. --- --- >>> power (Natural 2) (Natural 10) --- Natural 1024 --- --- >>> power (Natural 5) (Natural 0) --- Natural 1 -power :: - Natural -> - Natural -> - Natural -power (Natural x) (Natural y) = - Natural (x ^ y) - --- | Convert to 'Natural', defaulting to zero if the value is not a valid natural. --- --- >>> zeroOr (5 :: Integer) --- Natural 5 --- --- >>> zeroOr (-1 :: Integer) --- Natural 0 -zeroOr :: - (AsNatural a) => - a -> - Natural -zeroOr n = - fromMaybe zero' (n ^? _Natural) - --- | The length of a foldable structure as a 'Natural'. --- --- >>> length [1, 2, 3 :: Int] --- Natural 3 --- --- >>> length ([] :: [Int]) --- Natural 0 -length :: - (Foldable f) => - f a -> - Natural -length = - foldl (const . successor') zero' - --- | Replicate a value a natural number of times. --- --- >>> replicate (Natural 3) 'x' --- "xxx" --- --- >>> replicate (Natural 0) 'x' --- "" -replicate :: - Natural -> - a -> - [a] -replicate n = - take n . repeat - --- | Take a natural number of elements from a list. --- --- >>> take (Natural 2) [1, 2, 3 :: Int] --- [1,2] --- --- >>> take (Natural 0) [1, 2, 3 :: Int] --- [] --- --- >>> take (Natural 5) [1, 2, 3 :: Int] --- [1,2,3] -take :: - Natural -> - [a] -> - [a] -take _ [] = - [] -take n (h : t) = - case n ^? successor of - Nothing -> - [] - Just p -> - h : take p t - --- | Drop a natural number of elements from a list. --- --- >>> drop (Natural 2) [1, 2, 3, 4 :: Int] --- [3,4] --- --- >>> drop (Natural 0) [1, 2, 3 :: Int] --- [1,2,3] --- --- >>> drop (Natural 5) [1, 2, 3 :: Int] --- [] -drop :: - Natural -> - [a] -> - [a] -drop _ [] = - [] -drop n (h : t) = - case n ^? successor of - Nothing -> - h : t - Just p -> - drop p t - --- | Split a list at a natural index. --- --- >>> splitAt (Natural 2) [1, 2, 3, 4 :: Int] --- ([1,2],[3,4]) --- --- >>> splitAt (Natural 0) [1, 2, 3 :: Int] --- ([],[1,2,3]) --- --- >>> splitAt (Natural 5) [1, 2, 3 :: Int] --- ([1,2,3],[]) -splitAt :: - Natural -> - [a] -> - ([a], [a]) -splitAt n x = - (take n x, drop n x) - --- | Safe list indexing by 'Natural'. --- --- >>> ([] :: [Int]) !! Natural 0 --- Nothing --- --- >>> [1, 2, 3 :: Int] !! Natural 0 --- Just 1 -(!!) :: - [a] -> - Natural -> - Maybe a -[] !! _ = - Nothing -(h : t) !! n = case n ^? successor of - Nothing -> Just h - Just p -> t !! p - --- | Find all indices where a predicate holds. --- --- >>> findIndices (== 'a') "abacus" --- [Natural 0,Natural 2] --- --- >>> findIndices (== 'z') "abc" --- [] -findIndices :: - (a -> Bool) -> - [a] -> - [Natural] -findIndices p x = - map snd (filter (p . fst) (zip x (iterate successor' zero'))) - --- | Find the first index where a predicate holds. --- --- >>> findIndex (== 'a') "banana" --- Just (Natural 1) --- --- >>> findIndex (== 'z') "banana" --- Nothing -findIndex :: - (a -> Bool) -> - [a] -> - Maybe Natural -findIndex p = - listToMaybe . findIndices p - --- | Find all indices of an element. --- --- >>> elemIndices 'a' "abacus" --- [Natural 0,Natural 2] --- --- >>> elemIndices 'z' "abc" --- [] -elemIndices :: - (Eq a) => - a -> - [a] -> - [Natural] -elemIndices = - findIndices . (==) - --- | Find the first index of an element. --- --- >>> elemIndex 'a' "banana" --- Just (Natural 1) --- --- >>> elemIndex 'z' "banana" --- Nothing -elemIndex :: - (Eq a) => - a -> - [a] -> - Maybe Natural -elemIndex = - findIndex . (==) - --- | Subtract two natural numbers, flooring at zero. --- --- >>> minus (Natural 5) (Natural 3) --- Natural 2 --- --- >>> minus (Natural 3) (Natural 5) --- Natural 0 -minus :: - Natural -> - Natural -> - Natural -minus (Natural x) (Natural y) = - Natural (if x < y then 0 else x - y) - --- | An isomorphism between 'Natural' and @[()]@. --- --- >>> Natural 3 ^. list --- [(),(),()] --- --- >>> Natural 0 ^. list --- [] --- --- >>> list # [(), (), ()] --- Natural 3 -list :: - Iso' - Natural - [()] -list = - iso - (`replicate` ()) - length - ----- - --- | A positive integer (strictly positive: 1, 2, 3, ...). --- --- >>> Positive 1 --- Positive 1 --- --- >>> Positive 42 --- Positive 42 -newtype Positive - = Positive - Integer - deriving (Eq, Ord, Show) - --- | Positive numbers form a semigroup under addition. --- --- >>> Positive 3 <> Positive 4 --- Positive 7 -instance Semigroup Positive where - Positive x <> Positive y = - Positive (x + y) - --- | Typeclass for types that have a 'Positive' lens. --- --- >>> Positive 5 ^. positive --- Positive 5 -class HasPositive a where - positive :: - Lens' - a - Positive - --- | >>> Positive 5 ^. positive --- Positive 5 -instance HasPositive Positive where - positive = - id - --- | Typeclass for types that can be converted to/from 'Positive' via a prism. --- --- >>> (5 :: Integer) ^? _Positive --- Just (Positive 5) --- --- >>> (0 :: Integer) ^? _Positive --- Nothing -class AsPositive a where - _Positive :: - Prism' - a - Positive - --- | >>> Positive 5 ^? _Positive --- Just (Positive 5) -instance AsPositive Positive where - _Positive = - id - --- | Prism for converting an integral value to a 'Positive'. --- --- >>> (5 :: Integer) ^? integralPrism1 --- Just (Positive 5) --- --- >>> (0 :: Integer) ^? integralPrism1 --- Nothing -integralPrism1 :: - (Integral a) => - Prism' - a - Positive -integralPrism1 = - prism' - (\(Positive n) -> fromIntegral n) - (\n -> if n < 1 then Nothing else Just (Positive (fromIntegral n))) - --- | >>> (5 :: Int) ^? _Positive --- Just (Positive 5) --- --- >>> (0 :: Int) ^? _Positive --- Nothing -instance AsPositive Int where - _Positive = - integralPrism1 - --- | >>> (5 :: Integer) ^? _Positive --- Just (Positive 5) --- --- >>> (0 :: Integer) ^? _Positive --- Nothing -instance AsPositive Integer where - _Positive = - integralPrism1 - --- | >>> (5 :: Word) ^? _Positive --- Just (Positive 5) --- --- >>> (0 :: Word) ^? _Positive --- Nothing -instance AsPositive Word where - _Positive = - integralPrism1 - --- | >>> (Const 5 :: Const Integer Bool) ^? _Positive --- Just (Positive 5) -instance (Integral a) => AsPositive (Const a b) where - _Positive = - integralPrism1 - --- | >>> (Identity 5 :: Identity Integer) ^? _Positive --- Just (Positive 5) -instance (Integral a) => AsPositive (Identity a) where - _Positive = - integralPrism1 - --- | Positive numbers under addition. --- --- >>> SumPositive (Positive 3) <> SumPositive (Positive 4) --- SumPositive (Positive 7) -newtype SumPositive - = SumPositive - Positive - deriving (Eq, Ord, Show) - --- | >>> SumPositive (Positive 5) ^. positive --- Positive 5 -instance HasPositive SumPositive where - positive = - _Wrapped . positive - --- | >>> SumPositive (Positive 5) ^? _Positive --- Just (Positive 5) -instance AsPositive SumPositive where - _Positive = - _Wrapped . _Positive - -instance - (SumPositive ~ a) => - Rewrapped SumPositive a - --- | >>> SumPositive (Positive 5) ^. _Wrapped' --- Positive 5 -instance Wrapped SumPositive where - type Unwrapped SumPositive = Positive - _Wrapped' = - iso - (\(SumPositive x) -> x) - SumPositive - --- | >>> SumPositive (Positive 3) <> SumPositive (Positive 4) --- SumPositive (Positive 7) -instance Semigroup SumPositive where - SumPositive (Positive x) <> SumPositive (Positive y) = - SumPositive (Positive (x + y)) - --- | Positive numbers under maximum. --- --- >>> MaxPositive (Positive 3) <> MaxPositive (Positive 7) --- MaxPositive (Positive 7) -newtype MaxPositive - = MaxPositive - Positive - deriving (Eq, Ord, Show) - --- | >>> MaxPositive (Positive 5) ^. positive --- Positive 5 -instance HasPositive MaxPositive where - positive = - _Wrapped . positive - --- | >>> MaxPositive (Positive 5) ^? _Positive --- Just (Positive 5) -instance AsPositive MaxPositive where - _Positive = - _Wrapped . _Positive - -instance - (MaxPositive ~ a) => - Rewrapped MaxPositive a - --- | >>> MaxPositive (Positive 5) ^. _Wrapped' --- Positive 5 -instance Wrapped MaxPositive where - type Unwrapped MaxPositive = Positive - _Wrapped' = - iso - (\(MaxPositive x) -> x) - MaxPositive - --- | >>> MaxPositive (Positive 3) <> MaxPositive (Positive 7) --- MaxPositive (Positive 7) -instance Semigroup MaxPositive where - MaxPositive (Positive x) <> MaxPositive (Positive y) = - MaxPositive (Positive (x `max` y)) - --- | Positive numbers under minimum. --- --- >>> MinPositive (Positive 3) <> MinPositive (Positive 7) --- MinPositive (Positive 3) -newtype MinPositive - = MinPositive - Positive - deriving (Eq, Ord, Show) - --- | >>> MinPositive (Positive 5) ^. positive --- Positive 5 -instance HasPositive MinPositive where - positive = - _Wrapped . positive - --- | >>> MinPositive (Positive 5) ^? _Positive --- Just (Positive 5) -instance AsPositive MinPositive where - _Positive = - _Wrapped . _Positive - -instance - (MinPositive ~ a) => - Rewrapped MinPositive a - --- | >>> MinPositive (Positive 5) ^. _Wrapped' --- Positive 5 -instance Wrapped MinPositive where - type Unwrapped MinPositive = Positive - _Wrapped' = - iso - (\(MinPositive x) -> x) - MinPositive - --- | >>> MinPositive (Positive 3) <> MinPositive (Positive 7) --- MinPositive (Positive 3) -instance Semigroup MinPositive where - MinPositive (Positive x) <> MinPositive (Positive y) = - MinPositive (Positive (x `min` y)) - --- | Serialises a 'Positive' to a JSON number. --- --- >>> toJSON (Positive 1) --- Number 1.0 --- --- >>> toJSON (Positive 42) --- Number 42.0 --- --- >>> encode (Positive 1) --- "1" --- --- >>> encode (Positive 42) --- "42" -instance ToJSON Positive where - toJSON = - toJsonPositive - toEncoding (Positive n) = - toEncoding n - --- | Serialises any value with a 'HasPositive' instance to a JSON 'Value'. --- --- >>> toJsonPositive (Positive 42) --- Number 42.0 --- --- >>> toJsonPositive (SumPositive (Positive 7)) --- Number 7.0 --- --- >>> toJsonPositive (MaxPositive (Positive 7)) --- Number 7.0 --- --- >>> toJsonPositive (MinPositive (Positive 3)) --- Number 3.0 -{-# SPECIALIZE toJsonPositive :: - Positive -> - Value - #-} -{-# INLINE toJsonPositive #-} -toJsonPositive :: - (HasPositive a) => - a -> - Value -toJsonPositive a = - let Positive n = view positive a - in toJSON n - --- | Parses a 'Positive' from a JSON number, failing on non-positive values. --- --- >>> fromJSON (Number 1) :: Result Positive --- Success (Positive 1) --- --- >>> fromJSON (Number 42) :: Result Positive --- Success (Positive 42) --- --- >>> decode "42" :: Maybe Positive --- Just (Positive 42) --- --- >>> decode "1" :: Maybe Positive --- Just (Positive 1) --- --- >>> decode "0" :: Maybe Positive --- Nothing --- --- >>> decode "-1" :: Maybe Positive --- Nothing -instance FromJSON Positive where - parseJSON = - parseJsonPositive - --- | Parses a JSON value into a 'Positive', failing on non-positive values. --- --- >>> parse parseJsonPositive (Number 42) --- Success (Positive 42) --- --- >>> parse parseJsonPositive (Number 1) --- Success (Positive 1) --- --- >>> parse parseJsonPositive (Number 0) --- Error "parse failed, Positive: expected positive integer" --- --- >>> parse parseJsonPositive (Number (-1)) --- Error "parse failed, Positive: expected positive integer" -{-# INLINE parseJsonPositive #-} -parseJsonPositive :: - Value -> - Parser Positive -parseJsonPositive v = - parseJSON v >>= \n -> - if n < 1 - then fail "parse failed, Positive: expected positive integer" - else pure (Positive n) - --- | Serialises a 'SumPositive' to a JSON number. --- --- >>> encode (SumPositive (Positive 7)) --- "7" -instance ToJSON SumPositive where - toJSON = - toJsonPositive - toEncoding (SumPositive n) = - toEncoding n - --- | Parses a 'SumPositive' from a JSON number, failing on non-positive values. --- --- >>> decode "7" :: Maybe SumPositive --- Just (SumPositive (Positive 7)) --- --- >>> decode "0" :: Maybe SumPositive --- Nothing -instance FromJSON SumPositive where - parseJSON v = - parseJsonPositive v >>= \n -> pure (SumPositive n) - --- | Serialises a 'MaxPositive' to a JSON number. --- --- >>> encode (MaxPositive (Positive 7)) --- "7" -instance ToJSON MaxPositive where - toJSON = - toJsonPositive - toEncoding (MaxPositive n) = - toEncoding n - --- | Parses a 'MaxPositive' from a JSON number, failing on non-positive values. --- --- >>> decode "7" :: Maybe MaxPositive --- Just (MaxPositive (Positive 7)) --- --- >>> decode "0" :: Maybe MaxPositive --- Nothing -instance FromJSON MaxPositive where - parseJSON v = - parseJsonPositive v >>= \n -> pure (MaxPositive n) - --- | Serialises a 'MinPositive' to a JSON number. --- --- >>> encode (MinPositive (Positive 3)) --- "3" -instance ToJSON MinPositive where - toJSON = - toJsonPositive - toEncoding (MinPositive n) = - toEncoding n - --- | Parses a 'MinPositive' from a JSON number, failing on non-positive values. --- --- >>> decode "3" :: Maybe MinPositive --- Just (MinPositive (Positive 3)) --- --- >>> decode "0" :: Maybe MinPositive --- Nothing -instance FromJSON MinPositive where - parseJSON v = - parseJsonPositive v >>= \n -> pure (MinPositive n) - --- | An isomorphism between 'Natural' and 'Maybe Positive'. --- --- >>> Natural 0 ^. naturalPositive --- Nothing --- --- >>> Natural 5 ^. naturalPositive --- Just (Positive 5) --- --- >>> naturalPositive # Nothing --- Natural 0 --- --- >>> naturalPositive # Just (Positive 3) --- Natural 3 -naturalPositive :: - Iso' Natural (Maybe Positive) -naturalPositive = - iso - ( \(Natural n) -> - if n == 0 then Nothing else Just (Positive n) - ) - ( \x -> - Natural - ( case x of - Nothing -> - 0 - Just (Positive n) -> - n - ) - ) - --- | >>> Natural 5 ^? _Positive --- Just (Positive 5) --- --- >>> Natural 0 ^? _Positive --- Nothing -instance AsPositive Natural where - _Positive = - prism' - (\(Positive n) -> Natural n) - (\(Natural n) -> if n == 0 then Nothing else Just (Positive n)) - --- | A prism for the value one. --- --- >>> one # () --- Positive 1 --- --- >>> Positive 1 ^? one --- Just () --- --- >>> Positive 5 ^? one --- Nothing -one :: - Prism' - Positive - () -one = - prism' - (\() -> Positive 1) - (\(Positive n) -> if n == 1 then Just () else Nothing) - --- | The positive number one. --- --- >>> one' --- Positive 1 -one' :: - Positive -one' = - one # () - --- | A prism for the successor of a positive number. --- --- >>> successor1 # Positive 1 --- Positive 2 --- --- >>> successor1 # Positive 4 --- Positive 5 --- --- >>> Positive 5 ^? successor1 --- Just (Positive 4) --- --- >>> Positive 1 ^? successor1 --- Nothing -successor1 :: - Prism' - Positive - Positive -successor1 = - prism' - (\(Positive n) -> Positive (n + 1)) - (\(Positive n) -> if n == 1 then Nothing else Just (Positive (n - 1))) - --- | The successor of a positive number. --- --- >>> successor1' (Positive 1) --- Positive 2 --- --- >>> successor1' (Positive 4) --- Positive 5 -successor1' :: - Positive -> - Positive -successor1' = - (successor1 #) - --- | An isomorphism between 'Natural' and 'Positive' by adding/subtracting one. --- --- >>> Natural 0 ^. successorW --- Positive 1 --- --- >>> Natural 4 ^. successorW --- Positive 5 --- --- >>> successorW # Positive 1 --- Natural 0 --- --- >>> successorW # Positive 5 --- Natural 4 -successorW :: - Iso' - Natural - Positive -successorW = - iso - (\(Natural n) -> Positive (n + 1)) - (\(Positive n) -> Natural (n - 1)) - --- | Add two positive numbers. --- --- >>> plus1 (Positive 3) (Positive 4) --- Positive 7 --- --- >>> plus1 (Positive 1) (Positive 1) --- Positive 2 -plus1 :: - Positive -> - Positive -> - Positive -plus1 x y = - (_Wrapped # x <> (_Wrapped # y :: SumPositive)) ^. _Wrapped - --- | Multiply two positive numbers. --- --- >>> multiply1 (Positive 2) (Positive 2) --- Positive 4 --- --- >>> multiply1 (Positive 3) (Positive 4) --- Positive 12 -multiply1 :: - Positive -> - Positive -> - Positive -multiply1 (Positive x) (Positive y) = - Positive (x * y) - --- | Raise a positive number to a power. --- --- >>> power1 (Positive 2) (Positive 10) --- Positive 1024 --- --- >>> power1 (Positive 5) (Positive 1) --- Positive 5 -power1 :: - Positive -> - Positive -> - Positive -power1 (Positive x) (Positive y) = - Positive (x ^ y) - --- | Convert to 'Positive', defaulting to one if the value is not a valid positive. --- --- >>> oneOr (5 :: Integer) --- Positive 5 --- --- >>> oneOr (0 :: Integer) --- Positive 1 -oneOr :: - (AsPositive a) => - a -> - Positive -oneOr n = - fromMaybe one' (n ^? _Positive) - --- | A prism from 'Natural' to 'Positive', succeeding when the natural is not zero. --- --- >>> notZero # Positive 5 --- Natural 5 --- --- >>> Natural 5 ^? notZero --- Just (Positive 5) --- --- >>> Natural 0 ^? notZero --- Nothing -notZero :: - Prism' - Natural - Positive -notZero = - prism' - (\(Positive n) -> Natural n) - (\(Natural n) -> if n == 0 then Nothing else Just (Positive n)) - --- | The length of a non-empty foldable structure as a 'Positive'. --- --- >>> length1 (1 :| [2, 3 :: Int]) --- Positive 3 --- --- >>> length1 (1 :| ([] :: [Int])) --- Positive 1 -length1 :: - (Foldable1 f) => - f a -> - Positive -length1 x = - foldMap1 (const (SumPositive one')) x ^. _Wrapped - --- | Replicate a value a positive number of times into a 'NonEmpty'. --- --- >>> replicate1 (Positive 3) 'x' --- 'x' :| "xx" --- --- >>> replicate1 (Positive 1) 'x' --- 'x' :| "" -replicate1 :: - Positive -> - a -> - NonEmpty a -replicate1 n a = - take1 n (a :| repeat a) - --- | Take a positive number of elements from a 'NonEmpty'. --- --- >>> take1 (Positive 2) (1 :| [2, 3 :: Int]) --- 1 :| [2] --- --- >>> take1 (Positive 1) (1 :| [2, 3 :: Int]) --- 1 :| [] -take1 :: - Positive -> - NonEmpty a -> - NonEmpty a -take1 n (h :| t) = - h :| take (successorW # n) t - --- | Drop a positive number of elements from a 'NonEmpty'. --- --- >>> drop1 (Positive 1) (1 :| [2, 3 :: Int]) --- [2,3] --- --- >>> drop1 (Positive 2) (1 :| [2, 3 :: Int]) --- [3] -drop1 :: - Positive -> - NonEmpty a -> - [a] -drop1 n (_ :| t) = - drop (successorW # n) t - --- | Split a 'NonEmpty' at a positive index. --- --- >>> splitAt1 (Positive 2) (1 :| [2, 3, 4 :: Int]) --- (1 :| [2],[3,4]) --- --- >>> splitAt1 (Positive 1) (1 :| [2, 3, 4 :: Int]) --- (1 :| [],[2,3,4]) -splitAt1 :: - Positive -> - NonEmpty a -> - (NonEmpty a, [a]) -splitAt1 n x = - (take1 n x, drop1 n x) - --- | Safe indexing into a 'NonEmpty' by 'Positive'. --- --- >>> (1 :| []) !!! Positive 1 --- Just 1 --- --- >>> (1 :| [2, 3 :: Int]) !!! Positive 1 --- Just 1 --- --- >>> (1 :| [2, 3 :: Int]) !!! Positive 4 --- Nothing -(!!!) :: - NonEmpty a -> - Positive -> - Maybe a -(h :| t) !!! n = - (h : t) !! (successorW # n) - --- | Find all indices where a predicate holds in a 'NonEmpty'. --- --- >>> findIndices1 (== 'a') ('a' :| "bac") --- [Positive 1,Positive 3] --- --- >>> findIndices1 (== 'z') ('a' :| "bc") --- [] -findIndices1 :: - (a -> Bool) -> - NonEmpty a -> - [Positive] -findIndices1 p x = - map snd (NonEmpty.filter (p . fst) (NonEmpty.zip x (NonEmpty.iterate successor1' one'))) - --- | Find the first index where a predicate holds in a 'NonEmpty'. --- --- >>> findIndex1 (== 'a') ('b' :| "ana") --- Just (Positive 2) --- --- >>> findIndex1 (== 'z') ('b' :| "ana") --- Nothing -findIndex1 :: - (a -> Bool) -> - NonEmpty a -> - Maybe Positive -findIndex1 p = - listToMaybe . findIndices1 p - --- | Find all indices of an element in a 'NonEmpty'. --- --- >>> elemIndices1 'a' ('a' :| "bac") --- [Positive 1,Positive 3] --- --- >>> elemIndices1 'z' ('a' :| "bc") --- [] -elemIndices1 :: - (Eq a) => - a -> - NonEmpty a -> - [Positive] -elemIndices1 = - findIndices1 . (==) - --- | Find the first index of an element in a 'NonEmpty'. --- --- >>> elemIndex1 'a' ('b' :| "ana") --- Just (Positive 2) --- --- >>> elemIndex1 'z' ('b' :| "ana") --- Nothing -elemIndex1 :: - (Eq a) => - a -> - NonEmpty a -> - Maybe Positive -elemIndex1 = - findIndex1 . (==) - --- | Subtract two positive numbers, flooring at one. --- --- >>> minus1 (Positive 5) (Positive 3) --- Positive 2 --- --- >>> minus1 (Positive 3) (Positive 5) --- Positive 1 -minus1 :: - Positive -> - Positive -> - Positive -minus1 (Positive x) (Positive y) = - Positive (if x <= y then 1 else x - y) - --- | An isomorphism between 'Positive' and @'NonEmpty' ()@. --- --- >>> Positive 3 ^. list1 --- () :| [(),()] --- --- >>> Positive 1 ^. list1 --- () :| [] --- --- >>> list1 # (() :| [()]) --- Positive 2 -list1 :: - Iso' - Positive - (NonEmpty ()) -list1 = - iso - (`replicate1` ()) - length1 - --- | Convert a 'Natural' to its successor 'Positive'. --- --- >>> plusone (Natural 0) --- Positive 1 --- --- >>> plusone (Natural 4) --- Positive 5 -plusone :: - Natural -> - Positive -plusone = - (^. successorW) - --- | Convert a 'Positive' to its predecessor 'Natural'. --- --- >>> minusone (Positive 1) --- Natural 0 --- --- >>> minusone (Positive 5) --- Natural 4 -minusone :: - Positive -> - Natural -minusone = - (successorW #) + zero, + zero', + successor, + successor', + plus, + multiply, + power, + zeroOr, + length, + replicate, + take, + drop, + splitAt, + (!!), + findIndices, + findIndex, + elemIndices, + elemIndex, + minus, + list, + Positive, + HasPositive (..), + AsPositive (..), + SumPositive (..), + MaxPositive (..), + MinPositive (..), + naturalPositive, + one, + one', + successor1, + successor1', + successorW, + plus1, + multiply1, + power1, + oneOr, + length1, + replicate1, + take1, + drop1, + splitAt1, + (!!!), + findIndices1, + findIndex1, + elemIndices1, + elemIndex1, + minus1, + list1, + plusone, + minusone, + NotZero (..), + HasNotZero (..), + AsNotZero (..), + SumNotZero (..), + MaxNotZero (..), + MinNotZero (..), + positiveNotZero, + negativeNotZero, + notZeroPositive, + notZeroInteger, + isPositive, + isNegative, + negateNZ, + absoluteNZ, + signumNZ, + plusNZ, + multiplyNZ, + notZeroOr, + toJsonNatural, + parseJsonNatural, + toJsonPositive, + parseJsonPositive, + toJsonNotZero, + parseJsonNotZero, + ) +where + +import Control.Applicative (Const, pure) +import Control.Category (id, (.)) +import Control.Lens (Iso', Lens', Prism', Rewrapped, Wrapped (Unwrapped, _Wrapped'), iso, prism', (#), (^.), (^?), _Wrapped) +import Control.Monad (fail, (>>=)) +import Data.Aeson.Types + ( FromJSON (parseJSON), + Parser, + ToJSON (toEncoding, toJSON), + Value, + ) +import Data.Bool (Bool (False, True), not, (&&)) +import Data.Eq (Eq ((==))) +import Data.Foldable (Foldable (foldl')) +import Data.Function (const) +import Data.Functor.Identity (Identity) +import Data.Int (Int) +import Data.List (filter, iterate, map, repeat, zip) +import Data.List.NonEmpty (NonEmpty ((:|))) +import qualified Data.List.NonEmpty as NonEmpty (filter, iterate, zip) +import Data.Maybe (Maybe (Just, Nothing), fromMaybe, listToMaybe) +import Data.Monoid (Monoid (mappend, mempty)) +import Data.Ord (Ord (compare, (<), (<=)), max, min) +import Data.Semigroup (Semigroup ((<>))) +import Data.Semigroup.Foldable (Foldable1 (foldMap1)) +import Data.Tuple (fst, snd) +import Data.Word (Word) +import Prelude (Integer, Integral, Show, abs, fromIntegral, negate, (*), (+), (-), (^)) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Control.Lens((^?), (^.), (#), _Wrapped', _Wrapped) +-- >>> import Data.Aeson(encode, decode, fromJSON, Result(..)) +-- >>> import Data.Aeson.Types(parse, Value(Number)) +-- >>> import Data.List.NonEmpty(NonEmpty(..)) +-- >>> import Data.Maybe(fromJust) +-- >>> let nat n = fromJust ((n :: Integer) ^? _Natural) +-- >>> let pos n = fromJust ((n :: Integer) ^? _Positive) + +-- | A natural number (>= 0) represented as a newtype over 'Integer'. +-- +-- >>> nat 0 +-- Natural 0 +-- +-- >>> nat 5 +-- Natural 5 +newtype Natural + = Natural + Integer + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> nat 3 <> nat 4 +-- Natural 7 +-- +-- >>> nat 0 <> nat 5 +-- Natural 5 +instance Semigroup Natural where + Natural x <> Natural y = + Natural (x + y) + +-- | +-- +-- >>> mempty :: Natural +-- Natural 0 +instance Monoid Natural where + mappend = + (<>) + mempty = + Natural 0 + +class HasNatural a where + natural :: + Lens' + a + Natural + +-- | +-- +-- >>> (nat 5) ^. natural +-- Natural 5 +instance HasNatural Natural where + natural = + id + +class AsNatural a where + _Natural :: + Prism' + a + Natural + +-- | +-- +-- >>> _Natural # nat 5 :: Natural +-- Natural 5 +instance AsNatural Natural where + _Natural = + id + +integralPrism :: + (Integral a) => + Prism' + a + Natural +integralPrism = + prism' + (\(Natural n) -> fromIntegral n) + (\n -> if n < 0 then Nothing else Just (Natural (fromIntegral n))) + +-- | +-- +-- >>> (5 :: Int) ^? _Natural +-- Just (Natural 5) +-- +-- >>> (-1 :: Int) ^? _Natural +-- Nothing +instance AsNatural Int where + _Natural = + integralPrism + +-- | +-- +-- >>> (42 :: Integer) ^? _Natural +-- Just (Natural 42) +-- +-- >>> (-1 :: Integer) ^? _Natural +-- Nothing +instance AsNatural Integer where + _Natural = + integralPrism + +-- | +-- +-- >>> (7 :: Word) ^? _Natural +-- Just (Natural 7) +instance AsNatural Word where + _Natural = + integralPrism + +-- | +-- +-- >>> import Data.Functor.Identity(Identity(..)) +-- >>> import Control.Applicative(Const(..)) +-- >>> (Const 5 :: Const Integer Bool) ^? _Natural +-- Just (Natural 5) +instance (Integral a) => AsNatural (Const a b) where + _Natural = + integralPrism + +-- | +-- +-- >>> import Data.Functor.Identity(Identity(..)) +-- >>> (Identity 5 :: Identity Integer) ^? _Natural +-- Just (Natural 5) +instance (Integral a) => AsNatural (Identity a) where + _Natural = + integralPrism + +-- | +-- +-- >>> ProductNatural (nat 3) <> ProductNatural (nat 4) +-- ProductNatural (Natural 12) +-- +-- >>> mempty :: ProductNatural +-- ProductNatural (Natural 1) +newtype ProductNatural + = ProductNatural + Natural + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> ProductNatural (nat 5) ^. natural +-- Natural 5 +instance HasNatural ProductNatural where + natural = + _Wrapped . natural + +-- | +-- +-- >>> ProductNatural (nat 5) ^? _Natural +-- Just (Natural 5) +instance AsNatural ProductNatural where + _Natural = + _Wrapped . _Natural + +instance + (ProductNatural ~ a) => + Rewrapped ProductNatural a + +-- | +-- +-- >>> ProductNatural (nat 5) ^. _Wrapped' +-- Natural 5 +instance Wrapped ProductNatural where + type Unwrapped ProductNatural = Natural + _Wrapped' = + iso + (\(ProductNatural x) -> x) + ProductNatural + +-- | +-- +-- >>> ProductNatural (nat 3) <> ProductNatural (nat 4) +-- ProductNatural (Natural 12) +instance Semigroup ProductNatural where + ProductNatural (Natural x) <> ProductNatural (Natural y) = + ProductNatural (Natural (x * y)) + +-- | +-- +-- >>> mempty :: ProductNatural +-- ProductNatural (Natural 1) +instance Monoid ProductNatural where + mappend = + (<>) + mempty = + ProductNatural (Natural 1) + +-- | +-- +-- >>> MaxNatural (nat 3) <> MaxNatural (nat 7) +-- MaxNatural (Natural 7) +newtype MaxNatural + = MaxNatural + Natural + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> MaxNatural (nat 7) ^. natural +-- Natural 7 +instance HasNatural MaxNatural where + natural = + _Wrapped . natural + +-- | +-- +-- >>> MaxNatural (nat 7) ^? _Natural +-- Just (Natural 7) +instance AsNatural MaxNatural where + _Natural = + _Wrapped . _Natural + +instance + (MaxNatural ~ a) => + Rewrapped MaxNatural a + +-- | +-- +-- >>> MaxNatural (nat 7) ^. _Wrapped' +-- Natural 7 +instance Wrapped MaxNatural where + type Unwrapped MaxNatural = Natural + _Wrapped' = + iso + (\(MaxNatural x) -> x) + MaxNatural + +-- | +-- +-- >>> MaxNatural (nat 3) <> MaxNatural (nat 7) +-- MaxNatural (Natural 7) +instance Semigroup MaxNatural where + MaxNatural (Natural x) <> MaxNatural (Natural y) = + MaxNatural (Natural (x `max` y)) + +-- | +-- +-- >>> MinNatural (nat 3) <> MinNatural (nat 7) +-- MinNatural (Natural 3) +newtype MinNatural + = MinNatural + Natural + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> MinNatural (nat 3) ^. natural +-- Natural 3 +instance HasNatural MinNatural where + natural = + _Wrapped . natural + +-- | +-- +-- >>> MinNatural (nat 3) ^? _Natural +-- Just (Natural 3) +instance AsNatural MinNatural where + _Natural = + _Wrapped . _Natural + +instance + (MinNatural ~ a) => + Rewrapped MinNatural a + +-- | +-- +-- >>> MinNatural (nat 3) ^. _Wrapped' +-- Natural 3 +instance Wrapped MinNatural where + type Unwrapped MinNatural = Natural + _Wrapped' = + iso + (\(MinNatural x) -> x) + MinNatural + +-- | +-- +-- >>> MinNatural (nat 3) <> MinNatural (nat 7) +-- MinNatural (Natural 3) +instance Semigroup MinNatural where + MinNatural (Natural x) <> MinNatural (Natural y) = + MinNatural (Natural (x `min` y)) + +-- | Serialises a 'Natural' to a JSON number. +-- +-- >>> fromJSON (Number 0) :: Result Natural +-- Success (Natural 0) +-- +-- >>> fromJSON (Number 42) :: Result Natural +-- Success (Natural 42) +-- +-- >>> decode "42" :: Maybe Natural +-- Just (Natural 42) +-- +-- >>> decode "0" :: Maybe Natural +-- Just (Natural 0) +-- +-- >>> decode "-1" :: Maybe Natural +-- Nothing +instance ToJSON Natural where + toJSON = + toJsonNatural + toEncoding (Natural n) = + toEncoding n + +-- | Parses a 'Natural' from a JSON number, failing on negative values. +-- +-- >>> decode "0" :: Maybe Natural +-- Just (Natural 0) +instance FromJSON Natural where + parseJSON = + parseJsonNatural + +-- | Serialises any value with a 'HasNatural' instance to a JSON 'Value'. +-- +-- >>> toJsonNatural (nat 42) +-- Number 42.0 +-- +-- >>> toJsonNatural (ProductNatural (nat 12)) +-- Number 12.0 +-- +-- >>> toJsonNatural (MaxNatural (nat 7)) +-- Number 7.0 +-- +-- >>> toJsonNatural (MinNatural (nat 3)) +-- Number 3.0 +{-# SPECIALIZE toJsonNatural :: + Natural -> + Value + #-} +{-# INLINE toJsonNatural #-} +toJsonNatural :: + (HasNatural a) => + a -> + Value +toJsonNatural a = + let Natural n = a ^. natural + in toJSON n + +-- | Parses a JSON value into a 'Natural', failing on negative values. +-- +-- >>> parse parseJsonNatural (Number 42) +-- Success (Natural 42) +-- +-- >>> parse parseJsonNatural (Number 0) +-- Success (Natural 0) +-- +-- >>> parse parseJsonNatural (Number (-1)) +-- Error "parse failed, Natural: expected non-negative integer" +{-# INLINE parseJsonNatural #-} +parseJsonNatural :: + Value -> + Parser Natural +parseJsonNatural v = + parseJSON v >>= \n -> + if n < 0 + then fail "parse failed, Natural: expected non-negative integer" + else pure (Natural n) + +-- | Serialises a 'ProductNatural' to a JSON number. +-- +-- >>> encode (ProductNatural (nat 12)) +-- "12" +instance ToJSON ProductNatural where + toJSON = + toJsonNatural + toEncoding (ProductNatural n) = + toEncoding n + +-- | Parses a 'ProductNatural' from a JSON number, failing on negative values. +-- +-- >>> decode "12" :: Maybe ProductNatural +-- Just (ProductNatural (Natural 12)) +-- +-- >>> decode "-1" :: Maybe ProductNatural +-- Nothing +instance FromJSON ProductNatural where + parseJSON v = + parseJsonNatural v >>= \n -> pure (ProductNatural n) + +-- | Serialises a 'MaxNatural' to a JSON number. +-- +-- >>> encode (MaxNatural (nat 7)) +-- "7" +instance ToJSON MaxNatural where + toJSON = + toJsonNatural + toEncoding (MaxNatural n) = + toEncoding n + +-- | Parses a 'MaxNatural' from a JSON number, failing on negative values. +-- +-- >>> decode "7" :: Maybe MaxNatural +-- Just (MaxNatural (Natural 7)) +-- +-- >>> decode "-1" :: Maybe MaxNatural +-- Nothing +instance FromJSON MaxNatural where + parseJSON v = + parseJsonNatural v >>= \n -> pure (MaxNatural n) + +-- | Serialises a 'MinNatural' to a JSON number. +-- +-- >>> encode (MinNatural (nat 3)) +-- "3" +instance ToJSON MinNatural where + toJSON = + toJsonNatural + toEncoding (MinNatural n) = + toEncoding n + +-- | Parses a 'MinNatural' from a JSON number, failing on negative values. +-- +-- >>> decode "3" :: Maybe MinNatural +-- Just (MinNatural (Natural 3)) +-- +-- >>> decode "-1" :: Maybe MinNatural +-- Nothing +instance FromJSON MinNatural where + parseJSON v = + parseJsonNatural v >>= \n -> pure (MinNatural n) + +-- | Prism matching zero. +-- +-- >>> zero # () +-- Natural 0 +-- +-- >>> nat 0 ^? zero +-- Just () +-- +-- >>> nat 3 ^? zero +-- Nothing +zero :: + Prism' + Natural + () +zero = + prism' + (\() -> Natural 0) + (\(Natural n) -> if n == 0 then Just () else Nothing) + +-- | The zero natural number. +-- +-- >>> zero' +-- Natural 0 +zero' :: + Natural +zero' = + zero # () + +-- | Prism between a natural and its predecessor. +-- +-- >>> successor # nat 0 +-- Natural 1 +-- +-- >>> successor # nat 4 +-- Natural 5 +-- +-- >>> nat 5 ^? successor +-- Just (Natural 4) +-- +-- >>> nat 0 ^? successor +-- Nothing +successor :: + Prism' + Natural + Natural +successor = + prism' + (\(Natural n) -> Natural (n + 1)) + (\(Natural n) -> if n == 0 then Nothing else Just (Natural (n - 1))) + +-- | The successor of a natural number. +-- +-- >>> successor' (nat 0) +-- Natural 1 +-- +-- >>> successor' (nat 4) +-- Natural 5 +successor' :: + Natural -> + Natural +successor' = + (successor #) + +-- | Add two natural numbers. +-- +-- >>> plus (nat 3) (nat 4) +-- Natural 7 +-- +-- >>> plus (nat 0) (nat 5) +-- Natural 5 +plus :: + Natural -> + Natural -> + Natural +plus = + (<>) + +-- | Multiply two natural numbers. +-- +-- >>> multiply (nat 3) (nat 4) +-- Natural 12 +-- +-- >>> multiply (nat 0) (nat 5) +-- Natural 0 +multiply :: + Natural -> + Natural -> + Natural +multiply x y = + (_Wrapped # x <> (_Wrapped # y :: ProductNatural)) ^. _Wrapped + +-- | Raise a natural to a natural power. +-- +-- >>> power (nat 2) (nat 10) +-- Natural 1024 +-- +-- >>> power (nat 3) (nat 0) +-- Natural 1 +power :: + Natural -> + Natural -> + Natural +power (Natural x) (Natural y) = + Natural (x ^ y) + +-- | Return the natural if the prism matches, otherwise zero. +-- +-- >>> zeroOr (5 :: Integer) +-- Natural 5 +-- +-- >>> zeroOr (-1 :: Integer) +-- Natural 0 +zeroOr :: + (AsNatural a) => + a -> + Natural +zeroOr n = + fromMaybe zero' (n ^? _Natural) + +-- | Count the elements in a foldable structure. +-- +-- >>> length [1,2,3 :: Int] +-- Natural 3 +-- +-- >>> length ([] :: [Int]) +-- Natural 0 +length :: + (Foldable f) => + f a -> + Natural +length = + foldl' (const . successor') zero' + +-- | Replicate a value a natural number of times. +-- +-- >>> replicate (nat 3) 'x' +-- "xxx" +-- +-- >>> replicate (nat 0) 'x' +-- "" +replicate :: + Natural -> + a -> + [a] +replicate n = + take n . repeat + +-- | Take the first n elements. +-- +-- >>> take (nat 2) [1,2,3,4,5 :: Int] +-- [1,2] +-- +-- >>> take (nat 0) [1,2,3 :: Int] +-- [] +-- +-- >>> take (nat 5) [1,2 :: Int] +-- [1,2] +take :: + Natural -> + [a] -> + [a] +take _ [] = + [] +take n (h : t) = + case n ^? successor of + Nothing -> + [] + Just p -> + h : take p t + +-- | Drop the first n elements. +-- +-- >>> drop (nat 2) [1,2,3,4,5 :: Int] +-- [3,4,5] +-- +-- >>> drop (nat 0) [1,2,3 :: Int] +-- [1,2,3] +-- +-- >>> drop (nat 5) [1,2 :: Int] +-- [] +drop :: + Natural -> + [a] -> + [a] +drop _ [] = + [] +drop n (h : t) = + case n ^? successor of + Nothing -> + h : t + Just p -> + drop p t + +-- | Split a list at position n. +-- +-- >>> splitAt (nat 2) [1,2,3,4,5 :: Int] +-- ([1,2],[3,4,5]) +splitAt :: + Natural -> + [a] -> + ([a], [a]) +splitAt n x = + (take n x, drop n x) + +-- | Index into a list. +-- +-- >>> [10,20,30 :: Int] !! nat 0 +-- Just 10 +-- +-- >>> [10,20,30 :: Int] !! nat 2 +-- Just 30 +-- +-- >>> [10,20,30 :: Int] !! nat 5 +-- Nothing +-- +-- >>> ([] :: [Int]) !! nat 0 +-- Nothing +(!!) :: + [a] -> + Natural -> + Maybe a +[] !! _ = + Nothing +(h : t) !! n = + case n ^? successor of + Nothing -> + Just h + Just p -> + t !! p + +-- | Find all indices where the predicate holds. +-- +-- >>> findIndices (== 'a') "abacad" +-- [Natural 0,Natural 2,Natural 4] +-- +-- >>> findIndices (== 'z') "abacad" +-- [] +findIndices :: + (a -> Bool) -> + [a] -> + [Natural] +findIndices p x = + map snd (filter (p . fst) (zip x (iterate successor' zero'))) + +-- | Find the first index where the predicate holds. +-- +-- >>> findIndex (== 'c') "abcde" +-- Just (Natural 2) +-- +-- >>> findIndex (== 'z') "abcde" +-- Nothing +findIndex :: + (a -> Bool) -> + [a] -> + Maybe Natural +findIndex p = + listToMaybe . findIndices p + +-- | Find all indices of a given element. +-- +-- >>> elemIndices 'a' "banana" +-- [Natural 1,Natural 3,Natural 5] +elemIndices :: + (Eq a) => + a -> + [a] -> + [Natural] +elemIndices = + findIndices . (==) + +-- | Find the first index of a given element. +-- +-- >>> elemIndex 'n' "banana" +-- Just (Natural 2) +-- +-- >>> elemIndex 'z' "banana" +-- Nothing +elemIndex :: + (Eq a) => + a -> + [a] -> + Maybe Natural +elemIndex = + findIndex . (==) + +-- | Subtract two naturals, flooring at zero. +-- +-- >>> minus (nat 5) (nat 3) +-- Natural 2 +-- +-- >>> minus (nat 3) (nat 5) +-- Natural 0 +-- +-- >>> minus (nat 3) (nat 3) +-- Natural 0 +minus :: + Natural -> + Natural -> + Natural +minus (Natural x) (Natural y) = + Natural (if x < y then 0 else x - y) + +-- | Iso between a natural and a list of units. +-- +-- >>> nat 3 ^. list +-- [(),(),()] +-- +-- >>> length (nat 3 ^. list) +-- Natural 3 +list :: + Iso' + Natural + [()] +list = + iso + (`replicate` ()) + length + +---- + +-- | A positive integer (>= 1). Semigroup is multiplication. +-- +-- >>> pos 3 +-- Positive 3 +-- +-- >>> pos 3 <> pos 4 +-- Positive 12 +newtype Positive + = Positive + Integer + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> pos 3 <> pos 4 +-- Positive 12 +instance Semigroup Positive where + Positive x <> Positive y = + Positive (x * y) + +class HasPositive a where + positive :: + Lens' + a + Positive + +-- | +-- +-- >>> pos 5 ^. positive +-- Positive 5 +instance HasPositive Positive where + positive = + id + +class AsPositive a where + _Positive :: + Prism' + a + Positive + +-- | +-- +-- >>> _Positive # pos 5 :: Positive +-- Positive 5 +instance AsPositive Positive where + _Positive = + id + +integralPrism1 :: + (Integral a) => + Prism' + a + Positive +integralPrism1 = + prism' + (\(Positive n) -> fromIntegral n) + (\n -> if n < 1 then Nothing else Just (Positive (fromIntegral n))) + +-- | +-- +-- >>> (5 :: Int) ^? _Positive +-- Just (Positive 5) +-- +-- >>> (0 :: Int) ^? _Positive +-- Nothing +instance AsPositive Int where + _Positive = + integralPrism1 + +-- | +-- +-- >>> (42 :: Integer) ^? _Positive +-- Just (Positive 42) +-- +-- >>> (0 :: Integer) ^? _Positive +-- Nothing +instance AsPositive Integer where + _Positive = + integralPrism1 + +-- | +-- +-- >>> (7 :: Word) ^? _Positive +-- Just (Positive 7) +-- +-- >>> (0 :: Word) ^? _Positive +-- Nothing +instance AsPositive Word where + _Positive = + integralPrism1 + +-- | +-- +-- >>> import Control.Applicative(Const(..)) +-- >>> (Const 5 :: Const Integer Bool) ^? _Positive +-- Just (Positive 5) +instance (Integral a) => AsPositive (Const a b) where + _Positive = + integralPrism1 + +-- | +-- +-- >>> import Data.Functor.Identity(Identity(..)) +-- >>> (Identity 5 :: Identity Integer) ^? _Positive +-- Just (Positive 5) +instance (Integral a) => AsPositive (Identity a) where + _Positive = + integralPrism1 + +-- | +-- +-- >>> SumPositive (pos 3) <> SumPositive (pos 4) +-- SumPositive (Positive 7) +newtype SumPositive + = SumPositive + Positive + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> SumPositive (pos 5) ^. positive +-- Positive 5 +instance HasPositive SumPositive where + positive = + _Wrapped . positive + +-- | +-- +-- >>> SumPositive (pos 5) ^? _Positive +-- Just (Positive 5) +instance AsPositive SumPositive where + _Positive = + _Wrapped . _Positive + +instance + (SumPositive ~ a) => + Rewrapped SumPositive a + +-- | +-- +-- >>> SumPositive (pos 5) ^. _Wrapped' +-- Positive 5 +instance Wrapped SumPositive where + type Unwrapped SumPositive = Positive + _Wrapped' = + iso + (\(SumPositive x) -> x) + SumPositive + +-- | +-- +-- >>> SumPositive (pos 3) <> SumPositive (pos 4) +-- SumPositive (Positive 7) +instance Semigroup SumPositive where + SumPositive (Positive x) <> SumPositive (Positive y) = + SumPositive (Positive (x + y)) + +-- | +-- +-- >>> MaxPositive (pos 3) <> MaxPositive (pos 7) +-- MaxPositive (Positive 7) +newtype MaxPositive + = MaxPositive + Positive + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> MaxPositive (pos 7) ^. positive +-- Positive 7 +instance HasPositive MaxPositive where + positive = + _Wrapped . positive + +-- | +-- +-- >>> MaxPositive (pos 7) ^? _Positive +-- Just (Positive 7) +instance AsPositive MaxPositive where + _Positive = + _Wrapped . _Positive + +instance + (MaxPositive ~ a) => + Rewrapped MaxPositive a + +-- | +-- +-- >>> MaxPositive (pos 7) ^. _Wrapped' +-- Positive 7 +instance Wrapped MaxPositive where + type Unwrapped MaxPositive = Positive + _Wrapped' = + iso + (\(MaxPositive x) -> x) + MaxPositive + +-- | +-- +-- >>> MaxPositive (pos 3) <> MaxPositive (pos 7) +-- MaxPositive (Positive 7) +instance Semigroup MaxPositive where + MaxPositive (Positive x) <> MaxPositive (Positive y) = + MaxPositive (Positive (x `max` y)) + +-- | +-- +-- >>> MinPositive (pos 3) <> MinPositive (pos 7) +-- MinPositive (Positive 3) +newtype MinPositive + = MinPositive + Positive + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> MinPositive (pos 3) ^. positive +-- Positive 3 +instance HasPositive MinPositive where + positive = + _Wrapped . positive + +-- | +-- +-- >>> MinPositive (pos 3) ^? _Positive +-- Just (Positive 3) +instance AsPositive MinPositive where + _Positive = + _Wrapped . _Positive + +instance + (MinPositive ~ a) => + Rewrapped MinPositive a + +-- | +-- +-- >>> MinPositive (pos 3) ^. _Wrapped' +-- Positive 3 +instance Wrapped MinPositive where + type Unwrapped MinPositive = Positive + _Wrapped' = + iso + (\(MinPositive x) -> x) + MinPositive + +-- | +-- +-- >>> MinPositive (pos 3) <> MinPositive (pos 7) +-- MinPositive (Positive 3) +instance Semigroup MinPositive where + MinPositive (Positive x) <> MinPositive (Positive y) = + MinPositive (Positive (x `min` y)) + +-- | Serialises a 'Positive' to a JSON number. +-- +-- >>> fromJSON (Number 1) :: Result Positive +-- Success (Positive 1) +-- +-- >>> fromJSON (Number 42) :: Result Positive +-- Success (Positive 42) +-- +-- >>> decode "42" :: Maybe Positive +-- Just (Positive 42) +-- +-- >>> decode "1" :: Maybe Positive +-- Just (Positive 1) +-- +-- >>> decode "0" :: Maybe Positive +-- Nothing +-- +-- >>> decode "-1" :: Maybe Positive +-- Nothing +instance ToJSON Positive where + toJSON = + toJsonPositive + toEncoding (Positive n) = + toEncoding n + +-- | Parses a 'Positive' from a JSON number, failing on non-positive values. +-- +-- >>> decode "1" :: Maybe Positive +-- Just (Positive 1) +instance FromJSON Positive where + parseJSON = + parseJsonPositive + +-- | Serialises any value with a 'HasPositive' instance to a JSON 'Value'. +-- +-- >>> toJsonPositive (pos 42) +-- Number 42.0 +-- +-- >>> toJsonPositive (SumPositive (pos 7)) +-- Number 7.0 +-- +-- >>> toJsonPositive (MaxPositive (pos 7)) +-- Number 7.0 +-- +-- >>> toJsonPositive (MinPositive (pos 3)) +-- Number 3.0 +{-# SPECIALIZE toJsonPositive :: + Positive -> + Value + #-} +{-# INLINE toJsonPositive #-} +toJsonPositive :: + (HasPositive a) => + a -> + Value +toJsonPositive a = + let Positive n = a ^. positive + in toJSON n + +-- | Parses a JSON value into a 'Positive', failing on non-positive values. +-- +-- >>> parse parseJsonPositive (Number 42) +-- Success (Positive 42) +-- +-- >>> parse parseJsonPositive (Number 1) +-- Success (Positive 1) +-- +-- >>> parse parseJsonPositive (Number 0) +-- Error "parse failed, Positive: expected positive integer" +-- +-- >>> parse parseJsonPositive (Number (-1)) +-- Error "parse failed, Positive: expected positive integer" +{-# INLINE parseJsonPositive #-} +parseJsonPositive :: + Value -> + Parser Positive +parseJsonPositive v = + parseJSON v >>= \n -> + if n < 1 + then fail "parse failed, Positive: expected positive integer" + else pure (Positive n) + +-- | Serialises a 'SumPositive' to a JSON number. +-- +-- >>> encode (SumPositive (pos 7)) +-- "7" +instance ToJSON SumPositive where + toJSON = + toJsonPositive + toEncoding (SumPositive n) = + toEncoding n + +-- | Parses a 'SumPositive' from a JSON number, failing on non-positive values. +-- +-- >>> decode "7" :: Maybe SumPositive +-- Just (SumPositive (Positive 7)) +-- +-- >>> decode "0" :: Maybe SumPositive +-- Nothing +instance FromJSON SumPositive where + parseJSON v = + parseJsonPositive v >>= \n -> pure (SumPositive n) + +-- | Serialises a 'MaxPositive' to a JSON number. +-- +-- >>> encode (MaxPositive (pos 7)) +-- "7" +instance ToJSON MaxPositive where + toJSON = + toJsonPositive + toEncoding (MaxPositive n) = + toEncoding n + +-- | Parses a 'MaxPositive' from a JSON number, failing on non-positive values. +-- +-- >>> decode "7" :: Maybe MaxPositive +-- Just (MaxPositive (Positive 7)) +-- +-- >>> decode "0" :: Maybe MaxPositive +-- Nothing +instance FromJSON MaxPositive where + parseJSON v = + parseJsonPositive v >>= \n -> pure (MaxPositive n) + +-- | Serialises a 'MinPositive' to a JSON number. +-- +-- >>> encode (MinPositive (pos 3)) +-- "3" +instance ToJSON MinPositive where + toJSON = + toJsonPositive + toEncoding (MinPositive n) = + toEncoding n + +-- | Parses a 'MinPositive' from a JSON number, failing on non-positive values. +-- +-- >>> decode "3" :: Maybe MinPositive +-- Just (MinPositive (Positive 3)) +-- +-- >>> decode "0" :: Maybe MinPositive +-- Nothing +instance FromJSON MinPositive where + parseJSON v = + parseJsonPositive v >>= \n -> pure (MinPositive n) + +-- | Iso between a natural and maybe a positive. +-- +-- >>> nat 5 ^. naturalPositive +-- Just (Positive 5) +-- +-- >>> nat 0 ^. naturalPositive +-- Nothing +naturalPositive :: + Iso' Natural (Maybe Positive) +naturalPositive = + iso + ( \(Natural n) -> + if n == 0 then Nothing else Just (Positive n) + ) + ( \x -> + Natural + ( case x of + Nothing -> + 0 + Just (Positive n) -> + n + ) + ) + +-- | +-- +-- >>> nat 5 ^? _Positive +-- Just (Positive 5) +-- +-- >>> nat 0 ^? _Positive +-- Nothing +instance AsPositive Natural where + _Positive = + prism' + (\(Positive n) -> Natural n) + (\(Natural n) -> if n == 0 then Nothing else Just (Positive n)) + +-- | Prism matching one. +-- +-- >>> one # () +-- Positive 1 +-- +-- >>> pos 1 ^? one +-- Just () +-- +-- >>> pos 3 ^? one +-- Nothing +one :: + Prism' + Positive + () +one = + prism' + (\() -> Positive 1) + (\(Positive n) -> if n == 1 then Just () else Nothing) + +-- | The positive number one. +-- +-- >>> one' +-- Positive 1 +one' :: + Positive +one' = + one # () + +-- | Prism between a positive and its predecessor. +-- +-- >>> successor1 # pos 1 +-- Positive 2 +-- +-- >>> successor1 # pos 4 +-- Positive 5 +-- +-- >>> pos 5 ^? successor1 +-- Just (Positive 4) +-- +-- >>> pos 1 ^? successor1 +-- Nothing +successor1 :: + Prism' + Positive + Positive +successor1 = + prism' + (\(Positive n) -> Positive (n + 1)) + (\(Positive n) -> if n == 1 then Nothing else Just (Positive (n - 1))) + +-- | The successor of a positive number. +-- +-- >>> successor1' (pos 1) +-- Positive 2 +-- +-- >>> successor1' (pos 4) +-- Positive 5 +successor1' :: + Positive -> + Positive +successor1' = + (successor1 #) + +-- | Iso between natural and positive (n <-> n+1). +-- +-- >>> nat 0 ^. successorW +-- Positive 1 +-- +-- >>> nat 4 ^. successorW +-- Positive 5 +-- +-- >>> successorW # pos 1 +-- Natural 0 +-- +-- >>> successorW # pos 5 +-- Natural 4 +successorW :: + Iso' + Natural + Positive +successorW = + iso + (\(Natural n) -> Positive (n + 1)) + (\(Positive n) -> Natural (n - 1)) + +-- | Add two positive numbers. +-- +-- >>> plus1 (pos 3) (pos 4) +-- Positive 7 +plus1 :: + Positive -> + Positive -> + Positive +plus1 x y = + (_Wrapped # x <> (_Wrapped # y :: SumPositive)) ^. _Wrapped + +-- | Multiply two positive numbers. +-- +-- >>> multiply1 (pos 3) (pos 4) +-- Positive 12 +multiply1 :: + Positive -> + Positive -> + Positive +multiply1 = + (<>) + +-- | Raise a positive to a positive power. +-- +-- >>> power1 (pos 2) (pos 10) +-- Positive 1024 +-- +-- >>> power1 (pos 3) (pos 2) +-- Positive 9 +power1 :: + Positive -> + Positive -> + Positive +power1 (Positive x) (Positive y) = + Positive (x ^ y) + +-- | Return the positive if the prism matches, otherwise one. +-- +-- >>> oneOr (5 :: Integer) +-- Positive 5 +-- +-- >>> oneOr (0 :: Integer) +-- Positive 1 +oneOr :: + (AsPositive a) => + a -> + Positive +oneOr n = + fromMaybe one' (n ^? _Positive) + +-- | Count the elements in a non-empty foldable. +-- +-- >>> length1 ('a' :| "bc") +-- Positive 3 +-- +-- >>> length1 ('x' :| "") +-- Positive 1 +length1 :: + (Foldable1 f) => + f a -> + Positive +length1 x = + foldMap1 (const (SumPositive one')) x ^. _Wrapped + +-- | Replicate a value a positive number of times. +-- +-- >>> replicate1 (pos 3) 'x' +-- 'x' :| "xx" +-- +-- >>> replicate1 (pos 1) 'y' +-- 'y' :| "" +replicate1 :: + Positive -> + a -> + NonEmpty a +replicate1 n a = + take1 n (a :| repeat a) + +-- | Take the first n elements from a non-empty list. +-- +-- >>> take1 (pos 2) (1 :| [2,3,4,5 :: Int]) +-- 1 :| [2] +-- +-- >>> take1 (pos 1) (1 :| [2,3 :: Int]) +-- 1 :| [] +take1 :: + Positive -> + NonEmpty a -> + NonEmpty a +take1 n (h :| t) = + h :| take (successorW # n) t + +-- | Drop the first n elements from a non-empty list. +-- +-- >>> drop1 (pos 2) (1 :| [2,3,4,5 :: Int]) +-- [3,4,5] +-- +-- >>> drop1 (pos 1) (1 :| [2,3 :: Int]) +-- [2,3] +drop1 :: + Positive -> + NonEmpty a -> + [a] +drop1 n (_ :| t) = + drop (successorW # n) t + +-- | Split a non-empty list at position n. +-- +-- >>> splitAt1 (pos 2) (1 :| [2,3,4,5 :: Int]) +-- (1 :| [2],[3,4,5]) +splitAt1 :: + Positive -> + NonEmpty a -> + (NonEmpty a, [a]) +splitAt1 n x = + (take1 n x, drop1 n x) + +-- | Index into a non-empty list (1-based). +-- +-- >>> (10 :| [20,30 :: Int]) !!! pos 1 +-- Just 10 +-- +-- >>> (10 :| [20,30 :: Int]) !!! pos 3 +-- Just 30 +-- +-- >>> (10 :| [20,30 :: Int]) !!! pos 5 +-- Nothing +(!!!) :: + NonEmpty a -> + Positive -> + Maybe a +(h :| t) !!! n = + (h : t) !! (successorW # n) + +-- | Find all 1-based indices where the predicate holds. +-- +-- >>> findIndices1 (== 'a') ('a' :| "baca") +-- [Positive 1,Positive 3,Positive 5] +findIndices1 :: + (a -> Bool) -> + NonEmpty a -> + [Positive] +findIndices1 p x = + map snd (NonEmpty.filter (p . fst) (NonEmpty.zip x (NonEmpty.iterate successor1' one'))) + +-- | Find the first 1-based index where the predicate holds. +-- +-- >>> findIndex1 (== 'c') ('a' :| "bcde") +-- Just (Positive 3) +-- +-- >>> findIndex1 (== 'z') ('a' :| "bcde") +-- Nothing +findIndex1 :: + (a -> Bool) -> + NonEmpty a -> + Maybe Positive +findIndex1 p = + listToMaybe . findIndices1 p + +-- | Find all 1-based indices of a given element. +-- +-- >>> elemIndices1 'a' ('b' :| "anana") +-- [Positive 2,Positive 4,Positive 6] +elemIndices1 :: + (Eq a) => + a -> + NonEmpty a -> + [Positive] +elemIndices1 = + findIndices1 . (==) + +-- | Find the first 1-based index of a given element. +-- +-- >>> elemIndex1 'n' ('b' :| "anana") +-- Just (Positive 3) +-- +-- >>> elemIndex1 'z' ('b' :| "anana") +-- Nothing +elemIndex1 :: + (Eq a) => + a -> + NonEmpty a -> + Maybe Positive +elemIndex1 = + findIndex1 . (==) + +-- | Subtract two positives, flooring at one. +-- +-- >>> minus1 (pos 5) (pos 3) +-- Positive 2 +-- +-- >>> minus1 (pos 3) (pos 5) +-- Positive 1 +-- +-- >>> minus1 (pos 3) (pos 3) +-- Positive 1 +minus1 :: + Positive -> + Positive -> + Positive +minus1 (Positive x) (Positive y) = + Positive (if x <= y then 1 else x - y) + +-- | Iso between a positive and a non-empty list of units. +-- +-- >>> pos 3 ^. list1 +-- () :| [(),()] +-- +-- >>> length1 (pos 3 ^. list1) +-- Positive 3 +list1 :: + Iso' + Positive + (NonEmpty ()) +list1 = + iso + (`replicate1` ()) + length1 + +-- | Convert natural to positive by adding one. +-- +-- >>> plusone (nat 0) +-- Positive 1 +-- +-- >>> plusone (nat 4) +-- Positive 5 +plusone :: + Natural -> + Positive +plusone = + (^. successorW) + +-- | Convert positive to natural by subtracting one. +-- +-- >>> minusone (pos 1) +-- Natural 0 +-- +-- >>> minusone (pos 5) +-- Natural 4 +minusone :: + Positive -> + Natural +minusone = + (successorW #) + +---- + +-- | A non-zero integer. 'True' for positive, 'False' for negative. +-- The 'Positive' gives the absolute value. +-- +-- >>> NotZero True (pos 3) +-- NotZero True (Positive 3) +-- +-- >>> NotZero False (pos 7) +-- NotZero False (Positive 7) +data NotZero + = NotZero + Bool + Positive + deriving (Eq, Show) + +-- | +-- +-- >>> compare (NotZero True (pos 3)) (NotZero True (pos 5)) +-- LT +-- +-- >>> compare (NotZero False (pos 3)) (NotZero False (pos 5)) +-- GT +-- +-- >>> compare (NotZero False (pos 1)) (NotZero True (pos 1)) +-- LT +-- +-- >>> compare (NotZero True (pos 1)) (NotZero False (pos 1)) +-- GT +instance Ord NotZero where + compare (NotZero False (Positive x)) (NotZero False (Positive y)) = compare y x + compare (NotZero True (Positive x)) (NotZero True (Positive y)) = compare x y + compare (NotZero False _) (NotZero True _) = compare (0 :: Integer) (1 :: Integer) + compare (NotZero True _) (NotZero False _) = compare (1 :: Integer) (0 :: Integer) + +-- | Semigroup under addition. Note: this is partial if the result would be zero. +-- Use 'plusNZ' for a total version. +-- +-- >>> NotZero True (pos 3) <> NotZero True (pos 4) +-- NotZero True (Positive 7) +-- +-- >>> NotZero False (pos 3) <> NotZero False (pos 4) +-- NotZero False (Positive 7) +-- +-- >>> NotZero True (pos 5) <> NotZero False (pos 3) +-- NotZero True (Positive 2) +-- +-- >>> NotZero False (pos 5) <> NotZero True (pos 3) +-- NotZero False (Positive 2) +instance Semigroup NotZero where + NotZero s1 (Positive x) <> NotZero s2 (Positive y) = + case (s1, s2) of + (True, True) -> NotZero True (Positive (x + y)) + (False, False) -> NotZero False (Positive (x + y)) + (True, False) + | x <= y -> NotZero False (Positive (y - x)) + | True -> NotZero True (Positive (x - y)) + (False, True) + | y <= x -> NotZero False (Positive (x - y)) + | True -> NotZero True (Positive (y - x)) + +class HasNotZero a where + notZero :: + Lens' + a + NotZero + +-- | +-- +-- >>> NotZero True (pos 5) ^. notZero +-- NotZero True (Positive 5) +instance HasNotZero NotZero where + notZero = + id + +-- | +-- +-- >>> (7 :: Integer) ^? _NotZero +-- Just (NotZero True (Positive 7)) +-- +-- >>> (-3 :: Integer) ^? _NotZero +-- Just (NotZero False (Positive 3)) +-- +-- >>> (0 :: Integer) ^? _NotZero +-- Nothing +class AsNotZero a where + _NotZero :: + Prism' + a + NotZero + +-- | +-- +-- >>> _NotZero # NotZero True (pos 5) :: NotZero +-- NotZero True (Positive 5) +instance AsNotZero NotZero where + _NotZero = + id + +integralPrismNZ :: + (Integral a) => + Prism' + a + NotZero +integralPrismNZ = + prism' + (\(NotZero s (Positive n)) -> fromIntegral (if s then n else negate n)) + ( \n -> + let i = fromIntegral n :: Integer + in if i == 0 + then Nothing + else Just (NotZero (i > 0) (Positive (abs i))) + ) + where + (>) a b = not (a <= b) && not (a == b) + +-- | +-- +-- >>> (5 :: Int) ^? _NotZero +-- Just (NotZero True (Positive 5)) +-- +-- >>> (-5 :: Int) ^? _NotZero +-- Just (NotZero False (Positive 5)) +-- +-- >>> (0 :: Int) ^? _NotZero +-- Nothing +instance AsNotZero Int where + _NotZero = + integralPrismNZ + +-- | +-- +-- >>> (42 :: Integer) ^? _NotZero +-- Just (NotZero True (Positive 42)) +-- +-- >>> (-42 :: Integer) ^? _NotZero +-- Just (NotZero False (Positive 42)) +-- +-- >>> (0 :: Integer) ^? _NotZero +-- Nothing +instance AsNotZero Integer where + _NotZero = + integralPrismNZ + +-- | +-- +-- >>> (1 :: Word) ^? _NotZero +-- Just (NotZero True (Positive 1)) +-- +-- >>> (0 :: Word) ^? _NotZero +-- Nothing +instance AsNotZero Word where + _NotZero = + integralPrismNZ + +-- | +-- +-- >>> import Control.Applicative(Const(..)) +-- >>> (Const 5 :: Const Integer Bool) ^? _NotZero +-- Just (NotZero True (Positive 5)) +instance (Integral a) => AsNotZero (Const a b) where + _NotZero = + integralPrismNZ + +-- | +-- +-- >>> import Data.Functor.Identity(Identity(..)) +-- >>> (Identity (-3) :: Identity Integer) ^? _NotZero +-- Just (NotZero False (Positive 3)) +instance (Integral a) => AsNotZero (Identity a) where + _NotZero = + integralPrismNZ + +-- | +-- +-- >>> SumNotZero (NotZero True (pos 3)) <> SumNotZero (NotZero True (pos 4)) +-- SumNotZero (NotZero True (Positive 7)) +newtype SumNotZero + = SumNotZero + NotZero + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> SumNotZero (NotZero True (pos 5)) ^. notZero +-- NotZero True (Positive 5) +instance HasNotZero SumNotZero where + notZero = + _Wrapped . notZero + +-- | +-- +-- >>> SumNotZero (NotZero True (pos 5)) ^? _NotZero +-- Just (NotZero True (Positive 5)) +instance AsNotZero SumNotZero where + _NotZero = + _Wrapped . _NotZero + +instance + (SumNotZero ~ a) => + Rewrapped SumNotZero a + +-- | +-- +-- >>> SumNotZero (NotZero True (pos 5)) ^. _Wrapped' +-- NotZero True (Positive 5) +instance Wrapped SumNotZero where + type Unwrapped SumNotZero = NotZero + _Wrapped' = + iso + (\(SumNotZero x) -> x) + SumNotZero + +-- | +-- +-- >>> SumNotZero (NotZero True (pos 3)) <> SumNotZero (NotZero True (pos 4)) +-- SumNotZero (NotZero True (Positive 7)) +instance Semigroup SumNotZero where + SumNotZero x <> SumNotZero y = + SumNotZero (x <> y) + +-- | +-- +-- >>> MaxNotZero (NotZero True (pos 3)) <> MaxNotZero (NotZero True (pos 7)) +-- MaxNotZero (NotZero True (Positive 7)) +-- +-- >>> MaxNotZero (NotZero False (pos 3)) <> MaxNotZero (NotZero True (pos 1)) +-- MaxNotZero (NotZero True (Positive 1)) +newtype MaxNotZero + = MaxNotZero + NotZero + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> MaxNotZero (NotZero True (pos 7)) ^. notZero +-- NotZero True (Positive 7) +instance HasNotZero MaxNotZero where + notZero = + _Wrapped . notZero + +-- | +-- +-- >>> MaxNotZero (NotZero True (pos 7)) ^? _NotZero +-- Just (NotZero True (Positive 7)) +instance AsNotZero MaxNotZero where + _NotZero = + _Wrapped . _NotZero + +instance + (MaxNotZero ~ a) => + Rewrapped MaxNotZero a + +-- | +-- +-- >>> MaxNotZero (NotZero True (pos 7)) ^. _Wrapped' +-- NotZero True (Positive 7) +instance Wrapped MaxNotZero where + type Unwrapped MaxNotZero = NotZero + _Wrapped' = + iso + (\(MaxNotZero x) -> x) + MaxNotZero + +-- | +-- +-- >>> MaxNotZero (NotZero True (pos 3)) <> MaxNotZero (NotZero True (pos 7)) +-- MaxNotZero (NotZero True (Positive 7)) +instance Semigroup MaxNotZero where + MaxNotZero x <> MaxNotZero y = + MaxNotZero (max x y) + +-- | +-- +-- >>> MinNotZero (NotZero True (pos 3)) <> MinNotZero (NotZero True (pos 7)) +-- MinNotZero (NotZero True (Positive 3)) +-- +-- >>> MinNotZero (NotZero False (pos 3)) <> MinNotZero (NotZero True (pos 1)) +-- MinNotZero (NotZero False (Positive 3)) +newtype MinNotZero + = MinNotZero + NotZero + deriving (Eq, Ord, Show) + +-- | +-- +-- >>> MinNotZero (NotZero False (pos 3)) ^. notZero +-- NotZero False (Positive 3) +instance HasNotZero MinNotZero where + notZero = + _Wrapped . notZero + +-- | +-- +-- >>> MinNotZero (NotZero False (pos 3)) ^? _NotZero +-- Just (NotZero False (Positive 3)) +instance AsNotZero MinNotZero where + _NotZero = + _Wrapped . _NotZero + +instance + (MinNotZero ~ a) => + Rewrapped MinNotZero a + +-- | +-- +-- >>> MinNotZero (NotZero False (pos 3)) ^. _Wrapped' +-- NotZero False (Positive 3) +instance Wrapped MinNotZero where + type Unwrapped MinNotZero = NotZero + _Wrapped' = + iso + (\(MinNotZero x) -> x) + MinNotZero + +-- | +-- +-- >>> MinNotZero (NotZero True (pos 3)) <> MinNotZero (NotZero True (pos 7)) +-- MinNotZero (NotZero True (Positive 3)) +instance Semigroup MinNotZero where + MinNotZero x <> MinNotZero y = + MinNotZero (min x y) + +-- | Serialises a 'NotZero' to a JSON number. +-- +-- >>> fromJSON (Number 5) :: Result NotZero +-- Success (NotZero True (Positive 5)) +-- +-- >>> fromJSON (Number (-3)) :: Result NotZero +-- Success (NotZero False (Positive 3)) +-- +-- >>> decode "7" :: Maybe NotZero +-- Just (NotZero True (Positive 7)) +-- +-- >>> decode "-2" :: Maybe NotZero +-- Just (NotZero False (Positive 2)) +-- +-- >>> decode "0" :: Maybe NotZero +-- Nothing +instance ToJSON NotZero where + toJSON = + toJsonNotZero + toEncoding nz = + toEncoding (notZeroInteger nz) + +-- | Parses a 'NotZero' from a JSON number, failing on zero. +-- +-- >>> decode "5" :: Maybe NotZero +-- Just (NotZero True (Positive 5)) +instance FromJSON NotZero where + parseJSON = + parseJsonNotZero + +-- | Serialises any value with a 'HasNotZero' instance to a JSON 'Value'. +-- +-- >>> toJsonNotZero (NotZero True (pos 5)) +-- Number 5.0 +-- +-- >>> toJsonNotZero (NotZero False (pos 3)) +-- Number (-3.0) +-- +-- >>> toJsonNotZero (SumNotZero (NotZero True (pos 7))) +-- Number 7.0 +-- +-- >>> toJsonNotZero (MaxNotZero (NotZero False (pos 2))) +-- Number (-2.0) +-- +-- >>> toJsonNotZero (MinNotZero (NotZero True (pos 1))) +-- Number 1.0 +{-# SPECIALIZE toJsonNotZero :: + NotZero -> + Value + #-} +{-# INLINE toJsonNotZero #-} +toJsonNotZero :: + (HasNotZero a) => + a -> + Value +toJsonNotZero a = + toJSON (notZeroInteger (a ^. notZero)) + +-- | Parses a JSON value into a 'NotZero', failing on zero. +-- +-- >>> parse parseJsonNotZero (Number 5) +-- Success (NotZero True (Positive 5)) +-- +-- >>> parse parseJsonNotZero (Number (-3)) +-- Success (NotZero False (Positive 3)) +-- +-- >>> parse parseJsonNotZero (Number 0) +-- Error "parse failed, NotZero: expected non-zero integer" +{-# INLINE parseJsonNotZero #-} +parseJsonNotZero :: + Value -> + Parser NotZero +parseJsonNotZero v = + parseJSON v >>= \n -> + if n == 0 + then fail "parse failed, NotZero: expected non-zero integer" + else + pure + ( if n < 0 + then NotZero False (Positive (negate n)) + else NotZero True (Positive n) + ) + +-- | Serialises a 'SumNotZero' to a JSON number. +-- +-- >>> encode (SumNotZero (NotZero True (pos 7))) +-- "7" +instance ToJSON SumNotZero where + toJSON = + toJsonNotZero + toEncoding (SumNotZero nz) = + toEncoding (notZeroInteger nz) + +-- | Parses a 'SumNotZero' from a JSON number, failing on zero. +-- +-- >>> decode "7" :: Maybe SumNotZero +-- Just (SumNotZero (NotZero True (Positive 7))) +-- +-- >>> decode "0" :: Maybe SumNotZero +-- Nothing +instance FromJSON SumNotZero where + parseJSON v = + parseJsonNotZero v >>= \n -> pure (SumNotZero n) + +-- | Serialises a 'MaxNotZero' to a JSON number. +-- +-- >>> encode (MaxNotZero (NotZero False (pos 2))) +-- "-2" +instance ToJSON MaxNotZero where + toJSON = + toJsonNotZero + toEncoding (MaxNotZero nz) = + toEncoding (notZeroInteger nz) + +-- | Parses a 'MaxNotZero' from a JSON number, failing on zero. +-- +-- >>> decode "-2" :: Maybe MaxNotZero +-- Just (MaxNotZero (NotZero False (Positive 2))) +-- +-- >>> decode "0" :: Maybe MaxNotZero +-- Nothing +instance FromJSON MaxNotZero where + parseJSON v = + parseJsonNotZero v >>= \n -> pure (MaxNotZero n) + +-- | Serialises a 'MinNotZero' to a JSON number. +-- +-- >>> encode (MinNotZero (NotZero True (pos 1))) +-- "1" +instance ToJSON MinNotZero where + toJSON = + toJsonNotZero + toEncoding (MinNotZero nz) = + toEncoding (notZeroInteger nz) + +-- | Parses a 'MinNotZero' from a JSON number, failing on zero. +-- +-- >>> decode "1" :: Maybe MinNotZero +-- Just (MinNotZero (NotZero True (Positive 1))) +-- +-- >>> decode "0" :: Maybe MinNotZero +-- Nothing +instance FromJSON MinNotZero where + parseJSON v = + parseJsonNotZero v >>= \n -> pure (MinNotZero n) + +-- | Embed a 'Positive' as a positive 'NotZero'. +-- +-- >>> positiveNotZero (pos 5) +-- NotZero True (Positive 5) +positiveNotZero :: + Positive -> + NotZero +positiveNotZero = + NotZero True + +-- | Embed a 'Positive' as a negative 'NotZero'. +-- +-- >>> negativeNotZero (pos 5) +-- NotZero False (Positive 5) +negativeNotZero :: + Positive -> + NotZero +negativeNotZero = + NotZero False + +-- | Extract the magnitude from a 'NotZero'. +-- +-- >>> notZeroPositive (NotZero True (pos 5)) +-- Positive 5 +-- +-- >>> notZeroPositive (NotZero False (pos 3)) +-- Positive 3 +notZeroPositive :: + NotZero -> + Positive +notZeroPositive (NotZero _ p) = + p + +-- | Convert a 'NotZero' to an 'Integer'. +-- +-- >>> notZeroInteger (NotZero True (pos 5)) +-- 5 +-- +-- >>> notZeroInteger (NotZero False (pos 3)) +-- -3 +notZeroInteger :: + NotZero -> + Integer +notZeroInteger (NotZero s (Positive n)) = + if s then n else negate n + +-- | Test if a 'NotZero' is positive. +-- +-- >>> isPositive (NotZero True (pos 5)) +-- True +-- +-- >>> isPositive (NotZero False (pos 5)) +-- False +isPositive :: + NotZero -> + Bool +isPositive (NotZero s _) = + s + +-- | Test if a 'NotZero' is negative. +-- +-- >>> isNegative (NotZero False (pos 5)) +-- True +-- +-- >>> isNegative (NotZero True (pos 5)) +-- False +isNegative :: + NotZero -> + Bool +isNegative (NotZero s _) = + not s + +-- | Negate a 'NotZero'. +-- +-- >>> negateNZ (NotZero True (pos 5)) +-- NotZero False (Positive 5) +-- +-- >>> negateNZ (NotZero False (pos 3)) +-- NotZero True (Positive 3) +negateNZ :: + NotZero -> + NotZero +negateNZ (NotZero s p) = + NotZero (not s) p + +-- | Absolute value as a 'Positive'. +-- +-- >>> absoluteNZ (NotZero True (pos 5)) +-- Positive 5 +-- +-- >>> absoluteNZ (NotZero False (pos 3)) +-- Positive 3 +absoluteNZ :: + NotZero -> + Positive +absoluteNZ = + notZeroPositive + +-- | Signum: positive one or negative one. +-- +-- >>> signumNZ (NotZero True (pos 99)) +-- NotZero True (Positive 1) +-- +-- >>> signumNZ (NotZero False (pos 42)) +-- NotZero False (Positive 1) +signumNZ :: + NotZero -> + NotZero +signumNZ (NotZero s _) = + NotZero s one' + +-- | Add two 'NotZero' values. Returns 'Nothing' if the result is zero. +-- +-- >>> plusNZ (NotZero True (pos 3)) (NotZero True (pos 4)) +-- Just (NotZero True (Positive 7)) +-- +-- >>> plusNZ (NotZero True (pos 3)) (NotZero False (pos 3)) +-- Nothing +-- +-- >>> plusNZ (NotZero True (pos 5)) (NotZero False (pos 3)) +-- Just (NotZero True (Positive 2)) +-- +-- >>> plusNZ (NotZero False (pos 5)) (NotZero True (pos 3)) +-- Just (NotZero False (Positive 2)) +plusNZ :: + NotZero -> + NotZero -> + Maybe NotZero +plusNZ (NotZero s1 (Positive x)) (NotZero s2 (Positive y)) = + case (s1, s2) of + (True, True) -> Just (NotZero True (Positive (x + y))) + (False, False) -> Just (NotZero False (Positive (x + y))) + (True, False) + | x == y -> Nothing + | x < y -> Just (NotZero False (Positive (y - x))) + | True -> Just (NotZero True (Positive (x - y))) + (False, True) + | x == y -> Nothing + | y < x -> Just (NotZero False (Positive (x - y))) + | True -> Just (NotZero True (Positive (y - x))) + +-- | Multiply two 'NotZero' values. Always non-zero. +-- +-- >>> multiplyNZ (NotZero True (pos 3)) (NotZero True (pos 4)) +-- NotZero True (Positive 12) +-- +-- >>> multiplyNZ (NotZero False (pos 3)) (NotZero True (pos 4)) +-- NotZero False (Positive 12) +-- +-- >>> multiplyNZ (NotZero False (pos 3)) (NotZero False (pos 4)) +-- NotZero True (Positive 12) +multiplyNZ :: + NotZero -> + NotZero -> + NotZero +multiplyNZ (NotZero s1 (Positive x)) (NotZero s2 (Positive y)) = + NotZero (s1 == s2) (Positive (x * y)) + +-- | Return the 'NotZero' if the prism matches, otherwise positive one. +-- +-- >>> notZeroOr (5 :: Integer) +-- NotZero True (Positive 5) +-- +-- >>> notZeroOr (0 :: Integer) +-- NotZero True (Positive 1) +-- +-- >>> notZeroOr (-3 :: Integer) +-- NotZero False (Positive 3) +notZeroOr :: + (AsNotZero a) => + a -> + NotZero +notZeroOr n = + fromMaybe (NotZero True one') (n ^? _NotZero) + +-- | Prism from 'NotZero' to 'Positive' (matches only positive values). +-- +-- >>> (NotZero True (pos 5)) ^? _Positive +-- Just (Positive 5) +-- +-- >>> (NotZero False (pos 5)) ^? _Positive +-- Nothing +instance AsPositive NotZero where + _Positive = + prism' + positiveNotZero + (\(NotZero s p) -> if s then Just p else Nothing) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} -module Main where +module Main (main) where import System.Exit (exitWith) import System.Process (rawSystem)