/
OneLiner.hs
397 lines (363 loc) · 13.8 KB
/
OneLiner.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
-----------------------------------------------------------------------------
-- |
-- Module : Generics.OneLiner
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : sjoerd@w3future.com
-- Stability : experimental
-- Portability : non-portable
--
-- All functions without postfix are for instances of `Generic`, and functions
-- with postfix @1@ are for instances of `Generic1` (with kind @* -> *@) which
-- get an extra argument to specify how to deal with the parameter.
-- Functions with postfix @01@ are also for `Generic1` but they get yet another
-- argument that, like the `Generic` functions, allows handling of constant leaves.
-- The function `createA_` does not require any such instance, but must be given
-- a constructor explicitly.
-----------------------------------------------------------------------------
{-# LANGUAGE
RankNTypes
, Trustworthy
, TypeFamilies
, ConstraintKinds
, FlexibleContexts
, TypeApplications
, AllowAmbiguousTypes
, ScopedTypeVariables
#-}
module Generics.OneLiner (
-- * Producing values
create, createA, ctorIndex,
create1, createA1, ctorIndex1,
createA_,
-- * Traversing values
gmap, gfoldMap, gtraverse,
gmap1, gfoldMap1, gtraverse1,
-- * Combining values
mzipWith, mzipWith', zipWithA,
mzipWith1, mzipWith1', zipWithA1,
Zip(..),
-- * Consuming values
consume, consume1,
-- * Functions for records
-- | These functions only work for single constructor data types.
nullaryOp, unaryOp, binaryOp, createA', algebra, dialgebra,
createA1', gcotraverse1,
-- * Generic programming with profunctors
-- | All the above functions have been implemented using these functions,
-- using different `profunctor`s.
record, nonEmpty, generic,
record1, nonEmpty1, generic1,
record01, nonEmpty01, generic01,
-- ** Classes
GenericRecordProfunctor,
GenericNonEmptyProfunctor,
GenericProfunctor,
GenericUnitProfunctor(..),
GenericProductProfunctor(..),
GenericSumProfunctor(..),
GenericEmptyProfunctor(..),
-- * Types
ADT, ADTNonEmpty, ADTRecord, Constraints,
ADT1, ADTNonEmpty1, ADTRecord1, Constraints1, Constraints01,
FunConstraints, FunResult,
AnyType
) where
import GHC.Generics
import Control.Applicative
import Data.Bifunctor.Biff
import Data.Bifunctor.Clown
import Data.Bifunctor.Joker
import Data.Functor.Compose
import Data.Functor.Contravariant.Divisible
import Data.Profunctor
import Data.Tagged
import Generics.OneLiner.Internal
-- | Create a value (one for each constructor), given how to construct the components.
--
-- @
-- `minBound` = `head` `$` `create` \@`Bounded` [`minBound`]
-- `maxBound` = `last` `$` `create` \@`Bounded` [`maxBound`]
-- @
--
-- `create` is `createA` specialized to lists.
create :: forall c t. (ADT t, Constraints t c)
=> (forall s. c s => [s]) -> [t]
create = createA @c
{-# INLINE create #-}
-- | Create a value (one for each constructor), given how to construct the components, under an applicative effect.
--
-- Here's how to implement `get` from the `binary` package, first encoding the
-- constructor in a byte:
--
-- @
-- get = getWord8 `>>=` \\ix -> `getCompose` (`createA` \@Binary (`Compose` [get])) `!!` `fromEnum` ix
-- @
--
-- `createA` is `generic` specialized to `Joker`.
createA :: forall c t f. (ADT t, Constraints t c, Alternative f)
=> (forall s. c s => f s) -> f t
createA f = runJoker $ generic @c $ Joker f
{-# INLINE createA #-}
-- | Generate ways to consume values of type `t`. This is the contravariant version of `createA`.
--
-- `consume` is `generic` specialized to `Clown`.
consume :: forall c t f. (ADT t, Constraints t c, Decidable f)
=> (forall s. c s => f s) -> f t
consume f = runClown $ generic @c $ Clown f
{-# INLINE consume #-}
-- | `create1` is `createA1` specialized to lists.
create1 :: forall c t a. (ADT1 t, Constraints1 t c)
=> (forall b s. c s => [b] -> [s b]) -> [a] -> [t a]
create1 = createA1 @c
{-# INLINE create1 #-}
-- | `createA1` is `generic1` specialized to `Joker`.
createA1 :: forall c t f a. (ADT1 t, Constraints1 t c, Alternative f)
=> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a)
createA1 f = dimap Joker runJoker $ generic1 @c $ dimap runJoker Joker f
{-# INLINE createA1 #-}
-- | Create a value, given a constructor (or a function) and
-- how to construct its components, under an applicative effect.
--
-- For example, this is the implementation of `Test.QuickCheck.arbitrary` for a
-- type with a single constructor (e.g., quadruples @(,,,)@).
--
-- @
-- arbitrary = `createA_` \@`Arbitrary` arbitrary (,,,)
-- @
createA_ :: forall c t f. (FunConstraints c t, Applicative f)
=> (forall s. c s => f s) -> t -> f (FunResult t)
createA_ run = autoApply @c run . pure
{-# INLINE createA_ #-}
-- | `consume1` is `generic1` specialized to `Clown`.
consume1 :: forall c t f a. (ADT1 t, Constraints1 t c, Decidable f)
=> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a)
consume1 f = dimap Clown runClown $ generic1 @c $ dimap runClown Clown f
{-# INLINE consume1 #-}
-- | Map over a structure, updating each component.
--
-- `gmap` is `generic` specialized to @(->)@.
gmap :: forall c t. (ADT t, Constraints t c)
=> (forall s. c s => s -> s) -> t -> t
gmap = generic @c
{-# INLINE gmap #-}
-- | Map each component of a structure to a monoid, and combine the results.
--
-- If you have a class `Size`, which measures the size of a structure, then this could be the default implementation:
--
-- @
-- size = `succ` `.` `getSum` `.` `gfoldMap` \@`Size` (`Sum` `.` size)
-- @
--
-- `gfoldMap` is `gtraverse` specialized to `Const`.
gfoldMap :: forall c t m. (ADT t, Constraints t c, Monoid m)
=> (forall s. c s => s -> m) -> t -> m
gfoldMap f = getConst . gtraverse @c (Const . f)
{-# INLINE gfoldMap #-}
-- | Map each component of a structure to an action, evaluate these actions from left to right, and collect the results.
--
-- `gtraverse` is `generic` specialized to `Star`.
gtraverse :: forall c t f. (ADT t, Constraints t c, Applicative f)
=> (forall s. c s => s -> f s) -> t -> f t
gtraverse f = runStar $ generic @c $ Star f
{-# INLINE gtraverse #-}
-- |
-- @
-- fmap = `gmap1` \@`Functor` `fmap`
-- @
--
-- `gmap1` is `generic1` specialized to @(->)@.
gmap1 :: forall c t a b. (ADT1 t, Constraints1 t c)
=> (forall d e s. c s => (d -> e) -> s d -> s e) -> (a -> b) -> t a -> t b
gmap1 = generic1 @c
{-# INLINE gmap1 #-}
-- |
-- @
-- foldMap = `gfoldMap1` \@`Foldable` `foldMap`
-- @
--
-- `gfoldMap1` is `gtraverse1` specialized to `Const`.
gfoldMap1 :: forall c t m a. (ADT1 t, Constraints1 t c, Monoid m)
=> (forall s b. c s => (b -> m) -> s b -> m) -> (a -> m) -> t a -> m
gfoldMap1 f = dimap (Const .) (getConst .) $ gtraverse1 @c $ dimap (getConst .) (Const .) f
{-# INLINE gfoldMap1 #-}
-- |
-- @
-- traverse = `gtraverse1` \@`Traversable` `traverse`
-- @
--
-- `gtraverse1` is `generic1` specialized to `Star`.
gtraverse1 :: forall c t f a b. (ADT1 t, Constraints1 t c, Applicative f)
=> (forall d e s. c s => (d -> f e) -> s d -> f (s e)) -> (a -> f b) -> t a -> f (t b)
gtraverse1 f = dimap Star runStar $ generic1 @c $ dimap runStar Star f
{-# INLINE gtraverse1 #-}
-- | Combine two values by combining each component of the structures to a monoid, and combine the results.
-- Returns `mempty` if the constructors don't match.
--
-- @
-- `compare` s t = `compare` (`ctorIndex` s) (`ctorIndex` t) `<>` `mzipWith` \@`Ord` `compare` s t
-- @
--
-- `mzipWith` is `zipWithA` specialized to @`Compose` `Maybe` (`Const` m)@
mzipWith :: forall c t m. (ADT t, Constraints t c, Monoid m)
=> (forall s. c s => s -> s -> m) -> t -> t -> m
mzipWith = mzipWith' @c mempty
{-# INLINE mzipWith #-}
-- | Variant of `mzipWith` where you can choose the value which is returned
-- when the constructors don't match.
--
-- @
-- `compare` s t = `mzipWith'` \@`Ord` (`compare` (`ctorIndex` s) (`ctorIndex` t)) `compare` s t
-- @
mzipWith' :: forall c t m. (ADT t, Constraints t c, Monoid m)
=> m -> (forall s. c s => s -> s -> m) -> t -> t -> m
mzipWith' m f = outm2 m $ zipWithA @c $ inm2 f
{-# INLINE mzipWith' #-}
-- | Combine two values by combining each component of the structures with the given function, under an applicative effect.
-- Returns `empty` if the constructors don't match.
--
-- `zipWithA` is `generic` specialized to `Zip`
zipWithA :: forall c t f. (ADT t, Constraints t c, Alternative f)
=> (forall s. c s => s -> s -> f s) -> t -> t -> f t
zipWithA f = runZip $ generic @c $ Zip f
{-# INLINE zipWithA #-}
-- |
-- @
-- `liftCompare` = `mzipWith1` \@`Ord1` `liftCompare`
-- @
--
-- `mzipWith1` is `zipWithA1` specialized to @`Compose` `Maybe` (`Const` m)@
mzipWith1 :: forall c t m a. (ADT1 t, Constraints1 t c, Monoid m)
=> (forall s b. c s => (b -> b -> m) -> s b -> s b -> m)
-> (a -> a -> m) -> t a -> t a -> m
mzipWith1 = mzipWith1' @c mempty
{-# INLINE mzipWith1 #-}
-- | Variant of `mzipWith1` where you can choose the value which is returned
-- when the constructors don't match.
mzipWith1' :: forall c t m a. (ADT1 t, Constraints1 t c, Monoid m)
=> m
-> (forall s b. c s => (b -> b -> m) -> s b -> s b -> m)
-> (a -> a -> m) -> t a -> t a -> m
mzipWith1' m f = dimap inm2 (outm2 m) $ zipWithA1 @c $ dimap (outm2 m) inm2 f
{-# INLINE mzipWith1' #-}
-- | `zipWithA1` is `generic1` specialized to `Zip`
zipWithA1 :: forall c t f a b. (ADT1 t, Constraints1 t c, Alternative f)
=> (forall d e s. c s => (d -> d -> f e) -> s d -> s d -> f (s e))
-> (a -> a -> f b) -> t a -> t a -> f (t b)
zipWithA1 f = dimap Zip runZip $ generic1 @c $ dimap runZip Zip f
{-# INLINE zipWithA1 #-}
newtype Zip f a b = Zip { runZip :: a -> a -> f b }
instance Functor f => Profunctor (Zip f) where
dimap f g (Zip h) = Zip $ \a1 a2 -> fmap g (h (f a1) (f a2))
{-# INLINE dimap #-}
instance Applicative f => GenericUnitProfunctor (Zip f) where
unit = Zip $ \_ _ -> pure U1
{-# INLINE unit #-}
instance Applicative f => GenericProductProfunctor (Zip f) where
mult (Zip f) (Zip g) = Zip $ \(al :*: ar) (bl :*: br) -> (:*:) <$> f al bl <*> g ar br
{-# INLINE mult #-}
instance Alternative f => GenericSumProfunctor (Zip f) where
plus (Zip f) (Zip g) = Zip h where
h (L1 a) (L1 b) = fmap L1 (f a b)
h (R1 a) (R1 b) = fmap R1 (g a b)
h _ _ = empty
{-# INLINE plus #-}
instance Alternative f => GenericEmptyProfunctor (Zip f) where
zero = Zip absurd
{-# INLINE zero #-}
identity = Zip $ \_ _ -> empty
{-# INLINE identity #-}
inm2 :: (t -> t -> m) -> t -> t -> Compose Maybe (Const m) a
inm2 f = Compose .: Just .: Const .: f
{-# INLINE inm2 #-}
outm2 :: Monoid m => m -> (t -> t -> Compose Maybe (Const m) a) -> t -> t -> m
outm2 z f = maybe z getConst .: getCompose .: f
{-# INLINE outm2 #-}
-- | Implement a nullary operator by calling the operator for each component.
--
-- @
-- `mempty` = `nullaryOp` \@`Monoid` `mempty`
-- `fromInteger` i = `nullaryOp` \@`Num` (`fromInteger` i)
-- @
--
-- `nullaryOp` is `record` specialized to `Tagged`.
nullaryOp :: forall c t. (ADTRecord t, Constraints t c)
=> (forall s. c s => s) -> t
nullaryOp f = unTagged $ record @c $ Tagged f
{-# INLINE nullaryOp #-}
-- | Implement a unary operator by calling the operator on the components.
-- This is here for consistency, it is the same as `record`.
--
-- @
-- `negate` = `unaryOp` \@`Num` `negate`
-- @
unaryOp :: forall c t. (ADTRecord t, Constraints t c)
=> (forall s. c s => s -> s) -> t -> t
unaryOp = record @c
{-# INLINE unaryOp #-}
-- | Implement a binary operator by calling the operator on the components.
--
-- @
-- `mappend` = `binaryOp` \@`Monoid` `mappend`
-- (`+`) = `binaryOp` \@`Num` (`+`)
-- @
--
-- `binaryOp` is `algebra` specialized to pairs.
binaryOp :: forall c t. (ADTRecord t, Constraints t c)
=> (forall s. c s => s -> s -> s) -> t -> t -> t
binaryOp f = algebra @c (\(Pair a b) -> f a b) .: Pair
{-# INLINE binaryOp #-}
-- | Create a value of a record type (with exactly one constructor), given
-- how to construct the components, under an applicative effect.
--
-- Here's how to implement `get` from the `binary` package:
--
-- @
-- get = `createA'` (`For` :: `For` Binary) get
-- @
--
-- `createA'` is `record` specialized to `Joker`.
createA' :: forall c t f. (ADTRecord t, Constraints t c, Applicative f)
=> (forall s. c s => f s) -> f t
createA' f = runJoker $ record @c $ Joker f
{-# INLINE createA' #-}
data Pair a = Pair a a
instance Functor Pair where
fmap f (Pair a b) = Pair (f a) (f b)
{-# INLINE fmap #-}
-- | Create an F-algebra, given an F-algebra for each of the components.
--
-- @
-- `binaryOp` f l r = `algebra` \@c (\\(Pair a b) -> f a b) (Pair l r)
-- @
--
-- `algebra` is `record` specialized to `Costar`.
algebra :: forall c t f. (ADTRecord t, Constraints t c, Functor f)
=> (forall s. c s => f s -> s) -> f t -> t
algebra f = runCostar $ record @c $ Costar f
{-# INLINE algebra #-}
-- | `dialgebra` is `record` specialized to @`Biff` (->)@.
dialgebra :: forall c t f g. (ADTRecord t, Constraints t c, Functor f, Applicative g)
=> (forall s. c s => f s -> g s) -> f t -> g t
dialgebra f = runBiff $ record @c $ Biff f
{-# INLINE dialgebra #-}
-- | `createA1'` is `record1` specialized to `Joker`.
createA1' :: forall c t f a. (ADTRecord1 t, Constraints1 t c, Applicative f)
=> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a)
createA1' f = dimap Joker runJoker $ record1 @c $ dimap runJoker Joker f
{-# INLINE createA1' #-}
-- |
--
-- @
-- cotraverse = `gcotraverse1` \@`Distributive` `cotraverse`
-- @
--
-- `gcotraverse1` is `record1` specialized to `Costar`.
gcotraverse1 :: forall c t f a b. (ADTRecord1 t, Constraints1 t c, Functor f)
=> (forall d e s. c s => (f d -> e) -> f (s d) -> s e) -> (f a -> b) -> f (t a) -> t b
gcotraverse1 f p = runCostar $ record1 @c (Costar . f . runCostar) (Costar p)
{-# INLINE gcotraverse1 #-}
infixr 9 .:
(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(.:) = (.) . (.)
{-# INLINE (.:) #-}