Checkpoint, working on RnSource.lhs to add renaming of type space spe…

…cifier.
ghc · May 24, 2013 · 41365ae · 41365ae
1 parent 3e7a681
commit 41365ae
Show file tree

Hide file tree

Showing 4 changed files with 98 additions and 29 deletions.
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
@@ -528,7 +528,10 @@ tyFamInstDeclName = unLoc . tyFamInstDeclLName
 
 tyFamInstDeclLName :: OutputableBndr name
                    => TyFamInstDecl name -> Located name
-tyFamInstDeclLName (TyFamInstDecl { tfid_eqns =
+tyFamInstDeclLName (TyFamInstSingle { tfid_eqn =
+                                      L _ (TyFamInstEqn { tfie_tycon = ln })})
+  = ln
+tyFamInstDeclLName (TyFamInstBranched { tfid_eqns =
                      (L _ (TyFamInstEqn { tfie_tycon = ln })) : _ })
   -- there may be more than one equation, but grab the name from the first
   = ln
@@ -851,12 +854,25 @@ data TyFamInstEqn name
        , tfie_rhs   :: LHsType name }         
   deriving( Typeable, Data )
 
+type LTyFamInstSpace name = Located (TyFamInstSpace name)
+-- | The type space a branched instance lies in
+data TyFamInstSpace name
+  = TyFamInstSpace
+      { tfis_tycon :: Located name
+      , tfis_pats  :: HsWithBndrs [LHsType name]
+      }
+
 type LTyFamInstDecl name = Located (TyFamInstDecl name)
 data TyFamInstDecl name 
-  = TyFamInstDecl
-       { tfid_eqns  :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns 
-                                            -- Always non-empty
-       , tfid_group :: Bool                 -- Was this declared with the "where" syntax?
+  = TyFamInstSingle
+       { tfid_eqn   :: LTyFamInstEqn name
+       , tfid_fvs   :: NameSet
+       }
+  | TyFamInstBranched
+       { tfid_eqns  :: [LTyFamInstEqn name]    -- ^ list of (possibly-overlapping) eqns 
+                                               -- Always non-empty
+       , tfid_space :: Maybe LTyFamInstSpace  -- ^ The (optional) region of the type
+                                              -- space this group sits in.
        , tfid_fvs   :: NameSet }            -- The group is type-checked as one,
                                             --   so one NameSet will do
        -- INVARIANT: tfid_group == False --> length tfid_eqns == 1
@@ -927,22 +943,24 @@ tvs are fv(pat_tys), *including* ones that are already in scope
 
 Note [Family instance equation groups]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A TyFamInstDecl contains a list of FamInstEqn's, one for each
-equation defined in the instance group. For a standalone
-instance declaration, this list contains exactly one element.
-It is not possible for this list to have 0 elements --
-'type instance where' without anything else is not allowed.
+A TyFamInstBranched contains a list of FamInstEqn's, one for each equation
+defined in the branched instance. It is not possible for this list to have 0
+elements -- 'type instance where' without anything else is not allowed.
 
 \begin{code}
 instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
   ppr = pprTyFamInstDecl TopLevel
 
 pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name -> SDoc
-pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_group = False, tfid_eqns = [eqn] })
+pprTyFamInstDecl top_lvl (TyFamInstSingle { tfid_eqn = eqn })
    = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn)
-pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqns = eqns })
-   = hang (ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ptext (sLit "where"))
+pprTyFamInstDecl top_lvl (TyFamInstBranched { tfid_eqns = eqns, tfid_space = space })
+   = hang (ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+>
+           ppr_type_space space <+> ptext (sLit "where"))
         2 (vcat (map ppr eqns))
+   where
+     ppr_type_space Nothing  = empty
+     ppr_type_space (Just s) = ppr s
 
 ppr_instance_keyword :: TopLevelFlag -> SDoc
 ppr_instance_keyword TopLevel    = ptext (sLit "instance")

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
@@ -676,8 +676,10 @@
                 {% do { L loc tfi <- mkTyFamInst (comb2 $1 $3) $3
                       ; return (L loc (TyFamInstD { tfid_inst = tfi })) } }
 
-        | 'type' 'instance' 'where' ty_fam_inst_eqn_list
-                { LL (TyFamInstD { tfid_inst = mkTyFamInstGroup (unLoc $4) }) }
+        | 'type' 'instance' maybe_type_space 'where' ty_fam_inst_eqn_list
+                {% do { L loc tfi <- mkTyFamInstGroup (comb2 $1 $5)
+                                       (unLoc $3) (unLoc $5)
+                      ; return (L loc (TyFamInstD ( tfid_inst = tfi })) } }
 
           -- data/newtype instance declaration
         | data_or_newtype 'instance' tycl_hdr constrs deriving
@@ -695,6 +697,10 @@
 
 -- Type instance groups
 
+maybe_type_space :: { Located (Maybe (LHsType RdrName)) }
+        :                { noLoc Nothing }
+        | type           { LL (Just $1) }
+
 ty_fam_inst_eqn_list :: { Located [LTyFamInstEqn RdrName] }
         :     '{' ty_fam_inst_eqns '}'     { LL (unLoc $2) }
         | vocurly ty_fam_inst_eqns close   { $2 }

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
@@ -192,15 +192,26 @@ mkTyFamInst :: SrcSpan
             -> LTyFamInstEqn RdrName
             -> P (LTyFamInstDecl RdrName)
 mkTyFamInst loc eqn
-  = return (L loc (TyFamInstDecl { tfid_eqns  = [eqn]
-                                 , tfid_group = False
-                                 , tfid_fvs   = placeHolderNames }))
-
-mkTyFamInstGroup :: [LTyFamInstEqn RdrName]
-                 -> TyFamInstDecl RdrName
-mkTyFamInstGroup eqns = TyFamInstDecl { tfid_eqns  = eqns
-                                      , tfid_group = True
-                                      , tfid_fvs   = placeHolderNames }
+  = return (L loc (TyFamInstSingle { tfid_eqn  = [eqn]
+                                   , tfid_fvs   = placeHolderNames }))
+
+mkTyFamInstGroup :: SrcSpan
+                 -> Maybe (LHsType RdrName)
+                 -> [LTyFamInstEqn RdrName]
+                 -> P TyFamInstDecl RdrName
+mkTyFamInstGroup loc mspace eqns
+  = do { mspace' <- mkTyFamInstSpace mspace
+       ; return $ L loc (TyFamInstBranched { tfid_eqns  = eqns
+                                           , tfid_space = mspace'
+                                           , tfid_fvs   = placeHolderNames }) }
+
+mkTyFamInstSpace :: Maybe (LHsType RdrName)
+                 -> P (Maybe (LTyFamInstSpace RdrName))
+mkTyFamInstSpace Nothing = return Nothing
+mkTyFamInstSpace (Just ty)
+  = do { (tycon, pats) <- checkTyClHdr ty
+       ; return (TyFamInstSpace { tfis_tycon = tycon
+                                , tfis_pats  = mkHsWithBndrs pats }) }
 
 mkFamDecl :: SrcSpan
           -> FamilyFlavour

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
@@ -495,6 +495,29 @@ 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).
 
+rnFamInstLHS :: HsDocContext
+             -> Maybe (Name, [Name])
+             -> Located RdrName
+             -> [LHsType RdrName]
+             -> RnM (???)
+rnFamInstLHS doc mb_cls tycon pats
+  = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
+       ; let loc = case pats of
+                     []             -> pprPanic "rnFamInstDecl" (ppr tycon)
+                     (L loc _ : []) -> loc
+                     (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
+             (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
+
+
+       ; rdr_env  <- getLocalRdrEnv
+       ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
+       ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
+             -- All the free vars of the family patterns
+             -- with a sensible binding location
+       ; (pats', fvs) <- bindLocalNamesFV kv_names $ 
+                         bindLocalNamesFV tv_names $ 
+                         rnLHsTypes doc pats
+
 rnFamInstDecl :: HsDocContext
               -> Maybe (Name, [Name])
               -> Located RdrName
@@ -542,11 +565,22 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload
 rnTyFamInstDecl :: Maybe (Name, [Name])
                 -> TyFamInstDecl RdrName
                 -> RnM (TyFamInstDecl Name, FreeVars)
-rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqns = eqns, tfid_group = group })
-  = do { (eqns', fvs) <- rnList (rnTyFamInstEqn mb_cls) eqns
-       ; return (TyFamInstDecl { tfid_eqns = eqns'
-                               , tfid_group = group
-                               , tfid_fvs = fvs }, fvs) }
+rnTyFamInstDecl mb_cls (TyFamInstSingle { tfid_eqn = eqn })
+  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls) eqn
+       ; return (TyFamInstSingle { tfid_eqn = eqn'
+                                 , tfid_fvs = fvs }, fvs)
+rnTyFamInstDecl Nothing (TyFamInstBranched { tfid_eqns = eqns, tfid_space = mspace })
+  = do { (eqns', fvs1) <- rnList (rnTyFamInstEqn Nothing) eqns
+       ; (space', fvs2) <- rn_space mspace
+       ; let fvs = fvs1 `plusFVs` fvs2
+       ; return (TyFamInstBranched { tfid_eqns  = eqns'
+                                   , tfid_space = space'
+                                   , tfid_fvs   = fvs }, fvs) }
+  where rn_space Nothing  = (Nothing, emptyFVs)
+        rn_space (Just (TyFamInstSpace { tfis_tycon = tycon
+                                       , tfis_pats  = pats }))
+          = do { tycon' <- lookupFamInstName Nothing tycon
+               ; let loc
 
 rnTyFamInstEqn :: Maybe (Name, [Name])
                -> TyFamInstEqn RdrName