git.iko.soy/generic-lens
on master help sign in
Implemented generic Iso, in the vein of Control.Lens.Wrapped
commit28682d49d2c3ab90d8394b4719aa2743141ba5f1 authorIsaac Elliott <isaace71295@gmail.com> dateThu 9 Aug 2018, 15:11 (8 years ago) parent64075a2
3 files changed+88−2
compare with master
unifiedsplit
generic-lens.cabal+2−1 src/Data/Generics/Internal/VL/Iso.hs+28−1 src/Data/Generics/Iso.hs+58
generic-lens.cabal+2−1
@@ -23,7 +23,8 @@ flag dump-core
2323 default: False
2424
2525library
26− exposed-modules: Data.Generics.Product
26+ exposed-modules: Data.Generics.Iso
27+ , Data.Generics.Product
2728 , Data.Generics.Product.Any
2829 , Data.Generics.Product.Fields
2930 , Data.Generics.Product.Param
src/Data/Generics/Internal/VL/Iso.hs+28−1
@@ -20,16 +20,43 @@
2020-----------------------------------------------------------------------------
2121module Data.Generics.Internal.VL.Iso where
2222
23−import Data.Profunctor (Profunctor(..))
23+import Data.Coerce (coerce)
24+import Data.Functor.Identity (Identity(..))
25+import Data.Profunctor (Profunctor(..))
2426import GHC.Generics
2527import Data.Generics.Internal.GenericN (Rec (..))
2628
29+data Exchange a b s t = Exchange (s -> a) (b -> t)
30+
31+instance Functor (Exchange a b s) where
32+ fmap f (Exchange sa bt) = Exchange sa (f . bt)
33+ {-# INLINE fmap #-}
34+
35+instance Profunctor (Exchange a b) where
36+ dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
37+ {-# INLINE dimap #-}
38+ lmap f (Exchange sa bt) = Exchange (sa . f) bt
39+ {-# INLINE lmap #-}
40+ rmap f (Exchange sa bt) = Exchange sa (f . bt)
41+ {-# INLINE rmap #-}
42+
2743type Iso' s a
2844 = forall p f. (Profunctor p, Functor f) => p a (f a) -> p s (f s)
2945
3046type Iso s t a b
3147 = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
3248
49+fromIso :: Iso s t a b -> Iso b a t s
50+fromIso l = withIso l $ \ sa bt -> iso bt sa
51+{-# inline fromIso #-}
52+
53+-- | Extract the two functions, one from @s -> a@ and
54+-- one from @b -> t@ that characterize an 'Iso'.
55+withIso :: Iso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
56+withIso ai k = case ai (Exchange id Identity) of
57+ Exchange sa bt -> k sa (coerce bt)
58+{-# inline withIso #-}
59+
3360-- | A type and its generic representation are isomorphic
3461repIso :: (Generic a, Generic b) => Iso a b (Rep a x) (Rep b x)
3562repIso = iso from to
src/Data/Generics/Iso.hsnew file+58
@@ -0,0 +1,58 @@
1+{-# language ConstraintKinds #-}
2+{-# language DataKinds #-}
3+{-# language FlexibleContexts #-}
4+{-# language FlexibleInstances #-}
5+{-# language FunctionalDependencies #-}
6+{-# language MultiParamTypeClasses #-}
7+{-# language ScopedTypeVariables #-}
8+{-# language TypeFamilies #-}
9+{-# language TypeOperators #-}
10+{-# language UndecidableInstances #-}
11+module Data.Generics.Iso
12+ ( Is(..)
13+ , _Unwrapped
14+ , _Wrapped
15+ )
16+where
17+
18+import Data.Generics.Internal.VL.Iso as VL
19+import Data.Generics.Internal.VL.Lens ((^.))
20+
21+import Data.Kind (Constraint)
22+import GHC.Generics
23+import GHC.TypeLits
24+
25+class GIso a b | a -> b where
26+ gIso :: Iso' (a x) b
27+
28+instance GIso a b => GIso (M1 i k a) b where
29+ gIso = mIso.gIso
30+
31+instance GIso (K1 i c) c where
32+ gIso = kIso
33+
34+class Is a b | a -> b where
35+ {-# minimal _Is | isTo, isFrom #-}
36+ _Is :: VL.Iso' a b
37+ _Is = iso isTo isFrom
38+
39+ isTo :: a -> b
40+ isTo a = a ^. _Is
41+
42+ isFrom :: b -> a
43+ isFrom a = a ^. fromIso _Is
44+
45+type family ErrorUnlessOnlyOne a b :: Constraint where
46+ ErrorUnlessOnlyOne t (M1 i k a) = ErrorUnlessOnlyOne t a
47+ ErrorUnlessOnlyOne t (K1 i a) = ()
48+ ErrorUnlessOnlyOne t a =
49+ TypeError ('ShowType t ':<>: 'Text " is not a single-constructor, single-field datatype")
50+
51+instance (Generic a, ErrorUnlessOnlyOne a (Rep a), GIso (Rep a) b) => Is a b where
52+ _Is = repIso . gIso
53+
54+_Unwrapped :: Is a b => Iso' a b
55+_Unwrapped = _Is
56+
57+_Wrapped :: Is a b => Iso' b a
58+_Wrapped = fromIso _Is