Test #13585 in typecheck/should_compile/T13585
[ghc.git] / testsuite / tests / typecheck / should_compile / T13585a.hs
1 {-# LANGUAGE KindSignatures, RankNTypes, TypeFamilies, MultiParamTypeClasses, FlexibleInstances,UndecidableInstances #-}
2
3 module T13585a where
4
5 import Data.Monoid (First(..))
6 import Data.Functor.Identity
7
8 class Profunctor p where
9 dimap :: (a -> b) -> (c -> d) -> p b c -> p a d
10 dimap f g = lmap f . rmap g
11 {-# INLINE dimap #-}
12
13 lmap :: (a -> b) -> p b c -> p a c
14 lmap f = dimap f id
15 {-# INLINE lmap #-}
16
17 rmap :: (b -> c) -> p a b -> p a c
18 rmap = dimap id
19 {-# INLINE rmap #-}
20
21
22 data Exchange a b s t = Exchange (s -> a) (b -> t)
23
24 instance Functor (Exchange a b s) where
25 fmap f (Exchange sa bt) = Exchange sa (f . bt)
26 {-# INLINE fmap #-}
27
28 instance Profunctor (Exchange a b) where
29 dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
30 {-# INLINE dimap #-}
31 lmap f (Exchange sa bt) = Exchange (sa . f) bt
32 {-# INLINE lmap #-}
33 rmap f (Exchange sa bt) = Exchange sa (f . bt)
34 {-# INLINE rmap #-}
35
36
37
38 withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
39 withIso ai k = case ai (Exchange id Identity) of
40 Exchange sa bt -> k sa (runIdentity undefined bt)
41 {-# INLINE withIso #-}
42
43 type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
44 type Iso' s a = Iso s s a a
45 type AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t)
46
47 class (Rewrapped s t, Rewrapped t s) => Rewrapping s t
48 instance (Rewrapped s t, Rewrapped t s) => Rewrapping s t
49
50
51 instance (t ~ First b) => Rewrapped (First a) t
52 instance Wrapped (First a) where
53 type Unwrapped (First a) = Maybe a
54 _Wrapped' = iso getFirst First
55 {-# INLINE _Wrapped' #-}
56
57 class Wrapped s => Rewrapped (s :: *) (t :: *)
58
59 class Wrapped s where
60 type Unwrapped s :: *
61 _Wrapped' :: Iso' s (Unwrapped s)
62
63 _Wrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso s t (Unwrapped s) (Unwrapped t)
64 _Wrapping _ = _Wrapped
65 {-# INLINE _Wrapping #-}
66
67 iso :: (s -> a) -> (b -> t) -> Iso s t a b
68 iso sa bt = dimap sa (fmap bt)
69 {-# INLINE iso #-}
70
71 _Wrapped :: Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
72 _Wrapped = withIso _Wrapped' $ \ sa _ -> withIso _Wrapped' $ \ _ bt -> iso sa bt
73 {-# INLINE _Wrapped #-}
74
75 au :: Functor f => AnIso s t a b -> ((b -> t) -> f s) -> f a
76 au k = withIso k $ \ sa bt f -> fmap sa (f bt)
77 {-# INLINE au #-}
78
79 ala :: (Functor f, Rewrapping s t) => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s)
80 ala = au . _Wrapping
81 {-# INLINE ala #-}