Refactor type family instance abstract syntax declarations
authorRyan Scott <ryan.gl.scott@gmail.com>
Tue, 29 Aug 2017 16:38:54 +0000 (12:38 -0400)
committerBen Gamari <ben@smart-cactus.org>
Tue, 29 Aug 2017 16:39:18 +0000 (12:39 -0400)
This implements @simonpj's suggested refactoring of the abstract syntax
for type/data family instances (from
https://ghc.haskell.org/trac/ghc/ticket/14131#comment:9). This combines
the previously separate `TyFamEqn` and `DataFamInstDecl` types into a
single `FamEqn` datatype. This also factors the `HsImplicitBndrs` out of
`HsTyPats` in favor of putting them just outside of `FamEqn` (as opposed
to before, where all of the implicit binders were embedded inside of
`TyFamEqn`/`DataFamInstDecl`). Finally, along the way I noticed that
`dfid_fvs` and `tfid_fvs` were completely unused, so I removed them.

Aside from some changes in parser test output, there is no change in
behavior.

Requires a Haddock submodule commit from my fork (at
https://github.com/RyanGlScott/haddock/commit/815d2deb9c0222c916becccf84
64b740c26255fd)

Test Plan: ./validate

Reviewers: simonpj, austin, goldfire, bgamari, alanz

Reviewed By: bgamari

Subscribers: mpickering, goldfire, rwbarton, thomie, simonpj

GHC Trac Issues: #14131

Differential Revision: https://phabricator.haskell.org/D3881

14 files changed:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsDecls.hs
compiler/hsSyn/HsUtils.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnNames.hs
compiler/rename/RnSource.hs
compiler/typecheck/TcEnv.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcTyClsDecls.hs
testsuite/tests/parser/should_compile/DumpParsedAst.stderr
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
utils/haddock

index b78e366..5e630e5 100644 (file)
@@ -357,7 +357,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,
              ClosedTypeFamily Nothing ->
                  notHandled "abstract closed type family" (ppr decl)
              ClosedTypeFamily (Just eqns) ->
-               do { eqns1  <- mapM repTyFamEqn eqns
+               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
                   ; eqns2  <- coreList tySynEqnQTyConName eqns1
                   ; result <- repFamilyResultSig resultSig
                   ; inj    <- repInjectivityAnn injectivity
@@ -412,9 +412,9 @@ repAssocTyFamDefaults = mapM rep_deflt
   where
      -- very like repTyFamEqn, but different in the details
     rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
-    rep_deflt (L _ (TyFamEqn { tfe_tycon = tc
-                             , tfe_pats  = bndrs
-                             , tfe_rhs   = rhs }))
+    rep_deflt (L _ (FamEqn { feqn_tycon = tc
+                           , feqn_pats  = bndrs
+                           , feqn_rhs   = rhs }))
       = addTyClTyVarBinds bndrs $ \ _ ->
         do { tc1  <- lookupLOcc tc
            ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
@@ -495,10 +495,10 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
        ; eqn1 <- repTyFamEqn eqn
        ; repTySynInst tc eqn1 }
 
-repTyFamEqn :: LTyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
-repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
-                                             , hsib_vars = var_names }
-                           , tfe_rhs = rhs }))
+repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
+repTyFamEqn (HsIB { hsib_vars = var_names
+                  , hsib_body = FamEqn { feqn_pats = tys
+                                       , feqn_rhs  = rhs }})
   = do { let hs_tvs = HsQTvs { hsq_implicit = var_names
                              , hsq_explicit = []
                              , hsq_dependent = emptyNameSet }   -- Yuk
@@ -509,9 +509,11 @@ repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
             ; repTySynEqn tys2 rhs1 } }
 
 repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
-repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
-                                 , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names }
-                                 , dfid_defn = defn })
+repDataFamInstD (DataFamInstDecl { dfid_eqn =
+                  (HsIB { hsib_vars = var_names
+                        , hsib_body = FamEqn { feqn_tycon = tc_name
+                                             , feqn_pats  = tys
+                                             , feqn_rhs   = defn }})})
   = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
        ; let hs_tvs = HsQTvs { hsq_implicit = var_names
                              , hsq_explicit = []
index de36a85..a9df2b2 100644 (file)
@@ -300,10 +300,10 @@ cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
                                , dd_cons = cons', dd_derivs = derivs' }
 
        ; returnJustL $ InstD $ DataFamInstD
-           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
-                                         , dfid_defn = defn
-                                         , dfid_fixity = Prefix
-                                         , dfid_fvs = placeHolderNames } }}
+           { dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+                           FamEqn { feqn_tycon = tc', feqn_pats = typats'
+                                  , feqn_rhs = defn
+                                  , feqn_fixity = Prefix } }}}
 
 cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
   = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
@@ -315,17 +315,16 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
                                , dd_kindSig = ksig'
                                , dd_cons = [con'], dd_derivs = derivs' }
        ; returnJustL $ InstD $ DataFamInstD
