primus 0.1.0.0 → 0.2.0.0

raw patch · 21 files changed

+99/−174 lines, 21 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- Primus.Extra: (.@) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

- Primus.Extra: comparing1 :: forall f a a' b. Ord b => (forall x. f x -> b) -> f a -> f a' -> Ordering

- Primus.Extra: infixr 8 .@

- Primus.Extra: on1 :: forall f a a' b c. (b -> b -> c) -> (forall x. f x -> b) -> f a -> f a' -> c

- Primus.Extra: on2 :: forall f a a' a2 a2' b c. (b -> b -> c) -> (forall x y. f x y -> b) -> f a a2 -> f a' a2' -> c

+ Primus.Error: (.@) :: (c -> d) -> (a -> b -> c) -> a -> b -> d

+ Primus.Error: infixr 8 .@

Files

primus.cabal +5/−6
src/Primus.hs +0/−2
src/Primus/AsMaybe.hs +1/−2
src/Primus/Enum.hs +11/−10
src/Primus/Error.hs +8/−0
src/Primus/Extra.hs +0/−53
src/Primus/Fold.hs +1/−2
src/Primus/LRHist.hs +1/−1
src/Primus/Lens.hs +0/−1
src/Primus/List.hs +0/−1
src/Primus/NonEmpty.hs +0/−2
src/Primus/Num1.hs +0/−1
src/Primus/Rep.hs +0/−1
src/Primus/TypeLevel.hs +20/−63
src/Primus/ZipNonEmpty.hs +0/−1
test/Main.hs +3/−3
test/TestExtra.hs +0/−17
test/TestLRHist.hs +4/−6
test/TestNonEmpty.hs +1/−1
test/TestTypeLevel.hs +42/−0
test/TestZipNonEmpty.hs +2/−1

primus.cabal view

@@ -5,12 +5,12 @@ -- see: https://github.com/sol/hpack  name:           primus-version:        0.1.0.0-synopsis:       NonEmpty and positive functions+version:        0.2.0.0+synopsis:       nonempty and positive functions description:    A library containing positive-valued and nonempty functions . Please see the README on GitHub at <https://github.com/gbwey/primus#readme> category:       Data, General homepage:       https://github.com/gbwey/primus#readme-bug-reports:    https://github.com/gbwey/primus.git/issues+bug-reports:    https://github.com/gbwey/primus/issues author:         Grant Weyburne <gbwey9@gmail.com> maintainer:     Grant Weyburne <gbwey9@gmail.com> copyright:      2022 Grant Weyburne@@ -20,7 +20,7 @@  source-repository head   type: git-  location: https://github.com/gbwey/primus.git+  location: https://github.com/gbwey/primus  library   exposed-modules:@@ -29,7 +29,6 @@       Primus.Bool       Primus.Enum       Primus.Error-      Primus.Extra       Primus.Fold       Primus.Lens       Primus.List@@ -63,12 +62,12 @@       TestAsMaybe       TestBool       TestEnum-      TestExtra       TestFold       TestList       TestLRHist       TestNonEmpty       TestNum1+      TestTypeLevel       TestZipNonEmpty       Paths_primus   hs-source-dirs:

src/Primus.hs view

@@ -9,7 +9,6 @@   module Primus.AsMaybe,   module Primus.Bool,   module Primus.Enum,-  module Primus.Extra,   module Primus.Error,   module Primus.Fold,   module Primus.List,@@ -24,7 +23,6 @@ import Primus.Bool import Primus.Enum import Primus.Error-import Primus.Extra import Primus.Fold import Primus.List import Primus.NonEmpty

src/Primus/AsMaybe.hs view

