Rejig builders for pattern synonyms, especially unlifted ones
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 21 Nov 2014 10:04:09 +0000 (10:04 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 21 Nov 2014 11:35:23 +0000 (11:35 +0000)
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

12 files changed:
compiler/basicTypes/PatSyn.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsUtils.lhs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcPatSyn.lhs
compiler/typecheck/TcPatSyn.lhs-boot
compiler/typecheck/TcRnMonad.lhs

index c651080..9fc4f98 100644 (file)
@@ -14,8 +14,7 @@ module PatSyn (
         -- ** Type deconstruction
         patSynName, patSynArity, patSynIsInfix,
         patSynArgs, patSynTyDetails, patSynType,
-        patSynMatcher,
-        patSynWrapper, patSynWorker,
+        patSynMatcher, patSynBuilder,
         patSynExTyVars, patSynSig,
         patSynInstArgTys, patSynInstResTy,
         tidyPatSynIds
@@ -37,10 +36,62 @@ import HsBinds( HsPatSynDetails(..) )
 import qualified Data.Data as Data
 import qualified Data.Typeable
 import Data.Function
-import Control.Arrow (second)
 \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
@@ -72,11 +123,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)
@@ -86,16 +143,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 *bidirectional* pattern synonyms, we also generate a single wrapper
+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 "builder"
 function which implements the pattern synonym in an expression
 context. For our running example, it will be:
 
@@ -111,88 +174,21 @@ Injectivity of bidirectional pattern synonyms is checked in
 tcPatToExpr which walks the pattern and returns its corresponding
 expression when available.
 
-Note [Wrapper/worker for pattern synonyms with unboxed type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-For bidirectional pattern synonyms that have no arguments and have
-an unboxed type, we add an extra level of indirection, since $WP would
-otherwise be a top-level declaration with an unboxed type. In this case,
-a separate worker function is generated that has an extra Void# argument,
-and the wrapper redirects to it via a compulsory unfolding (that just
-applies it on Void#). Example:
+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.
 
         pattern P = 0#
 
-        $WP :: Int#
-        $WP unfolded to ($wP Void#)
-
-        $wP :: Void# -> Int#
-        $wP _ = 0#
+        $WP :: Void# -> Int#
+        $WP _ = 0#
 
-To make things more uniform, we always store two `Id`s in `PatSyn` for
-the wrapper and the worker, with the following behaviour:
+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.
 
-  if `psWrapper` == Just (`wrapper`, `worker`), then
-
-  * `wrapper` should always be used when compiling the pattern synonym
-    in an expression context (and its type is as prescribed)
-  * `worker` is always an `Id` with a binding that needs to be exported
-    as part of the definition of the pattern synonym
-
-If a separate worker is not needed (because the pattern synonym has arguments
-or has a non-unboxed type), the two `Id`s are the same.
-
-%************************************************************************
-%*                                                                      *
-\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 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, Id)
-             -- Nothing  => uni-directional pattern synonym
-             -- Just (wrapper, worker) => bi-direcitonal
-             -- Wrapper function, of type
-             --  forall univ_tvs, ex_tvs. (prov_theta, req_theta)
-             --                       =>  arg_tys -> res_ty
-             --
-             -- See Note [Wrapper/worker for pattern synonyms with unboxed type]
-  }
-  deriving Data.Typeable.Typeable
-\end{code}
 
 %************************************************************************
 %*                                                                      *
@@ -244,20 +240,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, Id)       -- ^ Name of wrapper/worker
+         -> (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,
@@ -266,7 +262,7 @@ mkPatSyn name declared_infix
                 psArity = length orig_args,
                 psOrigResTy = orig_res_ty,
                 psMatcher = matcher,
-                psWrapper = wrapper }
+                psBuilder = builder }
 \end{code}
 
 \begin{code}
@@ -310,18 +306,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 = fmap fst . psWrapper
-
-patSynWorker :: PatSyn -> Maybe Id
-patSynWorker = fmap snd . 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 (second 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
index ce2d5a5..6844f48 100644 (file)
@@ -46,14 +46,12 @@ import MkCore
 import DynFlags
 import CostCentre
 import Id
-import Unique
 import Module
 import VarSet
 import VarEnv
 import ConLike
 import DataCon
 import TysWiredIn
-import PrelNames ( seqIdKey )
 import BasicTypes
 import Maybes
 import SrcLoc
@@ -193,12 +191,7 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)              = dsLExpr e
 dsExpr (ExprWithTySigOut e _) = dsLExpr e
-dsExpr (HsVar var)            -- See Note [Unfolding while desugaring]
-  | unfold_var = return $ unfoldingTemplate unfolding
-  | otherwise  = return (varToCoreExpr var)   -- See Note [Desugaring vars]
-  where
-    unfold_var = isCompulsoryUnfolding unfolding && not (var `hasKey` seqIdKey)
-    unfolding = idUnfolding var
+dsExpr (HsVar var)            = return (varToCoreExpr var)   -- See Note [Desugaring vars]
 dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
 dsExpr (HsLit lit)            = dsLit lit
 dsExpr (HsOverLit lit)        = dsOverLit lit
@@ -227,19 +220,6 @@ dsExpr (HsApp fun arg)
 dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
 \end{code}
 
-Note [Unfolding while desugaring]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Variables with compulsory unfolding must be substituted at desugaring
-time. This is needed to preserve the let/app invariant in cases where
-the unfolding changes whether wrapping in a case is needed.
-Suppose we have a call like this:
-    I# x
-where 'x' has an unfolding like this:
-    f void#
-In this case, 'mkCoreAppDs' needs to see 'f void#', not 'x', to be
-able to do the right thing.
-
-
 Note [Desugaring vars]
 ~~~~~~~~~~~~~~~~~~~~~~
 In one situation we can get a *coercion* variable in a HsVar, namely
index b0fe24a..bd99b90 100644 (file)
@@ -348,18 +348,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"
index 094ae3e..460dc2b 100644 (file)
@@ -189,13 +189,13 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
 ------------------------------------------------------
 buildPatSyn :: Name -> Bool
-            -> Id -> Maybe (Id, 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'
@@ -207,9 +207,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
index 4241f07..ae82d3d 100644 (file)
@@ -134,8 +134,8 @@ data IfaceDecl
 
   | IfacePatSyn { ifName          :: IfaceTopBndr,           -- Name of the pattern synonym
                   ifPatIsInfix    :: Bool,
-                  ifPatMatcher    :: IfExtName,
-                  ifPatWorker     :: Maybe IfExtName,
+                  ifPatMatcher    :: (IfExtName, Bool),
+                  ifPatBuilder    :: Maybe (IfExtName, Bool),
                   -- Everything below is redundant,
                   -- but needed to implement pprIfaceDecl
                   ifPatUnivTvs    :: [IfaceTvBndr],
@@ -765,7 +765,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
         $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
     pp_branches _ = Outputable.empty
 
-pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWorker = worker,
+pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder,
                               ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
                               ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
                               ifPatArgs = arg_tys,
@@ -776,7 +776,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWorker = worker,
                  (pprIfaceContextMaybe req_ctxt)
                  (pprIfaceType ty)
   where
-    is_bidirectional = isJust worker
+    is_bidirectional = isJust builder
     tvs = univ_tvs ++ ex_tvs
     ty = foldr IfaceFunTy pat_ty arg_tys
 
@@ -1136,8 +1136,8 @@ freeNamesIfDecl d@IfaceAxiom{} =
   freeNamesIfTc (ifTyCon d) &&&
   fnList freeNamesIfAxBranch (ifAxBranches d)
 freeNamesIfDecl d@IfacePatSyn{} =
-  unitNameSet (ifPatMatcher d) &&&
-  maybe emptyNameSet unitNameSet (ifPatWorker d) &&&
+  unitNameSet (fst (ifPatMatcher d)) &&&
+  maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&
   freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
   freeNamesIfTvBndrs (ifPatExTvs d) &&&
   freeNamesIfContext (ifPatProvCtxt d) &&&
index a242875..bfa0fda 100644 (file)
@@ -1542,8 +1542,8 @@ dataConToIfaceDecl dataCon
 patSynToIfaceDecl :: PatSyn -> IfaceDecl
 patSynToIfaceDecl ps
   = IfacePatSyn { ifName          = getOccName . getName $ ps
-                , ifPatMatcher    = matcher
-                , ifPatWorker     = worker
+                , ifPatMatcher    = to_if_pr (patSynMatcher ps)
+                , ifPatBuilder    = fmap to_if_pr (patSynBuilder ps)
                 , ifPatIsInfix    = patSynIsInfix ps
                 , ifPatUnivTvs    = toIfaceTvBndrs univ_tvs'
                 , ifPatExTvs      = toIfaceTvBndrs ex_tvs'
@@ -1556,10 +1556,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)
-    worker = fmap idName (patSynWorker ps)
-
+    to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
 
 --------------------------
 coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
index 4950f5e..adc6725 100644 (file)
@@ -14,8 +14,7 @@ module TcIface (
         tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
         tcIfaceVectInfo, tcIfaceAnnotations,
         tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)
-        tcIfaceGlobal,
-        mkPatSynWrapperId, mkPatSynWorkerId -- Have to be here to avoid circular import
+        tcIfaceGlobal
  ) where
 
 #include "HsVersions.h"
@@ -28,7 +27,6 @@ import BuildTyCl
 import TcRnMonad
 import TcType
 import Type
-import TcMType
 import Coercion hiding (substTy)
 import TypeRep
 import HscTypes
@@ -77,7 +75,6 @@ import qualified Data.Map as Map
 #if __GLASGOW_HASKELL__ < 709
 import Data.Traversable ( traverse )
 #endif
-import Data.Traversable ( for )
 \end{code}
 
 This module takes
@@ -597,8 +594,8 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
        ; return (ACoAxiom axiom) }
 
 tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