-           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
-                                         , dfid_defn = defn
-                                         , dfid_fixity = Prefix
-                                         , dfid_fvs = placeHolderNames } }}
+           { dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+                           FamEqn { feqn_tycon = tc', feqn_pats = typats'
+                                  , feqn_rhs = defn
+                                  , feqn_fixity = Prefix } }}}
 
 cvtDec (TySynInstD tc eqn)
   = do  { tc' <- tconNameL tc
-        ; eqn' <- cvtTySynEqn tc' eqn
+        ; L _ eqn' <- cvtTySynEqn tc' eqn
         ; returnJustL $ InstD $ TyFamInstD
-            { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
-                                        , tfid_fvs = placeHolderNames } } }
+            { tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
 
 cvtDec (OpenTypeFamilyD head)
   = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
@@ -389,10 +388,11 @@ cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
 cvtTySynEqn tc (TySynEqn lhs rhs)
   = do  { lhs' <- mapM (wrap_apps <=< cvtType) lhs
         ; rhs' <- cvtType rhs
-        ; returnL $ TyFamEqn { tfe_tycon = tc
-                             , tfe_pats = mkHsImplicitBndrs lhs'
-                             , tfe_fixity = Prefix
-                             , tfe_rhs = rhs' } }
+        ; returnL $ mkHsImplicitBndrs
+                  $ FamEqn { feqn_tycon  = tc
+                           , feqn_pats   = lhs'
+                           , feqn_fixity = Prefix
+                           , feqn_rhs    = rhs' } }
 
 ----------------
 cvt_ci_decs :: MsgDoc -> [TH.Dec]
@@ -430,12 +430,12 @@ cvt_tycl_hdr cxt tc tvs
 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
                -> CvtM ( LHsContext GhcPs
                        , Located RdrName
-                       , HsImplicitBndrs GhcPs [LHsType GhcPs])
+                       , HsTyPats GhcPs)
 cvt_tyinst_hdr cxt tc tys
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
        ; tys' <- mapM (wrap_apps <=< cvtType) tys
-       ; return (cxt', tc', mkHsImplicitBndrs tys') }
+       ; return (cxt', tc', tys') }
 
 ----------------
 cvt_tyfam_head :: TypeFamilyHead
index 5a6d3dd..cb67be8 100644 (file)
@@ -38,7 +38,8 @@ module HsDecls (
   InstDecl(..), LInstDecl, NewOrData(..), FamilyInfo(..),
   TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,
   DataFamInstDecl(..), LDataFamInstDecl, pprDataFamInstFlavour, pprFamInstLHS,
-  TyFamEqn(..), TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
+  FamInstEqn, LFamInstEqn, FamEqn(..),
+  TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn,
   HsTyPats,
   LClsInstDecl, ClsInstDecl(..),
 
@@ -592,7 +593,7 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
 
 tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass)
 tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =
-                     (L _ (TyFamEqn { tfe_tycon = ln })) })
+                     (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })
   = ln
 
 tyClDeclLName :: TyClDecl pass -> Located (IdP pass)
@@ -999,7 +1000,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
         ( text "where"
         , case mb_eqns of
             Nothing   -> text ".."
-            Just eqns -> vcat $ map ppr_fam_inst_eqn eqns )
+            Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )
       _ -> (empty, empty)
 
 pprFlavour :: FamilyInfo pass -> SDoc
@@ -1283,27 +1284,35 @@ ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
 
 Note [Type family instance declarations in HsSyn]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The data type TyFamEqn represents one equation of a type family instance.
-It is parameterised over its tfe_pats field:
+The data type FamEqn represents one equation of a type family instance.
+Aside from the pass, it is also parameterised over two fields:
+feqn_pats and feqn_rhs.
+
+feqn_pats is either LHsTypes (for ordinary data/type family instances) or
+LHsQTyVars (for associated type family default instances). In particular:
 
  * An ordinary type family instance declaration looks like this in source Haskell
       type instance T [a] Int = a -> a
    (or something similar for a closed family)
-   It is represented by a TyFamInstEqn, with *type* in the tfe_pats field.
+   It is represented by a FamInstEqn, with a *type* (LHsType) in the feqn_pats
+   field.
 
  * On the other hand, the *default instance* of an associated type looks like
    this in source Haskell
       class C a where
         type T a b
         type T a b = a -> b   -- The default instance
-   It is represented by a TyFamDefltEqn, with *type variables* in the tfe_pats
-   field.
+   It is represented by a TyFamDefltEqn, with *type variables* (LHsQTyVars) in
+   the feqn_pats field.
+
+feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType
+(for type family instances).
 -}
 
 ----------------- Type synonym family instances -------------
 
 -- | Located Type Family Instance Equation
-type LTyFamInstEqn  pass = Located (TyFamInstEqn  pass)
+type LTyFamInstEqn pass = Located (TyFamInstEqn pass)
   -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'
   --   when in a list
 
@@ -1313,16 +1322,14 @@ type LTyFamInstEqn  pass = Located (TyFamInstEqn  pass)
 type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass)
 
 -- | Haskell Type Patterns
-type HsTyPats pass = HsImplicitBndrs pass [LHsType pass]
-            -- ^ Type patterns (with kind and type bndrs)
-            -- See Note [Family instance declaration binders]
+type HsTyPats pass = [LHsType pass]
 
 {- Note [Family instance declaration binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The HsTyPats field is LHS patterns or a type/data family instance.
-
-The hsib_vars of the HsImplicitBndrs are the template variables of the
-type patterns, i.e. fv(pat_tys).  Note in particular
+For ordinary data/type family instances, the feqn_pats field of FamEqn stores
+the LHS type (and kind) patterns. These type patterns can of course contain
+type (and kind) variables, which are bound in the hsib_vars field of the
+HsImplicitBndrs in FamInstEqn. Note in particular
 
 * The hsib_vars *includes* any anonymous wildcards.  For example
      type instance F a _ = a
@@ -1344,45 +1351,30 @@ type patterns, i.e. fv(pat_tys).  Note in particular
           type F (a8,b9) x10 = x10->a8
    so that we can compare the type pattern in the 'instance' decl and
    in the associated 'type' decl
+
+For associated type family default instances (TyFamDefltEqn), instead of using
+type patterns with binders in a surrounding HsImplicitBndrs, we use raw type
+variables (LHsQTyVars) in the feqn_pats field of FamEqn.
 -}
 
 -- | Type Family Instance Equation
-type TyFamInstEqn  pass = TyFamEqn pass (HsTyPats pass)
+type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)
 
 -- | Type Family Default Equation
-type TyFamDefltEqn pass = TyFamEqn pass (LHsQTyVars pass)
+type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass)
   -- See Note [Type family instance declarations in HsSyn]
 
--- | Type Family Equation
---
--- One equation in a type family instance declaration
--- See Note [Type family instance declarations in HsSyn]
-data TyFamEqn pass pats
-  = TyFamEqn
-       { tfe_tycon  :: Located (IdP pass)
-       , tfe_pats   :: pats
-       , tfe_fixity :: LexicalFixity    -- ^ Fixity used in the declaration
-       , tfe_rhs    :: LHsType pass }
-    -- ^
-    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
-
-    -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass, Data pats) => Data (TyFamEqn pass pats)
-
 -- | Located Type Family Instance Declaration
 type LTyFamInstDecl pass = Located (TyFamInstDecl pass)
 
 -- | Type Family Instance Declaration
-data TyFamInstDecl pass
-  = TyFamInstDecl
-       { tfid_eqn  :: LTyFamInstEqn pass
-       , tfid_fvs  :: PostRn pass NameSet }
+newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',
     --           'ApiAnnotation.AnnInstance',
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (TyFamInstDecl pass)
+deriving instance DataId pass => Data (TyFamInstDecl pass)
 
 ----------------- Data family instances -------------
 
@@ -1390,14 +1382,8 @@ deriving instance (DataId pass) => Data (TyFamInstDecl pass)
 type LDataFamInstDecl pass = Located (DataFamInstDecl pass)
 
 -- | Data Family Instance Declaration
