diff --git a/primus.cabal b/primus.cabal --- a/primus.cabal +++ b/primus.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: primus -version: 0.2.0.0 +version: 0.3.0.0 synopsis: nonempty and positive functions description: A library containing positive-valued and nonempty functions . Please see the README on GitHub at category: Data, General diff --git a/src/Primus/Enum.hs b/src/Primus/Enum.hs --- a/src/Primus/Enum.hs +++ b/src/Primus/Enum.hs @@ -136,16 +136,16 @@ -- | calculates the minimum and maximum range of enumerations that can be stored in a container of the given size capacity :: forall a t z. (Bounded a, Enum a, Foldable t) => t z -> Either String (Integer, Integer) -capacity (length -> len) = do +capacity (length -> len) = lmsg "capacity" $ do let z@(mn, mx) = minMax @a lhs <- case compare mn 0 of LT -> Right (-(-mn + 1) ^ len + 1) EQ -> Right 0 - GT -> Left $ "capacity: unsupported mn > 0: " ++ show z + GT -> Left $ "unsupported mn > 0: " ++ show z rhs <- case compare 0 mx of LT -> Right ((mx + 1) ^ len - 1) EQ -> Right 0 - GT -> Left $ "capacity: unsupported mx < 0: " ++ show z + GT -> Left $ "unsupported mx < 0: " ++ show z pure (lhs, rhs) {- | convert toEnum of "a" into a list containing "a"s diff --git a/src/Primus/Error.hs b/src/Primus/Error.hs --- a/src/Primus/Error.hs +++ b/src/Primus/Error.hs @@ -29,6 +29,7 @@ -- * decorate an error lmsg, + -- * miscellaneous (.@), ) where diff --git a/src/Primus/Fold.hs b/src/Primus/Fold.hs --- a/src/Primus/Fold.hs +++ b/src/Primus/Fold.hs @@ -148,7 +148,7 @@ ([a] -> [a] -> a -> b) -> t a -> t b -histMapImpl' isright f = snd . bool histMapL histMapR isright g () +histMapImpl' isright f = snd . histMapImpl isright g () where g :: [a] -> [a] -> () -> a -> ((), b) g ps ft () a = ((), f ps ft a) @@ -314,8 +314,12 @@ deriving stock (Ord, Show, Eq, Functor, Traversable, Foldable) -- | compare lengths of foldables -compareLengths :: Foldable t => NonEmpty (t a) -> [CLCount a] -compareLengths (xs :| xss) = map (compareLengthBy mempty xs) xss +compareLengths :: forall a b t u + . (Foldable t,Foldable u) + => t a + -> [u b] + -> [CLCount b] +compareLengths xs = map (compareLengthBy mempty xs) -- | compare length where lhs or rhs can be infinite but not both compareLength :: diff --git a/src/Primus/Lens.hs b/src/Primus/Lens.hs --- a/src/Primus/Lens.hs +++ b/src/Primus/Lens.hs @@ -10,6 +10,7 @@ Lens', lens, Iso, + Iso', iso, Traversal, _Fst, @@ -21,7 +22,7 @@ -- | lens type synonym type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t --- | restricted lens type synonym +-- | simpler lens type synonym type Lens' s a = Lens s s a a -- | create a lens @@ -32,6 +33,9 @@ -- | isomorphism type synonym type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) +-- | simpler isomorphism type synonym +type Iso' s a = Iso s s a a + -- | create an isomoprhism iso :: (s -> a) -> (b -> t) -> Iso s t a b iso sa bt = dimap sa (fmap bt) @@ -40,12 +44,12 @@ -- | traversal type synonym type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t --- | simple lens for accessing the first value in a tuple +-- | lens for accessing the first value in a tuple _Fst :: forall a x a'. Lens (a, x) (a', x) a a' _Fst = lens fst (\(_, x) a' -> (a', x)) {-# INLINE _Fst #-} --- | simple lens for accessing the second value in a tuple +-- | lens for accessing the second value in a tuple _Snd :: forall x b b'. Lens (x, b) (x, b') b b' _Snd = lens snd (\(x, _) b' -> (x, b')) {-# INLINE _Snd #-} diff --git a/src/Primus/List.hs b/src/Primus/List.hs --- a/src/Primus/List.hs +++ b/src/Primus/List.hs @@ -47,6 +47,10 @@ allEqualBy, snocL, unsnocL, + unsnocL', + list, + list', + listSnoc, ) where import Control.Arrow @@ -117,7 +121,7 @@ -- | split a list preserving information about the split splitAtL :: forall a. Int -> [a] -> ([a], SplitL a) splitAtL n xs - | n < 0 = (xs, SplitLNeg (unsafePos "x" (-n))) + | n < 0 = (xs, SplitLNeg (unsafePos "splitAtL" (-n))) | otherwise = go 0 xs where go :: Int -> [a] -> ([a], SplitL a) @@ -241,13 +245,31 @@ [] -> pure mempty a : as -> (\b -> bool first second b (a :)) <$> f a <*> go as +-- | break up a list into cases using cons +list :: b -> (a -> [a] -> b) -> [a] -> b +list z s = \case + [] -> z + a:as -> s a as + +-- | break up a list into cases using cons +list' :: [a] -> b -> (a -> [a] -> b) -> b +list' as z s = list z s as + +-- | break up a list into cases using snoc +listSnoc :: b -> ([a] -> a -> b) -> [a] -> b +listSnoc z s = maybe z (uncurry s) . unsnocL + -- | snoc for a list snocL :: [a] -> a -> [a] snocL as a = as ++ [a] +-- | unsnoc for a list +unsnocL :: [a] -> Maybe ([a], a) +unsnocL = list Nothing (Just .@ unsnocL') + -- | unsnoc for a value and a list -unsnocL :: a -> [a] -> ([a], a) -unsnocL a = +unsnocL' :: a -> [a] -> ([a], a) +unsnocL' a = \case [] -> ([], a) - x : xs -> first (a :) (unsnocL x xs) + x : xs -> first (a :) (unsnocL' x xs) diff --git a/src/Primus/NonEmpty.hs b/src/Primus/NonEmpty.hs --- a/src/Primus/NonEmpty.hs +++ b/src/Primus/NonEmpty.hs @@ -93,6 +93,10 @@ findDupsBy, replicate1, replicate1M, + + nonemptySnoc, + nonempty, + nonempty', ) where import Control.Arrow @@ -161,7 +165,7 @@ chunksRange1 :: Pos -> Pos -> NonEmpty a -> NonEmpty (NonEmpty a) chunksRange1 n (Pos skip) = unfoldr1NE (take1 n &&& N.drop skip) -{- | creates a nonempty container of length "sz" with chunks of a given size: @see 'chunkNLen' +{- | creates a nonempty container of length "sz" with chunks of a given size: see 'chunkNLen' must fill the container exactly -} chunkNLen1 :: @@ -312,6 +316,15 @@ go :: a -> [a] -> ([a], a) go n [] = ([], n) go n (x : xs) = first (n :) (go x xs) + +nonempty :: (a -> [a] -> b) -> NonEmpty a -> b +nonempty f (a:|as) = f a as + +nonempty' :: NonEmpty a -> (a -> [a] -> b) -> b +nonempty' = flip nonempty + +nonemptySnoc :: ([a] -> a -> b) -> NonEmpty a -> b +nonemptySnoc f = uncurry f . unsnoc1 -- | uncons for a nonempty list uncons1 :: forall a. NonEmpty a -> (a, [a]) diff --git a/src/Primus/Num1.hs b/src/Primus/Num1.hs --- a/src/Primus/Num1.hs +++ b/src/Primus/Num1.hs @@ -92,14 +92,12 @@ | otherwise = Right $ naturalFromInteger i instance Num1 Pos - +instance Num1 Word instance Num1 Word8 instance Num1 Word16 instance Num1 Word32 instance Num1 Word64 - instance Num1 Int - instance Num1 Int8 instance Num1 Int16 instance Num1 Int32 diff --git a/src/Primus/TypeLevel.hs b/src/Primus/TypeLevel.hs --- a/src/Primus/TypeLevel.hs +++ b/src/Primus/TypeLevel.hs @@ -138,7 +138,7 @@ -- | unsnoc a type level nonempty list type UnsnocT :: forall k. [k] -> ([k], k) type family UnsnocT ns where - UnsnocT '[] = GL.TypeError ('GL.Text "UnsnocT: undefined for empty indices") + UnsnocT '[] = GL.TypeError ( 'GL.Text "UnsnocT: undefined for empty indices") UnsnocT '[a] = '( '[], a) UnsnocT (a ': a1 ': as) = FirstConsT a (UnsnocT (a1 ': as)) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -10,8 +10,8 @@ import qualified TestList import qualified TestNonEmpty import qualified TestNum1 -import qualified TestZipNonEmpty import qualified TestTypeLevel +import qualified TestZipNonEmpty main :: IO () main = do diff --git a/test/TestEnum.hs b/test/TestEnum.hs --- a/test/TestEnum.hs +++ b/test/TestEnum.hs @@ -206,10 +206,10 @@ @?= Right (-35723051648, 34359738367) , testCase "capacity" $ capacity @NegOnly [] - @?= Left "capacity: unsupported mx < 0: (-3,-1)" + @?= Left "capacity:unsupported mx < 0: (-3,-1)" , testCase "capacity" $ capacity @PosOnly ['x'] - @?= Left "capacity: unsupported mn > 0: (1,3)" + @?= Left "capacity:unsupported mn > 0: (1,3)" , testCase "universeTraversable" $ universeTraversable [EQ] @?= Right ([LT] :| [[EQ], [GT]]) diff --git a/test/TestFold.hs b/test/TestFold.hs --- a/test/TestFold.hs +++ b/test/TestFold.hs @@ -95,7 +95,7 @@ compareLength ('a' :| ['b' .. 'g']) [100 :: Int .. 106] @?= CEQ , testCase "compareLengths" $ - compareLengths ([1 :: Int .. 5] :| [[101 .. 110], [201 .. 205], [301 .. 302], [], [1001 .. 1020]]) + compareLengths @Int @Int [1 .. 5] [[101 .. 110], [201 .. 205], [301 .. 302], [], [1001 .. 1020]] @?= [ CLT (106 :| [107, 108, 109, 110]) , CEQ , CGT @@ -103,10 +103,32 @@ , CLT (1006 :| [1007, 1008, 1009, 1010, 1011, 1012, 1013, 1014, 1015, 1016, 1017, 1018, 1019, 1020]) ] , testCase "compareLengths" $ - compareLengths ([1 :: Int .. 5] :| [[101 .. 110]]) + compareLengths @Char @Int ['a' .. 'z'] [[101 .. 110], [201 .. 205], [301 .. 302], [], [1001 .. 1020]] + @?= [CGT,CGT,CGT,CGT,CGT] + , testCase "compareLengths" $ + compareLengths @Char @Int ['a' .. 'd'] [[101 .. 104], [201 .. 204], [301 .. 302], [], [1001 .. 1010]] + @?= [ CEQ + , CEQ + , CGT + , CGT + , CLT (1005 :| [1006,1007,1008,1009,1010]) + ] + + , testCase "compareLengths" $ + compareLengths @Char @Int ['a' .. 'd'] [[101 .. 110], [201 .. 205], [301 .. 302], [], [1001 .. 1010]] + @?= + [ CLT (105 :| [106,107,108,109,110]) + , CLT (205 :| []) + , CGT + , CGT + , CLT (1005 :| [1006,1007,1008,1009,1010]) + ] + + , testCase "compareLengths" $ + compareLengths @Int @Int [1 .. 5] [[101 .. 110]] @?= [CLT (106 :| [107 .. 110])] , testCase "compareLengths" $ - compareLengths ([1 :: Int .. 5] :| []) + compareLengths @Int @Int @_ @[] [1 .. 5] [] @?= [] , testCase "compareLength infinite lhs" $ compareLength [1 :: Int ..] ['a' .. 'f'] diff --git a/test/TestList.hs b/test/TestList.hs --- a/test/TestList.hs +++ b/test/TestList.hs @@ -94,4 +94,12 @@ , 13 ] ) + , testCase "list" $ + list 'x' undefined ([] :: [()]) @?= 'x' + , testCase "listSnoc" $ + listSnoc 'x' undefined ([] :: [()]) @?= 'x' + , testCase "list" $ + list undefined (,) [1::Int ..5] @?= (1,[2..5]) + , testCase "listSnoc" $ + listSnoc undefined (,) [1::Int ..5] @?= ([1,2,3,4],5) ] diff --git a/test/TestNum1.hs b/test/TestNum1.hs --- a/test/TestNum1.hs +++ b/test/TestNum1.hs @@ -8,6 +8,7 @@ import Data.Pos import Data.Word +import Data.Int import GHC.Natural import Primus.Num1 import Test.Tasty @@ -87,4 +88,45 @@ , testCase "withOp2" $ fromInteger1 (100 :: Word8) 122 @?= Right @_ @Word8 122 + , testCase ".-" $ + (Right _4P .- Right _3P) @?= Right _1P + , testCase ".-" $ + (Right _4P .- Right _4P) @?= Left "(.-):integerToEnumSafe:underflow where 0 not in range [1..9223372036854775807]" + , testCase ".-" $ + (Right _4P .- Right _13P) @?= Left "(.-):integerToEnumSafe:underflow where -9 not in range [1..9223372036854775807]" + , testCase ".- .* .+" $ + (Right _2P .* Right _20P .+ Right _4P .- Right (_P @42)) @?= Right _2P + , testCase "abs1" $ + negate1 (Right _19P) @?= Left "negate1:integerToEnumSafe:underflow where -19 not in range [1..9223372036854775807]" + , testCase "abs1" $ + abs1 (Right _1P) @?= Right _1P + , testCase "abs1" $ + abs1 (Right _5P) @?= Right _5P + , testCase "signum1" $ + signum1 (Right _19P) @?= Right _1P + , testCase "negate1" $ + negate1 (Right _2P) @?= Left "negate1:integerToEnumSafe:underflow where -2 not in range [1..9223372036854775807]" + + , testCase "negate1" $ + negate1 (Right @_ @Word8 0) @?= Right 0 + , testCase "abs1" $ + abs1 (Right @_ @Word8 14) @?= Right 14 + , testCase "signum1" $ + signum1 (Right @_ @Word8 14) @?= Right 1 + , testCase "signum1" $ + signum1 (Right @_ @Word8 0) @?= Right 0 + + , testCase "negate1" $ + negate1 (Right @_ @Int8 14) @?= Right (-14) + , testCase "negate1" $ + negate1 (Right @_ @Int8 0) @?= Right 0 + , testCase "abs1" $ + negate1 (Right @_ @Int8 (-14)) @?= Right 14 + , testCase "signum1" $ + signum1 (Right @_ @Int8 (-14)) @?= Right (-1) + , testCase "signum1" $ + signum1 (Right @_ @Int8 0) @?= Right 0 + , testCase "signum1" $ + signum1 (Right @_ @Int8 14) @?= Right 1 + ] diff --git a/test/TestTypeLevel.hs b/test/TestTypeLevel.hs --- a/test/TestTypeLevel.hs +++ b/test/TestTypeLevel.hs @@ -1,42 +1,42 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module TestTypeLevel where - -import Primus.TypeLevel -import Data.List.NonEmpty (NonEmpty(..)) -import Test.Tasty -import Data.Pos -import Test.Tasty.HUnit - -doit :: IO () -doit = defaultMain suite - -suite :: TestTree -suite = - testGroup - "TestTypeLevel" - [ testCase "LengthT" $ - pnat @(LengthT '[]) @?= 0 - , testCase "LengthT" $ - pnat @(LengthT '[ 1,2,3]) @?= 3 - , testCase "LengthT" $ - pnat @(LengthT '[ 1,2,3,4,5,6,7,8,9,10]) @?= 10 - , testCase "LengthT" $ - pnat @(LengthT '[ 1,2,3,4,5,6,7,8,9,10,11]) @?= 11 - , testCase "LengthT" $ - pnat @(LengthT '[ 1,2,3,4,5,6,7,8,9]) @?= 9 - , testCase "LastT" $ - pnat @(LastT '[ 1,2,3]) @?= 3 - , testCase "InitT" $ - fromNSP @(InitT '[ 1,2,3]) @?= _1P :| [_2P] - , testCase "SnocT" $ - fromNSP @(SnocT '[ 1,2,3] 5) @?= _1P :| [_2P,_3P,_5P] - , testCase "UnsnocT Fst" $ - fromNSP @(Fst (UnsnocT '[ 1,2,3,4])) @?= _1P :| [_2P,_3P] - , testCase "UnsnocT Snd" $ - fromNP @(Snd (UnsnocT '[ 1,2,3,4])) @?= _4P - ] +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module TestTypeLevel where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Pos +import Primus.TypeLevel +import Test.Tasty +import Test.Tasty.HUnit + +doit :: IO () +doit = defaultMain suite + +suite :: TestTree +suite = + testGroup + "TestTypeLevel" + [ testCase "LengthT" $ + pnat @(LengthT '[]) @?= 0 + , testCase "LengthT" $ + pnat @(LengthT '[1, 2, 3]) @?= 3 + , testCase "LengthT" $ + pnat @(LengthT '[1, 2, 3, 4, 5, 6, 7, 8, 9, 10]) @?= 10 + , testCase "LengthT" $ + pnat @(LengthT '[1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11]) @?= 11 + , testCase "LengthT" $ + pnat @(LengthT '[1, 2, 3, 4, 5, 6, 7, 8, 9]) @?= 9 + , testCase "LastT" $ + pnat @(LastT '[1, 2, 3]) @?= 3 + , testCase "InitT" $ + fromNSP @(InitT '[1, 2, 3]) @?= _1P :| [_2P] + , testCase "SnocT" $ + fromNSP @(SnocT '[1, 2, 3] 5) @?= _1P :| [_2P, _3P, _5P] + , testCase "UnsnocT Fst" $ + fromNSP @(Fst (UnsnocT '[1, 2, 3, 4])) @?= _1P :| [_2P, _3P] + , testCase "UnsnocT Snd" $ + fromNP @(Snd (UnsnocT '[1, 2, 3, 4])) @?= _4P + ]