SpliceDecl(..),
-- ** Foreign function interface declarations
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
- CImportSpec(..), FoType(..),
+ CImportSpec(..),
-- ** Data-constructor declarations
- ConDecl(..), LConDecl, ResType(..), ConDeclField(..),
- HsConDeclDetails, hsConDeclArgTys,
+ ConDecl(..), LConDecl, ResType(..),
+ HsConDeclDetails, hsConDeclArgTys, hsConDeclsNames,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
| AnnD (AnnDecl id)
| RuleD (RuleDecl id)
| SpliceD (SpliceDecl id)
- | DocD (DocDecl id)
+ | DocD (DocDecl)
-- NB: all top-level fixity decls are contained EITHER
hs_annds :: [LAnnDecl id],
hs_ruleds :: [LRuleDecl id],
- hs_docs :: [LDocDecl id]
+ hs_docs :: [LDocDecl]
}
emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a
ppr_ds foreign_decls]
where
ppr_ds [] = empty
- ppr_ds ds = text "" $$ vcat (map ppr ds)
+ ppr_ds ds = blankLine $$ vcat (map ppr ds)
data SpliceDecl id = SpliceDecl (Located (HsExpr id)) -- Top level splice
data TyClDecl name
= ForeignType {
tcdLName :: Located name,
- tcdExtName :: Maybe FastString,
- tcdFoType :: FoType
+ tcdExtName :: Maybe FastString
}
-- only 'TyFamily' and
-- 'TySynonym'; the
-- latter for defaults
- tcdDocs :: [LDocDecl name] -- ^ Haddock docs
+ tcdDocs :: [LDocDecl] -- ^ Haddock docs
}
data NewOrData
concatMap (tyClDeclNames . unLoc) ats ++ [n | L _ (TypeSig n _) <- sigs]
tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
- = tc_name : conDeclsNames (map unLoc cons)
+ = tc_name : hsConDeclsNames cons
tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
tyClDeclTyVars (TyFamily {tcdTyVars = tvs}) = tvs
-- ^ Type variables. Depending on 'con_res' this describes the
-- follewing entities
--
- -- - ResTyH98: the constructor's existential type variables
- --
- -- - ResTyGADT: all the constructor's quantified type variables
+ -- - ResTyH98: the constructor's *existential* type variables
+ -- - ResTyGADT: *all* the constructor's quantified type variables
, con_cxt :: LHsContext name
-- ^ The context. This /does not/ include the \"stupid theta\" which
, con_res :: ResType name
-- ^ Result type of the constructor
- , con_doc :: Maybe (LHsDoc name)
+ , con_doc :: Maybe LHsDocString
-- ^ A possible Haddock comment.
+
+ , con_old_rec :: Bool
+ -- ^ TEMPORARY field; True <=> user has employed now-deprecated syntax for
+ -- GADT-style record decl C { blah } :: T a b
+ -- Remove this when we no longer parse this stuff, and hence do not
+ -- need to report decprecated use
}
type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map cd_fld_type flds
-data ConDeclField name -- Record fields have Haddoc docs on them
- = ConDeclField { cd_fld_name :: Located name,
- cd_fld_type :: LBangType name,
- cd_fld_doc :: Maybe (LHsDoc name) }
-
data ResType name
= ResTyH98 -- Constructor was declared using Haskell 98 syntax
| ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax,
-- and here is its result type
+
+instance OutputableBndr name => Outputable (ResType name) where
+ -- Debugging only
+ ppr ResTyH98 = ptext (sLit "ResTyH98")
+ ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
\end{code}
\begin{code}
-conDeclsNames :: (Eq name) => [ConDecl name] -> [Located name]
+hsConDeclsNames :: (Eq name) => [LConDecl name] -> [Located name]
-- See tyClDeclNames for what this does
-- The function is boringly complicated because of the records
-- And since we only have equality, we have to be a little careful
-conDeclsNames cons
+hsConDeclsNames cons
= snd (foldl do_one ([], []) cons)
where
- do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds })
+ do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
= (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
where
new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
(map cd_fld_name flds)
- do_one (flds_seen, acc) c
- = (flds_seen, (con_name c):acc)
+ do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
+ = (flds_seen, lname:acc)
\end{code}
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
+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 <+> ppr_fields fields
+ ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields
-pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _)
+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 expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _)
- = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty]
+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 _expl _tvs _cxt (InfixCon _ _) (ResTyGADT _res_ty) _)
+pprConDecl (ConDecl {con_name = con, con_details = InfixCon {}, con_res = ResTyGADT {} })
= pprPanic "pprConDecl" (ppr con)
-- In GADT syntax we don't allow infix constructors
-
-
-ppr_fields :: OutputableBndr name => [ConDeclField name] -> SDoc
-ppr_fields fields = braces (sep (punctuate comma (map ppr_fld fields)))
- where
- ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty,
- cd_fld_doc = doc })
- = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
\end{code}
%************************************************************************
instance (OutputableBndr name) => Outputable (DerivDecl name) where
ppr (DerivDecl ty)
- = hsep [ptext (sLit "derived instance"), ppr ty]
+ = hsep [ptext (sLit "deriving instance"), ppr ty]
\end{code}
%************************************************************************
CImport CCallConv -- ccall or stdcall
Safety -- safe or unsafe
FastString -- name of C header
- FastString -- name of library object
CImportSpec -- details of the C entity
- -- import of a .NET function
- --
- | DNImport DNCallSpec
-
-- details of an external C entity
--
data CImportSpec = CLabel CLabelString -- import address of a C label
-- convention
--
data ForeignExport = CExport CExportSpec -- contains the calling convention
- | DNExport -- presently unused
-
--- abstract type imported from .NET
---
-data FoType = DNType -- In due course we'll add subtype stuff
- deriving (Eq) -- Used for equality instance for TyClDecl
-
-- pretty printing of foreign declarations
--
2 (dcolon <+> ppr ty)
instance Outputable ForeignImport where
- ppr (DNImport spec) =
- ptext (sLit "dotnet") <+> ppr spec
- ppr (CImport cconv safety header lib spec) =
+ ppr (CImport cconv safety header spec) =
ppr cconv <+> ppr safety <+>
- char '"' <> pprCEntity header lib spec <> char '"'
+ char '"' <> pprCEntity spec <> char '"'
where
- pprCEntity header lib (CLabel lbl) =
- ptext (sLit "static") <+> ftext header <+> char '&' <>
- pprLib lib <> ppr lbl
- pprCEntity header lib (CFunction (StaticTarget lbl)) =
- ptext (sLit "static") <+> ftext header <+> char '&' <>
- pprLib lib <> ppr lbl
- pprCEntity _ _ (CFunction (DynamicTarget)) =
+ 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")
- --
- pprLib lib | nullFS lib = empty
- | otherwise = char '[' <> ppr lib <> char ']'
+ pprCEntity (CWrapper) = ptext (sLit "wrapper")
instance Outputable ForeignExport where
ppr (CExport (CExportStatic lbl cconv)) =
ppr cconv <+> char '"' <> ppr lbl <> char '"'
- ppr (DNExport ) =
- ptext (sLit "dotnet") <+> ptext (sLit "\"<unused>\"")
-
-instance Outputable FoType where
- ppr DNType = ptext (sLit "type dotnet")
\end{code}
\begin{code}
-type LDocDecl name = Located (DocDecl name)
+type LDocDecl = Located (DocDecl)
-data DocDecl name
- = DocCommentNext (HsDoc name)
- | DocCommentPrev (HsDoc name)
- | DocCommentNamed String (HsDoc name)
- | DocGroup Int (HsDoc name)
+data DocDecl
+ = DocCommentNext HsDocString
+ | DocCommentPrev HsDocString
+ | DocCommentNamed String HsDocString
+ | DocGroup Int HsDocString
-- Okay, I need to reconstruct the document comments, but for now:
-instance Outputable (DocDecl name) where
+instance Outputable DocDecl where
ppr _ = text "<document comment>"
-docDeclDoc :: DocDecl name -> HsDoc name
+docDeclDoc :: DocDecl -> HsDocString
docDeclDoc (DocCommentNext d) = d
docDeclDoc (DocCommentPrev d) = d
docDeclDoc (DocCommentNamed _ d) = d
projects / ghc-hetmet.git / blobdiff