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