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