diff options
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/printer/Makefile | 4 | ||||
| -rw-r--r-- | testsuite/tests/printer/T13550.hs | 69 | ||||
| -rw-r--r-- | testsuite/tests/printer/T13550.stdout | 22 | ||||
| -rw-r--r-- | testsuite/tests/printer/all.T | 1 |
5 files changed, 101 insertions, 4 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 921448e51d..8d90344f2f 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -37,7 +37,7 @@ import Outputable import MonadUtils ( foldrM ) import qualified Data.ByteString as BS -import Control.Monad( unless, liftM, ap ) +import Control.Monad( unless, liftM, ap, (<=<) ) import Data.Maybe( catMaybes, fromMaybe, isNothing ) import Language.Haskell.TH as TH hiding (sigP) @@ -386,7 +386,7 @@ cvtDec (TH.PatSynSigD nm ty) ---------------- cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn tc (TySynEqn lhs rhs) - = do { lhs' <- mapM cvtType lhs + = do { lhs' <- mapM (wrap_apps <=< cvtType) lhs ; rhs' <- cvtType rhs ; returnL $ TyFamEqn { tfe_tycon = tc , tfe_pats = mkHsImplicitBndrs lhs' @@ -433,7 +433,7 @@ cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] cvt_tyinst_hdr cxt tc tys = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc - ; tys' <- mapM cvtType tys + ; tys' <- mapM (wrap_apps <=< cvtType) tys ; return (cxt', tc', mkHsImplicitBndrs tys') } ---------------- @@ -552,7 +552,8 @@ cvtSrcStrictness SourceStrict = SrcStrict cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName) cvt_arg (Bang su ss, ty) - = do { ty' <- cvtType ty + = do { ty'' <- cvtType ty + ; ty' <- wrap_apps ty'' ; let su' = cvtSrcUnpackedness su ; let ss' = cvtSrcStrictness ss ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' } diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index 9f0eb23208..9cb968f2b4 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -205,3 +205,7 @@ T13199: .PHONY: T13050p T13050p: $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13050p.hs + +.PHONY: T13550 +T13550: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13550.hs diff --git a/testsuite/tests/printer/T13550.hs b/testsuite/tests/printer/T13550.hs new file mode 100644 index 0000000000..90a70aa487 --- /dev/null +++ b/testsuite/tests/printer/T13550.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-} +module Bug where + +$([d| type family Foo a b + type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) + + data family Bar a b + data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) + |]) + +{- + type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) + +becomes + +[TySynInstD Bug.Foo + (TySynEqn + [AppT + (ConT GHC.Base.Maybe) + (VarT a_6989586621679027317) + ,VarT b_6989586621679027318] + (AppT + (AppT + (ConT Data.Either.Either) + (AppT + (ConT GHC.Base.Maybe) + (VarT a_6989586621679027317) + ) + ) + (AppT (ConT GHC.Base.Maybe) (VarT b_6989586621679027318)) + ) + ) +] + + data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) + +becomes + +[DataInstD [] Bug.Bar + [AppT + (ConT GHC.Base.Maybe) + (VarT a_6989586621679027707) + ,VarT b_6989586621679027708 + ] + Nothing + [NormalC + BarMaybe_6989586621679027706 + [(Bang + NoSourceUnpackedness + NoSourceStrictness + ,AppT + (ConT GHC.Base.Maybe) + (VarT a_6989586621679027707) + ) + ,(Bang + NoSourceUnpackedness + NoSourceStrictness + ,AppT + (ConT GHC.Base.Maybe) + (VarT b_6989586621679027708) + ) + ] + ] + []] + + +-} diff --git a/testsuite/tests/printer/T13550.stdout b/testsuite/tests/printer/T13550.stdout new file mode 100644 index 0000000000..ff02835912 --- /dev/null +++ b/testsuite/tests/printer/T13550.stdout @@ -0,0 +1,22 @@ +T13550.hs:(6,3)-(11,6): Splicing declarations + [d| type family Foo a b + data family Bar a b + + type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) + data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) |] + ======> + type family Foo a b + type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) + data family Bar a b + data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) +T13550.ppr.hs:(5,3)-(8,69): Splicing declarations + [d| type family Foo a b + data family Bar a b + + type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) + data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) |] + ======> + type family Foo a b + type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b) + data family Bar a b + data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index e5fd00fdeb..c939e49300 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -48,3 +48,4 @@ test('Ppr047', expect_fail, run_command, ['$MAKE -s --no-print-directory ppr047' test('Ppr048', ignore_stderr, run_command, ['$MAKE -s --no-print-directory ppr048']) test('T13199', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13199']) test('T13050p', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13050p']) +test('T13550', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13550']) |