diff --git a/changelog.txt b/changelog.txt deleted file mode 100644 --- a/changelog.txt +++ /dev/null @@ -1,3 +0,0 @@ -v1 - Initial release -v1.0.0.1 - Added tests, added a few examples to the docs -v1.0.0.2 - Support GHC 9.2 and text-2.0, drop hedgehog dependency diff --git a/license.txt b/license.txt --- a/license.txt +++ b/license.txt @@ -1,4 +1,4 @@ -Copyright 2021 Mission Valley Software LLC +Copyright 2021-2022 Mission Valley Software LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in diff --git a/nat-optics.cabal b/nat-optics.cabal --- a/nat-optics.cabal +++ b/nat-optics.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: nat-optics -version: 1.0.0.2 +version: 1.0.0.3 category: Numeric, Optics synopsis: @@ -17,7 +17,7 @@ to cover basic usage, but you probably also want to import the "Optics" module from the `optics` package. -copyright: 2021 Mission Valley Software LLC +copyright: 2021-2022 Mission Valley Software LLC license: MIT license-file: license.txt @@ -29,8 +29,6 @@ build-type: Simple -extra-source-files: changelog.txt - source-repository head type: git location: https://github.com/typeclasses/nat-optics @@ -39,37 +37,33 @@ default-language: Haskell2010 ghc-options: -Wall default-extensions: DerivingStrategies + , FlexibleContexts , GeneralizedNewtypeDeriving , NoImplicitPrelude , TypeApplications common dependencies - build-depends: base ^>= 4.14 || ^>= 4.15 || ^>= 4.16 - , text ^>= 1.2.3 || ^>= 2.0 + build-depends: base ^>= 4.14 || ^>= 4.15 || ^>= 4.16 + , text ^>= 1.2.3.2 || ^>= 2.0 , optics-core ^>= 0.4 -common test - import: language - , dependencies - build-depends: nat-optics - other-modules: TestPrelude - library import: language , dependencies hs-source-dirs: src exposed-modules: NatOptics.NonNegative + , NatOptics.NonNegative.Unsafe , NatOptics.Positive + , NatOptics.Positive.Math + , NatOptics.Positive.Unsafe + , NatOptics.Signed other-modules: NatOptics.Internal -test-suite NonNegative - import: test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: NonNegative.hs - -test-suite Positive - import: test +test-suite nat-optics-test + import: language + , dependencies type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Positive.hs + main-is: Main.hs + build-depends: nat-optics + , hspec ^>= 2.8 || ^>= 2.9 || ^>= 2.10 diff --git a/src/NatOptics/Internal.hs b/src/NatOptics/Internal.hs --- a/src/NatOptics/Internal.hs +++ b/src/NatOptics/Internal.hs @@ -1,4 +1,10 @@ -module NatOptics.Internal ( strNat, textStr ) where +{-# language Trustworthy #-} + +module NatOptics.Internal + ( + strNat, textStr, + ) + where import Control.Monad ( mfilter ) import Data.Eq ( (==) ) diff --git a/src/NatOptics/NonNegative.hs b/src/NatOptics/NonNegative.hs --- a/src/NatOptics/NonNegative.hs +++ b/src/NatOptics/NonNegative.hs @@ -1,3 +1,5 @@ +{-# language Trustworthy #-} + module NatOptics.NonNegative ( {- * Type constructor -} NonNegative, @@ -6,13 +8,12 @@ natIso, textPrism, stringPrism, {- * Re-exports -} Natural, Integer, Prism', Iso', - view, review, preview + view, review, preview, ) where import Control.Applicative ( (*>) ) import Control.Monad ( guard ) import Data.Bits ( Bits, toIntegralSized ) -import Data.Eq ( Eq ) import Data.Function ( (.) ) import Data.Functor ( fmap, ($>), (<$>) ) import Data.Maybe ( Maybe ) @@ -29,10 +30,8 @@ import Optics.Review ( review ) import Prelude ( Integer, Integral, Num, fromIntegral, toInteger ) -import Text.Show ( Show ) -newtype NonNegative number = NonNegative{ number :: number } - deriving newtype (Eq, Ord, Show) +import NatOptics.NonNegative.Unsafe (NonNegative (..)) {- | For any numeric type @n@, @'NonNegative' n@ is a subset of @n@. @@ -53,7 +52,7 @@ natPrism = prism' (fromIntegral . number) - (fmap NonNegative . toIntegralSized) {- No need to verify + (fmap NonNegativeUnsafe . toIntegralSized) {- No need to verify here, because Natural is always non-negative. The only check here is when converting from 'Natural' to ensure that it does not overflow the max bound of 'n'. -} @@ -65,7 +64,7 @@ {- | 'Natural' and @'NonNegative' 'Natural'@ are the same thing. -} natIso :: Iso' Natural (NonNegative Natural) -natIso = iso NonNegative number +natIso = iso NonNegativeUnsafe number stringPrism :: (Integral n, Bits n) => Prism' String (NonNegative n) stringPrism = strNat % natPrism @@ -74,8 +73,8 @@ textPrism = textStr % stringPrism verify :: (Ord n, Num n) => n -> Maybe (NonNegative n) -verify n = guard (n >= 0) $> NonNegative n +verify n = guard (n >= 0) $> NonNegativeUnsafe n verifyAndResize :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe (NonNegative b) -verifyAndResize x = verify x *> (NonNegative <$> toIntegralSized x) +verifyAndResize x = verify x *> (NonNegativeUnsafe <$> toIntegralSized x) diff --git a/src/NatOptics/NonNegative/Unsafe.hs b/src/NatOptics/NonNegative/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/NatOptics/NonNegative/Unsafe.hs @@ -0,0 +1,14 @@ +{-# language Unsafe #-} + +module NatOptics.NonNegative.Unsafe + ( + NonNegative (..), + ) + where + +import Data.Eq ( Eq ) +import Data.Ord ( Ord ) +import Text.Show ( Show ) + +newtype NonNegative number = NonNegativeUnsafe{ number :: number } + deriving newtype (Eq, Ord, Show) diff --git a/src/NatOptics/Positive.hs b/src/NatOptics/Positive.hs --- a/src/NatOptics/Positive.hs +++ b/src/NatOptics/Positive.hs @@ -1,3 +1,5 @@ +{-# language Trustworthy #-} + module NatOptics.Positive ( {- * Type constructor -} Positive, @@ -6,13 +8,12 @@ textPrism, stringPrism, {- * Re-exports -} Natural, Integer, Prism', - view, review, preview + view, review, preview, ) where import Control.Applicative ( (*>) ) import Control.Monad ( guard ) import Data.Bits ( Bits, toIntegralSized ) -import Data.Eq ( Eq ) import Data.Function ( (.) ) import Data.Functor ( ($>), (<$>) ) import Data.Maybe ( Maybe ) @@ -28,10 +29,8 @@ import Optics.Review ( review ) import Prelude ( Integer, Integral, Num, fromIntegral, toInteger ) -import Text.Show ( Show ) -newtype Positive number = Positive{ number :: number } - deriving newtype (Eq, Ord, Show) +import NatOptics.Positive.Unsafe (Positive (..)) {- | For any numeric type @n@, @'Positive' n@ is a subset of @n@. @@ -63,7 +62,7 @@ textPrism = textStr % stringPrism verify :: (Num n, Ord n) => n -> Maybe (Positive n) -verify n = guard (n > 0) $> Positive n +verify n = guard (n > 0) $> PositiveUnsafe n verifyAndResize :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe (Positive b) -verifyAndResize x = verify x *> (Positive <$> toIntegralSized x) +verifyAndResize x = verify x *> (PositiveUnsafe <$> toIntegralSized x) diff --git a/src/NatOptics/Positive/Math.hs b/src/NatOptics/Positive/Math.hs new file mode 100644 --- /dev/null +++ b/src/NatOptics/Positive/Math.hs @@ -0,0 +1,33 @@ +{-# language Trustworthy #-} + +module NatOptics.Positive.Math + ( + minus, + plus, + ) + where + +import Data.Maybe ( Maybe (..) ) +import Data.Ord ( Ord, (<) ) +import Optics.Core ( preview, review ) +import Prelude ( Num, abs, (+), (-) ) + +import NatOptics.Positive.Unsafe ( Positive (..) ) +import qualified NatOptics.Positive as Positive + +import NatOptics.Signed ( Signed ) +import qualified NatOptics.Signed as Signed + +plus :: Num n => Positive n -> Positive n -> Positive n +plus (PositiveUnsafe a) (PositiveUnsafe b) = PositiveUnsafe (a + b) + +minus :: (Num n, Ord n) => Positive n -> Positive n -> Signed n +minus a b = + let + a' = review Positive.refine a + b' = review Positive.refine b + diff = a' - b' + in + case preview Positive.refine (abs diff) of + Nothing -> Signed.Zero + Just diff' -> if diff < 0 then Signed.Minus diff' else Signed.Plus diff' diff --git a/src/NatOptics/Positive/Unsafe.hs b/src/NatOptics/Positive/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/NatOptics/Positive/Unsafe.hs @@ -0,0 +1,10 @@ +{-# language Unsafe #-} + +module NatOptics.Positive.Unsafe where + +import Data.Eq ( Eq ) +import Data.Ord ( Ord ) +import Text.Show ( Show ) + +newtype Positive number = PositiveUnsafe{ number :: number } + deriving newtype (Eq, Ord, Show) diff --git a/src/NatOptics/Signed.hs b/src/NatOptics/Signed.hs new file mode 100644 --- /dev/null +++ b/src/NatOptics/Signed.hs @@ -0,0 +1,31 @@ +{-# language Trustworthy #-} + +module NatOptics.Signed + ( + Signed (..), + intIso, + ) + where + +import Data.Eq ( Eq ) +import Data.Ord ( Ord, compare, Ordering (..) ) +import Text.Show ( Show ) +import Optics.Core ( Iso', iso ) +import Prelude ( Integer, abs, negate ) + +import NatOptics.Positive.Unsafe ( Positive (..) ) + +data Signed n = Zero | Minus (Positive n) | Plus (Positive n) + deriving stock (Eq, Ord, Show) + +intIso :: Iso' Integer (Signed Integer) +intIso = iso f g + where + f x = case compare x 0 of + EQ -> Zero + LT -> Minus (PositiveUnsafe (abs x)) + GT -> Plus (PositiveUnsafe x) + g y = case y of + Zero -> 0 + Plus (PositiveUnsafe x) -> x + Minus (PositiveUnsafe x) -> negate x diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,71 @@ +module Main (main) where + +import Test.Hspec +import Prelude + +import Data.Int (Int16, Int32) +import Data.Maybe (isNothing) +import Optics.Core (preview, review, view) + +import qualified NatOptics.Positive as Pos +import qualified NatOptics.Positive.Unsafe as Pos +import qualified NatOptics.Positive.Math as Pos.Math +import qualified NatOptics.NonNegative as NN +import qualified NatOptics.NonNegative.Unsafe as NN +import qualified NatOptics.Signed as S + +main :: IO () +main = hspec $ do + nonNegativeSpec + positiveSpec + signedSpec + mathSpec + +nonNegativeSpec :: SpecWith () +nonNegativeSpec = describe "NonNegative" $ do + describe "0" $ do + specify "preview stringPrism" $ preview (NN.stringPrism @Int32) "0" `shouldBe` Just (NN.NonNegativeUnsafe 0) + specify "review refine" $ review NN.refine (NN.NonNegativeUnsafe @Int32 0) `shouldBe` 0 + specify "review stringPrism" $ review NN.stringPrism (NN.NonNegativeUnsafe @Int32 0) `shouldBe` "0" + describe "57" $ do + specify "preview stringPrism" $ preview (NN.stringPrism @Int32) "57" `shouldBe` Just (NN.NonNegativeUnsafe 57) + specify "refine" $ review NN.refine (NN.NonNegativeUnsafe @Int32 57) `shouldBe` 57 + specify "stringPrism" $ review NN.stringPrism (NN.NonNegativeUnsafe @Int32 57) `shouldBe` "57" + describe "preview stringPrism" $ do + let examples = [ "-0", "-1", "00", "𝟝𝟟", "57 ", "057", "9999999999999999999999999999" ] + specify "failures" $ all (isNothing . preview (NN.stringPrism @Int32)) examples + +positiveSpec :: SpecWith () +positiveSpec = describe "Positive" $ do + describe "1" $ do + specify "preview stringPrism" $ preview (Pos.stringPrism @Int16) "1" `shouldBe` Just (Pos.PositiveUnsafe 1) + specify "refine" $ review Pos.refine (Pos.PositiveUnsafe @Int16 1) `shouldBe` 1 + specify "stringPrism" $ review Pos.stringPrism (Pos.PositiveUnsafe @Int16 1) `shouldBe` "1" + describe "57" $ do + specify "preview stringPrism" $ preview (Pos.stringPrism @Int16) "57" `shouldBe` Just (Pos.PositiveUnsafe 57) + specify "refine" $ review Pos.refine (Pos.PositiveUnsafe @Int16 57) `shouldBe` 57 + specify "stringPrism" $ review Pos.stringPrism (Pos.PositiveUnsafe @Int16 57) `shouldBe` "57" + describe "stringPrism" $ do + let examples = [ "0", "-0", "-1", "00", "𝟝𝟟", "57 ", "057", "99999999999999999999999" ] + specify "failures" $ all (isNothing . preview (Pos.stringPrism @Int16)) examples + +signedSpec :: SpecWith () +signedSpec = describe "Signed" $ do + describe "intIso" $ do + describe "view" $ do + specify "0" $ view S.intIso 0 `shouldBe` S.Zero + specify "3" $ view S.intIso 3 `shouldBe` S.Plus (Pos.PositiveUnsafe 3) + specify "-5" $ view S.intIso (-5) `shouldBe` S.Minus (Pos.PositiveUnsafe 5) + describe "review" $ do + specify "0" $ review S.intIso S.Zero `shouldBe` 0 + specify "3" $ review S.intIso (S.Plus (Pos.PositiveUnsafe 3)) `shouldBe` 3 + specify "-5" $ review S.intIso (S.Minus (Pos.PositiveUnsafe 5)) `shouldBe` (-5) + +mathSpec :: SpecWith () +mathSpec = describe "Positive math" $ do + describe "plus" $ do + specify "10 + 5" $ Pos.Math.plus (Pos.PositiveUnsafe 10) (Pos.PositiveUnsafe 5) `shouldBe` Pos.PositiveUnsafe @Int32 15 + describe "minus" $ do + specify "3 - 3" $ Pos.Math.minus (Pos.PositiveUnsafe 3) (Pos.PositiveUnsafe 3) `shouldBe` S.Zero @Int32 + specify "3 - 5" $ Pos.Math.minus (Pos.PositiveUnsafe 3) (Pos.PositiveUnsafe 5) `shouldBe` S.Minus @Int32 (Pos.PositiveUnsafe 2) + specify "9 - 5" $ Pos.Math.minus (Pos.PositiveUnsafe 9) (Pos.PositiveUnsafe 5) `shouldBe` S.Plus @Int32 (Pos.PositiveUnsafe 4) diff --git a/test/NonNegative.hs b/test/NonNegative.hs deleted file mode 100644 --- a/test/NonNegative.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Main (main) where - -import NatOptics.NonNegative -import TestPrelude - -main :: IO () -main = main' failures - -failures :: [Failure] -failures = - case preview (stringPrism @Int32) "0" of - Nothing -> fail' "preview (stringPrism @Int32) \"0\" = Nothing" - Just n -> - case review refine n of - 0 -> okay - result -> fail' $ "review refine" ! show' n ! "=" ! show result - <> - case review stringPrism n of - "0" -> okay - result -> fail' $ "review stringPrism" ! show' n ! "=" ! show result - <> - case preview (stringPrism @Int32) "57" of - Nothing -> fail' "preview (stringPrism @Int32) \"57\" = Nothing" - Just n -> - case review refine n of - 57 -> okay - result -> fail' $ "review refine" ! show' n ! "=" ! show result - <> - case review stringPrism n of - "57" -> okay - result -> fail' $ "review stringPrism" ! show' n ! "=" ! show result - <> - foldMap - (\x -> case preview (stringPrism @Int32) x of - Nothing -> okay - result -> fail' $ "preview (stringPrism @Int32)" ! show' x ! "=" ! show result - ) - [ "-0", "-1", "00", "𝟝𝟟", "57 ", "057" - , "9999999999999999999999999999" ] diff --git a/test/Positive.hs b/test/Positive.hs deleted file mode 100644 --- a/test/Positive.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Main (main) where - -import NatOptics.Positive -import TestPrelude - -main :: IO () -main = main' failures - -failures :: [Failure] -failures = - case preview (stringPrism @Int16) "1" of - Nothing -> fail' "preview (stringPrism @Int16) \"1\" = Nothing" - Just n -> - case review refine n of - 1 -> okay - result -> fail' $ "review refine" ! show' n ! "=" ! show result - <> - case review stringPrism n of - "1" -> okay - result -> fail' $ "review stringPrism" ! show' n ! "=" ! show result - <> - case preview (stringPrism @Int16) "57" of - Nothing -> fail' "preview (stringPrism @Int16) \"57\" = Nothing" - Just n -> - case review refine n of - 57 -> okay - result -> fail' $ "review refine" ! show' n ! "=" ! show result - <> - case review stringPrism n of - "57" -> okay - result -> fail' $ "review stringPrism" ! show' n ! "=" ! show result - <> - foldMap - (\x -> case preview (stringPrism @Int16) x of - Nothing -> okay - result -> fail' $ "preview (stringPrism @Int16)" ! show' x ! "=" ! show result - ) - [ "0", "-0", "-1", "00", "𝟝𝟟", "57 ", "057" - , "99999999999999999999999" ] diff --git a/test/TestPrelude.hs b/test/TestPrelude.hs deleted file mode 100644 --- a/test/TestPrelude.hs +++ /dev/null @@ -1,29 +0,0 @@ -module TestPrelude (module X, Failure (..), main', show', okay, fail', (!)) where - -import Control.Monad as X -import Data.Foldable as X -import Data.Int as X -import Optics.Optic as X -import Optics.Re as X -import Prelude as X -import System.Exit as X - -data Failure = Failure String - -main' :: [Failure] -> IO () -main' failures = - unless (null failures) $ do - for_ failures $ \(Failure x) -> putStrLn ("🔥 " ++ x) - exitFailure - -show' :: Show a => a -> String -show' x = showsPrec 11 x "" - -okay :: [Failure] -okay = [] - -fail' :: String -> [Failure] -fail' x = [Failure x] - -(!) :: String -> String -> String -x ! y = x <> " " <> y