module HsDecls where
-import Ubiq
+IMP_Ubiq()
-- friends:
-import HsLoop ( nullMonoBinds, MonoBinds, Sig )
+import HsBinds ( HsBinds, MonoBinds, Sig, nullMonoBinds )
import HsPragmas ( DataPragmas, ClassPragmas,
InstancePragmas, ClassOpPragmas
)
import HsTypes
+import IdInfo
+import SpecEnv ( SpecEnv )
+import HsCore ( UfExpr )
+import HsBasic ( Fixity )
+import TyCon ( NewOrData(..) ) -- Just a boolean flag really
-- others:
-import Name ( pprSym, pprNonSym )
+import Name --( getOccName, OccName )
import Outputable ( interppSP, interpp'SP,
Outputable(..){-instance * []-}
)
import Pretty
import SrcLoc ( SrcLoc )
-import Util ( cmpList, panic#{-ToDo:rm eventually-} )
+import PprStyle ( PprStyle(..) )
+import Util
\end{code}
+
%************************************************************************
%* *
-\subsection[FixityDecl]{A fixity declaration}
+\subsection[HsDecl]{Declarations}
%* *
%************************************************************************
\begin{code}
-data FixityDecl name
- = InfixL name Int
- | InfixR name Int
- | InfixN name Int
+data HsDecl tyvar uvar name pat
+ = TyD (TyDecl name)
+ | ClD (ClassDecl tyvar uvar name pat)
+ | InstD (InstDecl tyvar uvar name pat)
+ | DefD (DefaultDecl name)
+ | ValD (HsBinds tyvar uvar name pat)
+ | SigD (IfaceSig name)
\end{code}
\begin{code}
-instance (NamedThing name, Outputable name)
- => Outputable (FixityDecl name) where
- ppr sty (InfixL var prec) = print_it sty "l" prec var
- ppr sty (InfixR var prec) = print_it sty "r" prec var
- ppr sty (InfixN var prec) = print_it sty "" prec var
+#ifdef DEBUG
+hsDeclName :: (NamedThing name, Outputable name, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => HsDecl tyvar uvar name pat -> name
+#endif
+hsDeclName (TyD (TyData _ _ name _ _ _ _ _)) = name
+hsDeclName (TyD (TySynonym name _ _ _)) = name
+hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) = name
+hsDeclName (SigD (IfaceSig name _ _ _)) = name
+hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
+-- Others don't make sense
+#ifdef DEBUG
+hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr PprDebug x)
+#endif
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => Outputable (HsDecl tyvar uvar name pat) where
+
+ ppr sty (TyD td) = ppr sty td
+ ppr sty (ClD cd) = ppr sty cd
+ ppr sty (SigD sig) = ppr sty sig
+ ppr sty (ValD binds) = ppr sty binds
+ ppr sty (DefD def) = ppr sty def
+ ppr sty (InstD inst) = ppr sty inst
+
+#ifdef DEBUG
+instance (Ord3 name, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+ NamedThing name, Outputable name, Outputable pat) =>
+ Ord3 (HsDecl tyvar uvar name pat) where
+#else
+instance (Ord3 name) => Ord3 (HsDecl tyvar uvar name pat) where
+#endif
+ d1 `cmp` d2 = hsDeclName d1 `cmp` hsDeclName d2
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[FixityDecl]{A fixity declaration}
+%* *
+%************************************************************************
-print_it sty suff prec var
- = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprSym sty var]
+\begin{code}
+data FixityDecl name = FixityDecl name Fixity SrcLoc
+
+instance Outputable name => Outputable (FixityDecl name) where
+ ppr sty (FixityDecl name fixity loc) = sep [ppr sty fixity, ppr sty name]
\end{code}
+
%************************************************************************
%* *
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
\begin{code}
data TyDecl name
- = TyData (Context name) -- context
+ = TyData NewOrData
+ (Context name) -- context
name -- type constructor
- [name] -- type variables
+ [HsTyVar name] -- type variables
[ConDecl name] -- data constructors (empty if abstract)
(Maybe [name]) -- derivings; Nothing => not specified
-- (i.e., derive default); Just [] => derive
(DataPragmas name)
SrcLoc
- | TyNew (Context name) -- context
- name -- type constructor
- [name] -- type variables
- [ConDecl name] -- data constructor (empty if abstract)
- (Maybe [name]) -- derivings; as above
- (DataPragmas name)
- SrcLoc
-
| TySynonym name -- type constructor
- [name] -- type variables
- (MonoType name) -- synonym expansion
+ [HsTyVar name] -- type variables
+ (HsType name) -- synonym expansion
SrcLoc
\end{code}
=> Outputable (TyDecl name) where
ppr sty (TySynonym tycon tyvars mono_ty src_loc)
- = ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars)
- 4 (ppCat [ppEquals, ppr sty mono_ty])
+ = hang (pp_decl_head sty SLIT("type") empty tycon tyvars)
+ 4 (ppr sty mono_ty)
- ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
+ ppr sty (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
= pp_tydecl sty
- (pp_decl_head sty SLIT("data") (pprContext sty context) tycon tyvars)
+ (pp_decl_head sty keyword (pp_context_and_arrow sty context) tycon tyvars)
(pp_condecls sty condecls)
derivings
-
- ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc)
- = pp_tydecl sty
- (pp_decl_head sty SLIT("newtype") (pprContext sty context) tycon tyvars)
- (pp_condecls sty condecl)
- derivings
+ where
+ keyword = case new_or_data of
+ NewType -> SLIT("newtype")
+ DataType -> SLIT("data")
pp_decl_head sty str pp_context tycon tyvars
- = ppCat [ppPStr str, pp_context, ppr sty tycon, interppSP sty tyvars]
+ = hsep [ptext str, pp_context, ppr sty tycon,
+ interppSP sty tyvars, ptext SLIT("=")]
-pp_condecls sty [] = ppNil -- abstract datatype
+pp_condecls sty [] = empty -- Curious!
pp_condecls sty (c:cs)
- = ppSep (ppBeside (ppStr "= ") (ppr sty c)
- : map (\ x -> ppBeside (ppStr "| ") (ppr sty x)) cs)
+ = sep (ppr sty c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr sty c)) cs)
pp_tydecl sty pp_head pp_decl_rhs derivings
- = ppHang pp_head 4 (ppSep [
+ = hang pp_head 4 (sep [
pp_decl_rhs,
- case derivings of
- Nothing -> ppNil
- Just ds -> ppBeside (ppPStr SLIT("deriving "))
- (ppParens (ppInterleave ppComma (map (ppr sty) ds)))])
+ case (derivings, sty) of
+ (Nothing,_) -> empty
+ (_,PprInterface) -> empty -- No derivings in interfaces
+ (Just ds,_) -> hsep [ptext SLIT("deriving"), parens (interpp'SP sty ds)]
+ ])
+
+pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Doc
+pp_context_and_arrow sty [] = empty
+pp_context_and_arrow sty theta = hsep [pprContext sty theta, ptext SLIT("=>")]
\end{code}
A type for recording what types a datatype should be specialised to.
\begin{code}
data SpecDataSig name
= SpecDataSig name -- tycon to specialise
- (MonoType name)
+ (HsType name)
SrcLoc
instance (NamedThing name, Outputable name)
=> Outputable (SpecDataSig name) where
ppr sty (SpecDataSig tycon ty _)
- = ppCat [ppStr "{-# SPECIALIZE data", ppr sty ty, ppStr "#-}"]
+ = hsep [text "{-# SPECIALIZE data", ppr sty ty, text "#-}"]
\end{code}
%************************************************************************
\begin{code}
data ConDecl name
- = ConDecl name -- prefix-style con decl
- [BangType name]
+ = ConDecl name -- Constructor name
+ (Context name) -- Existential context for this constructor
+ (ConDetails name)
SrcLoc
- | ConOpDecl (BangType name) -- infix-style con decl
- name
+data ConDetails name
+ = VanillaCon -- prefix-style con decl
+ [BangType name]
+
+ | InfixCon -- infix-style con decl
+ (BangType name)
(BangType name)
- SrcLoc
- | RecConDecl name
+ | RecCon -- record-style con decl
[([name], BangType name)] -- list of "fields"
- SrcLoc
- | NewConDecl name -- newtype con decl
- (MonoType name)
- SrcLoc
+ | NewCon -- newtype con decl
+ (HsType name)
data BangType name
- = Banged (PolyType name) -- PolyType: to allow Haskell extensions
- | Unbanged (PolyType name) -- (MonoType only needed for straight Haskell)
+ = Banged (HsType name) -- HsType: to allow Haskell extensions
+ | Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
\end{code}
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
+ ppr sty (ConDecl con cxt con_details loc)
+ = pp_context_and_arrow sty cxt <+> ppr_con_details sty con con_details
- ppr sty (ConDecl con tys _)
- = ppCat [pprNonSym sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
- ppr sty (ConOpDecl ty1 op ty2 _)
- = ppCat [ppr_bang sty ty1, pprSym sty op, ppr_bang sty ty2]
- ppr sty (NewConDecl con ty _)
- = ppCat [pprNonSym sty con, pprParendMonoType sty ty]
- ppr sty (RecConDecl con fields _)
- = ppCat [pprNonSym sty con, ppChar '{',
- ppInterleave pp'SP (map pp_field fields), ppChar '}']
- where
- pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
+ppr_con_details sty con (InfixCon ty1 ty2)
+ = hsep [ppr_bang sty ty1, ppr sty con, ppr_bang sty ty2]
+
+ppr_con_details sty con (VanillaCon tys)
+ = ppr sty con <+> hsep (map (ppr_bang sty) tys)
-ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendPolyType sty ty)
-ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty
+ppr_con_details sty con (NewCon ty)
+ = ppr sty con <+> pprParendHsType sty ty
+
+ppr_con_details sty con (RecCon fields)
+ = ppr sty con <+> braces (hsep (punctuate comma (map ppr_field fields)))
+ where
+ ppr_field (ns, ty) = hsep (map (ppr sty) ns) <+>
+ ptext SLIT("::") <+>
+ ppr_bang sty ty
+
+ppr_bang sty (Banged ty) = ptext SLIT("!") <> pprParendHsType sty ty
+ppr_bang sty (Unbanged ty) = pprParendHsType sty ty
\end{code}
%************************************************************************
data ClassDecl tyvar uvar name pat
= ClassDecl (Context name) -- context...
name -- name of the class
- name -- the class type variable
+ (HsTyVar name) -- the class type variable
[Sig name] -- methods' signatures
(MonoBinds tyvar uvar name pat) -- default methods
(ClassPragmas name)
=> Outputable (ClassDecl tyvar uvar name pat) where
ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
- = let
- top_matter = ppCat [ppStr "class", pprContext sty context,
- ppr sty clas, ppr sty tyvar]
- in
- if null sigs && nullMonoBinds methods then
- ppAbove top_matter (ppNest 4 (ppr sty pragmas))
- else
- ppAboves [ppCat [top_matter, ppStr "where"],
- ppNest 4 (ppAboves (map (ppr sty) sigs)),
- ppNest 4 (ppr sty methods),
- ppNest 4 (ppr sty pragmas) ]
+ | null sigs -- No "where" part
+ = top_matter
+
+ | otherwise -- Laid out
+ = sep [hsep [top_matter, ptext SLIT("where {")],
+ nest 4 (vcat [sep (map ppr_sig sigs),
+ ppr sty methods,
+ char '}'])]
+ where
+ top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow sty context,
+ ppr sty clas, ppr sty tyvar]
+ ppr_sig sig = ppr sty sig <> semi
\end{code}
%************************************************************************
\begin{code}
data InstDecl tyvar uvar name pat
- = InstDecl name -- Class
-
- (PolyType name) -- Context => Instance-type
+ = InstDecl (HsType name) -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
(MonoBinds tyvar uvar name pat)
- Bool -- True <=> This instance decl is from the
- -- module being compiled; False <=> It is from
- -- an imported interface.
+ [Sig name] -- User-supplied pragmatic info
- (Maybe Module) -- The name of the module where the instance decl
- -- originally came from; Nothing => Prelude
+ (Maybe name) -- Name for the dictionary function
- [Sig name] -- actually user-supplied pragmatic info
- (InstancePragmas name) -- interface-supplied pragmatic info
SrcLoc
\end{code}
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> Outputable (InstDecl tyvar uvar name pat) where
- ppr sty (InstDecl clas ty binds local modname uprags pragmas src_loc)
- = let
- (context, inst_ty)
- = case ty of
- HsPreForAllTy c t -> (c, t)
- HsForAllTy _ c t -> (c, t)
-
- top_matter = ppCat [ppStr "instance", pprContext sty context,
- ppr sty clas, pprParendMonoType sty inst_ty]
- in
- if nullMonoBinds binds && null uprags then
- ppAbove top_matter (ppNest 4 (ppr sty pragmas))
- else
- ppAboves [ppCat [top_matter, ppStr "where"],
- if null uprags then ppNil else ppNest 4 (ppr sty uprags),
- ppNest 4 (ppr sty binds),
- ppNest 4 (ppr sty pragmas) ]
+ ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc)
+ | case sty of { PprInterface -> True; other -> False} ||
+ nullMonoBinds binds && null uprags
+ = hsep [ptext SLIT("instance"), ppr sty inst_ty]
+
+ | otherwise
+ = vcat [hsep [ptext SLIT("instance"), ppr sty inst_ty, ptext SLIT("where")],
+ nest 4 (ppr sty uprags),
+ nest 4 (ppr sty binds) ]
\end{code}
A type for recording what instances the user wants to specialise;
\begin{code}
data SpecInstSig name
= SpecInstSig name -- class
- (MonoType name) -- type to specialise to
+ (HsType name) -- type to specialise to
SrcLoc
instance (NamedThing name, Outputable name)
=> Outputable (SpecInstSig name) where
ppr sty (SpecInstSig clas ty _)
- = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"]
+ = hsep [text "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, text "#-}"]
\end{code}
%************************************************************************
\begin{code}
data DefaultDecl name
- = DefaultDecl [MonoType name]
+ = DefaultDecl [HsType name]
SrcLoc
instance (NamedThing name, Outputable name)
=> Outputable (DefaultDecl name) where
ppr sty (DefaultDecl tys src_loc)
- = ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys))
+ = (<>) (ptext SLIT("default ")) (parens (interpp'SP sty tys))
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Signatures in interface files}
+%* *
+%************************************************************************
+
+\begin{code}
+data IfaceSig name
+ = IfaceSig name
+ (HsType name)
+ [HsIdInfo name]
+ SrcLoc
+
+instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
+ ppr sty (IfaceSig var ty _ _)
+ = hang (hsep [ppr sty var, ptext SLIT("::")])
+ 4 (ppr sty ty)
+
+data HsIdInfo name
+ = HsArity ArityInfo
+ | HsStrictness (StrictnessInfo name)
+ | HsUnfold (UfExpr name)
+ | HsUpdate UpdateInfo
+ | HsDeforest DeforestInfo
+ | HsArgUsage ArgUsageInfo
+ | HsFBType FBTypeInfo
+ -- ToDo: specialisations
\end{code}
projects / ghc-hetmet.git / blobdiff