@@ -46,7 +46,7 @@ import qualified Data.Semigroup as SG import Data.These import Data.These.Combinators-import Primus.Extra+import Primus.Error ((.@))  -- | converts to a 'Maybe' for failure types class AsMaybe x b | x -> b where@@ -142,7 +142,6 @@   go a = case toMaybe (f a) of     Nothing -> []     Just x -> x : go x-  {- | like 'Data.List.unfoldr' but terminate using 'AsMaybe'

src/Primus/Enum.hs view

@@ -4,6 +4,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-}+ {- | Module      : Primus.Enum Description : methods for safe enumeration and enumeration on containers@@ -136,16 +137,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-      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-      rhs <- case compare 0 mx of-            LT -> Right ((mx + 1) ^ len - 1)-            EQ -> Right 0-            GT -> Left $ "capacity: unsupported mx < 0: " ++ show z-      pure (lhs,rhs)+  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+  rhs <- case compare 0 mx of+    LT -> Right ((mx + 1) ^ len - 1)+    EQ -> Right 0+    GT -> Left $ "capacity: unsupported mx < 0: " ++ show z+  pure (lhs, rhs)  {- | convert toEnum of "a" into a list containing "a"s    zero is the empty list: see 'toEnumList'

src/Primus/Error.hs view

@@ -29,6 +29,8 @@    -- * decorate an error   lmsg,+  -- * miscellaneous+  (.@), ) where  import Control.Arrow@@ -103,3 +105,9 @@   \case     [] -> programmError $ "fromList1P:" ++ msg     x : xs -> x :| xs++-- | compose a two arg function followed by a one arg function+(.@) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(.@) = (.) . (.)++infixr 8 .@

− src/Primus/Extra.hs

@@ -1,53 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--{- |-Module      : Primus.Extra-Description : miscellaneous functions-Copyright   : (c) Grant Weyburne, 2022-License     : BSD-3--}-module Primus.Extra (-  on1,-  on2,-  comparing1,-  (.@),-) where---- | more flexible version of 'Data.Function.on' that allows differing types for the same container-on1 ::-  forall f a a' b c.-  (b -> b -> c) ->-  (forall x. f x -> b) ->-  f a ->-  f a' ->-  c-on1 f g fa fa' = f (g fa) (g fa')---- | more flexible version of 'Data.Function.on' that allows differing types for the same container but using two parameters-on2 ::-  forall f a a' a2 a2' b c.-  (b -> b -> c) ->-  (forall x y. f x y -> b) ->-  f a a2 ->-  f a' a2' ->-  c-on2 f g fa fa' = f (g fa) (g fa')---- | more flexible version of 'compare' that allows differing types for the same container-comparing1 ::-  forall f a a' b.-  Ord b =>-  (forall x. f x -> b) ->-  f a ->-  f a' ->-  Ordering-comparing1 g fa fa' = compare (g fa) (g fa')---- | compose a two arg function followed by a one arg function-(.@) :: (c -> d) -> (a -> b -> c) -> a -> b -> d-(.@) = (.) . (.)--infixr 8 .@

src/Primus/Fold.hs view

@@ -82,7 +82,6 @@ import Data.These import Data.These.Combinators import Primus.Error-import Primus.Extra  data Hist a b = Hist ![a] ![a] !b @@ -449,7 +448,7 @@  -- | 'Data.List.reverse' for a traversable container reverseT :: forall a t. Traversable t => t a -> t a-reverseT = frp . wrapL reverse+reverseT = frp . wrapL reverseF  -- | 'Data.List.sortBy' for a traversable container sortByT :: forall a t. Traversable t => (a -> a -> Ordering) -> t a -> t a

src/Primus/LRHist.hs view

@@ -1,8 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-}

src/Primus/Lens.hs view

