X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsExpr.lhs;h=419cb3161a58b65c5135b9aeec00d83703dd3861;hb=10fcd78ccde892feccda3f5eacd221c1de75feea;hp=b7d45737a9219a28f42953dae2caa67a022a4b13;hpb=ab46fd8e68f10b6162e77cfc0b216510d9b1d933;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index b7d4573..419cb31 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -17,14 +17,15 @@ import HsTypes ( HsType ) import HsImpExp ( isOperator ) -- 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} @@ -37,7 +38,7 @@ import SrcLoc ( SrcLoc ) \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 @@ -60,6 +61,7 @@ data HsExpr id pat -- 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 @@ -81,7 +83,7 @@ data HsExpr id pat (HsExpr id pat) | HsWith (HsExpr id pat) -- implicit parameter binding - [(id, HsExpr id pat)] + [(IPName id, HsExpr id pat)] | HsDo HsDoContext [Stmt id pat] -- "do":one or more stmts @@ -99,6 +101,10 @@ data HsExpr id pat PostTcType -- Gives type of components of list [HsExpr id pat] + | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] + PostTcType -- type of elements of the parallel array + [HsExpr id pat] + | ExplicitTuple -- tuple [HsExpr id pat] -- NB: Unit is ExplicitTuple [] @@ -135,6 +141,11 @@ data HsExpr 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 @@ -216,7 +227,7 @@ ppr_expr (HsVar v) | 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 @@ -248,7 +259,7 @@ ppr_expr (OpApp e1 op fixity e2) | 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) @@ -295,7 +306,7 @@ ppr_expr (HsLet binds expr) 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 @@ -303,6 +314,9 @@ 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 (ExplicitPArr _ exprs) + = pabrackets (fsep (punctuate comma (map ppr_expr exprs))) + ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) @@ -325,6 +339,11 @@ ppr_expr (ArithSeqIn info) 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 @@ -361,7 +380,11 @@ ppr_expr (DictApp expr dnames) 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: @@ -380,6 +403,7 @@ pprParendExpr expr HsVar _ -> pp_as_was HsIPVar _ -> pp_as_was ExplicitList _ _ -> pp_as_was + ExplicitPArr _ _ -> pp_as_was ExplicitTuple _ _ -> pp_as_was HsPar _ -> pp_as_was @@ -409,6 +433,13 @@ pp_rbinds thing rbinds 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} %************************************************************************ @@ -434,8 +465,6 @@ patterns in each equation. \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 @@ -456,7 +485,7 @@ data GRHS id pat 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) + = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty) unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat] unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] @@ -468,7 +497,7 @@ THis is something of a nuisance, but no more. \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. @@ -491,7 +520,7 @@ pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] pprMatch :: (Outputable id, Outputable pat) => HsMatchContext id -> Match id pat -> SDoc -pprMatch ctxt (Match _ pats maybe_ty grhss) +pprMatch ctxt (Match pats maybe_ty grhss) = pp_name ctxt <+> sep [sep (map ppr pats), ppr_maybe_ty, nest 2 (pprGRHSs ctxt grhss)] @@ -582,6 +611,7 @@ depends on the context. Consider the following contexts: 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] @@ -603,14 +633,20 @@ pprStmt (ParStmt stmtss) pprStmt (ParStmtOut stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) -pprDo :: (Outputable id, Outputable pat) => HsDoContext -> [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 - ResultStmt expr _ = last stmts -- Last stmt should - quals = init stmts -- be an ResultStmt +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} %************************************************************************ @@ -660,7 +696,9 @@ data HsMatchContext id -- Context of a Match or Stmt | RecUpd -- Record update deriving () -data HsDoContext = ListComp | DoExpr +data HsDoContext = ListComp + | DoExpr + | PArrComp -- parallel array comprehension \end{code} \begin{code} @@ -684,7 +722,10 @@ 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 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) @@ -694,4 +735,5 @@ matchContextErrString RecUpd = "record update" matchContextErrString LambdaExpr = "lambda" matchContextErrString (DoCtxt DoExpr) = "'do' expression" matchContextErrString (DoCtxt ListComp) = "list comprehension" +matchContextErrString (DoCtxt PArrComp) = "array comprehension" \end{code}