diff options
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Ppr.hs | 44 | ||||
| -rw-r--r-- | testsuite/tests/th/T19363.hs | 35 | ||||
| -rw-r--r-- | testsuite/tests/th/T19363.stdout | 20 | ||||
| -rw-r--r-- | testsuite/tests/th/T8761.stderr | 10 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 1 |
5 files changed, 83 insertions, 27 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 20487c904f..47585b9f9d 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -75,7 +75,7 @@ ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty pprFixity :: Name -> Fixity -> Doc pprFixity _ f | f == defaultFixity = empty -pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v +pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> pprName' Infix v where ppr_fix InfixR = text "infixr" ppr_fix InfixL = text "infixl" ppr_fix InfixN = text "infix" @@ -216,7 +216,7 @@ pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e <+> dcolon <+> ppr t -pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) +pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) pprExp i (StaticE e) = parensIf (i >= appPrec) $ text "static"<+> pprExp appPrec e @@ -225,7 +225,7 @@ pprExp _ (LabelE s) = text "#" <> text s pprExp _ (ImplicitParamVarE n) = text ('?' : n) pprFields :: [(Name,Exp)] -> Doc -pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) +pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e) pprMaybeExp :: Precedence -> Maybe Exp -> Doc pprMaybeExp _ Nothing = empty @@ -328,9 +328,9 @@ pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@" <> pprPat appPrec p pprPat _ WildP = text "_" pprPat _ (RecP nm fs) - = parens $ ppr nm + = parens $ pprName' Applied nm <+> braces (sep $ punctuate comma $ - map (\(s,p) -> ppr s <+> equals <+> ppr p) fs) + map (\(s,p) -> pprName' Applied s <+> equals <+> ppr p) fs) pprPat _ (ListP ps) = brackets (commaSep ps) pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p @@ -411,10 +411,10 @@ ppr_dec _ (DefaultSigD n ty) ppr_dec _ (PatSynD name args dir pat) = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS where - pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2 - | otherwise = ppr name <+> ppr args + pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> pprName' Infix name <+> ppr a2 + | otherwise = pprName' Applied name <+> ppr args pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where") - nestDepth (ppr name <+> ppr cls) + nestDepth (pprName' Applied name <+> ppr cls) | otherwise = ppr pat ppr_dec _ (PatSynSigD name ty) = pprPatSynSig name ty @@ -508,13 +508,13 @@ ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs = text "type" <+> maybeInst <+> case t of - Just n -> ppr n <+> argsDoc + Just n -> pprName' Applied n <+> argsDoc Nothing -> argsDoc <+> text "=" <+> ppr rhs ppr_tf_head :: TypeFamilyHead -> Doc ppr_tf_head (TypeFamilyHead tc tvs res inj) - = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj + = pprName' Applied tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj where maybeInj | (Just inj') <- inj = ppr inj' | otherwise = empty @@ -547,13 +547,13 @@ instance Ppr Foreign where <+> showtextl callconv <+> showtextl safety <+> text (show impent) - <+> ppr as + <+> pprName' Applied as <+> dcolon <+> ppr typ ppr (ExportF callconv expent as typ) = text "foreign export" <+> showtextl callconv <+> text (show expent) - <+> ppr as + <+> pprName' Applied as <+> dcolon <+> ppr typ ------------------------------ @@ -563,13 +563,13 @@ instance Ppr Pragma where <+> ppr inline <+> ppr rm <+> ppr phases - <+> ppr n + <+> pprName' Applied n <+> text "#-}" ppr (SpecialiseP n ty inline phases) = text "{-# SPECIALISE" <+> maybe empty ppr inline <+> ppr phases - <+> sep [ ppr n <+> dcolon + <+> sep [ pprName' Applied n <+> dcolon , nest 2 $ ppr ty ] <+> text "#-}" ppr (SpecialiseInstP inst) @@ -590,13 +590,13 @@ instance Ppr Pragma where ppr (AnnP tgt expr) = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}" where target1 ModuleAnnotation = text "module" - target1 (TypeAnnotation t) = text "type" <+> ppr t - target1 (ValueAnnotation v) = ppr v + target1 (TypeAnnotation t) = text "type" <+> pprName' Applied t + target1 (ValueAnnotation v) = pprName' Applied v ppr (LineP line file) = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}" ppr (CompleteP cls mty) - = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls) - <+> maybe empty (\ty -> dcolon <+> ppr ty) mty <+> text "#-}" + = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls) + <+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}" ------------------------------ instance Ppr Inline where @@ -627,10 +627,10 @@ instance Ppr Clause where ------------------------------ instance Ppr Con where - ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts) + ppr (NormalC c sts) = pprName' Applied c <+> sep (map pprBangType sts) ppr (RecC c vsts) - = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts)) + = pprName' Applied c <+> braces (sep (punctuate comma $ map pprVarBangType vsts)) ppr (InfixC st1 c st2) = pprBangType st1 <+> pprName' Infix c @@ -663,7 +663,7 @@ instance Ppr PatSynDir where instance Ppr PatSynArgs where ppr (PrefixPatSyn args) = sep $ map ppr args ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2 - ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels)) + ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map (pprName' Applied) sels)) commaSepApplied :: [Name] -> Doc commaSepApplied = commaSepWith (pprName' Applied) @@ -702,7 +702,7 @@ pprGadtRHS sts ty ------------------------------ pprVarBangType :: VarBangType -> Doc -- Slight infelicity: with print non-atomic type with parens -pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t) +pprVarBangType (v, bang, t) = pprName' Applied v <+> dcolon <+> pprBangType (bang, t) ------------------------------ pprBangType :: BangType -> Doc diff --git a/testsuite/tests/th/T19363.hs b/testsuite/tests/th/T19363.hs new file mode 100644 index 0000000000..41cd26c715 --- /dev/null +++ b/testsuite/tests/th/T19363.hs @@ -0,0 +1,35 @@ +{-# Language PatternSynonyms #-} +{-# Language TemplateHaskell #-} +{-# Language TypeFamilies #-} +{-# Language TypeOperators #-} + +module Main where + +import Language.Haskell.TH + +main = runQ [d| data Operator = (:*) Int | (:**) { (^**) :: Int } + + data (%*%) = (:%*%) + {-# COMPLETE (:%*%) :: (%*%) #-} + {-# ANN type (%*%) "yargh" #-} + + f = (:**) { (^**) = 42 } + infix 5 `f` + + (%%) :: [a] -> [a] -> [a] + (%%) = (++) + {-# INLINE (%%) #-} + {-# SPECIALISE (%%) :: String -> String -> String #-} + {-# ANN (%%) "blah" #-} + + g (:**) { (^**) = x } = x + + pattern a `H` b = (a, b) + pattern (:***) { (^***) } <- (:**) (^***) where + (:***) (^***) = (:**) (^***) + + foreign import ccall unsafe "blah" (<^>) :: Int + + type family (<%>) a + type (<%%>) a = a + |] >>= putStrLn . pprint diff --git a/testsuite/tests/th/T19363.stdout b/testsuite/tests/th/T19363.stdout new file mode 100644 index 0000000000..b6d2c30790 --- /dev/null +++ b/testsuite/tests/th/T19363.stdout @@ -0,0 +1,20 @@ +data Operator_0 + = (:*_1) GHC.Types.Int | (:**_2) {(^**_3) :: GHC.Types.Int} +data (%*%_4) = (:%*%_5) +{-# COMPLETE (:%*%_5) :: (%*%_4) #-} +{-# ANN type (%*%_4) "yargh" #-} +f_6 = (:**_2){(^**_3) = 42} +infix 5 `f_6` +(%%_7) :: [a_8] -> [a_8] -> [a_8] +(%%_7) = (GHC.Base.++) +{-# INLINE (%%_7) #-} +{-# SPECIALISE (%%_7) :: + GHC.Base.String -> GHC.Base.String -> GHC.Base.String #-} +{-# ANN (%%_7) "blah" #-} +g_9 ((:**_2) {(^**_3) = x_10}) = x_10 +pattern a_11 `H_12` b_13 = (a_11, b_13) +pattern (:***_14) {(^***_15)} <- (:**_2) (^***_15) where + (:***_14) (^***_16) = (:**_2) (^***_16) +foreign import ccall unsafe "static blah" (<^>_17) :: GHC.Types.Int +type family (<%>_18) a_19 +type (<%%>_20) a_21 = a_21 diff --git a/testsuite/tests/th/T8761.stderr b/testsuite/tests/th/T8761.stderr index eb45ff46eb..03f5086423 100644 --- a/testsuite/tests/th/T8761.stderr +++ b/testsuite/tests/th/T8761.stderr @@ -1,5 +1,5 @@ pattern Q1 x1_0 x2_1 x3_2 <- ((x1_0, x2_1), [x3_2], _, _) -pattern x1_0 Q2 x2_1 = GHC.Tuple.Solo (x1_0, x2_1) +pattern x1_0 `Q2` x2_1 = GHC.Tuple.Solo (x1_0, x2_1) pattern Q3 {qx3, qy3, qz3} <- ((qx3, qy3), [qz3]) where Q3 qx3 qy3 qz3 = ((qx3, qy3), [qz3]) T8761.hs:(16,1)-(39,13): Splicing declarations @@ -83,8 +83,8 @@ T8761.hs:(71,1)-(105,39): Splicing declarations forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex) pattern Pure x y <- ([x, 1], MkEx y) pattern Purep :: - forall a. - (Num a, Eq a) => forall b. Show b => a -> b -> ([a], ExProv) + forall a. (Num a, Eq a) => + forall b. Show b => a -> b -> ([a], ExProv) pattern Purep x y <- ([x, 1], MkExProv y) pattern Pep :: () => forall a. Show a => a -> ExProv pattern Pep x <- MkExProv x @@ -111,8 +111,8 @@ T8761.hs:(71,1)-(105,39): Splicing declarations forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex) pattern Pure x y <- ([x, 1], MkEx y) pattern Purep :: - forall a. - (Num a, Eq a) => forall b. Show b => a -> b -> ([a], ExProv) + forall a. (Num a, Eq a) => + forall b. Show b => a -> b -> ([a], ExProv) pattern Purep x y <- ([x, 1], MkExProv y) pattern Pep :: () => forall a. Show a => a -> ExProv pattern Pep x <- MkExProv x diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 866bbdef31..235c0148f7 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -518,4 +518,5 @@ test('T18388', normal, compile, ['']) test('T18612', normal, compile, ['']) test('T18740c', normal, compile_fail, ['']) test('T18740d', normal, compile_fail, ['']) +test('T19363', normal, compile_and_run, ['']) test('T19377', normal, compile, ['']) |