DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
tcdName, tyClDeclNames, tyClDeclTyVars,
- isClassDecl, isSynDecl, isDataDecl,
+ isClassDecl, isTFunDecl, isSynDecl, isTEqnDecl, isDataDecl,
countTyClDecls,
conDetailsTys,
+ instDeclATs,
collectRuleBndrSigTys,
) where
-- 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:
+--
+-- * 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'.
+--
+-- In both cases, 'tcdVars' collects all variables we need to quantify over.
+
type LTyClDecl name = Located (TyClDecl name)
data TyClDecl name
tcdCtxt :: LHsContext name, -- Context
tcdLName :: Located name, -- Type constructor
tcdTyVars :: [LHsTyVarBndr name], -- Type variables
- tcdKindSig :: Maybe Kind, -- Optional kind sig;
+ tcdTyPats :: Maybe [LHsType name], -- Type patterns
+ tcdKindSig:: Maybe Kind, -- Optional kind sig;
-- (only for the 'where' form)
tcdCons :: [LConDecl name], -- Data constructors
-- are non-empty for the newtype-deriving case
}
+ | TyFunction {tcdLName :: Located name, -- type constructor
+ tcdTyVars :: [LHsTyVarBndr name], -- type variables
+ tcdIso :: Bool, -- injective type?
+ tcdKindSig:: Maybe Kind -- result kind
+ }
+
| TySynonym { tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables
+ tcdTyPats :: Maybe [LHsType name], -- Type patterns
+ -- 'Nothing' => vanilla
+ -- type synonym
tcdSynRhs :: LHsType name -- synonym expansion
}
tcdTyVars :: [LHsTyVarBndr name], -- Class type variables
tcdFDs :: [Located (FunDep name)], -- Functional deps
tcdSigs :: [LSig name], -- Methods' signatures
- tcdMeths :: LHsBinds name -- Default methods
+ tcdMeths :: LHsBinds name, -- Default methods
+ tcdATs :: [LTyClDecl name] -- Associated types; ie
+ -- only 'TyData',
+ -- 'TyFunction',
+ -- and 'TySynonym'
}
data NewOrData
Simple classifiers
\begin{code}
-isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool
+isTFunDecl, isDataDecl, isSynDecl, isTEqnDecl, isClassDecl ::
+ TyClDecl name -> Bool
+
+-- type function kind signature
+isTFunDecl (TyFunction {}) = True
+isTFunDecl other = False
+
+-- vanilla Haskell type synonym
+isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
+isSynDecl other = False
-isSynDecl (TySynonym {}) = True
-isSynDecl other = False
+-- type equation (of a type function)
+isTEqnDecl (TySynonym {tcdTyPats = Just _}) = True
+isTEqnDecl other = False
isDataDecl (TyData {}) = True
isDataDecl other = False
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names
-tyClDeclNames (TySynonym {tcdLName = name}) = [name]
-tyClDeclNames (ForeignType {tcdLName = name}) = [name]
+tyClDeclNames (TyFunction {tcdLName = name}) = [name]
+tyClDeclNames (TySynonym {tcdLName = name,
+ tcdTyPats= Nothing}) = [name]
+tyClDeclNames (TySynonym {} ) = [] -- type equation
+tyClDeclNames (ForeignType {tcdLName = name}) = [name]
-tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs})
- = cls_name : [n | L _ (TypeSig n _) <- sigs]
+tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
+ = cls_name :
+ concatMap (tyClDeclNames . unLoc) ats ++ [n | L _ (TypeSig n _) <- sigs]
tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
= tc_name : conDeclsNames (map unLoc cons)
-tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
-tyClDeclTyVars (ForeignType {}) = []
+tyClDeclTyVars (TyFunction {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
+tyClDeclTyVars (ForeignType {}) = []
\end{code}
\begin{code}
-countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int)
- -- class, data, newtype, synonym decls
+countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int, Int)
+ -- class, synonym decls, type function signatures,
+ -- type function equations, data, newtype
countTyClDecls decls
= (count isClassDecl decls,
count isSynDecl decls,
+ count isTFunDecl decls,
+ count isTEqnDecl decls,
count isDataTy decls,
count isNewTy decls)
where
ppr (ForeignType {tcdLName = ltycon})
= hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon]
- ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
- = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars <+> equals)
+ ppr (TyFunction {tcdLName = ltycon, tcdTyVars = tyvars, tcdIso = iso,
+ tcdKindSig = mb_sig})
+ = typeMaybeIso <+> pp_decl_head [] ltycon tyvars Nothing <+>
+ ppr_sig mb_sig
+ where
+ typeMaybeIso = if iso
+ then ptext SLIT("type iso")
+ else ptext SLIT("type")
+
+ ppr_sig Nothing = empty
+ ppr_sig (Just kind) = dcolon <+> pprKind kind
+
+ ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
+ tcdSynRhs = mono_ty})
+ = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars typats <+>
+ equals)
4 (ppr mono_ty)
ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
- tcdTyVars = tyvars, tcdKindSig = mb_sig, tcdCons = condecls,
- tcdDerivs = derivings})
- = pp_tydecl (ppr new_or_data <+> pp_decl_head (unLoc context) ltycon tyvars <+> ppr_sig mb_sig)
+ tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig,
+ tcdCons = condecls, tcdDerivs = derivings})
+ = pp_tydecl (ppr new_or_data <+>
+ pp_decl_head (unLoc context) ltycon tyvars typats <+>
+ ppr_sig mb_sig)
(pp_condecls condecls)
derivings
where
ppr_sig Nothing = empty
ppr_sig (Just kind) = dcolon <+> pprKind kind
- ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds,
- tcdSigs = sigs, tcdMeths = methods})
- | null sigs -- No "where" part
+ ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
+ tcdFDs = fds,
+ tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
+ | null sigs && null ats -- No "where" part
= top_matter
| otherwise -- Laid out
= sep [hsep [top_matter, ptext SLIT("where {")],
- nest 4 (sep [sep (map ppr_sig sigs), pprLHsBinds methods, char '}'])]
+ nest 4 (sep [ sep (map ppr_semi ats)
+ , sep (map ppr_semi sigs)
+ , pprLHsBinds methods
+ , char '}'])]
where
- top_matter = ptext SLIT("class") <+> pp_decl_head (unLoc context) lclas tyvars <+> pprFundeps (map unLoc fds)
- ppr_sig sig = ppr sig <> semi
+ top_matter = ptext SLIT("class")
+ <+> pp_decl_head (unLoc context) lclas tyvars Nothing
+ <+> pprFundeps (map unLoc fds)
+ ppr_semi decl = ppr decl <> semi
pp_decl_head :: OutputableBndr name
=> HsContext name
-> Located name
-> [LHsTyVarBndr name]
+ -> Maybe [LHsType name]
-> SDoc
-pp_decl_head context thing tyvars
+pp_decl_head context thing tyvars Nothing -- no explicit type patterns
= hsep [pprHsContext context, ppr thing, interppSP tyvars]
+pp_decl_head context thing _ (Just typats) -- explicit type patterns
+ = hsep [ pprHsContext context, ppr thing
+ , hsep (map (pprParendHsType.unLoc) typats)]
+
pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _) -- In GADT syntax
= hang (ptext SLIT("where")) 2 (vcat (map ppr cs))
pp_condecls cs -- In H98 syntax
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
(LHsBinds name)
- [LSig name] -- User-supplied pragmatic info
+ [LSig name] -- User-supplied pragmatic info
+ [LTyClDecl name]-- Associated types (ie, 'TyData' and
+ -- 'TySynonym' only)
instance (OutputableBndr name) => Outputable (InstDecl name) where
- ppr (InstDecl inst_ty binds uprags)
+ ppr (InstDecl inst_ty binds uprags ats)
= vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
+ nest 4 (ppr ats),
nest 4 (ppr uprags),
nest 4 (pprLHsBinds binds) ]
+
+-- Extract the declarations of associated types from an instance
+--
+instDeclATs :: InstDecl name -> [LTyClDecl name]
+instDeclATs (InstDecl _ _ _ ats) = ats
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff