diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Util.hs')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Util.hs | 351 |
1 files changed, 0 insertions, 351 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Util.hs b/users/grfn/xanthous/src/Xanthous/Util.hs deleted file mode 100644 index f918340f055b..000000000000 --- a/users/grfn/xanthous/src/Xanthous/Util.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE QuantifiedConstraints #-} --------------------------------------------------------------------------------- -module Xanthous.Util - ( EqEqProp(..) - , EqProp(..) - , foldlMapM - , foldlMapM' - , between - - , appendVia - - -- * Foldable - -- ** Uniqueness - -- *** Predicates on uniqueness - , isUniqueOf - , isUnique - -- *** Removing all duplicate elements in n * log n time - , uniqueOf - , unique - -- *** Removing sequentially duplicate elements in linear time - , uniqOf - , uniq - -- ** Bag sequence algorithms - , takeWhileInclusive - , smallestNotIn - , removeVectorIndex - , removeFirst - , maximum1 - , minimum1 - - -- * Combinators - , times, times_, endoTimes - - -- * State utilities - , modifyK, modifyKL, useListOf - - -- * Type-level programming utils - , KnownBool(..) - - -- * - , AlphaChar(..) - ) where --------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (foldr) --------------------------------------------------------------------------------- -import Test.QuickCheck.Checkers -import Data.Foldable (foldr) -import Data.Monoid -import Data.Proxy -import qualified Data.Vector as V -import Data.Semigroup (Max(..), Min(..)) -import Data.Semigroup.Foldable -import Control.Monad.State.Class -import Control.Monad.State (evalState) --------------------------------------------------------------------------------- - -newtype EqEqProp a = EqEqProp a - deriving newtype Eq - -instance Eq a => EqProp (EqEqProp a) where - (=-=) = eq - -foldlMapM :: forall g b a m. (Foldable g, Monoid b, Applicative m) => (a -> m b) -> g a -> m b -foldlMapM f = foldr f' (pure mempty) - where - f' :: a -> m b -> m b - f' x = liftA2 mappend (f x) - --- Strict in the monoidal accumulator. For monads strict --- in the left argument of bind, this will run in constant --- space. -foldlMapM' :: forall g b a m. (Foldable g, Monoid b, Monad m) => (a -> m b) -> g a -> m b -foldlMapM' f xs = foldr f' pure xs mempty - where - f' :: a -> (b -> m b) -> b -> m b - f' x k bl = do - br <- f x - let !b = mappend bl br - k b - --- | Returns whether the third argument is in the range given by the first two --- arguments, inclusive --- --- >>> between (0 :: Int) 2 2 --- True --- --- >>> between (0 :: Int) 2 3 --- False -between - :: Ord a - => a -- ^ lower bound - -> a -- ^ upper bound - -> a -- ^ scrutinee - -> Bool -between lower upper x = x >= lower && x <= upper - --- | --- >>> appendVia Sum 1 2 --- 3 -appendVia :: (Rewrapping s t, Semigroup s) => (Unwrapped s -> s) -> Unwrapped s -> Unwrapped s -> Unwrapped s -appendVia wrap x y = op wrap $ wrap x <> wrap y - --------------------------------------------------------------------------------- - --- | Returns True if the targets of the given 'Fold' are unique per the 'Ord' instance for @a@ --- --- >>> isUniqueOf (folded . _1) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)]) --- True --- --- >>> isUniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2)] :: [(Int, Int)]) --- False --- --- @ --- 'isUniqueOf' :: Ord a => 'Getter' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Fold' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Lens'' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Iso'' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Traversal'' s a -> s -> 'Bool' --- 'isUniqueOf' :: Ord a => 'Prism'' s a -> s -> 'Bool' --- @ -isUniqueOf :: Ord a => Getting (Endo (Set a, Bool)) s a -> s -> Bool -isUniqueOf aFold = orOf _2 . foldrOf aFold rejectUnique (mempty, True) - where - rejectUnique x (seen, acc) - | seen ^. contains x = (seen, False) - | otherwise = (seen & contains x .~ True, acc) - --- | Returns true if the given 'Foldable' container contains only unique --- elements, as determined by the 'Ord' instance for @a@ --- --- >>> isUnique ([3, 1, 2] :: [Int]) --- True --- --- >>> isUnique ([1, 1, 2, 2, 3, 1] :: [Int]) --- False -isUnique :: (Foldable f, Ord a) => f a -> Bool -isUnique = isUniqueOf folded - - --- | O(n * log n). Returns a monoidal, 'Cons'able container (a list, a Set, --- etc.) consisting of the unique (per the 'Ord' instance for @a@) targets of --- the given 'Fold' --- --- >>> uniqueOf (folded . _2) ([(1, 2), (2, 2), (3, 2), (4, 3)] :: [(Int, Int)]) :: [Int] --- [2,3] --- --- @ --- 'uniqueOf' :: Ord a => 'Getter' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Fold' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Lens'' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Iso'' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Traversal'' s a -> s -> [a] --- 'uniqueOf' :: Ord a => 'Prism'' s a -> s -> [a] --- @ -uniqueOf - :: (Monoid c, Ord w, Cons c c w w) => Getting (Endo (Set w, c)) a w -> a -> c -uniqueOf aFold = snd . foldrOf aFold rejectUnique (mempty, mempty) - where - rejectUnique x (seen, acc) - | seen ^. contains x = (seen, acc) - | otherwise = (seen & contains x .~ True, cons x acc) - --- | Returns a monoidal, 'Cons'able container (a list, a Set, etc.) consisting --- of the unique (per the 'Ord' instance for @a@) contents of the given --- 'Foldable' container --- --- >>> unique [1, 1, 2, 2, 3, 1] :: [Int] --- [2,3,1] - --- >>> unique [1, 1, 2, 2, 3, 1] :: Set Int --- fromList [3,2,1] -unique :: (Foldable f, Cons c c a a, Ord a, Monoid c) => f a -> c -unique = uniqueOf folded - --------------------------------------------------------------------------------- - --- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.) --- consisting of the targets of the given 'Fold' with sequential duplicate --- elements removed --- --- This function (sorry for the confusing name) differs from 'uniqueOf' in that --- it only compares /sequentially/ duplicate elements (and thus operates in --- linear time). --- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name --- --- >>> uniqOf (folded . _2) ([(1, 2), (2, 2), (3, 1), (4, 2)] :: [(Int, Int)]) :: [Int] --- [2,1,2] --- --- @ --- 'uniqOf' :: Eq a => 'Getter' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Fold' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Lens'' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Iso'' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Traversal'' s a -> s -> [a] --- 'uniqOf' :: Eq a => 'Prism'' s a -> s -> [a] --- @ -uniqOf :: (Monoid c, Cons c c w w, Eq w) => Getting (Endo (Maybe w, c)) a w -> a -> c -uniqOf aFold = snd . foldrOf aFold rejectSeen (Nothing, mempty) - where - rejectSeen x (Nothing, acc) = (Just x, x <| acc) - rejectSeen x tup@(Just a, acc) - | x == a = tup - | otherwise = (Just x, x <| acc) - --- | O(n). Returns a monoidal, 'Cons'able container (a list, a Vector, etc.) --- consisting of the targets of the given 'Foldable' container with sequential --- duplicate elements removed --- --- This function (sorry for the confusing name) differs from 'unique' in that --- it only compares /sequentially/ unique elements (and thus operates in linear --- time). --- cf 'Data.Vector.uniq' and POSIX @uniq@ for the name --- --- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: [Int] --- [1,2,3,1] --- --- >>> uniq [1, 1, 1, 2, 2, 2, 3, 3, 1] :: Vector Int --- [1,2,3,1] --- -uniq :: (Foldable f, Eq a, Cons c c a a, Monoid c) => f a -> c -uniq = uniqOf folded - --- | Like 'takeWhile', but inclusive -takeWhileInclusive :: (a -> Bool) -> [a] -> [a] -takeWhileInclusive _ [] = [] -takeWhileInclusive p (x:xs) = x : if p x then takeWhileInclusive p xs else [] - --- | Returns the smallest value not in a list -smallestNotIn :: (Ord a, Bounded a, Enum a) => [a] -> a -smallestNotIn xs = case uniq $ sort xs of - [] -> minBound - xs'@(x : _) - | x > minBound -> minBound - | otherwise - -> snd . headEx . filter (uncurry (/=)) $ zip (xs' ++ [minBound]) [minBound..] - --- | Remove the element at the given index, if any, from the given vector -removeVectorIndex :: Int -> Vector a -> Vector a -removeVectorIndex idx vect = - let (before, after) = V.splitAt idx vect - in before <> fromMaybe Empty (tailMay after) - --- | Remove the first element in a sequence that matches a given predicate -removeFirst :: IsSequence seq => (Element seq -> Bool) -> seq -> seq -removeFirst p - = flip evalState False - . filterM (\x -> do - found <- get - let matches = p x - when matches $ put True - pure $ found || not matches) - -maximum1 :: (Ord a, Foldable1 f) => f a -> a -maximum1 = getMax . foldMap1 Max - -minimum1 :: (Ord a, Foldable1 f) => f a -> a -minimum1 = getMin . foldMap1 Min - -times :: (Applicative f, Num n, Enum n) => n -> (n -> f b) -> f [b] -times n f = traverse f [1..n] - -times_ :: (Applicative f, Num n, Enum n) => n -> f a -> f [a] -times_ n fa = times n (const fa) - --- | Multiply an endomorphism by an integral --- --- >>> endoTimes (4 :: Int) succ (5 :: Int) --- 9 -endoTimes :: Integral n => n -> (a -> a) -> a -> a -endoTimes n f = appEndo $ stimes n (Endo f) - --------------------------------------------------------------------------------- - --- | This class gives a boolean associated with a type-level bool, a'la --- 'KnownSymbol', 'KnownNat' etc. -class KnownBool (bool :: Bool) where - boolVal' :: forall proxy. proxy bool -> Bool - boolVal' _ = boolVal @bool - - boolVal :: Bool - boolVal = boolVal' $ Proxy @bool - -instance KnownBool 'True where boolVal = True -instance KnownBool 'False where boolVal = False - --------------------------------------------------------------------------------- - --- | Modify some monadic state via the application of a kleisli endomorphism on --- the state itself --- --- Note that any changes made to the state during execution of @k@ will be --- overwritten --- --- @@ --- modifyK pure === pure () --- @@ -modifyK :: MonadState s m => (s -> m s) -> m () -modifyK k = get >>= k >>= put - --- | Modify some monadic state via the application of a kleisli endomorphism on --- the target of a lens --- --- Note that any changes made to the state during execution of @k@ will be --- overwritten --- --- @@ --- modifyKL id pure === pure () --- @@ -modifyKL :: MonadState s m => LensLike m s s a b -> (a -> m b) -> m () -modifyKL l k = get >>= traverseOf l k >>= put - --- | Use a list of all the targets of a 'Fold' in the current state --- --- @@ --- evalState (useListOf folded) === toList --- @@ -useListOf :: MonadState s m => Getting (Endo [a]) s a -> m [a] -useListOf = gets . toListOf - --------------------------------------------------------------------------------- - --- | A newtype wrapper around 'Char' whose 'Enum' and 'Bounded' instances only --- include the characters @[a-zA-Z]@ --- --- >>> succ (AlphaChar 'z') --- 'A' -newtype AlphaChar = AlphaChar { getAlphaChar :: Char } - deriving stock Show - deriving (Eq, Ord) via Char - -instance Enum AlphaChar where - toEnum n - | between 0 25 n - = AlphaChar . toEnum $ n + fromEnum 'a' - | between 26 51 n - = AlphaChar . toEnum $ n - 26 + fromEnum 'A' - | otherwise - = error $ "Tag " <> show n <> " out of range [0, 51] for enum AlphaChar" - fromEnum (AlphaChar chr) - | between 'a' 'z' chr - = fromEnum chr - fromEnum 'a' - | between 'A' 'Z' chr - = fromEnum chr - fromEnum 'A' - | otherwise - = error $ "Invalid value for alpha char: " <> show chr - -instance Bounded AlphaChar where - minBound = AlphaChar 'a' - maxBound = AlphaChar 'Z' |