%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[HsExpr]{Abstract Haskell syntax: expressions}
\begin{code}
-#include "HsVersions.h"
-
module HsExpr where
-IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(HsLoop) -- for paranoia checking
+#include "HsVersions.h"
-- friends:
+import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match )
+
import HsBinds ( HsBinds )
-import HsBasic ( HsLit, Fixity(..), FixityDirection(..) )
-import HsMatches ( pprMatches, pprMatch, Match )
+import HsBasic ( HsLit )
+import BasicTypes ( Fixity(..), FixityDirection(..) )
import HsTypes ( HsType )
-- others:
-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 Name ( Name, NamedThing(..), isLexSym, occNameString )
+import Outputable
+import PprType ( pprType, pprParendType )
+import Type ( GenType )
+import Var ( GenTyVar, Id )
+import DataCon ( DataCon )
import SrcLoc ( SrcLoc )
-import Usage ( GenUsage{-instance-} )
---import Util ( panic{-ToDo:rm eventually-} )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-data HsExpr tyvar uvar id pat
+data HsExpr flexi id pat
= HsVar id -- variable
| HsLit HsLit -- literal
| HsLitOut HsLit -- TRANSLATION
- (GenType tyvar uvar) -- (with its type)
+ (GenType flexi) -- (with its type)
- | HsLam (Match tyvar uvar id pat) -- lambda
- | HsApp (HsExpr tyvar uvar id pat) -- application
- (HsExpr tyvar uvar id pat)
+ | HsLam (Match flexi id pat) -- lambda
+ | HsApp (HsExpr flexi id pat) -- application
+ (HsExpr flexi id pat)
-- Operator applications:
-- NB Bracketed ops such as (+) come out as Vars.
-- NB We need an expr for the operator in an OpApp/Section since
-- the typechecker may need to apply the operator to a few types.
- | OpApp (HsExpr tyvar uvar id pat) -- left operand
- (HsExpr tyvar uvar id pat) -- operator
+ | OpApp (HsExpr flexi id pat) -- left operand
+ (HsExpr flexi id pat) -- operator
Fixity -- Renamer adds fixity; bottom until then
- (HsExpr tyvar uvar id pat) -- right operand
+ (HsExpr flexi 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)
+ | NegApp (HsExpr flexi id pat) -- negated expr
+ (HsExpr flexi id pat) -- the negate id (in a HsVar)
- | HsPar (HsExpr tyvar uvar id pat) -- parenthesised expr
+ | HsPar (HsExpr flexi id pat) -- parenthesised expr
- | SectionL (HsExpr tyvar uvar id pat) -- operand
- (HsExpr tyvar uvar id pat) -- operator
- | SectionR (HsExpr tyvar uvar id pat) -- operator
- (HsExpr tyvar uvar id pat) -- operand
+ | SectionL (HsExpr flexi id pat) -- operand
+ (HsExpr flexi id pat) -- operator
+ | SectionR (HsExpr flexi id pat) -- operator
+ (HsExpr flexi id pat) -- operand
- | HsCase (HsExpr tyvar uvar id pat)
- [Match tyvar uvar id pat] -- must have at least one Match
+ | HsCase (HsExpr flexi id pat)
+ [Match flexi id pat] -- must have at least one Match
SrcLoc
- | HsIf (HsExpr tyvar uvar id pat) -- predicate
- (HsExpr tyvar uvar id pat) -- then part
- (HsExpr tyvar uvar id pat) -- else part
+ | HsIf (HsExpr flexi id pat) -- predicate
+ (HsExpr flexi id pat) -- then part
+ (HsExpr flexi id pat) -- else part
SrcLoc
- | HsLet (HsBinds tyvar uvar id pat) -- let(rec)
- (HsExpr tyvar uvar id pat)
+ | HsLet (HsBinds flexi id pat) -- let(rec)
+ (HsExpr flexi id pat)
- | HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts
+ | HsDo StmtCtxt
+ [Stmt flexi id pat] -- "do":one or more stmts
SrcLoc
- | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts
- id -- id for >>=, types applied
- id -- id for zero, typed applied
+ | HsDoOut StmtCtxt
+ [Stmt flexi id pat] -- "do":one or more stmts
+ id -- id for return
+ id -- id for >>=
+ id -- id for zero
+ (GenType flexi) -- Type of the whole expression
SrcLoc
- | 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]
+ [HsExpr flexi id pat]
| ExplicitListOut -- TRANSLATION
- (GenType tyvar uvar) -- Gives type of components of list
- [HsExpr tyvar uvar id pat]
+ (GenType flexi) -- Gives type of components of list
+ [HsExpr flexi id pat]
| ExplicitTuple -- tuple
- [HsExpr tyvar uvar id pat]
+ [HsExpr flexi id pat]
-- NB: Unit is ExplicitTuple []
-- for tuples, we can get the types
-- direct from the components
+ Bool -- boxed?
+
+ | HsCon DataCon -- TRANSLATION; a saturated constructor application
+ [GenType flexi]
+ [HsExpr flexi id pat]
-- Record construction
- | RecordCon (HsExpr tyvar uvar id pat) -- Always (HsVar id) until type checker,
- -- but the latter adds its type args too
- (HsRecordBinds tyvar uvar id pat)
+ | RecordCon id -- The constructor
+ (HsRecordBinds flexi id pat)
+
+ | RecordConOut DataCon
+ (HsExpr flexi id pat) -- Data con Id applied to type args
+ (HsRecordBinds flexi id pat)
+
-- Record update
- | RecordUpd (HsExpr tyvar uvar id pat)
- (HsRecordBinds tyvar uvar id pat)
+ | RecordUpd (HsExpr flexi id pat)
+ (HsRecordBinds flexi id pat)
- | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION
+ | RecordUpdOut (HsExpr flexi id pat) -- TRANSLATION
+ (GenType flexi) -- Type of *result* record (may differ from
+ -- type of input record)
[id] -- Dicts needed for construction
- (HsRecordBinds tyvar uvar id pat)
+ (HsRecordBinds flexi id pat)
| ExprWithTySig -- signature binding
- (HsExpr tyvar uvar id pat)
+ (HsExpr flexi id pat)
(HsType id)
| ArithSeqIn -- arithmetic sequence
- (ArithSeqInfo tyvar uvar id pat)
+ (ArithSeqInfo flexi id pat)
| ArithSeqOut
- (HsExpr tyvar uvar id pat) -- (typechecked, of course)
- (ArithSeqInfo tyvar uvar id pat)
+ (HsExpr flexi id pat) -- (typechecked, of course)
+ (ArithSeqInfo flexi id pat)
| CCall FAST_STRING -- call into the C world; string is
- [HsExpr tyvar uvar id pat] -- the C function; exprs are the
+ [HsExpr flexi id pat] -- the C function; exprs are the
-- arguments to pass.
Bool -- True <=> might cause Haskell
-- garbage-collection (must generate
-- NOTE: this CCall is the *boxed*
-- version; the desugarer will convert
-- it into the unboxed "ccall#".
- (GenType tyvar uvar) -- The result type; will be *bottom*
+ (GenType flexi) -- The result type; will be *bottom*
-- until the typechecker gets ahold of it
| HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation
- (HsExpr tyvar uvar id pat) -- expr whose cost is to be measured
+ (HsExpr flexi id pat) -- expr whose cost is to be measured
\end{code}
Everything from here on appears only in typechecker output.
\begin{code}
| TyLam -- TRANSLATION
- [tyvar]
- (HsExpr tyvar uvar id pat)
+ [GenTyVar flexi]
+ (HsExpr flexi id pat)
| TyApp -- TRANSLATION
- (HsExpr tyvar uvar id pat) -- generated by Spec
- [GenType tyvar uvar]
+ (HsExpr flexi id pat) -- generated by Spec
+ [GenType flexi]
-- DictLam and DictApp are "inverses"
| DictLam
[id]
- (HsExpr tyvar uvar id pat)
+ (HsExpr flexi id pat)
| DictApp
- (HsExpr tyvar uvar id pat)
+ (HsExpr flexi id pat)
[id]
- -- ClassDictLam and Dictionary are "inverses" (see note below)
- | ClassDictLam
- [id] -- superclass dicts
- [id] -- methods
- (HsExpr tyvar uvar id pat)
- | Dictionary
- [id] -- superclass dicts
- [id] -- methods
-
- | SingleDict -- a simple special case of Dictionary
- id -- local dictionary name
-
-type HsRecordBinds tyvar uvar id pat
- = [(id, HsExpr tyvar uvar id pat, Bool)]
+type HsRecordBinds flexi id pat
+ = [(id, HsExpr flexi id pat, Bool)]
-- True <=> source code used "punning",
-- i.e. {op1, op2} rather than {op1=e1, op2=e2}
\end{code}
\end{verbatim}
\begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- Outputable (HsExpr tyvar uvar id pat) where
- ppr = pprExpr
+instance (NamedThing id, Outputable id, Outputable pat) =>
+ Outputable (HsExpr flexi id pat) where
+ ppr expr = pprExpr expr
\end{code}
\begin{code}
-pprExpr sty (HsVar v) = ppr sty v
+pprExpr :: (NamedThing id, Outputable id, Outputable pat)
+ => HsExpr flexi id pat -> SDoc
+
+pprExpr e = pprDeeper (ppr_expr e)
+pprBinds b = pprDeeper (ppr b)
+
+ppr_expr (HsVar v) = ppr v
-pprExpr sty (HsLit lit) = ppr sty lit
-pprExpr sty (HsLitOut lit _) = ppr sty lit
+ppr_expr (HsLit lit) = ppr lit
+ppr_expr (HsLitOut lit _) = ppr lit
-pprExpr sty (HsLam match)
- = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)]
+ppr_expr (HsLam match)
+ = hsep [char '\\', nest 2 (pprMatch True match)]
-pprExpr sty expr@(HsApp e1 e2)
+ppr_expr expr@(HsApp e1 e2)
= let (fun, args) = collect_args expr [] in
- ppHang (pprExpr sty fun) 4 (ppSep (map (pprExpr sty) args))
+ (ppr_expr fun) <+> (sep (map ppr_expr args))
where
collect_args (HsApp fun arg) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
-pprExpr sty (OpApp e1 op fixity e2)
+ppr_expr (OpApp e1 op fixity e2)
= case op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
- pp_e1 = pprParendExpr sty e1 -- Add parens to make precedence clear
- pp_e2 = pprParendExpr sty e2
+ pp_e1 = pprParendExpr e1 -- Add parens to make precedence clear
+ pp_e2 = pprParendExpr e2
pp_prefixly
- = ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2])
+ = hang (pprExpr op) 4 (sep [pp_e1, pp_e2])
pp_infixly v
- = ppSep [pp_e1, ppCat [ppr sty v, pp_e2]]
+ = sep [pp_e1, hsep [pp_v, pp_e2]]
+ where
+ pp_v | isLexSym (occNameString (getOccName v)) = ppr v
+ | otherwise = char '`' <> ppr v <> char '`'
-pprExpr sty (NegApp e _)
- = ppBeside (ppChar '-') (pprParendExpr sty e)
+ppr_expr (NegApp e _)
+ = char '-' <+> pprParendExpr e
-pprExpr sty (HsPar e)
- = ppParens (pprExpr sty e)
+ppr_expr (HsPar e) = parens (ppr_expr e)
-pprExpr sty (SectionL expr op)
+ppr_expr (SectionL expr op)
= case op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
- pp_expr = pprParendExpr sty expr
+ pp_expr = pprParendExpr expr
- pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op])
- 4 (ppCat [pp_expr, ppStr "x_ )"])
- pp_infixly v
- = ppSep [ ppBeside ppLparen pp_expr,
- ppBeside (ppr sty v) ppRparen ]
+ pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
+ 4 (hsep [pp_expr, ptext SLIT("x_ )")])
+ pp_infixly v = parens (sep [pp_expr, ppr v])
-pprExpr sty (SectionR op expr)
+ppr_expr (SectionR op expr)
= case op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
- pp_expr = pprParendExpr sty expr
+ pp_expr = pprParendExpr expr
- pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op, ppPStr SLIT("x_")])
- 4 (ppBeside pp_expr ppRparen)
+ pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")])
+ 4 ((<>) pp_expr rparen)
pp_infixly v
- = ppSep [ ppBeside ppLparen (ppr sty v),
- ppBeside pp_expr ppRparen ]
+ = parens (sep [ppr v, pp_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) ]
+ppr_expr (HsCase expr matches _)
+ = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")],
+ nest 2 (pprMatches (True, empty) matches) ]
-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)]
+ppr_expr (HsIf e1 e2 e3 _)
+ = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")],
+ nest 4 (pprExpr e2),
+ ptext SLIT("else"),
+ nest 4 (pprExpr e3)]
-- special case: let ... in let ...
-pprExpr sty (HsLet binds expr@(HsLet _ _))
- = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppCat [ppr sty binds, ppPStr SLIT("in")]),
- ppr sty expr]
-
-pprExpr sty (HsLet binds expr)
- = ppSep [ppHang (ppPStr SLIT("let")) 2 (ppr sty binds),
- ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)]
-
-pprExpr sty (HsDo 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 (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 (ExplicitListOut ty exprs)
- = ppBesides [ ppBracket (ppInterleave ppComma (map (pprExpr sty) exprs)),
- ifnotPprForUser sty (ppBeside ppSP (ppParens (pprGenType sty ty))) ]
-
-pprExpr sty (ExplicitTuple exprs)
- = ppParens (ppInterleave ppComma (map (pprExpr sty) exprs))
-
-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)
-pprExpr sty (ArithSeqOut expr info)
- = case sty of
- PprForUser ->
- 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)
-
-pprExpr sty (TyApp expr [ty])
- = ppHang (pprExpr sty expr) 4 (pprParendGenType sty ty)
-
-pprExpr sty (TyApp expr tys)
- = ppHang (pprExpr sty expr)
- 4 (ppBracket (interpp'SP sty tys))
-
-pprExpr sty (DictLam dictvars expr)
- = ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"])
- 4 (pprExpr sty expr)
-
-pprExpr sty (DictApp expr [dname])
- = ppHang (pprExpr sty expr) 4 (ppr sty dname)
-
-pprExpr sty (DictApp expr dnames)
- = ppHang (pprExpr sty expr)
- 4 (ppBracket (interpp'SP sty dnames))
-
-pprExpr sty (ClassDictLam dicts methods expr)
- = ppHang (ppCat [ppStr "\\{-classdict-}",
- ppBracket (interppSP sty dicts),
- ppBracket (interppSP sty methods),
- ppStr "->"])
- 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]]
-
-pprExpr sty (SingleDict dname)
- = ppCat [ppPStr SLIT("{-singleDict-}"), ppr sty dname]
+ppr_expr (HsLet binds expr@(HsLet _ _))
+ = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
+ pprExpr expr]
+
+ppr_expr (HsLet binds expr)
+ = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
+ hang (ptext SLIT("in")) 2 (ppr expr)]
+
+ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
+ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts
+
+ppr_expr (ExplicitList exprs)
+ = brackets (fsep (punctuate comma (map ppr_expr exprs)))
+ppr_expr (ExplicitListOut ty exprs)
+ = hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))),
+ ifNotPprForUser ((<>) space (parens (pprType ty))) ]
+
+ppr_expr (ExplicitTuple exprs True)
+ = parens (sep (punctuate comma (map ppr_expr exprs)))
+
+ppr_expr (ExplicitTuple exprs False)
+ = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)")
+
+ppr_expr (HsCon con_id tys args)
+ = ppr con_id <+> sep (map pprParendType tys ++
+ map pprParendExpr args)
+
+ppr_expr (RecordCon con_id rbinds)
+ = pp_rbinds (ppr con_id) rbinds
+ppr_expr (RecordConOut data_con con rbinds)
+ = pp_rbinds (ppr con) rbinds
+
+ppr_expr (RecordUpd aexp rbinds)
+ = pp_rbinds (pprParendExpr aexp) rbinds
+ppr_expr (RecordUpdOut aexp _ _ rbinds)
+ = pp_rbinds (pprParendExpr aexp) rbinds
+
+ppr_expr (ExprWithTySig expr sig)
+ = hang (nest 2 (ppr_expr expr) <+> ptext SLIT("::"))
+ 4 (ppr sig)
+
+ppr_expr (ArithSeqIn info)
+ = brackets (ppr info)
+ppr_expr (ArithSeqOut expr info)
+ = brackets (ppr info)
+
+ppr_expr (CCall fun args _ is_asm result_ty)
+ = hang (if is_asm
+ then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''")
+ else ptext SLIT("_ccall_") <+> ptext fun)
+ 4 (sep (map pprParendExpr args))
+
+ppr_expr (HsSCC label expr)
+ = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ptext label), pprParendExpr expr ]
+
+ppr_expr (TyLam tyvars expr)
+ = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")])
+ 4 (ppr_expr expr)
+
+ppr_expr (TyApp expr [ty])
+ = hang (ppr_expr expr) 4 (pprParendType ty)
+
+ppr_expr (TyApp expr tys)
+ = hang (ppr_expr expr)
+ 4 (brackets (interpp'SP tys))
+
+ppr_expr (DictLam dictvars expr)
+ = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP dictvars, ptext SLIT("->")])
+ 4 (ppr_expr expr)
+
+ppr_expr (DictApp expr [dname])
+ = hang (ppr_expr expr) 4 (ppr dname)
+
+ppr_expr (DictApp expr dnames)
+ = hang (ppr_expr expr)
+ 4 (brackets (interpp'SP dnames))
\end{code}
Parenthesize unless very simple:
\begin{code}
-pprParendExpr :: (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => PprStyle -> HsExpr tyvar uvar id pat -> Pretty
+pprParendExpr :: (NamedThing id, Outputable id, Outputable pat)
+ => HsExpr flexi id pat -> SDoc
-pprParendExpr sty expr
+pprParendExpr expr
= let
- pp_as_was = pprExpr sty expr
+ pp_as_was = pprExpr expr
in
case expr of
- HsLit l -> ppr sty l
- HsLitOut l _ -> ppr sty l
+ HsLit l -> ppr l
+ HsLitOut l _ -> ppr l
HsVar _ -> pp_as_was
ExplicitList _ -> pp_as_was
ExplicitListOut _ _ -> pp_as_was
- ExplicitTuple _ -> pp_as_was
+ ExplicitTuple _ _ -> pp_as_was
HsPar _ -> pp_as_was
- _ -> ppParens pp_as_was
+ _ -> parens pp_as_was
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-pp_rbinds :: (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => PprStyle -> Pretty
- -> HsRecordBinds tyvar uvar id pat -> Pretty
-
-pp_rbinds sty thing rbinds
- = ppHang thing
- 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds)))
+pp_rbinds :: (NamedThing id, Outputable id, Outputable pat)
+ => SDoc
+ -> HsRecordBinds flexi id pat -> SDoc
+
+pp_rbinds thing rbinds
+ = hang thing
+ 4 (braces (hsep (punctuate comma (map (pp_rbind) rbinds))))
where
- pp_rbind PprForUser (v, _, True) = ppr PprForUser v
- pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e]
+ pp_rbind (v, e, pun_flag)
+ = getPprStyle $ \ sty ->
+ if pun_flag && userStyle sty then
+ ppr v
+ else
+ hsep [ppr v, char '=', ppr e]
\end{code}
%************************************************************************
%* *
-\subsection{Do stmts}
+\subsection{Do stmts and list comprehensions}
%* *
%************************************************************************
\begin{code}
-data Stmt tyvar uvar id pat
+data StmtCtxt -- Context of a Stmt
+ = DoStmt -- Do Statment
+ | ListComp -- List comprehension
+ | CaseAlt -- Guard on a case alternative
+ | PatBindRhs -- Guard on a pattern binding
+ | FunRhs Name -- Guard on a function defn for f
+ | LambdaBody -- Body of a lambda abstraction
+
+pprDo DoStmt stmts
+ = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
+pprDo ListComp stmts
+ = brackets $
+ hang (pprExpr expr <+> char '|')
+ 4 (interpp'SP quals)
+ where
+ ReturnStmt expr = last stmts -- Last stmt should be a ReturnStmt for list comps
+ quals = init stmts
+\end{code}
+
+\begin{code}
+data Stmt flexi id pat
= BindStmt pat
- (HsExpr tyvar uvar id pat)
+ (HsExpr flexi id pat)
SrcLoc
- | ExprStmt (HsExpr tyvar uvar id pat)
+
+ | LetStmt (HsBinds flexi id pat)
+
+ | GuardStmt (HsExpr flexi id pat) -- List comps only
+ SrcLoc
+
+ | ExprStmt (HsExpr flexi id pat) -- Do stmts; and guarded things at the end
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)
+
+ | ReturnStmt (HsExpr flexi id pat) -- List comps only, at the end
\end{code}
\begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- Outputable (Stmt tyvar uvar id pat) where
- ppr sty (BindStmt pat expr _)
- = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
- ppr sty (LetStmt binds)
- = 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
+instance (NamedThing id, Outputable id, Outputable pat) =>
+ Outputable (Stmt flexi id pat) where
+ ppr stmt = pprStmt stmt
+
+pprStmt (BindStmt pat expr _)
+ = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
+pprStmt (LetStmt binds)
+ = hsep [ptext SLIT("let"), pprBinds binds]
+pprStmt (ExprStmt expr _)
+ = ppr expr
+pprStmt (GuardStmt expr _)
+ = ppr expr
+pprStmt (ReturnStmt expr)
+ = hsep [ptext SLIT("return"), ppr expr]
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-data ArithSeqInfo tyvar uvar id pat
- = From (HsExpr tyvar uvar id pat)
- | FromThen (HsExpr tyvar uvar id pat)
- (HsExpr tyvar uvar id pat)
- | FromTo (HsExpr tyvar uvar id pat)
- (HsExpr tyvar uvar id pat)
- | FromThenTo (HsExpr tyvar uvar id pat)
- (HsExpr tyvar uvar id pat)
- (HsExpr tyvar uvar id pat)
-\end{code}
-
-\begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- Outputable (ArithSeqInfo tyvar uvar id pat) where
- ppr sty (From e1) = ppBesides [ppr sty e1, pp_dotdot]
- ppr sty (FromThen e1 e2) = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot]
- ppr sty (FromTo e1 e3) = ppBesides [ppr sty e1, pp_dotdot, ppr sty e3]
- ppr sty (FromThenTo e1 e2 e3)
- = ppBesides [ppr sty e1, pp'SP, ppr sty e2, pp_dotdot, ppr sty e3]
-
-pp_dotdot = ppPStr SLIT(" .. ")
-\end{code}
-
-``Qualifiers'' in list comprehensions:
-\begin{code}
-data Qualifier tyvar uvar id pat
- = GeneratorQual pat
- (HsExpr tyvar uvar id pat)
- | LetQual (HsBinds tyvar uvar id pat)
- | FilterQual (HsExpr tyvar uvar id pat)
+data ArithSeqInfo flexi id pat
+ = From (HsExpr flexi id pat)
+ | FromThen (HsExpr flexi id pat)
+ (HsExpr flexi id pat)
+ | FromTo (HsExpr flexi id pat)
+ (HsExpr flexi id pat)
+ | FromThenTo (HsExpr flexi id pat)
+ (HsExpr flexi id pat)
+ (HsExpr flexi id pat)
\end{code}
\begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
- Outputable (Qualifier tyvar uvar id pat) where
- ppr sty (GeneratorQual pat expr)
- = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
- ppr sty (LetQual binds)
- = ppCat [ppPStr SLIT("let"), ppr sty binds]
- ppr sty (FilterQual expr)
- = ppr sty expr
+instance (NamedThing id, Outputable id, Outputable pat) =>
+ Outputable (ArithSeqInfo flexi id pat) where
+ ppr (From e1) = hcat [ppr e1, pp_dotdot]
+ ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
+ ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3]
+ ppr (FromThenTo e1 e2 e3)
+ = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
+
+pp_dotdot = ptext SLIT(" .. ")
\end{code}
projects / ghc-hetmet.git / blobdiff