module HsExpr where
-import Ubiq{-uitous-}
-import HsLoop -- for paranoia checking
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(HsLoop) -- for paranoia checking
-- friends:
import HsBinds ( HsBinds )
import HsTypes ( PolyType )
-- others:
-import Id ( DictVar(..), GenId, Id(..) )
-import Name ( isOpLexeme, pprOp )
+import Id ( SYN_IE(DictVar), GenId, SYN_IE(Id) )
+import Name ( pprNonSym, pprSym )
import Outputable ( interppSP, interpp'SP, ifnotPprForUser )
import PprType ( pprGenType, pprParendGenType, GenType{-instance-} )
import Pretty
import PprStyle ( PprStyle(..) )
import SrcLoc ( SrcLoc )
import Usage ( GenUsage{-instance-} )
-import Util ( panic{-ToDo:rm eventually-} )
+--import Util ( panic{-ToDo:rm eventually-} )
\end{code}
%************************************************************************
(HsExpr tyvar uvar id pat) -- right operand
-- We preserve prefix negation and parenthesis for the precedence parser.
+ -- They are eventually removed by the type checker.
| NegApp (HsExpr tyvar uvar id pat) -- negated expr
+ (HsExpr tyvar uvar id pat) -- the negate id (in a HsVar)
+
| HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr
| SectionL (HsExpr tyvar uvar id pat) -- operand
| SectionR (HsExpr tyvar uvar id pat) -- operator
(HsExpr tyvar uvar id pat) -- operand
-
| HsCase (HsExpr tyvar uvar id pat)
[Match tyvar uvar id pat] -- must have at least one Match
SrcLoc
| HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts
SrcLoc
- | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts
- id id -- Monad and MonadZero dicts
+ | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts
+ id -- id for >>=, types applied
+ id -- id for zero, typed applied
SrcLoc
- | ListComp (HsExpr tyvar uvar id pat) -- list comprehension
- [Qual tyvar uvar id pat] -- at least one Qual(ifier)
+ | ListComp (HsExpr tyvar uvar id pat) -- list comprehension
+ [Qualifier tyvar uvar id pat] -- at least one Qualifier
| ExplicitList -- syntactic list
[HsExpr tyvar uvar id pat]
| RecordUpd (HsExpr tyvar uvar id pat)
(HsRecordBinds tyvar uvar id pat)
- | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION
- [id] -- Dicts needed for construction
- (HsRecordBinds tyvar uvar id pat)
+ | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION
+ [id] -- Dicts needed for construction
+ (HsRecordBinds tyvar uvar id pat)
| ExprWithTySig -- signature binding
(HsExpr tyvar uvar id pat)
\end{code}
\begin{code}
-pprExpr sty (HsVar v)
- = (if (isOpLexeme v) then ppParens else id) (ppr sty v)
+pprExpr sty (HsVar v) = pprNonSym sty v
pprExpr sty (HsLit lit) = ppr sty lit
pprExpr sty (HsLitOut lit _) = ppr sty lit
pprExpr sty expr@(HsApp e1 e2)
= let (fun, args) = collect_args expr [] in
- ppHang (pprParendExpr sty fun) 4 (ppSep (map (pprParendExpr sty) args))
+ ppHang (pprExpr sty fun) 4 (ppSep (map (pprExpr sty) args))
where
collect_args (HsApp fun arg) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
-
pprExpr sty (OpApp e1 op e2)
= case op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
- pp_e1 = pprParendExpr sty e1
- pp_e2 = pprParendExpr sty e2
+ pp_e1 = pprExpr sty e1
+ pp_e2 = pprExpr sty e2
pp_prefixly
- = ppHang (pprParendExpr sty op) 4 (ppSep [pp_e1, pp_e2])
+ = ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2])
pp_infixly v
- = ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]]
+ = ppSep [pp_e1, ppCat [pprSym sty v, pp_e2]]
-pprExpr sty (NegApp e)
- = ppBeside (ppChar '-') (ppParens (pprExpr sty e))
+pprExpr sty (NegApp e _)
+ = ppBeside (ppChar '-') (pprParendExpr sty e)
pprExpr sty (HsPar e)
= ppParens (pprExpr sty e)
-
pprExpr sty (SectionL expr op)
= case op of
HsVar v -> pp_infixly v
where
pp_expr = pprParendExpr sty expr
- pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op])
- 4 (ppCat [pp_expr, ppStr "_x )"])
+ pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op])
+ 4 (ppCat [pp_expr, ppStr "x_ )"])
pp_infixly v
= ppSep [ ppBeside ppLparen pp_expr,
- ppBeside (pprOp sty v) ppRparen ]
+ ppBeside (pprSym sty v) ppRparen ]
pprExpr sty (SectionR op expr)
= case op of
where
pp_expr = pprParendExpr sty expr
- pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppPStr SLIT("_x")])
+ pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op, ppPStr SLIT("x_")])
4 (ppBeside pp_expr ppRparen)
pp_infixly v
- = ppSep [ ppBeside ppLparen (pprOp sty v),
+ = ppSep [ ppBeside ppLparen (pprSym sty v),
ppBeside pp_expr ppRparen ]
-pprExpr sty (CCall fun args _ is_asm result_ty)
- = ppHang (if is_asm
- then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"]
- else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun))
- 4 (ppSep (map (pprParendExpr sty) args))
-
-pprExpr sty (HsSCC label expr)
- = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']),
- pprParendExpr sty expr ]
-
pprExpr sty (HsCase expr matches _)
= ppSep [ ppSep [ppPStr SLIT("case"), ppNest 4 (pprExpr sty expr), ppPStr SLIT("of")],
ppNest 2 (pprMatches sty (True, ppNil) matches) ]
-pprExpr sty (ListComp expr quals)
- = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
- 4 (ppSep [interpp'SP sty quals, ppRbrack])
+pprExpr sty (HsIf e1 e2 e3 _)
+ = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")],
+ ppNest 4 (pprExpr sty e2),
+ ppPStr SLIT("else"),
+ ppNest 4 (pprExpr sty e3)]
-- special case: let ... in let ...
pprExpr sty (HsLet binds expr@(HsLet _ _))
ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)]
pprExpr sty (HsDo stmts _)
- = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)]
+ = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts))
+pprExpr sty (HsDoOut stmts _ _ _)
+ = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts))
-pprExpr sty (HsIf e1 e2 e3 _)
- = ppSep [ppCat [ppPStr SLIT("if"), ppNest 2 (pprExpr sty e1), ppPStr SLIT("then")],
- ppNest 4 (pprExpr sty e2),
- ppPStr SLIT("else"),
- ppNest 4 (pprExpr sty e3)]
+pprExpr sty (ListComp expr quals)
+ = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|'])
+ 4 (ppSep [interpp'SP sty quals, ppRbrack])
pprExpr sty (ExplicitList exprs)
= ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs))
pprExpr sty (ExplicitTuple exprs)
= ppParens (ppInterleave ppComma (map (pprExpr sty) exprs))
-pprExpr sty (ExprWithTySig expr sig)
- = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")])
- 4 (ppBeside (ppr sty sig) ppRparen)
pprExpr sty (RecordCon con rbinds)
= pp_rbinds sty (ppr sty con) rbinds
pprExpr sty (RecordUpd aexp rbinds)
= pp_rbinds sty (pprParendExpr sty aexp) rbinds
+pprExpr sty (RecordUpdOut aexp _ rbinds)
+ = pp_rbinds sty (pprParendExpr sty aexp) rbinds
+
+pprExpr sty (ExprWithTySig expr sig)
+ = ppHang (ppBeside (ppNest 2 (pprExpr sty expr)) (ppPStr SLIT(" ::")))
+ 4 (ppr sty sig)
pprExpr sty (ArithSeqIn info)
= ppBracket (ppr sty info)
_ ->
ppBesides [ppLbrack, ppParens (ppr sty expr), ppr sty info, ppRbrack]
+pprExpr sty (CCall fun args _ is_asm result_ty)
+ = ppHang (if is_asm
+ then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"]
+ else ppBeside (ppPStr SLIT("_ccall_ ")) (ppPStr fun))
+ 4 (ppSep (map (pprParendExpr sty) args))
+
+pprExpr sty (HsSCC label expr)
+ = ppSep [ ppBeside (ppPStr SLIT("_scc_ ")) (ppBesides [ppChar '"', ppPStr label, ppChar '"']),
+ pprParendExpr sty expr ]
+
pprExpr sty (TyLam tyvars expr)
= ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"])
4 (pprExpr sty expr)
4 (pprExpr sty expr)
pprExpr sty (Dictionary dicts methods)
- = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
- ppBracket (interpp'SP sty dicts),
- ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
+ = ppSep [ppBesides [ppLparen, ppPStr SLIT("{-dict-}")],
+ ppBracket (interpp'SP sty dicts),
+ ppBesides [ppBracket (interpp'SP sty methods), ppRparen]]
pprExpr sty (SingleDict dname)
- = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
+ = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
+
+pprExpr sty (HsCon con tys exprs)
+ = ppCat [ppPStr SLIT("{-HsCon-}"), ppr sty con, interppSP sty tys, interppSP sty exprs]
\end{code}
Parenthesize unless very simple:
= ppHang thing 4
(ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}'])
where
- pp_rbind sty (v, _, True{-pun-}) = ppr sty v
- pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "<-", ppr sty e]
+ pp_rbind PprForUser (v, _, True) = ppr PprForUser v
+ pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e]
\end{code}
%************************************************************************
| ExprStmt (HsExpr tyvar uvar id pat)
SrcLoc
| LetStmt (HsBinds tyvar uvar id pat)
+
+ -- Translations; the types are the "a" and "b" types of the monad.
+ | BindStmtOut pat (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar)
+ | ExprStmtOut (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar)
\end{code}
\begin{code}
= ppCat [ppPStr SLIT("let"), ppr sty binds]
ppr sty (ExprStmt expr _)
= ppr sty expr
+ ppr sty (BindStmtOut pat expr _ _ _)
+ = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
+ ppr sty (ExprStmtOut expr _ _ _)
+ = ppr sty expr
\end{code}
%************************************************************************
``Qualifiers'' in list comprehensions:
\begin{code}
-data Qual tyvar uvar id pat
+data Qualifier tyvar uvar id pat
= GeneratorQual pat
(HsExpr tyvar uvar id pat)
| LetQual (HsBinds tyvar uvar id pat)
\begin{code}
instance (NamedThing id, Outputable id, Outputable pat,
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- Outputable (Qual tyvar uvar id pat) where
+ Outputable (Qualifier tyvar uvar id pat) where
ppr sty (GeneratorQual pat expr)
= ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
ppr sty (LetQual binds)
projects / ghc-hetmet.git / blobdiff