-data DataFamInstDecl pass
-  = DataFamInstDecl
-       { dfid_tycon     :: Located (IdP pass)
-       , dfid_pats      :: HsTyPats   pass       -- LHS
-       , dfid_fixity    :: LexicalFixity    -- ^ Fixity used in the declaration
-       , dfid_defn      :: HsDataDefn pass       -- RHS
-       , dfid_fvs       :: PostRn pass NameSet }
-                                           -- Free vars for dependency analysis
+newtype DataFamInstDecl pass
+  = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }
     -- ^
     --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',
     --           'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',
@@ -1406,7 +1392,38 @@ data DataFamInstDecl pass
     --           'ApiAnnotation.AnnClose'
 
     -- For details on above see note [Api annotations] in ApiAnnotation
-deriving instance (DataId pass) => Data (DataFamInstDecl pass)
+deriving instance DataId pass => Data (DataFamInstDecl pass)
+
+----------------- Family instances (common types) -------------
+
+-- | Located Family Instance Equation
+type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)
+
+-- | Family Instance Equation
+type FamInstEqn pass rhs
+  = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs)
+            -- ^ Here, the @pats@ are type patterns (with kind and type bndrs).
+            -- See Note [Family instance declaration binders]
+
+-- | Family Equation
+--
+-- One equation in a type family instance declaration, data family instance
+-- declaration, or type family default.
+-- See Note [Type family instance declarations in HsSyn]
+-- See Note [Family instance declaration binders]
+data FamEqn pass pats rhs
+  = FamEqn
+       { feqn_tycon  :: Located (IdP pass)
+       , feqn_pats   :: pats
+       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration
+       , feqn_rhs    :: rhs
+       }
+    -- ^
+    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
+
+    -- For details on above see note [Api annotations] in ApiAnnotation
+deriving instance (DataId pass, Data pats, Data rhs)
+                => Data (FamEqn pass pats rhs)
 
 ----------------- Class instances -------------
 
@@ -1467,19 +1484,19 @@ ppr_instance_keyword TopLevel    = text "instance"
 ppr_instance_keyword NotTopLevel = empty
 
 ppr_fam_inst_eqn :: (SourceTextX pass, OutputableBndrId pass)
-                 => LTyFamInstEqn pass -> SDoc
-ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon
-                                , tfe_pats  = pats
-                                , tfe_fixity = fixity
-                                , tfe_rhs   = rhs }))
+                 => TyFamInstEqn pass -> SDoc
+ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+                                            , feqn_pats   = pats
+                                            , feqn_fixity = fixity
+                                            , feqn_rhs    = rhs }})
     = pprFamInstLHS tycon pats fixity [] Nothing <+> equals <+> ppr rhs
 
 ppr_fam_deflt_eqn :: (SourceTextX pass, OutputableBndrId pass)
                   => LTyFamDefltEqn pass -> SDoc
-ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon
-                                 , tfe_pats  = tvs
-                                 , tfe_fixity = fixity
-                                 , tfe_rhs   = rhs }))
+ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon  = tycon
+                               , feqn_pats   = tvs
+                               , feqn_fixity = fixity
+                               , feqn_rhs    = rhs }))
     = text "type" <+> pp_vanilla_decl_head tycon tvs fixity []
                   <+> equals <+> ppr rhs
 
@@ -1489,17 +1506,19 @@ instance (SourceTextX pass, OutputableBndrId pass)
 
 pprDataFamInstDecl :: (SourceTextX pass, OutputableBndrId pass)
                    => TopLevelFlag -> DataFamInstDecl pass -> SDoc
-pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon
-                                            , dfid_pats  = pats
-                                            , dfid_fixity = fixity
-                                            , dfid_defn  = defn })
+pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                             FamEqn { feqn_tycon  = tycon
+                                    , feqn_pats   = pats
+                                    , feqn_fixity = fixity
+                                    , feqn_rhs    = defn }}})
   = pp_data_defn pp_hdr defn
   where
     pp_hdr ctxt = ppr_instance_keyword top_lvl
               <+> pprFamInstLHS tycon pats fixity ctxt (dd_kindSig defn)
 
 pprDataFamInstFlavour :: DataFamInstDecl pass -> SDoc
-pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) })
+pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                        FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})
   = ppr nd
 
 pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass)
@@ -1509,7 +1528,7 @@ pprFamInstLHS :: (SourceTextX pass, OutputableBndrId pass)
    -> HsContext pass
    -> Maybe (LHsKind pass)
    -> SDoc
-pprFamInstLHS thing (HsIB { hsib_body = typats }) fixity context mb_kind_sig
+pprFamInstLHS thing typats fixity context mb_kind_sig
                                               -- explicit type patterns
    = hsep [ pprHsContext context, pp_pats typats, pp_kind_sig ]
    where
index 374fbe9..a72e3c8 100644 (file)
@@ -1092,7 +1092,8 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
 -- the SrcLoc returned are for the whole declarations, not just the names
 hsDataFamInstBinders :: DataFamInstDecl pass
                      -> ([Located (IdP pass)], [LFieldOcc pass])
-hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
+hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                       FamEqn { feqn_rhs = defn }}})
   = hsDataDefnBinders defn
   -- There can't be repeated symbols because only data instances have binders
 
index 672b6f7..e3deb31 100644 (file)
@@ -1154,21 +1154,23 @@ ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }
 
 ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
         : ty_fam_inst_eqns ';' ty_fam_inst_eqn
-                                      {% asl (unLoc $1) $2 (snd $ unLoc $3)
-                                         >> ams $3 (fst $ unLoc $3)
-                                         >> return (sLL $1 $> ((snd $ unLoc $3) : unLoc $1)) }
+                                      {% let L loc (anns, eqn) = $3 in
+                                         asl (unLoc $1) $2 (L loc eqn)
+                                         >> ams $3 anns
+                                         >> return (sLL $1 $> (L loc eqn : unLoc $1)) }
         | ty_fam_inst_eqns ';'        {% addAnnotation (gl $1) AnnSemi (gl $2)
                                          >> return (sLL $1 $>  (unLoc $1)) }
-        | ty_fam_inst_eqn             {% ams $1 (fst $ unLoc $1)
-                                         >> return (sLL $1 $> [snd $ unLoc $1]) }
+        | ty_fam_inst_eqn             {% let L loc (anns, eqn) = $1 in
+                                         ams $1 anns
+                                         >> return (sLL $1 $> [L loc eqn]) }
         | {- empty -}                 { noLoc [] }
 