@@ -4,7 +4,6 @@ {- | Module      : Primus.Lens Description : minimal lens interfaces- -} module Primus.Lens (   Lens,

src/Primus/List.hs view

@@ -60,7 +60,6 @@ import GHC.Stack import Primus.Bool import Primus.Error-import Primus.Extra  -- | split a list into overlapping pairs plus overflow pairsOf1 :: [a] -> ([(a, a)], Maybe a)

src/Primus/NonEmpty.hs view

@@ -111,7 +111,6 @@ import qualified GHC.Exts as GE (IsList (..)) import Primus.Bool import Primus.Error-import Primus.Extra import Primus.Fold import Primus.Lens @@ -529,4 +528,3 @@ sumP :: Foldable1 t => t Pos -> Pos sumP = L.foldr1 (+!) {-# INLINE sumP #-}-

src/Primus/Num1.hs view

@@ -26,7 +26,6 @@ import GHC.Natural import Primus.Enum import Primus.Error-import Primus.Extra  -- | run a function of one integer against the underlying 'Num1' type withOp :: Num1 a => (Integer -> Integer) -> a -> Either String a

src/Primus/Rep.hs view

@@ -30,7 +30,6 @@ import qualified Data.List.NonEmpty as N import Primus.Enum import Primus.Error-import Primus.Extra import Primus.Fold  -- | builds a representable from the left using past and future inputs

src/Primus/TypeLevel.hs view

@@ -21,22 +21,15 @@   Snd,   Fsts,   Snds,-  Length,-  Len1T,+  LengthT,   NotEqTC,   Cons1T,-  Snoc1T,-  Snoc1LT,   SnocT,   InitT,-  Init1T,-  Last1T,-  Head1T,-  App1T,+  LastT,   ApplyConstraints1,   ApplyConstraint,   ApplyConstraints,-  UnconsT,   UnsnocT,   FirstConsT,   ToITupleT,@@ -96,19 +89,14 @@   Snds ('(_, b) ': rs) = b ': Snds rs  -- | 'length' at the typelevel-type Length :: forall k. [k] -> Nat-type family Length rs where-  Length '[] = 0-  Length (_ ': '[]) = 1-  Length (_ ': _ ': '[]) = 2-  Length (_ ': _ ': _ ': '[]) = 3-  Length (_ ': _ ': _ ': _ ': '[]) = 4-  Length (_ ': _ ': _ ': _ ': _ ': rs) = 5 + Length rs---- | get the length of a type level nonempty list-type Len1T :: forall k. NonEmpty k -> k-type family Len1T ns where-  Len1T (_ ':| ns) = 1 GN.+ Length ns+type LengthT :: forall k. [k] -> Nat+type family LengthT rs where+  LengthT '[] = 0+  LengthT '[_] = 1+  LengthT '[_, _] = 2+  LengthT '[_, _, _] = 3+  LengthT '[_, _, _, _] = 4+  LengthT (_ ': _ ': _ ': _ ': _ ': rs) = 5 + LengthT rs  -- | ensure that two types are not equal type NotEqTC :: forall k k1. k -> k1 -> Constraint@@ -123,29 +111,12 @@ type family Cons1T a ys = result | result -> a ys where   Cons1T a (b ':| bs) = a ':| b ': bs --- | snoc a nonempty list type to a type-type Snoc1T :: forall k. NonEmpty k -> k -> NonEmpty k-type family Snoc1T as b where-  Snoc1T (a ':| as) b = a ':| SnocT as b- -- | snoc a type list to a type type SnocT :: forall k. [k] -> k -> [k] type family SnocT as b where   SnocT '[] b = '[b]   SnocT (a ': as) b = a ': SnocT as b --- | snoc a type list to a type-type Snoc1LT :: forall k. [k] -> k -> NonEmpty k-type family Snoc1LT as b where-  Snoc1LT '[] b = b ':| '[]-  Snoc1LT (a ': as) b = Cons1T a (Snoc1LT as b)---- | append two nonempty lists at the type level-type App1T :: forall k. NonEmpty k -> NonEmpty k -> NonEmpty k-type family App1T x y where-  App1T (a ':| '[]) y = Cons1T a y-  App1T (a ':| a1 ': as) y = Cons1T a (App1T (a1 ':| as) y)- -- | create a constraint from a type and list of constraints taking a type type ApplyConstraints1 :: forall k. [k -> Constraint] -> k -> Constraint type family ApplyConstraints1 xs x where@@ -164,16 +135,12 @@   ApplyConstraints '[] _ = ()   ApplyConstraints (c ': cs) xs = (ApplyConstraint c xs, ApplyConstraints cs xs) --- | uncons a type level nonempty list-type UnconsT :: forall k. NonEmpty k -> (k, [k])-type family UnconsT ns = result | result -> ns where-  UnconsT (a ':| as) = '(a, as)- -- | unsnoc a type level nonempty list-type UnsnocT :: forall k. NonEmpty k -> ([k], k)+type UnsnocT :: forall k. [k] -> ([k], k) type family UnsnocT ns where-  UnsnocT (a ':| '[]) = '( '[], a)-  UnsnocT (a ':| a1 ': as) = FirstConsT a (UnsnocT (a1 ':| as))+  UnsnocT '[] = GL.TypeError ('GL.Text "UnsnocT: undefined for empty indices")+  UnsnocT '[a] = '( '[], a)+  UnsnocT (a ': a1 ': as) = FirstConsT a (UnsnocT (a1 ': as))  -- | cons a type to the first element in a tuple type FirstConsT :: forall k k1. k -> ([k], k1) -> ([k], k1)@@ -258,22 +225,12 @@ -- | get the init of a list type InitT :: forall a. [a] -> [a] type family InitT xs where-  InitT '[] = GL.TypeError ( 'GL.Text "InitT: undefined for 1d")-  InitT (_ ': '[]) = '[]+  InitT '[] = GL.TypeError ( 'GL.Text "InitT: undefined for empty indices")+  InitT '[_] = '[]   InitT (n ': m ': ns) = n ': InitT (m ': ns) --- | get the init of a nonempty list-type Init1T :: forall a. NonEmpty a -> NonEmpty a-type family Init1T ns where-  Init1T (n ':| ns) = n ':| InitT ns- -- | peel off the bottom-most index in the matrix-type Last1T :: forall k. NonEmpty k -> k-type family Last1T ns where-  Last1T (a ':| '[]) = a-  Last1T (_ ':| (a1 : as)) = Last1T (a1 ':| as)---- | get the head of a nonempty list-type Head1T :: forall k. NonEmpty k -> k-type family Head1T ns where-  Head1T (a ':| _) = a+type LastT :: forall k. [k] -> k+type family LastT ns where+  LastT '[a] = a+  LastT (_ ': a1 : as) = LastT (a1 ': as)

src/Primus/ZipNonEmpty.hs view

@@ -72,4 +72,3 @@ -- | iso for the zipnonempty constructor _Zip1 :: Iso (ZipNonEmpty a) (ZipNonEmpty b) (NonEmpty a) (NonEmpty b) _Zip1 = iso coerce coerce-

test/Main.hs view

@@ -5,13 +5,13 @@ import qualified TestAsMaybe import qualified TestBool import qualified TestEnum-import qualified TestExtra import qualified TestFold import qualified TestLRHist import qualified TestList import qualified TestNonEmpty import qualified TestNum1 import qualified TestZipNonEmpty+import qualified TestTypeLevel  main :: IO () main = do@@ -29,13 +29,13 @@         ( [ TestAsMaybe.suite           , TestBool.suite           , TestEnum.suite-          , TestExtra.suite           , TestFold.suite           , TestList.suite           , TestLRHist.suite           , TestNonEmpty.suite           , TestNum1.suite---          , TestZipNonEmpty.suite+          , TestTypeLevel.suite+          --          , TestZipNonEmpty.suite           ]             ++ zs         )

− test/TestExtra.hs

@@ -1,17 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--module TestExtra where--import Primus.Extra-import Test.Tasty-import Test.Tasty.HUnit--suite :: TestTree-suite =-  testGroup-    "TestExtra"-    [ testCase "on1" $ on1 compare length "adsf" [1 :: Int .. 2] @?= GT-    ]

test/TestLRHist.hs view

@@ -124,21 +124,21 @@         map lhToEither zz2           @?= [ Left "ab"               , Right (This 'H')-              , Left "dude"+              , Left "oops"               , Right (That 50)               ]     , testCase "lhToEitherI" $         map lhToEitherI zz2           @?= [ Left "ab"               , Right (This 'H', (72, (2, ('y', (True, ())))))-              , Left "dude"+              , Left "oops"               , Right (That 50, (50, (299, ('a', (False, ())))))               ]     , testCase "lhToEitherTuples" $         map lhToEitherTuples zz2           @?= [ Left "ab"               , Right (This 'H', 72, 2, 'y', True)-              , Left "dude"+              , Left "oops"               , Right (That 50, 50, 299, 'a', False)               ]     , testCase "lhToEitherTuples appLR" $@@ -347,7 +347,7 @@               if a > 50                 then Right (This (chr a))                 else Right (That a)-            else Left "dude"+            else Left "oops"       )  suiteCheckers :: TestTree@@ -367,5 +367,3 @@     . adjustOption (max $ TQ.QuickCheckTests n)     . adjustOption (max $ TQ.QuickCheckMaxRatio ratio)     . adjustOption (const (TQ.QuickCheckVerbose v))--

test/TestNonEmpty.hs view

@@ -10,8 +10,8 @@ import Data.Char import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as N-import Data.These import Data.Pos+import Data.These import Primus.Bool import Primus.Enum import Primus.NonEmpty

+ test/TestTypeLevel.hs view

@@ -0,0 +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
+    ]

test/TestZipNonEmpty.hs view

@@ -10,11 +10,11 @@ import Data.Foldable import qualified Data.List.NonEmpty as N import qualified Data.Monoid as MM+import Primus.ZipNonEmpty import Test.QuickCheck import Test.QuickCheck.Checkers import "checkers" Test.QuickCheck.Classes import Test.Tasty-import Primus.ZipNonEmpty import qualified Test.Tasty.QuickCheck as TQ  argsVerbose :: Args@@ -36,6 +36,7 @@ testLawsZipNonEmptyIO :: IO () testLawsZipNonEmptyIO = do   traverse_ verboseBatch testLawsZipNonEmpty+ {- doit :: IO () doit = defaultMain suite