From 41365aeba8020d31391784bc1b9887007e78c306 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Fri, 24 May 2013 17:01:17 +0100 Subject: [PATCH] Checkpoint, working on RnSource.lhs to add renaming of type space specifier. --- compiler/hsSyn/HsDecls.lhs | 44 +++++++++++++++++++++++++----------- compiler/parser/Parser.y.pp | 10 ++++++-- compiler/parser/RdrHsSyn.lhs | 29 ++++++++++++++++-------- compiler/rename/RnSource.lhs | 44 ++++++++++++++++++++++++++++++++---- 4 files changed, 98 insertions(+), 29 deletions(-) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index ce391c73e248..e0ab8791883c 100644 --- 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 index 34c0bc6901d8..0541f214f0a4 100644 --- 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 index 3695daef5855..f3a0a9113f3e 100644 --- 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 index cc410388dffd..de42e75f5ee9 100644 --- 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