INLINE pragma for patterns (#12178)

Allow INLINE and NOINLINE pragmas to be used for patterns.
Those are applied to both the builder and matcher (where applicable).

18 files changed, 248 insertions, 20 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 61d52bc47d..7997f5d182 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -476,6 +476,23 @@ Ambiguity:
     the -XTransformListComp extension.
 -}
 
+{- Note [%shift: activation -> {- empty -}]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Context:
+    sigdecl -> '{-# INLINE' . activation qvarcon '#-}'
+    activation -> {- empty -}
+    activation -> explicit_activation
+
+Example:
+
+    {-# INLINE [0] Something #-}
+
+Ambiguity:
+    We don't know whether the '[' is the start of the activation or the beginning
+    of the [] data constructor.
+    We parse this as having '[0]' activation for inlining 'Something', rather than
+    empty activation and inlining '[0] Something'.
+-}
 
 {- Note [Parser API Annotations]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1607,6 +1624,10 @@ pattern_synonym_sig :: { LSig GhcPs }
                    {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) $4)
                           [mj AnnPattern $1, mu AnnDcolon $3] }
 
+qvarcon :: { Located RdrName }
+        : qvar                          { $1 }
+        | qcon                          { $1 }
+
 -----------------------------------------------------------------------------
 -- Nested declarations
 
@@ -2506,7 +2527,7 @@ sigdecl :: { LHsDecl GhcPs }
                     ([ mo $1 ] ++ dcolon ++ [mc $4]) }
 
         -- This rule is for both INLINE and INLINABLE pragmas
-        | '{-# INLINE' activation qvar '#-}'
+        | '{-# INLINE' activation qvarcon '#-}'
                 {% ams ((sLL $1 $> $ SigD noExtField (InlineSig noExtField $3
                             (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)
                                             (snd $2)))))
@@ -2546,7 +2567,8 @@ sigdecl :: { LHsDecl GhcPs }
                    [mo $1,mc $3] }
 
 activation :: { ([AddAnn],Maybe Activation) }
-        : {- empty -}                           { ([],Nothing) }
+        : -- See Note [%shift: activation -> {- empty -}]
+          {- empty -} %shift                    { ([],Nothing) }
         | explicit_activation                   { (fst $1,Just (snd $1)) }
 
 explicit_activation :: { ([AddAnn],Activation) }  -- In brackets
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index 896ded667b..178390192f 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -445,10 +445,10 @@ tc_single :: forall thing.
             TopLevelFlag -> TcSigFun -> TcPragEnv
           -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
           -> TcM (LHsBinds GhcTc, thing)
-tc_single _top_lvl sig_fn _prag_fn
+tc_single _top_lvl sig_fn prag_fn
           (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))
           _ thing_inside
-  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)
+  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) prag_fn
        ; thing <- setGblEnv tcg_env thing_inside
        ; return (aux_binds, thing)
        }
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index ae9dd613d3..0a0b3f3bad 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -26,7 +26,7 @@ import GHC.Core.Multiplicity
 import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType )
 import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
 import GHC.Tc.Utils.Monad
-import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId )
+import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags )
 import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Utils.Zonk
@@ -77,12 +77,13 @@ import Data.List( partition, mapAccumL )
 
 tcPatSynDecl :: PatSynBind GhcRn GhcRn
              -> Maybe TcSigInfo
+             -> TcPragEnv -- See Note [Pragmas for pattern synonyms]
              -> TcM (LHsBinds GhcTc, TcGblEnv)
-tcPatSynDecl psb mb_sig
+tcPatSynDecl psb mb_sig prag_fn
   = recoverM (recoverPSB psb) $
     case mb_sig of
-      Nothing                 -> tcInferPatSynDecl psb
-      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
+      Nothing                 -> tcInferPatSynDecl psb prag_fn
+      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn
       _                       -> panic "tcPatSynDecl"
 
 recoverPSB :: PatSynBind GhcRn GhcRn
