1{-# LANGUAGE CPP #-} 2#if !(MIN_VERSION_base(4,9,0)) 3{-# LANGUAGE DefaultSignatures #-} 4{-# LANGUAGE DeriveGeneric #-} 5{-# LANGUAGE DeriveDataTypeable #-} 6#endif 7module Basement.Compat.Semigroup 8 ( Semigroup(..) 9 , ListNonEmpty(..) 10 ) where 11 12#if MIN_VERSION_base(4,9,0) 13import Data.Semigroup 14import qualified Data.List.NonEmpty as LNE 15 16type ListNonEmpty = LNE.NonEmpty 17#else 18import Prelude 19import Data.Data (Data) 20import Data.Monoid (Monoid(..)) 21import GHC.Generics (Generic) 22import Data.Typeable 23 24-- errorWithoutStackTrace 25 26infixr 6 <> 27infixr 5 :| 28 29data ListNonEmpty a = a :| [a] 30 deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic ) 31 32-- | The class of semigroups (types with an associative binary operation). 33-- 34-- @since 4.9.0.0 35class Semigroup a where 36 -- | An associative operation. 37 -- 38 -- @ 39 -- (a '<>' b) '<>' c = a '<>' (b '<>' c) 40 -- @ 41 -- 42 -- If @a@ is also a 'Monoid' we further require 43 -- 44 -- @ 45 -- ('<>') = 'mappend' 46 -- @ 47 (<>) :: a -> a -> a 48 49 default (<>) :: Monoid a => a -> a -> a 50 (<>) = mappend 51 52 -- | Reduce a non-empty list with @\<\>@ 53 -- 54 -- The default definition should be sufficient, but this can be 55 -- overridden for efficiency. 56 -- 57 sconcat :: ListNonEmpty a -> a 58 sconcat (a :| as) = go a as where 59 go b (c:cs) = b <> go c cs 60 go b [] = b 61 62 -- | Repeat a value @n@ times. 63 -- 64 -- Given that this works on a 'Semigroup' it is allowed to fail if 65 -- you request 0 or fewer repetitions, and the default definition 66 -- will do so. 67 -- 68 -- By making this a member of the class, idempotent semigroups and monoids can 69 -- upgrade this to execute in /O(1)/ by picking 70 -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@ 71 -- respectively. 72 stimes :: Integral b => b -> a -> a 73 stimes y0 x0 74 | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected" 75 | otherwise = f x0 y0 76 where 77 f x y 78 | even y = f (x <> x) (y `quot` 2) 79 | y == 1 = x 80 | otherwise = g (x <> x) (pred y `quot` 2) x 81 g x y z 82 | even y = g (x <> x) (y `quot` 2) z 83 | y == 1 = x <> z 84 | otherwise = g (x <> x) (pred y `quot` 2) (x <> z) 85 86instance Semigroup a => Semigroup (Maybe a) where 87 Nothing <> b = b 88 a <> Nothing = a 89 Just a <> Just b = Just (a <> b) 90 stimes _ Nothing = Nothing 91 stimes n (Just a) = case compare n 0 of 92 LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier" 93 EQ -> Nothing 94 GT -> Just (stimes n a) 95 96instance Semigroup [a] where 97 (<>) = (++) 98 99instance Semigroup (Either a b) where 100 Left _ <> b = b 101 a <> _ = a 102 stimes = stimesIdempotent 103 104instance (Semigroup a, Semigroup b) => Semigroup (a, b) where 105 (a,b) <> (a',b') = (a<>a',b<>b') 106 stimes n (a,b) = (stimes n a, stimes n b) 107 108instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where 109 (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c') 110 stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c) 111 112instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d) 113 => Semigroup (a, b, c, d) where 114 (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d') 115 stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d) 116 117instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e) 118 => Semigroup (a, b, c, d, e) where 119 (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e') 120 stimes n (a,b,c,d,e) = 121 (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e) 122 123-- | This is a valid definition of 'stimes' for a 'Monoid'. 124-- 125-- Unlike the default definition of 'stimes', it is defined for 0 126-- and so it should be preferred where possible. 127stimesMonoid :: (Integral b, Monoid a) => b -> a -> a 128stimesMonoid n x0 = case compare n 0 of 129 LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier" 130 EQ -> mempty 131 GT -> f x0 n 132 where 133 f x y 134 | even y = f (x `mappend` x) (y `quot` 2) 135 | y == 1 = x 136 | otherwise = g (x `mappend` x) (pred y `quot` 2) x 137 g x y z 138 | even y = g (x `mappend` x) (y `quot` 2) z 139 | y == 1 = x `mappend` z 140 | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z) 141 142-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'. 143-- 144-- When @mappend x x = x@, this definition should be preferred, because it 145-- works in /O(1)/ rather than /O(log n)/ 146stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a 147stimesIdempotentMonoid n x = case compare n 0 of 148 LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier" 149 EQ -> mempty 150 GT -> x 151 152-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'. 153-- 154-- When @x <> x = x@, this definition should be preferred, because it 155-- works in /O(1)/ rather than /O(log n)/. 156stimesIdempotent :: Integral b => b -> a -> a 157stimesIdempotent n x 158 | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected" 159 | otherwise = x 160 161#if !MIN_VERSION_base(4,9,0) 162errorWithoutStackTrace = error 163#endif 164 165#endif 166