File: alongside.hs

package info (click to toggle)
haskell-lens 4.18.1-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 2,016 kB
  • sloc: haskell: 16,792; sh: 15; makefile: 14; ansic: 8
file content (107 lines) | stat: -rw-r--r-- 4,185 bytes parent folder | download | duplicates (3)
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
{-# 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 a
         -> Lens' s' a'
         -> Lens' (s,s') (a,a')
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 a
          -> Lens' s' a'
          -> Lens' s'' a''
          -> Lens' s''' a'''
          -> Lens' s'''' a''''
          -> Lens' (s, (s', (s'', (s''', s''''))))
                  (a, (a', (a'', (a''', a''''))))
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