@@ -139,9 +140,11 @@ pattern.) But it'll do for now.
 -}
 
 tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
+                  -> TcPragEnv
                   -> TcM (LHsBinds GhcTc, TcGblEnv)
 tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
                        , psb_def = lpat, psb_dir = dir })
+                  prag_fn
   = addPatSynCtxt lname $
     do { traceTc "tcInferPatSynDecl {" $ ppr name
 
@@ -186,7 +189,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
 
        ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
        ; rec_fields <- lookupConstructorFields name
-       ; tc_patsyn_finish lname dir is_infix lpat'
+       ; tc_patsyn_finish lname dir is_infix lpat' prag_fn
                           (mkTyVarBinders InferredSpec univ_tvs
                             , req_theta,  ev_binds, req_dicts)
                           (mkTyVarBinders InferredSpec ex_tvs
@@ -344,6 +347,7 @@ is not very helpful, but at least we don't get a Lint error.
 
 tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
                   -> TcPatSynInfo
+                  -> TcPragEnv
                   -> TcM (LHsBinds GhcTc, TcGblEnv)
 tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                          , psb_def = lpat, psb_dir = dir }
@@ -351,6 +355,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
                       , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req  = req_theta
                       , patsig_ex_bndrs   = explicit_ex_bndrs,   patsig_prov = prov_theta
                       , patsig_body_ty    = sig_body_ty }
+                  prag_fn
   = addPatSynCtxt lname $
     do { traceTc "tcCheckPatSynDecl" $
          vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta
@@ -443,7 +448,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
        ; traceTc "tcCheckPatSynDecl }" $ ppr name
 
        ; rec_fields <- lookupConstructorFields name
-       ; tc_patsyn_finish lname dir is_infix lpat'
+       ; tc_patsyn_finish lname dir is_infix lpat' prag_fn
                           (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts)
                           (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts)
                           (args', skol_arg_tys)
@@ -653,6 +658,7 @@ tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
                  -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
                  -> Bool              -- ^ Whether infix
                  -> LPat GhcTc        -- ^ Pattern of the PatSyn
+                 -> TcPragEnv
                  -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])
                  -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])
                  -> ([LHsExpr GhcTc], [TcType])  -- ^ Pattern arguments and types
@@ -660,7 +666,7 @@ tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
                  -> [FieldLabel]      -- ^ Selector names
                  -- ^ Whether fields, empty if not record PatSyn
                  -> TcM (LHsBinds GhcTc, TcGblEnv)
-tc_patsyn_finish lname dir is_infix lpat'
+tc_patsyn_finish lname dir is_infix lpat' prag_fn
                  (univ_tvs, req_theta, req_ev_binds, req_dicts)
                  (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
                  (args, arg_tys)
@@ -691,7 +697,7 @@ tc_patsyn_finish lname dir is_infix lpat'
            ppr pat_ty
 
        -- Make the 'matcher'
-       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn
                                          (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
                                          (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
                                          (args, arg_tys)
@@ -701,7 +707,7 @@ tc_patsyn_finish lname dir is_infix lpat'
        ; builder_id <- mkPatSynBuilderId dir lname
                                          univ_tvs req_theta
                                          ex_tvs   prov_theta
-                                         arg_tys pat_ty
+                                         arg_tys pat_ty prag_fn
 
        -- Make the PatSyn itself
        ; let patSyn = mkPatSyn (unLoc lname) is_infix
@@ -731,13 +737,14 @@ tc_patsyn_finish lname dir is_infix lpat'
 
 tcPatSynMatcher :: Located Name
                 -> LPat GhcTc
+                -> TcPragEnv
                 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
                 -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
                 -> ([LHsExpr GhcTc], [TcType])
                 -> TcType
                 -> TcM ((Id, Bool), LHsBinds GhcTc)
 -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
-tcPatSynMatcher (L loc name) lpat
+tcPatSynMatcher (L loc name) lpat prag_fn
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs, ex_tys, prov_theta, prov_dicts)
                 (args, arg_tys) pat_ty
@@ -800,17 +807,19 @@ tcPatSynMatcher (L loc name) lpat
                     , mg_ext = MatchGroupTc [] res_ty
                     , mg_origin = Generated
                     }
+             prags = lookupPragEnv prag_fn name
+             -- See Note [Pragmas for pattern synonyms]
 
-       ; let bind = FunBind{ fun_id = L loc matcher_id
+       ; matcher_prag_id <- addInlinePrags matcher_id prags
+       ; let bind = FunBind{ fun_id = L loc matcher_prag_id
                            , fun_matches = mg
                            , fun_ext = idHsWrapper
                            , fun_tick = [] }
              matcher_bind = unitBag (noLoc bind)
-
        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
        ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
 
-       ; return ((matcher_id, is_unlifted), matcher_bind) }
+       ; return ((matcher_prag_id, is_unlifted), matcher_bind) }
 
 mkPatSynRecSelBinds :: PatSyn
                     -> [FieldLabel]  -- ^ Visible field labels
