Commit 82c4d36b authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Renaming of indexed types

Tue Aug  1 23:51:38 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Renaming of indexed types
parent b6eb00d1
......@@ -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
......
......@@ -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}
......
......@@ -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}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment