-- friends:
import HsBinds ( HsBinds(..), nullBinds )
+import HsTypes ( PostTcType )
import HsLit ( HsLit, HsOverLit )
import BasicTypes ( Fixity(..) )
import HsTypes ( HsType )
-- others:
import Name ( Name )
+import ForeignCall ( Safety )
import Outputable
import PprType ( pprParendType )
-import Type ( Type )
+import Type ( Type )
import Var ( TyVar )
import DataCon ( DataCon )
import CStrings ( CLabelString, pprCLabelString )
-import BasicTypes ( Boxity, tupleParens )
+import BasicTypes ( IPName, Boxity, tupleParens )
import SrcLoc ( SrcLoc )
\end{code}
\begin{code}
data HsExpr id pat
= HsVar id -- variable
- | HsIPVar id -- implicit parameter
+ | HsIPVar (IPName id) -- implicit parameter
| HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker
| HsLit HsLit -- Simple (non-overloaded) literals
-- They are eventually removed by the type checker.
| NegApp (HsExpr id pat) -- negated expr
+ Name -- Name of 'negate' (see RnEnv.lookupSyntaxName)
| HsPar (HsExpr id pat) -- parenthesised expr
(HsExpr id pat)
| HsWith (HsExpr id pat) -- implicit parameter binding
- [(id, HsExpr id pat)]
+ [(IPName id, HsExpr id pat)]
- | HsDo HsMatchContext
+ | HsDo HsDoContext
[Stmt id pat] -- "do":one or more stmts
SrcLoc
- | HsDoOut HsMatchContext
+ | HsDoOut HsDoContext
[Stmt id pat] -- "do":one or more stmts
id -- id for return
id -- id for >>=
SrcLoc
| ExplicitList -- syntactic list
+ PostTcType -- Gives type of components of list
[HsExpr id pat]
- | ExplicitListOut -- TRANSLATION
- Type -- Gives type of components of list
+
+ | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:]
+ PostTcType -- type of elements of the parallel array
[HsExpr id pat]
| ExplicitTuple -- tuple
(HsRecordBinds id pat)
| RecordUpdOut (HsExpr id pat) -- TRANSLATION
+ Type -- Type of *input* record
Type -- Type of *result* record (may differ from
- -- type of input record)
+ -- type of input record)
[id] -- Dicts needed for construction
(HsRecordBinds id pat)
| ArithSeqOut
(HsExpr id pat) -- (typechecked, of course)
(ArithSeqInfo id pat)
+ | PArrSeqIn -- arith. sequence for parallel array
+ (ArithSeqInfo id pat) -- [:e1..e2:] or [:e1, e2..e3:]
+ | PArrSeqOut
+ (HsExpr id pat) -- (typechecked, of course)
+ (ArithSeqInfo id pat)
| HsCCall CLabelString -- call into the C world; string is
[HsExpr id pat] -- the C function; exprs are the
-- arguments to pass.
- Bool -- True <=> might cause Haskell
+ Safety -- True <=> might cause Haskell
-- garbage-collection (must generate
-- more paranoid code)
Bool -- True <=> it's really a "casm"
-- NOTE: this CCall is the *boxed*
-- version; the desugarer will convert
-- it into the unboxed "ccall#".
- Type -- The result type; will be *bottom*
+ PostTcType -- The result type; will be *bottom*
-- until the typechecker gets ahold of it
| HsSCC FAST_STRING -- "set cost centre" (_scc_) annotation
| isOperator v = parens (ppr v)
| otherwise = ppr v
-ppr_expr (HsIPVar v) = char '?' <> ppr v
+ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsLit lit) = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
ppr_expr (HsLam match)
- = hsep [char '\\', nest 2 (pprMatch (True,empty) match)]
+ = hsep [char '\\', nest 2 (pprMatch LambdaExpr match)]
ppr_expr expr@(HsApp e1 e2)
= let (fun, args) = collect_args expr [] in
| otherwise = char '`' <> ppr v <> char '`'
-- Put it in backquotes if it's not an operator already
-ppr_expr (NegApp e) = char '-' <+> pprParendExpr e
+ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
ppr_expr (HsPar e) = parens (ppr_expr e)
ppr_expr (HsCase expr matches _)
= sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")],
- nest 2 (pprMatches (True, empty) matches) ]
+ nest 2 (pprMatches CaseAlt matches) ]
ppr_expr (HsIf e1 e2 e3 _)
= sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")],
hang (ptext SLIT("in")) 2 (ppr expr)]
ppr_expr (HsWith expr binds)
- = hsep [ppr expr, ptext SLIT("with"), ppr binds]
+ = hsep [ppr expr, ptext SLIT("with"), pp_ipbinds binds]
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)
+ppr_expr (ExplicitList _ exprs)
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
+ppr_expr (ExplicitPArr _ exprs)
+ = pabrackets (fsep (punctuate comma (map ppr_expr exprs)))
+
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens boxity (sep (punctuate comma (map ppr_expr exprs)))
ppr_expr (RecordUpd aexp rbinds)
= pp_rbinds (pprParendExpr aexp) rbinds
-ppr_expr (RecordUpdOut aexp _ _ rbinds)
+ppr_expr (RecordUpdOut aexp _ _ _ rbinds)
= pp_rbinds (pprParendExpr aexp) rbinds
ppr_expr (ExprWithTySig expr sig)
ppr_expr (ArithSeqOut expr info)
= brackets (ppr info)
+ppr_expr (PArrSeqIn info)
+ = pabrackets (ppr info)
+ppr_expr (PArrSeqOut expr info)
+ = pabrackets (ppr info)
+
ppr_expr EWildPat = char '_'
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e
4 (brackets (interpp'SP dnames))
ppr_expr (HsType id) = ppr id
-
+
+-- add parallel array brackets around a document
+--
+pabrackets :: SDoc -> SDoc
+pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
\end{code}
Parenthesize unless very simple:
HsVar _ -> pp_as_was
HsIPVar _ -> pp_as_was
- ExplicitList _ -> pp_as_was
- ExplicitListOut _ _ -> pp_as_was
+ ExplicitList _ _ -> pp_as_was
+ ExplicitPArr _ _ -> pp_as_was
ExplicitTuple _ _ -> pp_as_was
HsPar _ -> pp_as_was
hsep [ppr v, char '=', ppr e]
\end{code}
+\begin{code}
+pp_ipbinds :: (Outputable id, Outputable pat)
+ => [(IPName id, HsExpr id pat)] -> SDoc
+pp_ipbinds pairs = hsep (punctuate semi (map pp_item pairs))
+ where
+ pp_item (id,rhs) = ppr id <+> equals <+> ppr_expr rhs
+\end{code}
%************************************************************************
\begin{code}
data Match id pat
= Match
- [id] -- Tyvars wrt which this match is universally quantified
- -- empty after typechecking
[pat] -- The patterns
(Maybe (HsType id)) -- A type signature for the result of the match
-- Nothing after typechecking
data GRHSs id pat
= GRHSs [GRHS id pat] -- Guarded RHSs
(HsBinds id pat) -- The where clause
- (Maybe Type) -- Just rhs_ty after type checking
+ PostTcType -- Type of RHS (after type checking)
data GRHS id pat
- = GRHS [Stmt id pat] -- The RHS is the final ExprStmt
+ = GRHS [Stmt id pat] -- The RHS is the final ResultStmt
-- I considered using a RetunStmt, but
-- it printed 'wrong' in error messages
SrcLoc
-mkSimpleMatch :: [pat] -> HsExpr id pat -> Maybe Type -> SrcLoc -> Match id pat
-mkSimpleMatch pats rhs maybe_rhs_ty locn
- = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty)
+mkSimpleMatch :: [pat] -> HsExpr id pat -> Type -> SrcLoc -> Match id pat
+mkSimpleMatch pats rhs rhs_ty locn
+ = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty)
unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat]
-unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc]
+unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc]
\end{code}
@getMatchLoc@ takes a @Match@ and returns the
\begin{code}
getMatchLoc :: Match id pat -> SrcLoc
-getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
+getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
\end{code}
We know the list must have at least one @Match@ in it.
\begin{code}
pprMatches :: (Outputable id, Outputable pat)
- => (Bool, SDoc) -> [Match id pat] -> SDoc
-pprMatches print_info matches = vcat (map (pprMatch print_info) matches)
+ => HsMatchContext id -> [Match id pat] -> SDoc
+pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches)
+
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprFunBind :: (Outputable id, Outputable pat)
+ => id -> [Match id pat] -> SDoc
+pprFunBind fun matches = pprMatches (FunRhs fun) matches
+
+-- Exported to HsBinds, which can't see the defn of HsMatchContext
+pprPatBind :: (Outputable id, Outputable pat)
+ => pat -> GRHSs id pat -> SDoc
+pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
pprMatch :: (Outputable id, Outputable pat)
- => (Bool, SDoc) -> Match id pat -> SDoc
-pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss)
- = maybe_name <+> sep [sep (map ppr pats),
- ppr_maybe_ty,
- nest 2 (pprGRHSs is_case grhss)]
+ => HsMatchContext id -> Match id pat -> SDoc
+pprMatch ctxt (Match pats maybe_ty grhss)
+ = pp_name ctxt <+> sep [sep (map ppr pats),
+ ppr_maybe_ty,
+ nest 2 (pprGRHSs ctxt grhss)]
where
- maybe_name | is_case = empty
- | otherwise = name
+ pp_name (FunRhs fun) = ppr fun
+ pp_name other = empty
ppr_maybe_ty = case maybe_ty of
Just ty -> dcolon <+> ppr ty
Nothing -> empty
pprGRHSs :: (Outputable id, Outputable pat)
- => Bool -> GRHSs id pat -> SDoc
-pprGRHSs is_case (GRHSs grhss binds maybe_ty)
- = vcat (map (pprGRHS is_case) grhss)
+ => HsMatchContext id -> GRHSs id pat -> SDoc
+pprGRHSs ctxt (GRHSs grhss binds ty)
+ = vcat (map (pprGRHS ctxt) grhss)
$$
(if nullBinds binds then empty
else text "where" $$ nest 4 (pprDeeper (ppr binds)))
pprGRHS :: (Outputable id, Outputable pat)
- => Bool -> GRHS id pat -> SDoc
+ => HsMatchContext id -> GRHS id pat -> SDoc
-pprGRHS is_case (GRHS [ExprStmt expr _] locn)
- = text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
+pprGRHS ctxt (GRHS [ResultStmt expr _] locn)
+ = pp_rhs ctxt expr
-pprGRHS is_case (GRHS guarded locn)
- = sep [char '|' <+> interpp'SP guards,
- text (if is_case then "->" else "=") <+> pprDeeper (ppr expr)
- ]
+pprGRHS ctxt (GRHS guarded locn)
+ = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
where
- ExprStmt expr _ = last guarded -- Last stmt should be a ExprStmt for guards
- guards = init guarded
+ ResultStmt expr _ = last guarded -- Last stmt should be a ResultStmt for guards
+ guards = init guarded
+
+pp_rhs ctxt rhs = ptext (matchSeparator ctxt) <+> pprDeeper (ppr rhs)
\end{code}
data Stmt id pat
= BindStmt pat (HsExpr id pat) SrcLoc
| LetStmt (HsBinds id pat)
- | ExprStmt (HsExpr id pat) SrcLoc -- See notes that follow
- | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals
- | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming
+ | ResultStmt (HsExpr id pat) SrcLoc -- See notes that follow
+ | ExprStmt (HsExpr id pat) PostTcType SrcLoc -- See notes that follow
+ -- The type is the *element type* of the expression
+ | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals
+ | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming; the ids are the binders
+ -- bound by the stmts
\end{code}
-ExprStmts are a bit tricky, because what
-they mean depends on the context. Consider
- ExprStmt E
-in the following contexts:
+ExprStmts and ResultStmts are a bit tricky, because what they mean
+depends on the context. Consider the following contexts:
A do expression of type (m res_ty)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- * Non-last stmt in list: do { ....; E; ... }
+ * ExprStmt E any_ty: do { ....; E; ... }
E :: m any_ty
Translation: E >> ...
- * Last stmt in list: do { ....; E }
+ * ResultStmt E: do { ....; E }
E :: m res_ty
Translation: E
A list comprehensions of type [elt_ty]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- * Non-last stmt in list: [ .. | ..., E, ... ]
+ * ExprStmt E Bool: [ .. | .... E ]
+ [ .. | ..., E, ... ]
+ [ .. | .... | ..., E | ... ]
E :: Bool
Translation: if E then fail else ...
-
- * Last stmt in list: [ E | ... ]
+
+ * ResultStmt E: [ E | ... ]
E :: elt_ty
Translation: return E
A guard list, guarding a RHS of type rhs_ty
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- * Non-last stmt in list: f x | ..., E, ... = ...rhs...
+ * ExprStmt E Bool: f x | ..., E, ... = ...rhs...
E :: Bool
Translation: if E then fail else ...
- * Last stmt in list: f x | ...guards... = E
+ * ResultStmt E: f x | ...guards... = E
E :: rhs_ty
Translation: E
+Array comprehensions are handled like list comprehensions -=chak
+
\begin{code}
consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat]
consLetStmt EmptyBinds stmts = stmts
Outputable (Stmt 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 (ResultStmt expr _) = ppr expr
pprStmt (ParStmt stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
pprStmt (ParStmtOut stmtss)
= hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
-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
-
-pprDo :: (Outputable id, Outputable pat) => HsMatchContext -> [Stmt id pat] -> SDoc
+
+pprDo :: (Outputable id, Outputable pat)
+ => HsDoContext -> [Stmt id pat] -> SDoc
pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
-pprDo ListComp stmts = brackets $
- hang (pprExpr expr <+> char '|')
- 4 (interpp'SP quals)
- where
- ExprStmt expr _ = last stmts -- Last stmt should
- quals = init stmts -- be an ExprStmt
+pprDo ListComp stmts = pprComp brackets stmts
+pprDo PArrComp stmts = pprComp pabrackets stmts
+
+pprComp :: (Outputable id, Outputable pat)
+ => (SDoc -> SDoc) -> [Stmt id pat] -> SDoc
+pprComp brack stmts = brack $
+ hang (pprExpr expr <+> char '|')
+ 4 (interpp'SP quals)
+ where
+ ResultStmt expr _ = last stmts -- Last stmt should
+ quals = init stmts -- be an ResultStmt
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-data HsMatchContext -- Context of a Match or Stmt
- = ListComp -- List comprehension
- | DoExpr -- Do Statment
-
- | FunRhs Name -- Function binding for f
+data HsMatchContext id -- Context of a Match or Stmt
+ = DoCtxt HsDoContext -- Do-stmt or list comprehension
+ | FunRhs id -- Function binding for f
| CaseAlt -- Guard on a case alternative
| LambdaExpr -- Lambda
| PatBindRhs -- Pattern binding
| RecUpd -- Record update
deriving ()
--- It's convenient to have FunRhs as a Name
--- throughout so that HsMatchContext doesn't
--- need to be parameterised.
--- In the RdrName world we never use the FunRhs variant.
+data HsDoContext = ListComp
+ | DoExpr
+ | PArrComp -- parallel array comprehension
\end{code}
\begin{code}
-isDoExpr DoExpr = True
-isDoExpr other = False
-
-isDoOrListComp ListComp = True
-isDoOrListComp DoExpr = True
-isDoOrListComp other = False
+isDoExpr (DoCtxt DoExpr) = True
+isDoExpr other = False
\end{code}
\begin{code}
matchSeparator CaseAlt = SLIT("->")
matchSeparator LambdaExpr = SLIT("->")
matchSeparator PatBindRhs = SLIT("=")
-matchSeparator DoExpr = SLIT("<-")
-matchSeparator ListComp = SLIT("<-")
+matchSeparator (DoCtxt _) = SLIT("<-")
matchSeparator RecUpd = panic "When is this used?"
\end{code}
\begin{code}
-pprMatchContext (FunRhs fun) = ptext SLIT("In the definition of") <+> quotes (ppr fun)
-pprMatchContext CaseAlt = ptext SLIT("In a group of case alternatives beginning")
-pprMatchContext RecUpd = ptext SLIT("In a record-update construct")
-pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding")
-pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction")
-pprMatchContext DoExpr = ptext SLIT("In a 'do' expression pattern binding")
-pprMatchContext ListComp = ptext SLIT("In a 'list comprension' pattern binding")
+pprMatchContext (FunRhs fun) = ptext SLIT("In the definition of") <+> quotes (ppr fun)
+pprMatchContext CaseAlt = ptext SLIT("In a case alternative")
+pprMatchContext RecUpd = ptext SLIT("In a record-update construct")
+pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding")
+pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction")
+pprMatchContext (DoCtxt DoExpr) = ptext SLIT("In a 'do' expression pattern binding")
+pprMatchContext (DoCtxt ListComp) =
+ ptext SLIT("In a 'list comprehension' pattern binding")
+pprMatchContext (DoCtxt PArrComp) =
+ ptext SLIT("In an 'array comprehension' pattern binding")
+
+-- Used to generate the string for a *runtime* error message
+matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun)
+matchContextErrString CaseAlt = "case"
+matchContextErrString PatBindRhs = "pattern binding"
+matchContextErrString RecUpd = "record update"
+matchContextErrString LambdaExpr = "lambda"
+matchContextErrString (DoCtxt DoExpr) = "'do' expression"
+matchContextErrString (DoCtxt ListComp) = "list comprehension"
+matchContextErrString (DoCtxt PArrComp) = "array comprehension"
\end{code}
projects / ghc-hetmet.git / blobdiff