From 82c4d36b187955e3cedbb11cff92688747773456 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Fri, 15 Sep 2006 21:01:06 +0000 Subject: [PATCH] Renaming of indexed types Tue Aug 1 23:51:38 EDT 2006 Manuel M T Chakravarty * Renaming of indexed types --- compiler/hsSyn/HsDecls.lhs | 42 +++++++++++----- compiler/main/HscStats.lhs | 19 ++++++-- compiler/rename/RnSource.lhs | 110 ++++++++++++++++++++++-------------------- 3 files changed, 104 insertions(+), 67 deletions(-) diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 90479ab..54075d4 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -18,7 +18,8 @@ module HsDecls ( DeprecDecl(..), LDeprecDecl, HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, tcdName, tyClDeclNames, tyClDeclTyVars, - isClassDecl, isTFunDecl, isSynDecl, isTEqnDecl, isDataDecl, + isClassDecl, isTFunDecl, isSynDecl, isDataDecl, isKindSigDecl, + isIdxTyDecl, countTyClDecls, conDetailsTys, instDeclATs, @@ -52,6 +53,7 @@ import Outputable import Util ( count ) import SrcLoc ( Located(..), unLoc, noLoc ) import FastString +import Maybe ( isJust ) \end{code} @@ -329,21 +331,28 @@ Interface file code: -- for a module. That's why (despite the misnomer) IfaceSig and ForeignType -- are both in TyClDecl --- Representation of type functions and associated data types & synonyms --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- 'TyData' and 'TySynonym' have a field 'tcdPats::Maybe [LHsType name]', with --- the following meaning: +-- Representation of indexed types +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Kind signatures of indexed types come in two flavours: +-- +-- * kind signatures for type functions: variant `TyFunction' and +-- +-- * kind signatures for indexed data types and newtypes : variant `TyData' +-- iff a kind is present in `tcdKindSig' and there are no constructors in +-- `tcdCons'. +-- +-- Indexed types are represented by 'TyData' and 'TySynonym' using the field +-- 'tcdTyPats::Maybe [LHsType name]', with the following meaning: -- -- * If it is 'Nothing', we have a *vanilla* data type declaration or type -- synonym declaration and 'tcdVars' contains the type parameters of the -- type constructor. -- --- * If it is 'Just pats', we have the definition of an associated data type --- or a type function equations (toplevel or nested in an instance --- declarations). Then, 'pats' are type patterns for the type-indexes of --- the type constructor and 'tcdVars' are the variables in those --- patterns. Hence, the arity of the type constructor is 'length tcdPats' --- and *not* 'length tcdVars'. +-- * If it is 'Just pats', we have the definition of an indexed type Then, +-- 'pats' are type patterns for the type-indexes of the type constructor +-- and 'tcdVars' are the variables in those patterns. Hence, the arity of +-- the indexed type (ie, the number of indexes) is 'length tcdTyPats' and +-- *not* 'length tcdVars'. -- -- In both cases, 'tcdVars' collects all variables we need to quantify over. @@ -414,7 +423,7 @@ data NewOrData Simple classifiers \begin{code} -isTFunDecl, isDataDecl, isSynDecl, isTEqnDecl, isClassDecl :: +isTFunDecl, isDataDecl, isSynDecl, isClassDecl, isKindSigDecl, isIdxTyDecl :: TyClDecl name -> Bool -- type function kind signature @@ -434,6 +443,15 @@ isDataDecl other = False isClassDecl (ClassDecl {}) = True isClassDecl other = False + +-- kind signature (for an indexed type) +isKindSigDecl (TyFunction {} ) = True +isKindSigDecl (TyData {tcdKindSig = Just _, + tcdCons = [] }) = True +isKindSigDecl other = False + +-- definition of an instance of an indexed type +isIdxTyDecl = isJust . tcdTyPats \end{code} Dealing with names diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs index a750ad8..5ceef37 100644 --- a/compiler/main/HscStats.lhs +++ b/compiler/main/HscStats.lhs @@ -49,6 +49,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) ("DefaultMethods ", default_method_ds), ("InstDecls ", inst_ds), ("InstMethods ", inst_method_ds), + ("InstType ", inst_type_ds), + ("InstData ", inst_data_ds), ("TypeSigs ", bind_tys), ("ValBinds ", val_bind_ds), ("FunBinds ", fn_bind_ds), @@ -99,8 +101,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) = foldr add2 (0,0) (map data_info tycl_decls) (class_method_ds, default_method_ds) = foldr add2 (0,0) (map class_info tycl_decls) - (inst_method_ds, method_specs, method_inlines) - = foldr add3 (0,0,0) (map inst_info inst_decls) + (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds) + = foldr add5 (0,0,0,0,0) (map inst_info inst_decls) count_bind (PatBind { pat_lhs = L _ (VarPat n) }) = (1,0) count_bind (PatBind {}) = (0,1) @@ -135,21 +137,30 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info other = (0,0) - inst_info (InstDecl _ inst_meths inst_sigs _) -- !!!TODO: ATs info -=chak + inst_info (InstDecl _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of (_,_,ss,is) -> - (addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is) + case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of + (tyDecl, dtDecl) -> + (addpr (foldr add2 (0,0) + (map (count_bind.unLoc) (bagToList inst_meths))), + ss, is, tyDecl, dtDecl) + where + countATDecl (TyData {}) = (0, 1) + countATDecl (TySynonym {}) = (1, 0) addpr :: (Int,Int) -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) add3 :: (Int,Int,Int) -> (Int,Int,Int) -> (Int, Int, Int) add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int) + add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int) addpr (x,y) = x+y add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3) add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4) + add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6) \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 842f2b2..9a92f84 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -491,10 +491,13 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_ returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name}, emptyFVs) -rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, - tcdTyVars = tyvars, tcdTyPats = typatsMaybe, - tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs}) - | is_vanilla -- Normal Haskell data type decl +rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, + tcdLName = tycon, tcdTyVars = tyvars, + tcdTyPats = typatsMaybe, tcdCons = condecls, + tcdKindSig = sig, tcdDerivs = derivs}) + | isKindSigDecl tydecl -- kind signature of indexed type + = rnTySig tydecl bindTyVarsRn + | is_vanilla -- Normal Haskell data type decl = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the -- data type is syntactically illegal bindTyVarsRn data_doc tyvars $ \ tyvars' -> @@ -513,7 +516,7 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } - | otherwise -- GADT + | otherwise -- GADT = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now do { tycon' <- lookupLocatedTopBndrRn tycon ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) @@ -549,14 +552,19 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, rn_derivs Nothing = returnM (Nothing, emptyFVs) rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> returnM (Just ds', extractHsTyNames_s ds') - -rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty}) - = lookupLocatedTopBndrRn name `thenM` \ name' -> - bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) -> - returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', - tcdSynRhs = ty'}, - delFVs (map hsLTyVarName tyvars') fvs) + +rnTyClDecl (tydecl@TyFunction {}) = + rnTySig tydecl bindTyVarsRn + +rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, + tcdTyPats = typatsMaybe, tcdSynRhs = ty}) + = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> + do { name' <- lookupLocatedTopBndrRn name + ; typats' <- rnTyPats syn_doc typatsMaybe + ; (ty', fvs) <- rnHsTypeFVs syn_doc ty + ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', + tcdTyPats = typats', tcdSynRhs = ty'}, + delFVs (map hsLTyVarName tyvars') fvs) } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -712,43 +720,6 @@ rnField doc (name, ty) rnLHsType doc ty `thenM` \ new_ty -> returnM (new_name, new_ty) --- This data decl will parse OK --- data T = a Int --- treating "a" as the constructor. --- It is really hard to make the parser spot this malformation. --- So the renamer has to check that the constructor is legal --- --- We can get an operator as the constructor, even in the prefix form: --- data T = :% Int Int --- from interface files, which always print in prefix form - -checkConName name = checkErr (isRdrDataCon name) (badDataCon name) - -badDataCon name - = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] -\end{code} - - -%********************************************************* -%* * -\subsection{Support code to rename types} -%* * -%********************************************************* - -\begin{code} -rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] - -rnFds doc fds - = mappM (wrapLocM rn_fds) fds - where - rn_fds (tys1, tys2) - = rnHsTyVars doc tys1 `thenM` \ tys1' -> - rnHsTyVars doc tys2 `thenM` \ tys2' -> - returnM (tys1', tys2') - -rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs -rnHsTyvar doc tyvar = lookupOccRn tyvar - -- Rename kind signatures (signatures of indexed data types/newtypes and -- signatures of type functions) -- @@ -806,7 +777,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats where rn_at (tydecl@TyData {}) = rnTySig tydecl lookupIdxVars rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars - rn_at (tydelc@TySynonym {}) = panic "!!!TODO: case not impl yet" + rn_at (tydecl@TySynonym {}) = rnTyClDecl tydecl rn_at _ = panic "RnSource.rnATs: invalid TyClDecl" lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont @@ -817,6 +788,43 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats do name' <- lookupOccRn (hsTyVarName tyvar) return $ L l (replaceTyVarName tyvar name') + +-- This data decl will parse OK +-- data T = a Int +-- treating "a" as the constructor. +-- It is really hard to make the parser spot this malformation. +-- So the renamer has to check that the constructor is legal +-- +-- We can get an operator as the constructor, even in the prefix form: +-- data T = :% Int Int +-- from interface files, which always print in prefix form + +checkConName name = checkErr (isRdrDataCon name) (badDataCon name) + +badDataCon name + = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] +\end{code} + + +%********************************************************* +%* * +\subsection{Support code to rename types} +%* * +%********************************************************* + +\begin{code} +rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] + +rnFds doc fds + = mappM (wrapLocM rn_fds) fds + where + rn_fds (tys1, tys2) + = rnHsTyVars doc tys1 `thenM` \ tys1' -> + rnHsTyVars doc tys2 `thenM` \ tys2' -> + returnM (tys1', tys2') + +rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs +rnHsTyvar doc tyvar = lookupOccRn tyvar \end{code} -- 1.7.10.4