-ty_fam_inst_eqn :: { Located ([AddAnn],LTyFamInstEqn GhcPs) }
+ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }
         : type '=' ctype
                 -- Note the use of type for the head; this allows
                 -- infix type constructors and type patterns
               {% do { (eqn,ann) <- mkTyFamInstEqn $1 $3
-                    ; return (sLL $1 $> (mj AnnEqual $2:ann, sLL $1 $> eqn))  } }
+                    ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn))  } }
 
 -- Associated type family declarations
 --
index ecfae76..41d8a4a 100644 (file)
@@ -159,14 +159,14 @@ mkATDefault :: LTyFamInstDecl GhcPs
 --
 -- We use the Either monad because this also called
 -- from Convert.hs
-mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e }))
-      | TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity
-                 , tfe_rhs = rhs } <- e
-      = do { tvs <- checkTyVars (text "default") equalsDots tc (hsib_body pats)
-           ; return (L loc (TyFamEqn { tfe_tycon = tc
-                                     , tfe_pats = tvs
-                                     , tfe_fixity = fixity
-                                     , tfe_rhs = rhs })) }
+mkATDefault (L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }}))
+      | FamEqn { feqn_tycon = tc, feqn_pats = pats, feqn_fixity = fixity
+               , feqn_rhs = rhs } <- e
+      = do { tvs <- checkTyVars (text "default") equalsDots tc pats
+           ; return (L loc (FamEqn { feqn_tycon  = tc
+                                   , feqn_pats   = tvs
+                                   , feqn_fixity = fixity
+                                   , feqn_rhs    = rhs })) }
 
 mkTyData :: SrcSpan
          -> NewOrData
@@ -221,10 +221,11 @@ mkTyFamInstEqn :: LHsType GhcPs
                -> P (TyFamInstEqn GhcPs,[AddAnn])
 mkTyFamInstEqn lhs rhs
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
-       ; return (TyFamEqn { tfe_tycon = tc
-                          , tfe_pats  = mkHsImplicitBndrs tparams
-                          , tfe_fixity = fixity
-                          , tfe_rhs   = rhs },
+       ; return (mkHsImplicitBndrs
+                  (FamEqn { feqn_tycon  = tc
+                          , feqn_pats   = tparams
+                          , feqn_fixity = fixity
+                          , feqn_rhs    = rhs }),
                  ann) }
 
 mkDataFamInst :: SrcSpan
@@ -239,18 +240,17 @@ mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_
   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
        ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (DataFamInstD (
-                  DataFamInstDecl { dfid_tycon = tc
-                                  , dfid_pats = mkHsImplicitBndrs tparams
-                                  , dfid_fixity = fixity
-                                  , dfid_defn = defn, dfid_fvs = placeHolderNames }))) }
+       ; return (L loc (DataFamInstD (DataFamInstDecl (mkHsImplicitBndrs
+                  (FamEqn { feqn_tycon = tc
+                          , feqn_pats = tparams
+                          , feqn_fixity = fixity
+                          , feqn_rhs = defn }))))) }
 
 mkTyFamInst :: SrcSpan
-            -> LTyFamInstEqn GhcPs
+            -> TyFamInstEqn GhcPs
             -> P (LInstDecl GhcPs)
 mkTyFamInst loc eqn
-  = return (L loc (TyFamInstD (TyFamInstDecl { tfid_eqn  = eqn
-                                             , tfid_fvs  = placeHolderNames })))
+  = return (L loc (TyFamInstD (TyFamInstDecl eqn)))
 
 mkFamDecl :: SrcSpan
           -> FamilyInfo GhcPs
index 6197bc7..84e62f0 100644 (file)
@@ -688,14 +688,15 @@ getLocalNonValBinders fixity_env
 
     new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
                    -> RnM (AvailInfo, [(Name, [FieldLabel])])
-    new_di overload_ok mb_cls ti_decl
-        = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl)
-             ; let (bndrs, flds) = hsDataFamInstBinders ti_decl
+    new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =
+                                     HsIB { hsib_body = ti_decl }})
+        = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
+             ; let (bndrs, flds) = hsDataFamInstBinders dfid
              ; sub_names <- mapM newTopSrcBinder bndrs
              ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
              ; let avail    = AvailTC (unLoc main_name) sub_names flds'
                                   -- main_name is not bound here!
-                   fld_env  = mk_fld_env (dfid_defn ti_decl) sub_names flds'
+                   fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
              ; return (avail, fld_env) }
 
     new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs
index 4ac670c..cb9c960 100644 (file)
@@ -715,20 +715,22 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
              --     strange, but should not matter (and it would be more work
              --     to remove the context).
 
-rnFamInstDecl :: HsDocContext
-              -> Maybe (Name, [Name]) -- Nothing => not associated
-                                        -- Just (cls,tvs) => associated,
-                                        --   and gives class and tyvars of the
-                                        --   parent instance delc
-              -> Located RdrName
-              -> HsTyPats GhcPs
-              -> rhs
-              -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-              -> RnM (Located Name, HsTyPats GhcRn, rhs', FreeVars)
-rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
+rnFamInstEqn :: HsDocContext
+             -> Maybe (Name, [Name]) -- Nothing => not associated
+                                     -- Just (cls,tvs) => associated,
+                                     --   and gives class and tyvars of the
+                                     --   parent instance delc
+             -> FamInstEqn GhcPs rhs
+             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
+             -> RnM (FamInstEqn GhcRn rhs', FreeVars)
+rnFamInstEqn doc mb_cls (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+                                                   , feqn_pats   = pats
+                                                   , feqn_fixity = fixity
+                                                   , feqn_rhs    = payload }})
+            rnPayload
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
        ; let loc = case pats of
-                     []             -> pprPanic "rnFamInstDecl" (ppr tycon)
+                     []             -> pprPanic "rnFamInstEqn" (ppr tycon)
                      (L loc _ : []) -> loc
                      (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
 
@@ -786,67 +788,54 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
                         -- Note [Wildcards in family instances]
              all_fvs  = fvs `addOneFV` unLoc tycon'
 
-       ; return (tycon',
-                 HsIB { hsib_body = pats'
-                      , hsib_vars = all_ibs
-                      , hsib_closed = True },
-                 payload',
+       ; return (HsIB { hsib_vars = all_ibs
+                      , hsib_closed = True
+                      , hsib_body
+                          = FamEqn { feqn_tycon  = tycon'
+                                   , feqn_pats   = pats'
+                                   , feqn_fixity = fixity
+                                   , feqn_rhs    = payload' } },
                  all_fvs) }
              -- type instance => use, hence addOneFV
 
 rnTyFamInstDecl :: Maybe (Name, [Name])
                 -> TyFamInstDecl GhcPs
                 -> RnM (TyFamInstDecl GhcRn, FreeVars)
-rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
+rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
   = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
-       ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
-                               , tfid_fvs = fvs }, fvs) }
+       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
 
 rnTyFamInstEqn :: Maybe (Name, [Name])
                -> TyFamInstEqn GhcPs
                -> RnM (TyFamInstEqn GhcRn, FreeVars)
-rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
-                                , tfe_pats  = pats
-                                , tfe_fixity = fixity
-                                , tfe_rhs   = rhs })
-  = do { (tycon', pats', rhs', fvs) <-
-           rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
-       ; return (TyFamEqn { tfe_tycon = tycon'
-                          , tfe_pats  = pats'
-                          , tfe_fixity = fixity
-                          , tfe_rhs   = rhs' }, fvs) }
+rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon  = tycon }})
+  = rnFamInstEqn (TySynCtx tycon) mb_cls eqn rnTySyn
 
 rnTyFamDefltEqn :: Name
                 -> TyFamDefltEqn GhcPs
                 -> RnM (TyFamDefltEqn GhcRn, FreeVars)
-rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
-                              , tfe_pats  = tyvars
-                              , tfe_fixity = fixity
-                              , tfe_rhs   = rhs })
+rnTyFamDefltEqn cls (FamEqn { feqn_tycon  = tycon
+                            , feqn_pats   = tyvars
+                            , feqn_fixity = fixity
+                            , feqn_rhs    = rhs })
   = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->
     do { tycon'      <- lookupFamInstName (Just cls) tycon
        ; (rhs', fvs) <- rnLHsType ctx rhs
-       ; return (TyFamEqn { tfe_tycon = tycon'
-                          , tfe_pats  = tyvars'
-                          , tfe_fixity = fixity
-                          , tfe_rhs   = rhs' }, fvs) }
+       ; return (FamEqn { feqn_tycon  = tycon'
+                        , feqn_pats   = tyvars'
+                        , feqn_fixity = fixity
+                        , feqn_rhs    = rhs' }, fvs) }
   where
     ctx = TyFamilyCtx tycon
 
 rnDataFamInstDecl :: Maybe (Name, [Name])
                   -> DataFamInstDecl GhcPs
                   -> RnM (DataFamInstDecl GhcRn, FreeVars)
-rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
-                                          , dfid_pats  = pats
-                                          , dfid_fixity = fixity
-                                          , dfid_defn  = defn })
-  = do { (tycon', pats', defn', fvs) <-
-           rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
-       ; return (DataFamInstDecl { dfid_tycon = tycon'
-                                 , dfid_pats  = pats'
-                                 , dfid_fixity = fixity
-                                 , dfid_defn  = defn'
-                                 , dfid_fvs   = fvs }, fvs) }
+rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
+                           FamEqn { feqn_tycon  = tycon }})})
+  = do { (eqn', fvs) <-
+           rnFamInstEqn (TyDataCtx tycon) mb_cls eqn rnDataDefn
+       ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
 
 -- Renaming of the associated types in instances.
 
@@ -889,7 +878,7 @@ is the same as
 
 This is implemented as follows: during renaming anonymous wild cards
 '_' are given freshly generated names. These names are collected after
-renaming (rnFamInstDecl) and used to make new type variables during
+renaming (rnFamInstEqn) and used to make new type variables during
 type checking (tc_fam_ty_pats). One should not confuse these wild
 cards with the ones from partial type signatures. The latter generate
 fresh meta-variables whereas the former generate fresh skolems.
index 12f8a1d..4a27134 100644 (file)
@@ -592,7 +592,8 @@ tcAddDataFamConPlaceholders inst_decls thing_inside
       = concatMap (get_fi_cons . unLoc) fids
 
     get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
-    get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
+    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                  FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
       = map unLoc $ concatMap (getConNames . unLoc) cons
 
 
index a3da31d..2f3d358 100644 (file)
@@ -487,7 +487,10 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
         -- from their defaults (if available)
         ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
                             `unionNameSet`
-                            mkNameSet (map (unLoc . dfid_tycon . unLoc) adts)
+                            mkNameSet (map (unLoc . feqn_tycon
+                                                  . hsib_body
+                                                  . dfid_eqn
+                                                  . unLoc) adts)
         ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats)
                                (classATItems clas)
 
@@ -600,7 +603,7 @@ tcTyFamInstDecl :: Maybe ClsInstInfo
 tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
   = setSrcSpan loc           $
     tcAddTyFamInstCtxt decl  $
-    do { let fam_lname = tfe_tycon (unLoc eqn)
+    do { let fam_lname = feqn_tycon (hsib_body eqn)
        ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname
 
          -- (0) Check it's an open type family
@@ -609,7 +612,8 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
        ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
 
          -- (1) do the work of verifying the synonym group
-       ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) mb_clsinfo eqn
+       ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) mb_clsinfo
+                                        (L (getLoc fam_lname) eqn)
 
          -- (2) check for validity
        ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch
@@ -623,13 +627,17 @@ tcDataFamInstDecl :: Maybe ClsInstInfo
                   -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
   -- "newtype instance" and "data instance"
 tcDataFamInstDecl mb_clsinfo
-    (L loc decl@(DataFamInstDecl
-       { dfid_pats = pats
-       , dfid_tycon = fam_tc_name
-       , dfid_fixity = fixity
-       , dfid_defn = HsDataDefn { dd_ND = new_or_data, dd_cType = cType
-                                , dd_ctxt = ctxt, dd_cons = cons
-                                , dd_kindSig = m_ksig, dd_derivs = derivs } }))
+    (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_vars = tv_names
+                                                   , hsib_body =
+      FamEqn { feqn_pats   = pats
+             , feqn_tycon  = fam_tc_name
+             , feqn_fixity = fixity
+             , feqn_rhs    = HsDataDefn { dd_ND = new_or_data
+                                        , dd_cType = cType
+                                        , dd_ctxt = ctxt
+                                        , dd_cons = cons
+                                        , dd_kindSig = m_ksig
+                                        , dd_derivs = derivs } }}}))
   = setSrcSpan loc             $
     tcAddDataFamInstCtxt decl  $
     do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
