module HsDecls where
-import Ubiq{-uitous-}
+IMP_Ubiq()
-- friends:
-import HsLoop ( nullMonoBinds, MonoBinds, Sig )
+IMPORT_DELOOPER(HsLoop) ( nullMonoBinds, MonoBinds, Sig )
import HsPragmas ( DataPragmas, ClassPragmas,
InstancePragmas, ClassOpPragmas
)
import HsTypes
-- others:
-import Outputable
+import Name ( pprSym, pprNonSym )
+import Outputable ( interppSP, interpp'SP,
+ Outputable(..){-instance * []-}
+ )
import Pretty
-import ProtoName ( cmpProtoName, ProtoName )
import SrcLoc ( SrcLoc )
-import Util ( cmpList, panic#{-ToDo:rm eventually-} )
+--import Util ( panic#{-ToDo:rm eventually-} )
\end{code}
%************************************************************************
%* *
%************************************************************************
-These are only used in generating interfaces at the moment. They are
-not used in pretty-printing.
-
\begin{code}
data FixityDecl name
= InfixL name Int
ppr sty (InfixN var prec) = print_it sty "" prec var
print_it sty suff prec var
- = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprOp sty var]
+ = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprSym sty var]
\end{code}
%************************************************************************
SrcLoc
| RecConDecl name
- [(name, BangType name)] -- list of "fields"
+ [([name], BangType name)] -- list of "fields"
SrcLoc
| NewConDecl name -- newtype con decl
SrcLoc
data BangType name
- = Banged (MonoType name)
- | Unbanged (MonoType name)
-\end{code}
-
-In checking interfaces, we need to ``compare'' @ConDecls@. Use with care!
-\begin{code}
-eqConDecls cons1 cons2
- = case (cmpList cmp cons1 cons2) of { EQ_ -> True; _ -> False }
- where
- cmp (ConDecl n1 tys1 _) (ConDecl n2 tys2 _)
- = case cmpProtoName n1 n2 of
- EQ_ -> cmpList cmp_bang_ty tys1 tys2
- xxx -> xxx
- cmp (ConOpDecl _ _ _ _) _ = panic# "eqConDecls:ConOpDecl"
- cmp (RecConDecl _ _ _) _ = panic# "eqConDecls:RecConDecl"
- cmp (NewConDecl _ _ _) _ = panic# "eqConDecls:NewConDecl"
- -------------
-
- cmp_ty = cmpMonoType cmpProtoName
- -------------
- cmp_bang_ty (Banged ty1) (Banged ty2) = cmp_ty ty1 ty2
- cmp_bang_ty (Unbanged ty1) (Unbanged ty2) = cmp_ty ty1 ty2
- cmp_bang_ty (Banged _) _ = LT_
- cmp_bang_ty _ _ = GT_
+ = Banged (PolyType name) -- PolyType: to allow Haskell extensions
+ | Unbanged (PolyType name) -- (MonoType only needed for straight Haskell)
\end{code}
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
ppr sty (ConDecl con tys _)
- = ppCat [pprNonOp sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
+ = ppCat [pprNonSym sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
ppr sty (ConOpDecl ty1 op ty2 _)
- = ppCat [ppr_bang sty ty1, pprOp sty op, ppr_bang sty ty2]
+ = ppCat [ppr_bang sty ty1, pprSym sty op, ppr_bang sty ty2]
ppr sty (NewConDecl con ty _)
- = ppCat [pprNonOp sty con, pprParendMonoType sty ty]
+ = ppCat [pprNonSym sty con, pprParendMonoType sty ty]
ppr sty (RecConDecl con fields _)
- = ppCat [pprNonOp sty con, ppChar '{',
+ = 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_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendMonoType sty ty)
-ppr_bang sty (Unbanged ty) = pprParendMonoType sty ty
+ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendPolyType sty ty)
+ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty
\end{code}
%************************************************************************
=> Outputable (ClassDecl tyvar uvar name pat) where
ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
- = ppAboves [ppCat [ppStr "class", pprContext sty context, ppr sty clas,
- ppr sty tyvar, ppStr "where"],
- -- ToDo: really shouldn't print "where" unless there are sigs
- ppNest 4 (ppAboves (map (ppr sty) sigs)),
- ppNest 4 (ppr sty methods),
- ppNest 4 (ppr sty pragmas)]
+ = 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) ]
\end{code}
%************************************************************************
-- module being compiled; False <=> It is from
-- an imported interface.
- FAST_STRING -- The name of the module where the instance decl
- -- originally came from; easy enough if it's
- -- the module being compiled; otherwise, the
- -- info comes from a pragma.
+ Module -- The name of the module where the instance decl
+ -- originally came from
[Sig name] -- actually user-supplied pragmatic info
(InstancePragmas name) -- interface-supplied pragmatic info
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)
+ ppr sty (InstDecl clas ty binds from_here modname uprags pragmas src_loc)
= let
(context, inst_ty)
= case ty of
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) ]
+ 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) ]
\end{code}
A type for recording what instances the user wants to specialise;
projects / ghc-hetmet.git / blobdiff