1{-# LANGUAGE PolyKinds #-}
2{-# OPTIONS_HADDOCK hide #-}
3{-# LANGUAGE GADTs                     #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
5{-# LANGUAGE Rank2Types                #-}
6{-# LANGUAGE ScopedTypeVariables       #-}
7{-# LANGUAGE TypeFamilies              #-}
8{-# LANGUAGE TypeFamilyDependencies    #-}
9{-# LANGUAGE TypeOperators             #-}
10
11-----------------------------------------------------------------------------
12-- |
13-- Module      :  Data.Generics.Internal.VL.Iso
14-- Copyright   :  (C) 2020 Csongor Kiss
15-- License     :  BSD3
16-- Maintainer  :  Csongor Kiss <kiss.csongor.kiss@gmail.com>
17-- Stability   :  experimental
18-- Portability :  non-portable
19--
20-- Internal lens helpers. Only exported for Haddock
21--
22-----------------------------------------------------------------------------
23module Data.Generics.Internal.VL.Iso where
24
25import Data.Coerce (coerce)
26import Data.Functor.Identity (Identity(..))
27import Data.Profunctor
28import GHC.Generics
29import Data.Generics.Internal.GenericN (Rec (..), GenericN (..), Param (..))
30
31import qualified Data.Generics.Internal.Profunctor.Iso as P
32
33data Exchange a b s t = Exchange (s -> a) (b -> t)
34
35instance Functor (Exchange a b s) where
36  fmap f (Exchange p q) = Exchange p (f . q)
37  {-# INLINE fmap #-}
38
39instance Profunctor (Exchange a b) where
40  dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
41  {-# INLINE dimap #-}
42  lmap f (Exchange sa bt) = Exchange (sa . f) bt
43  {-# INLINE lmap #-}
44  rmap f (Exchange sa bt) = Exchange sa (f . bt)
45  {-# INLINE rmap #-}
46
47type Iso' s a
48  = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
49
50type Iso s t a b
51  = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
52
53fromIso :: Iso s t a b -> Iso b a t s
54fromIso l = withIso l $ \ sa bt -> iso bt sa
55{-# inline fromIso #-}
56
57iso2isovl :: P.Iso s t a b -> Iso s t a b
58iso2isovl _iso = P.withIso _iso iso
59{-# INLINE iso2isovl #-}
60
61-- | Extract the two functions, one from @s -> a@ and
62-- one from @b -> t@ that characterize an 'Iso'.
63withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
64withIso ai k = case ai (Exchange id Identity) of
65  Exchange sa bt -> k sa (coerce bt)
66{-# inline withIso #-}
67
68-- | A type and its generic representation are isomorphic
69repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
70repIso = iso from to
71
72repIsoN :: (GenericN a, GenericN b) => Iso a b (RepN a x) (RepN b x)
73repIsoN = iso fromN toN
74
75paramIso :: Iso (Param n a) (Param n b) a b
76paramIso = iso getStarParam StarParam
77
78-- | 'M1' is just a wrapper around `f p`
79mIso :: Iso (M1 i c f p) (M1 i c g p) (f p) (g p)
80mIso = iso unM1 M1
81
82kIso :: Iso (K1 r a p) (K1 r b p) a b
83kIso = iso unK1 K1
84
85recIso :: Iso (Rec r a p) (Rec r b p) a b
86recIso = iso (unK1 . unRec) (Rec . K1)
87
88prodIso :: Iso ((a :*: b) x) ((a' :*: b') x) (a x, b x) (a' x, b' x)
89prodIso = iso (\(a :*: b) -> (a, b)) (\(a, b) -> (a :*: b))
90
91iso :: (s -> a) -> (b -> t) -> Iso s t a b
92iso sa bt = dimap sa (fmap bt)
93{-# INLINE iso #-}
94