So again we treat source code and interface file code slightly differently.
Source code:
- Source code instance decls have a Nothing in the (Maybe name) field
(see data InstDecl below)
- The typechecker makes up a Local name for the dict fun for any source-code
instance decl, whether it comes from a source-code instance decl, or whether
the instance decl is derived from some other construct (e.g. 'deriving').
- The occurrence name it chooses is derived from the instance decl (just for
documentation really) --- e.g. dNumInt. Two dict funs may share a common
occurrence name, but will have different uniques. E.g.
instance Foo [Int] where ...
instance Foo [Bool] where ...
These might both be dFooList
- The CoreTidy phase externalises the name, and ensures the occurrence name is
unique (this isn't special to dict funs). So we'd get dFooList and dFooList1.
- We can take this relaxed approach (changing the occurrence name later)
because dict fun Ids are not captured in a TyCon or Class (unlike default
methods, say). Instead, they are kept separately in the InstEnv. This
makes it easy to adjust them after compiling a module. (Once we've finished
compiling that module, they don't change any more.)
Interface file code:
- The instance decl gives the dict fun name, so the InstDecl has a (Just name)
in the (Maybe name) field.
- RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we
suck in the dfun binding
\begin{code}
type LTyClDecl name = Located (TyClDecl name)
data TyClDecl name
= ForeignType {
tcdLName :: Located name,
tcdExtName :: Maybe FastString
}
|
TyFamily { tcdFlavour:: FamilyFlavour,
tcdLName :: Located name,
tcdTyVars :: [LHsTyVarBndr name],
tcdKind :: Maybe Kind
}
|
TyData { tcdND :: NewOrData,
tcdCtxt :: LHsContext name,
tcdLName :: Located name,
tcdTyVars :: [LHsTyVarBndr name],
tcdTyPats :: Maybe [LHsType name],
tcdKindSig:: Maybe Kind,
tcdCons :: [LConDecl name],
tcdDerivs :: Maybe [LHsType name]
}
| TySynonym { tcdLName :: Located name,
tcdTyVars :: [LHsTyVarBndr name],
tcdTyPats :: Maybe [LHsType name],
tcdSynRhs :: LHsType name
}
| ClassDecl { tcdCtxt :: LHsContext name,
tcdLName :: Located name,
tcdTyVars :: [LHsTyVarBndr name],
tcdFDs :: [Located (FunDep name)],
tcdSigs :: [LSig name],
tcdMeths :: LHsBinds name,
tcdATs :: [LTyClDecl name],
tcdDocs :: [LDocDecl]
}
deriving (Data, Typeable)
data NewOrData
= NewType
| DataType
deriving( Eq, Data, Typeable )
data FamilyFlavour
= TypeFamily
| DataFamily
deriving (Data, Typeable)
\end{code}
Simple classifiers
\begin{code}
isDataDecl :: TyClDecl name -> Bool
isDataDecl (TyData {}) = True
isDataDecl _other = False
isTypeDecl :: TyClDecl name -> Bool
isTypeDecl (TySynonym {}) = True
isTypeDecl _other = False
isSynDecl :: TyClDecl name -> Bool
isSynDecl (TySynonym {tcdTyPats = Nothing}) = True
isSynDecl _other = False
isClassDecl :: TyClDecl name -> Bool
isClassDecl (ClassDecl {}) = True
isClassDecl _ = False
isFamilyDecl :: TyClDecl name -> Bool
isFamilyDecl (TyFamily {}) = True
isFamilyDecl _other = False
isFamInstDecl :: TyClDecl name -> Bool
isFamInstDecl tydecl
| isTypeDecl tydecl
|| isDataDecl tydecl = isJust (tcdTyPats tydecl)
| otherwise = False
\end{code}
Dealing with names
\begin{code}
tcdName :: TyClDecl name -> name
tcdName decl = unLoc (tcdLName decl)
tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
tyClDeclTyVars (TyFamily {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, Int, Int)
countTyClDecls decls
= (count isClassDecl decls,
count isSynDecl decls,
count isDataTy decls,
count isNewTy decls,
count isFamilyDecl decls,
count isFamInstDecl decls)
where
isDataTy TyData{tcdND = DataType, tcdTyPats = Nothing} = True
isDataTy _ = False
isNewTy TyData{tcdND = NewType, tcdTyPats = Nothing} = True
isNewTy _ = False
\end{code}
\begin{code}
instance OutputableBndr name
=> Outputable (TyClDecl name) where
ppr (ForeignType {tcdLName = ltycon})
= hsep [ptext (sLit "foreign import type dotnet"), ppr ltycon]
ppr (TyFamily {tcdFlavour = flavour, tcdLName = ltycon,
tcdTyVars = tyvars, tcdKind = mb_kind})
= pp_flavour <+> pp_decl_head [] ltycon tyvars Nothing <+> pp_kind
where
pp_flavour = case flavour of
TypeFamily -> ptext (sLit "type family")
DataFamily -> ptext (sLit "data family")
pp_kind = case mb_kind of
Nothing -> empty
Just kind -> dcolon <+> pprKind kind
ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdTyPats = typats,
tcdSynRhs = mono_ty})
= hang (ptext (sLit "type") <+>
(if isJust typats then ptext (sLit "instance") else empty) <+>
pp_decl_head [] ltycon tyvars typats <+>
equals)
4 (ppr mono_ty)
ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon,
tcdTyVars = tyvars, tcdTyPats = typats, tcdKindSig = mb_sig,
tcdCons = condecls, tcdDerivs = derivings})
= pp_tydecl (null condecls && isJust mb_sig)
(ppr new_or_data <+>
(if isJust typats then ptext (sLit "instance") else empty) <+>
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, tcdATs = ats})
| null sigs && null ats
= top_matter
| otherwise
= sep [hsep [top_matter, ptext (sLit "where {")],
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 Nothing
<+> pprFundeps (map unLoc fds)
ppr_semi :: Outputable a => a -> SDoc
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 Nothing
= hsep [pprHsContext context, ppr thing, interppSP tyvars]
pp_decl_head context thing _ (Just typats)
= hsep [ pprHsContext context, ppr thing
, hsep (map (pprParendHsType.unLoc) typats)]
pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc
pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ } : _)
= hang (ptext (sLit "where")) 2 (vcat (map ppr cs))
pp_condecls cs
= equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs))
pp_tydecl :: OutputableBndr name => Bool -> SDoc -> SDoc -> Maybe [LHsType name] -> SDoc
pp_tydecl True pp_head _ _
= pp_head
pp_tydecl False pp_head pp_decl_rhs derivings
= hang pp_head 4 (sep [
pp_decl_rhs,
case derivings of
Nothing -> empty
Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
])
instance Outputable NewOrData where
ppr NewType = ptext (sLit "newtype")
ppr DataType = ptext (sLit "data")
\end{code}
%************************************************************************
%* *
\subsection[ConDecl]{A data-constructor declaration}
%* *
%************************************************************************
\begin{code}
type LConDecl name = Located (ConDecl name)
data ConDecl name
= ConDecl
{ con_name :: Located name
, con_explicit :: HsExplicitFlag
, con_qvars :: [LHsTyVarBndr name]
, con_cxt :: LHsContext name
, con_details :: HsConDeclDetails name
, con_res :: ResType name
, con_doc :: Maybe LHsDocString
, con_old_rec :: Bool
} deriving (Data, Typeable)
type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map cd_fld_type flds
data ResType name
= ResTyH98
| ResTyGADT (LHsType name)
deriving (Data, Typeable)
instance OutputableBndr name => Outputable (ResType name) where
ppr ResTyH98 = ptext (sLit "ResTyH98")
ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
\end{code}
\begin{code}
instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = ResTyH98, con_doc = doc })
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
where
ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = PrefixCon arg_tys
, con_res = ResTyGADT res_ty })
= ppr con <+> dcolon <+>
sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)]
where
mk_fun_ty a b = noLoc (HsFunTy a b)
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = RecCon fields, con_res = ResTyGADT res_ty })
= sep [ppr con <+> dcolon <+> pprHsForAll expl tvs cxt,
pprConDeclFields fields <+> arrow <+> ppr res_ty]
pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyGADT {} })
= pprPanic "pprConDecl" (ppr con)
\end{code}
%************************************************************************
%* *
\subsection[InstDecl]{An instance declaration
%* *
%************************************************************************
\begin{code}
type LInstDecl name = Located (InstDecl name)
data InstDecl name
= InstDecl (LHsType name)
(LHsBinds name)
[LSig name]
[LTyClDecl name]
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (InstDecl name) where
ppr (InstDecl inst_ty binds uprags ats)
= vcat [hsep [ptext (sLit "instance"), ppr inst_ty, ptext (sLit "where")]
, nest 4 $ vcat (map ppr ats)
, nest 4 $ vcat (map ppr uprags)
, nest 4 $ pprLHsBinds binds ]
instDeclATs :: [LInstDecl name] -> [LTyClDecl name]
instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
\end{code}
%************************************************************************
%* *
\subsection[DerivDecl]{A stand-alone instance deriving declaration
%* *
%************************************************************************
\begin{code}
type LDerivDecl name = Located (DerivDecl name)
data DerivDecl name = DerivDecl (LHsType name)
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
ppr (DerivDecl ty)
= hsep [ptext (sLit "deriving instance"), ppr ty]
\end{code}
%************************************************************************
%* *
\subsection[DefaultDecl]{A @default@ declaration}
%* *
%************************************************************************
There can only be one default declaration per module, but it is hard
for the parser to check that; we pass them all through in the abstract
syntax, and that restriction must be checked in the front end.
\begin{code}
type LDefaultDecl name = Located (DefaultDecl name)
data DefaultDecl name
= DefaultDecl [LHsType name]
deriving (Data, Typeable)
instance (OutputableBndr name)
=> Outputable (DefaultDecl name) where
ppr (DefaultDecl tys)
= ptext (sLit "default") <+> parens (interpp'SP tys)
\end{code}
%************************************************************************
%* *
\subsection{Foreign function interface declaration}
%* *
%************************************************************************
\begin{code}
type LForeignDecl name = Located (ForeignDecl name)
data ForeignDecl name
= ForeignImport (Located name) (LHsType name) ForeignImport
| ForeignExport (Located name) (LHsType name) ForeignExport
deriving (Data, Typeable)
data ForeignImport =
CImport CCallConv
Safety
FastString
CImportSpec
deriving (Data, Typeable)
data CImportSpec = CLabel CLabelString
| CFunction CCallTarget
| CWrapper
deriving (Data, Typeable)
data ForeignExport = CExport CExportSpec
deriving (Data, Typeable)
instance OutputableBndr name => Outputable (ForeignDecl name) where
ppr (ForeignImport n ty fimport) =
hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n)
2 (dcolon <+> ppr ty)
ppr (ForeignExport n ty fexport) =
hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n)
2 (dcolon <+> ppr ty)
instance Outputable ForeignImport where
ppr (CImport cconv safety header spec) =
ppr cconv <+> ppr safety <+>
char '"' <> pprCEntity spec <> char '"'
where
pp_hdr = if nullFS header then empty else ftext header
pprCEntity (CLabel lbl) =
ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
pprCEntity (CFunction (StaticTarget lbl _)) =
ptext (sLit "static") <+> pp_hdr <+> ppr lbl
pprCEntity (CFunction (DynamicTarget)) =
ptext (sLit "dynamic")
pprCEntity (CWrapper) = ptext (sLit "wrapper")
instance Outputable ForeignExport where
ppr (CExport (CExportStatic lbl cconv)) =
ppr cconv <+> char '"' <> ppr lbl <> char '"'
\end{code}
%************************************************************************
%* *
\subsection{Transformation rules}
%* *
%************************************************************************
\begin{code}
type LRuleDecl name = Located (RuleDecl name)
data RuleDecl name
= HsRule
RuleName
Activation
[RuleBndr name]
(Located (HsExpr name))
NameSet
(Located (HsExpr name))
NameSet
deriving (Data, Typeable)
data RuleBndr name
= RuleBndr (Located name)
| RuleBndrSig (Located name) (LHsType name)
deriving (Data, Typeable)
collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
instance OutputableBndr name => Outputable (RuleDecl name) where
ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs)
= sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act,
nest 4 (pp_forall <+> pprExpr (unLoc lhs)),
nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ]
where
pp_forall | null ns = empty
| otherwise = text "forall" <+> fsep (map ppr ns) <> dot
instance OutputableBndr name => Outputable (RuleBndr name) where
ppr (RuleBndr name) = ppr name
ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
\end{code}
%************************************************************************
%* *
\subsection[DocDecl]{Document comments}
%* *
%************************************************************************
\begin{code}
type LDocDecl = Located (DocDecl)
data DocDecl
= DocCommentNext HsDocString
| DocCommentPrev HsDocString
| DocCommentNamed String HsDocString
| DocGroup Int HsDocString
deriving (Data, Typeable)
instance Outputable DocDecl where
ppr _ = text "<document comment>"
docDeclDoc :: DocDecl -> HsDocString
docDeclDoc (DocCommentNext d) = d
docDeclDoc (DocCommentPrev d) = d
docDeclDoc (DocCommentNamed _ d) = d
docDeclDoc (DocGroup _ d) = d
\end{code}
%************************************************************************
%* *
\subsection[DeprecDecl]{Deprecations}
%* *
%************************************************************************
We use exported entities for things to deprecate.
\begin{code}
type LWarnDecl name = Located (WarnDecl name)
data WarnDecl name = Warning name WarningTxt
deriving (Data, Typeable)
instance OutputableBndr name => Outputable (WarnDecl name) where
ppr (Warning thing txt)
= hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
\end{code}
%************************************************************************
%* *
\subsection[AnnDecl]{Annotations}
%* *
%************************************************************************
\begin{code}
type LAnnDecl name = Located (AnnDecl name)
data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (AnnDecl name) where
ppr (HsAnnotation provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
data AnnProvenance name = ValueAnnProvenance name
| TypeAnnProvenance name
| ModuleAnnProvenance
deriving (Data, Typeable)
annProvenanceName_maybe :: AnnProvenance name -> Maybe name
annProvenanceName_maybe (ValueAnnProvenance name) = Just name
annProvenanceName_maybe (TypeAnnProvenance name) = Just name
annProvenanceName_maybe ModuleAnnProvenance = Nothing
modifyAnnProvenanceNameM :: Monad m => (before -> m after) -> AnnProvenance before -> m (AnnProvenance after)
modifyAnnProvenanceNameM fm prov =
case prov of
ValueAnnProvenance name -> liftM ValueAnnProvenance (fm name)
TypeAnnProvenance name -> liftM TypeAnnProvenance (fm name)
ModuleAnnProvenance -> return ModuleAnnProvenance
pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module")
pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
pprAnnProvenance (TypeAnnProvenance name) = ptext (sLit "ANN type") <+> ppr name
\end{code}