Commit 16e4ce4c authored by simonpj's avatar simonpj
Browse files

[project @ 2003-06-24 07:58:18 by simonpj]

----------------------------------------------
	Add support for Ross Paterson's arrow notation
	----------------------------------------------

Ross Paterson's ICFP'01 paper described syntax to support John Hughes's
"arrows", rather as do-notation supports monads.  Except that do-notation is
relatively modest -- you can write monads by hand without much trouble --
whereas arrow-notation is more-or-less essential for writing arrow programs.
It desugars to a massive pile of tuple construction and selection!

For some time, Ross has had a pre-processor for arrow notation, but the
resulting type error messages (reported in terms of the desugared code)
are impenetrable.  This commit integrates the syntax into GHC.  The
type error messages almost certainly still require tuning, but they should
be better than with the pre-processor.

Main syntactic changes (enabled with -farrows)

   exp ::= ... | proc pat -> cmd

   cmd ::= exp1 -<  exp2   |  exp1 >-  exp2
	|  exp1 -<< exp2   |  exp1 >>- exp2
	| \ pat1 .. patn -> cmd
	| let decls in cmd
	| if exp then cmd1 else cmd2
	| do { cstmt1 .. cstmtn ; cmd }
	| (| exp |) cmd1 .. cmdn
	| cmd1 qop cmd2
	| case exp of { calts }

   cstmt :: = let decls
	 |   pat <- cmd
	 |   rec { cstmt1 .. cstmtn }
	 |   cmd

New keywords and symbols:
	proc rec
	-<   >-   -<<   >>-
	(|  |)

The do-notation in cmds was not described in Ross's ICFP'01 paper; instead
it's in his chapter in The Fun of Programming (Plagrave 2003).

The four arrow-tail forms (-<) etc cover
  (a) which order the pices come in (-<  vs  >-), and
  (b) whether the locally bound variables can be used in the
		arrow part (-<  vs  -<<) .
In previous presentations, the higher-order-ness (b) was inferred,
but it makes a big difference to the typing required so it seems more
consistent to be explicit.

The 'rec' form is also available in do-notation:
  * you can use 'rec' in an ordinary do, with the obvious meaning
  * using 'mdo' just says "infer the minimal recs"


Still to do
~~~~~~~~~~~
Top priority is the user manual.

The implementation still lacks an implementation of
the case form of cmd.


Implementation notes
~~~~~~~~~~~~~~~~~~~~
Cmds are parsed, and indeed renamed, as expressions.  The type checker
distinguishes the two.
parent 67d41f03
This diff is collapsed.
......@@ -15,7 +15,10 @@ import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsGRHSs ( dsGuarded )
import DsCCall ( dsCCall )
import DsListComp ( dsListComp, dsPArrComp )
import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, mkCoreTupTy, selectMatchVar )
import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr,
mkCoreTupTy, selectMatchVar,
dsReboundNames, lookupReboundName )
import DsArrows ( dsProcExpr )
import DsMonad
#ifdef GHCI
......@@ -26,6 +29,7 @@ import DsMeta ( dsBracket, dsReify )
import HsSyn ( HsExpr(..), Pat(..), ArithSeqInfo(..),
Stmt(..), HsMatchContext(..), HsStmtContext(..),
Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..),
ReboundNames,
mkSimpleMatch, isDoExpr
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, hsPatType )
......@@ -52,7 +56,9 @@ import Name ( Name )
import TyCon ( tyConDataCons )
import TysWiredIn ( tupleCon, mkTupleTy )
import BasicTypes ( RecFlag(..), Boxity(..), ipNameName )
import PrelNames ( toPName )
import PrelNames ( toPName,
returnMName, bindMName, thenMName, failMName,
mfixName )
import SrcLoc ( noSrcLoc )
import Util ( zipEqual, zipWithEqual )
import Outputable
......@@ -559,6 +565,8 @@ dsExpr (HsReify r) = dsReify r
dsExpr (HsSplice n e _) = pprPanic "dsExpr:splice" (ppr e)
#endif
-- Arrow notation extension
dsExpr (HsProc pat cmd src_loc) = dsProcExpr pat cmd src_loc
\end{code}
......@@ -580,13 +588,18 @@ Basically does the translation given in the Haskell~1.3 report:
\begin{code}
dsDo :: HsStmtContext Name
-> [TypecheckedStmt]
-> [Id] -- id for: [return,fail,>>=,>>] and possibly mfixName
-> Type -- Element type; the whole expression has type (m t)
-> ReboundNames Id -- id for: [return,fail,>>=,>>] and possibly mfixName
-> Type -- Element type; the whole expression has type (m t)
-> DsM CoreExpr
dsDo do_or_lc stmts ids result_ty
= let
(return_id : fail_id : bind_id : then_id : _) = ids
= dsReboundNames ids `thenDs` \ (meth_binds, ds_meths) ->
let
return_id = lookupReboundName ds_meths returnMName
fail_id = lookupReboundName ds_meths failMName
bind_id = lookupReboundName ds_meths bindMName
then_id = lookupReboundName ds_meths thenMName
(m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
is_do = isDoExpr do_or_lc -- True for both MDo and Do
......@@ -598,13 +611,13 @@ dsDo do_or_lc stmts ids result_ty
go [ResultStmt expr locn]
| is_do = do_expr expr locn
| otherwise = do_expr expr locn `thenDs` \ expr2 ->
returnDs (mkApps (Var return_id) [Type b_ty, expr2])
returnDs (mkApps return_id [Type b_ty, expr2])
go (ExprStmt expr a_ty locn : stmts)
| is_do -- Do expression
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2, rest])
returnDs (mkApps then_id [Type a_ty, Type b_ty, expr2, rest])
| otherwise -- List comprehension
= do_expr expr locn `thenDs` \ expr2 ->
......@@ -614,7 +627,7 @@ dsDo do_or_lc stmts ids result_ty
in
mkStringLit msg `thenDs` \ core_msg ->
returnDs (mkIfThenElse expr2 rest
(App (App (Var fail_id) (Type b_ty)) core_msg))
(App (App fail_id (Type b_ty)) core_msg))
go (LetStmt binds : stmts )
= go stmts `thenDs` \ rest ->
......@@ -628,21 +641,22 @@ dsDo do_or_lc stmts ids result_ty
let
-- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception
fail_expr = mkApps (Var fail_id) [Type b_ty, core_msg]
fail_expr = mkApps fail_id [Type b_ty, core_msg]
a_ty = hsPatType pat
in
selectMatchVar pat `thenDs` \ var ->
matchSimply (Var var) (StmtCtxt do_or_lc) pat
body fail_expr `thenDs` \ match_code ->
returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, rhs, Lam var match_code])
returnDs (mkApps bind_id [Type a_ty, Type b_ty, rhs, Lam var match_code])
go (RecStmt rec_vars rec_stmts rec_rets : stmts)
go (RecStmt rec_stmts later_vars rec_vars rec_rets : stmts)
= go (bind_stmt : stmts)
where
bind_stmt = dsRecStmt m_ty ids rec_vars rec_stmts rec_rets
bind_stmt = dsRecStmt m_ty ds_meths rec_stmts later_vars rec_vars rec_rets
in
go stmts
go stmts `thenDs` \ stmts_code ->
returnDs (foldr Let stmts_code meth_binds)
where
do_expr expr locn = putSrcLocDs locn (dsExpr expr)
......@@ -658,16 +672,17 @@ We turn (RecStmt [v1,..vn] stmts) into:
\begin{code}
dsRecStmt :: Type -- Monad type constructor :: * -> *
-> [Id] -- Ids for: [return,fail,>>=,>>,mfix]
-> [Id] -> [TypecheckedStmt] -> [TypecheckedHsExpr] -- Guts of the RecStmt
-> [(Name,Id)] -- Rebound Ids
-> [TypecheckedStmt]
-> [Id] -> [Id] -> [TypecheckedHsExpr]
-> TypecheckedStmt
dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets
= ASSERT( length vars == length rets )
BindStmt tup_pat mfix_app noSrcLoc
where
(var1:rest) = vars -- Always at least one
(ret1:_) = rets
one_var = null rest
vars@(var1:rest) = later_vars ++ rec_vars -- Always at least one
rets@(ret1:_) = map HsVar later_vars ++ rec_rets
one_var = null rest
mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg
mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc)
......@@ -680,10 +695,13 @@ dsRecStmt m_ty ids@[return_id, _, _, _, mfix_id] vars stmts rets
| otherwise = LazyPat (TuplePat (map VarPat vars) Boxed)
body = HsDo DoExpr (stmts ++ [return_stmt])
ids -- Don't need the mfix, but it does no harm
[(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack
(mkAppTy m_ty tup_ty)
noSrcLoc
Var return_id = lookupReboundName ds_meths returnMName
Var mfix_id = lookupReboundName ds_meths mfixName
return_stmt = ResultStmt return_app noSrcLoc
return_app = HsApp (TyApp (HsVar return_id) [tup_ty]) tup_expr
\end{code}
......@@ -67,8 +67,8 @@ dsListComp quals elt_ty
returnDs (Var build_id `App` Type elt_ty
`App` mkLams [n_tyvar, c, n] result)
where isParallelComp (ParStmtOut bndrstmtss : _) = True
isParallelComp _ = False
where isParallelComp (ParStmt bndrstmtss : _) = True
isParallelComp _ = False
\end{code}
%************************************************************************
......@@ -125,7 +125,7 @@ comprehensions. The translation goes roughly as follows:
where (x1, .., xn) are the variables bound in p1, v1, p2
(y1, .., ym) are the variables bound in q1, v2, q2
In the translation below, the ParStmtOut branch translates each parallel branch
In the translation below, the ParStmt branch translates each parallel branch
into a sub-comprehension, and desugars each independently. The resulting lists
are fed to a zip function, we create a binding for all the variables bound in all
the comprehensions, and then we hand things off the the desugarer for bindings.
......@@ -139,22 +139,25 @@ with the Unboxed variety.
deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr
deListComp (ParStmtOut bndrstmtss : quals) list
= mapDs do_list_comp bndrstmtss `thenDs` \ exps ->
deListComp (ParStmt stmtss_w_bndrs : quals) list
= mapDs do_list_comp stmtss_w_bndrs `thenDs` \ exps ->
mkZipBind qual_tys `thenDs` \ (zip_fn, zip_rhs) ->
-- Deal with [e | pat <- zip l1 .. ln] in example above
deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
quals list
where -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
pat = TuplePat pats Boxed
pats = map (\(bs,_) -> mk_hs_tuple_pat bs) bndrstmtss
where
bndrs_s = map snd stmtss_w_bndrs
-- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
pat = TuplePat pats Boxed
pats = map mk_hs_tuple_pat bndrs_s
-- Types of (x1,..,xn), (y1,..,yn) etc
qual_tys = [ mk_bndrs_tys bndrs | (bndrs,_) <- bndrstmtss ]
qual_tys = map mk_bndrs_tys bndrs_s
do_list_comp (bndrs, stmts)
do_list_comp (stmts, bndrs)
= dsListComp (stmts ++ [ResultStmt (mk_hs_tuple_expr bndrs) noSrcLoc])
(mk_bndrs_tys bndrs)
......@@ -428,8 +431,8 @@ dePArrComp (LetStmt ds : qs) pa cea =
-- where
-- {x_1, ..., x_n} = DV (qs)
--
dePArrComp (ParStmtOut [] : qss2) pa cea = dePArrComp qss2 pa cea
dePArrComp (ParStmtOut ((xs, qs):qss) : qss2) pa cea =
dePArrComp (ParStmt [] : qss2) pa cea = dePArrComp qss2 pa cea
dePArrComp (ParStmt ((qs, xs):qss) : qss2) pa cea =
dsLookupGlobalId zipPName `thenDs` \zipP ->
let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed
ty'cea = parrElemType cea
......@@ -439,7 +442,7 @@ dePArrComp (ParStmtOut ((xs, qs):qss) : qss2) pa cea =
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
in
dePArrComp (ParStmtOut qss : qss2) pa' cea'
dePArrComp (ParStmt qss : qss2) pa' cea'
-- generate Core corresponding to `\p -> e'
--
......
......@@ -6,7 +6,7 @@
\begin{code}
module DsMonad (
DsM,
initDs, returnDs, thenDs, mapDs, listDs,
initDs, returnDs, thenDs, mapDs, listDs, fixDs,
mapAndUnzipDs, zipWithDs, foldlDs,
uniqSMtoDsM,
newTyVarsDs, cloneTyVarsDs,
......@@ -15,8 +15,9 @@ module DsMonad (
getSrcLocDs, putSrcLocDs,
getModuleDs,
getUniqueDs, getUniquesDs,
UniqSupply, getUniqSupplyDs,
getDOptsDs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
......@@ -30,7 +31,9 @@ module DsMonad (
import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
import HscTypes ( TyThing(..) )
import Bag ( emptyBag, snocBag, Bag )
import DataCon ( DataCon )
import TyCon ( TyCon )
import DataCon ( DataCon )
import Id ( mkSysLocal, setIdUnique, Id )
import Module ( Module )
import Var ( TyVar, setTyVarUnique )
......@@ -38,7 +41,7 @@ import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
import Type ( Type )
import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs,
UniqSM, UniqSupply )
fixUs, UniqSM, UniqSupply, getUs )
import Unique ( Unique )
import Name ( Name, nameOccName )
import NameEnv
......@@ -113,6 +116,9 @@ thenDs (DsM m1) m2 = DsM( \ env warns ->
returnDs :: a -> DsM a
returnDs result = DsM (\ env warns -> returnUs (result, warns))
fixDs :: (a -> DsM a) -> DsM a
fixDs f = DsM (\env warns -> fixUs (\ ~(a, _warns') -> unDsM (f a) env warns))
listDs :: [DsM a] -> DsM [a]
listDs [] = returnDs []
listDs (x:xs)
......@@ -173,6 +179,11 @@ getUniquesDs = DsM(\ env warns ->
getUniquesUs `thenUs` \ uniqs ->
returnUs (uniqs, warns))
getUniqSupplyDs :: DsM UniqSupply
getUniqSupplyDs = DsM(\ env warns ->
getUs `thenUs` \ uniqs ->
returnUs (uniqs, warns))
-- Make a new Id with the same print name, but different type, and new unique
newUniqueId :: Name -> Type -> DsM Id
newUniqueId id ty
......@@ -238,18 +249,23 @@ dsLookupGlobal name
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
= dsLookupGlobal name `thenDs` \ thing ->
returnDs (get_id name thing)
returnDs $ case thing of
AnId id -> id
other -> pprPanic "dsLookupGlobalId" (ppr name)
dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon name
= dsLookupGlobal name `thenDs` \ thing ->
returnDs (get_tycon name thing)
returnDs $ case thing of
ATyCon tc -> tc
other -> pprPanic "dsLookupTyCon" (ppr name)
get_id name (AnId id) = id
get_id name other = pprPanic "dsLookupGlobalId" (ppr name)
get_tycon name (ATyCon tc) = tc
get_tycon name other = pprPanic "dsLookupTyCon" (ppr name)
dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon name
= dsLookupGlobal name `thenDs` \ thing ->
returnDs $ case thing of
ADataCon dc -> dc
other -> pprPanic "dsLookupDataCon" (ppr name)
\end{code}
\begin{code}
......
......@@ -26,13 +26,16 @@ module DsUtils (
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
mkCoreTup, mkCoreSel, mkCoreTupTy,
dsReboundNames, lookupReboundName,
selectMatchVar
) where
#include "HsVersions.h"
import {-# SOURCE #-} Match ( matchSimply )
import {-# SOURCE #-} Match ( matchSimply )
import {-# SOURCE #-} DsExpr( dsExpr )
import HsSyn
import TcHsSyn ( TypecheckedPat, hsPatType )
......@@ -43,6 +46,7 @@ import DsMonad
import CoreUtils ( exprType, mkIfThenElse, mkCoerce )
import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody )
import Id ( idType, Id, mkWildId, mkTemplateLocals )
import Name ( Name )
import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
import TyCon ( isNewTyCon, tyConDataCons )
import DataCon ( DataCon, dataConSourceArity )
......@@ -65,11 +69,42 @@ import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
import Outputable
import UnicodeUtil ( intsToUtf8, stringToUtf8 )
import Util ( isSingleton, notNull, zipEqual )
import ListSetOps ( assocDefault )
import FastString
\end{code}
%************************************************************************
%* *
Rebindable syntax
%* *
%************************************************************************
\begin{code}
dsReboundNames :: ReboundNames Id
-> DsM ([CoreBind], -- Auxiliary bindings
[(Name,Id)]) -- Maps the standard name to its value
dsReboundNames rebound_ids
= mapAndUnzipDs mk_bind rebound_ids `thenDs` \ (binds_s, prs) ->
return (concat binds_s, prs)
where
-- The cheapo special case can happen when we
-- make an intermediate HsDo when desugaring a RecStmt
mk_bind (std_name, HsVar id) = return ([], (std_name, id))
mk_bind (std_name, expr) = dsExpr expr `thenDs` \ rhs ->
newSysLocalDs (exprType rhs) `thenDs` \ id ->
return ([NonRec id rhs], (std_name, id))
lookupReboundName :: [(Name,Id)] -> Name -> CoreExpr
lookupReboundName prs std_name
= Var (assocDefault (mk_panic std_name) prs std_name)
where
mk_panic std_name = pprPanic "dsReboundNames" (ptext SLIT("Not found:") <+> ppr std_name)
\end{code}
%************************************************************************
%* *
\subsection{Tidying lit pats}
......
......@@ -237,13 +237,12 @@ cvtdd (FromThenToR x y z) = (FromThenTo (cvt x) (cvt y) (cvt z))
cvtstmts :: [Meta.Stmt] -> [Hs.Stmt RdrName]
cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
cvtstmts [NoBindS e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt
cvtstmts (NoBindS e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss
cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
cvtstmts [NoBindS e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt
cvtstmts (NoBindS e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss
cvtstmts (Meta.BindS p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss
cvtstmts (Meta.LetS ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss
cvtstmts (Meta.ParS dss : ss) = ParStmt(map cvtstmts dss) : cvtstmts ss
cvtstmts (Meta.ParS dss : ss) = ParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss
cvtm :: Meta.Match -> Hs.Match RdrName
cvtm (Meta.Match p body wheres)
......
......@@ -22,6 +22,7 @@ import PprType ( pprParendType )
import Type ( Type )
import Var ( TyVar, Id )
import Name ( Name )
import NameSet ( FreeVars )
import DataCon ( DataCon )
import CStrings ( CLabelString, pprCLabelString )
import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) )
......@@ -86,11 +87,9 @@ data HsExpr id
| HsDo (HsStmtContext Name) -- The parameterisation is unimportant
-- because in this context we never use
-- the PatGuard or ParStmt variant
[Stmt id] -- "do":one or more stmts
[id] -- Ids for [return,fail,>>=,>>]
-- Brutal but simple
-- Before type checking, used for rebindable syntax
PostTcType -- Type of the whole expression
[Stmt id] -- "do":one or more stmts
(ReboundNames id) -- Ids for [return,fail,>>=,>>]
PostTcType -- Type of the whole expression
SrcLoc
| ExplicitList -- syntactic list
......@@ -161,6 +160,7 @@ data HsExpr id
| HsCoreAnn FastString -- hdaume: core annotation
(HsExpr id)
-----------------------------------------------------------
-- MetaHaskell Extensions
| HsBracket (HsBracket id) SrcLoc
......@@ -173,6 +173,37 @@ data HsExpr id
-- identify this splice point
| HsReify (HsReify id) -- reifyType t, reifyDecl i, reifyFixity
-----------------------------------------------------------
-- Arrow notation extension
| HsProc (Pat id) -- arrow abstraction, proc
(HsCmdTop id) -- body of the abstraction
-- always has an empty stack
SrcLoc
---------------------------------------
-- The following are commands, not expressions proper
| HsArrApp -- Arrow tail, or arrow application (f -< arg)
(HsExpr id) -- arrow expression, f
(HsExpr id) -- input expression, arg
PostTcType -- type of the arrow expressions f,
-- of the form a t t', where arg :: t
HsArrAppType -- higher-order (-<<) or first-order (-<)
Bool -- True => right-to-left (f -< arg)
-- False => left-to-right (arg >- f)
SrcLoc
| HsArrForm -- Command formation, (| e |) cmd1 .. cmdn
(HsExpr id) -- the operator
-- after type-checking, a type abstraction to be
-- applied to the type of the local environment tuple
(Maybe Fixity) -- fixity (filled in by the renamer), for forms that
-- were converted from OpApp's by the renamer
[HsCmdTop id] -- argument commands
SrcLoc
\end{code}
......@@ -212,6 +243,22 @@ type PendingSplice = (Name, HsExpr Id) -- Typechecked splices, waiting to be
-- pasted back in by the desugarer
\end{code}
Table of bindings of names used in rebindable syntax.
This gets filled in by the renamer.
\begin{code}
type ReboundNames id = [(Name, HsExpr id)]
-- * Before the renamer, this list is empty
--
-- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
-- For example, for the 'return' op of a monad
-- normal case: (GHC.Base.return, HsVar GHC.Base.return)
-- with rebindable syntax: (GHC.Base.return, return_22)
-- where return_22 is whatever "return" is in scope
--
-- * After the type checker, it takes the form [(std_name, <expression>)]
-- where <expression> is the evidence for the method
\end{code}
A @Dictionary@, unless of length 0 or 1, becomes a tuple. A
@ClassDictLam dictvars methods expr@ is, therefore:
......@@ -256,12 +303,7 @@ ppr_expr (OpApp e1 op fixity e2)
= hang (pprExpr op) 4 (sep [pp_e1, pp_e2])
pp_infixly v
= sep [pp_e1, hsep [pp_v_op, pp_e2]]
where
ppr_v = ppr v
pp_v_op | isOperator ppr_v = ppr_v
| otherwise = char '`' <> ppr_v <> char '`'
-- Put it in backquotes if it's not an operator already
= sep [pp_e1, hsep [pprInfix v, pp_e2]]
ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
......@@ -390,6 +432,35 @@ ppr_expr (HsBracket b _) = pprHsBracket b
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
ppr_expr (HsReify r) = ppr r
ppr_expr (HsProc pat (HsCmdTop cmd _ _ _) _)
= hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), pprExpr cmd]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True _)
= hsep [pprExpr arrow, ptext SLIT("-<"), pprExpr arg]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False _)
= hsep [pprExpr arg, ptext SLIT(">-"), pprExpr arrow]
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True _)
= hsep [pprExpr arrow, ptext SLIT("-<<"), pprExpr arg]
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False _)
= hsep [pprExpr arg, ptext SLIT(">>-"), pprExpr arrow]
ppr_expr (HsArrForm (HsVar v) (Just _) [arg1, arg2] _)
= sep [pprCmdArg arg1, hsep [pprInfix v, pprCmdArg arg2]]
ppr_expr (HsArrForm op _ args _)
= hang (ptext SLIT("(|") <> pprExpr op <> ptext SLIT("|)"))
4 (sep (map pprCmdArg args))
pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
pprCmdArg (HsCmdTop cmd@(HsArrForm _ Nothing [] _) _ _ _) = pprExpr cmd
pprCmdArg (HsCmdTop cmd _ _ _) = parens (pprExpr cmd)
-- Put a var in backquotes if it's not an operator already
pprInfix :: Outputable name => name -> SDoc
pprInfix v | isOperator ppr_v = ppr_v
| otherwise = char '`' <> ppr_v <> char '`'
where
ppr_v = ppr v
-- add parallel array brackets around a document
--
pa_brackets :: SDoc -> SDoc
......@@ -418,6 +489,70 @@ pprParendExpr expr
_ -> parens pp_as_was
\end{code}
%************************************************************************
%* *
\subsection{Commands (in arrow abstractions)}
%* *
%************************************************************************
We re-use HsExpr to represent these.
\begin{code}
type HsCmd id = HsExpr id
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}
The legal constructors for commands are:
= HsArrApp ... -- as above
| HsArrForm ... -- as above
| HsLam (Match id) -- kappa
-- the renamer turns this one into HsArrForm
| OpApp (HsExpr id) -- left operand
(HsCmd id) -- operator
Fixity -- Renamer adds fixity; bottom until then
(HsCmd id) -- right operand
| HsPar (HsCmd id) -- parenthesised command
| HsCase (HsExpr id)
[Match id] -- bodies are HsCmd's
SrcLoc
| HsIf (HsExpr id) -- predicate
(HsCmd id) -- then part
(HsCmd id) -- else part
SrcLoc
| HsLet (HsBinds id) -- let(rec)
(HsCmd id)
| HsDo (HsStmtContext Name) -- The parameterisation is unimportant
-- because in this context we never use
-- the PatGuard or ParStmt variant
[Stmt id] -- HsExpr's are really HsCmd's
(ReboundNames id)
PostTcType -- Type of the whole expression
SrcLoc
Top-level command, introducing a new arrow.
This may occur inside a proc (where the stack is empty) or as an
argument of a command-forming operator.
\begin{code}
data HsCmdTop id
= HsCmdTop (HsCmd id)
[PostTcType] -- types of inputs on the command's stack
PostTcType -- return type of the command
(ReboundNames id)
-- after type checking:
-- names used in the command's desugaring
\end{code}
%************************************************************************
%* *
\subsection{Record binds}
......@@ -486,6 +621,11 @@ mkSimpleMatch pats rhs rhs_ty locn
unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id]
unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc]
glueBindsOnGRHSs :: HsBinds id -> GRHSs id -> GRHSs id
glueBindsOnGRHSs EmptyBinds grhss = grhss
glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty)
= GRHSs grhss (binds1 `ThenBinds` binds2) ty
\end{code}
@getMatchLoc@ takes a @Match@ and returns the
......@@ -568,21 +708,25 @@ data Stmt id
-- The type is the *element type* of the expression
-- ParStmts only occur in a list comprehension
| ParStmt [[Stmt id]] -- List comp only: parallel set of quals
| ParStmtOut [([id], [Stmt id])] -- PLC after renaming; the ids are the binders
-- bound by the stmts
-- mdo-notation (only exists after renamer)
-- The ids are a subset of the variables bound by the stmts that
-- either (a) are used before they are bound in the stmts
-- or (b) are used in stmts that follow the RecStmt
| RecStmt [id]
[Stmt id]
[HsExpr id] -- Post type-checking only; these expressions correspond
-- 1-to-1 with the [id], and are the expresions that should
-- be returned by the recursion. They may not quite be the
-- Ids themselves, because the Id may be polymorphic, but
-- the returned thing has to be monomorphic.
| ParStmt [([Stmt id], [id])] -- After remaing, the ids are the binders
-- bound by the stmts and used subsequently
-- Recursive statement
| RecStmt [Stmt id]
--- The next two fields are only valid after renaming
[id] -- The ids are a subset of the variables bound by the stmts
-- that are used in stmts that follow the RecStmt