Rejig builders for pattern synonyms, especially unlifted oneswip/pattern-synonym-backport

When a pattern synonym is for an unlifted pattern, its "builder" would
naturally be a top-level unlifted binding, which isn't allowed.  So we
give it an extra Void# argument.

Our Plan A involved then making *two* Ids for these builders, with
some consequential fuss in the desugarer.  This was more pain than I
liked, so I've re-jigged it.

 * There is just one builder for a pattern synonym.

 * It may have an extra Void# arg, but this decision is signalled
   by the Bool in the psBuilder field.

   I did the same for the psMatcher field.

   Both Bools are serialised into interface files, so there is
   absolutely no doubt whether that extra Void# argument is required.

 * I renamed "wrapper" to "builder".  We have too may "wrappers"

 * In order to deal with typecchecking occurrences of P in expressions,
   I refactored the tcInferId code in TcExpr.

All of this allowed me to revert 5fe872
   "Apply compulsory unfoldings during desugaring, except for `seq` which is special."
which turned out to be a rather messy hack in DsBinds

    (cherry picked from commit e876208117a34fb58f7f1e470de2f954b3ca303d)

10 files changed, 316 insertions, 213 deletions

diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index 528b95a02e..7f4310e5c2 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -13,7 +13,7 @@ module PatSyn (
         -- ** Type deconstruction
         patSynName, patSynArity, patSynIsInfix,
         patSynArgs, patSynTyDetails, patSynType,
-        patSynWrapper, patSynMatcher,
+        patSynMatcher, patSynBuilder,
         patSynExTyVars, patSynSig,
         patSynInstArgTys, patSynInstResTy,
         tidyPatSynIds
@@ -38,6 +38,59 @@ import Data.Function
 \end{code}
 
 
+%************************************************************************
+%*                                                                      *
+\subsection{Pattern synonyms}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+-- | A pattern synonym
+-- See Note [Pattern synonym representation]
+data PatSyn
+  = MkPatSyn {
+        psName        :: Name,
+        psUnique      :: Unique,      -- Cached from Name
+
+        psArgs        :: [Type],
+        psArity       :: Arity,       -- == length psArgs
+        psInfix       :: Bool,        -- True <=> declared infix
+
+        psUnivTyVars  :: [TyVar],     -- Universially-quantified type variables
+        psReqTheta    :: ThetaType,   -- Required dictionaries
+        psExTyVars    :: [TyVar],     -- Existentially-quantified type vars
+        psProvTheta   :: ThetaType,   -- Provided dictionaries
+        psOrigResTy   :: Type,        -- Mentions only psUnivTyVars
+
+        -- See Note [Matchers and builders for pattern synonyms]
+        psMatcher     :: (Id, Bool),
+             -- Matcher function.
+             -- If Bool is True then prov_theta and arg_tys are empty
+             -- and type is
+             --   forall (r :: ?) univ_tvs. req_theta
+             --                       => res_ty
+             --                       -> (forall ex_tvs. Void# -> r)
+             --                       -> (Void# -> r)
+             --                       -> r
+             --
+             -- Otherwise type is
+             --   forall (r :: ?) univ_tvs. req_theta
+             --                       => res_ty
+             --                       -> (forall ex_tvs. prov_theta => arg_tys -> r)
+             --                       -> (Void# -> r)
+             --                       -> r
+
+        psBuilder     :: Maybe (Id, Bool)
+             -- Nothing  => uni-directional pattern synonym
+             -- Just (builder, is_unlifted) => bi-directional
+             -- Wrapper function, of type
+             --  forall univ_tvs, ex_tvs. (prov_theta, req_theta)
+             --                       =>  arg_tys -> res_ty
+             -- See Note [Builder for pattern synonyms with unboxed type]
+  }
+  deriving Data.Typeable.Typeable
+\end{code}
+
 Note [Pattern synonym representation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider the following pattern synonym declaration
@@ -69,11 +122,17 @@ In this case, the fields of MkPatSyn will be set as follows:
   psReqTheta   = (Eq t, Num t)
   psOrigResTy  = T (Maybe t)
 
-Note [Matchers and wrappers for pattern synonyms]
+Note [Matchers and builders for pattern synonyms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For each pattern synonym, we generate a single matcher function which
-implements the actual matching. For the above example, the matcher
-will have type:
+For each pattern synonym P, we generate
+
+  * a "matcher" function, used to desugar uses of P in patterns,
+    which implements pattern matching
+
+  * A "builder" function (for bidirectional pattern synonyms only),
+    used to desugar uses of P in expressions, which constructs P-values.
+
+For the above example, the matcher function has type:
 
         $mP :: forall (r :: ?) t. (Eq t, Num t)
             => T (Maybe t)
@@ -83,16 +142,22 @@ will have type:
 
 with the following implementation:
 
-        $mP @r @t $dEq $dNum scrut cont fail = case scrut of
-            MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
-            _                                 -> fail Void#
+        $mP @r @t $dEq $dNum scrut cont fail
+          = case scrut of
+              MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x
+              _                                 -> fail Void#
+
+Notice that the return type 'r' has an open kind, so that it can
+be instantiated by an unboxed type; for example where we see
+     f (P x) = 3#
 
 The extra Void# argument for the failure continuation is needed so that
-it is lazy even when the result type is unboxed. For the same reason,
-if the pattern has no arguments, an extra Void# argument is added
-to the success continuation as well.
+it is lazy even when the result type is unboxed.
+
+For the same reason, if the pattern has no arguments, an extra Void#
+argument is added to the success continuation as well.
 
-For *bidirectional* pattern synonyms, we also generate a single wrapper
+For *bidirectional* pattern synonyms, we also generate a "builder"
 function which implements the pattern synonym in an expression
 context. For our running example, it will be:
 
@@ -108,55 +173,21 @@ Injectivity of bidirectional pattern synonyms is checked in
 tcPatToExpr which walks the pattern and returns its corresponding
 expression when available.
 
-%************************************************************************
-%*                                                                      *
-\subsection{Pattern synonyms}
-%*                                                                      *
-%************************************************************************
+Note [Builder for pattern synonyms with unboxed type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For bidirectional pattern synonyms that have no arguments and have an
+unboxed type, we add an extra Void# argument to the builder, else it
+would be a top-level declaration with an unboxed type.
 
-\begin{code}
--- | A pattern synonym
--- See Note [Pattern synonym representation]
-data PatSyn
-  = MkPatSyn {
-        psName        :: Name,
-        psUnique      :: Unique,      -- Cached from Name
+        pattern P = 0#
 
-        psArgs        :: [Type],
-        psArity       :: Arity,       -- == length psArgs
-        psInfix       :: Bool,        -- True <=> declared infix
+        $WP :: Void# -> Int#
+        $WP _ = 0#
 
-        psUnivTyVars  :: [TyVar],     -- Universially-quantified type variables
-        psReqTheta    :: ThetaType,   -- Required dictionaries
-        psExTyVars    :: [TyVar],     -- Existentially-quantified type vars
-        psProvTheta   :: ThetaType,   -- Provided dictionaries
-        psOrigResTy   :: Type,        -- Mentions only psUnivTyVars
+This means that when typechecking an occurrence of P in an expression,
+we must remember that the builder has this void argument. This is
+done by TcPatSyn.patSynBuilderOcc.
 
-        -- See Note [Matchers and wrappers for pattern synonyms]
-        psMatcher     :: Id,
-            -- Matcher function. If psArgs is empty, then it has type
-             --   forall (r :: ?) univ_tvs. req_theta
-             --                       => res_ty
-             --                       -> (forall ex_tvs. prov_theta -> Void# -> r)
-             --                       -> (Void# -> r)
-             --                       -> r
-             --
-             -- Otherwise:
-             --   forall (r :: ?) univ_tvs. req_theta
-             --                       => res_ty
-             --                       -> (forall ex_tvs. prov_theta -> arg_tys -> r)
-             --                       -> (Void# -> r)
-             --                       -> r
-
-        psWrapper     :: Maybe Id
-             -- Nothing  => uni-directional pattern synonym
-             -- Just wid => bi-direcitonal
-             -- Wrapper function, of type
-             --  forall univ_tvs, ex_tvs. (prov_theta, req_theta)
-             --                       =>  arg_tys -> res_ty
-  }
-  deriving Data.Typeable.Typeable
-\end{code}
 
 %************************************************************************
 %*                                                                      *
@@ -208,20 +239,20 @@ instance Data.Data PatSyn where
 mkPatSyn :: Name
          -> Bool                 -- ^ Is the pattern synonym declared infix?
          -> ([TyVar], ThetaType) -- ^ Universially-quantified type variables
-                                --   and required dicts
+                                 --   and required dicts
          -> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
-                                --   and provided dicts
+                                 --   and provided dicts
          -> [Type]               -- ^ Original arguments
          -> Type                 -- ^ Original result type
-         -> Id                   -- ^ Name of matcher
-         -> Maybe Id             -- ^ Name of wrapper
+         -> (Id, Bool)           -- ^ Name of matcher
+         -> Maybe (Id, Bool)     -- ^ Name of builder
          -> PatSyn
 mkPatSyn name declared_infix
          (univ_tvs, req_theta)
          (ex_tvs, prov_theta)
          orig_args
          orig_res_ty
-         matcher wrapper
+         matcher builder
     = MkPatSyn {psName = name, psUnique = getUnique name,
                 psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
                 psProvTheta = prov_theta, psReqTheta = req_theta,
@@ -230,7 +261,7 @@ mkPatSyn name declared_infix
                 psArity = length orig_args,
                 psOrigResTy = orig_res_ty,
                 psMatcher = matcher,
-                psWrapper = wrapper }
+                psBuilder = builder }
 \end{code}
 
 \begin{code}
@@ -274,15 +305,17 @@ patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
                     , psArgs = arg_tys, psOrigResTy = res_ty })
   = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
 
-patSynWrapper :: PatSyn -> Maybe Id
-patSynWrapper = psWrapper
-
-patSynMatcher :: PatSyn -> Id
+patSynMatcher :: PatSyn -> (Id,Bool)
 patSynMatcher = psMatcher
 
+patSynBuilder :: PatSyn -> Maybe (Id, Bool)
+patSynBuilder = psBuilder
+
 tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
-tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
-  = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id }
+tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })
+  = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }
+  where
+    tidy_pr (id, dummy) = (tidy_fn id, dummy)
 
 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
 -- Return the types of the argument patterns
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 42abf2c63d..846c4211ca 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -354,18 +354,18 @@ mkPatSynCase var ty alt fail = do
     matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
     let MatchResult _ mkCont = match_result
     cont <- mkCoreLams bndrs <$> mkCont fail
-    return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, make_unstrict fail]
+    return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
   where
     MkCaseAlt{ alt_pat = psyn,
                alt_bndrs = bndrs,
                alt_wrapper = wrapper,
                alt_result = match_result} = alt
-    matcher = patSynMatcher psyn
+    (matcher, needs_void_lam) = patSynMatcher psyn
 
-    -- See Note [Matchers and wrappers for pattern synonyms] in PatSyns
+    -- See Note [Matchers and builders for pattern synonyms] in PatSyns
     -- on these extra Void# arguments
-    ensure_unstrict = if null (patSynArgs psyn) then make_unstrict else id
-    make_unstrict = Lam voidArgId
+    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
+                         | otherwise      = cont
 
 mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
 mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 31be15b638..72fe56e11d 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -184,13 +184,13 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
 ------------------------------------------------------
 buildPatSyn :: Name -> Bool
-            -> Id -> Maybe Id
+            -> (Id,Bool) -> Maybe (Id, Bool)
             -> ([TyVar], ThetaType) -- ^ Univ and req
             -> ([TyVar], ThetaType) -- ^ Ex and prov
             -> [Type]               -- ^ Argument types
             -> Type                 -- ^ Result type
             -> PatSyn
-buildPatSyn src_name declared_infix matcher wrapper
+buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
             (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty
   = ASSERT((and [ univ_tvs == univ_tvs'
                 , ex_tvs == ex_tvs'
@@ -202,9 +202,9 @@ buildPatSyn src_name declared_infix matcher wrapper
     mkPatSyn src_name declared_infix
              (univ_tvs, req_theta) (ex_tvs, prov_theta)
              arg_tys pat_ty
-             matcher wrapper
+             matcher builder
   where
-    ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher
+    ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id
     ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
     (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
     (arg_tys', _) = tcSplitFunTys cont_tau
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index a7f1780aac..7235652d25 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -122,8 +122,8 @@ data IfaceDecl
 
   | IfacePatSyn { ifName          :: OccName,           -- Name of the pattern synonym
                   ifPatIsInfix    :: Bool,
-                  ifPatMatcher    :: IfExtName,
-                  ifPatWrapper    :: Maybe IfExtName,
+                  ifPatMatcher    :: (IfExtName, Bool),
+                  ifPatBuilder    :: Maybe (IfExtName, Bool),
                   -- Everything below is redundant,
                   -- but needed to implement pprIfaceDecl
                   ifPatUnivTvs    :: [IfaceTvBndr],
@@ -1104,15 +1104,15 @@ pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branche
   = hang (ptext (sLit "axiom") <+> ppr name <> dcolon)
        2 (vcat $ map (pprAxBranch $ Just tycon) branches)
 
-pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
+pprIfaceDecl (IfacePatSyn { ifName = name, ifPatBuilder = builder,
                             ifPatIsInfix = is_infix,
                             ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
                             ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
                             ifPatArgs = args,
                             ifPatTy = ty })
-  = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
+  = pprPatSynSig name has_builder args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
   where
-    has_wrap = isJust wrapper
+    has_builder = isJust builder
     args' = case (is_infix, args) of
         (True, [left_ty, right_ty]) ->
             InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty)
@@ -1394,8 +1394,8 @@ freeNamesIfDecl d@IfaceAxiom{} =
   freeNamesIfTc (ifTyCon d) &&&
   fnList freeNamesIfAxBranch (ifAxBranches d)
 freeNamesIfDecl d@IfacePatSyn{} =
-  unitNameSet (ifPatMatcher d) &&&
-  maybe emptyNameSet unitNameSet (ifPatWrapper d) &&&
+  unitNameSet (fst (ifPatMatcher d)) &&&
+  maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&
   freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
   freeNamesIfTvBndrs (ifPatExTvs d) &&&
   freeNamesIfContext (ifPatProvCtxt d) &&&
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 32b43875b3..97efc365fb 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1488,8 +1488,8 @@ dataConToIfaceDecl dataCon
 patSynToIfaceDecl :: PatSyn -> IfaceDecl
 patSynToIfaceDecl ps
   = IfacePatSyn { ifName          = getOccName . getName $ ps
-                , ifPatMatcher    = matcher
-                , ifPatWrapper    = wrapper
+                , ifPatMatcher    = to_if_pr (patSynMatcher ps)
+                , ifPatBuilder    = fmap to_if_pr (patSynBuilder ps)
                 , ifPatIsInfix    = patSynIsInfix ps
                 , ifPatUnivTvs    = toIfaceTvBndrs univ_tvs'
                 , ifPatExTvs      = toIfaceTvBndrs ex_tvs'
@@ -1502,10 +1502,7 @@ patSynToIfaceDecl ps
     (univ_tvs, ex_tvs, prov_theta, req_theta, args, rhs_ty) = patSynSig ps
     (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
     (env2, ex_tvs')   = tidyTyVarBndrs env1 ex_tvs
-
-    matcher = idName (patSynMatcher ps)
-    wrapper = fmap idName (patSynWrapper ps)
-
+    to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
 
 --------------------------
 coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 873fdc1a63..281e7f6557 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -584,8 +584,8 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
        ; return (ACoAxiom axiom) }
 
 tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
-                              , ifPatMatcher = matcher_name
-                              , ifPatWrapper = wrapper_name
+                              , ifPatMatcher = if_matcher
+                              , ifPatBuilder = if_builder
                               , ifPatIsInfix = is_infix
                               , ifPatUnivTvs = univ_tvs
                               , ifPatExTvs = ex_tvs
@@ -595,11 +595,8 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                               , ifPatTy = pat_ty })
   = do { name <- lookupIfaceTop occ_name
        ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
-       ; matcher <- tcExt "Matcher" matcher_name
-       ; wrapper <- case wrapper_name of
-                        Nothing -> return Nothing
-                        Just wn -> do { wid <- tcExt "Wrapper" wn
-                                      ; return (Just wid) }
+       ; matcher <- tc_pr if_matcher
+       ; builder <- fmapMaybeM tc_pr if_builder
        ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
        { bindIfaceTyVars ex_tvs $ \ex_tvs -> do
        { patsyn <- forkM (mk_doc name) $
@@ -607,13 +604,15 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                 ; req_theta  <- tcIfaceCtxt req_ctxt
                 ; pat_ty     <- tcIfaceType pat_ty
                 ; arg_tys    <- mapM tcIfaceType args
-                ; return $ buildPatSyn name is_infix matcher wrapper
+                ; return $ buildPatSyn name is_infix matcher builder
                                        (univ_tvs, req_theta) (ex_tvs, prov_theta)
                                        arg_tys pat_ty }
        ; return $ AConLike . PatSynCon $ patsyn }}}
   where
      mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
-     tcExt s name = forkM (ptext (sLit s) <+> ppr name) $ tcIfaceExtId name
+     tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
+     tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
+                        ; return (id, b) }
 
 tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch]
 tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 7a97c30cdc..e7b8a4c459 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -27,7 +27,6 @@ import TcEvidence
 import TcHsType
 import TcPat
 import TcMType
-import PatSyn
 import ConLike
 import Type( tidyOpenType )
 import FunDeps( growThetaTyVars )
@@ -413,11 +412,8 @@ tc_single _top_lvl _sig_fn _prag_fn (L _ (PatSynBind psb)) thing_inside
   = do { (pat_syn, aux_binds) <- tcPatSynDecl psb
 
        ; let tything = AConLike (PatSynCon pat_syn)
-             implicit_ids = (patSynMatcher pat_syn) :
-                            (maybeToList (patSynWrapper pat_syn))
 
        ; thing <- tcExtendGlobalEnv [tything] $
-                  tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
                   thing_inside
        ; return (aux_binds, thing)
        }
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 3397b0836a..649d3f2e04 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -30,6 +30,7 @@ import TcEnv
 import TcArrows
 import TcMatches
 import TcHsType
+import TcPatSyn( tcPatSynBuilderOcc )
 import TcPat
 import TcMType
 import TcType
@@ -37,7 +38,6 @@ import DsMonad hiding (Splice)
 import Id
 import ConLike
 import DataCon
-import PatSyn
 import RdrName
 import Name
 import TyCon
@@ -1047,6 +1047,7 @@ in the other order, the extra signature in f2 is reqd.
 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
 tcCheckId name res_ty
   = do { (expr, actual_res_ty) <- tcInferId name
+       ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
        ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
          tcWrapResult expr actual_res_ty res_ty }
 
@@ -1060,31 +1061,33 @@ tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
 -- Look up an occurrence of an Id, and instantiate it (deeply)
 
 tcInferIdWithOrig orig id_name
-  = do { id <- lookup_id
-       ; (id_expr, id_rho) <- instantiateOuter orig id
-       ; (wrap, rho) <- deeplyInstantiate orig id_rho
-       ; return (mkHsWrap wrap id_expr, rho) }
+  = do { id_or_expr <- lookup_id
+       ; case id_or_expr of
+           Left id ->
+               do { (id_expr, id_rho) <- instantiateOuter orig id
+                  ; (wrap, rho) <- deeplyInstantiate orig id_rho
+                  ; return (mkHsWrap wrap id_expr, rho) }
+           Right (expr, rho) ->
+               do { return (expr, rho) }}
   where
-    lookup_id :: TcM TcId
+    lookup_id :: TcM (Either TcId (HsExpr TcId, TcRhoType))
     lookup_id
        = do { thing <- tcLookup id_name
             ; case thing of
                  ATcId { tct_id = id }
                    -> do { check_naughty id        -- Note [Local record selectors]
                          ; checkThLocalId id
-                         ; return id }
+                         ; return $ Left id }
 
                  AGlobal (AnId id)
-                   -> do { check_naughty id; return id }
+                   -> do { check_naughty id; return $ Left id }
                         -- A global cannot possibly be ill-staged
                         -- nor does it need the 'lifting' treatment
                         -- hence no checkTh stuff here
 
                  AGlobal (AConLike cl) -> case cl of
-                     RealDataCon con -> return (dataConWrapId con)
-                     PatSynCon ps -> case patSynWrapper ps of
-                         Nothing -> failWithTc (bad_patsyn ps)
-                         Just id -> return id
+                     RealDataCon con -> return $ Left $ dataConWrapId con
+                     PatSynCon ps -> fmap Right $ tcPatSynBuilderOcc orig ps
 
                  other -> failWithTc (bad_lookup other) }
 
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index 45be899a30..a2dc510207 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -5,7 +5,7 @@
 \section[TcPatSyn]{Typechecking pattern synonym declarations}
 
 \begin{code}
-module TcPatSyn (tcPatSynDecl) where
+module TcPatSyn (tcPatSynDecl, tcPatSynBuilderOcc) where
 
 import HsSyn
 import TcPat
@@ -32,15 +32,23 @@ import Data.Monoid
 import Bag
 import TcEvidence
 import BuildTyCl
+import Data.Maybe
+import Inst (deeplyInstantiate)
 
 #include "HsVersions.h"
 \end{code}
 
+%************************************************************************
+%*                                                                      *
+                    Type checking a pattern synonym
+%*                                                                      *
+%************************************************************************
+
 \begin{code}
 tcPatSynDecl :: PatSynBind Name Name
              -> TcM (PatSyn, LHsBinds Id)
-tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
-                  psb_def = lpat, psb_dir = dir }
+tcPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details,
+                      psb_def = lpat, psb_dir = dir }
   = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
        ; tcCheckPatSynPat lpat
        ; pat_ty <- newFlexiTyVarTy openTypeKind
@@ -68,6 +76,7 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
        ; req_theta  <- zonkTcThetaType req_theta
        ; pat_ty     <- zonkTcType pat_ty
        ; args       <- mapM zonkId args
+       ; let arg_tys = map varType args
 
        ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$
                                      ppr prov_theta $$
@@ -90,22 +99,30 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
                                          prov_dicts req_dicts
                                          prov_theta req_theta
                                          pat_ty
-       ; m_wrapper <- tcPatSynWrapper lname lpat dir args
-                                      univ_tvs ex_tvs theta pat_ty
-       ; let binds = matcher_bind `unionBags` maybe emptyBag snd m_wrapper
+
+       ; builder_id <- mkPatSynBuilderId dir lname (univ_tvs ++ ex_tvs) theta arg_tys pat_ty
+       ; builder_bind <- maybe (return emptyBag) (tcPatSynBuilderBind psb) builder_id
+
+       ; let binds = matcher_bind `unionBags` builder_bind
 
        ; traceTc "tcPatSynDecl }" $ ppr name
+
        ; let patSyn = mkPatSyn name is_infix
                         (univ_tvs, req_theta)
                         (ex_tvs, prov_theta)
                         (map varType args)
                         pat_ty
-                        matcher_id (fmap fst m_wrapper)
+                        matcher_id builder_id
        ; return (patSyn, binds) }
-
 \end{code}
 
 
+%************************************************************************
+%*                                                                      *
+         Constructing the "matcher" Id and its binding
+%*                                                                      *
+%************************************************************************
+
 \begin{code}
 tcPatSynMatcher :: Located Name
                 -> LPat Id
@@ -115,35 +132,39 @@ tcPatSynMatcher :: Located Name
                 -> [EvVar] -> [EvVar]
                 -> ThetaType -> ThetaType
                 -> TcType
-                -> TcM (Id, LHsBinds Id)
+                -> TcM ((Id, Bool), LHsBinds Id)
 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
 tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty
-  = do { res_tv <- do
-              { uniq <- newUnique
-              ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
-              ; return $ mkTcTyVar tv_name openTypeKind (SkolemTv False) }
-       ; matcher_name <- newImplicitBinder name mkMatcherOcc
-       ; let res_ty = mkTyVarTy res_tv
-             cont_args = if null args then [voidPrimId] else args
+  = do { uniq <- newUnique
+       ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
+             res_tv  = mkTcTyVar tv_name openTypeKind (SkolemTv False)
+             is_unlifted = null args && null prov_dicts
+             res_ty = mkTyVarTy res_tv
+             (cont_arg_tys, cont_args)
+               | is_unlifted = ([voidPrimTy], [nlHsVar voidPrimId])
+               | otherwise   = unzip [ (varType arg, nlHsVar arg)
+                                     | arg <- args
+                                     ]
              cont_ty = mkSigmaTy ex_tvs prov_theta $
-                       mkFunTys (map varType cont_args) res_ty
+                       mkFunTys cont_arg_tys res_ty
+
              fail_ty = mkFunTy voidPrimTy res_ty
 
-       ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
-             matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
-             matcher_id = mkVanillaGlobal matcher_name matcher_sigma
+       ; matcher_name <- newImplicitBinder name mkMatcherOcc
+       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty
+       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty
+       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty
 
-       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
-       ; let matcher_lid = L loc matcher_id
+       ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
+             matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau
+             matcher_id    = mkVanillaGlobal matcher_name matcher_sigma
 
-       ; scrutinee <- mkId "scrut" pat_ty
-       ; cont <- mkId "cont" cont_ty
-       ; let cont' = nlHsTyApps cont (map mkTyVarTy ex_tvs) $
-                     map nlHsVar (prov_dicts ++ cont_args)
-       ; fail <- mkId "fail" fail_ty
-       ; let fail' = nlHsApps fail [nlHsVar voidPrimId]
+             cont_dicts = map nlHsVar prov_dicts
+             cont' = nlHsTyApps cont (map mkTyVarTy ex_tvs)
+                                (cont_dicts ++ cont_args)
+             fail' = nlHsApps fail [nlHsVar voidPrimId]
 
-       ; let args = map nlVarPat [scrutinee, cont, fail]
+             args = map nlVarPat [scrutinee, cont, fail]
              lwpat = noLoc $ WildPat pat_ty
              cases = if isIrrefutableHsPat lpat
                      then [mkSimpleHsAlt lpat  cont']
@@ -164,7 +185,6 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
                        , mg_res_ty = res_ty
                        , mg_origin = Generated
                        }
-
              match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds
              mg = MG{ mg_alts = [match]
                     , mg_arg_tys = []
@@ -172,7 +192,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
                     , mg_origin = Generated
                     }
 
-       ; let bind = FunBind{ fun_id = matcher_lid
+       ; let bind = FunBind{ fun_id = L loc matcher_id
                            , fun_infix = False
                            , fun_matches = mg
                            , fun_co_fn = idHsWrapper
@@ -180,67 +200,122 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
                            , fun_tick = Nothing }
              matcher_bind = unitBag (noLoc bind)
 
+       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
        ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
 
-       ; return (matcher_id, matcher_bind) }
-  where
-    mkId s ty = mkSysLocalM (fsLit s) ty
+       ; return ((matcher_id, is_unlifted), matcher_bind) }
 
-tcPatSynWrapper :: Located Name
-                -> LPat Name
-                -> HsPatSynDir Name
-                -> [Var]
-                -> [TyVar] -> [TyVar]
-                -> ThetaType
-                -> TcType
-                -> TcM (Maybe (Id, LHsBinds Id))
--- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
-tcPatSynWrapper lname lpat dir args univ_tvs ex_tvs theta pat_ty
-  = do { let argNames = mkNameSet (map Var.varName args)
-       ; case (dir, tcPatToExpr argNames lpat) of
-           (Unidirectional, _) ->
-               return Nothing
-           (ImplicitBidirectional, Nothing) ->
-               cannotInvertPatSynErr lpat
-           (ImplicitBidirectional, Just lexpr) ->
-               fmap Just $ tc_pat_syn_wrapper_from_expr lname lexpr args univ_tvs ex_tvs theta pat_ty }
-
-tc_pat_syn_wrapper_from_expr :: Located Name
-                             -> LHsExpr Name
-                             -> [Var]
-                             -> [TyVar] -> [TyVar]
-                             -> ThetaType
-                             -> Type
-                             -> TcM (Id, LHsBinds Id)
-tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_ty
-  = do { let qtvs = univ_tvs ++ ex_tvs
-       ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs
-       ; let wrapper_theta = substTheta subst theta
-             pat_ty' = substTy subst pat_ty
-             args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args
-             wrapper_tau = mkFunTys (map varType args') pat_ty'
-             wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau
-
-       ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
-       ; let wrapper_id = mkVanillaGlobal wrapper_name wrapper_sigma
-
-       ; let wrapper_args = map (noLoc . VarPat . Var.varName) args'
-             wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
-             bind = mkTopFunBind Generated (L loc wrapper_name) [wrapper_match]
-             lbind = noLoc bind
-       ; let sig = TcSigInfo{ sig_id = wrapper_id
-                            , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs
-                            , sig_theta = wrapper_theta
-                            , sig_tau = wrapper_tau
-                            , sig_loc = loc
+
+isUnidirectional :: HsPatSynDir a -> Bool
+isUnidirectional Unidirectional          = True
+isUnidirectional ImplicitBidirectional   = False
+\end{code}
+
+
+%************************************************************************
+%*                                                                      *
+         Constructing the "builder" Id
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+mkPatSynBuilderId :: HsPatSynDir a -> Located Name
+                  -> [TyVar] -> ThetaType -> [Type] -> Type
+                  -> TcM (Maybe (Id, Bool))
+mkPatSynBuilderId dir  (L _ name) qtvs theta arg_tys pat_ty
+  | isUnidirectional dir
+  = return Nothing
+  | otherwise
+  = do { builder_name <- newImplicitBinder name mkDataConWorkerOcc
+       ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty)
+             builder_id    = mkVanillaGlobal builder_name builder_sigma
+       ; return (Just (builder_id, need_dummy_arg)) }
+  where
+    builder_arg_tys | need_dummy_arg = [voidPrimTy]
+                    | otherwise = arg_tys
+    need_dummy_arg = isUnLiftedType pat_ty && null arg_tys && null theta
+
+tcPatSynBuilderBind :: PatSynBind Name Name
+                    -> (Id, Bool)
+                    -> TcM (LHsBinds Id)
+-- See Note [Matchers and builders for pattern synonyms] in PatSyn
+tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
+                       , psb_dir = dir, psb_args = details }
+                    (worker_id, need_dummy_arg)
+  | isUnidirectional dir
+  = return emptyBag
+
+  | isNothing mb_match_group       -- Can't invert the pattern
+  = setSrcSpan (getLoc lpat) $ failWithTc $
+    hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
+       2 (ppr lpat)
+
+  | otherwise
+  = do { let match_dummy = mkMatch [nlWildPat] (noLoc $ HsLam mg) emptyLocalBinds
+             mg' | need_dummy_arg = mkMatchGroup Generated [match_dummy]
+                 | otherwise      = mg
+
+       ; let (worker_tvs, worker_theta, worker_tau) = tcSplitSigmaTy (idType worker_id)
+             bind = FunBind { fun_id = L loc (idName worker_id)
+                            , fun_infix = False
+                            , fun_matches = mg'
+                            , fun_co_fn = idHsWrapper
+                            , bind_fvs = placeHolderNames
+                            , fun_tick = Nothing }
+
+             sig = TcSigInfo{ sig_id = worker_id
+                            , sig_tvs = map (\tv -> (Nothing, tv)) worker_tvs
+                            , sig_theta = worker_theta
+                            , sig_tau = worker_tau
+                            , sig_loc = noSrcSpan
                             }
-       ; (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig lbind
-       ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds
-       ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id)
-       ; return (wrapper_id, wrapper_binds) }
 
+       ; (worker_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
+       ; traceTc "tcPatSynDecl worker" $ ppr worker_binds
+       ; return worker_binds }
+  where
+    Just mg = mb_match_group
+    mb_match_group = case dir of
+                        Unidirectional           -> Nothing
+                        ImplicitBidirectional    -> fmap mk_mg (tcPatToExpr args lpat)
+
+    mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
+    mk_mg body = mkMatchGroup Generated [wrapper_match]
+               where
+                 wrapper_args  = [L loc (VarPat n) | L loc n <- args]
+                 wrapper_match = mkMatch wrapper_args body EmptyLocalBinds
+
+    args = case details of
+              PrefixPatSyn args -> args
+              InfixPatSyn arg1 arg2 -> [arg1, arg2]
+
+tcPatSynBuilderOcc :: CtOrigin -> PatSyn -> TcM (HsExpr TcId, TcRhoType)
+-- The result type should be fully instantiated
+tcPatSynBuilderOcc orig ps
+  | Just (builder_id, add_void_arg) <- builder
+  = do { (wrap, rho) <- deeplyInstantiate orig (idType builder_id)
+       ; let inst_fun = mkHsWrap wrap (HsVar builder_id)
+       ; if add_void_arg
+         then return ( HsApp (noLoc inst_fun) (nlHsVar voidPrimId)
+                     , tcFunResultTy rho )
+         else return ( inst_fun, rho ) }
+
+  | otherwise  -- Unidirectional
+  = failWithTc $
+    ptext (sLit "non-bidirectional pattern synonym")
+    <+> quotes (ppr name) <+> ptext (sLit "used in an expression")
+  where
+    name    = patSynName ps
+    builder = patSynBuilder ps
 \end{code}
 
+
+%************************************************************************
+%*                                                                      *
+         Helper functions
+%*                                                                      *
+%************************************************************************
+
 Note [As-patterns in pattern synonym definitions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -304,15 +379,16 @@ nPlusKPatInPatSynErr pat
     hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:"))
        2 (ppr pat)
 
-tcPatToExpr :: NameSet -> LPat Name -> Maybe (LHsExpr Name)
-tcPatToExpr lhsVars = go
+tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name)
+tcPatToExpr args = go
   where
+    lhsVars = mkNameSet (map unLoc args)
+
     go :: LPat Name -> Maybe (LHsExpr Name)
     go (L loc (ConPatIn conName info))
-      = do
-          { let con = L loc (HsVar (unLoc conName))
-          ; exprs <- mapM go (hsConPatArgs info)
-          ; return $ foldl (\x y -> L loc (HsApp x y)) con exprs }
+      = do { let con = L loc (HsVar (unLoc conName))
+           ; exprs <- mapM go (hsConPatArgs info)
+           ; return $ foldl (\x y -> L loc (HsApp x y)) con exprs }
     go (L loc p) = fmap (L loc) $ go1 p
 
     go1 :: Pat Name -> Maybe (HsExpr Name)
@@ -343,12 +419,6 @@ tcPatToExpr lhsVars = go
     go1   (CoPat{})                = panic "CoPat in output of renamer"
     go1   _                        = Nothing
 
-cannotInvertPatSynErr :: OutputableBndr name => LPat name -> TcM a
-cannotInvertPatSynErr (L loc pat)
-  = setSrcSpan loc $ failWithTc $
-    hang (ptext (sLit "Right-hand side of bidirectional pattern synonym cannot be used as an expression"))
-       2 (ppr pat)
-
 -- Walk the whole pattern and for all ConPatOuts, collect the
 -- existentially-bound type variables and evidence binding variables.
 --
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 01c9d36cf3..eec06ebb20 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -426,6 +426,11 @@ newSysName occ
   = do { uniq <- newUnique
        ; return (mkSystemName uniq occ) }
 
+newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
+newSysLocalId fs ty
+  = do  { u <- newUnique
+        ; return (mkSysLocal fs u ty) }
+
 newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
 newSysLocalIds fs tys
   = do  { us <- newUniqueSupply