@@ -836,10 +845,11 @@ mkPatSynBuilderId :: HsPatSynDir a -> Located Name
                   -> [InvisTVBinder] -> ThetaType
                   -> [InvisTVBinder] -> ThetaType
                   -> [Type] -> Type
+                  -> TcPragEnv
                   -> TcM (Maybe (Id, Bool))
 mkPatSynBuilderId dir (L _ name)
                   univ_bndrs req_theta ex_bndrs prov_theta
-                  arg_tys pat_ty
+                  arg_tys pat_ty prag_fn
   | isUnidirectional dir
   = return Nothing
   | otherwise
@@ -856,8 +866,11 @@ mkPatSynBuilderId dir (L _ name)
               -- See Note [Exported LocalIds] in GHC.Types.Id
 
              builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id
+             prags          = lookupPragEnv prag_fn name
+             -- See Note [Pragmas for pattern synonyms]
 
-       ; return (Just (builder_id', need_dummy_arg)) }
+       ; builder_prag_id <- addInlinePrags builder_id' prags
+       ; return (Just (builder_prag_id, need_dummy_arg)) }
 
 tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
                     -> TcM (LHsBinds GhcTc)
@@ -1129,12 +1142,34 @@ converting the pattern to an expression (for the builder RHS) we
 simply discard the signature.
 
 Note [Record PatSyn Desugaring]
--------------------------------
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It is important that prov_theta comes before req_theta as this ordering is used
 when desugaring record pattern synonym updates.
 
 Any change to this ordering should make sure to change GHC.HsToCore.Expr if you
 want to avoid difficult to decipher core lint errors!
+
+Note [Pragmas for pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+INLINE and NOINLINE pragmas are supported for pattern synonyms. They affect both
+the matcher and the builder.
+(See Note [Matchers and builders for pattern synonyms] in PatSyn)
+
+For example:
+    pattern InlinedPattern x = [x]
+    {-# INLINE InlinedPattern #-}
+    pattern NonInlinedPattern x = [x]
+    {-# NOINLINE NonInlinedPattern #-}
+
+For pattern synonyms with explicit builders, only pragma for the entire pattern
+synonym is supported. For example:
+    pattern HeadC x <- x:xs where
+      HeadC x = [x]
+      -- This wouldn't compile: {-# INLINE HeadC #-}
+    {-# INLINE HeadC #-} -- But this works
+
+When no pragma is provided for a pattern, the inlining decision might change
+between different versions of GHC.
  -}
 
 
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
index 38fc4b52f1..22e5c9fb86 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
@@ -5,9 +5,11 @@ import GHC.Tc.Types ( TcM, TcSigInfo )
 import GHC.Tc.Utils.Monad ( TcGblEnv)
 import GHC.Hs.Extension ( GhcRn, GhcTc )
 import Data.Maybe  ( Maybe )
+import GHC.Tc.Gen.Sig ( TcPragEnv )
 
 tcPatSynDecl :: PatSynBind GhcRn GhcRn
              -> Maybe TcSigInfo
+             -> TcPragEnv
              -> TcM (LHsBinds GhcTc, TcGblEnv)
 
 tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
diff --git a/docs/users_guide/exts/pattern_synonyms.rst b/docs/users_guide/exts/pattern_synonyms.rst
index abb7b82860..9415fb72b4 100644
--- a/docs/users_guide/exts/pattern_synonyms.rst
+++ b/docs/users_guide/exts/pattern_synonyms.rst
@@ -520,4 +520,38 @@ below:
     *Main> g (False:undefined)
     False
 
+Pragmas for pattern synonyms
+----------------------------
+
+The :ref:`inlinable-pragma`, :ref:`inline-pragma` and :ref:`noinline-pragma` are supported for pattern
+synonyms. For example: ::
+
+    patternInlinablePattern x = [x]
+    {-# INLINABLE InlinablePattern #-}
+    pattern InlinedPattern x = [x]
+    {-# INLINE InlinedPattern #-}
+    pattern NonInlinedPattern x = [x]
+    {-# NOINLINE NonInlinedPattern #-}
+
+As with other ``INLINABLE``, ``INLINE`` and ``NOINLINE`` pragmas, it's possible to specify
+to which phase the pragma applies: ::
+
+    pattern Q x = [x]
+    {-# NOINLINE[1] Q #-}
+
+The pragmas are applied both when the pattern is used as a matcher, and as a
+data constructor. For explicitly bidirectional pattern synonyms, the pragma
+must be at top level, not nested in the where clause. For example, this won't compile: ::
+
+    pattern HeadC x <- x:xs where
+      HeadC x = [x]
+      {-# INLINE HeadC #-}
+
+but this will: ::
+
+    pattern HeadC x <- x:xs where
+      HeadC x = [x]
+    {-# INLINE HeadC #-}
 
+When no pragma is provided for a pattern, the inlining decision is made by
+GHC's own inlining heuristics.
diff --git a/testsuite/tests/typecheck/should_compile/InlinePatSyn_ExplicitBidiBuilder.hs b/testsuite/tests/typecheck/should_compile/InlinePatSyn_ExplicitBidiBuilder.hs
new file mode 100644
index 0000000000..2a7c29a3f7
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InlinePatSyn_ExplicitBidiBuilder.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module InlinePatSyn_ExplicitBidiBuilder where
+
+-- Explicit bidirectional pattern
+pattern ExplicitPattern x <- x:xs where
+  ExplicitPattern x = [x]
+{-# INLINE ExplicitPattern #-}
+
+testExplicitBuilder x = ExplicitPattern (x+1)
diff --git a/testsuite/tests/typecheck/should_compile/InlinePatSyn_ExplicitBidiMatcher.hs b/testsuite/tests/typecheck/should_compile/InlinePatSyn_ExplicitBidiMatcher.hs
new file mode 100644
index 0000000000..9c45a2f0ad
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InlinePatSyn_ExplicitBidiMatcher.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module InlinePatSyn_ExplicitBidiMatcher where
+
+-- Explicit bidirectional pattern
+pattern ExplicitPattern x <- x:xs where
+  ExplicitPattern x = [x]
+{-# INLINE ExplicitPattern #-}
+
+testMatcherofExplicitBuilder (ExplicitPattern x) = 1
+testMatcherofExplicitBuilder _  = 2
diff --git a/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlinableBuilder.hs b/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlinableBuilder.hs
new file mode 100644
index 0000000000..3d9a3cd833
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlinableBuilder.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module InlinePatSyn_InlinableBuilder where
+
+-- Pattern with "INLINE" pragma, both builder and matcher should be inlined
+pattern InlinablePattern a = [[[[a]]]]
+{-# INLINABLE InlinablePattern #-}
+
+testInBuilder x = InlinablePattern (x+1)
diff --git a/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlinableMatcher.hs b/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlinableMatcher.hs
new file mode 100644
index 0000000000..ef9066d825
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlinableMatcher.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module InlinePatSyn_InlinableMatcher where
+
+-- Pattern with "INLINE" pragma, both builder and matcher should be inlined
+pattern InlinablePattern a = [[[[a]]]]
+{-# INLINEABLE InlinablePattern #-}
+
+testInMatcher (InlinablePattern x) = 1
+testInMatcher _ = 2
diff --git a/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlineBuilder.hs b/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlineBuilder.hs
new file mode 100644
index 0000000000..80ecc5e6bd
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlineBuilder.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module InlinePatSyn_InlineBuilder where
+
+-- Pattern with "INLINE" pragma, both builder and matcher should be inlined
+pattern InlinePattern a = [[[[a]]]]
+{-# INLINE InlinePattern #-}
+
+testInBuilder x = InlinePattern (x+1)
diff --git a/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlineMatcher.hs b/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlineMatcher.hs
new file mode 100644
index 0000000000..1f343ab1d7
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InlinePatSyn_InlineMatcher.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module InlinePatSyn_InlineMatcher where
+
+-- Pattern with "INLINE" pragma, both builder and matcher should be inlined
+pattern InlinePattern a = [[[[a]]]]
+{-# INLINE InlinePattern #-}
+
+testInMatcher (InlinePattern x) = 1
+testInMatcher _ = 2
diff --git a/testsuite/tests/typecheck/should_compile/InlinePatSyn_NoInlineBuilder.hs b/testsuite/tests/typecheck/should_compile/InlinePatSyn_NoInlineBuilder.hs
new file mode 100644
index 0000000000..39b265e937
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InlinePatSyn_NoInlineBuilder.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module InlinePatSyn_NoInlineBuilder where
+
+-- Pattern with "NOINLINE" pragma, neither builder nor matcher should be inlined
+pattern NonInlinablePattern a = Left a
+{-# NOINLINE NonInlinablePattern #-}
+
+testNonBuilder x = NonInlinablePattern (x+1)
diff --git a/testsuite/tests/typecheck/should_compile/InlinePatSyn_NoInlineMatcher.hs b/testsuite/tests/typecheck/should_compile/InlinePatSyn_NoInlineMatcher.hs
new file mode 100644
index 0000000000..3788830cf6
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/InlinePatSyn_NoInlineMatcher.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T12178 where
+
+-- Pattern with "NOINLINE" pragma, neither builder nor matcher should be inlined
+pattern NonInlinablePattern a = Left a
+{-# NOINLINE NonInlinablePattern #-}
+
+testNonMatcher (NonInlinablePattern x) = 1
+testNonMatcher _ = 2
diff --git a/testsuite/tests/typecheck/should_compile/Makefile b/testsuite/tests/typecheck/should_compile/Makefile
index 5c0c84f8ec..5cb3bd2001 100644
--- a/testsuite/tests/typecheck/should_compile/Makefile
+++ b/testsuite/tests/typecheck/should_compile/Makefile
@@ -80,3 +80,40 @@ T17566:
 	$(RM) -f T17566a.o T17566a.hi T17566.o T17566.hi
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c T17566a.hs
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c T17566.hs
+
+# In the InlinePatSyn tests, we're interested in whether the pattern synonym (whose name always contains the string 'Pattern').
+# is inlined or not. To determine this, we use sed to isolate lines between the start and end of the test definition. That is,
+# from a line starting with 'test', to a blank line. We then use grep to determine if 'Pattern' occurs anywhere in the definition
+# in the core. If it was inlined, it naturally won't occur, so grep -v will succeed, if it wasn't then plain grep will succeed.
+
+InlinePatSyn_InlinableBuilder:
+	$(RM) -f InlinePatSyn_InlinableBuilder.o InlinePatSyn_InlinableBuilder.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_InlinableBuilder.hs  -O -dsuppress-all -ddump-hi | grep -q 'Inline:'
+
+InlinePatSyn_InlinableMatcher:
+	$(RM) -f InlinePatSyn_InlinableMatcher.o InlinePatSyn_InlinableMatcher.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_InlinableMatcher.hs  -O -dsuppress-all -ddump-hi | grep -q 'Inline:'
+
+InlinePatSyn_InlineBuilder:
+	$(RM) -f InlinePatSyn_InlineBuilder.o InlinePatSyn_InlineBuilder.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_InlineBuilder.hs  -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
+
+InlinePatSyn_InlineMatcher:
+	$(RM) -f InlinePatSyn_InlineMatcher.o InlinePatSyn_InlineMatcher.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_InlineMatcher.hs  -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
+
+InlinePatSyn_NoInlineBuilder:
+	$(RM) -f InlinePatSyn_NoInlineBuilder.o InlinePatSyn_NoInlineBuilder.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_NoInlineBuilder.hs  -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -q 'Pattern'
+
+InlinePatSyn_NoInlineMatcher:
+	$(RM) -f InlinePatSyn_NoInlineMatcher.o InlinePatSyn_NoInlineMatcher.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_NoInlineMatcher.hs  -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -q 'Pattern'
+
+InlinePatSyn_ExplicitBidiBuilder:
+	$(RM) -f InlinePatSyn_ExplicitBidiBuilder.o InlinePatSyn_ExplicitBidiBuilder.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_ExplicitBidiBuilder.hs  -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
+
+InlinePatSyn_ExplicitBidiMatcher:
+	$(RM) -f InlinePatSyn_ExplicitBidiMatcher.o InlinePatSyn_ExplicitBidiMatcher.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c InlinePatSyn_ExplicitBidiMatcher.hs  -O -dsuppress-all -ddump-simpl | sed -n '/^test/,/^$$/p' | grep -vq 'Pattern'
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index f7574af0fb..588c5fc2e4 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -756,3 +756,11 @@ test('TyAppPat_Wildcard', normal, compile, [''])
 
 test('T18998', normal, compile, [''])
 test('T18998b', normal, compile, [''])
+test('InlinePatSyn_InlinableBuilder', [], makefile_test, [])
+test('InlinePatSyn_InlinableMatcher', [], makefile_test, [])
+test('InlinePatSyn_InlineBuilder', [], makefile_test, [])
+test('InlinePatSyn_InlineMatcher', [], makefile_test, [])
+test('InlinePatSyn_NoInlineBuilder', [], makefile_test, [])
+test('InlinePatSyn_NoInlineMatcher', [], makefile_test, [])
+test('InlinePatSyn_ExplicitBidiBuilder', [], makefile_test, [])
+test('InlinePatSyn_ExplicitBidiMatcher', [], makefile_test, [])
diff --git a/testsuite/tests/typecheck/should_fail/T12178a.hs b/testsuite/tests/typecheck/should_fail/T12178a.hs
new file mode 100644
index 0000000000..9a94baafbf
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T12178a.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module T12178a where
+
+-- Trying to inline a data constructor fails
+data L a = C a (L a) | T
+{-# INLINE C #-}
diff --git a/testsuite/tests/typecheck/should_fail/T12178a.stderr b/testsuite/tests/typecheck/should_fail/T12178a.stderr
new file mode 100644
index 0000000000..ef9f66a526
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T12178a.stderr
@@ -0,0 +1,4 @@
+
+T12178a.hs:7:12: error:
+    The INLINE pragma for ‘C’ lacks an accompanying binding
+      (The INLINE pragma must be given where ‘C’ is declared)
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 62d6e3b2ae..e92404fbc5 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -605,3 +605,4 @@ test('TyAppPat_PatternBinding', normal, compile_fail, [''])
 test('TyAppPat_PatternBindingExistential', normal, compile_fail, [''])
 test('TyAppPat_ScopedTyVarConflict', normal, compile_fail, [''])
 test('TyAppPat_TooMany', normal, compile_fail, [''])
+test('T12178a', normal, compile_fail, [''])