-                              , ifPatMatcher = matcher_name
-                              , ifPatWorker = worker_name
+                              , ifPatMatcher = if_matcher
+                              , ifPatBuilder = if_builder
                               , ifPatIsInfix = is_infix
                               , ifPatUnivTvs = univ_tvs
                               , ifPatExTvs = ex_tvs
@@ -608,8 +605,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
-       ; worker <- traverse (tcExt "Worker") worker_name
+       ; 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) $
@@ -617,21 +614,15 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                 ; req_theta  <- tcIfaceCtxt req_ctxt
                 ; pat_ty     <- tcIfaceType pat_ty
                 ; arg_tys    <- mapM tcIfaceType args
-                ; wrapper    <- for worker $ \worker_id -> do
-                    { wrapper_id <- mkPatSynWrapperId (noLoc name)
-                                      (univ_tvs ++ ex_tvs)
-                                      (req_theta ++ prov_theta)
-                                      arg_tys pat_ty
-                                      worker_id
-                    ; return (wrapper_id, worker_id)
-                    }
-                ; 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 :: [IfaceAxBranch] -> IfL [CoAxBranch]
 tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
@@ -1541,41 +1532,3 @@ bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
          bindIfaceTyVars_AT bs $ \bs' ->
          thing_inside (b':bs') }
 \end{code}
-
-%************************************************************************
-%*                                                                      *
-                PatSyn wrapper/worker helpers
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
--- These are here (and not in TcPatSyn) just to avoid circular imports.
-
-mkPatSynWrapperId :: Located Name
-                  -> [TyVar] -> ThetaType -> [Type] -> Type
-                  -> Id
-                  -> TcRnIf gbl lcl Id
-mkPatSynWrapperId name qtvs theta arg_tys pat_ty worker_id
-  | need_dummy_arg = do
-      { wrapper_id <- mkPatSynWorkerId name mkDataConWrapperOcc qtvs theta arg_tys pat_ty
-      ; let unfolding = mkCoreApp (Var worker_id) (Var voidPrimId)
-            wrapper_id' = setIdUnfolding wrapper_id $ mkCompulsoryUnfolding unfolding
-      ; return wrapper_id' }
-  | otherwise = return worker_id -- No indirection needed
-  where
-    need_dummy_arg = null arg_tys && isUnLiftedType pat_ty
-
-mkPatSynWorkerId :: Located Name -> (OccName -> OccName)
-                 -> [TyVar] -> ThetaType -> [Type] -> Type
-                 -> TcRnIf gbl loc Id
-mkPatSynWorkerId (L loc name) mk_occ_name qtvs theta arg_tys pat_ty
-  = do { worker_name <- newImplicitBinder name mk_occ_name
-       ; (subst, worker_tvs) <- tcInstSigTyVarsLoc loc qtvs
-       ; let worker_theta = substTheta subst theta
-             pat_ty' = substTy subst pat_ty
-             arg_tys' = map (substTy subst) arg_tys
-             worker_tau = mkFunTys arg_tys' pat_ty'
-             -- TODO: just substitute worker_sigma...
-             worker_sigma = mkSigmaTy worker_tvs worker_theta worker_tau
-       ; return $ mkVanillaGlobal worker_name worker_sigma }
-\end{code}
index ec5f9d7..b44762e 100644 (file)
@@ -16,8 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
 
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
-import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynWorker )
-
+import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynBuilderBind )
 import DynFlags
 import HsSyn
 import HscTypes( isHsBootOrSig )
