DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars,
- isClassDecl, isTFunDecl, isSynDecl, isTEqnDecl, isDataDecl,
+ isClassDecl, isTFunDecl, isSynDecl, isDataDecl, isKindSigDecl,
+ isIdxTyDecl,
countTyClDecls,
conDetailsTys,
instDeclATs,
import Util ( count )
import SrcLoc ( Located(..), unLoc, noLoc )
import FastString
+import Maybe ( isJust )
\end{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.
Simple classifiers
\begin{code}
-isTFunDecl, isDataDecl, isSynDecl, isTEqnDecl, isClassDecl ::
+isTFunDecl, isDataDecl, isSynDecl, isClassDecl, isKindSigDecl, isIdxTyDecl ::
TyClDecl name -> Bool
-- type function kind signature
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
("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),
= 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)
(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}
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' ->
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)
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)
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)
--
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
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}
projects / ghc-hetmet.git / commitdiff