@@ -640,7 +648,7 @@ tcDataFamInstDecl mb_clsinfo
 
          -- Kind check type patterns
        ; let mb_kind_env = thdOf3 <$> mb_clsinfo
-       ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats
+       ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo tv_names pats
                      (kcDataDefn mb_kind_env decl) $
              \tvs pats res_kind ->
     do { stupid_theta <- solveEqualities $ tcHsContext ctxt
index a152942..f0afdb6 100644 (file)
@@ -1060,7 +1060,7 @@ tcClassATs class_name cls ats at_defs
        ; mapM tc_at ats }
   where
     at_def_tycon :: LTyFamDefltEqn GhcRn -> Name
-    at_def_tycon (L _ eqn) = unLoc (tfe_tycon eqn)
+    at_def_tycon (L _ eqn) = unLoc (feqn_tycon eqn)
 
     at_fam_name :: LFamilyDecl GhcRn -> Name
     at_fam_name (L _ decl) = unLoc (fdLName decl)
@@ -1088,11 +1088,12 @@ tcDefaultAssocDecl _ []
 
 tcDefaultAssocDecl _ (d1:_:_)
   = failWithTc (text "More than one default declaration for"
-                <+> ppr (tfe_tycon (unLoc d1)))
+                <+> ppr (feqn_tycon (unLoc d1)))
 
-tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = lname@(L _ tc_name)
-                                           , tfe_pats = hs_tvs, tfe_fixity = fixity
-                                           , tfe_rhs = rhs })]
+tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = lname@(L _ tc_name)
+                                         , feqn_pats = hs_tvs
+                                         , feqn_fixity = fixity
+                                         , feqn_rhs = rhs })]
   | HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs
   = -- See Note [Type-checking default assoc decls]
     setSrcSpan loc $
@@ -1110,10 +1111,9 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = lname@(L _ tc_name)
                  (wrongNumberOfParmsErr fam_arity)
 
        -- Typecheck RHS
-       ; let pats = HsIB { hsib_vars = imp_vars ++ map hsLTyVarName exp_vars
-                         , hsib_body = map hsLTyVarBndrToType exp_vars
-                         , hsib_closed = False } -- this field is ignored, anyway
-             pp_lhs = pprFamInstLHS lname pats fixity [] Nothing
+       ; let all_vars = imp_vars ++ map hsLTyVarName exp_vars
+             pats     = map hsLTyVarBndrToType exp_vars
+             pp_lhs   = pprFamInstLHS lname pats fixity [] Nothing
 
           -- NB: Use tcFamTyPats, not tcTyClTyVars. The latter expects to get
           -- the LHsQTyVars used for declaring a tycon, but the names here
@@ -1124,7 +1124,7 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = lname@(L _ tc_name)
           -- type default LHS can mention *different* type variables than the
           -- enclosing class. So it's treated more as a freestanding beast.
        ; (pats', rhs_ty)
-           <- tcFamTyPats shape Nothing pats
+           <- tcFamTyPats shape Nothing all_vars pats
               (kcTyFamEqnRhs Nothing pp_lhs rhs) $
               \tvs pats rhs_kind ->
               do { rhs_ty <- solveEqualities $
@@ -1168,16 +1168,17 @@ proper tcMatchTys here.)  -}
 -------------------------
 kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn GhcRn -> TcM ()
 kcTyFamInstEqn fam_tc_shape@(FamTyConShape { fs_name = fam_tc_name })
-    (L loc (TyFamEqn { tfe_tycon  = lname@(L _ eqn_tc_name)
-                     , tfe_pats   = pats
-                     , tfe_fixity = fixity
-                     , tfe_rhs    = hs_ty }))
+    (L loc (HsIB { hsib_vars = tv_names
+                 , hsib_body = FamEqn { feqn_tycon  = lname@(L _ eqn_tc_name)
+                                      , feqn_pats   = pats
+                                      , feqn_fixity = fixity
+                                      , feqn_rhs    = hs_ty }}))
   = setSrcSpan loc $
     do { checkTc (fam_tc_name == eqn_tc_name)
                  (wrongTyFamName fam_tc_name eqn_tc_name)
        ; discardResult $
          tc_fam_ty_pats fam_tc_shape Nothing -- not an associated type
-                        pats (kcTyFamEqnRhs Nothing pp_lhs hs_ty) }
+                        tv_names pats (kcTyFamEqnRhs Nothing pp_lhs hs_ty) }
   where
     pp_lhs = pprFamInstLHS lname pats fixity [] Nothing
 
@@ -1207,13 +1208,14 @@ tcTyFamInstEqn :: FamTyConShape -> Maybe ClsInstInfo -> LTyFamInstEqn GhcRn
 -- Needs to be here, not in TcInstDcls, because closed families
 -- (typechecked here) have TyFamInstEqns
 tcTyFamInstEqn fam_tc_shape@(FamTyConShape { fs_name = fam_tc_name }) mb_clsinfo
-    (L loc (TyFamEqn { tfe_tycon  = lname@(L _ eqn_tc_name)
-                     , tfe_pats   = pats
-                     , tfe_fixity = fixity
-                     , tfe_rhs    = hs_ty }))
+    (L loc (HsIB { hsib_vars = tv_names
+                 , hsib_body = FamEqn { feqn_tycon  = lname@(L _ eqn_tc_name)
+                                      , feqn_pats   = pats
+                                      , feqn_fixity = fixity
+                                      , feqn_rhs    = hs_ty }}))
   = ASSERT( fam_tc_name == eqn_tc_name )
     setSrcSpan loc $
-    tcFamTyPats fam_tc_shape mb_clsinfo pats
+    tcFamTyPats fam_tc_shape mb_clsinfo tv_names pats
                 (kcTyFamEqnRhs mb_clsinfo pp_lhs hs_ty) $
                     \tvs pats res_kind ->
     do { rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind
@@ -1240,11 +1242,13 @@ kcDataDefn :: Maybe (VarEnv Kind) -- ^ Possibly, instantiations for vars
 -- Used for 'data instance' only
 -- Ordinary 'data' is handled by kcTyClDec
 kcDataDefn mb_kind_env
-           (DataFamInstDecl
-             { dfid_tycon  = fam_name
-             , dfid_pats   = pats
-             , dfid_fixity = fixity
-             , dfid_defn   = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_kindSig = mb_kind } })
+           (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+              FamEqn { feqn_tycon  = fam_name
+                     , feqn_pats   = pats
+                     , feqn_fixity = fixity
+                     , feqn_rhs    = HsDataDefn { dd_ctxt = ctxt
+                                                , dd_cons = cons
+                                                , dd_kindSig = mb_kind } }}})
            res_k
   = do  { _ <- tcHsContext ctxt
         ; checkNoErrs $ mapM_ (wrapLocM kcConDecl) cons
@@ -1373,7 +1377,8 @@ famTyConShape fam_tc
 
 tc_fam_ty_pats :: FamTyConShape
                -> Maybe ClsInstInfo
-               -> HsTyPats GhcRn      -- Patterns
+               -> [Name]              -- Bound kind/type variable names
+               -> HsTyPats GhcRn      -- Type patterns
                -> (TcKind -> TcM r)   -- Kind checker for RHS
                -> TcM ([Type], r)     -- Returns the type-checked patterns
 -- Check the type patterns of a type or data family instance
@@ -1390,7 +1395,7 @@ tc_fam_ty_pats :: FamTyConShape
 tc_fam_ty_pats (FamTyConShape { fs_name = name, fs_arity = arity
                               , fs_flavor = flav, fs_binders = binders
                               , fs_res_kind = res_kind })
-               mb_clsinfo (HsIB { hsib_body = arg_pats, hsib_vars = tv_names })
+               mb_clsinfo tv_names arg_pats
                kind_checker
   = do { -- First, check the arity.
          -- If we wait until validity checking, we'll get kind
@@ -1428,7 +1433,8 @@ tc_fam_ty_pats (FamTyConShape { fs_name = name, fs_arity = arity
 -- See Note [tc_fam_ty_pats vs tcFamTyPats]
 tcFamTyPats :: FamTyConShape
             -> Maybe ClsInstInfo
-            -> HsTyPats GhcRn        -- patterns
+            -> [Name]          -- Implicitly bound kind/type variable names
+            -> HsTyPats GhcRn  -- Type patterns
             -> (TcKind -> TcM ([TcType], TcKind))
                 -- kind-checker for RHS
                 -- See Note [Instantiating a family tycon]
@@ -1437,11 +1443,12 @@ tcFamTyPats :: FamTyConShape
                 -> TcKind
                 -> TcM a)            -- NB: You can use solveEqualities here.
             -> TcM a
-tcFamTyPats fam_shape@(FamTyConShape { fs_name = name }) mb_clsinfo pats
-            kind_checker thing_inside
+tcFamTyPats fam_shape@(FamTyConShape { fs_name = name }) mb_clsinfo
+            tv_names arg_pats kind_checker thing_inside
   = do { (typats, (more_typats, res_kind))
             <- solveEqualities $  -- See Note [Constraints in patterns]
-               tc_fam_ty_pats fam_shape mb_clsinfo pats kind_checker
+               tc_fam_ty_pats fam_shape mb_clsinfo
+                              tv_names arg_pats kind_checker
 
           {- TODO (RAE): This should be cleverer. Consider this:
 
@@ -3062,9 +3069,10 @@ tcAddTyFamInstCtxt decl
   = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)
 
 tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
-tcMkDataFamInstCtxt decl
+tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =
+                            HsIB { hsib_body = eqn }})
   = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")
-                    (unLoc (dfid_tycon decl))
+                    (unLoc (feqn_tycon eqn))
 
 tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
 tcAddDataFamInstCtxt decl
index 5c20f29..b6b74a4 100644 (file)
        (ClosedTypeFamily
         (Just
          [({ DumpParsedAst.hs:8:3-36 }
-           (TyFamEqn
-            ({ DumpParsedAst.hs:8:3-8 }
-             (Unqual
-              {OccName: Length}))
-            (HsIB
-             (PlaceHolder)
+           (HsIB
+            (PlaceHolder)
+            (FamEqn
+             ({ DumpParsedAst.hs:8:3-8 }
+              (Unqual
+               {OccName: Length}))
              [({ DumpParsedAst.hs:8:10-17 }
                (HsParTy
                 ({ DumpParsedAst.hs:8:11-16 }
                        ({ DumpParsedAst.hs:8:15-16 }
                         (Unqual
                          {OccName: as}))))))]))))]
-             (PlaceHolder))
-            (Prefix)
-            ({ DumpParsedAst.hs:8:21-36 }
-             (HsAppsTy
-              [({ DumpParsedAst.hs:8:21-24 }
-                (HsAppPrefix
-                 ({ DumpParsedAst.hs:8:21-24 }
-                  (HsTyVar
-                   (NotPromoted)
-                   ({ DumpParsedAst.hs:8:21-24 }
-                    (Unqual
-                     {OccName: Succ}))))))
-              ,({ DumpParsedAst.hs:8:26-36 }
-                (HsAppPrefix
-                 ({ DumpParsedAst.hs:8:26-36 }
-                  (HsParTy
-                   ({ DumpParsedAst.hs:8:27-35 }
-                    (HsAppsTy
-                     [({ DumpParsedAst.hs:8:27-32 }
-                       (HsAppPrefix
-                        ({ DumpParsedAst.hs:8:27-32 }
-                         (HsTyVar
-                          (NotPromoted)
-                          ({ DumpParsedAst.hs:8:27-32 }
-                           (Unqual
-                            {OccName: Length}))))))
-                     ,({ DumpParsedAst.hs:8:34-35 }
-                       (HsAppPrefix
-                        ({ DumpParsedAst.hs:8:34-35 }
-                         (HsTyVar
-                          (NotPromoted)
-                          ({ DumpParsedAst.hs:8:34-35 }
-                           (Unqual
-                            {OccName: as}))))))]))))))]))))
+             (Prefix)
+             ({ DumpParsedAst.hs:8:21-36 }
+              (HsAppsTy
+               [({ DumpParsedAst.hs:8:21-24 }
+                 (HsAppPrefix
+                  ({ DumpParsedAst.hs:8:21-24 }
+                   (HsTyVar
+                    (NotPromoted)
+                    ({ DumpParsedAst.hs:8:21-24 }
+                     (Unqual
+                      {OccName: Succ}))))))
+               ,({ DumpParsedAst.hs:8:26-36 }
+                 (HsAppPrefix
+                  ({ DumpParsedAst.hs:8:26-36 }
+                   (HsParTy
+                    ({ DumpParsedAst.hs:8:27-35 }
+                     (HsAppsTy
+                      [({ DumpParsedAst.hs:8:27-32 }
+                        (HsAppPrefix
+                         ({ DumpParsedAst.hs:8:27-32 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpParsedAst.hs:8:27-32 }
+                            (Unqual
+                             {OccName: Length}))))))
+                      ,({ DumpParsedAst.hs:8:34-35 }
+                        (HsAppPrefix
+                         ({ DumpParsedAst.hs:8:34-35 }
+                          (HsTyVar
+                           (NotPromoted)
+                           ({ DumpParsedAst.hs:8:34-35 }
+                            (Unqual
+                             {OccName: as}))))))]))))))])))
+            (PlaceHolder)))
          ,({ DumpParsedAst.hs:9:3-24 }
-           (TyFamEqn
-            ({ DumpParsedAst.hs:9:3-8 }
-             (Unqual
-              {OccName: Length}))
-            (HsIB
-             (PlaceHolder)
+           (HsIB
+            (PlaceHolder)
+            (FamEqn
+             ({ DumpParsedAst.hs:9:3-8 }
+              (Unqual
+               {OccName: Length}))
              [({ DumpParsedAst.hs:9:10-12 }
                (HsExplicitListTy
                 (Promoted)
                 (PlaceHolder)
                 []))]
-             (PlaceHolder))
-            (Prefix)
-            ({ DumpParsedAst.hs:9:21-24 }
-             (HsAppsTy
-              [({ DumpParsedAst.hs:9:21-24 }
-                (HsAppPrefix
-                 ({ DumpParsedAst.hs:9:21-24 }
-                  (HsTyVar
-                   (NotPromoted)
-                   ({ DumpParsedAst.hs:9:21-24 }
-                    (Unqual
-                     {OccName: Zero}))))))]))))]))
+             (Prefix)
+             ({ DumpParsedAst.hs:9:21-24 }
+              (HsAppsTy
+               [({ DumpParsedAst.hs:9:21-24 }
+                 (HsAppPrefix
+                  ({ DumpParsedAst.hs:9:21-24 }
+                   (HsTyVar
+                    (NotPromoted)
+                    ({ DumpParsedAst.hs:9:21-24 }
+                     (Unqual
+                      {OccName: Zero}))))))])))
+            (PlaceHolder)))]))
        ({ DumpParsedAst.hs:7:13-18 }
         (Unqual
          {OccName: Length}))
index e677fc5..6ea6e8f 100644 (file)
        (ClosedTypeFamily
         (Just
          [({ DumpRenamedAst.hs:8:3-36 }
-           (TyFamEqn
-            ({ DumpRenamedAst.hs:8:3-8 }
-             {Name: DumpRenamedAst.Length})
-            (HsIB
-             [{Name: a}
-             ,{Name: as}]
+           (HsIB
+            [{Name: a}
+            ,{Name: as}]
+            (FamEqn
+             ({ DumpRenamedAst.hs:8:3-8 }
+              {Name: DumpRenamedAst.Length})
              [({ DumpRenamedAst.hs:8:10-17 }
                (HsParTy
                 ({ DumpRenamedAst.hs:8:11-16 }
                     (NotPromoted)
                     ({ DumpRenamedAst.hs:8:15-16 }
                      {Name: as})))))))]
-             (True))
-            (Prefix)
-            ({ DumpRenamedAst.hs:8:21-36 }
-             (HsAppTy
-              ({ DumpRenamedAst.hs:8:21-24 }
-               (HsTyVar
-                (NotPromoted)
-                ({ DumpRenamedAst.hs:8:21-24 }
-                 {Name: DumpRenamedAst.Succ})))
-              ({ DumpRenamedAst.hs:8:26-36 }
-               (HsParTy
-                ({ DumpRenamedAst.hs:8:27-35 }
-                 (HsAppTy
-                  ({ DumpRenamedAst.hs:8:27-32 }
-                   (HsTyVar
-                    (NotPromoted)
-                    ({ DumpRenamedAst.hs:8:27-32 }
-                     {Name: DumpRenamedAst.Length})))
-                  ({ DumpRenamedAst.hs:8:34-35 }
-                   (HsTyVar
-                    (NotPromoted)
-                    ({ DumpRenamedAst.hs:8:34-35 }
-                     {Name: as})))))))))))
+             (Prefix)
+             ({ DumpRenamedAst.hs:8:21-36 }
+              (HsAppTy
+               ({ DumpRenamedAst.hs:8:21-24 }
+                (HsTyVar
+                 (NotPromoted)
+                 ({ DumpRenamedAst.hs:8:21-24 }
+                  {Name: DumpRenamedAst.Succ})))
+               ({ DumpRenamedAst.hs:8:26-36 }
+                (HsParTy
+                 ({ DumpRenamedAst.hs:8:27-35 }
+                  (HsAppTy
+                   ({ DumpRenamedAst.hs:8:27-32 }
+                    (HsTyVar
+                     (NotPromoted)
+                     ({ DumpRenamedAst.hs:8:27-32 }
+                      {Name: DumpRenamedAst.Length})))
+                   ({ DumpRenamedAst.hs:8:34-35 }
+                    (HsTyVar
+                     (NotPromoted)
+                     ({ DumpRenamedAst.hs:8:34-35 }
+                      {Name: as}))))))))))
+            (True)))
          ,({ DumpRenamedAst.hs:9:3-24 }
-           (TyFamEqn
-            ({ DumpRenamedAst.hs:9:3-8 }
-             {Name: DumpRenamedAst.Length})
-            (HsIB
-             []
+           (HsIB
+            []
+            (FamEqn
+             ({ DumpRenamedAst.hs:9:3-8 }
+              {Name: DumpRenamedAst.Length})
              [({ DumpRenamedAst.hs:9:10-12 }
                (HsExplicitListTy
                 (Promoted)
                 (PlaceHolder)
                 []))]
-             (True))
-            (Prefix)
-            ({ DumpRenamedAst.hs:9:21-24 }
-             (HsTyVar
-              (NotPromoted)
-              ({ DumpRenamedAst.hs:9:21-24 }
-               {Name: DumpRenamedAst.Zero})))))]))
+             (Prefix)
+             ({ DumpRenamedAst.hs:9:21-24 }
+              (HsTyVar
+               (NotPromoted)
+               ({ DumpRenamedAst.hs:9:21-24 }
+                {Name: DumpRenamedAst.Zero}))))
+            (True)))]))
        ({ DumpRenamedAst.hs:7:13-18 }
         {Name: DumpRenamedAst.Length})
        (HsQTvs
index 648410f..815d2de 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 648410f64b4a2423f2afe8afb6089b7749ebd4af
+Subproject commit 815d2deb9c0222c916becccf8464b740c26255fd