Commit 3801262e authored by Rik Steenkamp's avatar Rik Steenkamp Committed by Ben Gamari

Fix printing of an `IfacePatSyn`

Now the existentially quantified type variables are printed
at the correct location when printing a pattern synonym type
from an `IfacePatSyn`. The function `pprIfaceContextMaybe`
has been removed as it is no longer needed.

Fixes #11524.

Reviewers: austin, goldfire, thomie, bgamari, mpickering

Reviewed By: bgamari

Differential Revision: https://phabricator.haskell.org/D1958

GHC Trac Issues: #11524
parent 6ca9b15f
......@@ -900,18 +900,6 @@ ppr_sig (PatSynSig name sig_ty)
= text "pattern" <+> pprPrefixOcc (unLoc name) <+> dcolon
<+> ppr sig_ty
pprPatSynSig :: (OutputableBndr name)
=> name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
pprPatSynSig ident _is_bidir tvs req prov ty
= text "pattern" <+> pprPrefixOcc ident <+> dcolon <+>
tvs <+> context <+> ty
where
context = case (req, prov) of
(Nothing, Nothing) -> empty
(Nothing, Just prov) -> parens empty <+> darrow <+> prov <+> darrow
(Just req, Nothing) -> req <+> darrow
(Just req, Just prov) -> req <+> darrow <+> prov <+> darrow
instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
where
......
......@@ -57,7 +57,6 @@ import SrcLoc
import Fingerprint
import Binary
import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
import HsBinds
import TyCon ( Role (..), Injectivity(..) )
import StaticFlags (opt_PprStyle_Debug)
import Util( filterOut, filterByList )
......@@ -753,20 +752,25 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon
$$ ppShowIface ss (text "axiom" <+> ppr ax))
pp_branches _ = Outputable.empty
pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder,
pprIfaceDecl _ (IfacePatSyn { ifName = name,
ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
ifPatArgs = arg_tys,
ifPatTy = pat_ty} )
= pprPatSynSig name is_bidirectional
(pprUserIfaceForAll (map tv_to_forall_bndr tvs))
(pprIfaceContextMaybe req_ctxt)
(pprIfaceContextMaybe prov_ctxt)
(pprIfaceType ty)
= sdocWithDynFlags mk_msg
where
is_bidirectional = isJust builder
tvs = univ_tvs ++ ex_tvs
ty = foldr IfaceFunTy pat_ty arg_tys
mk_msg dflags
= hsep [ text "pattern", pprPrefixOcc name, dcolon
, univ_msg, pprIfaceContextArr req_ctxt
, ppWhen insert_empty_ctxt $ parens empty <+> darrow
, ex_msg, pprIfaceContextArr prov_ctxt
, pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys]
where
univ_msg = pprUserIfaceForAll $ map tv_to_forall_bndr univ_tvs
ex_msg = pprUserIfaceForAll $ map tv_to_forall_bndr ex_tvs
insert_empty_ctxt = null req_ctxt
&& not (null prov_ctxt && isEmpty dflags ex_msg)
pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
ifIdDetails = details, ifIdInfo = info })
......
......@@ -41,7 +41,7 @@ module IfaceType (
-- Printing
pprIfaceType, pprParendIfaceType,
pprIfaceContext, pprIfaceContextArr, pprIfaceContextMaybe,
pprIfaceContext, pprIfaceContextArr,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
......@@ -77,7 +77,6 @@ import Outputable
import FastString
import UniqSet
import VarEnv
import Data.Maybe
import UniqFM
import Util
......@@ -1042,15 +1041,13 @@ instance Binary IfaceTcArgs where
-------------------
pprIfaceContextArr :: Outputable a => [a] -> SDoc
-- Prints "(C a, D b) =>", including the arrow
pprIfaceContextArr = maybe empty (<+> darrow) . pprIfaceContextMaybe
pprIfaceContextArr [] = empty
pprIfaceContextArr preds = pprIfaceContext preds <+> darrow
pprIfaceContext :: Outputable a => [a] -> SDoc
pprIfaceContext = fromMaybe (parens empty) . pprIfaceContextMaybe
pprIfaceContextMaybe :: Outputable a => [a] -> Maybe SDoc
pprIfaceContextMaybe [] = Nothing
pprIfaceContextMaybe [pred] = Just $ ppr pred -- No parens
pprIfaceContextMaybe preds = Just $ parens (fsep (punctuate comma (map ppr preds)))
pprIfaceContext [] = parens empty
pprIfaceContext [pred] = ppr pred -- No parens
pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds)))
instance Binary IfaceType where
put_ bh (IfaceForAllTy aa ab) = do
......
-- Test the printing of an `IfacePatSyn`
-- We test all valid combinations of:
-- universal type variables yes/no
-- "required" context yes/no
-- existential type variables yes/no
-- "provided" context yes/no
-- -fprint-explicit-foralls yes/no
:set -XPatternSynonyms
:set -XGADTs
data Ex where MkEx :: a -> Ex
data ExProv where MkExProv :: (Show a) => a -> ExProv
data UnivProv a where MkUnivProv :: (Show a) => a -> UnivProv a
pattern P <- True
pattern Pe x <- MkEx x
pattern Pu x <- x
pattern Pue x y <- (x, MkEx y)
pattern Pur x <- [x, 1]
pattern Purp x y <- ([x, 1], MkUnivProv y)
pattern Pure x y <- ([x, 1], MkEx y)
pattern Purep x y <- ([x, 1], MkExProv y)
pattern Pep x <- MkExProv x
pattern Pup x <- MkUnivProv x
pattern Puep x y <- (MkExProv x, y)
putStrLn "without -fprint-explicit-foralls"
putStrLn "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
:info P
:info Pe
:info Pu
:info Pue
:info Pur
:info Purp
:info Pure
:info Purep
:info Pep
:info Pup
:info Puep
putStrLn "\nwith -fprint-explicit-foralls"
putStrLn "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
:set -fprint-explicit-foralls
:info P
:info Pe
:info Pu
:info Pue
:info Pur
:info Purp
:info Pure
:info Purep
:info Pep
:info Pup
:info Puep
without -fprint-explicit-foralls
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
pattern P :: Bool -- Defined at <interactive>:16:1
pattern Pe :: a -> Ex -- Defined at <interactive>:17:1
pattern Pu :: t -> t -- Defined at <interactive>:18:1
pattern Pue :: t -> a -> (t, Ex) -- Defined at <interactive>:19:1
pattern Pur :: (Num a, Eq a) => a -> [a]
-- Defined at <interactive>:20:1
pattern Purp :: (Num a, Eq a) => Show t => a
-> t -> ([a], UnivProv t)
-- Defined at <interactive>:21:1
pattern Pure :: (Num a, Eq a) => a -> a1 -> ([a], Ex)
-- Defined at <interactive>:22:1
pattern Purep :: (Num a, Eq a) => Show a1 => a
-> a1 -> ([a], ExProv)
-- Defined at <interactive>:23:1
pattern Pep :: () => Show a => a -> ExProv
-- Defined at <interactive>:24:1
pattern Pup :: () => Show t => t -> UnivProv t
-- Defined at <interactive>:25:1
pattern Puep :: () => Show a => a -> t -> (ExProv, t)
-- Defined at <interactive>:26:1
with -fprint-explicit-foralls
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
pattern P :: Bool -- Defined at <interactive>:16:1
pattern Pe :: () => forall a. a -> Ex
-- Defined at <interactive>:17:1
pattern Pu :: forall t. t -> t -- Defined at <interactive>:18:1
pattern Pue :: forall t. () => forall a. t -> a -> (t, Ex)
-- Defined at <interactive>:19:1
pattern Pur :: forall a. (Num a, Eq a) => a -> [a]
-- Defined at <interactive>:20:1
pattern Purp :: forall a t. (Num a, Eq a) => Show t => a
-> t -> ([a], UnivProv t)
-- Defined at <interactive>:21:1
pattern Pure :: forall a. (Num a, Eq a) => forall a1. a
-> a1 -> ([a], Ex)
-- Defined at <interactive>:22:1
pattern Purep :: forall a. (Num a, Eq a) => forall a1. Show a1 => a
-> a1 -> ([a], ExProv)
-- Defined at <interactive>:23:1
pattern Pep :: () => forall a. Show a => a -> ExProv
-- Defined at <interactive>:24:1
pattern Pup :: forall t. () => Show t => t -> UnivProv t
-- Defined at <interactive>:25:1
pattern Puep :: forall t. () => forall a. Show a => a
-> t -> (ExProv, t)
-- Defined at <interactive>:26:1
......@@ -244,3 +244,4 @@ test('T11051b', normal, ghci_script, ['T11051b.script'])
test('T11266', check_stdout(lambda *args: 1), ghci_script, ['T11266.script'])
test('T11389', req_interp, run_command, ['$MAKE -s --no-print-directory T11389'])
test('T11524a', normal, ghci_script, ['T11524a.script'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment