Add a pattern-syn form of PromotionErr
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 21 Dec 2015 14:18:32 +0000 (14:18 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 23 Dec 2015 07:46:37 +0000 (07:46 +0000)
The main change is to add PatSynPE to PromotionErr, so that
when we get an ill-staged use of a pattern synonym we get a
civilised error message.

We were already doing this in half-baked form in tcValBinds, but
this patch tidies up the impl (which previously used a hack rather
than APromotionErr), and does it in tcTyClsInstDecls too.

compiler/hsSyn/HsBinds.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnTypes.hs
testsuite/tests/patsyn/should_fail/T11265.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/T11265.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/T9161-1.stderr
testsuite/tests/patsyn/should_fail/T9161-2.stderr
testsuite/tests/patsyn/should_fail/all.T

index 6acac76..7a11463 100644 (file)
@@ -42,7 +42,6 @@ import DynFlags
 
 import Data.Data hiding ( Fixity )
 import Data.List hiding ( foldr )
-import qualified Data.List as L (foldr)
 import Data.Ord
 import Data.Foldable ( Foldable(..) )
 #if __GLASGOW_HASKELL__ < 709
@@ -484,20 +483,6 @@ plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
 plusHsValBinds _ _
   = panic "HsBinds.plusHsValBinds"
 
-getTypeSigNames :: HsValBinds a -> NameSet
--- Get the names that have a user type sig
-getTypeSigNames (ValBindsOut _ sigs)
-  = L.foldr get_type_sig emptyNameSet sigs
-  where
-    get_type_sig :: LSig Name -> NameSet -> NameSet
-    get_type_sig sig ns =
-      case sig of
-        L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
-        L _ (PatSynSig name _) -> extendNameSet ns (unLoc name)
-        _ -> ns
-
-getTypeSigNames _
-  = panic "HsBinds.getTypeSigNames"
 
 {-
 What AbsBinds means
index be60056..83f2eb9 100644 (file)
@@ -32,7 +32,6 @@ import TcEvidence
 import TcHsType
 import TcPat
 import TcMType
-import ConLike
 import Inst( deeplyInstantiate )
 import FamInstEnv( normaliseType )
 import FamInst( tcGetFamInstEnvs )
@@ -174,10 +173,10 @@ Then we get
                                fm
 -}
 
-tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
+tcTopBinds :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM (TcGblEnv, TcLclEnv)
 -- The TcGblEnv contains the new tcg_binds and tcg_spects
 -- The TcLclEnv has an extended type envt for the new bindings
-tcTopBinds (ValBindsOut binds sigs)
+tcTopBinds binds sigs
   = do  { -- Pattern synonym bindings populate the global environment
           (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
             do { gbl <- getGblEnv
@@ -192,8 +191,6 @@ tcTopBinds (ValBindsOut binds sigs)
         -- The top level bindings are flattened into a giant
         -- implicitly-mutually-recursive LHsBinds
 
-tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"
-
 tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
 tcRecSelBinds (ValBindsOut binds sigs)
   = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
@@ -203,10 +200,10 @@ tcRecSelBinds (ValBindsOut binds sigs)
        ; return tcg_env' }
 tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
 
-tcHsBootSigs :: HsValBinds Name -> TcM [Id]
+tcHsBootSigs :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM [Id]
 -- A hs-boot file has only one BindGroup, and it only has type
 -- signatures in it.  The renamer checked all this
-tcHsBootSigs (ValBindsOut binds sigs)
+tcHsBootSigs binds sigs
   = do  { checkTc (null binds) badBootDeclErr
         ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
   where
@@ -218,7 +215,6 @@ tcHsBootSigs (ValBindsOut binds sigs)
                ; return (mkVanillaGlobal name sigma_ty) }
         -- Notice that we make GlobalIds, not LocalIds
     tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
-tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
 
 badBootDeclErr :: MsgDoc
 badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
@@ -267,9 +263,8 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
     toDict ipClass x ty = HsWrap $ mkWpCastR $
                           wrapIP $ mkClassPred ipClass [x,ty]
 
-{-
-Note [Implicit parameter untouchables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Implicit parameter untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We add the type variables in the types of the implicit parameters
 as untouchables, not so much because we really must not unify them,
 but rather because we otherwise end up with constraints like this
@@ -282,29 +277,6 @@ time by defaulting.  No no no.
 However [Oct 10] this is all handled automatically by the
 untouchable-range idea.
 
-Note [Placeholder PatSyn kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (Trac #9161)
-
-  {-# LANGUAGE PatternSynonyms, DataKinds #-}
-  pattern A = ()
-  b :: A
-  b = undefined
-
-Here, the type signature for b mentions A.  But A is a pattern
-synonym, which is typechecked (for very good reasons; a view pattern
-in the RHS may mention a value binding) as part of a group of
-bindings.  It is entirely reasonable to reject this, but to do so
-we need A to be in the kind environment when kind-checking the signature for B.
-
-Hence the tcExtendKindEnv2 patsyn_placeholder_kinds, which adds a binding
-    A -> AGlobal (AConLike (PatSynCon _|_))
-to the environment. Then TcHsType.tcTyVar will find A in the kind environment,
-and will give a 'wrongThingErr' as a result.  But the lookup of A won't fail.
-
-The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in
-tcTyVar, doesn't look inside the TcTyThing.
-
 Note [Inlining and hs-boot files]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this example (Trac #10083):
@@ -359,9 +331,10 @@ tcValBinds :: TopLevelFlag
            -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 
 tcValBinds top_lvl binds sigs thing_inside
-  = do  {  -- Typecheck the signature
-        ; (poly_ids, sig_fn) <- tcExtendKindEnv2 patsyn_placeholder_kinds $
-                                         -- See Note [Placeholder PatSyn kinds]
+  = do  { let patsyns = getPatSynBinds binds
+
+            -- Typecheck the signature
+        ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
                                 tcTySigs sigs
 
         ; _self_boot <- tcSelfBootInfo
@@ -390,12 +363,6 @@ tcValBinds top_lvl binds sigs thing_inside
                    ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
                    ; return (extra_binds, thing) }
             ; return (binds' ++ extra_binds', thing) }}
-  where
-    patsyns = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds]
-    patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds]
-      = [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ]
-    placeholder_patsyn_tything
-      = AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
 
 ------------------------
 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
index 5ea521e..5381a6d 100644 (file)
@@ -36,6 +36,8 @@ module TcEnv(
         getScopedTyVarBinds, getInLocalScope,
         wrongThingErr, pprBinders,
 
+        tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
+        getPatSynBinds, getTypeSigNames,
         tcExtendRecEnv,         -- For knot-tying
 
         -- Instances
@@ -84,6 +86,7 @@ import TyCon
 import CoAxiom
 import Class
 import Name
+import NameSet
 import NameEnv
 import VarEnv
 import HscTypes
@@ -94,6 +97,7 @@ import Module
 import Outputable
 import Encoding
 import FastString
+import Bag
 import ListSetOps
 import Util
 import Maybes( MaybeErr(..) )
@@ -538,7 +542,104 @@ tcExtendIdBndrs bndrs thing_inside
                    thing_inside }
 
 
-{-
+{- *********************************************************************
+*                                                                      *
+             Adding placeholders
+*                                                                      *
+********************************************************************* -}
+
+tcAddDataFamConPlaceholders :: [LInstDecl Name] -> TcM a -> TcM a
+-- See Note [AFamDataCon: not promoting data family constructors]
+tcAddDataFamConPlaceholders inst_decls thing_inside
+  = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
+                     | lid <- inst_decls, con <- get_cons lid ]
+      thing_inside
+      -- Note [AFamDataCon: not promoting data family constructors]
+  where
+    -- get_cons extracts the *constructor* bindings of the declaration
+    get_cons :: LInstDecl Name -> [Name]
+    get_cons (L _ (TyFamInstD {}))                     = []
+    get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
+    get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
+      = concatMap (get_fi_cons . unLoc) fids
+
+    get_fi_cons :: DataFamInstDecl Name -> [Name]
+    get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
+      = map unLoc $ concatMap (getConNames . unLoc) cons
+
+
+tcAddPatSynPlaceholders :: [PatSynBind Name Name] -> TcM a -> TcM a
+-- See Note [Don't promote pattern synonyms]
+tcAddPatSynPlaceholders pat_syns thing_inside
+  = tcExtendKindEnv2 [ (name, APromotionErr PatSynPE)
+                     | PSB{ psb_id = L _ name } <- pat_syns ]
+       thing_inside
+
+getPatSynBinds :: [(RecFlag, LHsBinds Name)] -> [PatSynBind Name Name]
+getPatSynBinds binds
+  = [ psb | (_, lbinds) <- binds
+          , L _ (PatSynBind psb) <- bagToList lbinds ]
+
+
+getTypeSigNames :: [LSig Name] -> NameSet
+-- Get the names that have a user type sig
+getTypeSigNames sigs
+  = foldr get_type_sig emptyNameSet sigs
+  where
+    get_type_sig :: LSig Name -> NameSet -> NameSet
+    get_type_sig sig ns =
+      case sig of
+        L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
+        L _ (PatSynSig name _) -> extendNameSet ns (unLoc name)
+        _ -> ns
+
+
+{- Note [AFamDataCon: not promoting data family constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data family T a
+  data instance T Int = MkT
+  data Proxy (a :: k)
+  data S = MkS (Proxy 'MkT)
+
+Is it ok to use the promoted data family instance constructor 'MkT' in
+the data declaration for S?  No, we don't allow this. It *might* make
+sense, but at least it would mean that we'd have to interleave
+typechecking instances and data types, whereas at present we do data
+types *then* instances.
+
+So to check for this we put in the TcLclEnv a binding for all the family
+constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
+type checking 'S' we'll produce a decent error message.
+
+Note [Don't promote pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We never promote pattern synonyms.
+
+Consider this (Trac #11265):
+  pattern A = True
+  instance Eq A
+We want a civilised error message from the occurrence of 'A'
+in the instance, yet 'A' really has not yet been type checked.
+
+Similarly (Trac #9161)
+  {-# LANGUAGE PatternSynonyms, DataKinds #-}
+  pattern A = ()
+  b :: A
+  b = undefined
+Here, the type signature for b mentions A.  But A is a pattern
+synonym, which is typechecked as part of a group of bindings (for very
+good reasons; a view pattern in the RHS may mention a value binding).
+It is entirely reasonable to reject this, but to do so we need A to be
+in the kind environment when kind-checking the signature for B.
+
+Hence tcAddPatSynPlaceholers adds a binding
+    A -> APromotionErr PatSynPE
+to the environment. Then TcHsType.tcTyVar will find A in the kind
+environment, and will give a 'wrongThingErr' as a result.  But the
+lookup of A won't fail.
+
+
 ************************************************************************
 *                                                                      *
 \subsection{Rules}
index 5ba86e1..1200bf1 100644 (file)
@@ -2134,6 +2134,7 @@ promotionErr name err
                NoDataKinds    -> text "Perhaps you intended to use DataKinds"
                NoTypeInTypeTC -> text "Perhaps you intended to use TypeInType"
                NoTypeInTypeDC -> text "Perhaps you intended to use TypeInType"
+               PatSynPE       -> text "Pattern synonyms cannot be promoted"
                _ -> text "it is defined and used in the same recursive group"
 
 {-
index d30cf44..298a953 100644 (file)
@@ -632,16 +632,16 @@ tcRnHsBootDecls hsc_src decls
    = do { (first_group, group_tail) <- findSplice decls
 
                 -- Rename the declarations
-        ; (tcg_env, HsGroup {
-                   hs_tyclds = tycl_decls,
-                   hs_instds = inst_decls,
-                   hs_derivds = deriv_decls,
-                   hs_fords  = for_decls,
-                   hs_defds  = def_decls,
-                   hs_ruleds = rule_decls,
-                   hs_vects  = vect_decls,
-                   hs_annds  = _,
-                   hs_valds  = val_binds }) <- rnTopSrcDecls first_group
+        ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
+                            , hs_instds = inst_decls
+                            , hs_derivds = deriv_decls
+                            , hs_fords  = for_decls
+                            , hs_defds  = def_decls
+                            , hs_ruleds = rule_decls
+                            , hs_vects  = vect_decls
+                            , hs_annds  = _
+                            , hs_valds  = ValBindsOut val_binds val_sigs })
+              <- rnTopSrcDecls first_group
         -- The empty list is for extra dependencies coming from .hs-boot files
         -- See Note [Extra dependencies from .hs-boot files] in RnSource
         ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
@@ -659,12 +659,12 @@ tcRnHsBootDecls hsc_src decls
                 -- Typecheck type/class/isntance decls
         ; traceTc "Tc2 (boot)" empty
         ; (tcg_env, inst_infos, _deriv_binds)
-             <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls
+             <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls val_binds
         ; setGblEnv tcg_env     $ do {
 
                 -- Typecheck value declarations
         ; traceTc "Tc5" empty
-        ; val_ids <- tcHsBootSigs val_binds
+        ; val_ids <- tcHsBootSigs val_binds val_sigs
 
                 -- Wrap up
                 -- No simplification or zonking to do
@@ -1143,7 +1143,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                          hs_annds  = annotation_decls,
                          hs_ruleds = rule_decls,
                          hs_vects  = vect_decls,
-                         hs_valds  = val_binds })
+                         hs_valds  = hs_val_binds@(ValBindsOut val_binds val_sigs) })
  = do {         -- Type-check the type and class decls, and all imported decls
                 -- The latter come in via tycl_decls
         traceTc "Tc2 (src)" empty ;
@@ -1151,8 +1151,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                 -- Source-language instances, including derivings,
                 -- and import the supporting declarations
         traceTc "Tc3" empty ;
-        (tcg_env, inst_infos, deriv_binds)
-            <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls ;
+        (tcg_env, inst_infos, ValBindsOut deriv_binds deriv_sigs)
+            <- tcTyClsInstDecls tycl_decls inst_decls deriv_decls val_binds ;
         setGblEnv tcg_env       $ do {
 
                 -- Generate Applicative/Monad proposal (AMP) warnings
@@ -1175,12 +1175,12 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
                 -- Now GHC-generated derived bindings, generics, and selectors
                 -- Do not generate warnings from compiler-generated code;
                 -- hence the use of discardWarnings
-        tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
+        tc_envs <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
         setEnvs tc_envs $ do {
 
                 -- Value declarations next
         traceTc "Tc5" empty ;
-        tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
+        tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds val_sigs;
         setEnvs tc_envs $ do {  -- Environment doesn't change now
 
                 -- Second pass over class and instance declarations,
@@ -1210,8 +1210,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
             ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)
                                 emptyFVs fo_gres
 
-            ; sig_names = mkNameSet (collectHsValBinders val_binds)
-                          `minusNameSet` getTypeSigNames val_binds
+            ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
+                          `minusNameSet` getTypeSigNames val_sigs
 
                 -- Extend the GblEnv with the (as yet un-zonked)
                 -- bindings, rules, foreign decls
@@ -1232,6 +1232,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
         return (tcg_env', tcl_env)
     }}}}}}
 
+tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
+
 
 tcSemigroupWarnings :: TcM ()
 tcSemigroupWarnings = do
@@ -1420,51 +1422,21 @@ tcMissingParentClassWarn warnFlag isName shouldName
 tcTyClsInstDecls :: [TyClGroup Name]
                  -> [LInstDecl Name]
                  -> [LDerivDecl Name]
+                 -> [(RecFlag, LHsBinds Name)]
                  -> TcM (TcGblEnv,            -- The full inst env
                          [InstInfo Name],     -- Source-code instance decls to process;
                                               -- contains all dfuns for this module
                           HsValBinds Name)    -- Supporting bindings for derived instances
 
-tcTyClsInstDecls tycl_decls inst_decls deriv_decls
- = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
-                    | lid <- inst_decls, con <- get_cons lid ] $
-      -- Note [AFamDataCon: not promoting data family constructors]
+tcTyClsInstDecls tycl_decls inst_decls deriv_decls binds
+ = tcAddDataFamConPlaceholders inst_decls           $
+   tcAddPatSynPlaceholders (getPatSynBinds binds) $
    do { tcg_env <- tcTyAndClassDecls tycl_decls ;
       ; setGblEnv tcg_env $
         tcInstDecls1 tycl_decls inst_decls deriv_decls }
-  where
-    -- get_cons extracts the *constructor* bindings of the declaration
-    get_cons :: LInstDecl Name -> [Name]
-    get_cons (L _ (TyFamInstD {}))                     = []
-    get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
-    get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
-      = concatMap (get_fi_cons . unLoc) fids
-
-    get_fi_cons :: DataFamInstDecl Name -> [Name]
-    get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
-      = map unLoc $ concatMap (getConNames . unLoc) cons
-
-{-
-Note [AFamDataCon: not promoting data family constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data family T a
-  data instance T Int = MkT
-  data Proxy (a :: k)
-  data S = MkS (Proxy 'MkT)
-
-Is it ok to use the promoted data family instance constructor 'MkT' in
-the data declaration for S?  No, we don't allow this. It *might* make
-sense, but at least it would mean that we'd have to interleave
-typechecking instances and data types, whereas at present we do data
-types *then* instances.
 
-So to check for this we put in the TcLclEnv a binding for all the family
-constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
-type checking 'S' we'll produce a decent error message.
 
-
-************************************************************************
+{- *********************************************************************
 *                                                                      *
         Checking for 'main'
 *                                                                      *
index 8489512..5275f90 100644 (file)
@@ -885,6 +885,8 @@ data PromotionErr
 
   | FamDataConPE     -- Data constructor for a data family
                      -- See Note [AFamDataCon: not promoting data family constructors] in TcRnDriver
+  | PatSynPE         -- Pattern synonyms
+                     -- See Note [Don't promote pattern synonyms] in TcEnv
 
   | RecDataConPE     -- Data constructor in a recursive loop
                      -- See Note [ARecDataCon: recusion and promoting data constructors] in TcTyClsDecls
@@ -905,6 +907,7 @@ instance Outputable TcTyThing where     -- Debugging only
 instance Outputable PromotionErr where
   ppr ClassPE        = text "ClassPE"
   ppr TyConPE        = text "TyConPE"
+  ppr PatSynPE       = text "PatSynPE"
   ppr FamDataConPE   = text "FamDataConPE"
   ppr RecDataConPE   = text "RecDataConPE"
   ppr NoDataKinds    = text "NoDataKinds"
@@ -921,6 +924,7 @@ pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe
 pprPECategory :: PromotionErr -> SDoc
 pprPECategory ClassPE        = ptext (sLit "Class")
 pprPECategory TyConPE        = ptext (sLit "Type constructor")
+pprPECategory PatSynPE       = ptext (sLit "Pattern synonym")
 pprPECategory FamDataConPE   = ptext (sLit "Data constructor")
 pprPECategory RecDataConPE   = ptext (sLit "Data constructor")
 pprPECategory NoDataKinds    = ptext (sLit "Data constructor")
@@ -964,6 +968,7 @@ Note that:
     *type variable*  Eg
         f :: forall a. blah
         f x = let g y = ...(y::a)...
+
 -}
 
 type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc))
diff --git a/testsuite/tests/patsyn/should_fail/T11265.hs b/testsuite/tests/patsyn/should_fail/T11265.hs
new file mode 100644 (file)
index 0000000..a7ee5c4
--- /dev/null
@@ -0,0 +1,6 @@
+{-# LANGUAGE PatternSynonyms, DataKinds #-}
+
+pattern A = True
+
+class    F a
+instance F A
diff --git a/testsuite/tests/patsyn/should_fail/T11265.stderr b/testsuite/tests/patsyn/should_fail/T11265.stderr
new file mode 100644 (file)
index 0000000..eda5d35
--- /dev/null
@@ -0,0 +1,6 @@
+
+T11265.hs:6:12: error:
+    • Pattern synonym ‘A’ cannot be used here
+        (Pattern synonyms cannot be promoted)
+    • In the first argument of ‘F’, namely ‘A’
+      In the instance declaration for ‘F A’
index 4e74469..04d9b31 100644 (file)
@@ -1,5 +1,6 @@
-\r
-T9161-1.hs:6:14: error:\r
-    Pattern synonym ‘PATTERN’ used as a type\r
-    In the type signature:\r
-      wrongLift :: PATTERN\r
+
+T9161-1.hs:6:14: error:
+    • Pattern synonym ‘PATTERN’ cannot be used here
+        (Pattern synonyms cannot be promoted)
+    • In the type signature:
+        wrongLift :: PATTERN
index b7a1f36..409b922 100644 (file)
@@ -1,6 +1,7 @@
 
 T9161-2.hs:8:20: error:
-    • Pattern synonym ‘PATTERN’ used as a type
+    • Pattern synonym ‘PATTERN’ cannot be used here
+        (Pattern synonyms cannot be promoted)
     • In the first argument of ‘Proxy’, namely ‘PATTERN’
       In the type signature:
         wrongLift :: Proxy PATTERN ()
index 6ef64ae..eeb405b 100644 (file)
@@ -27,3 +27,4 @@ test('export-type-synonym', normal, compile_fail, [''])
 test('export-ps-rec-sel', normal, compile_fail, [''])
 test('T11053', normal, compile, ['-fwarn-missing-pat-syn-sigs'])
 test('T10426', normal, compile_fail, [''])
+test('T11265', normal, compile_fail, [''])