Remove the type-checking knot.
[ghc.git] / testsuite / tests / polykinds / T14172a.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE KindSignatures #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE PolyKinds #-}
5 {-# LANGUAGE RankNTypes #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeFamilies #-}
8 {-# LANGUAGE UndecidableInstances #-}
9 module T14172a where
10
11 import Data.Coerce
12 import Data.Functor.Compose
13 import Data.Functor.Identity
14
15 class Profunctor p where
16 dimap :: (a -> b) -> (c -> d) -> p b c -> p a d
17 (#.) :: Coercible c b => (b -> c) -> p a b -> p a c
18
19 instance Profunctor (->) where
20 dimap ab cd bc = cd . bc . ab
21 {-# INLINE dimap #-}
22 (#.) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b
23 {-# INLINE (#.) #-}
24
25 type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)
26 type Iso' s a = Iso s s a a
27
28 iso :: (s -> a) -> (b -> t) -> Iso s t a b
29 iso sa bt = dimap sa (fmap bt)
30 {-# INLINE iso #-}
31
32 type AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t)
33
34 data Exchange a b s t = Exchange (s -> a) (b -> t)
35
36 instance Profunctor (Exchange a b) where
37 dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt)
38 {-# INLINE dimap #-}
39 (#.) _ = coerce
40 {-# INLINE ( #. ) #-}
41
42 withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
43 withIso ai k = case ai (Exchange id Identity) of
44 Exchange sa bt -> k sa (runIdentity #. bt)
45 {-# INLINE withIso #-}
46
47 class Wrapped s where
48 type Unwrapped s :: *
49 _Wrapped' :: Iso' s (Unwrapped s)
50
51 class Wrapped s => Rewrapped (s :: *) (t :: *)
52
53 class (Rewrapped s t, Rewrapped t s) => Rewrapping s t
54 instance (Rewrapped s t, Rewrapped t s) => Rewrapping s t
55
56 instance (t ~ Compose f' g' a') => Rewrapped (Compose f g a) t
57 instance Wrapped (Compose f g a) where
58 type Unwrapped (Compose f g a) = f (g a)
59 _Wrapped' = iso getCompose Compose
60
61 _Wrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso s t (Unwrapped s) (Unwrapped t)
62 _Wrapping _ = _Wrapped
63 {-# INLINE _Wrapping #-}
64
65 _Wrapped :: Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
66 _Wrapped = withIso _Wrapped' $ \ sa _ -> withIso _Wrapped' $ \ _ bt -> iso sa bt
67 {-# INLINE _Wrapped #-}