git.iko.soy/generic-lens
on bfcd00a help sign in
generic-lens/src/Data/Generics/Internal/Lens.hs
93 lines 2.7 kB history raw
1{-# LANGUAGE Rank2Types #-}
2{-# LANGUAGE TypeOperators #-}
4-----------------------------------------------------------------------------
5-- |
6-- Module : Data.Generics.Internal.Lens
7-- Copyright : (C) 2017 Csongor Kiss
8-- License : BSD3
9-- Maintainer : Csongor Kiss <kiss.csongor.kiss@gmail.com>
10-- Stability : experimental
11-- Portability : non-portable
12--
13-- Internal lens helpers. Only exported for Haddock
14--
15-----------------------------------------------------------------------------
16module Data.Generics.Internal.Lens where
18import Control.Applicative (Const(..))
19import Data.Functor.Identity (Identity(..))
20import Data.Profunctor (Choice(right'), Profunctor(dimap))
21import GHC.Generics ((:*:)(..), (:+:)(..), Generic(..), K1(..), M1(..), Rep)
23-- | Type alias for lens
24type Lens' s a
25 = forall f. Functor f => (a -> f a) -> s -> f s
27-- | Type alias for prism
28type Prism' s a
29 = forall p f. (Choice p, Applicative f) => p a (f a) -> p s (f s)
31type Iso' s a
32 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
34-- | Getting
35(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
36s ^. l = getConst (l Const s)
37infixl 8 ^.
39-- | Setting
40set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
41set l b
42 = runIdentity . l (\_ -> Identity b)
44-- | Lens focusing on the first element of a product
45first :: Lens' ((a :*: b) x) (a x)
46first f (a :*: b)
47 = fmap (:*: b) (f a)
49-- | Lens focusing on the second element of a product
50second :: Lens' ((a :*: b) x) (b x)
51second f (a :*: b)
52 = fmap (a :*:) (f b)
54left :: Prism' ((a :+: b) x) (a x)
55left = prism L1 $ \x -> case x of
56 L1 a -> Right a
57 R1 _ -> Left x
59right :: Prism' ((a :+: b) x) (b x)
60right = prism R1 $ \x -> case x of
61 L1 _ -> Left x
62 R1 a -> Right a
64combine :: Lens' (s x) a -> Lens' (t x) a -> Lens' ((s :+: t) x) a
65combine sa _ f (L1 s) = fmap (\a -> L1 (set sa a s)) (f (s ^. sa))
66combine _ ta f (R1 t) = fmap (\a -> R1 (set ta a t)) (f (t ^. ta))
68prism :: (a -> s) -> (s -> Either s a) -> Prism' s a
69prism bt seta = dimap seta (either pure (fmap bt)) . right'
71-- | A type and its generic representation are isomorphic
72repIso :: Generic a => Iso' a (Rep a x)
73repIso = dimap from (fmap to)
75-- | 'M1' is just a wrapper around `f p`
76mIso :: Iso' (M1 i c f p) (f p)
77mIso = dimap unM1 (fmap M1)
79kIso :: Iso' (K1 t a x) a
80kIso = dimap unK1 (fmap K1)
82sumIso :: Iso' ((a :+: b) x) (Either (a x) (b x))
83sumIso = dimap f (fmap t)
84 where f (L1 x) = Left x
85 f (R1 x) = Right x
86 t (Left x) = L1 x
87 t (Right x) = R1 x
89_Left :: Prism' (Either a c) a
90_Left = prism Left $ either Right (Left . Right)
92_Right :: Prism' (Either c a) a
93_Right = prism Right $ either (Left . Left) Right