primus (empty) → 0.1.0.0
raw patch · 29 files changed
+5577/−0 lines, 29 filesdep +QuickCheckdep +adjunctionsdep +base
Dependencies added: QuickCheck, adjunctions, base, checkers, deepseq, distributive, lens, pos, primus, profunctors, semigroupoids, tasty, tasty-hunit, tasty-quickcheck, these
Files
- LICENSE +29/−0
- primus.cabal +93/−0
- src/Primus.hs +33/−0
- src/Primus/AsMaybe.hs +286/−0
- src/Primus/Bool.hs +107/−0
- src/Primus/Enum.hs +300/−0
- src/Primus/Error.hs +105/−0
- src/Primus/Extra.hs +53/−0
- src/Primus/Fold.hs +472/−0
- src/Primus/LRHist.hs +520/−0
- src/Primus/Lens.hs +52/−0
- src/Primus/List.hs +254/−0
- src/Primus/NonEmpty.hs +532/−0
- src/Primus/Num1.hs +107/−0
- src/Primus/One.hs +52/−0
- src/Primus/Rep.hs +118/−0
- src/Primus/TypeLevel.hs +279/−0
- src/Primus/ZipNonEmpty.hs +75/−0
- test/Main.hs +41/−0
- test/TestAsMaybe.hs +392/−0
- test/TestBool.hs +83/−0
- test/TestEnum.hs +387/−0
- test/TestExtra.hs +17/−0
- test/TestFold.hs +266/−0
- test/TestLRHist.hs +371/−0
- test/TestList.hs +97/−0
- test/TestNonEmpty.hs +302/−0
- test/TestNum1.hs +90/−0
- test/TestZipNonEmpty.hs +64/−0
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License + +Copyright (c) 2018, Grant Weyburne +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ primus.cabal view
@@ -0,0 +1,93 @@+cabal-version: 1.12 ++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: primus+version: 0.1.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+author: Grant Weyburne <gbwey9@gmail.com>+maintainer: Grant Weyburne <gbwey9@gmail.com>+copyright: 2022 Grant Weyburne+license: BSD3+license-file: LICENSE+build-type: Simple++source-repository head+ type: git+ location: https://github.com/gbwey/primus.git++library+ exposed-modules:+ Primus+ Primus.AsMaybe+ Primus.Bool+ Primus.Enum+ Primus.Error+ Primus.Extra+ Primus.Fold+ Primus.Lens+ Primus.List+ Primus.LRHist+ Primus.NonEmpty+ Primus.Num1+ Primus.One+ Primus.Rep+ Primus.TypeLevel+ Primus.ZipNonEmpty+ other-modules:+ Paths_primus+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wunused-type-patterns -Wredundant-constraints -Wmonomorphism-restriction -Wmissing-deriving-strategies -Wmissing-local-signatures -Wmissing-export-lists -Widentities+ build-depends:+ adjunctions+ , base >=4.7 && <5+ , deepseq+ , distributive+ , pos+ , profunctors+ , semigroupoids+ , these+ default-language: Haskell2010++test-suite primus-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ TestAsMaybe+ TestBool+ TestEnum+ TestExtra+ TestFold+ TestList+ TestLRHist+ TestNonEmpty+ TestNum1+ TestZipNonEmpty+ Paths_primus+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wunused-type-patterns -Wredundant-constraints -Wmissing-deriving-strategies -Widentities -Wno-missing-export-lists -Wno-missing-local-signatures+ build-depends:+ QuickCheck+ , adjunctions+ , base+ , checkers+ , deepseq+ , distributive+ , lens+ , pos+ , primus+ , profunctors+ , semigroupoids+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , these+ default-language: Haskell2010
+ src/Primus.hs view
@@ -0,0 +1,33 @@+{- |+Module : Primus+Description : common modules+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus (+ module Data.Pos,+ module Primus.AsMaybe,+ module Primus.Bool,+ module Primus.Enum,+ module Primus.Extra,+ module Primus.Error,+ module Primus.Fold,+ module Primus.List,+ module Primus.NonEmpty,+ module Primus.Num1,+ module Primus.One,+ module Primus.Rep,+) where++import Data.Pos+import Primus.AsMaybe+import Primus.Bool+import Primus.Enum+import Primus.Error+import Primus.Extra+import Primus.Fold+import Primus.List+import Primus.NonEmpty+import Primus.Num1+import Primus.One+import Primus.Rep
+ src/Primus/AsMaybe.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module : Primus.AsMaybe+Description : methods with termination+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.AsMaybe (+ -- * AsMaybe+ AsMaybe (..),+ iterateT1,+ unfoldrT,+ pairsT,++ -- * ApThese+ ApThese (..),+ toTheseT,+ toTheseTS,+ partitionEithersT,+ partitionTheseT,+ filterT,+ spanT,+ spanTAlt,+ spanTS,+ takeWhileT,+ takeWhileTS,++ -- * ApTheseF for use with 'Primus.LRHist.LRHist'+ ApTheseF (..),+) where++import Control.Arrow+import Data.Bool+import Data.Functor.Identity+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Semigroup as SG+import Data.These+import Data.These.Combinators+import Primus.Extra++-- | converts to a 'Maybe' for failure types+class AsMaybe x b | x -> b where+ toMaybe :: x -> Maybe b++instance (b ~ b1) => AsMaybe (These e b) b1 where+ toMaybe = these (const Nothing) Just (const Just)+instance (b ~ b1) => AsMaybe (Either e b) b1 where+ toMaybe = either (const Nothing) Just+instance (b ~ b1) => AsMaybe (Maybe b) b1 where+ toMaybe = id+instance (b1 ~ [b]) => AsMaybe [b] b1 where+ toMaybe = \case+ [] -> Nothing+ as@(_ : _) -> Just as+instance (z ~ SG.Arg b1 y, AsMaybe x b1) => AsMaybe (SG.Arg x y) z where+ toMaybe (SG.Arg x y) = (`SG.Arg` y) <$> toMaybe x+instance (b ~ (b1, b2), AsMaybe x b1, AsMaybe y b2) => AsMaybe (x, y) b where+ toMaybe (x, y) = (,) <$> toMaybe x <*> toMaybe y+instance (b ~ (b1, b2, b3), AsMaybe x b1, AsMaybe y b2, AsMaybe z b3) => AsMaybe (x, y, z) b where+ toMaybe (x, y, z) = (,,) <$> toMaybe x <*> toMaybe y <*> toMaybe z++instance AsMaybe x z => AsMaybe (Identity x) z where+ toMaybe (Identity x) = toMaybe x++-- supports Bool instance so partition can work the same as base [not a requirement but..]++-- | flexible "e" to use with eg 'partitionTheseT': Bool is also valid+class ApThese e a x b | x e a -> b where+ apThese :: a -> x -> These e b++instance (e ~ e1, b ~ b1) => ApThese e1 a (These e b) b1 where+ apThese _ = id+instance (e ~ e1, b ~ b1) => ApThese e1 a (Either e b) b1 where+ apThese _ = either This That+instance (e ~ a, b ~ b1) => ApThese e a (Maybe b) b1 where+ apThese a = maybe (This a) That+instance (e ~ a, b ~ a) => ApThese e a Bool b where+ apThese a = bool (This a) (That a)+instance (e ~ a, b1 ~ [b]) => ApThese e a [b] b1 where+ apThese a = \case+ [] -> This a+ as@(_ : _) -> That as++instance (z ~ SG.Arg b1 y, ApThese e a x b1) => ApThese e a (SG.Arg x y) z where+ apThese a (SG.Arg x y) = (`SG.Arg` y) <$> apThese a x+instance (Semigroup e, b ~ (b1, b2), ApThese e a x b1, ApThese e a y b2) => ApThese e a (x, y) b where+ apThese a (x, y) = (,) <$> apThese a x <*> apThese a y+instance (Semigroup e, b ~ (b1, b2, b3), ApThese e a x b1, ApThese e a y b2, ApThese e a z b3) => ApThese e a (x, y, z) b where+ apThese a (x, y, z) = (,,) <$> apThese a x <*> apThese a y <*> apThese a z++instance ApThese e a x z => ApThese e a (Identity x) z where+ apThese a (Identity x) = apThese a x++-- for LRHist "e" is fixed+-- supports Bool instance for use with LRHist [this is a requirement]++-- | for use with 'Primus.LRHist.LRHist' using a fixed "e"+class ApTheseF e a x b | x e a -> b where+ apTheseF :: a -> x -> These e b++instance (e ~ e1, b ~ b1) => ApTheseF e1 a (These e b) b1 where+ apTheseF _ = id+instance (e ~ e1, b ~ b1) => ApTheseF e1 a (Either e b) b1 where+ apTheseF _ = either This That+instance (Monoid e, b ~ b1) => ApTheseF e a (Maybe b) b1 where+ apTheseF _ = maybe (This mempty) That+instance (Monoid e, b ~ a) => ApTheseF e a Bool b where+ apTheseF a = bool (This mempty) (That a)+instance (Monoid e, b1 ~ [b]) => ApTheseF e a [b] b1 where+ apTheseF _ = \case+ [] -> This mempty+ as@(_ : _) -> That as++instance (z ~ SG.Arg b1 y, ApTheseF e a x b1) => ApTheseF e a (SG.Arg x y) z where+ apTheseF a (SG.Arg x y) = (`SG.Arg` y) <$> apTheseF a x+instance (Semigroup e, b ~ (b1, b2), ApTheseF e a x b1, ApTheseF e a y b2) => ApTheseF e a (x, y) b where+ apTheseF a (x, y) = (,) <$> apTheseF a x <*> apTheseF a y+instance (Semigroup e, b ~ (b1, b2, b3), ApTheseF e a x b1, ApTheseF e a y b2, ApTheseF e a z b3) => ApTheseF e a (x, y, z) b where+ apTheseF a (x, y, z) = (,,) <$> apTheseF a x <*> apTheseF a y <*> apTheseF a z++instance ApTheseF e a x z => ApTheseF e a (Identity x) z where+ apTheseF a (Identity x) = apTheseF a x++-- | similar to 'Data.List.NonEmpty.iterate' but terminate using 'AsMaybe'+iterateT1 ::+ AsMaybe x a =>+ (a -> x) ->+ a ->+ NonEmpty a+iterateT1 f a0 = a0 :| go a0+ where+ go a = case toMaybe (f a) of+ Nothing -> []+ Just x -> x : go x+++{- | like 'Data.List.unfoldr' but terminate using 'AsMaybe'++@+>>> unfoldrT (splitAt 2) [1..8]+[[1,2],[3,4],[5,6],[7,8]]++vs++>>> unfoldr (\s -> if null s then Nothing else Just (splitAt 2 s)) [1..8]+[[1,2],[3,4],[5,6],[7,8]]+@+-}+unfoldrT ::+ AsMaybe t t =>+ (t -> (a, t)) ->+ t ->+ [a]+unfoldrT f s0 =+ case toMaybe s0 of+ Nothing -> []+ Just s1 ->+ let (a, s2) = f s1+ in a : unfoldrT f s2++-- | run a functions against each side of a tuple and stitch them together for use with 'unfoldrT' where "s" is a tuple and you want to stop as soon as the either terminates+pairsT :: (x -> (a, x)) -> (y -> (b, y)) -> (x, y) -> ((a, b), (x, y))+pairsT f g (x0, y0) =+ let (a, x) = f x0+ (b, y) = g y0+ in ((a, b), (x, y))++-- | apply a function to a list and convert to a list of 'These'+toTheseT ::+ forall e a x b.+ (ApThese e a x b) =>+ (a -> x) ->+ [a] ->+ [These e b]+toTheseT f = map (\a -> apThese a (f a))++-- | like 'toTheseT' with state+toTheseTS ::+ forall e a x b z.+ (ApThese e a x b) =>+ (z -> a -> (z, x)) ->+ z ->+ [a] ->+ (z, [These e b])+toTheseTS f = L.mapAccumL (\z a -> second (apThese a) (f z a))++-- | like 'partitionEithersT' ignoring the second element of the result+filterT ::+ forall e a b x.+ ApThese e a x b =>+ (a -> x) ->+ [a] ->+ [b]+filterT = catThat .@ toTheseT @e -- minimal type applications required as "e" isnt used here++-- | like 'toTheseT' but use 'partitionHereThere' on the results (swapped version of 'Data.List.partition')+partitionEithersT ::+ forall e a b x.+ ApThese e a x b =>+ (a -> x) ->+ [a] ->+ ([e], [b])+partitionEithersT = partitionHereThere .@ toTheseT++-- | like 'toTheseT' but use 'partitionThese' on the results+partitionTheseT ::+ forall e a b x.+ ApThese e a x b =>+ (a -> x) ->+ [a] ->+ ([e], [b], [(e, b)])+partitionTheseT = partitionThese .@ toTheseT++-- | similar to 'Data.List.span' using 'ApThese' for failure (support Bool and These)+spanT ::+ forall e a x b.+ ApThese e a x b =>+ (a -> x) ->+ [a] ->+ ([b], [a])+spanT f = \case+ [] -> ([], [])+ a : as -> case apThese @e a (f a) of+ This _ -> ([], a : as)+ That b -> first (b :) (spanT @e f as)+ These _ b -> ((b :) *** (a :)) (spanT @e f as) -- put in both buckets and keep going++-- | like 'spanT' but doesn't continue in the 'These' case+spanTAlt ::+ forall e a x b.+ ApThese e a x b =>+ (a -> x) ->+ [a] ->+ ([b], [a])+spanTAlt f = \case+ [] -> ([], [])+ a : as -> case apThese @e a (f a) of+ This _ -> ([], a : as)+ That b -> first (b :) (spanT @e f as)+ These _ b -> ([b], a : as) -- put in both buckets and stop++-- | like 'spanT' with state+spanTS ::+ forall e a x b z.+ ApThese e a x b =>+ (z -> a -> (z, x)) ->+ z ->+ [a] ->+ (z, ([b], [a]))+spanTS f z0 = \case+ [] -> (z0, ([], []))+ a : as ->+ let (z, x) = f z0 a+ in case apThese @e a x of+ This _ -> (z, ([], a : as))+ That b -> second (first (b :)) (spanTS @e f z as)+ These _ b -> second ((b :) *** (a :)) (spanTS @e f z as) -- if these then put in both buckets++-- | like 'takeWhileT' with state+takeWhileTS ::+ forall e a x b z.+ ApThese e a x b =>+ (z -> a -> (z, x)) ->+ z ->+ [a] ->+ (z, [b])+takeWhileTS f = second fst .@ spanTS @e f++-- | like 'spanT' but ignore the second element of the result+takeWhileT ::+ forall e a x b.+ ApThese e a x b =>+ (a -> x) ->+ [a] ->+ [b]+takeWhileT = fst .@ spanT @e
+ src/Primus/Bool.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : Primus.Bool+Description : boolean methods+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.Bool (+ -- * builders+ boolMaybe,+ boolEither,+ boolThese,+ boolThese',++ -- * monadic functions+ boolM,+ unlessMB,+ whenMB,+) where++import Data.Bool+import Data.These++{- | monadic version of 'Data.Bool.bool'+ predicate appears first unlike 'Data.Bool.bool'+-}+boolM :: Monad m => m Bool -> m a -> m a -> m a+boolM mb mf mt = mb >>= bool mf mt++{- | create a 'Maybe' using a predicate and a function for the success case+ predicate appears first unlike 'Data.Bool.bool'+-}+boolMaybe ::+ (a -> Bool) ->+ (a -> b) ->+ a ->+ Maybe b+boolMaybe p r a+ | p a = Just (r a)+ | otherwise = Nothing++{- | create a 'Either' using a predicate and functions for the failure and success case+ predicates appear first unlike 'Data.Bool.bool'+-}+boolEither ::+ (a -> Bool) ->+ (a -> e) ->+ (a -> b) ->+ a ->+ Either e b+boolEither p l r a+ | p a = Right (r a)+ | otherwise = Left (l a)++{- | create a 'These' using two predicates and functions for the This case and That case+ False + * == This (a -> e)+ True + False == That (a -> b)+ True + True == These (a -> e) (a -> b) -- "a" effectively appears twice++ predicates appear first unlike 'Data.Bool.bool'+-}+boolThese ::+ (a -> Bool) ->+ (a -> Bool) ->+ (a -> e) ->+ (a -> b) ->+ a ->+ These e b+boolThese p q l r = boolThese' p q l r const++{- | similar to 'boolThese' but allows you to override the 'These' case++ predicates appear first unlike 'Data.Bool.bool'+-}+boolThese' ::+ (a -> Bool) ->+ (a -> Bool) ->+ (a -> e) ->+ (a -> b) ->+ ((e, b) -> a -> (e, b)) ->+ a ->+ These e b+boolThese' p q l r b a =+ case (p a, q a) of+ (False, _) -> This (l a)+ (True, False) -> That (r a)+ (True, True) -> uncurry These (b (l a, r a) a)++-- | 'Control.Monad.unless' but makes the "a" parameter available to the callback+unlessMB ::+ Applicative m =>+ (a -> Bool) ->+ a ->+ (a -> m ()) ->+ m ()+unlessMB p a m = bool (m a) (pure ()) (p a)++-- | 'Control.Monad.when' but makes the "a" parameter available to the callback+whenMB ::+ Applicative m =>+ (a -> Bool) ->+ a ->+ (a -> m ()) ->+ m ()+whenMB p a m = bool (pure ()) (m a) (p a)
+ src/Primus/Enum.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{- |+Module : Primus.Enum+Description : methods for safe enumeration and enumeration on containers+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.Enum (+ -- * enumerations+ universe1,+ universe1R,+ enumFrom1,+ enumFrom1R,+ enumTo1,+ enumFromThen1,+ enumFromTo1,+ enumFromThenTo1,++ -- * converters+ predSafe,+ succSafe,+ integerToEnumSafe,+ integerToIntSafe,++ -- * container enums++ -- ** enumerations+ toEnumList,+ toEnumList1,+ universeTraversable,+ toEnumTraversable,+ -- calcNextEnum,+ -- minMax,+ -- zerolr++ -- ** converters+ succTraversable,+ predTraversable,+ fromEnumFoldable,+ fromEnumFoldable1,++ -- ** capacity+ capacity,+) where++import Control.Arrow+import Data.Foldable+import Data.Function+import Data.Functor+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty (..))+import Data.Ord+import Data.Semigroup.Foldable+import Primus.Error+import Primus.Fold++-- | create a nonempty list of all the values for an 'Enum'+universe1 :: forall a. (Bounded a, Enum a) => NonEmpty a+universe1 = enumFrom1 minBound++-- | create a nonempty list of all the values for an 'Enum' in reverse order+universe1R :: forall a. (Bounded a, Enum a) => NonEmpty a+universe1R = enumFrom1R maxBound++-- | create a nonempty list of values starting at "a"+enumFrom1 :: (Bounded a, Enum a) => a -> NonEmpty a+enumFrom1 a = a :| drop 1 [a .. maxBound]++-- | create a nonempty list of values starting at "a"+enumTo1 :: (Bounded a, Enum a) => a -> NonEmpty a+enumTo1 a = minBound :| drop 1 [minBound .. a]++-- | create a nonempty list of values starting at "a" and skipping "b"+enumFromThen1 :: (Bounded a, Enum a) => a -> a -> NonEmpty a+enumFromThen1 a b =+ case comparing fromEnum a b of+ LT -> a :| drop 1 [a, b .. maxBound]+ EQ -> a :| [] -- diverges from enumFromThen by returning one value instead of cycling+ GT -> a :| drop 1 [a, b .. minBound]++-- | 'enumFromThenTo' for nonempty lists+enumFromThenTo1 :: Enum a => a -> a -> a -> NonEmpty a+enumFromThenTo1 a b c =+ if comparing fromEnum a b == EQ+ then a :| [] -- diverges from enumFromThenTo by returning one value instead of cycling+ else a :| drop 1 [a, b .. c]++-- | create a nonempty list of values starting at "a" and skipping "b"+enumFromTo1 :: Enum a => a -> a -> NonEmpty a+enumFromTo1 a b =+ case comparing fromEnum a b of+ LT -> a :| drop 1 [a .. b]+ EQ -> a :| [] -- diverges from enumFromTo by returning one value instead of cycling+ GT -> a :| drop 1 [a, pred a .. b] -- diverges from enumFromTo by going backwards instead of returning nothing+ -- pred has to exist: a > b => pred a >= b unless float ...++-- | create a nonempty list of "a" in reverse order+enumFrom1R :: forall a. (Bounded a, Enum a) => a -> NonEmpty a+enumFrom1R a+ | Just prv <- predSafe a = a :| drop 1 [a, prv .. minBound]+ | otherwise = a :| []++-- | safe 'pred' for a bounded 'Enum'+predSafe :: (Bounded a, Enum a) => a -> Maybe a+predSafe a+ | on (==) fromEnum a minBound = Nothing+ | otherwise = Just (pred a)++-- | safe 'succ' for a bounded 'Enum'+succSafe :: (Bounded a, Enum a) => a -> Maybe a+succSafe a+ | on (==) fromEnum a maxBound = Nothing+ | otherwise = Just (succ a)++-- | load a given container with "a"s using the relative position "i"+toEnumTraversable ::+ forall a f z.+ (Traversable f, Enum a, Bounded a) =>+ f z ->+ Integer ->+ Either String (f a)+toEnumTraversable tz i = do+ lst <- toEnumList @a i+ z <- zerolr+ c <- capacity @a tz+ lmsg ("cap=" ++ show c) $ padL (z <$ tz) lst++zerolr :: forall a. (Bounded a, Enum a) => Either String a+zerolr = left (const "zerolr: not defined at zero") $ integerToEnumSafe @a 0++-- | 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)++{- | convert toEnum of "a" into a list containing "a"s+ zero is the empty list: see 'toEnumList'+-}+toEnumList :: forall a. (Enum a, Bounded a) => Integer -> Either String [a]+toEnumList i+ | i == 0 = [] <$ zerolr @a+ | otherwise =+ let f :: Integer -> Either String (Maybe (a, Integer))+ f s+ | s == 0 = pure Nothing+ | otherwise =+ calcNextEnum s <&> \(s', a) ->+ if abs s' < abs s+ then Just (a, s')+ else+ if s' == 0+ then Nothing+ else programmError "toEnumList"+ in unfoldlM f i++-- | calculate the next enum+calcNextEnum :: forall a. (Enum a, Bounded a) => Integer -> Either String (Integer, a)+calcNextEnum i = lmsg "calcNextEnum" $+ case compare i 0 of+ GT+ | mx > 0 ->+ let (a, b) = divMod i (mx + 1)+ in case integerToEnumSafe b of+ Left e -> Left $ "out of range(GT): " ++ show i ++ " mod " ++ show (mx + 1) ++ " == " ++ show b ++ "(undefined) e=" ++ e+ Right c -> Right (a, c)+ | otherwise -> Left "not defined for positive numbers"+ EQ -> (0,) <$> zerolr+ LT+ | mn < 0 ->+ let (a, b) = quotRem i (mn - 1)+ in case integerToEnumSafe b of+ Left e -> Left $ "out of range(LT): " ++ show i ++ " mod " ++ show (mn - 1) ++ " == " ++ show b ++ "(undefined) e=" ++ e+ Right c -> Right (-a, c)+ | otherwise -> Left "not defined for negative numbers"+ where+ (mn, mx) = minMax @a++-- | return the min and max of a bounded enum+minMax :: forall a. (Enum a, Bounded a) => (Integer, Integer)+minMax = on (,) (toInteger . fromEnum @a) minBound maxBound++-- | concrete safe conversion of Integer to Int+integerToIntSafe :: Integer -> Either String Int+integerToIntSafe = integerToEnumSafe++-- | safe 'toEnum'+integerToEnumSafe :: forall a. (Enum a, Bounded a) => Integer -> Either String a+integerToEnumSafe i+ | i < mn = Left $ msg "underflow"+ | i > mx = Left $ msg "overflow"+ | otherwise = pure $ toEnum @a $ fromInteger @Int i -- i <= maxBound && maxBound :: Int so cant fail on fromInteger+ where+ (mn, mx) = minMax @a+ msg s = "integerToEnumSafe:" ++ s ++ " where " ++ show i ++ " not in range [" ++ show mn ++ ".." ++ show mx ++ "]"++-- | convert toEnum of "a" into a nonempty list containing "a"s+toEnumList1 :: forall a. (Enum a, Bounded a) => Integer -> Either String (NonEmpty a)+toEnumList1 i =+ toEnumList i <&> \case+ [] -> minBound :| []+ a : as -> a :| as++-- | reverse of 'toEnumList' [can fail if xs is null and toEnum 0 is not defined]+fromEnumFoldable ::+ forall a t.+ (Foldable t, Enum a, Bounded a) =>+ t a ->+ Either String Integer+fromEnumFoldable xs =+ case toList xs of+ [] -> 0 <$ zerolr @a+ a : as -> pure $ fromEnumFoldable1 (a :| as)++-- | reverse of 'toEnumList1' [cant fail]+fromEnumFoldable1 ::+ forall a t.+ (Foldable1 t, Enum a, Bounded a) =>+ t a ->+ Integer+fromEnumFoldable1 xs =+ let (mn, mx) = minMax @a+ nn, pp :: Maybe Integer+ nn = if mn < 0 then Just (-1) else Nothing+ pp = if mx > 0 then Just 1 else Nothing+ f ::+ a ->+ (Integer, (Maybe Integer, Maybe Integer)) ->+ (Integer, (Maybe Integer, Maybe Integer))+ f a (b, (n, p)) =+ let v = toInteger (fromEnum a)+ w = case (compare v 0, n, p) of+ (LT, Just x, _) -> b - v * x+ (EQ, _, _) -> b+ (GT, _, Just y) -> b + v * y+ o -> programmError $ "fromEnumFoldable1 " ++ show o+ in (w, ((\x -> -(mn - 1) * x) <$> n, (\x -> (mx + 1) * x) <$> p))+ in fst $ foldr f (0, (nn, pp)) xs++-- | 'succ' for a traversable container+succTraversable ::+ forall a t.+ (Traversable t, Enum a, Bounded a) =>+ t a ->+ Either String (t a)+succTraversable xs =+ let f :: Bool -> a -> (Bool, a)+ f b a =+ case (b, succSafe a) of+ (True, Just a') -> (False, a')+ (True, Nothing) -> (True, minBound)+ _o -> (b, a)+ (lft, ret) = L.mapAccumR f True xs+ in if lft+ then Left "succTraversable: over maxbound"+ else Right ret++-- | 'pred' for a traversable container+predTraversable ::+ forall a t.+ (Traversable t, Enum a, Bounded a) =>+ t a ->+ Either String (t a)+predTraversable xs =+ let f :: Bool -> a -> (Bool, a)+ f b a =+ case (b, predSafe a) of+ (True, Just a') -> (False, a')+ (True, Nothing) -> (True, maxBound)+ _o -> (b, a)+ (lft, ret) = L.mapAccumR f True xs+ in if lft+ then Left "predTraversable: below minbound"+ else Right ret++{- | generate all the possible enum combinations for the given container in ascending order++ useful for creating all the valid indices for matrices+-}+universeTraversable ::+ forall f a.+ (Traversable f, Enum a, Bounded a) =>+ f a ->+ Either String (NonEmpty (f a))+universeTraversable ta = do+ (mn, mx) <- capacity @a ta+ traverse (toEnumTraversable ta) (mn :| drop 1 [mn .. mx])
+ src/Primus/Error.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : Primus.Error+Description : error methods+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.Error (+ -- * force conversion from an Either+ forceRight,+ forceRightP,+ fr,+ frp,++ -- * force conversion from a nonempty list+ fromList1,+ fromList1P,+ ne,+ nep,++ -- * error types+ programmError,+ normalError,+ compileError,++ -- * decorate an error+ lmsg,+) where++import Control.Arrow+import Data.List.NonEmpty (NonEmpty (..))+import GHC.Stack++-- | indicates a programmer error+programmError :: HasCallStack => String -> a+programmError s = withFrozenCallStack $ error $ "programm error:" ++ s++-- | indicates a user error+normalError :: HasCallStack => String -> a+normalError s = withFrozenCallStack $ error s++-- | indicates a compiler error+compileError :: HasCallStack => String -> a+compileError s = withFrozenCallStack $ error $ "should be a compile error (check the constraints):" ++ s++-- | unsafe force an error if 'Left'+forceRight :: HasCallStack => String -> Either String a -> a+forceRight s = \case+ Left e -> withFrozenCallStack $ error $ "forceRight:" ++ s ++ " e=" ++ e+ Right a -> a++-- | unsafe force an error if 'Left'+forceRightP :: HasCallStack => String -> Either String a -> a+forceRightP s = \case+ Left e -> withFrozenCallStack $ error $ "programmer error:" ++ s ++ " e=" ++ e+ Right a -> a++-- | unsafe force an error if 'Left'+fr :: HasCallStack => Either String a -> a+fr = forceRight ""++-- | unsafe force an error if 'Left'+frp :: HasCallStack => Either String a -> a+frp = forceRightP ""++-- | prepend an error message+lmsg :: String -> Either String a -> Either String a+lmsg s =+ left+ ( \e -> case s of+ [] -> e+ _ : _ -> s <> ":" <> e+ )++-- | unsafe conversion from list to a nonempty list+ne :: HasCallStack => [a] -> NonEmpty a+ne =+ \case+ [] -> normalError "ne:list is empty"+ x : xs -> x :| xs++-- | unsafe conversion from list to a nonempty list+nep :: HasCallStack => [a] -> NonEmpty a+nep =+ \case+ [] -> programmError "nep:list is empty"+ x : xs -> x :| xs++-- | unsafe conversion from list to a nonempty list+fromList1 :: HasCallStack => String -> [a] -> NonEmpty a+fromList1 msg =+ \case+ [] -> normalError $ "fromList1:" ++ msg+ x : xs -> x :| xs++-- | unsafe conversion from list to a nonempty list+fromList1P :: HasCallStack => String -> [a] -> NonEmpty a+fromList1P msg =+ \case+ [] -> programmError $ "fromList1P:" ++ msg+ x : xs -> x :| xs
+ src/Primus/Extra.hs view
@@ -0,0 +1,53 @@+{-# 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
@@ -0,0 +1,472 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : Primus.Fold+Description : fold and unfolds+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.Fold (+ -- * fill a container+ fillTraversable,+ fillTraversableExact,+ traverseLR,++ -- * extended traversals with access to past and future input+ histMapL,+ histMapR,+ histMapL',+ histMapR',++ -- * change inside of a container+ wrapL,+ wrap1,++ -- * fold and unfolds+ pFoldR,+ pFoldL,+ unfoldl,+ unfoldrM,+ unfoldlM,++ -- * zip+ zipExtrasT,+ zipExtrasRight,+ zipWithExact,+ zipExact,+ zipWithT,++ -- * compare container lengths+ CLCount (..),+ compareLength,+ compareLengthBy,+ compareLengths,+ clOrdering,++ -- * pad containers+ padR,+ padL,++ -- * chunking+ chunkN,+ chunkN',++ -- * scan+ postscanl,+ postscanr,++ -- * miscellaneous+ initsT,+ tailsT,+ reverseT,+ sortByT,+ unzipF,+ reverseF,+) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.Bool+import Data.Foldable+import Data.Kind+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as N+import Data.Semigroup.Foldable+import Data.These+import Data.These.Combinators+import Primus.Error+import Primus.Extra++data Hist a b = Hist ![a] ![a] !b++getHistZ :: Hist a b -> b+getHistZ (Hist _ _ z) = z++{- | left fold over a list giving the caller access to past and future input and state "z"+ if you want previous "b" values then put it in "z"+-}+histMapImpl ::+ Traversable t =>+ Bool ->+ ([a] -> [a] -> z -> a -> (z, b)) ->+ z ->+ t a ->+ (z, t b)+histMapImpl isright f z0 lst =+ first getHistZ $+ bool+ L.mapAccumL+ L.mapAccumR+ isright+ g+ (Hist [] (bool toList reverseF isright lst) z0)+ lst+ where+ g (Hist ps ft z) a =+ case ft of+ [] -> programmError "histMapImpl: ran out of data!"+ _ : ft0 ->+ let (z', b) = f ps ft0 z a+ in (Hist (a : ps) ft0 z', b)++-- | left/right fold over a list giving the caller access state "z" (for finite containers only)+histMapL+ , histMapR ::+ Traversable t =>+ ([a] -> [a] -> z -> a -> (z, b)) ->+ z ->+ t a ->+ (z, t b)+histMapL = histMapImpl False+histMapR = histMapImpl True++-- | left/right fold that gives access to past input (reverse order) and future input+pFoldL, pFoldR :: forall a b. ([a] -> [a] -> b -> a -> b) -> b -> [a] -> b+pFoldR f n = go []+ where+ go :: [a] -> [a] -> b+ go pres = \case+ [] -> n+ a : as -> f pres as (go (a : pres) as) a+pFoldL f = go []+ where+ go :: [a] -> b -> [a] -> b+ go pres !z = \case+ [] -> z+ a : as -> go (a : pres) (f pres as z a) as++histMapImpl' ::+ forall a b t.+ Traversable t =>+ Bool ->+ ([a] -> [a] -> a -> b) ->+ t a ->+ t b+histMapImpl' isright f = snd . bool histMapL histMapR isright g ()+ where+ g :: [a] -> [a] -> () -> a -> ((), b)+ g ps ft () a = ((), f ps ft a)++-- | same as 'histMapL' or 'histMapR' but skips state+histMapL'+ , histMapR' ::+ forall a b t.+ Traversable t =>+ ([a] -> [a] -> a -> b) ->+ t a ->+ t b+histMapL' = histMapImpl' False+histMapR' = histMapImpl' True++-- | like 'Data.List.unfoldr' but reverses the order of the list+unfoldl :: forall s a. (s -> Maybe (a, s)) -> s -> [a]+unfoldl f = go []+ where+ go :: [a] -> s -> [a]+ go as !s = case f s of+ Nothing -> as+ Just (a, s1) -> go (a : as) s1++-- | monadic unfoldr+unfoldrM :: forall m s a. Monad m => (s -> m (Maybe (a, s))) -> s -> m [a]+unfoldrM f s = do+ mas <- f s+ case mas of+ Nothing -> return []+ Just (a, s') -> (a :) <$> unfoldrM f s'++-- | monadic unfoldl+unfoldlM :: forall m s a. Monad m => (s -> m (Maybe (a, s))) -> s -> m [a]+unfoldlM f = go []+ where+ go :: [a] -> s -> m [a]+ go as s = do+ mas <- f s+ case mas of+ Nothing -> return as+ Just (a, s') -> go (a : as) s'++-- | traverse a container using 'StateLR'+traverseLR ::+ forall t a b c.+ Traversable t =>+ (c -> a -> Either String (c, b)) ->+ c ->+ t a ->+ Either String (c, t b)+traverseLR f c0 ta =+ let g :: a -> StateLR String c b+ g a = StateLR $ \c -> f c a+ in unStateLR (traverse g ta) c0++-- | fill a traversable with a list and fail if not enough data+fillTraversable ::+ forall t a z.+ Traversable t =>+ t z ->+ [a] ->+ Either String ([a], t a)+fillTraversable tz as0 =+ let g :: z -> StateLR String [a] a+ g _ = StateLR $ \case+ [] -> Left "fillTraversable: not enough data"+ d : ds' -> Right (ds', d)+ in unStateLR (traverse g tz) as0++-- | fill a traversable with a list and fail if there are leftovers: see 'fillTraversable'+fillTraversableExact ::+ forall f a z.+ Traversable f =>+ f z ->+ [a] ->+ Either String (f a)+fillTraversableExact = g .@ fillTraversable+ where+ g :: Either String ([a], b) -> Either String b+ g = \case+ Right ([], ret) -> Right ret+ Right (_ : _, _) -> Left "fillTraversableExact: too many elements found"+ Left e -> Left e++-- | run a function against the contents of the 'Foldable1' container as a nonempty list+wrap1 ::+ forall (g :: Type -> Type) a b.+ (Traversable g, Foldable1 g) =>+ (NonEmpty a -> NonEmpty b) ->+ g a ->+ Either String (g b)+wrap1 f gx = fillTraversableExact gx (toList (f (toNonEmpty gx)))++-- | run a function against the contents of the 'Foldable' container as a list+wrapL ::+ forall (g :: Type -> Type) a b.+ (Traversable g) =>+ ([a] -> [b]) ->+ g a ->+ Either String (g b)+wrapL f gx = fillTraversableExact gx (f (toList gx))++-- | pad fill "as" to the right or left with values from "zs"+padR, padL :: forall t a. Traversable t => t a -> [a] -> Either String (t a)+padR = padImpl True+padL = padImpl False++-- | pad fill "as" to the left/right with values from "zs"+padImpl :: forall t a. Traversable t => Bool -> t a -> [a] -> Either String (t a)+padImpl isright as zs =+ let (rs, zz) = bool (L.mapAccumR f (reverseF zs)) (L.mapAccumL f zs) isright as+ in case rs of+ [] -> Right zz+ _ : _ -> Left $ "pad" ++ bool "L" "R" isright ++ ": negative fill: would need to truncate the data"+ where+ f :: [a] -> a -> ([a], a)+ f xs a =+ case xs of+ [] -> ([], a)+ b : bs -> (bs, b)++-- | have to call a second time if the left container is bigger than the right one+zipExtrasT :: forall a b t. Traversable t => t a -> t b -> t (These a b)+zipExtrasT xs ys =+ let (rs, ret) = zipExtrasRight (toList xs) ys+ in case rs of+ [] -> ret+ _ : _ -> swapThese <$> zipExtrasT ys xs++-- | zip a foldable into a traversable container and return any leftovers+zipExtrasRight ::+ forall a b t.+ Traversable t =>+ [a] ->+ t b ->+ ([a], t (These a b))+zipExtrasRight = L.mapAccumL f+ where+ f :: [a] -> b -> ([a], These a b)+ f zs b = case zs of+ [] -> ([], That b)+ a : as -> (as, These a b)++-- | predicate for 'CEQ'+clOrdering :: CLCount b -> Maybe Ordering+clOrdering = \case+ CError{} -> Nothing+ CLT{} -> Just LT+ CEQ -> Just EQ+ CGT -> Just GT++-- | difference between two foldables but quick exit if lhs is larger than rhs+data CLCount b+ = -- | error+ CError !String+ | -- | leftovers from rhs: ie lhs is smaller than rhs+ CLT !(NonEmpty b)+ | -- | same size+ CEQ+ | -- | lhs is larger than rhs+ CGT+ 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++-- | compare length where lhs or rhs can be infinite but not both+compareLength ::+ forall t u a b.+ (Foldable t, Foldable u) =>+ t a ->+ u b ->+ CLCount b+compareLength = compareLengthBy mempty++-- | compare length where lhs or rhs can be infinite but not both+compareLengthBy ::+ forall t u a b.+ (Foldable t, Foldable u) =>+ (Int -> a -> b -> Maybe String) ->+ t a ->+ u b ->+ CLCount b+compareLengthBy p xs ys =+ foldr f g xs (0, toList ys)+ where+ g :: (Int, [b]) -> CLCount b+ g (_, zs) = case zs of+ [] -> CEQ+ w : ws -> CLT (w :| ws)+ f :: a -> ((Int, [b]) -> CLCount b) -> (Int, [b]) -> CLCount b+ f a k (i, zs) = case zs of+ [] -> CGT -- quickexit+ b : bs -> case p i a b of+ Nothing -> k (i + 1, bs)+ Just e -> CError e++-- | 'zipWith' with an Applicative result+zipWithT ::+ (Applicative f, Traversable t, Applicative t) =>+ (a -> b -> f c) ->+ t a ->+ t b ->+ f (t c)+zipWithT f = sequenceA .@ liftA2 f++-- | fills a container with chunks using a user supplied unfold function+chunkN ::+ forall t s b z.+ Traversable t =>+ (s -> Either String (s, b)) ->+ t z ->+ s ->+ Either String (s, t b)+chunkN f tz = unStateLR (traverse (const (StateLR f)) tz)++-- | similar to 'chunkN' but "s" is restricted to a foldable: if there is data left then will fail+chunkN' ::+ forall t a u b z.+ (Traversable t, Foldable u) =>+ (u a -> Either String (u a, b)) ->+ t z ->+ u a ->+ Either String (t b)+chunkN' f tz s = do+ (s', ret) <- chunkN g tz s+ if null s'+ then Right ret+ else Left "chunkN': there is still data remaining at eof"+ where+ g s' =+ if null s'+ then Left "chunkN': not enough data"+ else f s'++-- | splits a container "u" into parts of length "len" and fills container "t"+zipWithExact ::+ forall t u a b c.+ (Traversable t, Foldable u) =>+ (a -> b -> c) ->+ t a ->+ u b ->+ Either String (t c)+zipWithExact f ta ub = do+ let g a = StateLR $ \case+ [] -> Left "zipWithExact: lhs has more data"+ b : bs -> Right (bs, f a b)+ (vx, ret) <- unStateLR (traverse g ta) (toList ub)+ if null vx+ then Right ret+ else Left "zipWithExact: lhs has less data"++-- | see 'zipWithExact'+zipExact ::+ forall t u a b.+ (Traversable t, Foldable u) =>+ t a ->+ u b ->+ Either String (t (a, b))+zipExact = zipWithExact (,)++-- | combines state and failure as a monad+newtype StateLR e s a = StateLR {unStateLR :: s -> Either e (s, a)}+ deriving stock (Functor)++instance Applicative (StateLR e s) where+ pure a = StateLR $ \s -> Right (s, a)+ (<*>) = ap++instance Monad (StateLR e s) where+ return = pure+ StateLR sa >>= amb =+ StateLR $ \s -> case sa s of+ Left e -> Left e+ Right (s1, a) -> unStateLR (amb a) s1++-- | 'Data.List.inits' for a traversable container+initsT :: forall a t. Traversable t => t a -> t (NonEmpty a)+initsT ta = case toList ta of+ [] -> fmap pure ta+ i : is -> frp $ fillTraversableExact ta (map (i :|) (L.inits is))++-- | 'Data.List.tails' for a traversable container+tailsT :: forall a t. Traversable t => t a -> t (NonEmpty a)+tailsT ta = forceRight "tailsT" $ do+ (xs, ret) <- traverseLR g (toList ta) ta+ case xs of+ [] -> pure ret+ _ : _ -> Left "extra data at eof"+ where+ g :: [a] -> p -> Either String ([a], NonEmpty a)+ g s _ = case s of+ [] -> Left "ran out of data"+ a : as -> Right (as, a :| as)++-- | 'Data.List.reverse' for a traversable container+reverseT :: forall a t. Traversable t => t a -> t a+reverseT = frp . wrapL reverse++-- | 'Data.List.sortBy' for a traversable container+sortByT :: forall a t. Traversable t => (a -> a -> Ordering) -> t a -> t a+sortByT f = frp . wrapL (L.sortBy f)++-- | 'N.scanr' for a traversable that drops the last value+postscanr :: Traversable f => (a -> b -> b) -> b -> f a -> f b+postscanr f c = frp . wrapL (N.init . N.scanr f c)++-- | 'N.scanl' for a traversable that drops the first value+postscanl :: Traversable f => (b -> a -> b) -> b -> f a -> f b+postscanl f c = frp . wrapL (N.tail . N.scanl f c)++-- | unzip for a functor of pairs+unzipF :: Functor f => f (a, b) -> (f a, f b)+unzipF = fmap fst &&& fmap snd++-- | reverse a foldable+reverseF :: Foldable t => t a -> [a]+reverseF = foldl' (flip (:)) []
+ src/Primus/LRHist.hs view
@@ -0,0 +1,520 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- need PolyKinds else could fail for callers using TP type families+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module : Primus.LRHist+Description : like 'Either' but keeps history of all successes+Copyright : (c) Grant Weyburne, 2022+License : BSD-3++tracks one or more successes and optionally a failure++prefer the smart constructors to enforce correctness or use the apply methods+-}+module Primus.LRHist (+ -- * datatype+ LRHist (..),++ -- * smart constructors+ rhi,+ rh,+ lh,+ lhskip,++ -- * constructors with better type application order+ rhi',+ rh',+ lh',+ lhskip',++ -- * converters+ lhToEitherI,+ lhToEither,+ lhToEitherTuples,++ -- * function application+ lhBool,+ lhMaybe,+ lhMaybe',+ lhEither,+ lhEither',+ appLR,+ appLRS,+ appLRB,++ -- * traversals+ traverseLRHistB,+ traverseLRHist,++ -- * miscellaneous+ eitherToLH,+ maybeToLH,+ validateLRHist,+) where++import Data.Bifoldable+import Data.Bifunctor+import Data.Bitraversable+import Data.Bool+import Data.Kind+import qualified Data.List as L+import Data.Proxy+import Data.These+import qualified GHC.Read as GR+import Primus.AsMaybe+import Primus.Bool+import Primus.Error (programmError)+import qualified Primus.TypeLevel as TP+import qualified Text.ParserCombinators.ReadPrec as PC+import qualified Text.Read.Lex as TRL++{- | like 'Either' but keeps track of history of all successes+ if there is a failure it wraps the previous successes and stops adding data to 'LRHist'+ "e" the error type+ "as" is the typelevel list in reverse order that tracks all previous "a"s+ "a" is the latest success type+-}+type LRHist :: [Type] -> Type -> Type -> Type+data LRHist as e a where+ -- | wraps an existing error+ LhSkip ::+ LRHist as e a' ->+ LRHist (a' ': as) e a+ -- | wraps previous nested successes with an error+ Lh ::+ e ->+ LRHist as e a' ->+ LRHist (a' ': as) e a+ -- | initial success value+ Rhi ::+ a ->+ LRHist '[] e a+ -- | subsequent success+ Rh ::+ a ->+ LRHist as e a' ->+ LRHist (a' ': as) e a++deriving stock instance Functor (LRHist as e)+deriving stock instance Foldable (LRHist as e)+deriving stock instance Traversable (LRHist as e)+deriving stock instance (Show a, Show e, TP.ApplyConstraints '[Show] as) => Show (LRHist as e a)+deriving stock instance (TP.ApplyConstraints '[Eq, Ord] as, Eq e, Ord e, Ord a) => Ord (LRHist as e a)+deriving stock instance (TP.ApplyConstraints '[Eq] as, Eq e, Eq a) => Eq (LRHist as e a)+instance+ (Semigroup e, Monoid a) =>+ Monoid (LRHist '[] e a)+ where+ mempty = Rhi mempty+instance+ ( Monoid a+ , Monoid e+ , Monoid a'+ , TP.ApplyConstraints '[Semigroup, Monoid] as+ , Monoid (LRHist as e a')+ ) =>+ Monoid (LRHist (a' ': as) e a)+ where+ mempty = Rh mempty mempty++instance+ ( Semigroup a+ , Semigroup e+ , TP.ApplyConstraints '[Semigroup] as+ ) =>+ Semigroup (LRHist as e a)+ where+ x <> y = case (x, y) of+ (Rhi a, Rhi a') -> Rhi (a <> a')+ (Rh a ls, Rh a' ls') -> Rh (a <> a') (ls <> ls')+ (Lh e ls, Lh e' ls') -> Lh (e <> e') (ls <> ls')+ (LhSkip ls, LhSkip ls') -> LhSkip (ls <> ls')+ (z@LhSkip{}, _) -> z+ (_, z@LhSkip{}) -> z+ (z@Lh{}, _) -> z+ (_, z@Lh{}) -> z++-- | constructor for 'Rhi' with more convenient type application order+rhi' :: forall e a. a -> LRHist '[] e a+rhi' = Rhi++-- | constructor for 'Rh' with more convenient type application order+rh' :: forall e a a' as. a -> LRHist as e a' -> LRHist (a' : as) e a+rh' = Rh++-- | constructor for 'Lh' with more convenient type application order+lh' :: forall a e a' as. e -> LRHist as e a' -> LRHist (a' : as) e a+lh' = Lh++-- | constructor for 'LhSkip' with more convenient type application order+lhskip' :: forall a e a' as. LRHist as e a' -> LRHist (a' : as) e a+lhskip' = LhSkip++-- | smart constructor for 'Rhi'+rhi :: forall e a. a -> (Proxy 'True, LRHist '[] e a)+rhi a = (Proxy, Rhi a)++-- | smart constructor for 'Rh'+rh ::+ forall e a a' as proxy.+ a ->+ (proxy 'True, LRHist as e a') ->+ (proxy 'True, LRHist (a' : as) e a)+rh a = second (Rh a)++-- | smart constructor for 'Lh'+lh ::+ forall a e a' as proxy.+ e ->+ (proxy 'True, LRHist as e a') ->+ (Proxy 'False, LRHist (a' : as) e a)+lh e (_p, z) = (Proxy, Lh e z)++-- | smart constructor for 'LhSkip'+lhskip ::+ forall a e a' as proxy.+ (proxy 'False, LRHist as e a') ->+ (proxy 'False, LRHist (a' : as) e a)+lhskip = second LhSkip++-- | initialise 'LRHist' with an 'Either' by wrapping a unit+eitherToLH :: Either e a -> LRHist '[()] e a+eitherToLH lr = either Lh Rh lr (Rhi ())++-- | initialise 'LRHist' with an 'Maybe' by wrapping a unit+maybeToLH :: Monoid e => Maybe a -> LRHist '[()] e a+maybeToLH = eitherToLH . maybe (Left mempty) Right++-- | returns an inductive tuple on success and Either for failure+lhToEitherI ::+ forall e a as.+ RHistC as =>+ LRHist as e a ->+ Either e (RHistT a as)+lhToEitherI = rhist++-- | convert 'LRHist' to an 'Either'+lhToEither :: forall e a as. LRHist as e a -> Either e a+lhToEither = \case+ Rhi a -> Right a+ Rh a _ -> Right a+ Lh e _ -> Left e+ z@LhSkip{} -> Left $ go z+ where+ go :: forall as' a'. LRHist as' e a' -> e+ go = \case+ Rhi{} -> programmError "malformed LRHist: LhSkip expects inner LhSkip or Lh but found Rhi"+ Rh{} -> programmError "malformed LRHist: LhSkip expects LhSkip or Lh but found Rh"+ Lh e _ -> e+ LhSkip ls -> go ls++-- | extract the initial type for 'LRHist'+type OrgAT :: [Type] -> Type -> Type+type family OrgAT as a where+ OrgAT '[] a' = a'+ OrgAT (a ': as) _ = OrgAT as a++-- | extracts the initial value from 'LRHist'+type OrgAC :: [Type] -> Type -> Constraint+class OrgAC as a where+ orgA :: LRHist as e a -> OrgAT as a++instance OrgAC '[] a' where+ orgA = \case+ Rhi a -> a+instance OrgAC as a => OrgAC (a ': as) a' where+ orgA = \case+ Rh _ ls -> orgA ls+ Lh _ ls -> orgA ls+ LhSkip ls -> orgA ls++-- | returns flattened n-tuple with all the history of successes on success and Either for failure+lhToEitherTuples ::+ forall e a as tp.+ ( TP.ITupleC tp+ , RHistC as+ , TP.ToITupleT tp ~ RHistT a as+ ) =>+ LRHist as e a ->+ Either e tp+lhToEitherTuples = fmap TP.fromITupleC . rhist++-- | type family for creating an inductive tuple+type RHistT :: Type -> [Type] -> Type+type family RHistT a as where+ RHistT a '[] = (a, ())+ RHistT a (a' ': as) = (a, RHistT a' as)++-- | return an inductive tuple on success+type RHistC :: [Type] -> Constraint+class RHistC as where+ rhist :: LRHist as e a -> Either e (RHistT a as)++instance RHistC '[] where+ rhist = \case+ Rhi a -> Right (a, ())+instance RHistC as => RHistC (a ': as) where+ rhist = \case+ Rh a ls -> (a,) <$> rhist ls+ Lh e _ -> Left e+ LhSkip ls -> case rhist ls of+ Left e -> Left e+ Right _a -> programmError "malformed LRHist: LhSkip wrapping Rh or Rhi"++-- | validate that the composition of constructors for 'LRHist' is valid+validateLRHist :: forall e a as. LRHist as e a -> Either String ()+validateLRHist =+ \case+ Rhi{} -> Right ()+ Rh _ ls -> case ls of+ Lh{} -> Left "Rh cannot wrap Lh"+ LhSkip{} -> Left "Rh cannot wrap LhSkip"+ Rhi{} -> validateLRHist ls+ Rh{} -> validateLRHist ls+ Lh _ ls -> case ls of+ Lh{} -> Left "Lh cannot wrap Lh"+ LhSkip{} -> Left "Lh cannot wrap LhSkip"+ Rhi{} -> validateLRHist ls+ Rh{} -> validateLRHist ls+ LhSkip ls -> case ls of+ Lh{} -> validateLRHist ls+ LhSkip{} -> validateLRHist ls+ Rhi{} -> Left "LhSkip cannot wrap Rhi"+ Rh{} -> Left "LhSkip cannot wrap Rh"++-- | base case for 'LRHist' Read instance for '[] so only supports 'Rhi' constructor+instance+ (Read a, Read e) =>+ Read (LRHist '[] e a)+ where+ readPrec =+ GR.parens+ ( PC.prec+ 10+ ( do+ GR.expectP (TRL.Ident "Rhi")+ a <- PC.step GR.readPrec+ return (Rhi a)+ )+ )++-- | successor case for 'LRHist' Read instance (a' ': as) so supports 'Rh', 'Lh', 'LhSkip' constructors+instance+ ( Read a+ , Read e+ , Read a'+ , Read (LRHist as e a')+ , TP.ApplyConstraints '[Read] as+ ) =>+ Read (LRHist (a' ': as) e a)+ where+ readPrec =+ GR.parens+ ( PC.prec+ 10+ ( do+ GR.expectP (TRL.Ident "LhSkip")+ rst <- PC.step GR.readPrec+ return (LhSkip rst)+ )+ PC.+++ PC.prec+ 10+ ( do+ GR.expectP (TRL.Ident "Lh")+ e <- PC.step GR.readPrec+ rst <- PC.step GR.readPrec+ return (Lh e rst)+ )+ PC.+++ PC.prec+ 10+ ( do+ GR.expectP (TRL.Ident "Rh")+ a <- PC.step GR.readPrec+ rst <- PC.step GR.readPrec+ return (Rh a rst)+ )+ )++instance Bifunctor (LRHist as) where+ bimap f g = \case+ Rhi a -> Rhi (g a)+ Rh a ls -> Rh (g a) (first f ls)+ Lh e ls -> Lh (f e) (first f ls)+ LhSkip ls -> LhSkip (first f ls)++instance Bifoldable (LRHist as) where+ bifoldMap f g = \case+ Rhi a -> g a+ Rh a ls -> g a <> bifoldMap f (const mempty) ls+ Lh e ls -> f e <> bifoldMap f (const mempty) ls+ LhSkip ls -> bifoldMap f (const mempty) ls++instance Bitraversable (LRHist as) where+ bitraverse f g = \case+ Rhi a -> Rhi <$> g a+ Rh a ls -> Rh <$> g a <*> bitraverse f pure ls+ Lh e ls -> Lh <$> f e <*> bitraverse f pure ls+ LhSkip ls -> LhSkip <$> bitraverse f pure ls++-- | uses a boolean predicate to determine success or failure+lhBool ::+ forall e a a' as.+ (a ~ a', Monoid e) =>+ (a' -> Bool) ->+ LRHist as e a' ->+ LRHist (a' ': as) e a+lhBool f w =+ case w of+ Rhi a -> k a+ Rh a _ls -> k a+ Lh{} -> LhSkip w+ LhSkip{} -> LhSkip w+ where+ k a = bool (Lh mempty) (Rh a) (f a) w++-- | uses a maybe function to determine success or failure and also allow change of type "a"+lhMaybe ::+ forall e a a' as.+ Monoid e =>+ (a' -> Maybe a) ->+ LRHist as e a' ->+ LRHist (a' ': as) e a+lhMaybe f w =+ case w of+ Rhi a -> k a+ Rh a _ls -> k a+ Lh{} -> LhSkip w+ LhSkip{} -> LhSkip w+ where+ k a = maybe (Lh mempty) Rh (f a) w++-- | similar to 'lhMaybe' leveraging 'boolMaybe'+lhMaybe' ::+ forall e a a' as.+ Monoid e =>+ (a' -> Bool) ->+ (a' -> a) ->+ LRHist as e a' ->+ LRHist (a' ': as) e a+lhMaybe' p f w =+ case w of+ Rhi a -> k a+ Rh a _ls -> k a+ Lh{} -> LhSkip w+ LhSkip{} -> LhSkip w+ where+ k a = maybe (Lh mempty) Rh (boolMaybe p f a) w++-- | uses an either function to determine success or failure and also allow change of type "a"+lhEither ::+ forall e a a' as.+ (a' -> Either e a) ->+ LRHist as e a' ->+ LRHist (a' ': as) e a+lhEither f w =+ case w of+ Rhi a -> either Lh Rh (f a) w+ Rh a _ls -> either Lh Rh (f a) w+ Lh{} -> LhSkip w+ LhSkip{} -> LhSkip w++-- | similar to 'lhEither' leveraging 'boolEither'+lhEither' ::+ forall e a a' as.+ (a' -> Bool) ->+ (a' -> e) ->+ (a' -> a) ->+ LRHist as e a' ->+ LRHist (a' ': as) e a+lhEither' p l r w =+ case w of+ Rhi a -> k a+ Rh a _ls -> k a+ Lh{} -> LhSkip w+ LhSkip{} -> LhSkip w+ where+ k a = either Lh Rh (boolEither p l r a) w++-- | apply a function to 'LRHist' using 'ApTheseF'+appLR ::+ forall e a a' as x.+ (ApTheseF e a' x a) =>+ (a' -> x) ->+ LRHist as e a' ->+ LRHist (a' ': as) e a+appLR f w =+ case w of+ Rhi a -> k a+ Rh a _ls -> k a+ Lh{} -> LhSkip w+ LhSkip{} -> LhSkip w+ where+ k a =+ let th = apTheseF a (f a)+ in these Lh Rh (const Rh) th w++-- | similar to 'appLR' with state+appLRS ::+ forall e a' x a as z.+ (ApTheseF e a' x a) =>+ (z -> a' -> (z, x)) ->+ z ->+ LRHist as e a' ->+ (z, LRHist (a' ': as) e a)+appLRS f z w =+ case w of+ Rhi a -> k a+ Rh a _ls -> k a+ Lh{} -> (z, LhSkip w)+ LhSkip{} -> (z, LhSkip w)+ where+ k a =+ let (z1, th) = second (apTheseF a) (f z a)+ in (z1, these Lh Rh (const Rh) th w)++-- | apply a function to a 'LRHist' via 'boolEither'+appLRB ::+ forall e a a' as.+ (a' -> Bool) ->+ (a' -> e) ->+ (a' -> a) ->+ LRHist as e a' ->+ LRHist (a' ': as) e a+appLRB p l r = appLR (boolEither p l r)++-- | convenience method to apply 'appLR' to a container of 'LRHist' with state+traverseLRHist ::+ forall e a t a' as z.+ Traversable t =>+ (z -> a' -> (z, Either e a)) ->+ z ->+ t (LRHist as e a') ->+ (z, t (LRHist (a' ': as) e a))+traverseLRHist f = L.mapAccumL (appLRS f)++-- | convenience method to apply 'appLRB' to a container of 'LRHist'+traverseLRHistB ::+ forall e a t a' as.+ Functor t =>+ (a' -> Bool) ->+ (a' -> e) ->+ (a' -> a) ->+ t (LRHist as e a') ->+ t (LRHist (a' ': as) e a)+traverseLRHistB p l r = fmap (appLRB p l r)
+ src/Primus/Lens.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module : Primus.Lens+Description : minimal lens interfaces++-}+module Primus.Lens (+ Lens,+ Lens',+ lens,+ Iso,+ iso,+ Traversal,+ _Fst,+ _Snd,+) where++import Data.Profunctor++-- | lens type synonym+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t++-- | restricted lens type synonym+type Lens' s a = Lens s s a a++-- | create a lens+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens sa sbt afb s = sbt s <$> afb (sa s)+{-# INLINE lens #-}++-- | isomorphism type synonym+type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)++-- | create an isomoprhism+iso :: (s -> a) -> (b -> t) -> Iso s t a b+iso sa bt = dimap sa (fmap bt)+{-# INLINE iso #-}++-- | 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+_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+_Snd :: forall x b b'. Lens (x, b) (x, b') b b'+_Snd = lens snd (\(x, _) b' -> (x, b'))+{-# INLINE _Snd #-}
+ src/Primus/List.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++{- |+Module : Primus.List+Description : list functions+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.List (+ -- * partition methods+ partitionEithersL,+ partitionEithersL',+ partitionTheseL,+ partitionTheseL',+ partitionM,++ -- * span methods+ spanMaybe,+ spanMaybe',+ lengthExact,+ zipWithLongest,+ zipLongest,++ -- * chunking+ pairsOf1,+ pairsOf2,+ pairsOf',+ chunksOf,++ -- * split methods+ splitAtLGE,+ splits,+ SplitL (..),+ splitAtL,+ atL,+ atNoteL,+ updateAtL,+ setAtL,++ -- * miscellaneous+ allEqual,+ allEqualBy,+ snocL,+ unsnocL,+) where++import Control.Arrow+import Data.Bool+import Data.Either+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as N+import Data.Pos+import Data.These+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)+pairsOf1 = pairsOf' _1P++-- | split a list into non-overlapping pairs plus overflow+pairsOf2 :: [a] -> ([(a, a)], Maybe a)+pairsOf2 = pairsOf' _2P++-- | split into pairs skipping given number of values+pairsOf' :: forall a. Pos -> [a] -> ([(a, a)], Maybe a)+pairsOf' (Pos i) = go+ where+ go :: [a] -> ([(a, a)], Maybe a)+ go =+ \case+ [] -> ([], Nothing)+ [a] -> ([], Just a)+ [a, a'] -> ([(a, a')], Nothing)+ (a : a' : a'' : as) ->+ let (x, y) = go (drop (i - 1) (a' : a'' : as))+ in ((a, a') : x, y)++-- | simple utility for chunking data but guarantees we make progress+chunksOf :: forall a. Pos -> [a] -> [[a]]+chunksOf (Pos n) = L.unfoldr f+ where+ f :: [a] -> Maybe ([a], [a])+ f = \case+ [] -> Nothing+ xs@(_ : _) -> Just (splitAt n xs)++-- | checks that the list has all the same values+allEqual :: Eq a => [a] -> Either (a, a) ()+allEqual = allEqualBy (==)++-- | checks that the list has all the same values with a predicate+allEqualBy :: (a -> a -> Bool) -> [a] -> Either (a, a) ()+allEqualBy f =+ \case+ [] -> pure ()+ [_] -> pure ()+ x : x' : xs+ | f x x' -> allEqualBy f (x' : xs)+ | otherwise -> Left (x, x')++-- | represents the status of a split on a list+data SplitL a+ = SplitLNeg !Pos+ | SplitLLT !Int+ | SplitLEQ+ | SplitLGT !(NonEmpty a)+ deriving stock (Ord, Show, Eq)++-- | 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)))+ | otherwise = go 0 xs+ where+ go :: Int -> [a] -> ([a], SplitL a)+ go i []+ | i == n = ([], SplitLEQ)+ | otherwise = ([], SplitLLT i)+ go i (a : as)+ | i == n = ([], SplitLGT (a :| as))+ | otherwise = first (a :) (go (i + 1) as)++-- | split a list but has to have enough elements else fails+splitAtLGE :: Int -> [a] -> Either String ([a], [a])+splitAtLGE n as =+ let (ns, z) = splitAtL n as+ in (ns,) <$> case z of+ SplitLNeg (Pos j) -> Left $ "negative index " ++ show j+ SplitLLT len -> Left $ "not enough elements: expected " ++ show n ++ " found " ++ show len+ SplitLEQ -> pure mempty+ SplitLGT ex -> pure (N.toList ex)++-- | set a value at a given index in a list+setAtL :: Int -> a -> [a] -> Maybe [a]+setAtL i0 = updateAtL i0 . const++-- | update a value at a given index in a list+updateAtL :: Int -> (a -> a) -> [a] -> Maybe [a]+updateAtL i f as0 =+ case atLImpl i as0 of+ Right (a, (xs, ys)) -> Just (xs <> (f a : ys))+ Left _ -> Nothing++-- | update a value at a given index in a list+atLImpl :: Int -> [a] -> Either String (a, ([a], [a]))+atLImpl i as0 =+ let (xs, ys) = splitAtL i as0+ in case ys of+ SplitLNeg (Pos j) -> Left $ "negative index " ++ show j+ SplitLLT _ -> Left $ "LT: i=" <> show i <> " out of bounds"+ SplitLEQ -> Left $ "EQ: i=" <> show i <> " out of bounds"+ SplitLGT (a :| as) -> Right (a, (xs, as))++-- | index into a list+atL :: Int -> [a] -> Maybe a+atL = either (const Nothing) (Just . fst) .@ atLImpl++-- | unsafe index into a list+atNoteL :: HasCallStack => String -> [a] -> Int -> a+atNoteL msg = fst . forceRight msg .@ flip atLImpl++-- | compares the length of a potentially infinite list with "n" and succeeds if they are the same+lengthExact :: Int -> [a] -> Either String [a]+lengthExact n xs =+ let (as, z) = splitAtL n xs+ in case z of+ SplitLNeg (Pos j) -> Left $ "negative index " ++ show j+ SplitLLT len -> Left $ "LT: expected " ++ show n ++ " found " ++ show len+ SplitLEQ -> Right as+ SplitLGT _ -> Left $ "GT: too many elements: expected " ++ show n++-- | creates the longest of the two lists: fills with 'This' or 'That'+zipWithLongest :: forall a b c. (These a b -> c) -> [a] -> [b] -> [c]+zipWithLongest f = go .@ (,)+ where+ go = \case+ ([], []) -> []+ (xs@(_ : _), []) -> map (f . This) xs+ ([], ys@(_ : _)) -> map (f . That) ys+ (x : xs, y : ys) -> f (These x y) : go (xs, ys)++-- | 'zipWithLongest' for 'id'+zipLongest :: [a] -> [b] -> [These a b]+zipLongest = zipWithLongest id++-- | break up a list into all possible pairs of nonempty lists: see 'Primus.NonEmpty.splits1'+splits :: forall a. [a] -> [([a], [a])]+splits = \case+ [] -> []+ x : xs -> go ([x], xs)+ where+ go :: ([a], [a]) -> [([a], [a])]+ go = \case+ ([], _) -> []+ (_, []) -> []+ (a : as, b : bs) -> (a : as, b : bs) : go (a : as ++ [b], bs)++-- | like 'Data.List.partition' but allow the user to change the types of "e" and "b" using 'Either'+partitionEithersL' :: Foldable t => (a -> Either e b) -> t a -> ([e], [b])+partitionEithersL' f = partitionEithers . foldr ((:) . f) []++-- | like 'partitionEithersL'' using 'Primus.Bool.boolEither'+partitionEithersL :: Foldable t => (a -> Bool) -> (a -> e) -> (a -> b) -> t a -> ([e], [b])+partitionEithersL p l r = partitionEithers . foldr ((:) . boolEither p l r) []++-- | like 'Data.List.partition' but allow the user to change the types of "e" and "b" using 'These'+partitionTheseL' :: Foldable t => (a -> These e b) -> t a -> ([e], [b], [(e, b)])+partitionTheseL' f = partitionThese . foldr ((:) . f) []++-- | like 'partitionTheseL' using 'Primus.Bool.boolThese'+partitionTheseL :: Foldable t => (a -> Bool) -> (a -> Bool) -> (a -> e) -> (a -> b) -> t a -> ([e], [b], [(e, b)])+partitionTheseL p q l r = partitionThese . foldr ((:) . boolThese p q l r) []++-- | like 'Data.List.span' but allow the user to change the success type using 'Maybe'+spanMaybe' :: (a -> Maybe b) -> [a] -> ([b], [a])+spanMaybe' f = go+ where+ go = \case+ [] -> ([], [])+ a : as -> case f a of+ Nothing -> ([], a : as)+ Just b -> first (b :) (go as)++-- | like 'spanMaybe'' using 'Primus.Bool.boolMaybe'+spanMaybe :: (a -> Bool) -> (a -> b) -> [a] -> ([b], [a])+spanMaybe p r = spanMaybe' (boolMaybe p r)++-- | partition for an applicative+partitionM :: Applicative m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM f = go+ where+ go = \case+ [] -> pure mempty+ a : as -> (\b -> bool first second b (a :)) <$> f a <*> go as++-- | snoc for a list+snocL :: [a] -> a -> [a]+snocL as a = as ++ [a]++-- | unsnoc for a value and a list+unsnocL :: a -> [a] -> ([a], a)+unsnocL a =+ \case+ [] -> ([], a)+ x : xs -> first (a :) (unsnocL x xs)
+ src/Primus/NonEmpty.hs view
@@ -0,0 +1,532 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{- |+Module : Primus.NonEmpty+Description : utilities for nonempty lists+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.NonEmpty (+ MLR (..),++ -- * zip+ zipWithExtras1,+ zipWithExtras,+ mlrOrdering,+ fromList1LR,++ -- * chunking+ chunksOf1,+ chunksRange1,+ chunkNLen,+ chunkNLen1,++ -- * split+ Split1 (..),+ split1Ordering,+ splitAt1,+ splitAt1',+ splitAt1GE,+ splitAts1,+ splits1,+ splits3,++ -- * partition+ partition1,+ -- toThese1,++ -- * span+ spanAdjacent1,+ breakAdjacent1,+ span1,+ break1,++ -- * ascending order methods+ Seq1 (..),+ isSequence1,+ isEnumAscending,+ seq1Ordering,++ -- * isomorphisms+ uncons1,+ unsnoc1,+ consNonEmpty,+ snocNonEmpty,++ -- * positive specific functions+ sumP,+ lengthP,++ -- * fold unfold+ foldMapM1,+ unfoldr1NE,+ unfoldrM1,++ -- * iterators+ iterateMaybe1,+ iterateMaybe1',+ iterateN1,+ replicateP,++ -- * miscellaneous+ appendL1,+ appendR1,+ snoc1,+ updateAt1,+ at1,+ setAt1,+ units1,+ unitsF,+ lengthExact1,+ take1,+ sum1,+ groupByAdjacent1,+ findDupsBy,+ replicate1,+ replicate1M,+) where++import Control.Arrow+import Control.Monad+import Data.Either+import Data.Foldable+import Data.Function+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as N+import Data.Pos+import Data.Semigroup+import Data.Semigroup.Foldable+import Data.These+import Data.Tuple+import qualified GHC.Exts as GE (IsList (..))+import Primus.Bool+import Primus.Error+import Primus.Extra+import Primus.Fold+import Primus.Lens++-- | zips two nonempty lists together and puts any leftovers into 'MLR'+zipWithExtras1 :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> (NonEmpty c, MLR a b)+zipWithExtras1 f (a :| as) (b :| bs) = first (f a b :|) $ zipWithExtras f as bs++-- | represents an optional 'Either' ie Maybe (Either (NonEmpty a) (NonEmpty b))+data MLR a b+ = -- | extra values on the left hand side+ MLRLeft !(NonEmpty a)+ | -- | both values have the same length+ MLREqual+ | -- | extra values on the right hand side+ MLRRight !(NonEmpty b)+ deriving stock (Show, Eq, Ord)++-- | 'MLRLeft' predicate+mlrOrdering :: MLR a b -> Ordering+mlrOrdering = \case+ MLRLeft{} -> LT+ MLREqual -> EQ+ MLRRight{} -> GT++-- | zips two lists together and puts any leftovers into 'MLR'+zipWithExtras :: forall a b c. (a -> b -> c) -> [a] -> [b] -> ([c], MLR a b)+zipWithExtras f = go+ where+ go [] [] = ([], MLREqual)+ go (a : as) (b : bs) = let (x, y) = go as bs in (f a b : x, y)+ go (a : as) [] = ([], MLRLeft (a :| as))+ go [] (b : bs) = ([], MLRRight (b :| bs))++-- | conversion from list to a nonempty list+fromList1LR :: [a] -> Either String (NonEmpty a)+fromList1LR =+ \case+ [] -> Left "fromList1LR: empty list"+ n : ns -> Right $ n :| ns++-- | split a nonempty list into a nonempty list of nonempty chunks+chunksOf1 :: Pos -> NonEmpty a -> NonEmpty (NonEmpty a)+chunksOf1 = join chunksRange1++{- | split a nonempty list into a nonempty list of nonempty chunks given a chunk size and how many to skip each iteration+ can decide the size of the chunks and how many elements to skip+-}+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'+ must fill the container exactly+-}+chunkNLen1 ::+ forall a u.+ Foldable u =>+ Pos ->+ Pos ->+ u a ->+ Either String (NonEmpty (NonEmpty a))+chunkNLen1 sz = chunkNLen (units1 sz)++{- | fills a container "tz" with chunks of size "len"+ must fill the container exactly+-}+chunkNLen ::+ forall t a u z.+ (Traversable t, Foldable u) =>+ t z ->+ Pos ->+ u a ->+ Either String (t (NonEmpty a))+chunkNLen tz len ua = do+ chunkN' f tz (toList ua)+ where+ f :: [a] -> Either String ([a], NonEmpty a)+ f = \case+ [] -> Left "chunkNLen: not enough data"+ x : xs -> swap <$> splitAt1GE len (x :| xs)++{- | unfoldr for a nonempty list++will not terminate if the user keeps returning a larger [s] than received+-}+unfoldr1NE ::+ forall s a.+ (NonEmpty s -> (a, [s])) ->+ NonEmpty s ->+ NonEmpty a+unfoldr1NE f = go+ where+ go :: NonEmpty s -> NonEmpty a+ go ns =+ let (a, ys) = f ns+ in (a :|) $ case ys of+ [] -> []+ x : xs -> N.toList (go (x :| xs))++-- | 'replicate' for a nonempty list+replicate1 :: Pos -> a -> NonEmpty a+replicate1 (Pos n) a = a :| replicate (n - 1) a++-- | 'replicateM' for a nonempty list+replicate1M :: Applicative m => Pos -> m a -> m (NonEmpty a)+replicate1M (Pos n) ma = (:|) <$> ma <*> replicateM (n - 1) ma++-- | 'partitionThese' for a nonempty list+partition1 ::+ Foldable1 t =>+ (a -> Bool) ->+ t a ->+ These (NonEmpty a) (NonEmpty a)+partition1 p =+ sconcat+ . N.map (boolM p (This . pure) (That . pure))+ . toNonEmpty++-- | internal function used by 'span1'+toThese1 ::+ These (NonEmpty a) (NonEmpty b) ->+ ([a], [b]) ->+ These (NonEmpty a) (NonEmpty b)+toThese1 th ns =+ th & case ns of+ ([], []) -> id+ (a : as, []) -> (<> This (a :| as))+ ([], b : bs) -> (<> That (b :| bs))+ (a : as, b : bs) -> (<> These (a :| as) (b :| bs))++-- | 'span' for a nonempty list+span1 ::+ Foldable1 t =>+ (a -> Bool) ->+ t a ->+ These (NonEmpty a) (NonEmpty a)+span1 p (toNonEmpty -> (a :| as)) =+ toThese1+ ( boolM+ p+ (That . pure)+ (This . pure)+ a+ )+ (L.span p as)++-- | 'break' for a nonempty list+break1 ::+ Foldable1 t =>+ (a -> Bool) ->+ t a ->+ These (NonEmpty a) (NonEmpty a)+break1 p = span1 (not . p)++-- | 'sum' for a nonempty list+sum1 :: (Foldable1 t, Num a) => t a -> a+sum1 = L.foldl' (+) 0++-- | predicate for an ascending nonempty list+isSequence1 :: (Foldable1 t, Eq a, Enum a) => t a -> Bool+isSequence1 = (EQ ==) . seq1Ordering . isEnumAscending++-- | possible results for determining if a nonempty list is in ascending order+data Seq1 a+ = -- | generated enumerable sequence is shorter than the original list+ S1Short !(NonEmpty a)+ | -- | first mismatch+ S1Fail !(a, a)+ | -- | both sequences match+ S1Ok+ deriving stock (Show, Eq, Ord, Functor)++-- | predicate for 'S1Short'+seq1Ordering :: Seq1 a -> Ordering+seq1Ordering = \case+ S1Short{} -> LT+ S1Ok{} -> EQ+ S1Fail{} -> GT++-- | shows the first failure or if the length of the enum is too short+isEnumAscending :: forall t a. (Foldable1 t, Eq a, Enum a) => t a -> Seq1 a+isEnumAscending (toNonEmpty -> as@(a :| _)) =+ let (cs, me) = zipWithExtras1 f (a :| drop 1 [a ..]) as+ in case me of+ MLRLeft _ -> either S1Fail (const S1Ok) $ sequenceA cs+ MLREqual -> either S1Fail (const S1Ok) $ sequenceA cs+ MLRRight zs -> S1Short zs+ where+ f :: a -> a -> Either (a, a) ()+ f x y = if x == y then Right () else Left (x, y)++-- | snoc for a nonempty list+snoc1 :: Foldable t => t a -> a -> NonEmpty a+snoc1 as a = foldr (N.<|) (pure a) as++-- | unsnoc for a nonempty list+unsnoc1 :: forall a. NonEmpty a -> ([a], a)+unsnoc1 = uncurry go . uncons1+ where+ go :: a -> [a] -> ([a], a)+ go n [] = ([], n)+ go n (x : xs) = first (n :) (go x xs)++-- | uncons for a nonempty list+uncons1 :: forall a. NonEmpty a -> (a, [a])+uncons1 (z :| zs) = (z, zs)++-- | cons iso from 'NonEmpty'+consNonEmpty :: Iso (NonEmpty a) (NonEmpty b) (a, [a]) (b, [b])+consNonEmpty = iso uncons1 (uncurry (:|))++-- | snoc iso from 'NonEmpty'+snocNonEmpty :: Iso (NonEmpty a) (NonEmpty b) ([a], a) ([b], b)+snocNonEmpty = iso unsnoc1 (uncurry snoc1)++-- | 'N.groupBy1' but applies the predicate to adjacent elements+groupByAdjacent1 :: forall a. (a -> a -> Bool) -> NonEmpty a -> NonEmpty (NonEmpty a)+groupByAdjacent1 p (a0 :| as0) =+ let (as, ass) = go a0 as0+ in (a0 :| as) :| ass+ where+ go :: a -> [a] -> ([a], [NonEmpty a])+ go a' = \case+ [] -> ([], [])+ a : as ->+ let (ys, zs) = go a as+ in if p a' a+ then (a : ys, zs)+ else ([], (a :| ys) : zs)++-- | partition duplicates elements together with their positiion+findDupsBy :: forall a c. Ord c => (a -> c) -> [a] -> ([NonEmpty (Int, a)], [(Int, a)])+findDupsBy f =+ partitionEithers+ . map g+ . N.groupAllWith (f . snd)+ . zip [0 ..]+ where+ g :: NonEmpty (Int, a) -> Either (NonEmpty (Int, a)) (Int, a)+ g = \case+ x :| [] -> Right x+ x :| y : ys -> Left (x :| y : ys)++-- | "foldMapM" for nonempty containers: uses Semigroup instead of Monoid+foldMapM1 ::+ forall b m f a.+ (Semigroup b, Monad m, Foldable1 f) =>+ (a -> m b) ->+ f a ->+ m b+foldMapM1 f (toNonEmpty -> n :| ns) = foldr step return ns =<< f n+ where+ step :: a -> (b -> m b) -> b -> m b+ step x r z = f x >>= \y -> r $! z <> y++-- | 'Primus.Fold.unfoldM' for nonempty results+unfoldrM1 :: Monad m => (s -> m (a, Maybe s)) -> s -> m (NonEmpty a)+unfoldrM1 f s = do+ (a, ms) <- f s+ case ms of+ Nothing -> return (a :| [])+ Just s' -> (a N.<|) <$> unfoldrM1 f s'++-- | 'take' for a nonempty list+take1 :: Pos -> NonEmpty a -> NonEmpty a+take1 (Pos i) (a :| as) = a :| take (i - 1) as++-- | 'splitAt' for a nonempty list but doesnt guarantee the number of elements+splitAt1 :: Pos -> NonEmpty a -> (NonEmpty a, [a])+splitAt1 (Pos i) (a :| as) = first (a :|) (splitAt (i - 1) as)++-- | comparator for 'Split1'+split1Ordering :: Split1 a -> Ordering+split1Ordering = \case+ SplitLT{} -> LT+ SplitEQ{} -> EQ+ SplitGT{} -> GT++-- | represents the status of a split a nonempty list+data Split1 a+ = SplitLT !Pos+ | SplitEQ+ | SplitGT !(NonEmpty a)+ deriving stock (Ord, Show, Eq)++-- | split a nonempty list preserving information about the split+splitAt1' :: forall a. Pos -> NonEmpty a -> (NonEmpty a, Split1 a)+splitAt1' = go _1P+ where+ go :: Pos -> Pos -> NonEmpty a -> (NonEmpty a, Split1 a)+ go !i !n (a :| [])+ | i == n = (a :| [], SplitEQ)+ | otherwise = (a :| [], SplitLT i)+ go !i !n (a :| a1 : as)+ | i == n = (a :| [], SplitGT (a1 :| as))+ | otherwise =+ let (ys, y) = go (succP i) n (a1 :| as)+ in (a N.<| ys, y)++-- | split a nonempty list but has to have enough elements else fails+splitAt1GE :: Pos -> NonEmpty a -> Either String (NonEmpty a, [a])+splitAt1GE n as =+ let (ns, z) = splitAt1' n as+ in (ns,) <$> case z of+ SplitLT (Pos len) -> Left $ "not enough elements: expected " ++ show (unP n) ++ " found " ++ show len+ SplitEQ -> pure mempty+ SplitGT ex -> pure (N.toList ex)++-- | repeatedly split a nonempty list+splitAts1 :: Pos -> NonEmpty a -> NonEmpty (NonEmpty a)+splitAts1 i = unfoldr1NE (splitAt1 i) . toNonEmpty++-- | compares the length of a potentially infinite nonempty list with "n" and succeeds if they are the same+lengthExact1 :: Pos -> NonEmpty a -> Either String (NonEmpty a)+lengthExact1 n xs =+ let (as, z) = splitAt1' n xs+ in case z of+ SplitLT (Pos len) -> Left $ "LT: not enough elements: expected " ++ show (unP n) ++ " found " ++ show len+ SplitEQ -> Right as+ SplitGT _ -> Left $ "GT: too many elements: expected " ++ show (unP n)++-- | break up a nonempty list into all possible pairs of nonempty lists+splits1 :: forall a. NonEmpty a -> [(NonEmpty a, NonEmpty a)]+splits1 (n :| ns) = go ([n], ns)+ where+ go :: ([a], [a]) -> [(NonEmpty a, NonEmpty a)]+ go = \case+ ([], _) -> []+ (_, []) -> []+ (a : as, b : bs) -> (a :| as, b :| bs) : go (a : as ++ [b], bs)++-- | like 'Data.List.iterate' but allows termination using Maybe+iterateMaybe1' :: (a -> Maybe a) -> a -> NonEmpty a+iterateMaybe1' f a0 = a0 :| go a0+ where+ go a = case f a of+ Nothing -> []+ Just x -> x : go x++-- | like 'iterateMaybe1'' with 'boolMaybe'+iterateMaybe1 :: (a -> Bool) -> (a -> a) -> a -> NonEmpty a+iterateMaybe1 f g = iterateMaybe1' (boolMaybe f g)++-- | iterate "n" times+iterateN1 :: Pos -> (a -> a) -> a -> NonEmpty a+iterateN1 n = take1 n .@ N.iterate++-- | break up a nonempty list into a nonempty list of three parts+splits3 :: forall a. NonEmpty a -> NonEmpty ([a], a, [a])+splits3 (n :| ns) = N.scanl f ([], n, ns) ns+ where+ f :: forall z. ([a], a, [a]) -> z -> ([a], a, [a])+ f (xs, y, zs') _ = case zs' of+ [] -> programmError "splits3"+ z : zs -> (xs ++ [y], z, zs)++-- | like 'Data.List.span' but applies the predicate to adjacent elements+spanAdjacent1 :: (a -> a -> Bool) -> NonEmpty a -> (NonEmpty a, [a])+spanAdjacent1 p (a0 :| as0) = first (a0 :|) (go a0 as0)+ where+ go a' = \case+ [] -> ([], [])+ a : as+ | p a' a -> first (a :) (go a as)+ | otherwise -> ([], a : as)++-- | like 'Data.List.break' but applies the predicate to adjacent elements+breakAdjacent1 :: (a -> a -> Bool) -> NonEmpty a -> (NonEmpty a, [a])+breakAdjacent1 p = spanAdjacent1 (not .@ p)++-- | append a list with a nonempty list+appendL1 :: [a] -> NonEmpty a -> NonEmpty a+appendL1 as bs = foldr N.cons bs as++-- | append a nonempty list with a list+appendR1 :: NonEmpty a -> [a] -> NonEmpty a+appendR1 (a :| as) bs = a :| (as <> bs)++-- | set a value at an index starting at one+setAt1 :: Pos -> a -> NonEmpty a -> Maybe (NonEmpty a)+setAt1 i = updateAt1 i . const++-- | update a value at an index starting at one+updateAt1 :: Pos -> (a -> a) -> NonEmpty a -> Maybe (NonEmpty a)+updateAt1 (Pos i) f ns =+ case N.splitAt (i - 1) ns of+ ([], b : bs) -> Just (f b :| bs)+ (a : as, b : bs) -> Just (a :| as ++ (f b : bs))+ (_, []) -> Nothing++-- | get a value at an index starting at one+at1 :: Pos -> NonEmpty a -> Maybe a+at1 (Pos i) ns =+ case N.splitAt (i - 1) ns of+ (_, b : _) -> Just b+ (_, []) -> Nothing++-- | generate a repeated nonempty list of values for a fixed size+replicateP :: Pos -> a -> NonEmpty a+replicateP (Pos i) a = a :| replicate (i - 1) a++-- | length of nonempty list+lengthP :: Foldable1 t => t a -> Pos+lengthP = unsafePos "lengthP" . N.length . toNonEmpty+{-# INLINE lengthP #-}++-- | generate a nonempty list of units for a fixed size+units1 :: Pos -> NonEmpty ()+units1 = unitsF++-- | generate a nonempty list of units for a given container of the given size+unitsF :: forall l a. (GE.IsList (l a), GE.Item (l a) ~ ()) => Pos -> l a+unitsF = GE.fromList . flip replicate () . unP++-- | sum of nonempty list of 'Pos' values+sumP :: Foldable1 t => t Pos -> Pos+sumP = L.foldr1 (+!)+{-# INLINE sumP #-}+
+ src/Primus/Num1.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}++{- |+Module : Primus.Num1+Description : similar to 'Num' class but with failure handling+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.Num1 (+ Num1 (..),+ withOp,+ withOp2,+ withOp3,+ withOp4,+) where++import Control.Applicative+import Control.Monad+import Data.Int+import Data.Kind+import Data.Pos+import Data.Word+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+withOp f a = fromInteger1 a (f (toInteger1 a))++-- | run a function of two integers against the underlying 'Num1' types+withOp2 :: Num1 a => (Integer -> Integer -> Integer) -> a -> a -> Either String a+withOp2 f a b = fromInteger1 a (f (toInteger1 a) (toInteger1 b))++-- | run a function of three integers against the underlying 'Num1' types+withOp3 :: Num1 a => (Integer -> Integer -> Integer -> Integer) -> a -> a -> a -> Either String a+withOp3 f a b c =+ fromInteger1 a (f (toInteger1 a) (toInteger1 b) (toInteger1 c))++-- | run a function of four integers against the underlying 'Num1' types+withOp4 :: Num1 a => (Integer -> Integer -> Integer -> Integer -> Integer) -> a -> a -> a -> a -> Either String a+withOp4 f a b c d =+ fromInteger1 a (f (toInteger1 a) (toInteger1 b) (toInteger1 c) (toInteger1 d))++{- | lifted version of Num class for handling failure+ minimal definition requires 'toInteger1' and 'fromInteger1' unless leveraging default signatures+-}+type Num1 :: Type -> Constraint+class Num1 a where+ -- | required method for converting from "a" to an 'Integer'+ toInteger1 :: a -> Integer+ default toInteger1 :: Enum a => a -> Integer+ toInteger1 = toInteger . fromEnum @a++ -- | required method for trying to convert from an 'Integer' to "a"+ fromInteger1 :: a -> Integer -> Either String a+ default fromInteger1 :: (Bounded a, Enum a) => a -> Integer -> Either String a+ fromInteger1 = const integerToEnumSafe++ (.+)+ , (.-)+ , (.*) ::+ Either String a ->+ Either String a ->+ Either String a+ (.+) = join .@ liftA2 (lmsg "(.+)" .@ withOp2 (+))+ (.-) = join .@ liftA2 (lmsg "(.-)" .@ withOp2 (-))+ (.*) = join .@ liftA2 (lmsg "(.*)" .@ withOp2 (*))+ negate1+ , abs1+ , signum1+ , succ1+ , pred1 ::+ Either String a ->+ Either String a+ negate1 = (=<<) (lmsg "negate1" . withOp negate)+ signum1 = (=<<) (lmsg "signum1" . withOp signum)+ abs1 = (=<<) (lmsg "abs1" . withOp abs)+ succ1 = (=<<) (lmsg "succ1" . withOp succ)+ pred1 = (=<<) (lmsg "pred1" . withOp pred)++infixl 7 .*+infixl 6 .++infixl 6 .-++instance Num1 Natural where+ fromInteger1 _ i+ | i < 0 = Left $ "Natural: undefined for negative numbers " ++ show i+ | otherwise = Right $ naturalFromInteger i++instance Num1 Pos++instance Num1 Word8+instance Num1 Word16+instance Num1 Word32+instance Num1 Word64++instance Num1 Int++instance Num1 Int8+instance Num1 Int16+instance Num1 Int32+instance Num1 Int64
+ src/Primus/One.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{- |+Module : Primus.One+Description : holds a singleton value+Copyright : (c) Grant Weyburne, 2016+License : BSD-3++handles a tuple of size one. this is a special type that distinguishes a singleton value from a ntuple+will be replaced by Solo when ghc 9.2 is standard and generics-sop is updated to support Solo+-}+module Primus.One (+ One (..),+ unOne,+) where++import Control.DeepSeq+import Data.Coerce+import Data.Data+import qualified Data.Functor.Apply as Apply+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import GHC.Generics (Generic, Generic1)++-- | unwrap 'One'+unOne :: One a -> a+unOne = coerce++-- | One holds a single value. To use wprint we need a SOP Generics instance+newtype One a = One a+ deriving stock (Data, Generic, Generic1, Show, Eq, Ord, Traversable, Read, Functor, Foldable)+ deriving newtype (Semigroup, Monoid, NFData)+ deriving anyclass (NFData1, Foldable1)++instance Applicative One where+ pure = coerce+ (<*>) = coerce+instance Apply.Apply One where+ (<.>) = coerce+instance Monad One where+ return = pure+ One a >>= amb = amb a+instance Traversable1 One where+ traverse1 afb = fmap One . afb . unOne
+ src/Primus/Rep.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- |+Module : Primus.Rep+Description : representable methods for use with fixed containers+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.Rep (+ buildRepL,+ buildRepR,+ fillRep,+ toEnumRep,+ izipWithR,+ izipWithRF,+ ipostscanr,+ ipostscanl,+ unfoldlRep,+ unfoldrRep,+) where++import Data.Bool+import Data.Distributive+import Data.Foldable+import Data.Functor.Rep+import qualified Data.List as L+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+buildRepL ::+ forall f a b.+ (Traversable f, Representable f) =>+ ([Rep f] -> [Rep f] -> b -> Rep f -> (b, a)) ->+ b ->+ (b, f a)+buildRepL f b0 = histMapL f b0 (tabulate id)++-- | same as 'buildRepL' but associates to the right+buildRepR ::+ forall f a b.+ (Traversable f, Representable f) =>+ ([Rep f] -> [Rep f] -> b -> Rep f -> (b, a)) ->+ b ->+ (b, f a)+buildRepR f b0 = histMapR f b0 (tabulate id)++-- | fill a representable container with a foldable+fillRep ::+ forall f a.+ (Representable f, Traversable f) =>+ [a] ->+ Either String ([a], f a)+fillRep = fillTraversable (tabulate id)++-- | load a fixed container with "a"s using the relative position "i"+toEnumRep ::+ forall f a.+ (Traversable f, Representable f, Enum a, Bounded a) =>+ Integer ->+ Either String (f a)+toEnumRep = toEnumTraversable (tabulate id)++-- | 'Data.List.zipWith' with rep index+izipWithR ::+ Representable f =>+ (Rep f -> a -> b -> c) ->+ f a ->+ f b ->+ f c+izipWithR f as bs = tabulate $ \k -> f k (index as k) (index bs k)++-- | 'Control.Monad.zipWithM' with rep index+izipWithRF ::+ (Representable f, Distributive g) =>+ (Rep f -> a -> b -> g c) ->+ f a ->+ f b ->+ g (f c)+izipWithRF f = collect id .@ izipWithR f++{- | like 'Data.List.scanr'+ passes in the 'Rep' index and removes the first element+-}+ipostscanr :: (Representable f, Traversable f) => (Rep f -> a -> b -> b) -> b -> f a -> f b+ipostscanr f c ta =+ frp $ fillTraversableExact ta $ N.init $ N.scanr (uncurry f) c xs+ where+ xs = toList $ imapRep (,) ta++{- | like 'Data.List.scanl'+ passes in the 'Rep' index and removes the last element+-}+ipostscanl :: (Representable f, Traversable f) => (Rep f -> b -> a -> b) -> b -> f a -> f b+ipostscanl f c ta =+ frp $ fillTraversableExact ta $ N.tail $ N.scanl g c xs+ where+ xs = imapRep (,) ta+ g b (i, a) = f i b a++-- | left/right unfold from the right into a Representable+unfoldlRep+ , unfoldrRep ::+ (Representable f, Traversable f) =>+ (Rep f -> s -> (s, a)) ->+ s ->+ (s, f a)+unfoldlRep = unfoldRepImpl False+unfoldrRep = unfoldRepImpl True++unfoldRepImpl :: (Representable f, Traversable f) => Bool -> (Rep f -> s -> (s, a)) -> s -> (s, f a)+unfoldRepImpl isright f s = bool L.mapAccumL L.mapAccumR isright (flip f) s (tabulate id)
+ src/Primus/TypeLevel.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module : Primus.TypeLevel+Description : commonly used type families+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.TypeLevel (+ pnat,+ FailUnless,+ Fst,+ Snd,+ Fsts,+ Snds,+ Length,+ Len1T,+ NotEqTC,+ Cons1T,+ Snoc1T,+ Snoc1LT,+ SnocT,+ InitT,+ Init1T,+ Last1T,+ Head1T,+ App1T,+ ApplyConstraints1,+ ApplyConstraint,+ ApplyConstraints,+ UnconsT,+ UnsnocT,+ FirstConsT,+ ToITupleT,+ FromITupleT,+ ITupleC (..),+ type (++),+ type (:=>),+) where++import Data.Kind+import Data.List.NonEmpty (NonEmpty (..))+import Data.Proxy+import GHC.TypeLits+import qualified GHC.TypeLits as GL+import qualified GHC.TypeNats as GN+import Primus.One++-- | fail with error message if "b" is 'False+type FailUnless :: Bool -> ErrorMessage -> Constraint+type family FailUnless b err where+ FailUnless 'False err = TypeError ( 'Text "FailUnless: " ':<>: err)+ FailUnless 'True _ = ()++-- | extract an int from a 'Nat'+pnat :: forall n. KnownNat n => Int+pnat = fromEnum (GN.natVal (Proxy @n))++-- | type level boolean implication+type (:=>) :: Bool -> Bool -> Bool+type family x :=> y where+ 'False :=> _ = 'True+ 'True :=> x = x+ _ :=> 'False = 'True+ _ :=> 'True = 'True+ x :=> x = 'True++-- | "fst" at the typelevel+type Fst :: forall a b. (a, b) -> a+type family Fst tp where+ Fst '(a, _) = a++-- | "snd" at the typelevel+type Snd :: forall a b. (a, b) -> b+type family Snd tp where+ Snd '(_, b) = b++-- | "map fst" at the typelevel+type Fsts :: forall a b. [(a, b)] -> [a]+type family Fsts rs where+ Fsts '[] = '[]+ Fsts ('(a, _) ': rs) = a ': Fsts rs++-- | "map snd" at the typelevel+type Snds :: forall a b. [(a, b)] -> [b]+type family Snds rs where+ Snds '[] = '[]+ 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++-- | ensure that two types are not equal+type NotEqTC :: forall k k1. k -> k1 -> Constraint+type family NotEqTC a b where+ NotEqTC a a = TypeError ( 'Text "NotEqTC: found equal")+ NotEqTC _ _ = ()++-- sometimes you can avoid using Cons1T: check first (expand/inline at the callsite)++-- | cons a type to a nonempty list at the type level+type Cons1T :: forall k. k -> NonEmpty k -> NonEmpty k+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+ ApplyConstraints1 '[] _ = ()+ ApplyConstraints1 (c ': cs) x = (c x, ApplyConstraints1 cs x)++-- | create a constraint from a list of types and a constraint that take a type+type ApplyConstraint :: (k -> Constraint) -> [k] -> Constraint+type family ApplyConstraint c xs where+ ApplyConstraint _ '[] = ()+ ApplyConstraint c (x ': xs) = (c x, ApplyConstraint c xs)++-- | create a constraint from a list of types and list of constraints that take a type+type ApplyConstraints :: [k -> Constraint] -> [k] -> Constraint+type family ApplyConstraints cs xs where+ 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 family UnsnocT ns where+ 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)+type family FirstConsT a b = result | result -> a b where+ FirstConsT a '(as, c) = '(a ': as, c)++-- putStrLn $ genITupleAll _10P++-- | convert a flat tuple type to an inductive tuple+type ToITupleT :: Type -> Type+type family ToITupleT x = result | result -> x where+ ToITupleT (One a1) = (a1, ())+ ToITupleT (a1, a2) = (a1, (a2, ()))+ ToITupleT (a1, a2, a3) = (a1, (a2, (a3, ())))+ ToITupleT (a1, a2, a3, a4) = (a1, (a2, (a3, (a4, ()))))+ ToITupleT (a1, a2, a3, a4, a5) = (a1, (a2, (a3, (a4, (a5, ())))))+ ToITupleT (a1, a2, a3, a4, a5, a6) = (a1, (a2, (a3, (a4, (a5, (a6, ()))))))+ ToITupleT (a1, a2, a3, a4, a5, a6, a7) = (a1, (a2, (a3, (a4, (a5, (a6, (a7, ())))))))+ ToITupleT (a1, a2, a3, a4, a5, a6, a7, a8) = (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, ()))))))))+ ToITupleT (a1, a2, a3, a4, a5, a6, a7, a8, a9) = (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, (a9, ())))))))))+ ToITupleT (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, (a9, (a10, ()))))))))))++-- | convert an inductive tuple to a flat tuple type+type FromITupleT :: Type -> Type+type family FromITupleT x = result | result -> x where+ FromITupleT (a1, ()) = One a1+ FromITupleT (a1, (a2, ())) = (a1, a2)+ FromITupleT (a1, (a2, (a3, ()))) = (a1, a2, a3)+ FromITupleT (a1, (a2, (a3, (a4, ())))) = (a1, a2, a3, a4)+ FromITupleT (a1, (a2, (a3, (a4, (a5, ()))))) = (a1, a2, a3, a4, a5)+ FromITupleT (a1, (a2, (a3, (a4, (a5, (a6, ())))))) = (a1, a2, a3, a4, a5, a6)+ FromITupleT (a1, (a2, (a3, (a4, (a5, (a6, (a7, ()))))))) = (a1, a2, a3, a4, a5, a6, a7)+ FromITupleT (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, ())))))))) = (a1, a2, a3, a4, a5, a6, a7, a8)+ FromITupleT (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, (a9, ()))))))))) = (a1, a2, a3, a4, a5, a6, a7, a8, a9)+ FromITupleT (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, (a9, (a10, ())))))))))) = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)++-- | conversions to and from an inductive tuple and a flat tuple+type ITupleC :: Type -> Constraint+class ITupleC x where+ toITupleC :: x -> ToITupleT x+ fromITupleC :: ToITupleT x -> x++instance ITupleC (One a1) where+ toITupleC (One a1) = (a1, ())+ fromITupleC (a1, ()) = One a1+instance ITupleC (a1, a2) where+ toITupleC (a1, a2) = (a1, (a2, ()))+ fromITupleC (a1, (a2, ())) = (a1, a2)+instance ITupleC (a1, a2, a3) where+ toITupleC (a1, a2, a3) = (a1, (a2, (a3, ())))+ fromITupleC (a1, (a2, (a3, ()))) = (a1, a2, a3)+instance ITupleC (a1, a2, a3, a4) where+ toITupleC (a1, a2, a3, a4) = (a1, (a2, (a3, (a4, ()))))+ fromITupleC (a1, (a2, (a3, (a4, ())))) = (a1, a2, a3, a4)+instance ITupleC (a1, a2, a3, a4, a5) where+ toITupleC (a1, a2, a3, a4, a5) = (a1, (a2, (a3, (a4, (a5, ())))))+ fromITupleC (a1, (a2, (a3, (a4, (a5, ()))))) = (a1, a2, a3, a4, a5)+instance ITupleC (a1, a2, a3, a4, a5, a6) where+ toITupleC (a1, a2, a3, a4, a5, a6) = (a1, (a2, (a3, (a4, (a5, (a6, ()))))))+ fromITupleC (a1, (a2, (a3, (a4, (a5, (a6, ())))))) = (a1, a2, a3, a4, a5, a6)+instance ITupleC (a1, a2, a3, a4, a5, a6, a7) where+ toITupleC (a1, a2, a3, a4, a5, a6, a7) = (a1, (a2, (a3, (a4, (a5, (a6, (a7, ())))))))+ fromITupleC (a1, (a2, (a3, (a4, (a5, (a6, (a7, ()))))))) = (a1, a2, a3, a4, a5, a6, a7)+instance ITupleC (a1, a2, a3, a4, a5, a6, a7, a8) where+ toITupleC (a1, a2, a3, a4, a5, a6, a7, a8) = (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, ()))))))))+ fromITupleC (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, ())))))))) = (a1, a2, a3, a4, a5, a6, a7, a8)+instance ITupleC (a1, a2, a3, a4, a5, a6, a7, a8, a9) where+ toITupleC (a1, a2, a3, a4, a5, a6, a7, a8, a9) = (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, (a9, ())))))))))+ fromITupleC (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, (a9, ()))))))))) = (a1, a2, a3, a4, a5, a6, a7, a8, a9)+instance ITupleC (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) where+ toITupleC (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, (a9, (a10, ()))))))))))+ fromITupleC (a1, (a2, (a3, (a4, (a5, (a6, (a7, (a8, (a9, (a10, ())))))))))) = (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)++-- | append two type level lists+type (++) :: forall a. [a] -> [a] -> [a]+type family (++) xs ys where+ '[] ++ ys = ys+ (x ': xs) ++ ys = x ': xs ++ ys++infixr 5 ++++-- | 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 (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
+ src/Primus/ZipNonEmpty.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++{- |+Module : Primus.ZipNonEmpty+Description : 'Control.Applicative.ZipList' version for 'NonEmpty'+Copyright : (c) Grant Weyburne, 2022+License : BSD-3+-}+module Primus.ZipNonEmpty (+ ZipNonEmpty (..),+ _Zip1,+ unZipNonEmpty,+) where++import Control.Applicative+import Control.DeepSeq+import Data.Coerce+import Data.Data+import qualified Data.Functor.Apply as Apply+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as N+import Data.Semigroup.Foldable+import Data.Semigroup.Traversable+import qualified GHC.Exts as GE (IsList (..))+import GHC.Generics (Generic, Generic1)+import Primus.Error (normalError)+import Primus.Lens++-- | unwrap 'ZipNonEmpty'+unZipNonEmpty :: ZipNonEmpty a -> NonEmpty a+unZipNonEmpty = coerce++-- | zippable version of 'NonEmpty'+newtype ZipNonEmpty a = ZipNonEmpty (NonEmpty a)+ deriving stock (Data, Generic, Generic1, Show, Eq, Ord, Traversable, Read)+ deriving (NFData) via (NonEmpty a)+ deriving (NFData1, Foldable, Foldable1, Functor) via NonEmpty++-- checkers hangs+instance Monoid a => Monoid (ZipNonEmpty a) where+ mempty = pure mempty++instance Semigroup a => Semigroup (ZipNonEmpty a) where+ (<>) = liftA2 (<>)++instance Applicative ZipNonEmpty where+ pure = ZipNonEmpty . N.repeat+ liftA2 f (ZipNonEmpty xs) (ZipNonEmpty ys) = ZipNonEmpty (N.zipWith f xs ys)++instance Apply.Apply ZipNonEmpty where+ (<.>) = (<*>)++instance Traversable1 ZipNonEmpty where+ traverse1 afb = fmap ZipNonEmpty . traverse1 afb . unZipNonEmpty++instance GE.IsList (ZipNonEmpty a) where+ type Item (ZipNonEmpty a) = a+ fromList =+ \case+ [] -> normalError "IsList: fromList: need at least one element"+ x : xs -> ZipNonEmpty (x :| xs)+ toList = N.toList . coerce++-- | iso for the zipnonempty constructor+_Zip1 :: Iso (ZipNonEmpty a) (ZipNonEmpty b) (NonEmpty a) (NonEmpty b)+_Zip1 = iso coerce coerce+
+ test/Main.hs view
@@ -0,0 +1,41 @@+module Main where++import System.Environment+import Test.Tasty+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++main :: IO ()+main = do+ xs <- getArgs+ let x1 = [TestLRHist.suiteCheckers, TestZipNonEmpty.suiteCheckers]+ (os, zs) <- case xs of+ "0" : os -> putStrLn "NORMAL (Explicit)" >> return (os, mempty)+ "1" : os -> putStrLn "VERBOSE" >> return (os, x1)+ "2" : os -> putStrLn "EXTRA VERBOSE" >> return (os, x1)+ os -> putStrLn "NORMAL" >> return (os, [])+ withArgs os $+ defaultMain $+ testGroup+ "alltests"+ ( [ TestAsMaybe.suite+ , TestBool.suite+ , TestEnum.suite+ , TestExtra.suite+ , TestFold.suite+ , TestList.suite+ , TestLRHist.suite+ , TestNonEmpty.suite+ , TestNum1.suite+-- , TestZipNonEmpty.suite+ ]+ ++ zs+ )
+ test/TestAsMaybe.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module TestAsMaybe where++import Control.Arrow+import Data.Char+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.Semigroup as SG+import Data.These+import Primus.AsMaybe+import Primus.Bool+import Primus.Enum+import Test.Tasty+import Test.Tasty.HUnit++suite :: TestTree+suite =+ testGroup+ "TestAsMaybe"+ [ testCase "iterateT1" $+ iterateT1 (\i -> if i > 0 then Just (i - 1) else Nothing) (5 :: Int)+ @?= (5 :| [4, 3, 2, 1, 0])+ , testCase "iterateT1 simpler" $+ iterateT1 (boolMaybe (> 0) pred) (5 :: Int)+ @?= (5 :| [4, 3, 2, 1, 0])+ , testCase "iterateT1" $+ iterateT1 succSafe LT+ @?= (LT :| [EQ, GT])+ , testCase "iterateT1" $+ iterateT1 succSafe GT+ @?= (GT :| [])+ , testCase "iterateT1" $+ iterateT1 predSafe GT+ @?= (GT :| [EQ, LT])+ , testCase "iterateT1" $+ iterateT1 (\x -> if length x > 5 then Left @String "asdf" else Right (length x : x)) [0 :: Int]+ @?= ([0] :| [[1, 0], [2, 1, 0], [3, 2, 1, 0], [4, 3, 2, 1, 0], [5, 4, 3, 2, 1, 0]])+ , testCase "iterateT1 simpler" $+ iterateT1 (boolEither ((<= 5) . length) (const @String "asdf") (\x -> length x : x)) [0 :: Int]+ @?= ([0] :| [[1, 0], [2, 1, 0], [3, 2, 1, 0], [4, 3, 2, 1, 0], [5, 4, 3, 2, 1, 0]])+ , testCase "iterateT1" $+ iterateT1 (\x -> if length x > 5 then Nothing else Just (length x : x)) [0 :: Int]+ @?= ([0] :| [[1, 0], [2, 1, 0], [3, 2, 1, 0], [4, 3, 2, 1, 0], [5, 4, 3, 2, 1, 0]])+ , testCase "iterateT1" $+ iterateT1 (\x -> if length x > 5 then [] else length x : x) [0 :: Int]+ @?= ([0] :| [[1, 0], [2, 1, 0], [3, 2, 1, 0], [4, 3, 2, 1, 0], [5, 4, 3, 2, 1, 0]])+ , testCase "iterateT1" $+ iterateT1 (\(x, y) -> (if length x > 5 then [] else length x : x, Just y)) ([0 :: Int], 1 :: Int)+ @?= (([0], 1) :| [([1, 0], 1), ([2, 1, 0], 1), ([3, 2, 1, 0], 1), ([4, 3, 2, 1, 0], 1), ([5, 4, 3, 2, 1, 0], 1)])+ , testCase "takeWhileTS" $+ takeWhileTS (\b a -> (b + 1, Just (b, a))) (100 :: Int) "abcdef"+ @?= (106, [(100, 'a'), (101, 'b'), (102, 'c'), (103, 'd'), (104, 'e'), (105, 'f')])+ , testCase "takeWhileT" $+ takeWhileT (\a -> if a > 'f' then Nothing else Just (a, ord a)) ['a' .. 'm']+ @?= [('a', 97), ('b', 98), ('c', 99), ('d', 100), ('e', 101), ('f', 102)]+ , testCase "takeWhileT simpler" $+ takeWhileT (boolMaybe (<= 'f') (id &&& ord)) ['a' .. 'm']+ @?= [('a', 97), ('b', 98), ('c', 99), ('d', 100), ('e', 101), ('f', 102)]+ , testCase "filterT" $+ filterT (\a -> if even a then Nothing else Just (show a)) [1 :: Int .. 10]+ @?= ["1", "3", "5", "7", "9"]+ , testCase "filterT simpler" $+ filterT (boolMaybe odd show) [1 :: Int .. 10]+ @?= ["1", "3", "5", "7", "9"]+ , testCase "filterT" $+ filterT (\a -> replicate (7 - a) 'x') [1 :: Int .. 10]+ @?= ["xxxxxx", "xxxxx", "xxxx", "xxx", "xx", "x"]+ , testCase "takeWhileT" $+ takeWhileT (\a -> if even a then Nothing else Just (a, a + 1)) [1 :: Int .. 10]+ @?= [(1, 2)]+ , testCase "takeWhileT" $+ takeWhileT (\a -> if a == 5 then Nothing else Just (show a)) [1 :: Int .. 10]+ @?= ["1", "2", "3", "4"]+ , testCase "takeWhileT" $+ takeWhileT (\a -> replicate (7 - a) 'x') [1 :: Int .. 10]+ @?= ["xxxxxx", "xxxxx", "xxxx", "xxx", "xx", "x"]+ , testCase "partitionEithersT" $+ partitionEithersT (\a -> if odd a then Just (show a) else Nothing) [1 .. 10 :: Int]+ @?= ([2, 4, 6, 8, 10], ["1", "3", "5", "7", "9"])+ , testCase "partitionEithersT" $+ partitionEithersT (\a -> if odd a then Right (show a) else Left a) [1 .. 10 :: Int]+ @?= ([2, 4, 6, 8, 10], ["1", "3", "5", "7", "9"])+ , testCase "partitionEithersT" $+ partitionEithersT (\a -> replicate (7 - a) 'x') [1 .. 10 :: Int]+ @?= ([7, 8, 9, 10], ["xxxxxx", "xxxxx", "xxxx", "xxx", "xx", "x"])+ , testCase "toTheseT warped" $+ toTheseT+ ( \a ->+ let w = chr (a + 50)+ in if even a+ then That w+ else+ if a > 4+ then These ("These=" ++ show a) w+ else This ("This=" ++ show a)+ )+ [1 .. 10 :: Int]+ @?= [ This "This=1"+ , That '4'+ , This "This=3"+ , That '6'+ , These "These=5" '7'+ , That '8'+ , These "These=7" '9'+ , That ':'+ , These "These=9" ';'+ , That '<'+ ]+ , testCase "toTheseT ok" $+ toTheseT+ ( \a ->+ let w = chr (a + 50)+ in if even a+ then if a > 4 then These ("These=" ++ show a) w else That w+ else This ("This=" ++ show a)+ )+ [1 .. 10 :: Int]+ @?= [This "This=1", That '4', This "This=3", That '6', This "This=5", These "These=6" '8', This "This=7", These "These=8" ':', This "This=9", These "These=10" '<']+ , testCase "toTheseT boolThese simpler" $ -- not the same as the above as "That" should not be opposite of "These"!!+ toTheseT (boolThese even (> 4) (chr . (+ 50)) show) [1 .. 10]+ @?= [This '3', That "2", This '5', That "4", This '7', These '8' "6", This '9', These ':' "8", This ';', These '<' "10"]+ , testCase "unfoldrT" $+ unfoldrT (splitAt 2) [1 :: Int .. 8]+ @?= [[1, 2], [3, 4], [5, 6], [7, 8]]+ , testCase "unfoldrT" $+ unfoldrT (splitAt 2) [1 :: Int .. 7]+ @?= [[1, 2], [3, 4], [5, 6], [7]]+ , testCase "unfoldrT" $+ unfoldrT (splitAt 2) [1 :: Int]+ @?= [[1]]+ , testCase "unfoldrT" $+ unfoldrT (splitAt 2) ([] :: [Int])+ @?= []+ , testCase "unfoldrT" $+ unfoldrT (first sum . splitAt 3) [1 :: Int .. 10]+ @?= [6, 15, 24, 10]+ , testCase "iterateT1" $+ iterateT1 succSafe LT+ @?= (LT :| [EQ, GT])+ , testCase "iterateT1" $+ iterateT1 succSafe GT+ @?= (GT :| [])+ , testCase "iterateT1" $+ iterateT1 predSafe GT+ @?= (GT :| [EQ, LT])+ , testCase "spanT" $+ spanT (\x -> SG.Arg (if x > 3 then "" else "xx" :: String) (x, x * 1000)) [1 .. 5 :: Int]+ @?= (+ [ SG.Arg "xx" (1, 1000)+ , SG.Arg "xx" (2, 2000)+ , SG.Arg "xx" (3, 3000)+ ]+ , [4, 5]+ )+ , testCase "takeWhileT" $+ takeWhileT (\x -> SG.Arg (if x > 3 then "" else "xx" :: String) (x, x * 1000)) [1 .. 5 :: Int]+ @?= [ SG.Arg "xx" (1, 1000)+ , SG.Arg "xx" (2, 2000)+ , SG.Arg "xx" (3, 3000)+ ]+ , testCase "takeWhileT" $+ takeWhileT (\x -> SG.Arg (if x > 3 then Nothing else Just @String "xx") (x, x * 1000)) [1 .. 5 :: Int]+ @?= [ SG.Arg "xx" (1, 1000)+ , SG.Arg "xx" (2, 2000)+ , SG.Arg "xx" (3, 3000)+ ]+ , testCase "spanT" $+ spanT (\i -> if i < 4 then These "thesedata" (show i) else if i < 8 then That (show i) else This @String "thosedata") [1 :: Int .. 10]+ @?= (["1", "2", "3", "4", "5", "6", "7"], [1, 2, 3, 8, 9, 10])+ , testCase "partitionEithersT" $+ partitionEithersT (\a -> if even a then Left @String "1" else Right (a, True)) [1 :: Int .. 4]+ @?= (+ [ "1"+ , "1"+ ]+ ,+ [+ ( 1+ , True+ )+ ,+ ( 3+ , True+ )+ ]+ )+ , testCase "partitionEithersT" $+ partitionEithersT even [1 :: Int .. 5]+ @?= (+ [ 1+ , 3+ , 5+ ]+ ,+ [ 2+ , 4+ ]+ )+ , testCase "L.span" $+ L.span even [2 :: Int, 4, 6, 8, 9, 11, 13]+ @?= (+ [ 2+ , 4+ , 6+ , 8+ ]+ ,+ [ 9+ , 11+ , 13+ ]+ )+ , testCase "spanT" $+ spanT (\a -> if even a then Just (chr (a + 50)) else Nothing) [2 :: Int, 4, 6, 8, 9, 11, 13]+ @?= ( "468:"+ ,+ [ 9+ , 11+ , 13+ ]+ )+ , testCase "spanT simpler" $+ spanT (boolMaybe even (chr . (+ 50))) [2 :: Int, 4, 6, 8, 9, 11, 13]+ @?= ( "468:"+ ,+ [ 9+ , 11+ , 13+ ]+ )+ , testCase "apThese" $ apThese 'x' (Just @Int 1) @?= That 1+ , testCase "apThese" $ apThese 'x' True @?= That 'x'+ , testCase "apThese" $ apThese 'x' False @?= This 'x'+ , testCase "apThese" $ apThese 'x' (Nothing @Double) @?= This 'x'+ , testCase "partitionEithersT" $+ partitionEithersT (\a -> if even a then Right (chr (a + 50)) else Left (show a ++ "oops")) [1 .. 10]+ @?= (["1oops", "3oops", "5oops", "7oops", "9oops"], "468:<")+ , testCase "toTheseTS" $+ toTheseTS (\z a -> (z + 1, if even a then Right (z, a) else Left (a, z, "oops" :: String))) (100 :: Integer) [2, 4, 6, 7, 8, 9 :: Int]+ @?= ( 106+ ,+ [ That+ ( 100+ , 2+ )+ , That+ ( 101+ , 4+ )+ , That+ ( 102+ , 6+ )+ , This+ ( 7+ , 103+ , "oops"+ )+ , That+ ( 104+ , 8+ )+ , This+ ( 9+ , 105+ , "oops"+ )+ ]+ )+ , testCase "partitionEithersT" $+ partitionEithersT (\a -> if even a then Right (chr (50 + a)) else Left (a, "oops" :: String)) [2, 4, 6, 7, 8, 9 :: Int]+ @?= (+ [+ ( 7+ , "oops"+ )+ ,+ ( 9+ , "oops"+ )+ ]+ , "468:"+ )+ , testCase "spanTS" $+ spanTS (\z a -> (z + 1, if even a then Right (z, chr (50 + a)) else Left (z, a, "oops" :: String))) (100 :: Int) [2, 4, 6, 7, 8, 9 :: Int]+ @?= ( 104+ ,+ (+ [+ ( 100+ , '4'+ )+ ,+ ( 101+ , '6'+ )+ ,+ ( 102+ , '8'+ )+ ]+ ,+ [ 7+ , 8+ , 9+ ]+ )+ )+ , testCase "L.span" $ L.span even [2, 4, 6, 5, 3, 1, 2, 3 :: Int] @?= ([2, 4, 6], [5, 3, 1, 2, 3])+ , testCase "toMaybe" $ toMaybe (Left @String @Int "asdf", Nothing @()) @?= Nothing+ , testCase "toMaybe" $ toMaybe (Right @Double @String "asdf", "" :: String) @?= Nothing+ , testCase "toMaybe" $ toMaybe (Right @() @Int 11, "abc" :: String) @?= Just (11, "abc")+ , testCase "toMaybe" $ toMaybe (Right @() @Int 11) @?= Just 11+ , testCase "toMaybe" $ toMaybe (Just 'x') @?= Just 'x'+ , testCase "toMaybe" $ toMaybe (Nothing @Char) @?= Nothing+ , testCase "toMaybe" $ toMaybe (SG.Arg @String @Int "" 2) @?= Nothing+ , testCase "toMaybe" $ toMaybe (SG.Arg @String @Int "xyz" 2) @?= Just (SG.Arg "xyz" 2)+ , testCase "toMaybe" $ toMaybe (SG.Arg (This @Int @Bool 123) 'x') @?= Nothing+ , testCase "toMaybe" $ toMaybe (SG.Arg (That @Double @Int 123) 'x') @?= Just (SG.Arg 123 'x')+ , testCase "partitionTheseT" $+ partitionTheseT (boolThese even (>= 5) show (chr . (65 +))) [1 :: Int .. 10]+ @?= (+ [ "1"+ , "3"+ , "5"+ , "7"+ , "9"+ ]+ , "CE"+ ,+ [+ ( "6"+ , 'G'+ )+ ,+ ( "8"+ , 'I'+ )+ ,+ ( "10"+ , 'K'+ )+ ]+ )+ , testCase "toTheseT" $+ toTheseT even [1 :: Int .. 10]+ @?= [This 1, That 2, This 3, That 4, This 5, That 6, This 7, That 8, This 9, That 10]+ , testCase "toTheseT'" $+ toTheseT (\a -> if even a then Just (a, show a) else Nothing) [1 :: Int .. 10]+ @?= [This 1, That (2, "2"), This 3, That (4, "4"), This 5, That (6, "6"), This 7, That (8, "8"), This 9, That (10, "10")]+ , testCase "unfoldrT" $+ unfoldrT (\(a, b) -> let (x, y) = splitAt 1 a; (z, w) = splitAt 2 b in ((x, z), (y, w))) ("abc" :: String, [1 :: Int .. 10])+ @?= [+ ( "a"+ ,+ [ 1+ , 2+ ]+ )+ ,+ ( "b"+ ,+ [ 3+ , 4+ ]+ )+ ,+ ( "c"+ ,+ [ 5+ , 6+ ]+ )+ ]+ , testCase "unfoldrT" $+ unfoldrT (pairsT (splitAt 1) (splitAt 2)) ("asdf", [1 :: Int .. 6])+ @?= [("a", [1, 2]), ("s", [3, 4]), ("d", [5, 6])]+ , testCase "spanT" $+ spanT Just [2 :: Int, 4, 6, 1, 3, 5, 2, 3]+ @?= ([2, 4, 6, 1, 3, 5, 2, 3], [])+ , testCase "spanT" $+ spanT (boolThese even (> 4) show (chr . (+ 65))) [2 :: Int, 4, 6, 1, 3, 5, 2, 3]+ @?= ("CEG", [6, 1, 3, 5, 2, 3])+ , testCase "spanT" $+ spanT (boolThese even (< 10) id show) [2, 4 .. 20 :: Int]+ @?= (["2", "4", "6", "8", "10", "12", "14", "16", "18", "20"], [2, 4, 6, 8])+ ]
+ test/TestBool.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module TestBool where++import Data.Char+import Data.These+import Primus.Bool+import Test.Tasty+import Test.Tasty.HUnit++doit :: IO ()+doit = defaultMain suite++suite :: TestTree+suite =+ testGroup+ "TestBool"+ [ testCase "boolThese" $+ map (boolThese even (> 5) show (chr . (+ 66))) [1 :: Int .. 10]+ @?= [ This "1"+ , That 'D'+ , This "3"+ , That 'F'+ , This "5"+ , These "6" 'H'+ , This "7"+ , These "8" 'J'+ , This "9"+ , These "10" 'L'+ ]+ , testCase "boolThese'" $+ map (boolThese' even (> 5) show (chr . (+ 66)) (\_ a -> ("both(" ++ show a ++ ")", chr (a + 50)))) [1 :: Int .. 10]+ @?= [ This "1"+ , That 'D'+ , This "3"+ , That 'F'+ , This "5"+ , These "both(6)" '8'+ , This "7"+ , These "both(8)" ':'+ , This "9"+ , These "both(10)" '<'+ ]+ , testCase "boolEither" $+ map (boolEither even show (chr . (+ 66))) [1 :: Int .. 10]+ @?= [ Left "1"+ , Right 'D'+ , Left "3"+ , Right 'F'+ , Left "5"+ , Right 'H'+ , Left "7"+ , Right 'J'+ , Left "9"+ , Right 'L'+ ]+ , testCase "boolM" $+ boolM even ("odd",) ("even",) (3 :: Int) @?= ("odd" :: String, 3)+ , testCase "boolM" $+ boolM even ("odd",) ("even",) (4 :: Int) @?= ("even" :: String, 4)+ , testCase "boolThese" $+ traverse (boolThese (const True) (< 5) show id) [1 :: Int .. 10]+ @?= These "1234" [1, 2, 3, 4, 5, 6, 7, 8, 9, 10]+ , testCase "boolThese" $+ traverse (boolThese (< 5) (const True) show id) [1 :: Int .. 10]+ @?= This "12345"+ , testCase "boolEither" $+ traverse (boolEither (< 5) show id) [1 :: Int .. 10]+ @?= Left "5"+ , testCase "boolEither" $+ traverse (boolEither (const True) show id) [1 :: Int .. 10]+ @?= Right [1 .. 10]+ , testCase "boolMaybe" $+ traverse (boolMaybe (const True) (chr . (+ 64))) [1 :: Int .. 10]+ @?= Just ['A' .. 'J']+ , testCase "boolThese" $+ map (boolThese even (> 5) show (chr . (+ 65))) [1 :: Int .. 10]+ @?= [This "1", That 'C', This "3", That 'E', This "5", These "6" 'G', This "7", These "8" 'I', This "9", These "10" 'K']+ ]
+ test/TestEnum.hs view
@@ -0,0 +1,387 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module TestEnum where++import Control.Arrow+import Control.Monad+import Data.Int+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as N+import Data.Pos+import Primus.AsMaybe+import Primus.Enum+import Primus.NonEmpty+import Test.Tasty+import Test.Tasty.HUnit++suite :: TestTree+suite =+ testGroup+ "TestEnum"+ [ testCase "enumFrom1" $ take1 _5P (enumFrom1 _5P) @?= (_5P :| [_6P, _7P, _8P, _9P])+ , testCase "enumFrom1R" $ enumFrom1R _5P @?= (_5P :| [_4P, _3P, _2P, _1P])+ , testCase "enumFrom1R" $ enumFrom1R _1P @?= (_1P :| [])+ , testCase "enumTo1" $ enumTo1 _5P @?= (_1P :| [_2P, _3P, _4P, _5P])+ , testCase "enumTo1" $ enumTo1 _1P @?= (_1P :| [])+ , testCase "enumTo1" $ enumTo1 EQ @?= (LT :| [EQ])+ , testCase "enumTo1" $ enumTo1 LT @?= (LT :| [])+ , testCase "enumTo1" $ enumTo1 GT @?= (LT :| [EQ, GT])+ , testCase "enumFromThen1" $ take1 _5P (enumFromThen1 _5P _11P) @?= (_5P :| [_11P, _17P, _P @23, _P @29])+ , testCase "enumFromThen1" $ enumFromThen1 _15P _10P @?= (_15P :| [_10P, _5P])+ , testCase "enumFromThen1" $ enumFromThen1 _5P _5P @?= (_5P :| [])+ , testCase "enumFromThen1" $ enumFromThen1 LT LT @?= (LT :| [])+ , testCase "enumFromThen1" $ enumFromThen1 LT GT @?= (LT :| [GT])+ , testCase "enumFromThen1" $ enumFromThen1 GT LT @?= (GT :| [LT])+ , testCase "enumFromThen1" $ enumFromThen1 GT EQ @?= (GT :| [EQ, LT])+ , testCase "enumFromTo1" $ enumFromTo1 _5P _9P @?= (_5P :| [_6P, _7P, _8P, _9P])+ , testCase "enumFromTo1" $ enumFromTo1 _9P _5P @?= (_9P :| [_8P, _7P, _6P, _5P])+ , testCase "enumFromTo1" $ enumFromTo1 _5P _5P @?= (_5P :| [])+ , testCase "enumFromTo1" $ enumFromTo1 LT LT @?= (LT :| [])+ , testCase "enumFromTo1" $ enumFromTo1 LT GT @?= (LT :| [EQ, GT])+ , testCase "enumFromTo1" $ enumFromTo1 GT LT @?= (GT :| [EQ, LT])+ , testCase "enumFromTo1" $ enumFromTo1 GT EQ @?= (GT :| [EQ])+ , testCase "universe1" $ universe1 @?= (LT :| [EQ, GT])+ , testCase "universe1R" $ universe1R @?= (GT :| [EQ, LT])+ , testCase "universe1R" $ universe1R @?= (GT :| [EQ, LT])+ , testCase "enumTo1" $ enumTo1 _4P @?= (_1P :| [_2P, _3P, _4P])+ , testCase "enumFrom1" $ enumFrom1 EQ @?= (EQ :| [GT])+ , testCase "enumFrom1" $ enumFrom1 GT @?= (GT :| [])+ , testCase "enumFrom1R" $ enumFrom1R LT @?= (LT :| [])+ , testCase "enumFrom1R" $ enumFrom1R EQ @?= (EQ :| [LT])+ , testCase "enumFrom1R" $ enumFrom1R GT @?= (GT :| [EQ, LT])+ , testCase "toEnumTraversable" $ toEnumTraversable @Ordering (Just ()) 0 @?= Right (Just LT)+ , testCase "toEnumTraversable" $ toEnumTraversable @Ordering (Just ()) 2 @?= Right (Just GT)+ , testCase "toEnumTraversable" $ toEnumTraversable @Ordering (Just ()) 10 @?= Left "cap=(0,2):padL: negative fill: would need to truncate the data"+ , testCase "toEnumTraversable" $ toEnumTraversable @Ordering (replicate 5 ()) 242 @?= Right [GT, GT, GT, GT, GT]+ , testCase "toEnumTraversable" $ toEnumTraversable @Ordering (replicate 5 ()) 243 @?= Left "cap=(0,242):padL: negative fill: would need to truncate the data"+ , testCase "toEnumTraversable" $ toEnumTraversable @Ordering (replicate 5 ()) 0 @?= Right [LT, LT, LT, LT, LT]+ , testCase "toEnumTraversable" $ toEnumTraversable @Ordering (replicate 5 ()) (-1) @?= Left "calcNextEnum:not defined for negative numbers"+ , testCase "toEnumTraversable" $ toEnumTraversable @Ordering (replicate 5 ()) (-123) @?= Left "calcNextEnum:not defined for negative numbers"+ , testCase "toEnumList" $ toEnumList @Ordering 14 @?= Right [EQ, EQ, GT]+ , testCase "toEnumList" $ toEnumList1 @Ordering 0 @?= Right (LT :| [])+ , testCase "toEnumList" $ toEnumList1 @() 0 @?= Right (() :| [])+ , testCase "enumlist" $ traverse (fromEnumFoldable <=< toEnumList @PosNeg) [-5 .. 5] @?= Right [-5 .. 5]+ , testCase "enumlist" $ map (toEnumList @PosOnly) [-5 .. -1] @?= replicate 5 (Left "calcNextEnum:not defined for negative numbers")+ , testCase "enumlist" $ toEnumList @PosOnly 0 @?= Left "zerolr: not defined at zero"+ , testCase "enumlist" $ toEnumList @PosOnly 1 @?= Right [AA1]+ , testCase "enumlist" $ toEnumList @PosOnly 2 @?= Right [BB1]+ , testCase "enumlist" $ toEnumList @PosOnly 3 @?= Right [CC1]+ , testCase "enumlist" $ left (const ()) (toEnumList @PosOnly 4) @?= Left ()+ , testCase "enumlist" $ toEnumList @PosOnly 5 @?= Right [AA1, AA1]+ , testCase "enumlist" $ toEnumList @PosOnly 6 @?= Right [AA1, BB1]+ , testCase "enumlist" $ toEnumList @PosOnly 7 @?= Right [AA1, CC1]+ , testCase "enumlist" $ left (const ()) (toEnumList @PosOnly 8) @?= Left ()+ , testCase "enumlist" $ toEnumList @PosOnly2 0 @?= Left "zerolr: not defined at zero"+ , testCase "enumlist" $ left (const ()) (toEnumList @PosOnly2 1) @?= Left ()+ , testCase "enumlist" $ toEnumList @PosOnly2 2 @?= Right [AA5]+ , testCase "enumlist" $ toEnumList @PosOnly2 123 @?= Right [CC5, CC5, BB5]+ , testCase "enumlist" $ map (toEnumList @NegOnly) [1 .. 5] @?= replicate 5 (Left "calcNextEnum:not defined for positive numbers")+ , testCase "enumlist" $ toEnumList @NegOnly 0 @?= Left "zerolr: not defined at zero"+ , testCase "enumlist" $ toEnumList @NegOnly (-1) @?= Right [CC4]+ , testCase "enumlist" $ toEnumList @NegOnly (-2) @?= Right [BB4]+ , testCase "enumlist" $ toEnumList @NegOnly (-3) @?= Right [AA4]+ , testCase "enumlist" $ left (const ()) (toEnumList @NegOnly (-4)) @?= Left ()+ , testCase "enumlist" $ toEnumList @NegOnly (-5) @?= Right [CC4, CC4]+ , testCase "enumlist" $ toEnumList @NegOnly (-6) @?= Right [CC4, BB4]+ , testCase "enumlist" $ toEnumList @NegOnly (-7) @?= Right [CC4, AA4]+ , testCase "enumlist" $ left (const ()) (toEnumList @NegOnly (-8)) @?= Left ()+ , testCase "enumlist" $ map (toEnumList @PosNat) [-5 .. -1] @?= replicate 5 (Left "calcNextEnum:not defined for negative numbers")+ , testCase "enumlist" $ toEnumList @PosNat 0 @?= Right []+ , testCase "enumlist" $ toEnumList @PosNat 1 @?= Right [BB2]+ , testCase "enumlist" $ toEnumList @PosNat 2 @?= Right [CC2]+ , testCase "enumlist" $ toEnumList @PosNat 3 @?= Right [DD2]+ , testCase "enumlist" $ toEnumList @PosNat 4 @?= Right [BB2, AA2]+ , testCase "enumlist" $ toEnumList @PosNat 5 @?= Right [BB2, BB2]+ , testCase "enumlist" $ map (toEnumList @NegNat) [1 .. 5] @?= replicate 5 (Left "calcNextEnum:not defined for positive numbers")+ , testCase "enumlist" $ toEnumList @NegNat 0 @?= Right []+ , testCase "enumlist" $ toEnumList @NegNat (-1) @?= Right [CC3]+ , testCase "enumlist" $ toEnumList @NegNat (-2) @?= Right [BB3]+ , testCase "enumlist" $ toEnumList @NegNat (-3) @?= Right [AA3]+ , testCase "enumlist" $ toEnumList @NegNat (-4) @?= Right [CC3, DD3]+ , testCase "enumlist" $ toEnumList @NegNat (-5) @?= Right [CC3, CC3]+ , testCase "enumlist" $ toEnumList @NegNat (-6) @?= Right [CC3, BB3]+ , testCase "enumlist" $ toEnumList @NegNat (-7) @?= Right [CC3, AA3]+ , testCase "enumlist" $ toEnumList @NegNat (-8) @?= Right [BB3, DD3]+ , testCase "enumlist" $ toEnumList 100 @?= Right [True, True, False, False, True, False, False]+ , testCase "enumlist1" $ toEnumList1 100 @?= Right (True :| [True, False, False, True, False, False])+ , testCase "fromenum" $ fromEnumFoldable @PosOnly [] @?= Left "zerolr: not defined at zero"+ , testCase "fromenum" $ fromEnumFoldable @NegNat [] @?= Right 0+ , testCase "fromenum" $ fromEnumFoldable @PosNat [] @?= Right 0+ , testCase "fromenum" $ fromEnumFoldable @PosNeg [] @?= Right 0+ , testCase "universe1" $ universe1 @Ordering @?= (LT :| [EQ, GT])+ , testCase "toEnumList" $ toEnumList @Ordering 0 @?= Right []+ , testCase "toEnumList" $ toEnumList @Ordering 1 @?= Right [EQ]+ , testCase "toEnumList" $ toEnumList @Ordering 2 @?= Right [GT]+ , testCase "toEnumList" $ toEnumList @Ordering 3 @?= Right [EQ, LT]+ , testCase "toEnumList" $ toEnumList @Ordering 10 @?= Right [EQ, LT, EQ]+ , testCase "toEnumList" $ toEnumList @Ordering 200 @?= Right [GT, EQ, EQ, LT, GT]+ , testCase "toEnumList1" $ toEnumList1 @Ordering 200 @?= Right (GT :| [EQ, EQ, LT, GT])+ , testCase "toEnumList1" $ toEnumList1 @Ordering 0 @?= Right (LT :| [])+ , testCase "toEnumList1" $ toEnumList1 @Ordering 1 @?= Right (EQ :| [])+ , testCase "toEnumList1" $ toEnumList1 @Ordering 100 @?= Right (EQ :| [LT, GT, LT, EQ])+ , testCase "toEnumList1" $ toEnumList1 @Ordering 27 @?= Right (EQ :| [LT, LT, LT])+ , testCase "succ pred traversable" $ iterateT1 succTraversable [LT, LT, LT] @?= N.reverse (iterateT1 predTraversable [GT, GT, GT])+ , testCase "succ traversable" $+ iterateT1 succTraversable [LT, LT, LT]+ @?= ( [LT, LT, LT]+ :| [ [LT, LT, EQ]+ , [LT, LT, GT]+ , [LT, EQ, LT]+ , [LT, EQ, EQ]+ , [LT, EQ, GT]+ , [LT, GT, LT]+ , [LT, GT, EQ]+ , [LT, GT, GT]+ , [EQ, LT, LT]+ , [EQ, LT, EQ]+ , [EQ, LT, GT]+ , [EQ, EQ, LT]+ , [EQ, EQ, EQ]+ , [EQ, EQ, GT]+ , [EQ, GT, LT]+ , [EQ, GT, EQ]+ , [EQ, GT, GT]+ , [GT, LT, LT]+ , [GT, LT, EQ]+ , [GT, LT, GT]+ , [GT, EQ, LT]+ , [GT, EQ, EQ]+ , [GT, EQ, GT]+ , [GT, GT, LT]+ , [GT, GT, EQ]+ , [GT, GT, GT]+ ]+ )+ , testCase "predSafe" $+ predSafe LT @?= Nothing+ , testCase "predSafe" $+ predSafe EQ @?= Just LT+ , testCase "predSafe" $+ predSafe GT @?= Just EQ+ , testCase "predSafe" $+ predSafe AA @?= Nothing+ , testCase "predSafe" $+ predSafe BB @?= Just AA+ , testCase "predSafe" $+ predSafe EE @?= Just DD+ , testCase "succSafe" $+ succSafe LT @?= Just EQ+ , testCase "succSafe" $+ succSafe EQ @?= Just GT+ , testCase "succSafe" $+ succSafe GT @?= Nothing+ , testCase "succSafe" $+ succSafe AA @?= Just BB+ , testCase "succSafe" $+ succSafe DD @?= Just EE+ , testCase "succSafe" $+ succSafe EE @?= Nothing+ , testCase "enumFromThen1" $ enumFromThen1 AA AA @?= AA :| []+ , testCase "enumFromThen1" $ enumFromThen1 BB AA @?= BB :| [AA]+ , testCase "enumFromThen1" $ enumFromThen1 BB CC @?= BB :| [CC, DD, EE]+ , testCase "enumFromThen1" $ enumFromThen1 EE CC @?= EE :| [CC, AA]+ , testCase "enumFromTo1" $ enumFromTo1 AA AA @?= AA :| []+ , testCase "enumFromTo1" $ enumFromTo1 BB AA @?= BB :| [AA]+ , testCase "enumFromTo1" $ enumFromTo1 BB EE @?= BB :| [CC, DD, EE]+ , testCase "enumFromTo1" $ enumFromTo1 BB CC @?= BB :| [CC]+ , testCase "enumFromTo1" $ enumFromTo1 EE CC @?= EE :| [DD, CC]+ , testCase "predSafe" $ predSafe _4P @?= Just _3P+ , testCase "universe1" $ universe1 @?= (AA :| [BB, CC, DD, EE])+ , testCase "universe1R" $ universe1R @?= (EE :| [DD, CC, BB, AA])+ , testCase "universe1" $ universe1 @?= (AA3 :| [BB3, CC3, DD3])+ , testCase "universe1R" $ universe1R @?= (DD3 :| [CC3, BB3, AA3])+ , testCase "fromEnumFoldable" $+ fromEnumFoldable (replicate 5 (maxBound @Int8))+ @?= Right 34359738367+ , testCase "fromEnumFoldable" $+ fromEnumFoldable (replicate 5 (minBound @Int8))+ @?= Right (-35723051648)+ , testCase "capacity" $+ capacity @Int8 (replicate 5 ())+ @?= Right (-35723051648, 34359738367)+ , testCase "capacity" $+ capacity @NegOnly []+ @?= Left "capacity: unsupported mx < 0: (-3,-1)"+ , testCase "capacity" $+ capacity @PosOnly ['x']+ @?= Left "capacity: unsupported mn > 0: (1,3)"+ , testCase "universeTraversable" $+ universeTraversable [EQ]+ @?= Right ([LT] :| [[EQ], [GT]])+ , testCase "universeTraversable" $+ universeTraversable [EQ, EQ]+ @?= Right ([LT, LT] :| [[LT, EQ], [LT, GT], [EQ, LT], [EQ, EQ], [EQ, GT], [GT, LT], [GT, EQ], [GT, GT]])+ , testCase "universeTraversable" $+ universeTraversable [EQ, EQ, EQ]+ @?= Right ([LT, LT, LT] :| [[LT, LT, EQ], [LT, LT, GT], [LT, EQ, LT], [LT, EQ, EQ], [LT, EQ, GT], [LT, GT, LT], [LT, GT, EQ], [LT, GT, GT], [EQ, LT, LT], [EQ, LT, EQ], [EQ, LT, GT], [EQ, EQ, LT], [EQ, EQ, EQ], [EQ, EQ, GT], [EQ, GT, LT], [EQ, GT, EQ], [EQ, GT, GT], [GT, LT, LT], [GT, LT, EQ], [GT, LT, GT], [GT, EQ, LT], [GT, EQ, EQ], [GT, EQ, GT], [GT, GT, LT], [GT, GT, EQ], [GT, GT, GT]])+ , testCase "universeTraversable" $+ universeTraversable [(), (), ()]+ @?= Right ([(), (), ()] :| [])+ , testCase "capacity" $+ capacity @PosNeg (replicate 5 ())+ @?= Right (-242, 242)+ , testCase "capacity" $+ capacity @PosNeg (replicate 3 ())+ @?= Right (-26, 26)+ , testCase "universeTraversable" $+ universeTraversable [AA, BB, CC]+ @?= Right ([AA, AA, AA] :| [[AA, AA, BB], [AA, AA, CC], [AA, BB, AA], [AA, BB, BB], [AA, BB, CC], [AA, CC, AA], [AA, CC, BB], [AA, CC, CC], [BB, AA, AA], [BB, AA, BB], [BB, AA, CC], [BB, BB, AA], [BB, BB, BB], [BB, BB, CC], [BB, CC, AA], [BB, CC, BB], [BB, CC, CC], [CC, AA, AA], [CC, AA, BB], [CC, AA, CC], [CC, BB, AA], [CC, BB, BB], [CC, BB, CC], [CC, CC, AA], [CC, CC, BB], [CC, CC, CC], [CC, CC, DD], [CC, CC, EE], [CC, DD, CC], [CC, DD, DD], [CC, DD, EE], [CC, EE, CC], [CC, EE, DD], [CC, EE, EE], [DD, CC, CC], [DD, CC, DD], [DD, CC, EE], [DD, DD, CC], [DD, DD, DD], [DD, DD, EE], [DD, EE, CC], [DD, EE, DD], [DD, EE, EE], [EE, CC, CC], [EE, CC, DD], [EE, CC, EE], [EE, DD, CC], [EE, DD, DD], [EE, DD, EE], [EE, EE, CC], [EE, EE, DD], [EE, EE, EE]])+ , testCase "capacity" $+ capacity @NegNat (replicate 3 ())+ @?= Right (-63, 0)+ , testCase "universeTraversable" $+ universeTraversable [AA3, AA3, AA3]+ @?= Right ([AA3, AA3, AA3] :| [[AA3, AA3, BB3], [AA3, AA3, CC3], [AA3, AA3, DD3], [AA3, BB3, AA3], [AA3, BB3, BB3], [AA3, BB3, CC3], [AA3, BB3, DD3], [AA3, CC3, AA3], [AA3, CC3, BB3], [AA3, CC3, CC3], [AA3, CC3, DD3], [AA3, DD3, AA3], [AA3, DD3, BB3], [AA3, DD3, CC3], [AA3, DD3, DD3], [BB3, AA3, AA3], [BB3, AA3, BB3], [BB3, AA3, CC3], [BB3, AA3, DD3], [BB3, BB3, AA3], [BB3, BB3, BB3], [BB3, BB3, CC3], [BB3, BB3, DD3], [BB3, CC3, AA3], [BB3, CC3, BB3], [BB3, CC3, CC3], [BB3, CC3, DD3], [BB3, DD3, AA3], [BB3, DD3, BB3], [BB3, DD3, CC3], [BB3, DD3, DD3], [CC3, AA3, AA3], [CC3, AA3, BB3], [CC3, AA3, CC3], [CC3, AA3, DD3], [CC3, BB3, AA3], [CC3, BB3, BB3], [CC3, BB3, CC3], [CC3, BB3, DD3], [CC3, CC3, AA3], [CC3, CC3, BB3], [CC3, CC3, CC3], [CC3, CC3, DD3], [CC3, DD3, AA3], [CC3, DD3, BB3], [CC3, DD3, CC3], [CC3, DD3, DD3], [DD3, AA3, AA3], [DD3, AA3, BB3], [DD3, AA3, CC3], [DD3, AA3, DD3], [DD3, BB3, AA3], [DD3, BB3, BB3], [DD3, BB3, CC3], [DD3, BB3, DD3], [DD3, CC3, AA3], [DD3, CC3, BB3], [DD3, CC3, CC3], [DD3, CC3, DD3], [DD3, DD3, AA3], [DD3, DD3, BB3], [DD3, DD3, CC3], [DD3, DD3, DD3]])+ , testCase "fromEnumFoldable1 universeTraversable" $+ let m = universeTraversable [AA3, AA3, AA3]+ z = join $ (traverse . traverse) fromEnumFoldable m+ in z @?= Right (-63 :| [-62 .. 0])+ , testCase "fromEnumFoldable1 universeTraversable" $+ let m = universeTraversable [AA, AA, AA]+ z = join $ (traverse . traverse) fromEnumFoldable m+ in z @?= Right (-26 :| [-25 .. 26])+ , testCase "universeTraversable" $+ universeTraversable ([] :: [Ordering])+ @?= Right ([] :| [])+ , testCase "capacity" $+ capacity @Ordering []+ @?= Right (0, 0)+ , testCase "integerToEnumSafe" $+ integerToEnumSafe @() 1+ @?= Left "integerToEnumSafe:overflow where 1 not in range [0..0]"+ , testCase "integerToEnumSafe" $+ integerToEnumSafe @() 0+ @?= Right ()+ , testCase "integerToEnumSafe" $+ integerToEnumSafe @PosNeg 3+ @?= Left "integerToEnumSafe:overflow where 3 not in range [-2..2]"+ , testCase "integerToEnumSafe" $+ integerToEnumSafe @PosNeg (-3)+ @?= Left "integerToEnumSafe:underflow where -3 not in range [-2..2]"+ , testCase "integerToEnumSafe" $+ integerToEnumSafe @PosNeg (-2)+ @?= Right AA+ , testCase "integerToIntSafe" $+ integerToIntSafe (fromIntegral (minBound :: Int))+ @?= Right (-9223372036854775808)+ , testCase "integerToIntSafe" $+ integerToIntSafe (-1 + fromIntegral (minBound :: Int))+ @?= Left "integerToEnumSafe:underflow where -9223372036854775809 not in range [-9223372036854775808..9223372036854775807]"+ , testCase "integerToIntSafe" $+ integerToIntSafe (fromIntegral (maxBound :: Int))+ @?= Right 9223372036854775807+ , testCase "integerToIntSafe" $+ integerToIntSafe (1 + fromIntegral (maxBound :: Int))+ @?= Left "integerToEnumSafe:overflow where 9223372036854775808 not in range [-9223372036854775808..9223372036854775807]"+ , testCase "universe1" $+ universe1 @() @?= () :| []+ , testCase "universe1R" $+ universe1R @() @?= () :| []+ , testCase "enumFrom1" $+ enumFrom1 @() () @?= () :| []+ , testCase "enumFrom1R" $+ enumFrom1R @() () @?= () :| []+ , testCase "enumFromTo1" $+ enumFromTo1 @() () () @?= () :| []+ , testCase "enumTo1" $+ enumTo1 @() () @?= () :| []+ , testCase "enumFromThen1" $+ enumFromThen1 @() () () @?= () :| []+ , testCase "enumFromThenTo1" $+ enumFromThenTo1 @() () () () @?= () :| []+ , testCase "enumFrom1" $+ enumFrom1 @PosNeg DD @?= DD :| [EE]+ , testCase "enumFrom1R" $+ enumFrom1R @PosNeg DD @?= DD :| [CC, BB, AA]+ , testCase "enumFromTo1" $+ enumFromTo1 @PosNeg DD BB @?= DD :| [CC, BB]+ , testCase "enumTo1" $+ enumTo1 @PosNeg AA @?= AA :| []+ , testCase "enumFromThen1" $+ enumFromThen1 @PosNeg AA CC @?= AA :| [CC, EE]+ , testCase "enumFromThenTo1" $+ enumFromThenTo1 @PosNeg AA AA BB @?= AA :| []+ , testCase "enumFromThenTo1" $+ enumFromThenTo1 @PosNeg EE DD DD @?= EE :| [DD]+ , testCase "enumFromThenTo1" $+ enumFromThenTo1 @PosNeg EE DD BB @?= EE :| [DD, CC, BB]+ ]++data PosNeg = AA | BB | CC | DD | EE deriving stock (Bounded, Show, Eq)+instance Enum PosNeg where+ toEnum (-2) = AA+ toEnum (-1) = BB+ toEnum 0 = CC+ toEnum 1 = DD+ toEnum 2 = EE+ toEnum _ = error "bad toEnum PosNeg"++ fromEnum AA = -2+ fromEnum BB = -1+ fromEnum CC = 0+ fromEnum DD = 1+ fromEnum EE = 2++data PosNat = AA2 | BB2 | CC2 | DD2 deriving stock (Bounded, Show, Eq)+instance Enum PosNat where+ toEnum 0 = AA2+ toEnum 1 = BB2+ toEnum 2 = CC2+ toEnum 3 = DD2+ toEnum _ = error "bad toEnum PosNat"++ fromEnum AA2 = 0+ fromEnum BB2 = 1+ fromEnum CC2 = 2+ fromEnum DD2 = 3++data NegNat = AA3 | BB3 | CC3 | DD3 deriving stock (Bounded, Show, Eq)+instance Enum NegNat where+ toEnum (-3) = AA3+ toEnum (-2) = BB3+ toEnum (-1) = CC3+ toEnum 0 = DD3+ toEnum _ = error "bad toEnum NegNat"++ fromEnum AA3 = -3+ fromEnum BB3 = -2+ fromEnum CC3 = -1+ fromEnum DD3 = 0++data PosOnly = AA1 | BB1 | CC1 deriving stock (Bounded, Show, Eq)+instance Enum PosOnly where+ toEnum 1 = AA1+ toEnum 2 = BB1+ toEnum 3 = CC1+ toEnum _ = error "bad toEnum PosOnly"++ fromEnum AA1 = 1+ fromEnum BB1 = 2+ fromEnum CC1 = 3++data PosOnly2 = AA5 | BB5 | CC5 deriving stock (Bounded, Show, Eq)+instance Enum PosOnly2 where+ toEnum 2 = AA5+ toEnum 3 = BB5+ toEnum 4 = CC5+ toEnum _ = error "bad toEnum PosOnly2"++ fromEnum AA5 = 2+ fromEnum BB5 = 3+ fromEnum CC5 = 4++data NegOnly = AA4 | BB4 | CC4 deriving stock (Bounded, Show, Eq)+instance Enum NegOnly where+ toEnum (-3) = AA4+ toEnum (-2) = BB4+ toEnum (-1) = CC4+ toEnum _ = error "bad toEnum NegOnly"++ fromEnum AA4 = -3+ fromEnum BB4 = -2+ fromEnum CC4 = -1
+ test/TestExtra.hs view
@@ -0,0 +1,17 @@+{-# 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/TestFold.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module TestFold where++import Data.Bool+import Data.Char+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as N+import Data.Ord+import Data.Pos+import Data.These+import Primus.Fold+import Primus.NonEmpty+import Test.Tasty+import Test.Tasty.HUnit++doit :: IO ()+doit = defaultMain suite++suite :: TestTree+suite =+ testGroup+ "TestFold"+ [ testCase "histMapL" $+ histMapL (\ps ft z a -> ((length ft, length ps) : z, show a)) [(999, 998)] [1 .. 5 :: Int]+ @?= ([(0, 4), (1, 3), (2, 2), (3, 1), (4, 0), (999, 998)], ["1", "2", "3", "4", "5"])+ , testCase "histMapL" $+ histMapL (\_ps ft z a -> (ft : z, show a)) [] [1 .. 5 :: Int]+ @?= ([[], [5], [4, 5], [3, 4, 5], [2, 3, 4, 5]], ["1", "2", "3", "4", "5"])+ , testCase "histMapR" $+ histMapR (\_ps ft z a -> (ft : z, show a)) [] [1 .. 5 :: Int]+ @?= ([[], [1], [2, 1], [3, 2, 1], [4, 3, 2, 1]], ["1", "2", "3", "4", "5"])+ , testCase "histMapL" $+ histMapL (\ps ft z a -> (z - 1, (z, toUpper a, ps, ft))) (100 :: Int) ['a' .. 'f']+ @?= (94, [(100, 'A', "", "bcdef"), (99, 'B', "a", "cdef"), (98, 'C', "ba", "def"), (97, 'D', "cba", "ef"), (96, 'E', "dcba", "f"), (95, 'F', "edcba", "")])+ , testCase "histMapR" $+ histMapR (\ps ft z a -> (z - 1, (z, toUpper a, ps, ft))) (100 :: Int) ['a' .. 'f']+ @?= (94, [(95, 'A', "bcdef", ""), (96, 'B', "cdef", "a"), (97, 'C', "def", "ba"), (98, 'D', "ef", "cba"), (99, 'E', "f", "dcba"), (100, 'F', "", "edcba")])+ , testCase "histMapL'" $ histMapL' (\p f a -> (a, p, f)) ['a' .. 'f'] @?= [('a', "", "bcdef"), ('b', "a", "cdef"), ('c', "ba", "def"), ('d', "cba", "ef"), ('e', "dcba", "f"), ('f', "edcba", "")]+ , testCase "fillTraversable" $ fillTraversable [1 :: Int, 2, 3] ("abcdef" :: String) @?= Right ("def", "abc")+ , testCase "fillTraversableExact" $ fillTraversableExact [1 :: Int, 2, 3] ("abc" :: String) @?= Right "abc"+ , testCase "fillTraversableExact" $ fillTraversableExact [1 :: Int, 2, 3] ("abcd" :: String) @?= Left "fillTraversableExact: too many elements found"+ , testCase "wrapL" $ wrapL reverse ("abcdef" :: String) @?= Right "fedcba"+ , testCase "wrapL" $ wrapL (map succ) (Just (123 :: Int)) @?= Right (Just 124)+ , testCase "wrapL" $ wrapL (map succ) (Nothing :: Maybe Int) @?= Right Nothing+ , testCase "padL" $ padL (replicate1 @Int _10P 1) [9999] @?= Right (1 :| [1, 1, 1, 1, 1, 1, 1, 1, 9999])+ , testCase "padR" $ padR (replicate1 @Int _10P 1) [9999] @?= Right (9999 :| [1, 1, 1, 1, 1, 1, 1, 1, 1])+ , testCase "padR" $ padR (replicate1 @Int _1P 4) [9999] @?= Right (9999 :| [])+ , testCase "padR fail" $ padR (replicate1 @Int _1P 4) [9999, 123] @?= Left "padR: negative fill: would need to truncate the data"+ , testCase "padR" $ padR ("a" :: String) [] @?= Right "a"+ , testCase "padR fail" $ padR ("a" :: String) ("bc" :: String) @?= Left "padR: negative fill: would need to truncate the data"+ , testCase "padL fail" $ padL ("a" :: String) ("bc" :: String) @?= Left "padL: negative fill: would need to truncate the data"+ , testCase "padR" $ padR (replicate 5 'a') ("bc" :: String) @?= Right "bcaaa"+ , testCase "padR" $ padR ("aa" :: String) ("bc" :: String) @?= Right "bc"+ , testCase "padR" $ padR [1 .. 10 :: Int] [101 .. 104] @?= Right [101, 102, 103, 104, 5, 6, 7, 8, 9, 10]+ , testCase "padL" $ padL [1 .. 10 :: Int] [101 .. 104] @?= Right [1, 2, 3, 4, 5, 6, 101, 102, 103, 104]+ , testCase "padR" $ padR [1 .. 4 :: Int] [101 .. 104] @?= Right [101, 102, 103, 104]+ , testCase "padL" $ padL (1 :| [2 .. 4 :: Int]) [101 .. 104] @?= Right (101 :| [102, 103, 104])+ , testCase "padR" $ padR (1 :| [2 .. 10 :: Int]) [101 .. 104] @?= Right (101 :| [102, 103, 104, 5, 6, 7, 8, 9, 10])+ , testCase "padL" $ padL (1 :| [2 .. 10 :: Int]) [101 .. 104] @?= Right (1 :| [2, 3, 4, 5, 6, 101, 102, 103, 104])+ , testCase "padR" $ padR (1 :| [2 .. 4 :: Int]) [101 .. 104] @?= Right (101 :| [102, 103, 104])+ , testCase "padL" $ padL (1 :| [2 .. 4 :: Int]) [101 .. 104] @?= Right (101 :| [102, 103, 104])+ , testCase "zipExtrasT" $ zipExtrasT [1 :: Int .. 5] ['a' .. 'f'] @?= [These 1 'a', These 2 'b', These 3 'c', These 4 'd', These 5 'e', That 'f']+ , testCase "zipExtrasT" $ zipExtrasT [1 :: Int .. 5] ['a' .. 'e'] @?= [These 1 'a', These 2 'b', These 3 'c', These 4 'd', These 5 'e']+ , testCase "zipExtrasT" $ zipExtrasT [1 :: Int .. 4] ['a' .. 'e'] @?= [These 1 'a', These 2 'b', These 3 'c', These 4 'd', That 'e']+ , testCase "zipExtrasT" $ zipExtrasT [1 :: Int .. 4] ([] @()) @?= [This 1, This 2, This 3, This 4]+ , testCase "zipExtrasT" $ zipExtrasT ([] @()) [1 :: Int .. 4] @?= [That 1, That 2, That 3, That 4]+ , testCase "compareLength" $ compareLength [1 :: Int .. 5] ("abc" :: String) @?= CGT+ , testCase "compareLength" $ compareLength [1 :: Int .. 5] ("abcde" :: String) @?= CEQ+ , testCase "compareLength" $ compareLength [1 :: Int .. 5] ("abcdefg" :: String) @?= CLT ('f' :| "g")+ , testCase "compareLength" $ compareLength [1 :: Int .. 5] ("" :: String) @?= CGT+ , testCase "compareLength" $ compareLength ([] :: [Int]) ("" :: String) @?= CEQ+ , testCase "compareLength" $ compareLength (These () 'x') ('a' :| "bc") @?= CLT ('b' :| "c")+ , testCase "compareLength" $ compareLength (These True 'x') ('a' :| "") @?= CEQ+ , testCase "compareLength" $+ compareLength ([] :: [Int]) ([] @Char)+ @?= CEQ+ , testCase "compareLength" $+ compareLength ('a' :| ['b' .. 'g']) [100 :: Int .. 104]+ @?= CGT+ , testCase "compareLength" $+ compareLength ('a' :| ['b' .. 'g']) [100 :: Int .. 105]+ @?= CGT+ , testCase "compareLength" $+ compareLength ('a' :| ['b' .. 'g']) [100 :: Int .. 112]+ @?= CLT (107 :| [108, 109, 110, 111, 112])+ , testCase "compareLength" $+ compareLength ('a' :| ['b' .. 'g']) [100 :: Int .. 108]+ @?= CLT (107 :| [108])+ , testCase "compareLength" $+ compareLength ('a' :| ['b' .. 'g']) [100 :: Int .. 106]+ @?= CEQ+ , testCase "compareLengths" $+ compareLengths ([1 :: Int .. 5] :| [[101 .. 110], [201 .. 205], [301 .. 302], [], [1001 .. 1020]])+ @?= [ CLT (106 :| [107, 108, 109, 110])+ , CEQ+ , CGT+ , CGT+ , CLT (1006 :| [1007, 1008, 1009, 1010, 1011, 1012, 1013, 1014, 1015, 1016, 1017, 1018, 1019, 1020])+ ]+ , testCase "compareLengths" $+ compareLengths ([1 :: Int .. 5] :| [[101 .. 110]])+ @?= [CLT (106 :| [107 .. 110])]+ , testCase "compareLengths" $+ compareLengths ([1 :: Int .. 5] :| [])+ @?= []+ , testCase "compareLength infinite lhs" $+ compareLength [1 :: Int ..] ['a' .. 'f']+ @?= CGT+ , testCase "compareLength infinite rhs" $+ case compareLength ['a' .. 'f'] [1 :: Int ..] of+ CLT ns -> N.take 10 ns @?= [7 .. 16]+ o -> assertFailure $ "expected CLT but found " ++ show o+ , testCase "zipWithExact" $+ zipWithExact (,) (1 :| [2 :: Int .. 5]) ['a' .. 'e']+ @?= Right ((1, 'a') :| [(2, 'b'), (3, 'c'), (4, 'd'), (5, 'e')])+ , testCase "zipWithExact" $+ zipWithExact (,) (1 :| [2 :: Int .. 5]) ['a' .. 'f']+ @?= Left "zipWithExact: lhs has less data"+ , testCase "zipWithExact" $+ zipWithExact (,) (1 :| [2 :: Int .. 5]) ['a' .. 'd']+ @?= Left "zipWithExact: lhs has more data"+ , testCase "tailsT" $+ tailsT (1 :| [2 :: Int, 3, 4, 5, 6, 7, 8, 9, 10])+ @?= (1 :| [2, 3, 4, 5, 6, 7, 8, 9, 10])+ :| [ 2 :| [3, 4, 5, 6, 7, 8, 9, 10]+ , 3 :| [4, 5, 6, 7, 8, 9, 10]+ , 4 :| [5, 6, 7, 8, 9, 10]+ , 5 :| [6, 7, 8, 9, 10]+ , 6 :| [7, 8, 9, 10]+ , 7 :| [8, 9, 10]+ , 8 :| [9, 10]+ , 9 :| [10]+ , 10 :| []+ ]+ , testCase "initsT" $+ initsT (1 :| [2 :: Int, 3, 4, 5, 6, 7, 8, 9, 10])+ @?= (1 :| [])+ :| [ 1 :| [2]+ , 1 :| [2, 3]+ , 1 :| [2, 3, 4]+ , 1 :| [2, 3, 4, 5]+ , 1 :| [2, 3, 4, 5, 6]+ , 1 :| [2, 3, 4, 5, 6, 7]+ , 1 :| [2, 3, 4, 5, 6, 7, 8]+ , 1 :| [2, 3, 4, 5, 6, 7, 8, 9]+ , 1 :| [2, 3, 4, 5, 6, 7, 8, 9, 10]+ ]+ , testCase "reverseT" $+ reverseT (1 :| [2 :: Int, 3, 4, 5, 6, 7, 8, 9, 10])+ @?= 10 :| [9, 8, 7, 6, 5, 4, 3, 2, 1]+ , testCase "sortByT" $+ sortByT (comparing (\x -> Down (x `mod` 5, x))) [1 :: Int .. 10]+ @?= [9, 4, 8, 3, 7, 2, 6, 1, 10, 5]+ , testCase "pFoldL" $+ pFoldL (\xs ys z a -> (xs, ys, a) : z) [([77], [88], 999)] [1 :: Int .. 5]+ @?= [ ([4, 3, 2, 1], [], 5)+ , ([3, 2, 1], [5], 4)+ , ([2, 1], [4, 5], 3)+ , ([1], [3, 4, 5], 2)+ , ([], [2, 3, 4, 5], 1)+ , ([77], [88], 999)+ ]+ , testCase "pFoldR" $+ pFoldR (\xs ys z a -> (xs, ys, a) : z) [([77], [88], 999)] [1 :: Int .. 5]+ @?= [ ([], [2, 3, 4, 5], 1)+ , ([1], [3, 4, 5], 2)+ , ([2, 1], [4, 5], 3)+ , ([3, 2, 1], [5], 4)+ , ([4, 3, 2, 1], [], 5)+ , ([77], [88], 999)+ ]+ , testCase "pFoldL" $+ pFoldL (\as bs b a -> (as, bs, a) : b) [] [1 :: Int .. 4]+ @?= [([3, 2, 1], [], 4), ([2, 1], [4], 3), ([1], [3, 4], 2), ([], [2, 3, 4], 1)]+ , testCase "pFoldR" $+ pFoldR (\as bs b a -> (as, bs, a) : b) [] [1 :: Int .. 4]+ @?= [([], [2, 3, 4], 1), ([1], [3, 4], 2), ([2, 1], [4], 3), ([3, 2, 1], [], 4)]+ , testCase "unfoldl" $+ unfoldl (\s -> if null s then Nothing else Just (splitAt 2 s)) "abcdef"+ @?= ["ef", "cd", "ab"]+ , testCase "unfoldl" $+ unfoldl (\s -> if null s then Nothing else Just (splitAt 2 s)) ""+ @?= []+ , testCase "unfoldrM" $+ unfoldrM (\s -> Right @() (if null s then Nothing else Just (splitAt 2 s))) ("" :: String)+ @?= Right []+ , testCase "unfoldlM" $+ unfoldlM (\s -> Right @() (if null s then Nothing else Just (splitAt 2 s))) "abcdefg"+ @?= Right ["g", "ef", "cd", "ab"]+ , testCase "unfoldrM" $+ unfoldrM (\s -> Right @() (if null s then Nothing else Just (splitAt 2 s))) "abcdefg"+ @?= Right ["ab", "cd", "ef", "g"]+ , testCase "unfoldrM" $+ unfoldrM (\s -> if length s == 4 then Left ("xx" :: String) else Right (if null s then Nothing else Just (splitAt 2 s))) "abcd"+ @?= Left "xx"+ , testCase "unfoldrM" $+ unfoldrM (\s -> if length s == 3 then Left ("xx" :: String) else Right (if null s then Nothing else Just (splitAt 2 s))) "abcdefg"+ @?= Left "xx"+ , testCase "unfoldlM" $+ unfoldlM (\s -> if null s then [Nothing] else [Just $ splitAt 3 s, Just $ splitAt 5 s]) [1 :: Int .. 10]+ @?= [ [[10], [7, 8, 9], [4, 5, 6], [1, 2, 3]]+ , [[10], [7, 8, 9], [4, 5, 6], [1, 2, 3]]+ , [[7, 8, 9, 10], [4, 5, 6], [1, 2, 3]]+ , [[9, 10], [4, 5, 6, 7, 8], [1, 2, 3]]+ , [[9, 10], [4, 5, 6, 7, 8], [1, 2, 3]]+ , [[9, 10], [6, 7, 8], [1, 2, 3, 4, 5]]+ , [[9, 10], [6, 7, 8], [1, 2, 3, 4, 5]]+ , [[6, 7, 8, 9, 10], [1, 2, 3, 4, 5]]+ ]+ , testCase "unfoldrM" $+ unfoldrM (\s -> if null s then [Nothing] else [Just $ splitAt 3 s, Just $ splitAt 5 s]) [1 :: Int .. 10]+ @?= [ [[1, 2, 3], [4, 5, 6], [7, 8, 9], [10]]+ , [[1, 2, 3], [4, 5, 6], [7, 8, 9], [10]]+ , [[1, 2, 3], [4, 5, 6], [7, 8, 9, 10]]+ , [[1, 2, 3], [4, 5, 6, 7, 8], [9, 10]]+ , [[1, 2, 3], [4, 5, 6, 7, 8], [9, 10]]+ , [[1, 2, 3, 4, 5], [6, 7, 8], [9, 10]]+ , [[1, 2, 3, 4, 5], [6, 7, 8], [9, 10]]+ , [[1, 2, 3, 4, 5], [6, 7, 8, 9, 10]]+ ]+ , testCase "unfoldlM" $+ unfoldlM (\s -> if null s then [Nothing] else map Just [splitAt 2 s, splitAt 3 s]) "abcdef"+ @?= [ ["ef", "cd", "ab"]+ , ["ef", "cd", "ab"]+ , ["f", "cde", "ab"]+ , ["f", "cde", "ab"]+ , ["f", "de", "abc"]+ , ["f", "de", "abc"]+ , ["def", "abc"]+ ]+ , testCase "unfoldrM" $+ unfoldrM (\s -> if null s then [Nothing] else map Just [splitAt 2 s, splitAt 3 s]) "abcdef"+ @?= [ ["ab", "cd", "ef"]+ , ["ab", "cd", "ef"]+ , ["ab", "cde", "f"]+ , ["ab", "cde", "f"]+ , ["abc", "de", "f"]+ , ["abc", "de", "f"]+ , ["abc", "def"]+ ]+ , testCase "unfoldrM1" $+ unfoldrM1 (\s -> let (a, b) = splitAt 3 s; (c, d) = splitAt 5 s in bool [(a, Just b)] [(a, Nothing)] (null b) <> bool [(c, Just d)] [(c, Nothing)] (null d)) "abcdefghi"+ @?= [ "abc" :| ["def", "ghi"]+ , "abc" :| ["def", "ghi"]+ , "abc" :| ["defgh", "i"]+ , "abc" :| ["defgh", "i"]+ , "abcde" :| ["fgh", "i"]+ , "abcde" :| ["fgh", "i"]+ , "abcde" :| ["fghi"]+ ]+ , testCase "unfoldrM" $+ unfoldrM (\s -> if null s then [Nothing] else map Just [splitAt 3 s, splitAt 5 s]) "abcdefghi"+ @?= [ ["abc", "def", "ghi"]+ , ["abc", "def", "ghi"]+ , ["abc", "defgh", "i"]+ , ["abc", "defgh", "i"]+ , ["abcde", "fgh", "i"]+ , ["abcde", "fgh", "i"]+ , ["abcde", "fghi"]+ ]+ ]
+ test/TestLRHist.hs view
@@ -0,0 +1,371 @@+{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module TestLRHist where++import Control.Monad+import Data.Char+import Data.Foldable+import Data.Functor+import qualified Data.Monoid as MM+import Data.Proxy+import Data.These+import Primus.LRHist+import qualified Primus.TypeLevel as TP+import Test.QuickCheck+import Test.QuickCheck.Checkers+import "checkers" Test.QuickCheck.Classes+import Test.Tasty+import Test.Tasty.HUnit+import qualified Test.Tasty.QuickCheck as TQ++argsVerbose :: Args+argsVerbose = stdArgs{maxSuccess = 500, chatty = True}++doit :: IO ()+doit = defaultMain suite++instance (LRHistArbC as e a, Arbitrary a, Arbitrary e) => Arbitrary (LRHist as e a) where+ arbitrary = lrhistArbC++class LRHistArbC as e a where+ lrhistArbC :: (Arbitrary a, Arbitrary e) => Gen (LRHist as e a)+instance LRHistArbC '[] e a where+ lrhistArbC = Rhi <$> arbitrary+instance (Arbitrary a', LRHistArbC as e a') => LRHistArbC (a' ': as) e a where+ lrhistArbC = do+ x <- lrhistArbC @as @e @a'+ case x of+ LhSkip{} -> pure $ LhSkip x+ Lh{} -> pure $ LhSkip x+ Rhi{} -> oneof [flip Rh x <$> arbitrary, flip Lh x <$> arbitrary]+ Rh{} -> oneof [flip Rh x <$> arbitrary, flip Lh x <$> arbitrary]++instance (TP.ApplyConstraint Eq as, Eq e, Eq a) => EqProp (LRHist as e a) where (=-=) = eq++testLawsLRHist0 :: [TestBatch]+testLawsLRHist0 =+ [functor z, monoid z, semigroup (z, Fixed (10 :: Int)), foldable z1] -- , traversable z] -- 9.2 issues+ where+ z = undefined :: LRHist '[] String (MM.Sum Integer, String, MM.Sum Int)+ z1 = undefined :: LRHist '[] String (String, Integer, String, Int, Bool)++testLawsLRHist1 :: [TestBatch]+testLawsLRHist1 =+ [functor z, monoid z, semigroup (z, Fixed (10 :: Int)), foldable z1] -- , traversable z]+ where+ z = undefined :: LRHist '[MM.Sum Int, String] String (MM.Sum Integer, String, MM.Sum Int)+ z1 = undefined :: LRHist '[MM.Sum Int, String] String (String, Integer, String, Int, Bool)++testLawsLRHistIO :: IO ()+testLawsLRHistIO = do+ traverse_ verboseBatch testLawsLRHist0+ traverse_ verboseBatch testLawsLRHist1++suite :: TestTree+suite =+ testGroup+ "TestLRHist"+ [ testCase "lhToEither" $ lhToEither (appLR Left (appLR Right (Rhi 'x'))) @?= Left @_ @String 'x'+ , testCase "lhToEither" $ lhToEither (appLR Right (appLR Right (appLR (const (Left "xx")) (Rhi 'x')))) @?= Left @String @() "xx"+ , testCase "lhToEither" $ lhToEither (appLR Right (appLR Right (appLR Right (Rhi 'x')))) @?= Right @String 'x'+ , testCase "lhToEither" $ lhToEither (appLR (Right . show) (appLR Right (appLR Right (Rhi 'x')))) @?= Right @String "'x'"+ , testCase "lhToEither" $ lhToEither (appLR Left (Rhi 'x')) @?= Left @_ @String 'x'+ , testCase "lhToEither" $ lhToEither (Rhi 'x') @?= Right @() 'x'+ , testCase "validateLRHist" $ validateLRHist (LhSkip (Rhi ())) @?= Left "LhSkip cannot wrap Rhi"+ , testCase "validateLRHist" $ validateLRHist (Lh () (Rhi ())) @?= Right ()+ , testCase "validateLRHist" $ validateLRHist (Lh () (Rh () (Rhi ()))) @?= Right ()+ , testCase "validateLRHist" $ validateLRHist (Rh () (Lh () (Rhi ()))) @?= Left "Rh cannot wrap Lh"+ , testCase "read" $ readsPrec @(LRHist '[Bool] String Char) 1 (show (Rh 'x' (Rhi @_ @String True))) @?= [(Rh 'x' (Rhi True), "")]+ , testCase "read" $ readsPrec @(LRHist '[Double, Bool] String Char) 1 (show (LhSkip @_ @_ @_ @Double $ Lh @_ @_ @_ @Int "ogre" (Rhi @_ @String True))) @?= [(LhSkip (Lh "ogre" (Rhi @_ @String True)), "")]+ , testCase "read dsl" $ readsPrec @(LRHist '[Double, Bool] String Char) 1 (show (snd (lhskip @Double $ lh @Int "ogre" (rhi @String True)))) @?= [(LhSkip (Lh "ogre" (Rhi @_ @String True)), "")]+ , testCase "read" $ readsPrec @(LRHist '[Bool] String Char) 1 (show (Lh @_ @_ @_ @Int "ogre" (Rhi @_ @String True))) @?= [(Lh "ogre" (Rhi True), "")]+ , testCase "read dsl" $ readsPrec @(LRHist '[Bool] String Char) 1 (show (snd (lh @Int "ogre" (rhi @String True)))) @?= [(Lh "ogre" (Rhi True), "")]+ , testCase "dsl" $ lhskip @() (lh @Int "ogre" (rhi @String True)) @?= (Proxy, LhSkip (Lh "ogre" (Rhi True)))+ , testCase "dsl" $ (lhskip @() $ lh @Int "ogre" $ rh True $ rhi @String True) @?= (Proxy, LhSkip (Lh "ogre" (Rh True (Rhi True))))+ , testCase "dsl" $ (lhskip @() $ lh @Int "ogre" $ rhi @String True) @?= (Proxy, LhSkip (Lh "ogre" (Rhi True)))+ , testCase "dsl" $ snd (lhskip @() (lh @Int "hello" (rhi @String ()))) @?= LhSkip (Lh "hello" (Rhi ()))+ , testCase "dsl" $ snd (lhskip @Double (lhskip @() (lh @Int "hello" (rhi @String ())))) @?= LhSkip (LhSkip (Lh "hello" (Rhi ())))+ , testCase "dsl" $ snd (lhskip @Double (lhskip @Bool (lh @Int "hello" (rh 'x' (rhi @String ()))))) @?= LhSkip (LhSkip (Lh "hello" (Rh 'x' (Rhi ()))))+ , testCase "validateLRHist" $ validateLRHist (snd (lhskip (lhskip (lh @_ @String "xx" (rhi 'x'))))) @?= Right ()+ , testCase "dsl" $ snd (lhskip (lhskip (lh @_ @String "xx" (rhi 'x')))) @?= (LhSkip (LhSkip (Lh "xx" (Rhi 'x'))) :: LRHist '[Double, Bool, Char] String ())+ , testCase "read" $+ let x :: LRHist '[Bool, Char, Int] String ()+ x = LhSkip (LhSkip (Lh "xx" (Rhi 3)))+ in read (show x) @?= x+ , testCase "read" $+ let x :: LRHist '[Bool, Char, Float, Int] String ()+ x = LhSkip (LhSkip (Lh "xx" (Rh 1.2 (Rhi 3))))+ in read (show x) @?= x+ , testCase "read" $+ let x :: LRHist '[Char, Float, Int] String Bool+ x = Rh False (Rh 'x' (Rh 1.2 (Rhi 3)))+ in read (show x) @?= x+ , testCase "read" $+ let x :: LRHist '[Bool, Char, Float, Int] String ()+ x = Lh "yy" (Lh "xx" (Rh 'x' (Rh 1.2 (Rhi 3)))) -- even though fundamentally flawed+ in read (show x) @?= x+ , testCase "read" $ read @(LRHist '[Int] String Bool) (show (snd (lh @() "adf" $ rhi @String @Int 1))) @?= Lh "adf" (Rhi 1)+ , testCase "validateLRHist" $+ let x :: LRHist '[Bool, Char, Float, Int] String ()+ x = Lh "yy" (Lh "xx" (Rh 'x' (Rh 1.2 (Rhi 3))))+ in validateLRHist x @?= Left "Lh cannot wrap Lh"+ , testCase "lhToEither" $+ map lhToEither zz2+ @?= [ Left "ab"+ , Right (This 'H')+ , Left "dude"+ , Right (That 50)+ ]+ , testCase "lhToEitherI" $+ map lhToEitherI zz2+ @?= [ Left "ab"+ , Right (This 'H', (72, (2, ('y', (True, ())))))+ , Left "dude"+ , Right (That 50, (50, (299, ('a', (False, ())))))+ ]+ , testCase "lhToEitherTuples" $+ map lhToEitherTuples zz2+ @?= [ Left "ab"+ , Right (This 'H', 72, 2, 'y', True)+ , Left "dude"+ , Right (That 50, 50, 299, 'a', False)+ ]+ , testCase "lhToEitherTuples appLR" $+ (zz1 <&> lhToEitherTuples . appLR (> 50))+ @?= [ Left "ab"+ , Right (72, 72, 2, 'y', True)+ , Right (71, 71, 299, 'a', False)+ , Left ""+ ]+ , testCase "lhToEitherTuples appLR" $+ (zz1 <&> lhToEitherTuples . appLR (\a -> if a > 50 then Just (chr a) else Nothing))+ @?= [ Left "ab"+ , Right ('H', 72, 2, 'y', True)+ , Right ('G', 71, 299, 'a', False)+ , Left ""+ ]+ , testCase "appLR" $+ map (appLR @String (\a -> if even a then Right (chr (a + 50)) else Left ("oops:" ++ show a)) . Rhi) [1 :: Int .. 6]+ @?= [ Lh "oops:1" (Rhi 1)+ , Rh '4' (Rhi 2)+ , Lh "oops:3" (Rhi 3)+ , Rh '6' (Rhi 4)+ , Lh "oops:5" (Rhi 5)+ , Rh '8' (Rhi 6)+ ]+ , testCase "appLR" $+ map (appLR even . Rhi) [1 :: Int .. 5]+ @?= [ Lh+ ()+ (Rhi 1)+ , Rh+ 2+ (Rhi 2)+ , Lh+ ()+ (Rhi 3)+ , Rh+ 4+ (Rhi 4)+ , Lh+ ()+ (Rhi 5)+ ]+ , testCase "appLR" $+ map (appLR (\a -> if a <= 3 then Nothing else Just (chr (a + 50))) . appLR even . Rhi) [1 :: Int .. 6]+ @?= [ LhSkip+ ( Lh+ ()+ (Rhi 1)+ )+ , Lh+ ()+ ( Rh+ 2+ (Rhi 2)+ )+ , LhSkip+ ( Lh+ ()+ (Rhi 3)+ )+ , Rh+ '6'+ ( Rh+ 4+ (Rhi 4)+ )+ , LhSkip+ ( Lh+ ()+ (Rhi 5)+ )+ , Rh+ '8'+ ( Rh+ 6+ (Rhi 6)+ )+ ]+ , testCase "lhMaybe'" $+ map (lhMaybe' (> 3) (chr . (+ 50)) . lhBool even . Rhi) [1 :: Int .. 6]+ @?= [ LhSkip+ ( Lh+ ()+ (Rhi 1)+ )+ , Lh+ ()+ ( Rh+ 2+ (Rhi 2)+ )+ , LhSkip+ ( Lh+ ()+ (Rhi 3)+ )+ , Rh+ '6'+ ( Rh+ 4+ (Rhi 4)+ )+ , LhSkip+ ( Lh+ ()+ (Rhi 5)+ )+ , Rh+ '8'+ ( Rh+ 6+ (Rhi 6)+ )+ ]+ , testCase "traverseLRHist" $+ traverseLRHist (\z a -> (z + 1, if even a then Right (z, a) else Left (a, z))) (100 :: Int) (map Rhi [1 :: Int .. 6])+ @?= ( 106+ ,+ [ Lh+ ( 1+ , 100+ )+ (Rhi 1)+ , Rh+ ( 101+ , 2+ )+ (Rhi 2)+ , Lh+ ( 3+ , 102+ )+ (Rhi 3)+ , Rh+ ( 103+ , 4+ )+ (Rhi 4)+ , Lh+ ( 5+ , 104+ )+ (Rhi 5)+ , Rh+ ( 105+ , 6+ )+ (Rhi 6)+ ]+ )+ , testCase "appLR" $+ appLR (\a -> if even a then Just a else Nothing) (Rhi @Int @() 4)+ @?= Rh 4 (Rhi 4)+ , testCase "appLR" $+ appLR (\a -> if even a then Just (chr (a + 50)) else Nothing) (Rhi @Int @() 4)+ @?= Rh '6' (Rhi 4)+ , testCase "appLR" $+ appLR (\a -> if even a then Just (chr (a + 50)) else Nothing) (Rhi @Int @() 4)+ @?= Rh '6' (Rhi 4)+ , testCase "appLR" $+ appLR even (Rhi @Int @() 4)+ @?= Rh 4 (Rhi 4)+ , testCase "appLR" $+ appLR (\a -> if even a then Right (chr (a + 50)) else Left @String "znork") (Rhi @Int 4)+ @?= Rh '6' (Rhi 4)+ , testCase "appLR" $+ appLR (\a -> if even a then Right (chr (a + 50)) else Left @String "znork") (Rhi @Int 5)+ @?= Lh "znork" (Rhi 5)+ , testCase "appLR" $+ lhEither' even (const @String "znork") (chr . (+ 50)) (Rhi @Int 5)+ @?= Lh "znork" (Rhi 5)+ , testCase "appLRB" $+ appLRB even show (chr . (65 +)) (Rhi @Int 12)+ @?= Rh 'M' (Rhi 12)+ , testCase "appLRB" $+ appLRB even show (chr . (65 +)) (Rhi @Int 11)+ @?= Lh "11" (Rhi 11)+ , testCase "eitherToLH" $ eitherToLH (Left @_ @Int 'x') @?= Lh 'x' (Rhi ())+ , testCase "eitherToLH" $ eitherToLH (Right @Int 'x') @?= Rh 'x' (Rhi ())+ , testCase "lhEither'" $+ lhEither' ((> 4) . length) show (join (,)) (lhMaybe' even show (lhBool even (Rhi @Int 12)))+ @?= Lh "\"12\"" (Rh "12" (Rh 12 (Rhi 12)))+ , testCase "traverseLRHistB" $+ traverseLRHistB (< 'x') show id [snd $ lhskip $ lh "sdf" $ rhi 12, snd $ rh 'a' $ rh @_ @Int 999 $ rhi @_ @Int 123]+ @?= [ LhSkip (LhSkip (Lh "sdf" (Rhi 12)))+ , Rh 'a' (Rh 'a' (Rh 999 (Rhi 123)))+ ]+ ]++zz1 :: [LRHist '[Int, Char, Bool] String Int]+zz1 =+ [ snd $ lhskip $ lh "ab" $ rh 'x' $ rhi False+ , snd $ rh 72 $ rh 2 $ rh 'y' $ rhi True+ , snd $ rh 71 $ rh 299 $ rh 'a' $ rhi False+ , snd $ rh 50 $ rh 299 $ rh 'a' $ rhi False+ ]++zz2 :: [LRHist '[Int, Int, Char, Bool] String (These Char Int)]+zz2 =+ zz1+ <&> appLR+ ( \a ->+ if even a+ then+ if a > 50+ then Right (This (chr a))+ else Right (That a)+ else Left "dude"+ )++suiteCheckers :: TestTree+suiteCheckers =+ testGroup+ "TestLRHist Checkers"+ [ adj' False 100 1000 10 $ TQ.testProperties "LRHist '[]" (checkersToProps testLawsLRHist0)+ , adj' False 100 1000 10 $ TQ.testProperties "LRHist (a ': as)" (checkersToProps testLawsLRHist1)+ ]++checkersToProps :: [TestBatch] -> [(String, Property)]+checkersToProps = concatMap (\(a, bs) -> map (\(x, y) -> (a ++ " " ++ x, y)) bs)++adj' :: Bool -> Int -> Int -> Int -> TestTree -> TestTree+adj' v sz n ratio =+ adjustOption (const $ TQ.QuickCheckMaxSize sz)+ . adjustOption (max $ TQ.QuickCheckTests n)+ . adjustOption (max $ TQ.QuickCheckMaxRatio ratio)+ . adjustOption (const (TQ.QuickCheckVerbose v))++
+ test/TestList.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module TestList where++import Data.Char+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as N+import Data.Pos+import Data.These+import Primus.List+import Test.Tasty+import Test.Tasty.HUnit++suite :: TestTree+suite =+ testGroup+ "TestList"+ [ testCase "pairsOf1" $ pairsOf1 @Int [1, 2, 3] @?= ([(1, 2), (2, 3)], Nothing)+ , testCase "pairsOf1" $ pairsOf1 @Int [1, 2] @?= ([(1, 2)], Nothing)+ , testCase "pairsOf1" $ pairsOf1 @Int [1] @?= ([], Just 1)+ , testCase "pairsOf1" $ pairsOf1 @Int [] @?= ([], Nothing)+ , testCase "pairsOf2" $ pairsOf2 @Int [1, 2, 3, 4] @?= ([(1, 2), (3, 4)], Nothing)+ , testCase "pairsOf2" $ pairsOf2 @Int [1, 2, 3] @?= ([(1, 2)], Just 3)+ , testCase "pairsOf2" $ pairsOf2 @Int [1, 2] @?= ([(1, 2)], Nothing)+ , testCase "pairsOf2" $ pairsOf2 @Int [1] @?= ([], Just 1)+ , testCase "pairsOf2" $ pairsOf2 @Int [] @?= ([], Nothing)+ , testCase "chunksOf" $ chunksOf @Int _4P [1 .. 13] @?= [[1, 2, 3, 4], [5, 6, 7, 8], [9, 10, 11, 12], [13]]+ , testCase "chunksOf" $ chunksOf @Int _4P [1, 2, 3, 4, 5] @?= [[1, 2, 3, 4], [5]]+ , testCase "chunksOf" $ chunksOf @Int _4P [1, 2, 3, 4] @?= [[1, 2, 3, 4]]+ , testCase "chunksOf" $ chunksOf @Int _4P [1, 2, 3] @?= [[1, 2, 3]]+ , testCase "chunksOf" $ chunksOf @Int _4P [1, 2] @?= [[1, 2]]+ , testCase "chunksOf" $ chunksOf @Int _4P [1] @?= [[1]]+ , testCase "chunksOf" $ chunksOf @Int _4P [] @?= []+ , testCase "atL" $ atL 0 ['a', 'c', 'e'] @?= Just 'a'+ , testCase "atL" $ atL 1 ['a', 'c', 'e'] @?= Just 'c'+ , testCase "atL" $ atL 2 ['a', 'c', 'e'] @?= Just 'e'+ , testCase "atL" $ atL 3 ['a', 'c', 'e'] @?= Nothing+ , testCase "atL" $ atL 0 ([] :: [Int]) @?= Nothing+ , testCase "updateAtL" $ updateAtL 0 toUpper "ace" @?= Just "Ace"+ , testCase "updateAtL" $ updateAtL 1 toUpper "ace" @?= Just "aCe"+ , testCase "updateAtL" $ updateAtL 2 toUpper "ace" @?= Just "acE"+ , testCase "updateAtL" $ updateAtL 3 toUpper "ace" @?= Nothing+ , testCase "updateAtL" $ updateAtL 0 toUpper "" @?= Nothing+ , testCase "splitAtLGE" $ splitAtLGE @Int 0 [1, 2, 3, 4, 5] @?= Right ([], [1, 2, 3, 4, 5])+ , testCase "splitAtLGE" $ splitAtLGE @Int 1 [1, 2, 3, 4, 5] @?= Right ([1], [2, 3, 4, 5])+ , testCase "splitAtLGE" $ splitAtLGE @Int 5 [1, 2, 3, 4, 5] @?= Right ([1, 2, 3, 4, 5], [])+ , testCase "splitAtLGE" $ splitAtLGE @Int 6 [1, 2, 3, 4, 5] @?= Left "not enough elements: expected 6 found 5"+ , testCase "splitAtLGE" $ splitAtLGE @Int (-44) [1, 2, 3, 4, 5] @?= Left "negative index 44"+ , testCase "splitAtLGE" $ splitAtLGE @Int 0 [] @?= Right ([], [])+ , testCase "splitAtL" $ splitAtL @Int 0 [] @?= ([], SplitLEQ)+ , testCase "splitAtL" $ splitAtL @Int 0 [1] @?= ([], SplitLGT (1 :| []))+ , testCase "splitAtL" $ splitAtL @Int 1 [] @?= ([], SplitLLT 0)+ , testCase "splitAtL" $ splitAtL @Int (-4) [1, 2, 3, 4, 5] @?= ([1, 2, 3, 4, 5], SplitLNeg _4P)+ , testCase "splitAtL" $ splitAtL @Int 0 [1, 2, 3, 4, 5] @?= ([], SplitLGT (1 :| [2, 3, 4, 5]))+ , testCase "splitAtL" $ splitAtL @Int 1 [1, 2, 3, 4, 5] @?= ([1], SplitLGT (2 :| [3, 4, 5]))+ , testCase "splitAtL" $ splitAtL @Int 2 [1, 2, 3, 4, 5] @?= ([1, 2], SplitLGT (3 :| [4, 5]))+ , testCase "splitAtL" $ splitAtL @Int 5 [1, 2, 3, 4, 5] @?= ([1, 2, 3, 4, 5], SplitLEQ)+ , testCase "splitAtL" $ splitAtL @Int 6 [1, 2, 3, 4, 5] @?= ([1, 2, 3, 4, 5], SplitLLT 5)+ , testCase "splitAtL" $ splitAtL @Int (-1) [1, 2, 3, 4, 5] @?= ([1, 2, 3, 4, 5], SplitLNeg _1P)+ , testCase "splitAtL infinite" $+ let (xs, ss) = splitAtL @Int 4 [1 ..]+ in case ss of+ SplitLGT ns -> (xs, N.take 10 ns) @?= ([1 .. 4], [5 .. 14])+ o -> assertFailure $ "expected SplitLGT but found " ++ show o+ , testCase "zipLongest" $ zipLongest [1 :: Int .. 5] "Abc" @?= [These 1 'A', These 2 'b', These 3 'c', This 4, This 5]+ , testCase "zipLongest" $ zipLongest "Abc" [1 :: Int .. 5] @?= [These 'A' 1, These 'b' 2, These 'c' 3, That 4, That 5]+ , testCase "lengthExact" $ lengthExact 2 "abc" @?= Left "GT: too many elements: expected 2"+ , testCase "lengthExact" $ lengthExact 3 "abc" @?= Right "abc"+ , testCase "lengthExact" $ lengthExact 4 "abc" @?= Left "LT: expected 4 found 3"+ , testCase "lengthExact" $ lengthExact 0 "abc" @?= Left "GT: too many elements: expected 0"+ , testCase "lengthExact" $ lengthExact 0 "" @?= Right ""+ , testCase "partitionTheseL" $+ partitionTheseL even (> 5) id (chr . (+ 50)) [1 :: Int .. 10]+ @?= ([1, 3, 5, 7, 9], "46", [(6, '8'), (8, ':'), (10, '<')])+ , testCase "partitionEithersL" $+ partitionEithersL even id (chr . (+ 50)) [1 :: Int .. 10]+ @?= ([1, 3, 5, 7, 9], "468:<")+ , testCase "partitionTheseL" $+ partitionTheseL (> 4) even id id [1 :: Int .. 10]+ @?= ([1, 2, 3, 4], [5, 7, 9], [(6, 6), (8, 8), (10, 10)])+ , testCase "spanMaybe" $+ spanMaybe even show [2, 4, 6, 8, 1, 2, 3, 4 :: Int]+ @?= (["2", "4", "6", "8"], [1, 2, 3, 4])+ , testCase "spanMaybe even simpler" $+ spanMaybe even (chr . (+ 50)) [2 :: Int, 4, 6, 8, 9, 11, 13]+ @?= ( "468:"+ ,+ [ 9+ , 11+ , 13+ ]+ )+ ]
+ test/TestNonEmpty.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module TestNonEmpty where++import Control.Lens+import Data.Char+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as N+import Data.These+import Data.Pos+import Primus.Bool+import Primus.Enum+import Primus.NonEmpty+import Test.Tasty+import Test.Tasty.HUnit++suite :: TestTree+suite =+ testGroup+ "TestNonEmpty"+ [ testCase "splits1" $ splits1 ('a' :| "bcd") @?= [('a' :| "", 'b' :| "cd"), ('a' :| "b", 'c' :| "d"), ('a' :| "bc", 'd' :| "")]+ , testCase "splits1" $ splits1 ('a' :| "b") @?= [('a' :| "", 'b' :| "")]+ , testCase "splits1" $ splits1 ('a' :| "") @?= []+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int (<) (1 :| [2, 5, 7, 10, 11]) @?= (1 :| [2, 5, 7, 10, 11]) :| []+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int (<) (1 :| [2, 5, 7, 3, 10, 11]) @?= (1 :| [2, 5, 7]) :| [3 :| [10, 11]]+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int (<) ((1 :: Int) :| []) @?= (1 :| []) :| []+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int (<) (10 :| [9, 8, 7, 6, 5]) @?= (10 :| []) :| [9 :| [], 8 :| [], 7 :| [], 6 :| [], 5 :| []]+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int ((==) . (+ 1)) (1 :| [4, 5, 7, 10, 11]) @?= (1 :| []) :| [4 :| [5], 7 :| [], 10 :| [11]]+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int ((==) . (+ 1)) (1 :| [2, 3, 4]) @?= (1 :| [2, 3, 4]) :| []+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int ((==) . (+ 1)) (10 :| [9, 8]) @?= (10 :| []) :| [9 :| [], 8 :| []]+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int ((==) . (+ 1)) (10 :| [8, 8, 9]) @?= (10 :| []) :| [8 :| [], 8 :| [9]]+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int ((==) . (+ 1)) (1 :| [2]) @?= (1 :| [2]) :| []+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int ((==) . (+ 1)) (1 :| [3]) @?= (1 :| []) :| [3 :| []]+ , testCase "groupByAdjacent1" $ groupByAdjacent1 @Int ((==) . (+ 1)) (1 :| [0]) @?= (1 :| []) :| [0 :| []]+ , testCase "findDupsBy" $ findDupsBy (even . ord) "abcd" @?= ([(0, 'a') :| [(2, 'c')], (1, 'b') :| [(3, 'd')]], [])+ , testCase "findDupsBy" $ findDupsBy id "abcd" @?= ([], [(0, 'a'), (1, 'b'), (2, 'c'), (3, 'd')])+ , testCase "findDupsBy" $ findDupsBy (even . ord) "aceg" @?= ([(0, 'a') :| [(1, 'c'), (2, 'e'), (3, 'g')]], [])+ , testCase "findDupsBy" $ findDupsBy (even . ord) "acegzyz" @?= ([(0, 'a') :| [(1, 'c'), (2, 'e'), (3, 'g'), (5, 'y')], (4, 'z') :| [(6, 'z')]], [])+ , testCase "findDupsBy" $ findDupsBy id "aaaaabccdc" @?= ([(0, 'a') :| [(1, 'a'), (2, 'a'), (3, 'a'), (4, 'a')], (6, 'c') :| [(7, 'c'), (9, 'c')]], [(5, 'b'), (8, 'd')])+ , testCase "findDupsBy" $ findDupsBy id "aaa" @?= ([(0, 'a') :| [(1, 'a'), (2, 'a')]], [])+ , testCase "findDupsBy" $ findDupsBy id "axaya" @?= ([(0, 'a') :| [(2, 'a'), (4, 'a')]], [(1, 'x'), (3, 'y')])+ , testCase "consNonEmpty" $ (1 :| [2, 3, 4 :: Int]) ^. consNonEmpty @?= (1, [2, 3, 4])+ , testCase "consNonEmpty" $ (1, [2, 3, 4 :: Int]) ^. from consNonEmpty @?= (1 :| [2, 3, 4])+ , testCase "splitAt1'" $ splitAt1' @Int _1P (2 :| [3 .. 6]) @?= (2 :| [], SplitGT (3 :| [4, 5, 6]))+ , testCase "splitAt1'" $ splitAt1' @Int _2P (2 :| [3 .. 6]) @?= (2 :| [3], SplitGT (4 :| [5, 6]))+ , testCase "splitAt1'" $ splitAt1' @Int _3P (2 :| [3 .. 6]) @?= (2 :| [3, 4], SplitGT (5 :| [6]))+ , testCase "splitAt1'" $ splitAt1' @Int _3P (2 :| []) @?= (2 :| [], SplitLT _1P)+ , testCase "splitAt1'" $ splitAt1' @Int _1P (2 :| []) @?= (2 :| [], SplitEQ)+ , testCase "chunksRange1" $ chunksRange1 @Int _1P _2P (1 :| [2 .. 5]) @?= (1 :| []) :| [3 :| [], 5 :| []]+ , testCase "chunksRange1" $ chunksRange1 @Int _1P _2P (1 :| [2 .. 10]) @?= (1 :| []) :| [3 :| [], 5 :| [], 7 :| [], 9 :| []]+ , testCase "chunksRange1" $ chunksRange1 @Int _3P _2P (1 :| [2 .. 10]) @?= (1 :| [2, 3]) :| [3 :| [4, 5], 5 :| [6, 7], 7 :| [8, 9], 9 :| [10]]+ , testCase "chunksRange1" $ chunksRange1 @Int _3P _1P (1 :| [2 .. 10]) @?= (1 :| [2, 3]) :| [2 :| [3, 4], 3 :| [4, 5], 4 :| [5, 6], 5 :| [6, 7], 6 :| [7, 8], 7 :| [8, 9], 8 :| [9, 10], 9 :| [10], 10 :| []]+ , testCase "chunksRange1" $ chunksRange1 @Int _3P _1P (1 :| []) @?= (1 :| []) :| []+ , testCase "chunksRange1" $ chunksRange1 @Int _1P _1P (1 :| []) @?= (1 :| []) :| []+ , testCase "unfoldr1NE" $+ unfoldr1NE (\ns -> ((length ns, N.head ns), N.drop 1 ns)) (N.fromList "abcdef")+ @?= ((6, 'a') :| [(5, 'b'), (4, 'c'), (3, 'd'), (2, 'e'), (1, 'f')])+ , testCase "isEnumAscending" $ isEnumAscending @_ @Int (1 :| [2, 3, 4]) @?= S1Ok+ , testCase "isEnumAscending" $ isEnumAscending @_ @Int (1 :| [2, 3, 4, 3]) @?= S1Fail (5, 3)+ , testCase "isEnumAscending" $ isEnumAscending (LT :| [EQ, GT]) @?= S1Ok+ , testCase "isEnumAscending" $ isEnumAscending (LT :| [EQ, GT, EQ]) @?= S1Short (EQ :| [])+ , testCase "isEnumAscending" $ isEnumAscending @_ @Int (1 :| [2, 3, 4, 98, 9, 3]) @?= S1Fail (5, 98)+ , testCase "splits3" $+ splits3 (1 :| [2 :: Int .. 5])+ @?= (([], 1, [2, 3, 4, 5]) :| [([1], 2, [3, 4, 5]), ([1, 2], 3, [4, 5]), ([1, 2, 3], 4, [5]), ([1, 2, 3, 4], 5, [])])+ , testCase "splits3" $+ splits3 ((1 :: Int) :| [])+ @?= (([], 1, []) :| [])+ , testCase "consNonEmpty" $+ (consNonEmpty # (from consNonEmpty # (1 :| [2 :: Int .. 5])))+ @?= (1 :| [2, 3, 4, 5])+ , testCase "chunkNLen nonempty" $+ chunkNLen (enumTo1 _3P) _4P [1 :: Int .. 12]+ @?= Right ((1 :| [2, 3, 4]) :| [5 :| [6, 7, 8], 9 :| [10, 11, 12]])+ , testCase "chunkNLen nonempty" $+ chunkNLen (enumTo1 _3P) _4P [1 :: Int .. 13]+ @?= Left "chunkN': there is still data remaining at eof"+ , testCase "chunkNLen nonempty" $+ chunkNLen (enumTo1 _3P) _4P [1 :: Int .. 11]+ @?= Left "not enough elements: expected 4 found 3"+ , testCase "chunkNLen list" $+ chunkNLen (replicate 3 ()) _4P [1 :: Int .. 12]+ @?= Right [1 :| [2, 3, 4], 5 :| [6, 7, 8], 9 :| [10, 11, 12]]+ , testCase "chunkNLen list" $+ chunkNLen (replicate 3 ()) _4P [1 :: Int .. 13] @?= Left "chunkN': there is still data remaining at eof"+ , testCase "chunkNLen list" $+ chunkNLen (replicate 3 ()) _4P [1 :: Int .. 11]+ @?= Left "not enough elements: expected 4 found 3"+ , testCase "appendL1" $+ appendL1 [1 :: Int .. 4] (101 :| [102])+ @?= (1 :| [2, 3, 4, 101, 102])+ , testCase "appendR1" $+ appendR1 (101 :| [102]) [1 :: Int .. 4]+ @?= (101 :| [102, 1, 2, 3, 4])+ , testCase "appendL1" $+ appendL1 [] (101 :| [102 :: Int])+ @?= (101 :| [102])+ , testCase "appendR1" $+ appendR1 (101 :| [102 :: Int]) []+ @?= (101 :| [102])+ , testCase "iterateMaybe1 even simpler" $+ iterateMaybe1 (> 0) pred (5 :: Int)+ @?= (5 :| [4, 3, 2, 1, 0])+ , testCase "snoc1" $+ snoc1 [1, 2, 3, 4 :: Int] 999 @?= 1 :| [2, 3, 4, 999]+ , testCase "snoc1" $+ snoc1 ([] :: [Int]) 999 @?= 999 :| []+ , testCase "unsnoc1" $+ unsnoc1 (1 :| [2, 3, 4, 999]) @?= ([1, 2, 3, 4 :: Int], 999)+ , testCase "unsnoc1" $+ unsnoc1 ((999 :: Int) :| []) @?= ([], 999)+ , testCase "take1" $+ take1 _1P ('a' :| []) @?= 'a' :| ""+ , testCase "take1" $+ take1 _2P ('a' :| []) @?= 'a' :| ""+ , testCase "take1" $+ take1 _2P ('a' :| "bc") @?= 'a' :| "b"+ , testCase "take1" $+ take1 _3P ('a' :| "bc") @?= 'a' :| "bc"+ , testCase "splitAts1" $+ splitAts1 _2P ('a' :| "bcde") @?= ('a' :| "b") :| ['c' :| "d", 'e' :| ""]+ , testCase "splitAts1" $+ splitAts1 _2P ('a' :| "") @?= ('a' :| "") :| []+ , testCase "splitAts1" $+ splitAts1 _2P ('a' :| "b") @?= ('a' :| "b") :| []+ , testCase "splitAts1" $+ splitAts1 _1P ('a' :| "b") @?= ('a' :| "") :| ['b' :| ""]+ , testCase "lengthExact1" $+ lengthExact1 _1P ('a' :| "bcdef")+ @?= Left "GT: too many elements: expected 1"+ , testCase "lengthExact1" $+ lengthExact1 _6P ('a' :| "bcdef")+ @?= Right ('a' :| "bcdef")+ , testCase "lengthExact1" $+ lengthExact1 _6P ('a' :| "bcde")+ @?= Left "LT: not enough elements: expected 6 found 5"+ , testCase "updateAt1" $+ updateAt1 _3P (+ 100) (1 :| [2 :: Int .. 5])+ @?= Just (1 :| [2, 103, 4, 5])+ , testCase "updateAt1" $+ updateAt1 _1P (+ 100) (1 :| [2 :: Int .. 5])+ @?= Just (101 :| [2, 3, 4, 5])+ , testCase "updateAt1" $+ updateAt1 _5P (+ 100) (1 :| [2 :: Int .. 5])+ @?= Just (1 :| [2, 3, 4, 105])+ , testCase "updateAt1" $+ updateAt1 _6P (+ 100) (1 :| [2 :: Int .. 5])+ @?= Nothing+ , testCase "updateAt1" $+ updateAt1 _7P (+ 100) (1 :| [2 :: Int .. 5])+ @?= Nothing+ , testCase "spanAdjacent1" $+ spanAdjacent1 (<) (1 :| [2 :: Int, 4, 5, 1, 9, 2, 3])+ @?= (1 :| [2, 4, 5], [1, 9, 2, 3])+ , testCase "spanAdjacent1" $+ spanAdjacent1 (<) (9 :| [8 :: Int, 7, 1])+ @?= (9 :| [], [8, 7, 1])+ , testCase "spanAdjacent1" $+ spanAdjacent1 (<) (9 :| [8 :: Int, 7, 1, 9])+ @?= (9 :| [], [8, 7, 1, 9])+ , testCase "spanAdjacent1" $+ spanAdjacent1 (<) ((9 :: Int) :| [])+ @?= (9 :| [], [])+ , testCase "spanAdjacent1" $+ spanAdjacent1 (<) (9 :| [10 :: Int, 11])+ @?= (9 :| [10, 11], [])+ , testCase "spanAdjacent1" $+ spanAdjacent1 ((==) . (+ 1)) (1 :| [2 :: Int, 3, 4, 5, 6])+ @?= (1 :| [2, 3, 4, 5, 6], [])+ , testCase "spanAdjacent1" $+ spanAdjacent1 ((==) . (+ 1)) (1 :| [2 :: Int, 3, 4, 5, 6, 8])+ @?= (1 :| [2, 3, 4, 5, 6], [8])+ , testCase "breakAdjacent1" $+ breakAdjacent1 (<) (1 :| [2 :: Int, 4, 5, 1, 9, 2, 3])+ @?= (1 :| [], [2, 4, 5, 1, 9, 2, 3])+ , testCase "breakAdjacent1" $+ breakAdjacent1 (<) (9 :| [8 :: Int, 7, 1])+ @?= (9 :| [8, 7, 1], [])+ , testCase "breakAdjacent1" $+ breakAdjacent1 (<) (9 :| [8 :: Int, 7, 1, 9])+ @?= (9 :| [8, 7, 1], [9])+ , testCase "breakAdjacent1" $+ breakAdjacent1 (<) ((9 :: Int) :| [])+ @?= (9 :| [], [])+ , testCase "breakAdjacent1" $+ breakAdjacent1 ((==) . (+ 1)) (1 :| [2 :: Int, 3, 4, 5, 6, 8])+ @?= (1 :| [], [2, 3, 4, 5, 6, 8])+ , testCase "breakAdjacent1" $+ breakAdjacent1 ((==) . (+ 1)) (1 :| [3 :: Int, 5])+ @?= (1 :| [3, 5], [])+ , testCase "breakAdjacent1" $+ breakAdjacent1 ((==) . (+ 1)) (1 :| [3 :: Int, 5, 6])+ @?= (1 :| [3, 5], [6])+ , testCase "breakAdjacent1" $+ splitAt1GE _1P (1 :| [2 :: Int, 3, 4])+ @?= Right (1 :| [], [2, 3, 4])+ , testCase "breakAdjacent1" $+ splitAt1GE _2P (1 :| [2 :: Int, 3, 4])+ @?= Right (1 :| [2], [3, 4])+ , testCase "breakAdjacent1" $+ splitAt1GE _4P (1 :| [2 :: Int, 3, 4])+ @?= Right (1 :| [2, 3, 4], [])+ , testCase "breakAdjacent1" $+ splitAt1GE _5P (1 :| [2 :: Int, 3, 4])+ @?= Left "not enough elements: expected 5 found 4"+ , testCase "breakAdjacent1" $+ splitAt1GE _5P ((1 :: Int) :| [])+ @?= Left "not enough elements: expected 5 found 1"+ , testCase "breakAdjacent1" $+ splitAt1GE _1P ((1 :: Int) :| [])+ @?= Right (1 :| [], [])+ , testCase "zipWithExtras" $+ zipWithExtras (,) ([] :: [Int]) "abcd"+ @?= ([], MLRRight ('a' :| "bcd"))+ , testCase "zipWithExtras" $+ zipWithExtras (,) ("abcd" :: String) ([] :: [Int])+ @?= ([], MLRLeft ('a' :| "bcd"))+ , testCase "zipWithExtras" $+ zipWithExtras (,) ("abcd" :: String) [1, 2, 3, 4 :: Int]+ @?= ([('a', 1), ('b', 2), ('c', 3), ('d', 4)], MLREqual)+ , testCase "zipWithExtras" $+ zipWithExtras (,) ("abcd" :: String) [1, 2, 3 :: Int]+ @?= ([('a', 1), ('b', 2), ('c', 3)], MLRLeft ('d' :| ""))+ , testCase "zipWithExtras" $+ zipWithExtras (,) ("abcd" :: String) [1, 2, 3, 4, 5 :: Int]+ @?= ([('a', 1), ('b', 2), ('c', 3), ('d', 4)], MLRRight (5 :| []))+ , testCase "zipWithExtras" $+ zipWithExtras (,) ([] :: [Int]) ([] :: [()])+ @?= ([], MLREqual)+ , testCase "zipWithExtras1" $+ zipWithExtras1 (,) ((1 :: Int) :| []) ('a' :| "bcd")+ @?= ((1, 'a') :| [], MLRRight ('b' :| "cd"))+ , testCase "zipWithExtras1" $+ zipWithExtras1 (,) ('a' :| "bcd") ((1 :: Int) :| [])+ @?= (('a', 1) :| [], MLRLeft ('b' :| "cd"))+ , testCase "zipWithExtras1" $+ zipWithExtras1 (,) ('a' :| "bcd") (1 :| [2, 3, 4 :: Int])+ @?= (('a', 1) :| [('b', 2), ('c', 3), ('d', 4)], MLREqual)+ , testCase "zipWithExtras1" $+ zipWithExtras1 (,) ('a' :| "bcd") (1 :| [2, 3 :: Int])+ @?= (('a', 1) :| [('b', 2), ('c', 3)], MLRLeft ('d' :| ""))+ , testCase "zipWithExtras1" $+ zipWithExtras1 (,) ('a' :| "bcd") (1 :| [2, 3, 4, 5 :: Int])+ @?= (('a', 1) :| [('b', 2), ('c', 3), ('d', 4)], MLRRight (5 :| []))+ , testCase "zipWithExtras1" $+ zipWithExtras1 (,) ((1 :: Int) :| []) (() :| [])+ @?= ((1, ()) :| [], MLREqual)+ , testCase "unfoldrM1" $+ unfoldrM1 (\s -> Just (take 3 s, boolMaybe (not . null) id (drop 3 s))) [1 :: Int .. 11]+ @?= Just ([1, 2, 3] :| [[4, 5, 6], [7, 8, 9], [10, 11]])+ , testCase "span1" $+ span1 even (2 :| [4 :: Int, 6, 8, 1, 210])+ @?= These (2 :| [4, 6, 8]) (1 :| [210])+ , testCase "span1" $+ span1 even (1 :| [2 :: Int, 4, 6, 8, 1, 210])+ @?= These (2 :| [4, 6, 8]) (1 :| [1, 210])+ , testCase "span1" $+ span1 even (2 :| [4 :: Int, 6, 8])+ @?= This (2 :| [4, 6, 8])+ , testCase "span1" $+ span1 even ((1 :: Int) :| [])+ @?= That (1 :| [])+ , testCase "span1" $+ span1 even (1 :| [3 :: Int, 5])+ @?= That (1 :| [3, 5])+ , testCase "partition1" $+ partition1 even (2 :| [4 :: Int, 6, 8, 1, 210])+ @?= These (1 :| []) (2 :| [4, 6, 8, 210])+ , testCase "partition1" $+ partition1 even (1 :| [2 :: Int, 4, 6, 8, 1, 210])+ @?= These (1 :| [1]) (2 :| [4, 6, 8, 210])+ , testCase "partition1" $+ partition1 even (1 :| [2 :: Int, 3, 4, 5, 6, 7, 8])+ @?= These (1 :| [3, 5, 7]) (2 :| [4, 6, 8])+ , testCase "partition1" $+ partition1 even (2 :| [4 :: Int, 6, 8])+ @?= That (2 :| [4, 6, 8])+ , testCase "partition1" $+ partition1 even ((1 :: Int) :| [])+ @?= This (1 :| [])+ , testCase "partition1" $+ partition1 even (1 :| [3 :: Int, 5])+ @?= This (1 :| [3, 5])+ , testCase "at1" $ at1 _1P ('a' :| "ce") @?= Just 'a'+ , testCase "at1" $ at1 _2P ('a' :| "ce") @?= Just 'c'+ , testCase "at1" $ at1 _3P ('a' :| "ce") @?= Just 'e'+ , testCase "at1" $ at1 _4P ('a' :| "ce") @?= Nothing+ , testCase "at1" $ at1 _1P ('a' :| []) @?= Just 'a'+ , testCase "updateAt1" $ updateAt1 _1P toUpper ('a' :| "ce") @?= Just ('A' :| "ce")+ , testCase "updateAt1" $ updateAt1 _2P toUpper ('a' :| "ce") @?= Just ('a' :| "Ce")+ , testCase "updateAt1" $ updateAt1 _3P toUpper ('a' :| "ce") @?= Just ('a' :| "cE")+ , testCase "updateAt1" $ updateAt1 _4P toUpper ('a' :| "ce") @?= Nothing+ , testCase "updateAt1" $ updateAt1 _1P toUpper ('a' :| []) @?= Just ('A' :| [])+ , testCase "updateAt1" $ updateAt1 _2P toUpper ('a' :| []) @?= Nothing+ , testCase "lengthP" $ lengthP (2 :| [1 :: Int .. 5]) @?= _6P+ , testCase "unitsF" $ unitsF @[] _4P @?= [(), (), (), ()]+ , testCase "unitsF" $ unitsF @NonEmpty _4P @?= (() :| [(), (), ()])+ ]
+ test/TestNum1.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module TestNum1 where++import Data.Pos+import Data.Word+import GHC.Natural+import Primus.Num1+import Test.Tasty+import Test.Tasty.HUnit++doit :: IO ()+doit = defaultMain suite++suite :: TestTree+suite =+ testGroup+ "TestNum1"+ [ testCase "Num1" $+ fromInteger1 @Natural 0 (-100)+ @?= Left "Natural: undefined for negative numbers -100"+ , testCase "Num1" $ withOp2 @Natural (*) 4 5 @?= Right 20+ , testCase "Num1" $ withOp2 @Natural (*) 9 0 @?= Right 0+ , testCase "Num1" $ withOp2 @Natural (-) 7 5 @?= Right 2+ , testCase "Num1" $ withOp2 @Natural (-) 5 5 @?= Right 0+ , testCase "Num1" $+ withOp2 @Natural (-) 4 5+ @?= Left "Natural: undefined for negative numbers -1"+ , testCase "pred1" $+ pred1 @Natural (pure 0)+ @?= Left "pred1:Natural: undefined for negative numbers -1"+ , testCase "pred1" $+ pred1 @Natural (pure 2)+ @?= Right 1+ , testCase "succ1" $+ succ1 @Natural (pure 1)+ @?= Right 2+ , testCase "withOp" $+ withOp @Natural (subtract 9) 2+ @?= Left "Natural: undefined for negative numbers -7"+ , testCase "withOp" $+ withOp @Natural (subtract 9) 14+ @?= Right 5+ , testCase "fromInteger1" $+ fromInteger1 _10P 0+ @?= Left "integerToEnumSafe:underflow where 0 not in range [1..9223372036854775807]"+ , testCase "withOp2" $ withOp2 (*) _1P _5P @?= Right _5P+ , testCase "withOp2" $ withOp2 (*) _1P _1P @?= Right _1P+ , testCase "withOp2" $ withOp2 (*) _1P _2P @?= Right _2P+ , testCase "withOp2" $ withOp2 ((-) . (+ 1)) _5P _5P @?= Right _1P+ , testCase "withOp2" $ withOp2 ((-) . (+ 1)) _5P _5P @?= Right _1P+ , testCase "withOp2" $ withOp2 (-) _7P _5P @?= Right _2P+ , testCase "withOp2" $+ withOp2 (-) _5P _5P+ @?= Left "integerToEnumSafe:underflow where 0 not in range [1..9223372036854775807]"+ , testCase "withOp2" $+ withOp2 (-) _5P _13P+ @?= Left "integerToEnumSafe:underflow where -8 not in range [1..9223372036854775807]"+ , testCase "withOp2" $+ withOp2 (-) (_P @333) (_P @1234)+ @?= Left "integerToEnumSafe:underflow where -901 not in range [1..9223372036854775807]"+ , testCase "pred1" $+ pred1 (pure _1P)+ @?= Left "pred1:integerToEnumSafe:underflow where 0 not in range [1..9223372036854775807]"+ , testCase "pred1" $+ pred1 (pure _2P)+ @?= Right _1P+ , testCase "succ1" $+ succ1 (pure _1P)+ @?= Right _2P+ , testCase "withOp" $+ withOp (subtract 9) _2P+ @?= Left "integerToEnumSafe:underflow where -7 not in range [1..9223372036854775807]"+ , testCase "withOp" $+ withOp (subtract 9) _14P+ @?= Right _5P+ , testCase "withOp2" $+ withOp2 ((-) . (+ 1)) (100 :: Word8) (113 :: Word8)+ @?= Left "integerToEnumSafe:underflow where -12 not in range [0..255]"+ , testCase "withOp2" $+ fromInteger1 (100 :: Word8) 2000+ @?= Left "integerToEnumSafe:overflow where 2000 not in range [0..255]"+ , testCase "withOp2" $+ fromInteger1 (100 :: Word8) 122+ @?= Right @_ @Word8 122+ ]
+ test/TestZipNonEmpty.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS -Wno-orphans #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module TestZipNonEmpty where++import Data.Foldable+import qualified Data.List.NonEmpty as N+import qualified Data.Monoid as MM+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+argsVerbose = stdArgs{maxSuccess = 500, chatty = True}++instance Arbitrary a => Arbitrary (ZipNonEmpty a) where+ -- arbitrary = ((ZipNonEmpty .) . (:|)) <$> arbitrary <*> arbitrary+ arbitrary = ZipNonEmpty . N.fromList <$> listOf1 arbitrary++instance Eq a => EqProp (ZipNonEmpty a) where (=-=) = eq++testLawsZipNonEmpty :: [TestBatch]+testLawsZipNonEmpty =+ [functor z, semigroup (z, Fixed (10 :: Int)), foldable z1] -- , traversable z]+ where+ z = undefined :: ZipNonEmpty (MM.Sum Integer, String, MM.Sum Int)+ z1 = undefined :: ZipNonEmpty (String, Integer, String, Int, Bool)++testLawsZipNonEmptyIO :: IO ()+testLawsZipNonEmptyIO = do+ traverse_ verboseBatch testLawsZipNonEmpty+{-+doit :: IO ()+doit = defaultMain suite++suite :: TestTree+suite =+ testGroup+ "TestZipNonEmpty"+ []+-}+suiteCheckers :: TestTree+suiteCheckers =+ testGroup+ "TestZipNonEmpty Checkers"+ [ adj' False 100 1000 10 $ TQ.testProperties "ZipNonEmpty" (checkersToProps testLawsZipNonEmpty)+ ]++checkersToProps :: [TestBatch] -> [(String, Property)]+checkersToProps = concatMap (\(a, bs) -> map (\(x, y) -> (a ++ " " ++ x, y)) bs)++adj' :: Bool -> Int -> Int -> Int -> TestTree -> TestTree+adj' v sz n ratio =+ adjustOption (const $ TQ.QuickCheckMaxSize sz)+ . adjustOption (max $ TQ.QuickCheckTests n)+ . adjustOption (max $ TQ.QuickCheckMaxRatio ratio)+ . adjustOption (const (TQ.QuickCheckVerbose v))