@@ -29,11 +28,9 @@ import TcEvidence
 import TcHsType
 import TcPat
 import TcMType
-import PatSyn
 import ConLike
 import FamInstEnv( normaliseType )
 import FamInst( tcGetFamInstEnvs )
-import Type( tidyOpenType, splitFunTys )
 import TyCon
 import TcType
 import TysPrim
@@ -321,7 +318,7 @@ tcValBinds top_lvl binds sigs thing_inside
             { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
                    { thing <- thing_inside
                      -- See Note [Pattern synonym wrappers don't yield dependencies]
-                   ; patsyn_workers <- mapM tcPatSynWorker patsyns
+                   ; patsyn_workers <- mapM tcPatSynBuilderBind patsyns
                    ; let extra_binds = [ (NonRecursive, worker) | worker <- patsyn_workers ]
                    ; return (extra_binds, thing) }
              ; return (binds' ++ extra_binds', thing) }}
@@ -423,11 +420,12 @@ tc_single :: forall thing.
 tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
   = do { (pat_syn, aux_binds) <- tc_pat_syn_decl
        ; let tything = AConLike (PatSynCon pat_syn)
-             implicit_ids = (patSynMatcher pat_syn) :
-                            (maybeToList (patSynWorker pat_syn))
+-- SLPJ: Why is this necessary?
+--             implicit_ids = patSynMatcher pat_syn :
+--                            maybeToList (patSynWorker pat_syn)
 
        ; thing <- tcExtendGlobalEnv [tything] $
-                  tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
+--                  tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
                   thing_inside
        ; return (aux_binds, thing)
        }
index a242ed7..05a53d6 100644 (file)
@@ -31,6 +31,7 @@ import TcEnv
 import TcArrows
 import TcMatches
 import TcHsType
+import TcPatSyn( tcPatSynBuilderOcc )
 import TcPat
 import TcMType
 import TcType
@@ -38,7 +39,6 @@ import DsMonad hiding (Splice)
 import Id
 import ConLike
 import DataCon
-import PatSyn
 import RdrName
 import Name
 import TyCon
@@ -1028,6 +1028,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 }
 
@@ -1041,57 +1042,75 @@ tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
 -- Look up an occurrence of an Id, and instantiate it (deeply)
 
 tcInferIdWithOrig orig id_name
+  | id_name `hasKey` tagToEnumKey
+  = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
+        -- tcApp catches the case (tagToEnum# arg)
+
   | id_name `hasKey` assertIdKey
   = do { dflags <- getDynFlags
        ; if gopt Opt_IgnoreAsserts dflags
-         then normal_case
-         else assert_case dflags }
+         then tc_infer_id orig id_name
+         else tc_infer_assert dflags orig }
+
   | otherwise
-  = normal_case
-  where
-    normal_case
-      = do { id <- lookup_id id_name
-           ; (id_expr, id_rho) <- instantiateOuter orig id
-           ; (wrap, rho) <- deeplyInstantiate orig id_rho
-           ; return (mkHsWrap wrap id_expr, rho) }
-
-    assert_case dflags  -- See Note [Adding the implicit parameter to 'assert']
-      = do { sloc <- getSrcSpanM
-           ; assert_error_id <- lookup_id assertErrorName
-           ; (id_expr, id_rho) <- instantiateOuter orig assert_error_id
-           ; case tcSplitFunTy_maybe id_rho of {
-               Nothing -> pprPanic "assert type" (ppr id_rho) ;
-               Just (arg_ty, res_ty) -> ASSERT( arg_ty `tcEqType` addrPrimTy )
-        do { return (HsApp (L sloc id_expr)
-                           (L sloc (srcSpanPrimLit dflags sloc)), res_ty) } } }
-
-lookup_id :: Name -> TcM TcId
-lookup_id id_name
+  = tc_infer_id orig id_name
+
+tc_infer_assert :: DynFlags -> CtOrigin -> TcM (HsExpr TcId, TcRhoType)
+-- Deal with an occurrence of 'assert'
+-- See Note [Adding the implicit parameter to 'assert']
+tc_infer_assert dflags orig
+  = do { sloc <- getSrcSpanM
+       ; assert_error_id <- tcLookupId assertErrorName
+       ; (wrap, id_rho) <- deeplyInstantiate orig (idType assert_error_id)
+       ; let (arg_ty, res_ty) = case tcSplitFunTy_maybe id_rho of
+                                   Nothing      -> pprPanic "assert type" (ppr id_rho)
+                                   Just arg_res -> arg_res
+       ; ASSERT( arg_ty `tcEqType` addrPrimTy )
+         return (HsApp (L sloc (mkHsWrap wrap (HsVar assert_error_id)))
+                       (L sloc (srcSpanPrimLit dflags sloc))
+                , res_ty) }
+
+tc_infer_id :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
+-- Return type is deeply instantiated
+tc_infer_id orig id_name
  = do { thing <- tcLookup id_name
       ; case thing of
              ATcId { tct_id = id }
                -> do { check_naughty id        -- Note [Local record selectors]
                      ; checkThLocalId id
-                     ; return id }
+                     ; inst_normal_id id }
 
              AGlobal (AnId id)
-               -> do { check_naughty id; return id }
+               -> do { check_naughty id
+                     ; inst_normal_id 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
-
-             other -> failWithTc (bad_lookup other) }
+                 RealDataCon con -> inst_data_con con
+                 PatSynCon ps    -> tcPatSynBuilderOcc orig ps
 
+             _ -> failWithTc $
+                  ppr thing <+> ptext (sLit "used where a value identifer was expected") }
   where
-    bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected")
-
-    bad_patsyn name = ppr name <+>  ptext (sLit "used in an expression, but it's a non-bidirectional pattern synonym")
+    inst_normal_id id
+      = do { (wrap, rho) <- deeplyInstantiate orig (idType id)
+           ; return (mkHsWrap wrap (HsVar id), rho) }
+
+    inst_data_con con
+       -- For data constructors,
+       --   * Must perform the stupid-theta check
+       --   * No need to deeply instantiate because type has all foralls at top
+       = do { let wrap_id           = dataConWrapId con
+                  (tvs, theta, rho) = tcSplitSigmaTy (idType wrap_id)
+            ; (subst, tvs') <- tcInstTyVars tvs
+            ; let tys'   = mkTyVarTys tvs'
+                  theta' = substTheta subst theta
+                  rho'   = substTy subst rho
+            ; wrap <- instCall orig tys' theta'
+            ; addDataConStupidTheta con tys'
+            ; return (mkHsWrap wrap (HsVar wrap_id), rho') }
 
     check_naughty id
       | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
@@ -1100,29 +1119,6 @@ lookup_id id_name
 srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId
 srcSpanPrimLit dflags span
     = HsLit (HsStringPrim (unsafeMkByteString (showSDocOneLine dflags (ppr span))))
-
-------------------------
-instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType)
--- Do just the first level of instantiation of an Id
---   a) Deal with method sharing
---   b) Deal with stupid checks
--- Only look at the *outer level* of quantification
--- See Note [Multiple instantiation]
-
-instantiateOuter orig id
-  | null tvs && null theta
-  = return (HsVar id, tau)
-
-  | otherwise
-  = do { (subst, tvs') <- tcInstTyVars tvs
-       ; let tys'   = mkTyVarTys tvs'
-             theta' = substTheta subst theta
-       ; doStupidChecks id tys'
-       ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys' $$ ppr theta'))
-       ; wrap <- instCall orig tys' theta'
-       ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) }
-  where
-    (tvs, theta, tau) = tcSplitSigmaTy (idType id)
 \end{code}
 
 Note [Adding the implicit parameter to 'assert']
