-----------------------------------------------------------
-- MetaHaskell Extensions
+
| HsBracket (HsBracket id)
| HsBracketOut (HsBracket Name) -- Output of the type checker is the *original*
-- always has an empty stack
---------------------------------------
- -- Hpc Support
-
- | HsTick
- Int -- module-local tick number
- (LHsExpr id) -- sub-expression
-
- | HsBinTick
- Int -- module-local tick number for True
- Int -- module-local tick number for False
- (LHsExpr id) -- sub-expression
-
- ---------------------------------------
-- The following are commands, not expressions proper
| HsArrApp -- Arrow tail, or arrow application (f -< arg)
(Maybe Fixity) -- fixity (filled in by the renamer), for forms that
-- were converted from OpApp's by the renamer
[LHsCmdTop id] -- argument commands
-\end{code}
-These constructors only appear temporarily in the parser.
-The renamer translates them into the Right Thing.
+ ---------------------------------------
+ -- Haskell program coverage (Hpc) Support
+
+ | HsTick
+ Int -- module-local tick number
+ (LHsExpr id) -- sub-expression
+
+ | HsBinTick
+ Int -- module-local tick number for True
+ Int -- module-local tick number for False
+ (LHsExpr id) -- sub-expression
+
+ | HsTickPragma -- A pragma introduced tick
+ (FastString,(Int,Int),(Int,Int)) -- external span for this tick
+ (LHsExpr id)
+
+ ---------------------------------------
+ -- These constructors only appear temporarily in the parser.
+ -- The renamer translates them into the Right Thing.
-\begin{code}
| EWildPat -- wildcard
| EAsPat (Located id) -- as pattern
| ELazyPat (LHsExpr id) -- ~ pattern
| HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y
-\end{code}
-Everything from here on appears only in typechecker output.
+ ---------------------------------------
+ -- Finally, HsWrap appears only in typechecker output
-\begin{code}
| HsWrap HsWrapper -- TRANSLATION
(HsExpr id)
\end{code}
\begin{code}
+-- pprExpr and pprLExpr call pprDeeper;
+-- the underscore versions do not
pprExpr :: OutputableBndr id => HsExpr id -> SDoc
-
pprExpr e = pprDeeper (ppr_expr e)
+pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
+pprLExpr e = pprDeeper (ppr_expr (unLoc e))
+
pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc
pprBinds b = pprDeeper (ppr b)
ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
ppr_expr (ExplicitList _ exprs)
- = brackets (fsep (punctuate comma (map ppr_lexpr exprs)))
+ = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (ExplicitPArr _ exprs)
- = pa_brackets (fsep (punctuate comma (map ppr_lexpr exprs)))
+ = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (ExplicitTuple exprs boxity)
- = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
+ = tupleParens boxity (pprDeeperList sep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (RecordCon con_id con_expr rbinds)
= pp_rbinds (ppr con_id) rbinds
ppr tickIdFalse,
ptext SLIT(">("),
ppr exp,ptext SLIT(")")]
+ppr_expr (HsTickPragma externalSrcLoc exp)
+ = hcat [ptext SLIT("tickpragma<"), ppr externalSrcLoc,ptext SLIT(">("), ppr exp,ptext SLIT(")")]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
= hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg]
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprParendExpr expr
= let
- pp_as_was = ppr_lexpr expr
- -- Using ppr_expr here avoids the call to 'deeper'
- -- Not sure if that's always right.
+ pp_as_was = pprLExpr expr
+ -- Using pprLExpr makes sure that we go 'deeper'
+ -- I think that is usually (always?) right
in
case unLoc expr of
HsLit l -> ppr l
HsPar _ -> pp_as_was
HsBracket _ -> pp_as_was
HsBracketOut _ [] -> pp_as_was
-
_ -> parens pp_as_was
\end{code}
%************************************************************************
\begin{code}
-type HsRecordBinds id = [(Located id, LHsExpr id)]
+data HsRecordBinds id = HsRecordBinds [(Located id, LHsExpr id)]
recBindFields :: HsRecordBinds id -> [id]
-recBindFields rbinds = [unLoc field | (field,_) <- rbinds]
+recBindFields (HsRecordBinds rbinds) = [unLoc field | (field,_) <- rbinds]
pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc
-pp_rbinds thing rbinds
+pp_rbinds thing (HsRecordBinds rbinds)
= hang thing
- 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds))))
+ 4 (braces (pprDeeperList sep (punctuate comma (map (pp_rbind) rbinds))))
where
pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e]
\end{code}
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
pprGRHSs ctxt (GRHSs grhss binds)
- = vcat (map (pprGRHS ctxt . unLoc) grhss)
- $$
- (if isEmptyLocalBinds binds then empty
+ = pprDeeper
+ (vcat (map (pprGRHS ctxt . unLoc) grhss)
+ $$
+ if isEmptyLocalBinds binds then empty
else text "where" $$ nest 4 (pprBinds binds))
pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment))
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
-pprDo DoExpr stmts body = ptext SLIT("do") <+> (vcat (map ppr stmts) $$ ppr body)
-pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> (vcat (map ppr stmts) $$ ppr body)
+pprDo DoExpr stmts body = ptext SLIT("do") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
+pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
pprDo ListComp stmts body = pprComp brackets stmts body
pprDo PArrComp stmts body = pprComp pa_brackets stmts body
pprDo other stmts body = panic "pprDo" -- PatGuard, ParStmtCxt
projects / ghc-hetmet.git / blobdiff