path: root/ghc/compiler/hsSyn/HsExpr.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
%
\section[HsExpr]{Abstract Haskell syntax: expressions}

\begin{code}
#include "HsVersions.h"

module HsExpr where

IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(HsLoop) -- for paranoia checking

-- friends:
import HsBinds		( HsBinds )
import HsLit		( HsLit )
import HsMatches	( pprMatches, pprMatch, Match )
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 SrcLoc		( SrcLoc )
import Usage		( GenUsage{-instance-} )
--import Util		( panic{-ToDo:rm eventually-} )
\end{code}

%************************************************************************
%*									*
\subsection{Expressions proper}
%*									*
%************************************************************************

\begin{code}
data HsExpr tyvar uvar id pat
  = HsVar	id				-- variable
  | HsLit	HsLit				-- literal
  | HsLitOut	HsLit				-- TRANSLATION
		(GenType tyvar uvar)		-- (with its type)

  | HsLam	(Match  tyvar uvar id pat)	-- lambda
  | HsApp	(HsExpr tyvar uvar id pat)	-- application
		(HsExpr tyvar uvar 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
		(HsExpr tyvar uvar 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)

  | HsPar	(HsExpr tyvar uvar 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
				
  | HsCase	(HsExpr tyvar uvar id pat)
		[Match  tyvar uvar 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
		SrcLoc

  | HsLet	(HsBinds tyvar uvar id pat)	-- let(rec)
		(HsExpr  tyvar uvar id pat)

  | HsDo	[Stmt tyvar uvar 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
		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]
  | ExplicitListOut		-- TRANSLATION
		(GenType tyvar uvar)	-- Gives type of components of list
		[HsExpr tyvar uvar id pat]

  | ExplicitTuple		-- tuple
		[HsExpr tyvar uvar id pat]
				-- NB: Unit is ExplicitTuple []
				-- for tuples, we can get the types
				-- direct from the components

	-- 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)

	-- Record update
  | RecordUpd	(HsExpr tyvar uvar id pat)
		(HsRecordBinds tyvar uvar id pat)

  | RecordUpdOut (HsExpr tyvar uvar id pat)	-- TRANSLATION
		 [id]				-- Dicts needed for construction
		 (HsRecordBinds tyvar uvar id pat)

  | ExprWithTySig		-- signature binding
		(HsExpr tyvar uvar id pat)
		(HsType id)
  | ArithSeqIn			-- arithmetic sequence
		(ArithSeqInfo tyvar uvar id pat)
  | ArithSeqOut
		(HsExpr       tyvar uvar id pat) -- (typechecked, of course)
		(ArithSeqInfo tyvar uvar id pat)

  | CCall	FAST_STRING	-- call into the C world; string is
		[HsExpr tyvar uvar id pat]	-- the C function; exprs are the
				-- arguments to pass.
		Bool		-- 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#".
		(GenType tyvar uvar)	-- 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
\end{code}

Everything from here on appears only in typechecker output.

\begin{code}
  | TyLam			-- TRANSLATION
		[tyvar]
		(HsExpr tyvar uvar id pat)
  | TyApp			-- TRANSLATION
		(HsExpr  tyvar uvar id pat) -- generated by Spec
		[GenType tyvar uvar]

  -- DictLam and DictApp are "inverses"
  |  DictLam
		[id]
		(HsExpr tyvar uvar id pat)
  |  DictApp
		(HsExpr tyvar uvar 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

  |  HsCon 			-- TRANSLATION; a constructor application
	Id			-- used only in the RHS of constructor definitions
	[GenType tyvar uvar]
	[HsExpr tyvar uvar id pat]

type HsRecordBinds tyvar uvar id pat
  = [(id, HsExpr tyvar uvar id pat, Bool)]
	-- True <=> source code used "punning",
	-- i.e. {op1, op2} rather than {op1=e1, op2=e2}
\end{code}

A @Dictionary@, unless of length 0 or 1, becomes a tuple.  A
@ClassDictLam dictvars methods expr@ is, therefore:
\begin{verbatim}
\ x -> case x of ( dictvars-and-methods-tuple ) -> expr
\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
\end{code}

\begin{code}
pprExpr sty (HsVar v) = pprNonSym sty v

pprExpr sty (HsLit    lit)   = ppr sty lit
pprExpr sty (HsLitOut lit _) = ppr sty lit

pprExpr sty (HsLam match)
  = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)]

pprExpr sty expr@(HsApp e1 e2)
  = let (fun, args) = collect_args expr [] in
    ppHang (pprExpr sty fun) 4 (ppSep (map (pprExpr sty) args))
  where
    collect_args (HsApp fun arg) args = collect_args fun (arg:args)
    collect_args fun		 args = (fun, args)

pprExpr sty (OpApp e1 op e2)
  = case op of
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
    pp_e1 = pprExpr sty e1
    pp_e2 = pprExpr sty e2

    pp_prefixly
      = ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2])

    pp_infixly v
      = ppSep [pp_e1, ppCat [pprSym sty v, pp_e2]]

pprExpr sty (NegApp e _)
  = ppBeside (ppChar '-') (pprParendExpr sty e)

pprExpr sty (HsPar e)
  = ppParens (pprExpr sty e)

pprExpr sty (SectionL expr op)
  = case op of
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
    pp_expr = pprParendExpr sty 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 (pprSym sty v) ppRparen ]

pprExpr sty (SectionR op expr)
  = case op of
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
    pp_expr = pprParendExpr sty expr

    pp_prefixly = ppHang (ppCat [ppStr "( \\ x_ ->", ppr sty op, ppPStr SLIT("x_")])
		       4 (ppBeside pp_expr ppRparen)
    pp_infixly v
      = ppSep [ ppBeside ppLparen (pprSym sty v),
		ppBeside pp_expr  ppRparen ]

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) ]

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)]

-- 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]

pprExpr sty (HsCon con tys exprs)
  = ppCat [ppPStr SLIT("{-HsCon-}"), ppr sty con, interppSP sty tys, interppSP sty exprs]
\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 sty expr
  = let
	pp_as_was = pprExpr sty expr
    in
    case expr of
      HsLit l		    -> ppr sty l
      HsLitOut l _	    -> ppr sty l
      HsVar _		    -> pp_as_was
      ExplicitList _	    -> pp_as_was
      ExplicitListOut _ _   -> pp_as_was
      ExplicitTuple _	    -> pp_as_was
      _			    -> ppParens pp_as_was
\end{code}

%************************************************************************
%*									*
\subsection{Record binds}
%*									*
%************************************************************************

\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)))
  where
    pp_rbind PprForUser (v, _, True) = ppr PprForUser v
    pp_rbind sty        (v, e, _)    = ppCat [ppr sty v, ppStr "=", ppr sty e]
\end{code}

%************************************************************************
%*									*
\subsection{Do stmts}
%*									*
%************************************************************************

\begin{code}
data Stmt tyvar uvar id pat
  = BindStmt	pat
		(HsExpr  tyvar uvar id pat)
		SrcLoc
  | ExprStmt	(HsExpr  tyvar uvar id pat)
		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)
\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
\end{code}

%************************************************************************
%*									*
\subsection{Enumerations and list comprehensions}
%*									*
%************************************************************************

\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)
\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
\end{code}