1{-# LANGUAGE NoImplicitPrelude #-} 2{-# LANGUAGE DeriveGeneric #-} 3{-# LANGUAGE GeneralizedNewtypeDeriving #-} 4{-# LANGUAGE PolyKinds #-} 5{-# LANGUAGE ScopedTypeVariables #-} 6 7-- | Auxilary definitions for 'Semigroup' 8-- 9-- This module provides some @newtype@ wrappers and helpers which are 10-- reexported from the "Data.Semigroup" module or imported directly 11-- by some other modules. 12-- 13-- This module also provides internal definitions related to the 14-- 'Semigroup' class some. 15-- 16-- This module exists mostly to simplify or workaround import-graph 17-- issues; there is also a .hs-boot file to allow "GHC.Base" and other 18-- modules to import method default implementations for 'stimes' 19-- 20-- @since 4.11.0.0 21module Data.Semigroup.Internal where 22 23import GHC.Base hiding (Any) 24import GHC.Enum 25import GHC.Num 26import GHC.Read 27import GHC.Show 28import GHC.Generics 29import GHC.Real 30 31-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'. 32-- 33-- When @x <> x = x@, this definition should be preferred, because it 34-- works in \(\mathcal{O}(1)\) rather than \(\mathcal{O}(\log n)\). 35stimesIdempotent :: Integral b => b -> a -> a 36stimesIdempotent n x 37 | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected" 38 | otherwise = x 39 40-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. 41-- 42-- When @mappend x x = x@, this definition should be preferred, because it 43-- works in \(\mathcal{O}(1)\) rather than \(\mathcal{O}(\log n)\) 44stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a 45stimesIdempotentMonoid n x = case compare n 0 of 46 LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier" 47 EQ -> mempty 48 GT -> x 49 50-- | This is a valid definition of 'stimes' for a 'Monoid'. 51-- 52-- Unlike the default definition of 'stimes', it is defined for 0 53-- and so it should be preferred where possible. 54stimesMonoid :: (Integral b, Monoid a) => b -> a -> a 55stimesMonoid n x0 = case compare n 0 of 56 LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier" 57 EQ -> mempty 58 GT -> f x0 n 59 where 60 f x y 61 | even y = f (x `mappend` x) (y `quot` 2) 62 | y == 1 = x 63 | otherwise = g (x `mappend` x) (y `quot` 2) x -- See Note [Half of y - 1] 64 g x y z 65 | even y = g (x `mappend` x) (y `quot` 2) z 66 | y == 1 = x `mappend` z 67 | otherwise = g (x `mappend` x) (y `quot` 2) (x `mappend` z) -- See Note [Half of y - 1] 68 69-- this is used by the class definitionin GHC.Base; 70-- it lives here to avoid cycles 71stimesDefault :: (Integral b, Semigroup a) => b -> a -> a 72stimesDefault y0 x0 73 | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" 74 | otherwise = f x0 y0 75 where 76 f x y 77 | even y = f (x <> x) (y `quot` 2) 78 | y == 1 = x 79 | otherwise = g (x <> x) (y `quot` 2) x -- See Note [Half of y - 1] 80 g x y z 81 | even y = g (x <> x) (y `quot` 2) z 82 | y == 1 = x <> z 83 | otherwise = g (x <> x) (y `quot` 2) (x <> z) -- See Note [Half of y - 1] 84 85{- Note [Half of y - 1] 86 ~~~~~~~~~~~~~~~~~~~~~ 87 Since y is guaranteed to be odd and positive here, 88 half of y - 1 can be computed as y `quot` 2, optimising subtraction away. 89-} 90 91stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a 92stimesMaybe _ Nothing = Nothing 93stimesMaybe n (Just a) = case compare n 0 of 94 LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" 95 EQ -> Nothing 96 GT -> Just (stimes n a) 97 98stimesList :: Integral b => b -> [a] -> [a] 99stimesList n x 100 | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier" 101 | otherwise = rep n 102 where 103 rep 0 = [] 104 rep i = x ++ rep (i - 1) 105 106-- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'. 107-- 108-- >>> getDual (mappend (Dual "Hello") (Dual "World")) 109-- "WorldHello" 110newtype Dual a = Dual { getDual :: a } 111 deriving ( Eq -- ^ @since 2.01 112 , Ord -- ^ @since 2.01 113 , Read -- ^ @since 2.01 114 , Show -- ^ @since 2.01 115 , Bounded -- ^ @since 2.01 116 , Generic -- ^ @since 4.7.0.0 117 , Generic1 -- ^ @since 4.7.0.0 118 ) 119 120-- | @since 4.9.0.0 121instance Semigroup a => Semigroup (Dual a) where 122 Dual a <> Dual b = Dual (b <> a) 123 stimes n (Dual a) = Dual (stimes n a) 124 125-- | @since 2.01 126instance Monoid a => Monoid (Dual a) where 127 mempty = Dual mempty 128 129-- | @since 4.8.0.0 130instance Functor Dual where 131 fmap = coerce 132 133-- | @since 4.8.0.0 134instance Applicative Dual where 135 pure = Dual 136 (<*>) = coerce 137 138-- | @since 4.8.0.0 139instance Monad Dual where 140 m >>= k = k (getDual m) 141 142-- | The monoid of endomorphisms under composition. 143-- 144-- >>> let computation = Endo ("Hello, " ++) <> Endo (++ "!") 145-- >>> appEndo computation "Haskell" 146-- "Hello, Haskell!" 147newtype Endo a = Endo { appEndo :: a -> a } 148 deriving ( Generic -- ^ @since 4.7.0.0 149 ) 150 151-- | @since 4.9.0.0 152instance Semigroup (Endo a) where 153 (<>) = coerce ((.) :: (a -> a) -> (a -> a) -> (a -> a)) 154 stimes = stimesMonoid 155 156-- | @since 2.01 157instance Monoid (Endo a) where 158 mempty = Endo id 159 160-- | Boolean monoid under conjunction ('&&'). 161-- 162-- >>> getAll (All True <> mempty <> All False) 163-- False 164-- 165-- >>> getAll (mconcat (map (\x -> All (even x)) [2,4,6,7,8])) 166-- False 167newtype All = All { getAll :: Bool } 168 deriving ( Eq -- ^ @since 2.01 169 , Ord -- ^ @since 2.01 170 , Read -- ^ @since 2.01 171 , Show -- ^ @since 2.01 172 , Bounded -- ^ @since 2.01 173 , Generic -- ^ @since 4.7.0.0 174 ) 175 176-- | @since 4.9.0.0 177instance Semigroup All where 178 (<>) = coerce (&&) 179 stimes = stimesIdempotentMonoid 180 181-- | @since 2.01 182instance Monoid All where 183 mempty = All True 184 185-- | Boolean monoid under disjunction ('||'). 186-- 187-- >>> getAny (Any True <> mempty <> Any False) 188-- True 189-- 190-- >>> getAny (mconcat (map (\x -> Any (even x)) [2,4,6,7,8])) 191-- True 192newtype Any = Any { getAny :: Bool } 193 deriving ( Eq -- ^ @since 2.01 194 , Ord -- ^ @since 2.01 195 , Read -- ^ @since 2.01 196 , Show -- ^ @since 2.01 197 , Bounded -- ^ @since 2.01 198 , Generic -- ^ @since 4.7.0.0 199 ) 200 201-- | @since 4.9.0.0 202instance Semigroup Any where 203 (<>) = coerce (||) 204 stimes = stimesIdempotentMonoid 205 206-- | @since 2.01 207instance Monoid Any where 208 mempty = Any False 209 210-- | Monoid under addition. 211-- 212-- >>> getSum (Sum 1 <> Sum 2 <> mempty) 213-- 3 214newtype Sum a = Sum { getSum :: a } 215 deriving ( Eq -- ^ @since 2.01 216 , Ord -- ^ @since 2.01 217 , Read -- ^ @since 2.01 218 , Show -- ^ @since 2.01 219 , Bounded -- ^ @since 2.01 220 , Generic -- ^ @since 4.7.0.0 221 , Generic1 -- ^ @since 4.7.0.0 222 , Num -- ^ @since 4.7.0.0 223 ) 224 225-- | @since 4.9.0.0 226instance Num a => Semigroup (Sum a) where 227 (<>) = coerce ((+) :: a -> a -> a) 228 stimes n (Sum a) = Sum (fromIntegral n * a) 229 230-- | @since 2.01 231instance Num a => Monoid (Sum a) where 232 mempty = Sum 0 233 234-- | @since 4.8.0.0 235instance Functor Sum where 236 fmap = coerce 237 238-- | @since 4.8.0.0 239instance Applicative Sum where 240 pure = Sum 241 (<*>) = coerce 242 243-- | @since 4.8.0.0 244instance Monad Sum where 245 m >>= k = k (getSum m) 246 247-- | Monoid under multiplication. 248-- 249-- >>> getProduct (Product 3 <> Product 4 <> mempty) 250-- 12 251newtype Product a = Product { getProduct :: a } 252 deriving ( Eq -- ^ @since 2.01 253 , Ord -- ^ @since 2.01 254 , Read -- ^ @since 2.01 255 , Show -- ^ @since 2.01 256 , Bounded -- ^ @since 2.01 257 , Generic -- ^ @since 4.7.0.0 258 , Generic1 -- ^ @since 4.7.0.0 259 , Num -- ^ @since 4.7.0.0 260 ) 261 262-- | @since 4.9.0.0 263instance Num a => Semigroup (Product a) where 264 (<>) = coerce ((*) :: a -> a -> a) 265 stimes n (Product a) = Product (a ^ n) 266 267 268-- | @since 2.01 269instance Num a => Monoid (Product a) where 270 mempty = Product 1 271 272-- | @since 4.8.0.0 273instance Functor Product where 274 fmap = coerce 275 276-- | @since 4.8.0.0 277instance Applicative Product where 278 pure = Product 279 (<*>) = coerce 280 281-- | @since 4.8.0.0 282instance Monad Product where 283 m >>= k = k (getProduct m) 284 285 286-- | Monoid under '<|>'. 287-- 288-- >>> getAlt (Alt (Just 12) <> Alt (Just 24)) 289-- Just 12 290-- 291-- >>> getAlt $ Alt Nothing <> Alt (Just 24) 292-- Just 24 293-- 294-- @since 4.8.0.0 295newtype Alt f a = Alt {getAlt :: f a} 296 deriving ( Generic -- ^ @since 4.8.0.0 297 , Generic1 -- ^ @since 4.8.0.0 298 , Read -- ^ @since 4.8.0.0 299 , Show -- ^ @since 4.8.0.0 300 , Eq -- ^ @since 4.8.0.0 301 , Ord -- ^ @since 4.8.0.0 302 , Num -- ^ @since 4.8.0.0 303 , Enum -- ^ @since 4.8.0.0 304 , Monad -- ^ @since 4.8.0.0 305 , MonadPlus -- ^ @since 4.8.0.0 306 , Applicative -- ^ @since 4.8.0.0 307 , Alternative -- ^ @since 4.8.0.0 308 , Functor -- ^ @since 4.8.0.0 309 ) 310 311-- | @since 4.9.0.0 312instance Alternative f => Semigroup (Alt f a) where 313 (<>) = coerce ((<|>) :: f a -> f a -> f a) 314 stimes = stimesMonoid 315 316-- | @since 4.8.0.0 317instance Alternative f => Monoid (Alt f a) where 318 mempty = Alt empty 319