From a855d4546080dfe88c5d24cce7a3b9b2e741fcda Mon Sep 17 00:00:00 2001 From: Lennart Augustsson Date: Mon, 23 Sep 2024 01:07:41 +0200 Subject: [PATCH] Add missing files. --- lib/Data/Foldable1.hs | 571 ++++++++++++++++++++++++++++++++++++ lib/Data/Monoid/Internal.hs | 252 ++++++++++++++++ 2 files changed, 823 insertions(+) create mode 100644 lib/Data/Foldable1.hs create mode 100644 lib/Data/Monoid/Internal.hs diff --git a/lib/Data/Foldable1.hs b/lib/Data/Foldable1.hs new file mode 100644 index 00000000..28dd17b5 --- /dev/null +++ b/lib/Data/Foldable1.hs @@ -0,0 +1,571 @@ +-- | +-- Copyright: Edward Kmett, Oleg Grenrus +-- License: BSD-3-Clause +-- +-- A class of non-empty data structures that can be folded to a summary value. +-- +-- @since 4.18.0.0 + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Foldable1 ( + Foldable1(..), + foldr1, foldr1', + foldl1, foldl1', + intercalate1, + foldrM1, + foldlM1, + foldrMapM1, + foldlMapM1, + maximumBy, + minimumBy, + ) where +import Data.Foldable (Foldable, foldlM, foldr) +import Data.List ([](..), foldl, foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe +import Data.Semigroup +import Data.Tuple (Solo (..)) +import Prelude + (Maybe (..), Monad (..), Ord, Ordering (..), id, seq, ($!), ($), (.), + (=<<), flip, const, error) + +import qualified Data.List.NonEmpty as NE + +import Data.Complex (Complex (..)) + +import Data.Ord (Down (..)) + +import qualified Data.Monoid as Mon + +-- Instances +import Data.Functor.Compose (Compose (..)) +import Data.Functor.Identity (Identity (..)) + +import qualified Data.Functor.Product as Functor +import qualified Data.Functor.Sum as Functor + +-- coerce +--import GHC.Internal.Data.Coerce (Coercible, coerce) + +-- $setup +-- >>> import Prelude hiding (foldr1, foldl1, head, last, minimum, maximum) + +------------------------------------------------------------------------------- +-- Foldable1 type class +------------------------------------------------------------------------------- + +-- | Non-empty data structures that can be folded. +-- +-- @since 4.18.0.0 +class Foldable t => Foldable1 t where + {-# MINIMAL foldMap1 | foldrMap1 #-} + + -- At some point during design it was possible to define this class using + -- only 'toNonEmpty'. But it seems a bad idea in general. + -- + -- So currently we require either foldMap1 or foldrMap1 + -- + -- * foldMap1 defined using foldrMap1 + -- * foldrMap1 defined using foldMap1 + -- + -- One can always define an instance using the following pattern: + -- + -- toNonEmpty = ... + -- foldMap f = foldMap f . toNonEmpty + -- foldrMap1 f g = foldrMap1 f g . toNonEmpty + + -- | Given a structure with elements whose type is a 'Semigroup', combine + -- them via the semigroup's @('<>')@ operator. This fold is + -- right-associative and lazy in the accumulator. When you need a strict + -- left-associative fold, use 'foldMap1'' instead, with 'id' as the map. + -- + -- @since 4.18.0.0 + fold1 :: Semigroup m => t m -> m + fold1 = foldMap1 id + + -- | Map each element of the structure to a semigroup, and combine the + -- results with @('<>')@. This fold is right-associative and lazy in the + -- accumulator. For strict left-associative folds consider 'foldMap1'' + -- instead. + -- + -- >>> foldMap1 (:[]) (1 :| [2, 3, 4]) + -- [1,2,3,4] + -- + -- @since 4.18.0.0 + foldMap1 :: Semigroup m => (a -> m) -> t a -> m + foldMap1 f = foldrMap1 f (\a m -> f a <> m) + + -- | A left-associative variant of 'foldMap1' that is strict in the + -- accumulator. Use this for strict reduction when partial results are + -- merged via @('<>')@. + -- + -- >>> foldMap1' Sum (1 :| [2, 3, 4]) + -- Sum {getSum = 10} + -- + -- @since 4.18.0.0 + foldMap1' :: Semigroup m => (a -> m) -> t a -> m + foldMap1' f = foldlMap1' f (\m a -> m <> f a) + + -- | 'NonEmpty' list of elements of a structure, from left to right. + -- + -- >>> toNonEmpty (Identity 2) + -- 2 :| [] + -- + -- @since 4.18.0.0 + toNonEmpty :: t a -> NonEmpty a + toNonEmpty = runNonEmptyDList . foldMap1 singleton + + -- | The largest element of a non-empty structure. + -- + -- >>> maximum (32 :| [64, 8, 128, 16]) + -- 128 + -- + -- @since 4.18.0.0 + maximum :: Ord a => t a -> a + maximum = getMax . foldMap1' Max + + -- | The least element of a non-empty structure. + -- + -- >>> minimum (32 :| [64, 8, 128, 16]) + -- 8 + -- + -- @since 4.18.0.0 + minimum :: Ord a => t a -> a + minimum = getMin . foldMap1' Min + + -- | The first element of a non-empty structure. + -- + -- >>> head (1 :| [2, 3, 4]) + -- 1 + -- + -- @since 4.18.0.0 + head :: t a -> a + head = getFirst . foldMap1 First + + -- | The last element of a non-empty structure. + -- + -- >>> last (1 :| [2, 3, 4]) + -- 4 + -- + -- @since 4.18.0.0 + last :: t a -> a + last = getLast . foldMap1 Last + + -- | Right-associative fold of a structure, lazy in the accumulator. + -- + -- In case of 'NonEmpty' lists, 'foldrMap1', when given a function @f@, a + -- binary operator @g@, and a list, reduces the list using @g@ from right to + -- left applying @f@ to the rightmost element: + -- + -- > foldrMap1 f g (x1 :| [x2, ..., xn1, xn]) == x1 `g` (x2 `g` ... (xn1 `g` (f xn))...) + -- + -- Note that since the head of the resulting expression is produced by + -- an application of @g@ to the first element of the list, if @g@ is lazy + -- in its right argument, 'foldrMap1' can produce a terminating expression + -- from an unbounded list. + -- + -- For a general 'Foldable1' structure this should be semantically identical + -- to: + -- + -- @foldrMap1 f g = foldrMap1 f g . 'toNonEmpty'@ + -- + -- @since 4.18.0.0 + foldrMap1 :: (a -> b) -> (a -> b -> b) -> t a -> b + foldrMap1 f g xs = + appFromMaybe (foldMap1 (FromMaybe . h) xs) Nothing + where + h a Nothing = f a + h a (Just b) = g a b + + -- | Left-associative fold of a structure but with strict application of the + -- operator. + -- + -- This ensures that each step of the fold is forced to Weak Head Normal + -- Form before being applied, avoiding the collection of thunks that would + -- otherwise occur. This is often what you want to strictly reduce a + -- finite structure to a single strict result. + -- + -- For a general 'Foldable1' structure this should be semantically identical + -- to: + -- + -- @foldlMap1' f z = foldlMap1' f z . 'toNonEmpty'@ + -- + -- @since 4.18.0.0 + foldlMap1' :: (a -> b) -> (b -> a -> b) -> t a -> b + foldlMap1' f g xs = + foldrMap1 f' g' xs SNothing + where + -- f' :: a -> SMaybe b -> b + f' a SNothing = f a + f' a (SJust b) = g b a + + -- g' :: a -> (SMaybe b -> b) -> SMaybe b -> b + g' a x SNothing = x $! SJust (f a) + g' a x (SJust b) = x $! SJust (g b a) + + -- | Left-associative fold of a structure, lazy in the accumulator. This is + -- rarely what you want, but can work well for structures with efficient + -- right-to-left sequencing and an operator that is lazy in its left + -- argument. + -- + -- In case of 'NonEmpty' lists, 'foldlMap1', when given a function @f@, a + -- binary operator @g@, and a list, reduces the list using @g@ from left to + -- right applying @f@ to the leftmost element: + -- + -- > foldlMap1 f g (x1 :| [x2, ..., xn]) == (...(((f x1) `g` x2) `g`...) `g` xn + -- + -- Note that to produce the outermost application of the operator the entire + -- input list must be traversed. This means that 'foldlMap1' will diverge if + -- given an infinite list. + -- + -- If you want an efficient strict left-fold, you probably want to use + -- 'foldlMap1'' instead of 'foldlMap1'. The reason for this is that the + -- latter does not force the /inner/ results (e.g. @(f x1) \`g\` x2@ in the + -- above example) before applying them to the operator (e.g. to + -- @(\`g\` x3)@). This results in a thunk chain \(O(n)\) elements long, + -- which then must be evaluated from the outside-in. + -- + -- For a general 'Foldable1' structure this should be semantically identical + -- to: + -- + -- @foldlMap1 f g = foldlMap1 f g . 'toNonEmpty'@ + -- + -- @since 4.18.0.0 + foldlMap1 :: (a -> b) -> (b -> a -> b) -> t a -> b + foldlMap1 f g xs = + appFromMaybe (getDual (foldMap1 ((Dual . FromMaybe) . h) xs)) Nothing + where + h a Nothing = f a + h a (Just b) = g b a + + -- | 'foldrMap1'' is a variant of 'foldrMap1' that performs strict reduction + -- from right to left, i.e. starting with the right-most element. The input + -- structure /must/ be finite, otherwise 'foldrMap1'' runs out of space + -- (/diverges/). + -- + -- If you want a strict right fold in constant space, you need a structure + -- that supports faster than \(O(n)\) access to the right-most element. + -- + -- This method does not run in constant space for structures such as + -- 'NonEmpty' lists that don't support efficient right-to-left iteration and + -- so require \(O(n)\) space to perform right-to-left reduction. Use of this + -- method with such a structure is a hint that the chosen structure may be a + -- poor fit for the task at hand. If the order in which the elements are + -- combined is not important, use 'foldlMap1'' instead. + -- + -- @since 4.18.0.0 + foldrMap1' :: (a -> b) -> (a -> b -> b) -> t a -> b + foldrMap1' f g xs = + foldlMap1 f' g' xs SNothing + where + f' a SNothing = f a + f' a (SJust b) = g a b + + g' bb a SNothing = bb $! SJust (f a) + g' bb a (SJust b) = bb $! SJust (g a b) + +------------------------------------------------------------------------------- +-- Combinators +------------------------------------------------------------------------------- + +-- | A variant of 'foldrMap1' where the rightmost element maps to itself. +-- +-- @since 4.18.0.0 +foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a +foldr1 = foldrMap1 id +{-# INLINE foldr1 #-} + +-- | A variant of 'foldrMap1'' where the rightmost element maps to itself. +-- +-- @since 4.18.0.0 +foldr1' :: Foldable1 t => (a -> a -> a) -> t a -> a +foldr1' = foldrMap1' id +{-# INLINE foldr1' #-} + +-- | A variant of 'foldlMap1' where the leftmost element maps to itself. +-- +-- @since 4.18.0.0 +foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a +foldl1 = foldlMap1 id +{-# INLINE foldl1 #-} + +-- | A variant of 'foldlMap1'' where the leftmost element maps to itself. +-- +-- @since 4.18.0.0 +foldl1' :: Foldable1 t => (a -> a -> a) -> t a -> a +foldl1' = foldlMap1' id +{-# INLINE foldl1' #-} + +-- | Insert an @m@ between each pair of @t m@. +-- +-- >>> intercalate1 ", " $ "hello" :| ["how", "are", "you"] +-- "hello, how, are, you" +-- +-- >>> intercalate1 ", " $ "hello" :| [] +-- "hello" +-- +-- >>> intercalate1 mempty $ "I" :| ["Am", "Fine", "You?"] +-- "IAmFineYou?" +-- +-- @since 4.18.0.0 +intercalate1 :: (Foldable1 t, Semigroup m) => m -> t m -> m +intercalate1 = flip intercalateMap1 id + +intercalateMap1 :: (Foldable1 t, Semigroup m) => m -> (a -> m) -> t a -> m +intercalateMap1 j f = flip joinee j . foldMap1 (JoinWith . const . f) + +-- | Monadic fold over the elements of a non-empty structure, +-- associating to the right, i.e. from right to left. +-- +-- @since 4.18.0.0 +foldrM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a +foldrM1 = foldrMapM1 return + +-- | Map variant of 'foldrM1'. +-- +-- @since 4.18.0.0 +foldrMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (a -> b -> m b) -> t a -> m b +foldrMapM1 g f = go . toNonEmpty + where + go (e:|es) = + case es of + [] -> g e + x:xs -> f e =<< go (x:|xs) + +-- | Monadic fold over the elements of a non-empty structure, +-- associating to the left, i.e. from left to right. +-- +-- @since 4.18.0.0 +foldlM1 :: (Foldable1 t, Monad m) => (a -> a -> m a) -> t a -> m a +foldlM1 = foldlMapM1 return + +-- | Map variant of 'foldlM1'. +-- +-- @since 4.18.0.0 +foldlMapM1 :: (Foldable1 t, Monad m) => (a -> m b) -> (b -> a -> m b) -> t a -> m b +foldlMapM1 g f t = g x >>= \y -> foldlM f y xs + where x:|xs = toNonEmpty t + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. +-- +-- @since 4.18.0.0 +maximumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a +maximumBy cmp = foldl1' max' + where max' x y = case cmp x y of + GT -> x + _ -> y + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. +-- +-- @since 4.18.0.0 +minimumBy :: Foldable1 t => (a -> a -> Ordering) -> t a -> a +minimumBy cmp = foldl1' min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +------------------------------------------------------------------------------- +-- Auxiliary types +------------------------------------------------------------------------------- + +-- | Used for default toNonEmpty implementation. +newtype NonEmptyDList a = NEDL { unNEDL :: [a] -> NonEmpty a } + +instance Semigroup (NonEmptyDList a) where + xs <> ys = NEDL (unNEDL xs . NE.toList . unNEDL ys) + {-# INLINE (<>) #-} + +-- | Create dlist with a single element +singleton :: a -> NonEmptyDList a +singleton = NEDL . (:|) + +-- | Convert a dlist to a non-empty list +runNonEmptyDList :: NonEmptyDList a -> NonEmpty a +runNonEmptyDList = ($ []) . unNEDL +{-# INLINE runNonEmptyDList #-} + +-- | Used for foldrMap1 and foldlMap1 definitions +newtype FromMaybe b = FromMaybe { appFromMaybe :: Maybe b -> b } + +instance Semigroup (FromMaybe b) where + FromMaybe f <> FromMaybe g = FromMaybe (f . Just . g) + +-- | Strict maybe, used to implement default foldlMap1' etc. +data SMaybe a = SNothing | SJust !a + +-- | Used to implement intercalate1/Map +newtype JoinWith a = JoinWith {joinee :: (a -> a)} + +instance Semigroup a => Semigroup (JoinWith a) where + JoinWith a <> JoinWith b = JoinWith $ \j -> a j <> j <> b j + +------------------------------------------------------------------------------- +-- Instances for misc base types +------------------------------------------------------------------------------- + +-- | @since 4.18.0.0 +instance Foldable1 NonEmpty where + foldMap1 f (x :| xs) = go (f x) xs where + go y [] = y + go y (z : zs) = y <> go (f z) zs + + foldMap1' f (x :| xs) = foldl' (\m y -> m <> f y) (f x) xs + + toNonEmpty = id + + foldrMap1 g f (x :| xs) = go x xs where + go y [] = g y + go y (z : zs) = f y (go z zs) + + foldlMap1 g f (x :| xs) = foldl f (g x) xs + foldlMap1' g f (x :| xs) = let gx = g x in gx `seq` foldl' f gx xs + + head = NE.head + last = NE.last + +{- +-- | @since 4.18.0.0 +instance Foldable1 Down where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Complex where + foldMap1 f (x :+ y) = f x <> f y + + toNonEmpty (x :+ y) = x :| y : [] + +------------------------------------------------------------------------------- +-- Instances for tuples +------------------------------------------------------------------------------- + +-- 3+ tuples are not Foldable/Traversable + +-- | @since 4.18.0.0 +instance Foldable1 Solo where + foldMap1 f (MkSolo y) = f y + toNonEmpty (MkSolo x) = x :| [] + minimum (MkSolo x) = x + maximum (MkSolo x) = x + head (MkSolo x) = x + last (MkSolo x) = x + +-- | @since 4.18.0.0 +instance Foldable1 ((,) a) where + foldMap1 f (_, y) = f y + toNonEmpty (_, x) = x :| [] + minimum (_, x) = x + maximum (_, x) = x + head (_, x) = x + last (_, x) = x +-} + +------------------------------------------------------------------------------- +-- Monoid / Semigroup instances +------------------------------------------------------------------------------- + +{- +-- | @since 4.18.0.0 +instance Foldable1 Dual where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Sum where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Product where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Min where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Max where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 First where + foldMap1 = coerce + +-- | @since 4.18.0.0 +instance Foldable1 Last where + foldMap1 = coerce + +-- | @since 4.18.0.0 +deriving instance (Foldable1 f) => Foldable1 (Mon.Alt f) + +-- | @since 4.18.0.0 +deriving instance (Foldable1 f) => Foldable1 (Mon.Ap f) +-} + +------------------------------------------------------------------------------- +-- Extra instances +------------------------------------------------------------------------------- + +{- +-- | @since 4.18.0.0 +instance Foldable1 Identity where + foldMap1 = coerce + + foldrMap1 g _ = coerce g + foldrMap1' g _ = coerce g + foldlMap1 g _ = coerce g + foldlMap1' g _ = coerce g + + toNonEmpty (Identity x) = x :| [] + + last = coerce + head = coerce + minimum = coerce + maximum = coerce +-} + +-- | It would be enough for either half of a product to be 'Foldable1'. +-- Other could be 'Foldable'. +instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Product f g) where + foldMap1 f (Functor.Pair x y) = foldMap1 f x <> foldMap1 f y + foldrMap1 g f (Functor.Pair x y) = foldr f (foldrMap1 g f y) x + + head (Functor.Pair x _) = head x + last (Functor.Pair _ y) = last y + +-- | @since 4.18.0.0 +instance (Foldable1 f, Foldable1 g) => Foldable1 (Functor.Sum f g) where + foldMap1 f (Functor.InL x) = foldMap1 f x + foldMap1 f (Functor.InR y) = foldMap1 f y + + foldrMap1 g f (Functor.InL x) = foldrMap1 g f x + foldrMap1 g f (Functor.InR y) = foldrMap1 g f y + + toNonEmpty (Functor.InL x) = toNonEmpty x + toNonEmpty (Functor.InR y) = toNonEmpty y + + head (Functor.InL x) = head x + head (Functor.InR y) = head y + last (Functor.InL x) = last x + last (Functor.InR y) = last y + + minimum (Functor.InL x) = minimum x + minimum (Functor.InR y) = minimum y + maximum (Functor.InL x) = maximum x + maximum (Functor.InR y) = maximum y + +-- | @since 4.18.0.0 +instance (Foldable1 f, Foldable1 g) => Foldable1 (Compose f g) where + foldMap1 f = foldMap1 (foldMap1 f) . getCompose + + foldrMap1 f g = foldrMap1 (foldrMap1 f g) (\xs x -> foldr g x xs) . getCompose + + head = head . head . getCompose + last = last . last . getCompose diff --git a/lib/Data/Monoid/Internal.hs b/lib/Data/Monoid/Internal.hs new file mode 100644 index 00000000..2a02cd86 --- /dev/null +++ b/lib/Data/Monoid/Internal.hs @@ -0,0 +1,252 @@ +module Data.Monoid.Internal(module Data.Monoid.Internal) where +import Prelude() -- do not import Prelude +import Primitives +import Control.Applicative +import Control.Error +import Data.Bool +import Data.Bounded +import Data.Eq +import Data.Function +import Data.Functor +import Data.Int +import Data.Integral +import Data.List_Type +import Data.List.NonEmpty_Type +import Data.Ord +import Data.Maybe_Type +import Data.Num +import Text.Show + +class Semigroup a => Monoid a where + mempty :: a + mappend :: a -> a -> a + mappend = (<>) + mconcat :: [a] -> a + mconcat [] = mempty + mconcat (a:as) = a <> mconcat as + +--------------------- + +newtype Endo a = Endo (a -> a) +appEndo :: forall a . Endo a -> (a -> a) +appEndo (Endo f) = f + +instance forall a . Semigroup (Endo a) where + Endo f <> Endo g = Endo (f . g) + +instance forall a . Monoid (Endo a) where + mempty = Endo id + +--------------------- + +newtype Dual a = Dual a +getDual :: forall a . Dual a -> a +getDual (Dual a) = a + +instance forall a . Semigroup a => Semigroup (Dual a) where + Dual a <> Dual b = Dual (b <> a) + +instance forall a . Monoid a => Monoid (Dual a) where + mempty = Dual mempty + +instance Functor Dual where + fmap f (Dual a) = Dual (f a) + +instance Applicative Dual where + pure = Dual + Dual f <*> Dual b = Dual (f b) + +--------------------- + +newtype Max a = Max a +getMax :: forall a . Max a -> a +getMax (Max a) = a + +instance forall a . Ord a => Semigroup (Max a) where + Max a <> Max b = Max (a `max` b) + +instance forall a . (Ord a, Bounded a) => Monoid (Max a) where + mempty = Max minBound + +--------------------- + +newtype Min a = Min a +getMin :: forall a . Min a -> a +getMin (Min a) = a + +instance forall a . Ord a => Semigroup (Min a) where + Min a <> Min b = Min (a `min` b) + +instance forall a . (Ord a, Bounded a) => Monoid (Min a) where + mempty = Min maxBound + +--------------------- + +newtype Sum a = Sum a +getSum :: forall a . Sum a -> a +getSum (Sum a) = a + +instance forall a . Num a => Semigroup (Sum a) where + Sum a <> Sum b = Sum (a + b) + +instance forall a . (Num a) => Monoid (Sum a) where + mempty = Sum 0 + +--------------------- + +newtype Product a = Product a +getProduct :: forall a . Product a -> a +getProduct (Product a) = a + +instance forall a . Num a => Semigroup (Product a) where + Product a <> Product b = Product (a * b) + +instance forall a . (Num a) => Monoid (Product a) where + mempty = Product 1 + +--------------------- + +newtype All = All Bool +getAll :: All -> Bool +getAll (All a) = a + +instance Semigroup All where + All a <> All b = All (a && b) + +instance Monoid All where + mempty = All True + +--------------------- + +newtype Any = Any Bool +getAny :: Any -> Bool +getAny (Any a) = a + +instance Semigroup Any where + Any a <> Any b = Any (a || b) + +instance Monoid Any where + mempty = Any False + +--------------------- + +instance Semigroup Ordering where + LT <> _ = LT + EQ <> o = o + GT <> _ = GT + +instance Monoid Ordering where + mempty = EQ + +---------------------- + +data Arg a b = Arg a b + deriving(Show) + +type ArgMin a b = Min (Arg a b) + +type ArgMax a b = Max (Arg a b) + +instance Functor (Arg a) where + fmap f (Arg x a) = Arg x (f a) + +instance Eq a => Eq (Arg a b) where + Arg a _ == Arg b _ = a == b + +instance Ord a => Ord (Arg a b) where + Arg a _ `compare` Arg b _ = compare a b + min x@(Arg a _) y@(Arg b _) + | a <= b = x + | otherwise = y + max x@(Arg a _) y@(Arg b _) + | a >= b = x + | otherwise = y + +---------------------- + +newtype Alt f a = Alt (f a) +-- deriving (Show) +getAlt :: Alt f a -> f a +getAlt (Alt x) = x +{- + deriving ( Generic -- ^ @since base-4.8.0.0 + , Generic1 -- ^ @since base-4.8.0.0 + , Read -- ^ @since base-4.8.0.0 + , Show -- ^ @since base-4.8.0.0 + , Eq -- ^ @since base-4.8.0.0 + , Ord -- ^ @since base-4.8.0.0 + , Num -- ^ @since base-4.8.0.0 + , Enum -- ^ @since base-4.8.0.0 + , Monad -- ^ @since base-4.8.0.0 + , MonadPlus -- ^ @since base-4.8.0.0 + , Applicative -- ^ @since base-4.8.0.0 + , Alternative -- ^ @since base-4.8.0.0 + , Functor -- ^ @since base-4.8.0.0 + ) +-} + +instance Alternative f => Semigroup (Alt f a) where + Alt x <> Alt y = Alt (x <|> y) + stimes = stimesMonoid + +instance Alternative f => Monoid (Alt f a) where + mempty = Alt empty + +---------------------- + +-- This really belongs in Data.Semigroup, +-- but some functions have Monoid as in the context. + +infixr 6 <> +class Semigroup a where + (<>) :: a -> a -> a + sconcat :: NonEmpty a -> a + stimes :: (Integral b, Ord b) => b -> a -> a + + sconcat (a :| as) = go a as + where go b (c:cs) = b <> go c cs + go b [] = b + + stimes y0 x0 + | y0 <= 0 = error "stimes: positive multiplier expected" + | otherwise = f x0 y0 + where + f x y + | y `rem` 2 == 0 = f (x <> x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x <> x) (y `quot` 2) x + g x y z + | y `rem` 2 == 0 = g (x <> x) (y `quot` 2) z + | y == 1 = x <> z + | otherwise = g (x <> x) (y `quot` 2) (x <> z) + +stimesIdempotent :: (Integral b, Ord b) => b -> a -> a +stimesIdempotent n x = + if n <= 0 then error "stimesIdempotent: positive multiplier expected" + else x + +stimesIdempotentMonoid :: (Ord b, Integral b, Monoid a) => b -> a -> a +stimesIdempotentMonoid n x = case compare n 0 of + LT -> error "stimesIdempotentMonoid: negative multiplier" + EQ -> mempty + GT -> x + +stimesMonoid :: (Ord b, Integral b, Monoid a) => b -> a -> a +stimesMonoid n x0 = case compare n 0 of + LT -> error "stimesMonoid: negative multiplier" + EQ -> mempty + GT -> f x0 n + where + f x y + | even y = f (x `mappend` x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x `mappend` x) (y `quot` 2) x + g x y z + | even y = g (x `mappend` x) (y `quot` 2) z + | y == 1 = x `mappend` z + | otherwise = g (x `mappend` x) (y `quot` 2) (x `mappend` z) + +--------------------- + +instance (Semigroup b) => Semigroup (a -> b) where + f <> g = \ x -> f x <> g x