diff options
5 files changed, 100 insertions, 0 deletions
diff --git a/testsuite/tests/typecheck/should_compile/Makefile b/testsuite/tests/typecheck/should_compile/Makefile index cb8269ae15..fc908998f9 100644 --- a/testsuite/tests/typecheck/should_compile/Makefile +++ b/testsuite/tests/typecheck/should_compile/Makefile @@ -56,3 +56,9 @@ Tc271: '$(TEST_HC)' $(TEST_HC_OPTS) -c Tc271.hs-boot '$(TEST_HC)' $(TEST_HC_OPTS) -c Tc271a.hs '$(TEST_HC)' $(TEST_HC_OPTS) -c Tc271.hs + +T13585: + $(RM) -f T13585a.o T13585a.hi T13585b.o T13585b.hi T13585.o T13585.hi + '$(TEST_HC)' $(TEST_HC_OPTS) -c T13585a.hs -O + '$(TEST_HC)' $(TEST_HC_OPTS) -c T13585b.hs -O + '$(TEST_HC)' $(TEST_HC_OPTS) -c T13585.hs -O diff --git a/testsuite/tests/typecheck/should_compile/T13585.hs b/testsuite/tests/typecheck/should_compile/T13585.hs new file mode 100644 index 0000000000..74c94123c4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T13585.hs @@ -0,0 +1,5 @@ +module T13585 where +import T13585b (extractZonedTime) + +main :: IO () +main = print extractZonedTime diff --git a/testsuite/tests/typecheck/should_compile/T13585a.hs b/testsuite/tests/typecheck/should_compile/T13585a.hs new file mode 100644 index 0000000000..fda3d7048a --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T13585a.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE KindSignatures, RankNTypes, TypeFamilies, MultiParamTypeClasses, FlexibleInstances,UndecidableInstances #-} + +module T13585a where + +import Data.Monoid (First(..)) +import Data.Functor.Identity + +class Profunctor p where + dimap :: (a -> b) -> (c -> d) -> p b c -> p a d + dimap f g = lmap f . rmap g + {-# INLINE dimap #-} + + lmap :: (a -> b) -> p b c -> p a c + lmap f = dimap f id + {-# INLINE lmap #-} + + rmap :: (b -> c) -> p a b -> p a c + rmap = dimap id + {-# INLINE rmap #-} + + +data Exchange a b s t = Exchange (s -> a) (b -> t) + +instance Functor (Exchange a b s) where + fmap f (Exchange sa bt) = Exchange sa (f . bt) + {-# INLINE fmap #-} + +instance Profunctor (Exchange a b) where + dimap f g (Exchange sa bt) = Exchange (sa . f) (g . bt) + {-# INLINE dimap #-} + lmap f (Exchange sa bt) = Exchange (sa . f) bt + {-# INLINE lmap #-} + rmap f (Exchange sa bt) = Exchange sa (f . bt) + {-# INLINE rmap #-} + + + +withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r +withIso ai k = case ai (Exchange id Identity) of + Exchange sa bt -> k sa (runIdentity undefined bt) +{-# INLINE withIso #-} + +type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t) +type Iso' s a = Iso s s a a +type AnIso s t a b = Exchange a b a (Identity b) -> Exchange a b s (Identity t) + +class (Rewrapped s t, Rewrapped t s) => Rewrapping s t +instance (Rewrapped s t, Rewrapped t s) => Rewrapping s t + + +instance (t ~ First b) => Rewrapped (First a) t +instance Wrapped (First a) where + type Unwrapped (First a) = Maybe a + _Wrapped' = iso getFirst First + {-# INLINE _Wrapped' #-} + +class Wrapped s => Rewrapped (s :: *) (t :: *) + +class Wrapped s where + type Unwrapped s :: * + _Wrapped' :: Iso' s (Unwrapped s) + +_Wrapping :: Rewrapping s t => (Unwrapped s -> s) -> Iso s t (Unwrapped s) (Unwrapped t) +_Wrapping _ = _Wrapped +{-# INLINE _Wrapping #-} + +iso :: (s -> a) -> (b -> t) -> Iso s t a b +iso sa bt = dimap sa (fmap bt) +{-# INLINE iso #-} + +_Wrapped :: Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t) +_Wrapped = withIso _Wrapped' $ \ sa _ -> withIso _Wrapped' $ \ _ bt -> iso sa bt +{-# INLINE _Wrapped #-} + +au :: Functor f => AnIso s t a b -> ((b -> t) -> f s) -> f a +au k = withIso k $ \ sa bt f -> fmap sa (f bt) +{-# INLINE au #-} + +ala :: (Functor f, Rewrapping s t) => (Unwrapped s -> s) -> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s) +ala = au . _Wrapping +{-# INLINE ala #-} diff --git a/testsuite/tests/typecheck/should_compile/T13585b.hs b/testsuite/tests/typecheck/should_compile/T13585b.hs new file mode 100644 index 0000000000..db09cf1faa --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T13585b.hs @@ -0,0 +1,7 @@ +module T13585b where + +import T13585a +import Data.Monoid + +extractZonedTime :: Maybe () +extractZonedTime = ala First foldMap [Nothing] diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 874235387e..34b8184069 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -557,3 +557,4 @@ test('T13509', normal, compile, ['']) test('T13526', normal, compile, ['']) test('T13603', normal, compile, ['']) test('T13333', normal, compile, ['']) +test('T13585', [extra_files(['T13585.hs', 'T13585a.hs', 'T13585b.hs'])], run_command, ['$MAKE -s --no-print-directory T13585']) |