X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsDecls.lhs;h=d4f6628b68d6d4da66e077cab06036d240df8dcd;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=1e1cc3e17cca47790a7416639b54afd7aeaf3a22;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 1e1cc3e..d4f6628 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -22,6 +22,7 @@ import HsTypes import IdInfo import SpecEnv ( SpecEnv ) import HsCore ( UfExpr ) +import HsBasic ( Fixity ) -- others: import Name ( pprSym, pprNonSym, getOccName, OccName ) @@ -30,7 +31,7 @@ import Outputable ( interppSP, interpp'SP, ) import Pretty import SrcLoc ( SrcLoc ) -import PprStyle ( PprStyle(..) ) +import PprStyle ( PprStyle(..), ifaceStyle ) \end{code} @@ -70,6 +71,10 @@ instance (NamedThing name, Outputable name, Outputable pat, ppr sty (ValD binds) = ppr sty binds ppr sty (DefD def) = ppr sty def ppr sty (InstD inst) = ppr sty inst + +-- In interfaces, top-level binders are printed without their "Module." prefix +ppr_top_binder sty bndr | ifaceStyle sty = ppr sty (getOccName bndr) + | otherwise = ppr sty bndr \end{code} @@ -86,26 +91,6 @@ instance Outputable name => Outputable (FixityDecl name) where ppr sty (FixityDecl name fixity loc) = ppSep [ppr sty fixity, ppr sty name] \end{code} -It's convenient to keep the source location in the @Fixity@; it makes error reporting -in the renamer easier. - -\begin{code} -data Fixity = Fixity Int FixityDirection -data FixityDirection = InfixL | InfixR | InfixN - deriving(Eq) - -instance Outputable Fixity where - ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec] - -instance Outputable FixityDirection where - ppr sty InfixL = ppStr "infixl" - ppr sty InfixR = ppStr "infixr" - ppr sty InfixN = ppStr "infix" - -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 -\end{code} - %************************************************************************ %* * @@ -162,12 +147,12 @@ instance (NamedThing name, Outputable name) derivings pp_decl_head sty str pp_context tycon tyvars - = ppCat [ppPStr str, pp_context, ppr sty (getOccName tycon), + = ppCat [ppPStr str, pp_context, ppr_top_binder sty tycon, interppSP sty tyvars, ppPStr SLIT("=")] pp_condecls sty [] = ppNil -- Curious! pp_condecls sty (c:cs) - = ppSep (ppr sty c : map (\ c -> ppBeside (ppStr "| ") (ppr sty c)) cs) + = ppSep (ppr sty c : map (\ c -> ppBeside (ppPStr SLIT("| ")) (ppr sty c)) cs) pp_tydecl sty pp_head pp_decl_rhs derivings = ppHang pp_head 4 (ppSep [ @@ -234,24 +219,29 @@ data BangType name instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where ppr sty (ConDecl con tys _) - = ppCat [ppr sty (getOccName con), ppInterleave ppNil (map (ppr_bang sty) tys)] + = ppCat [ppr_top_binder sty con, ppInterleave ppNil (map (ppr_bang sty) tys)] -- We print ConOpDecls in prefix form in interface files - ppr PprInterface (ConOpDecl ty1 op ty2 _) - = ppCat [ppr PprInterface (getOccName op), ppr_bang PprInterface ty1, ppr_bang PprInterface ty2] ppr sty (ConOpDecl ty1 op ty2 _) - = ppCat [ppr_bang sty ty1, ppr sty (getOccName op), ppr_bang sty ty2] + | ifaceStyle sty + = ppCat [ppr_top_binder sty op, ppr_bang sty ty1, ppr_bang sty ty2] + | otherwise + = ppCat [ppr_bang sty ty1, ppr_top_binder sty op, ppr_bang sty ty2] ppr sty (NewConDecl con ty _) - = ppCat [ppr sty (getOccName con), pprParendHsType sty ty] + = ppCat [ppr_top_binder sty con, pprParendHsType sty ty] ppr sty (RecConDecl con fields _) - = ppCat [ppr sty (getOccName con), + = ppCat [ppr_top_binder sty con, ppCurlies (ppInterleave pp'SP (map pp_field fields)) ] where - pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty] + pp_field (ns, ty) = ppCat [ppCat (map (ppr_top_binder sty) ns), + ppPStr SLIT("::"), ppr_bang sty ty] -ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendHsType sty ty) +ppr_bang sty (Banged ty) = ppBeside (ppPStr SLIT("! ")) (pprParendHsType sty ty) + -- The extra space helps the lexical analyser that lexes + -- interface files; it doesn't make the rigid operator/identifier + -- distinction, so "!a" is a valid identifier so far as it is concerned ppr_bang sty (Unbanged ty) = pprParendHsType sty ty \end{code} @@ -282,16 +272,16 @@ instance (NamedThing name, Outputable name, Outputable pat, = top_matter | iface_style -- All on one line (for now at least) - = ppCat [top_matter, ppStr "where", + = ppCat [top_matter, ppPStr SLIT("where"), ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)] | otherwise -- Laid out - = ppSep [ppCat [top_matter, ppStr "where {"], + = ppSep [ppCat [top_matter, ppPStr SLIT("where {")], ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods) - `ppBeside` ppStr "}")] + `ppBeside` ppChar '}')] where - top_matter = ppCat [ppStr "class", pp_context_and_arrow sty context, - ppr sty (getOccName clas), ppr sty tyvar] + top_matter = ppCat [ppPStr SLIT("class"), pp_context_and_arrow sty context, + ppr_top_binder sty clas, ppr sty tyvar] pp_sigs = map (ppr sty) sigs pp_methods = ppr sty methods iface_style = case sty of {PprInterface -> True; other -> False} @@ -326,10 +316,10 @@ instance (NamedThing name, Outputable name, Outputable pat, ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc) | case sty of { PprInterface -> True; other -> False} || nullMonoBinds binds && null uprags - = ppCat [ppStr "instance", ppr sty inst_ty] + = ppCat [ppPStr SLIT("instance"), ppr sty inst_ty] | otherwise - = ppAboves [ppCat [ppStr "instance", ppr sty inst_ty, ppStr "where"], + = ppAboves [ppCat [ppPStr SLIT("instance"), ppr sty inst_ty, ppPStr SLIT("where")], ppNest 4 (ppr sty uprags), ppNest 4 (ppr sty binds) ] \end{code} @@ -387,7 +377,7 @@ data IfaceSig name instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where ppr sty (IfaceSig var ty _ _) - = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")]) + = ppHang (ppCat [ppr_top_binder sty var, ppPStr SLIT("::")]) 4 (ppr sty ty) data HsIdInfo name