@@ -1133,58 +1129,6 @@ e1 e2).  This isn't really the Right Thing because there's no way to
 output.  We'll have fix this in due course, when we care more about
 being able to reconstruct the exact original program.
 
-Note [Multiple instantiation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
-For example, consider
-        f :: forall a. Eq a => forall b. Ord b => a -> b
-At a call to f, at say [Int, Bool], it's tempting to translate the call to
-
-        f_m1
-  where
-        f_m1 :: forall b. Ord b => Int -> b
-        f_m1 = f Int dEqInt
-
-        f_m2 :: Int -> Bool
-        f_m2 = f_m1 Bool dOrdBool
-
-But notice that f_m2 has f_m1 as its meth_id.  Now the danger is that if we do
-a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
-        f_m1 = f_mx
-But it's entirely possible that f_m2 will continue to float out, because it
-mentions no type variables.  Result, f_m1 isn't in scope.
-
-Here's a concrete example that does this (test tc200):
-
-    class C a where
-      f :: Eq b => b -> a -> Int
-      baz :: Eq a => Int -> a -> Int
-
-    instance C Int where
-      baz = f
-
-Current solution: only do the "method sharing" thing for the first type/dict
-application, not for the iterated ones.  A horribly subtle point.
-
-\begin{code}
-doStupidChecks :: TcId
-               -> [TcType]
-               -> TcM ()
--- Check two tiresome and ad-hoc cases
--- (a) the "stupid theta" for a data con; add the constraints
---     from the "stupid theta" of a data constructor (sigh)
-
-doStupidChecks fun_id tys
-  | Just con <- isDataConId_maybe fun_id   -- (a)
-  = addDataConStupidTheta con tys
-
-  | fun_id `hasKey` tagToEnumKey           -- (b)
-  = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
-
-  | otherwise
-  = return () -- The common case
-\end{code}
-
 Note [tagToEnum#]
 ~~~~~~~~~~~~~~~~~
 Nasty check to ensure that tagToEnum# is applied to a type that is an
index a2731ca..0796472 100644 (file)
@@ -7,14 +7,15 @@
 \begin{code}
 {-# LANGUAGE CPP #-}
 
-module TcPatSyn (tcInferPatSynDecl, tcCheckPatSynDecl, mkPatSynWrapperId, tcPatSynWorker) where
+module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
+                , tcPatSynBuilderBind, tcPatSynBuilderOcc
+  ) where
 
 import HsSyn
 import TcPat
 import TcRnMonad
 import TcEnv
 import TcMType
-import TcIface
 import TysPrim
 import Name
 import SrcLoc
@@ -47,6 +48,12 @@ import Control.Monad (forM)
 #include "HsVersions.h"
 \end{code}
 
+%************************************************************************
+%*                                                                      *
+                    Type checking a pattern synonym
+%*                                                                      *
+%************************************************************************
+
 \begin{code}
 tcInferPatSynDecl :: PatSynBind Name Name
                   -> TcM (PatSyn, LHsBinds Id)
@@ -168,6 +175,8 @@ wrongNumberOfParmsErr ty_arity
   = ptext (sLit "Number of pattern synonym arguments doesn't match type; expected")
     <+> ppr ty_arity
 
+-------------------------
+-- Shared by both tcInferPatSyn and tcCheckPatSyn
 tc_patsyn_finish :: Located Name
                  -> HsPatSynDir Name
                  -> Bool
@@ -188,16 +197,15 @@ tc_patsyn_finish lname dir is_infix lpat'
                                          wrapped_args
                                          pat_ty
 
-       ; wrapper_ids <- if isBidirectional dir
-                        then fmap Just $ mkPatSynWrapperIds lname qtvs theta arg_tys pat_ty
-                        else return Nothing
+       ; builder_id <- mkPatSynBuilderId dir lname qtvs theta arg_tys pat_ty
 
        ; let patSyn = mkPatSyn (unLoc lname) is_infix
                         (univ_tvs, req_theta)
                         (ex_tvs, prov_theta)
                         arg_tys
                         pat_ty
-                        matcher_id wrapper_ids
+                        matcher_id builder_id
+
        ; return (patSyn, matcher_bind) }
   where
     qtvs = univ_tvs ++ ex_tvs
@@ -206,6 +214,12 @@ tc_patsyn_finish lname dir is_infix lpat'
 \end{code}
 
 
+%************************************************************************
+%*                                                                      *
+         Constructing the "matcher" Id and its binding
+%*                                                                      *
+%************************************************************************
+
 \begin{code}
 tcPatSynMatcher :: Located Name
                 -> LPat Id
@@ -213,45 +227,43 @@ tcPatSynMatcher :: Located Name
                 -> ([TcTyVar], [TcType], ThetaType, TcEvBinds, [EvVar])
                 -> [(Var, HsWrapper)]
                 -> TcType
-                -> TcM (Id, LHsBinds Id)
--- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
+                -> TcM ((Id, Bool), LHsBinds Id)
+-- See Note [Matchers and builders for pattern synonyms] in PatSyn
 tcPatSynMatcher (L loc name) lpat
                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
                 (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts)
                 wrapped_args pat_ty
-  = do { res_tv <- do
-              { uniq <- newUnique
-              ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
-              ; return $ mkTcTyVar tv_name openTypeKind (SkolemTv False) }
-       ; let res_ty = mkTyVarTy res_tv
-
-       ; let (cont_arg_tys, cont_args)
-               | null wrapped_args = ([voidPrimTy], [nlHsVar voidPrimId])
-               | otherwise = unzip [ (varType arg, mkLHsWrap wrap $ nlHsVar arg)
-                                   | (arg, wrap) <- wrapped_args
-                                   ]
+  = do { uniq <- newUnique
+       ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
+             res_tv  = mkTcTyVar tv_name openTypeKind (SkolemTv False)
+             is_unlifted = null wrapped_args && null prov_dicts
+             res_ty = mkTyVarTy res_tv
+             (cont_arg_tys, cont_args)
+               | is_unlifted = ([voidPrimTy], [nlHsVar voidPrimId])
+               | otherwise   = unzip [ (varType arg, mkLHsWrap wrap $ nlHsVar arg)
+                                     | (arg, wrap) <- wrapped_args
+                                     ]
              cont_ty = mkSigmaTy ex_tvs prov_theta $
                        mkFunTys cont_arg_tys res_ty
 
-       ; let fail_ty = mkFunTy voidPrimTy res_ty
+             fail_ty = mkFunTy voidPrimTy res_ty
 
        ; matcher_name <- newImplicitBinder name mkMatcherOcc
-       ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
+       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty
+       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty
+       ; fail         <- newSysLocalId (fsLit "fail")  fail_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_id    = mkVanillaGlobal matcher_name matcher_sigma
 
-       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
-       ; let matcher_lid = L loc matcher_id
+             cont_dicts = map nlHsVar prov_dicts
+             cont' = mkLHsWrap (mkWpLet prov_ev_binds) $
+                     nlHsTyApps cont ex_tys (cont_dicts ++ cont_args)
 
-       ; scrutinee <- mkId "scrut" pat_ty
-       ; cont <- mkId "cont" cont_ty
-       ; let cont_dicts = map nlHsVar prov_dicts
-       ; let cont' = nlHsTyApps cont ex_tys $ cont_dicts ++ cont_args
-       ; cont' <- return $ mkLHsWrap (mkWpLet prov_ev_binds) cont'
-       ; fail <- mkId "fail" fail_ty
-       ; let fail' = nlHsApps fail [nlHsVar voidPrimId]
+             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']
@@ -272,7 +284,6 @@ tcPatSynMatcher (L loc name) lpat
                        , 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 = []
@@ -280,7 +291,7 @@ tcPatSynMatcher (L loc name) lpat
                     , 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
@@ -288,60 +299,63 @@ tcPatSynMatcher (L loc name) lpat
                            , 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
-
-isBidirectional :: HsPatSynDir a -> Bool
-isBidirectional Unidirectional = False
-isBidirectional ImplicitBidirectional = True
-isBidirectional ExplicitBidirectional{} = True
-
-tcPatSynWorker :: PatSynBind Name Name
-                -> TcM (LHsBinds Id)
--- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
-tcPatSynWorker PSB{ psb_id = lname, psb_def = lpat, psb_dir = dir, psb_args = details }
-  = case dir of
-    Unidirectional -> return emptyBag
-    ImplicitBidirectional ->
-        do { lexpr <- case tcPatToExpr (mkNameSet args) lpat of
-                  Nothing -> cannotInvertPatSynErr lpat
-                  Just lexpr -> return lexpr
-           ; let wrapper_args = map (noLoc . VarPat) args
-                 wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
-           ; mkPatSynWorker lname $ mkMatchGroupName Generated [wrapper_match] }
-    ExplicitBidirectional mg -> mkPatSynWorker lname mg
-  where
-    args = map unLoc $ case details of
-        PrefixPatSyn args -> args
-        InfixPatSyn arg1 arg2 -> [arg1, arg2]
-
-mkPatSynWrapperIds :: Located Name
-                   -> [TyVar] -> ThetaType -> [Type] -> Type
-                   -> TcM (Id, Id)
-mkPatSynWrapperIds lname qtvs theta arg_tys pat_ty
-  = do { worker_id <- mkPatSynWorkerId lname mkDataConWorkerOcc qtvs theta worker_arg_tys pat_ty
-       ; wrapper_id <- mkPatSynWrapperId lname qtvs theta arg_tys pat_ty worker_id
-       ; return (wrapper_id, worker_id) }
+       ; return ((matcher_id, is_unlifted), matcher_bind) }
+
+
+isUnidirectional :: HsPatSynDir a -> Bool
+isUnidirectional Unidirectional          = True
+isUnidirectional ImplicitBidirectional   = False
+isUnidirectional ExplicitBidirectional{} = 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
-    worker_arg_tys | need_dummy_arg = [voidPrimTy]
-                   | otherwise = arg_tys
-    need_dummy_arg = null arg_tys && isUnLiftedType pat_ty
-
-mkPatSynWorker :: Located Name
-                -> MatchGroup Name (LHsExpr Name)
-                -> TcM (LHsBinds Id)
-mkPatSynWorker (L loc name) mg
+    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
+                    -> 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 }
+  | 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 { patsyn <- tcLookupPatSyn name
-       ; let worker_id = fromMaybe (panic "mkPatSynWrapper") $
-                         patSynWorker patsyn
-             need_dummy_arg = null (patSynArgs patsyn) && isUnLiftedType (patSynType patsyn)
+       ; let (worker_id, need_dummy_arg) = fromMaybe (panic "mkPatSynWrapper") $
+                                           patSynBuilder patsyn
 
        ; let match_dummy = mkMatch [nlWildPatName] (noLoc $ HsLam mg) emptyLocalBinds
              mg' | need_dummy_arg = mkMatchGroupName Generated [match_dummy]
-                 | otherwise = mg
+                 | otherwise      = mg
 
        ; let (worker_tvs, worker_theta, worker_tau) = tcSplitSigmaTy (idType worker_id)
              bind = FunBind { fun_id = L loc (idName worker_id)
@@ -362,9 +376,49 @@ mkPatSynWorker (L loc name) mg
        ; traceTc "tcPatSynDecl worker" $ ppr worker_binds
        ; return worker_binds }
   where
-
+    Just mg = mb_match_group
+    mb_match_group = case dir of
+                        Unidirectional           -> Nothing
+                        ExplicitBidirectional mg -> Just mg
+                        ImplicitBidirectional    -> fmap mk_mg (tcPatToExpr args lpat)
+
+    mk_mg :: LHsExpr Name -> MatchGroup Name (LHsExpr Name)
+    mk_mg body = mkMatchGroupName 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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -428,15 +482,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)
@@ -467,12 +522,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.
 --
index d22d46f..697f377 100644 (file)
@@ -15,6 +15,6 @@ tcCheckPatSynDecl :: PatSynBind Name Name
                   -> TcPatSynInfo
                   -> TcM (PatSyn, LHsBinds Id)
 
-tcPatSynWorker :: PatSynBind Name Name
-               -> TcM (LHsBinds Id)
+tcPatSynBuilderBind :: PatSynBind Name Name
+                    -> TcM (LHsBinds Id)
 \end{code}
index b73b525..33fee4f 100644 (file)
@@ -431,6 +431,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