Add psEqSpec field to PatSyn

6 files changed, 51 insertions, 19 deletions

diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs
index 081968aabd..b2ff5abe6f 100644
--- a/compiler/basicTypes/PatSyn.hs
+++ b/compiler/basicTypes/PatSyn.hs
@@ -15,7 +15,7 @@ module PatSyn (
         patSynName, patSynArity, patSynIsInfix,
         patSynArgs, patSynTyDetails, patSynType,
         patSynMatcher, patSynBuilder,
-        patSynExTyVars, patSynSig,
+        patSynExTyVars, patSynSig, patSynEqSpec,
         patSynInstArgTys, patSynInstResTy,
         tidyPatSynIds
     ) where
@@ -50,17 +50,19 @@ import Data.Function
 data PatSyn
   = MkPatSyn {
         psName        :: Name,
-        psUnique      :: Unique,      -- Cached from Name
+        psUnique      :: Unique,          -- Cached from Name
 
         psArgs        :: [Type],
-        psArity       :: Arity,       -- == length psArgs
-        psInfix       :: Bool,        -- True <=> declared infix
+        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
+        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
+        psEqSpec      :: [(TyVar, Type)], -- Equalities derived from the result type,
+                                         -- _as written by the programmer_
 
         -- See Note [Matchers and builders for pattern synonyms]
         psMatcher     :: (Id, Bool),
@@ -241,6 +243,7 @@ mkPatSyn :: Name
                                  --   and required dicts
          -> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
                                  --   and provided dicts
+         -> [(TyVar, Type)]      -- ^ Equalities from hand-written type signature
          -> [Type]               -- ^ Original arguments
          -> Type                 -- ^ Original result type
          -> (Id, Bool)           -- ^ Name of matcher
@@ -249,12 +252,14 @@ mkPatSyn :: Name
 mkPatSyn name declared_infix
          (univ_tvs, req_theta)
          (ex_tvs, prov_theta)
+         eq_spec
          orig_args
          orig_res_ty
          matcher builder
     = MkPatSyn {psName = name, psUnique = getUnique name,
                 psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
                 psProvTheta = prov_theta, psReqTheta = req_theta,
+                psEqSpec = eq_spec,
                 psInfix = declared_infix,
                 psArgs = orig_args,
                 psArity = length orig_args,
@@ -302,6 +307,11 @@ patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
                     , psArgs = arg_tys, psOrigResTy = res_ty })
   = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
 
+-- | Equalities derived from the type signature of the pattern synonym,
+-- as written by the programmer
+patSynEqSpec :: PatSyn -> [(TyVar,Type)]
+patSynEqSpec = psEqSpec
+
 patSynMatcher :: PatSyn -> (Id,Bool)
 patSynMatcher = psMatcher
 
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 33be51ff7f..e72362d0a4 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -188,11 +188,13 @@ buildPatSyn :: Name -> Bool
             -> (Id,Bool) -> Maybe (Id, Bool)
             -> ([TyVar], ThetaType) -- ^ Univ and req
             -> ([TyVar], ThetaType) -- ^ Ex and prov
+            -> [(TyVar,Type)]       -- ^ Equality spec
             -> [Type]               -- ^ Argument types
             -> Type                 -- ^ Result type
             -> PatSyn
 buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
-            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty
+            (univ_tvs, req_theta) (ex_tvs, prov_theta)
+            eq_spec arg_tys pat_ty
   = ASSERT((and [ univ_tvs == univ_tvs'
                 , ex_tvs == ex_tvs'
                 , pat_ty `eqType` pat_ty'
@@ -202,7 +204,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
                 ]))
     mkPatSyn src_name declared_infix
              (univ_tvs, req_theta) (ex_tvs, prov_theta)
-             arg_tys pat_ty
+             eq_spec arg_tys pat_ty
              matcher builder
   where
     ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 7cd875fd2c..609609d4d7 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -136,6 +136,7 @@ data IfaceDecl
                   ifPatIsInfix    :: Bool,
                   ifPatMatcher    :: (IfExtName, Bool),
                   ifPatBuilder    :: Maybe (IfExtName, Bool),
+                  ifPatEqSpec     :: IfaceEqSpec,
                   -- Everything below is redundant,
                   -- but needed to implement pprIfaceDecl
                   ifPatUnivTvs    :: [IfaceTvBndr],
@@ -695,6 +696,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
 pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder,
                               ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
                               ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
+                              ifPatEqSpec = eq_spec,
                               ifPatArgs = arg_tys,
                               ifPatTy = pat_ty} )
   = pprPatSynSig name is_bidirectional
@@ -1072,6 +1074,7 @@ freeNamesIfDecl d@IfacePatSyn{} =
   freeNamesIfContext (ifPatProvCtxt d) &&&
   freeNamesIfContext (ifPatReqCtxt d) &&&
   fnList freeNamesIfType (ifPatArgs d) &&&
+  fnList freeNamesIfType (map snd (ifPatEqSpec d)) &&&
   freeNamesIfType (ifPatTy d)
 
 freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
@@ -1358,7 +1361,7 @@ instance Binary IfaceDecl where
         put_ bh a3
         put_ bh a4
 
-    put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
+    put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
         putByte bh 7
         put_ bh (occNameFS name)
         put_ bh a2
