@TyVars@ as well. Currently trying the former... MEGA SIGH.
\begin{code}
-#include "HsVersions.h"
-
module HsCore (
UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
UfDefault(..), UfBinding(..),
UfArg(..), UfPrimOp(..)
) where
-IMP_Ubiq()
+#include "HsVersions.h"
-- friends:
import HsTypes ( HsType, pprParendHsType )
-import PrimOp ( PrimOp, tagOf_PrimOp )
import Kind ( Kind {- instance Outputable -} )
-import Type ( GenType {- instance Outputable -} )
-- others:
import Literal ( Literal )
-import Outputable ( Outputable(..) )
-import Pretty
import Util ( panic )
+import CostCentre
+import Outputable
\end{code}
%************************************************************************
data UfCoercion name = UfIn name | UfOut name
data UfAlts name
- = UfAlgAlts [(name, [UfBinder name], UfExpr name)]
+ = UfAlgAlts [(name, [name], UfExpr name)]
(UfDefault name)
| UfPrimAlts [(Literal, UfExpr name)]
(UfDefault name)
data UfDefault name
= UfNoDefault
- | UfBindDefault (UfBinder name)
- (UfExpr name)
+ | UfBindDefault name (UfExpr name)
data UfBinding name
= UfNonRec (UfBinder name)
data UfBinder name
= UfValBinder name (HsType name)
| UfTyBinder name Kind
- | UfUsageBinder name
data UfArg name
= UfVarArg name
| UfLitArg Literal
| UfTyArg (HsType name)
- | UfUsageArg name
\end{code}
%************************************************************************
\begin{code}
instance Outputable name => Outputable (UfExpr name) where
- ppr sty (UfVar v) = ppr sty v
- ppr sty (UfLit l) = ppr sty l
+ ppr (UfVar v) = ppr v
+ ppr (UfLit l) = ppr l
- ppr sty (UfCon c as)
- = ppCat [ppStr "(UfCon", ppr sty c, ppr sty as, ppStr ")"]
- ppr sty (UfPrim o as)
- = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty as, ppStr ")"]
+ ppr (UfCon c as)
+ = hsep [text "UfCon", ppr c, ppr as, char ')']
+ ppr (UfPrim o as)
+ = hsep [text "UfPrim", ppr o, ppr as, char ')']
- ppr sty (UfLam b body)
- = ppCat [ppChar '\\', ppr sty b, ppStr "->", ppr sty body]
+ ppr (UfLam b body)
+ = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
- ppr sty (UfApp fun (UfTyArg ty))
- = ppCat [ppr sty fun, ppStr "@", pprParendHsType sty ty]
+ ppr (UfApp fun (UfTyArg ty))
+ = hsep [ppr fun, char '@', pprParendHsType ty]
- ppr sty (UfApp fun (UfLitArg lit))
- = ppCat [ppr sty fun, ppr sty lit]
+ ppr (UfApp fun (UfLitArg lit))
+ = hsep [ppr fun, ppr lit]
- ppr sty (UfApp fun (UfVarArg var))
- = ppCat [ppr sty fun, ppr sty var]
+ ppr (UfApp fun (UfVarArg var))
+ = hsep [ppr fun, ppr var]
- ppr sty (UfCase scrut alts)
- = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
+ ppr (UfCase scrut alts)
+ = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}']
where
pp_alts (UfAlgAlts alts deflt)
- = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
+ = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
where
- pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
+ pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
pp_alts (UfPrimAlts alts deflt)
- = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
+ = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
where
- pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
+ pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs]
+
+ pp_deflt UfNoDefault = empty
+ pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs]
- pp_deflt UfNoDefault = ppNil
- pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
+ ppr_arrow = ptext SLIT("->")
- ppr sty (UfLet (UfNonRec b rhs) body)
- = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
- ppr sty (UfLet (UfRec pairs) body)
- = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
+ ppr (UfLet (UfNonRec b rhs) body)
+ = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
+ ppr (UfLet (UfRec pairs) body)
+ = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
where
- pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
+ pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
- ppr sty (UfSCC uf_cc body)
- = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
+ ppr (UfSCC uf_cc body)
+ = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr body]
instance Outputable name => Outputable (UfPrimOp name) where
- ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
+ ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
= let
- before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
- after = if is_casm then ppStr "'' " else ppSP
+ before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
+ after = if is_casm then text "'' " else space
in
- ppBesides [before, ppPStr str, after,
- ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+ hcat [before, ptext str, after,
+ brackets (ppr arg_tys), space, ppr result_ty]
- ppr sty (UfOtherOp op)
- = ppr sty op
+ ppr (UfOtherOp op)
+ = ppr op
instance Outputable name => Outputable (UfArg name) where
- ppr sty (UfVarArg v) = ppr sty v
- ppr sty (UfLitArg l) = ppr sty l
- ppr sty (UfTyArg ty) = pprParendHsType sty ty
- ppr sty (UfUsageArg name) = ppr sty name
+ ppr (UfVarArg v) = ppr v
+ ppr (UfLitArg l) = ppr l
+ ppr (UfTyArg ty) = pprParendHsType ty
instance Outputable name => Outputable (UfBinder name) where
- ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppStr "::", ppr sty ty]
- ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind]
- ppr sty (UfUsageBinder name) = ppr sty name
+ ppr (UfValBinder name ty) = hsep [ppr name, ptext SLIT("::"), ppr ty]
+ ppr (UfTyBinder name kind) = hsep [ppr name, ptext SLIT("::"), ppr kind]
\end{code}
projects / ghc-hetmet.git / blobdiff