Fix printing of an `IfacePatSyn`
authorRik Steenkamp <rik@ewps.nl>
Sat, 5 Mar 2016 19:01:06 +0000 (20:01 +0100)
committerBen Gamari <ben@smart-cactus.org>
Sat, 5 Mar 2016 19:02:13 +0000 (20:02 +0100)
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

compiler/hsSyn/HsBinds.hs
compiler/iface/IfaceSyn.hs
compiler/iface/IfaceType.hs
testsuite/tests/ghci/scripts/T11524a.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T11524a.stdout [new file with mode: 0644]
testsuite/tests/ghci/scripts/all.T

index e2476cd..4d5e72c 100644 (file)
@@ -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
index 9113285..e5315b3 100644 (file)
@@ -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 })
index 52454ff..ca31283 100644 (file)
@@ -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
diff --git a/testsuite/tests/ghci/scripts/T11524a.script b/testsuite/tests/ghci/scripts/T11524a.script
new file mode 100644 (file)
index 0000000..29811d5
--- /dev/null
@@ -0,0 +1,55 @@
+-- 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
diff --git a/testsuite/tests/ghci/scripts/T11524a.stdout b/testsuite/tests/ghci/scripts/T11524a.stdout
new file mode 100644 (file)
index 0000000..dca7dbd
--- /dev/null
@@ -0,0 +1,49 @@
+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
index 3827bb6..87be4f1 100755 (executable)
@@ -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'])