@@ -1370,6 +1373,7 @@ instance Binary IfaceDecl where
         put_ bh a8
         put_ bh a9
         put_ bh a10
+        put_ bh a11
 
     get bh = do
         h <- getByte bh
@@ -1433,8 +1437,9 @@ instance Binary IfaceDecl where
                     a8 <- get bh
                     a9 <- get bh
                     a10 <- get bh
+                    a11 <- get bh
                     occ <- return $! mkDataOccFS a1
-                    return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10)
+                    return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
             _ -> panic (unwords ["Unknown IfaceDecl tag:", show h])
 
 instance Binary IfaceFamTyConFlav where
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 7226cb01f8..b4455fd00b 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1537,6 +1537,7 @@ patSynToIfaceDecl ps
                 , ifPatExTvs      = toIfaceTvBndrs ex_tvs'
                 , ifPatProvCtxt   = tidyToIfaceContext env2 prov_theta
                 , ifPatReqCtxt    = tidyToIfaceContext env2 req_theta
+                , ifPatEqSpec     = tidyEqSpec env2 eq_spec
                 , ifPatArgs       = map (tidyToIfaceType env2) args
                 , ifPatTy         = tidyToIfaceType env2 rhs_ty
                 }
@@ -1544,6 +1545,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
+    eq_spec = patSynEqSpec ps
     to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
 
 --------------------------
@@ -1679,7 +1681,7 @@ tyConToIfaceDecl env tycon
                     ifConInfix   = dataConIsInfix data_con,
                     ifConWrapper = isJust (dataConWrapId_maybe data_con),
                     ifConExTvs   = toIfaceTvBndrs ex_tvs',
-                    ifConEqSpec  = map to_eq_spec eq_spec,
+                    ifConEqSpec  = tidyEqSpec con_env2 eq_spec,
                     ifConCtxt    = tidyToIfaceContext con_env2 theta,
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
                     ifConFields  = map getOccName
@@ -1699,7 +1701,6 @@ tyConToIfaceDecl env tycon
                      -- A bit grimy, perhaps, but it's simple!
 
           (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
-          to_eq_spec (tv,ty)  = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
 
 toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
 toIfaceBang _    HsNoBang            = IfNoBang
@@ -1778,6 +1779,11 @@ tidyTyVar :: TidyEnv -> TyVar -> TyVar
 tidyTyVar (_, subst) tv = lookupVarEnv subst tv `orElse` tv
    -- TcType.tidyTyVarOcc messes around with FlatSkols
 
+tidyEqSpec :: TidyEnv -> [(TyVar, Type)] -> IfaceEqSpec
+tidyEqSpec env = map tidy_eq
+  where
+    tidy_eq (tv, ty) = (toIfaceTyVar (tidyTyVar env tv), tidyToIfaceType env ty)
+
 getFS :: NamedThing a => a -> FastString
 getFS x = occNameFS (getOccName x)
 
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 0d504e2063..24f5b9e05b 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -448,6 +448,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                               , ifPatExTvs = ex_tvs
                               , ifPatProvCtxt = prov_ctxt
                               , ifPatReqCtxt = req_ctxt
+                              , ifPatEqSpec = eq_spec
                               , ifPatArgs = args
                               , ifPatTy = pat_ty })
   = do { name <- lookupIfaceTop occ_name
@@ -459,11 +460,12 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
        { patsyn <- forkM (mk_doc name) $
              do { prov_theta <- tcIfaceCtxt prov_ctxt
                 ; req_theta  <- tcIfaceCtxt req_ctxt
-                ; pat_ty     <- tcIfaceType pat_ty
+                ; eq_spec    <- tcIfaceEqSpec eq_spec
                 ; arg_tys    <- mapM tcIfaceType args
+                ; pat_ty     <- tcIfaceType pat_ty
                 ; return $ buildPatSyn name is_infix matcher builder
                                        (univ_tvs, req_theta) (ex_tvs, prov_theta)
-                                       arg_tys pat_ty }
+                                       eq_spec arg_tys pat_ty }
        ; return $ AConLike . PatSynCon $ patsyn }}}
   where
      mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 92877575ea..e444ee4652 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -114,7 +114,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
          ppr (ex_tvs, prov_theta) $$
          ppr (univ_tvs, req_theta) $$
          ppr arg_tys $$
-         ppr tau
+         ppr pat_ty
        ; tcCheckPatSynPat lpat
 
        ; req_dicts <- newEvVars req_theta
@@ -192,7 +192,13 @@ tc_patsyn_finish lname dir is_infix lpat'
                  (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
                  wrapped_args
                  pat_ty
-  = do { (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
+  = do { traceTc "tc_patsyn_finish" $
+         ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
+         ppr (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts) $$
+         ppr wrapped_args $$
+         ppr pat_ty
+
+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
                                          (univ_tvs, req_theta, req_ev_binds, req_dicts)
                                          (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts)
                                          wrapped_args
@@ -203,6 +209,7 @@ tc_patsyn_finish lname dir is_infix lpat'
        ; let patSyn = mkPatSyn (unLoc lname) is_infix
                         (univ_tvs, req_theta)
                         (ex_tvs, prov_theta)
+                        []
                         arg_tys
                         pat_ty
                         matcher_id builder_id