/
alongside.hs
109 lines (93 loc) · 4.24 KB
/
alongside.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
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
import Control.Applicative
import Control.Comonad
import Control.Comonad.Store.Class
import Control.Lens.Internal
import Control.Lens
import Criterion.Main
import Data.Functor.Compose
import Data.Functor.Identity
-- | A finally encoded Store
newtype Experiment a b s = Experiment { runExperiment :: forall f. Functor f => (a -> f b) -> f s }
instance Functor (Experiment a b) where
fmap f (Experiment k) = Experiment (fmap f . k)
{-# INLINE fmap #-}
instance (a ~ b) => Comonad (Experiment a b) where
extract (Experiment m) = runIdentity (m Identity)
{-# INLINE extract #-}
duplicate = duplicateExperiment
{-# INLINE duplicate #-}
-- | 'Experiment' is an indexed 'Comonad'.
duplicateExperiment :: Experiment a c s -> Experiment a b (Experiment b c s)
duplicateExperiment (Experiment m) = getCompose (m (Compose . fmap placebo . placebo))
{-# INLINE duplicateExperiment #-}
-- | A trivial 'Experiment'.
placebo :: a -> Experiment a b b
placebo i = Experiment (\k -> k i)
{-# INLINE placebo #-}
instance (a ~ b) => ComonadStore a (Experiment a b) where
pos m = posExperiment m
peek d m = peekExperiment d m
peeks f m = runIdentity $ runExperiment m (\c -> Identity (f c))
experiment f m = runExperiment m f
posExperiment :: Experiment a b s -> a
posExperiment m = getConst (runExperiment m Const)
{-# INLINE posExperiment #-}
peekExperiment :: b -> Experiment a b s -> s
peekExperiment b m = runIdentity $ runExperiment m (\_ -> Identity b)
{-# INLINE peekExperiment #-}
trial :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')
trial l r pfq (s,s') = fmap (\(b,t') -> (peekExperiment b x,t')) (getCompose (r (\a' -> Compose $ pfq (posExperiment x, a')) s'))
where x = l placebo s
{-# INLINE trial #-}
posContext :: Context a b s -> a
posContext (Context _ a) = a
{-# INLINE posContext #-}
peekContext :: b -> Context a b s -> s
peekContext b (Context f _) = f b
{-# INLINE peekContext #-}
-- a version of alongside built with Context and product
half :: LensLike (Context a b) s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')
half l r pfq (s,s') = fmap (\(b,t') -> (peekContext b x,t')) (getCompose (r (\a' -> Compose $ pfq (posContext x, a')) s'))
where x = l (Context id) s
{-# INLINE half #-}
-- alongside' :: Lens s t a b -> Lens s' t' a' b' -> Lens (s,s') (t,t') (a,a') (b,b')
-- {-# INLINE alongside'#-}
compound :: Lens s t a b
-> Lens s' t' a' b'
-> Lens (s,s') (t,t') (a,a') (b,b')
compound l r = lens (\(s, s') -> (view l s, view r s'))
(\(s, s') (t, t') -> (set l t s, set r t' s'))
{-# INLINE compound #-}
compound5 :: Lens s t a b
-> Lens s' t' a' b'
-> Lens s'' t'' a'' b''
-> Lens s''' t''' a''' b'''
-> Lens s'''' t'''' a'''' b''''
-> Lens (s, (s', (s'', (s''', s''''))))
(t, (t', (t'', (t''', t''''))))
(a, (a', (a'', (a''', a''''))))
(b, (b', (b'', (b''', b''''))))
compound5 l l' l'' l''' l''''
= lens (\(s, (s', (s'', (s''', s''''))))
-> (view l s, (view l' s', (view l'' s'', (view l''' s''', view l'''' s'''')))) )
(\(s, (s', (s'', (s''', s'''')))) (t, (t', (t'', (t''', t''''))))
-> (set l t s, (set l' t' s', (set l'' t'' s'', (set l''' t''' s''', set l'''' t'''' s'''')))) )
main = defaultMain
[ bench "alongside1" $ nf (view $ alongside _1 _2) (("hi", 1), (2, "there!"))
, bench "trial1" $ nf (view $ trial _1 _2) (("hi", 1), (2, "there!"))
, bench "half1" $ nf (view $ half _1 _2) (("hi", 1), (2, "there!"))
, bench "compound1" $ nf (view $ compound _1 _2) (("hi", 1), (2, "there!"))
, bench "alongside5" $ nf (view $ (alongside _1 (alongside _1 (alongside _1 (alongside _1 _1)))))
((v,v),((v,v),((v,v),((v,v),(v,v)))))
, bench "trial5" $ nf (view $ (trial _1 (trial _1 (trial _1 (trial _1 _1)))))
((v,v),((v,v),((v,v),((v,v),(v,v)))))
, bench "half5" $ nf (view $ (half _1 (half _1 (half _1 (half _1 _1)))))
((v,v),((v,v),((v,v),((v,v),(v,v)))))
, bench "compound5" $ nf (view $ compound5 _1 _1 _1 _1 _1)
((v,v),((v,v),((v,v),((v,v),(v,v)))))
]
where v = 1 :: Int