%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[HsExpr]{Abstract Haskell syntax: expressions}
+
+HsExpr: Abstract Haskell syntax: expressions
\begin{code}
module HsExpr where
#include "HsVersions.h"
-- friends:
-import HsDecls ( HsGroup )
-import HsPat ( LPat )
-import HsLit ( HsLit(..), HsOverLit )
-import HsTypes ( LHsType, PostTcType )
-import HsImpExp ( isOperator, pprHsVar )
-import HsBinds ( HsLocalBinds, DictBinds, ExprCoFn, isEmptyLocalBinds )
+import HsDecls
+import HsPat
+import HsLit
+import HsTypes
+import HsImpExp
+import HsBinds
-- others:
-import Type ( Type, pprParendType )
-import Var ( TyVar, Id )
-import Name ( Name )
-import BasicTypes ( IPName, Boxity, tupleParens, Arity, Fixity(..) )
-import SrcLoc ( Located(..), unLoc )
+import Var
+import Name
+import BasicTypes
+import DataCon
+import SrcLoc
import Outputable
import FastString
\end{code}
-- Record update
| RecordUpd (LHsExpr id)
(HsRecordBinds id)
- PostTcType -- Type of *input* record
- PostTcType -- Type of *result* record (may differ from
- -- type of input record)
+ [DataCon] -- Filled in by the type checker to the *non-empty*
+ -- list of DataCons that have all the upd'd fields
+ [PostTcType] -- Argument types of *input* record type
+ [PostTcType] -- and *output* record type
+ -- For a type family, the arg types are of the *instance* tycon, not the family tycon
| ExprWithTySig -- e :: type
(LHsExpr id)
-----------------------------------------------------------
-- MetaHaskell Extensions
+
| HsBracket (HsBracket id)
| HsBracketOut (HsBracket Name) -- Output of the type checker is the *original*
(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
+ [id] -- variables in scope
+ (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.
-
-\begin{code}
- | TyLam -- TRANSLATION
- [TyVar]
- (LHsExpr id)
- | TyApp -- TRANSLATION
- (LHsExpr id) -- generated by Spec
- [Type]
-
- -- DictLam and DictApp are "inverses"
- | DictLam
- [id]
- (LHsExpr id)
- | DictApp
- (LHsExpr id)
- [id]
+ ---------------------------------------
+ -- Finally, HsWrap appears only in typechecker output
- | HsCoerce ExprCoFn -- TRANSLATION
+ | HsWrap HsWrapper -- TRANSLATION
(HsExpr id)
type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
\end{code}
\begin{code}
-pprExpr :: OutputableBndr id => HsExpr id -> SDoc
+-----------------------
+-- pprExpr, pprLExpr, pprBinds call pprDeeper;
+-- the underscore versions do not
+pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
+pprLExpr (L _ e) = pprExpr e
-pprExpr e = pprDeeper (ppr_expr e)
+pprExpr :: OutputableBndr id => HsExpr id -> SDoc
+pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e
+ | otherwise = pprDeeper (ppr_expr e)
+
+isQuietHsExpr :: HsExpr id -> Bool
+-- Parentheses do display something, but it gives little info and
+-- if we go deeper when we go inside them then we get ugly things
+-- like (...)
+isQuietHsExpr (HsPar _) = True
+-- applications don't display anything themselves
+isQuietHsExpr (HsApp _ _) = True
+isQuietHsExpr (OpApp _ _ _ _) = True
+isQuietHsExpr _ = False
pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc
pprBinds b = pprDeeper (ppr b)
+-----------------------
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
+ppr_expr (HsPar e) = parens (ppr_lexpr e)
+
+ppr_expr (HsCoreAnn s e)
+ = vcat [ptext SLIT("HsCoreAnn") <+> ftext s, ppr_lexpr e]
ppr_expr (HsApp e1 e2)
= let (fun, args) = collect_args e1 [e2] in
- (ppr_lexpr fun) <+> (sep (map pprParendExpr args))
+ hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
where
collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
pp_e2 = pprParendExpr e2
pp_prefixly
- = hang (ppr op) 4 (sep [pp_e1, pp_e2])
+ = hang (ppr op) 2 (sep [pp_e1, pp_e2])
pp_infixly v
- = sep [pp_e1, hsep [pprInfix v, pp_e2]]
+ = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
-ppr_expr (HsPar e) = parens (ppr_lexpr e)
-
ppr_expr (SectionL expr op)
= case unLoc op of
HsVar v -> pp_infixly v
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)))
ppr_expr (RecordCon con_id con_expr rbinds)
= pp_rbinds (ppr con_id) rbinds
-ppr_expr (RecordUpd aexp rbinds _ _)
+ppr_expr (RecordUpd aexp rbinds _ _ _)
= pp_rbinds (pprParendExpr aexp) rbinds
ppr_expr (ExprWithTySig expr sig)
ppr_expr (HsSCC lbl expr)
= sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ]
-ppr_expr (TyLam tyvars expr)
- = hang (hsep [ptext SLIT("/\\"),
- hsep (map (pprBndr LambdaBind) tyvars),
- ptext SLIT("->")])
- 4 (ppr_lexpr expr)
-
-ppr_expr (TyApp expr [ty])
- = hang (ppr_lexpr expr) 4 (pprParendType ty)
-
-ppr_expr (TyApp expr tys)
- = hang (ppr_lexpr expr)
- 4 (brackets (interpp'SP tys))
-
-ppr_expr (DictLam dictvars expr)
- = hang (hsep [ptext SLIT("\\{-dict-}"),
- hsep (map (pprBndr LambdaBind) dictvars),
- ptext SLIT("->")])
- 4 (ppr_lexpr expr)
-
-ppr_expr (DictApp expr [dname])
- = hang (ppr_lexpr expr) 4 (ppr dname)
-
-ppr_expr (DictApp expr dnames)
- = hang (ppr_lexpr expr)
- 4 (brackets (interpp'SP dnames))
-
-ppr_expr (HsCoerce co_fn e) = ppr_expr e
-
-ppr_expr (HsType id) = ppr id
+ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
+ppr_expr (HsType id) = ppr id
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
+ppr_expr (HsTick tickId vars exp)
+ = hcat [ptext SLIT("tick<"), ppr tickId,ptext SLIT(">("), hsep (map pprHsVar vars), ppr exp,ptext SLIT(")")]
+ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
+ = hcat [ptext SLIT("bintick<"),
+ ppr tickIdTrue,
+ ptext SLIT(","),
+ 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]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
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
- HsOverLit l -> ppr l
-
- HsVar _ -> pp_as_was
- HsIPVar _ -> pp_as_was
- ExplicitList _ _ -> pp_as_was
- ExplicitPArr _ _ -> pp_as_was
- ExplicitTuple _ _ -> pp_as_was
- HsPar _ -> pp_as_was
- HsBracket _ -> pp_as_was
- HsBracketOut _ [] -> pp_as_was
-
- _ -> parens pp_as_was
+ HsLit l -> pp_as_was
+ HsOverLit l -> pp_as_was
+ HsVar _ -> pp_as_was
+ HsIPVar _ -> pp_as_was
+ ExplicitList _ _ -> pp_as_was
+ ExplicitPArr _ _ -> pp_as_was
+ ExplicitTuple _ _ -> pp_as_was
+ HsPar _ -> pp_as_was
+ HsBracket _ -> pp_as_was
+ HsBracketOut _ [] -> pp_as_was
+ HsDo sc _ _ _
+ | isListCompExpr sc -> pp_as_was
+ _ -> parens pp_as_was
+
+isAtomicHsExpr :: HsExpr id -> Bool -- A single token
+isAtomicHsExpr (HsVar {}) = True
+isAtomicHsExpr (HsLit {}) = True
+isAtomicHsExpr (HsOverLit {}) = True
+isAtomicHsExpr (HsIPVar {}) = True
+isAtomicHsExpr (HsWrap _ e) = isAtomicHsExpr e
+isAtomicHsExpr (HsPar e) = isAtomicHsExpr (unLoc e)
+isAtomicHsExpr e = False
\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}
(GRHSs id)
matchGroupArity :: MatchGroup id -> Arity
+matchGroupArity (MatchGroup [] _)
+ = panic "matchGroupArity" -- MatchGroup is never empty
matchGroupArity (MatchGroup (match:matches) _)
= ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
-- Assertion just checks that all the matches have the same number of pats
\begin{code}
pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
-pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches))
+pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc matches))
+ -- Don't print the type; it's only
+ -- a place-holder before typechecking
-- Exported to HsBinds, which can't see the defn of HsMatchContext
pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
pprGRHSs ctxt (GRHSs grhss binds)
= vcat (map (pprGRHS ctxt . unLoc) grhss)
- $$
- (if isEmptyLocalBinds binds then empty
- else text "where" $$ nest 4 (pprBinds binds))
+ $$ 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 = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts) $$ ppr body)
-pprDo (MDoExpr _) stmts body = hang (ptext SLIT("mdo")) 3 (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
pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
isDoExpr :: HsStmtContext id -> Bool
isDoExpr DoExpr = True
isDoExpr (MDoExpr _) = True
-isDoExpr other = False
+isDoExpr _ = False
+
+isListCompExpr :: HsStmtContext id -> Bool
+isListCompExpr ListComp = True
+isListCompExpr PArrComp = True
+isListCompExpr _ = False
\end{code}
\begin{code}
pprMatchContext ProcExpr = ptext SLIT("an arrow abstraction")
pprMatchContext (StmtCtxt ctxt) = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt
-pprMatchRhsContext (FunRhs fun) = ptext SLIT("a right-hand side of function") <+> quotes (ppr fun)
-pprMatchRhsContext CaseAlt = ptext SLIT("the body of a case alternative")
-pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern binding")
-pprMatchRhsContext LambdaExpr = ptext SLIT("the body of a lambda")
-pprMatchRhsContext ProcExpr = ptext SLIT("the body of a proc")
-pprMatchRhsContext RecUpd = panic "pprMatchRhsContext"
-
pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c]
pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext DoExpr = ptext SLIT("a 'do' expression")
pprStmtContext ListComp = ptext SLIT("a list comprehension")
pprStmtContext PArrComp = ptext SLIT("an array comprehension")
+{-
+pprMatchRhsContext (FunRhs fun) = ptext SLIT("a right-hand side of function") <+> quotes (ppr fun)
+pprMatchRhsContext CaseAlt = ptext SLIT("the body of a case alternative")
+pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern binding")
+pprMatchRhsContext LambdaExpr = ptext SLIT("the body of a lambda")
+pprMatchRhsContext ProcExpr = ptext SLIT("the body of a proc")
+pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt
+
-- Used for the result statement of comprehension
-- e.g. the 'e' in [ e | ... ]
-- or the 'r' in f x = r
pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt
pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext other
-
+-}
-- Used to generate the string for a *runtime* error message
matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun)