Commit 16e4ce4c authored by simonpj's avatar simonpj

[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)
......
This diff is collapsed.
......@@ -22,7 +22,7 @@ module HsSyn (
Fixity, NewOrData,
HsModule(..),
collectStmtsBinders,
collectStmtsBinders, collectStmtBinders,
collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
collectSigTysFromHsBinds, collectSigTysFromMonoBinds
......@@ -148,6 +148,9 @@ collectMonoBinders binds
go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc
go (FunMonoBind f _ _ loc) acc = f : acc
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
go (VarMonoBind v _) acc = v : acc
go (AbsBinds _ _ dbinds _ binds) acc
= [dp | (_,dp,_) <- dbinds] ++ go binds acc
\end{code}
......@@ -195,6 +198,7 @@ collectStmtBinders (BindStmt pat _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectHsBinders binds
collectStmtBinders (ExprStmt _ _ _) = []
collectStmtBinders (ResultStmt _ _) = []
collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
collectStmtBinders other = panic "collectStmtBinders"
\end{code}
......@@ -293,6 +293,7 @@ data DynFlag
| Opt_FFI
| Opt_PArr -- syntactic support for parallel arrays
| Opt_With -- deprecated keyword for implicit parms
| Opt_Arrows -- Arrow-notation syntax
| Opt_Generics
| Opt_NoImplicitPrelude
......
-----------------------------------------------------------------------------
-- $Id: DriverFlags.hs,v 1.116 2003/06/23 10:35:17 simonpj Exp $
-- $Id: DriverFlags.hs,v 1.117 2003/06/24 07:58:20 simonpj Exp $
--
-- Driver flags
--
......@@ -455,6 +455,7 @@ fFlags = [
( "fi", Opt_FFI ), -- support `-ffi'...
( "ffi", Opt_FFI ), -- ...and also `-fffi'
( "with", Opt_With ), -- with keyword
( "arrows", Opt_Arrows ), -- arrow syntax
( "parr", Opt_PArr ),
( "allow-overlapping-instances", Opt_AllowOverlappingInstances ),
( "allow-undecidable-instances", Opt_AllowUndecidableInstances ),
......
......@@ -387,10 +387,7 @@ myParseModule dflags src_filename
_scc_ "Parser" do
buf <- hGetStringBuffer src_filename
let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
ffiEF = dopt Opt_FFI dflags,
withEF = dopt Opt_With dflags,
parrEF = dopt Opt_PArr dflags}
let exts = mkExtFlags dflags
loc = mkSrcLoc (mkFastString src_filename) 1
case parseModule buf (mkPState loc exts) of {
......@@ -513,10 +510,7 @@ hscParseStmt dflags str
buf <- stringToStringBuffer str
let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
ffiEF = dopt Opt_FFI dflags,
withEF = dopt Opt_With dflags,
parrEF = dopt Opt_PArr dflags}
let exts = mkExtFlags dflags
loc = mkSrcLoc FSLIT("<interactive>") 1
case parseStmt buf (mkPState loc exts) of {
......@@ -574,10 +568,7 @@ hscThing hsc_env pcs0 ic str
myParseIdentifier dflags str
= do buf <- stringToStringBuffer str
let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
ffiEF = dopt Opt_FFI dflags,
withEF = dopt Opt_With dflags,
parrEF = dopt Opt_PArr dflags}
let exts = mkExtFlags dflags
loc = mkSrcLoc FSLIT("<interactive>") 1
case parseIdentifier buf (mkPState loc exts) of
......@@ -683,4 +674,11 @@ initExternalPackageState
initOrigNames :: OrigNameCache
initOrigNames = foldl extendOrigNameCache emptyModuleEnv knownKeyNames
mkExtFlags dflags
= ExtFlags { glasgowExtsEF = dopt Opt_GlasgowExts dflags,
ffiEF = dopt Opt_FFI dflags,
withEF = dopt Opt_With dflags,
arrowsEF = dopt Opt_Arrows dflags,
parrEF = dopt Opt_PArr dflags}
\end{code}
......@@ -98,6 +98,7 @@ loadPackageConfig conf_filename = do
let loc = mkSrcLoc (mkFastString conf_filename) 1
exts = ExtFlags {glasgowExtsEF = False,
ffiEF = False,
arrowsEF = False,
withEF = False,
parrEF = False}
case parse buf (mkPState loc exts) of
......
......@@ -210,6 +210,16 @@ data Token
| ITreifyDecl
| ITreifyFixity
-- Arrow notation extension
| ITproc
| ITrec
| IToparenbar -- (|
| ITcparenbar -- |)
| ITlarrowtail -- -<
| ITrarrowtail -- >-
| ITLarrowtail -- -<<
| ITRarrowtail -- >>-
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
deriving Show -- debugging
......@@ -295,6 +305,13 @@ isSpecial _ = False
ghcExtensionKeywordsFM = listToUFM $
map (\(x, y, z) -> (mkFastString x, (y, z)))
[ ( "forall", ITforall, bit glaExtsBit),
( "mdo", ITmdo, bit glaExtsBit),
( "reifyDecl", ITreifyDecl, bit glaExtsBit),
( "reifyType", ITreifyType, bit glaExtsBit),
( "reifyFixity",ITreifyFixity, bit glaExtsBit),
( "rec", ITrec, bit glaExtsBit .|. bit arrowsBit),
( "foreign", ITforeign, bit ffiBit),
( "export", ITexport, bit ffiBit),
( "label", ITlabel, bit ffiBit),
......@@ -302,14 +319,15 @@ ghcExtensionKeywordsFM = listToUFM $
( "safe", ITsafe, bit ffiBit),
( "threadsafe", ITthreadsafe, bit ffiBit),
( "unsafe", ITunsafe, bit ffiBit),
( "with", ITwith, bit withBit),
( "mdo", ITmdo, bit glaExtsBit),
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "dotnet", ITdotnet, bit ffiBit),
( "reifyDecl", ITreifyDecl, bit glaExtsBit),
( "reifyType", ITreifyType, bit glaExtsBit),
( "reifyFixity",ITreifyFixity, bit glaExtsBit),
( "with", ITwith, bit withBit),
( "proc", ITproc, bit arrowsBit),
-- On death row
("_ccall_", ITccall (False, False, PlayRisky),
bit glaExtsBit),
("_ccall_GC_", ITccall (False, False, PlaySafe False),
......@@ -321,23 +339,29 @@ ghcExtensionKeywordsFM = listToUFM $
]
haskellKeySymsFM = listToUFM $
map (\ (x,y) -> (mkFastString x,y))
[ ("..", ITdotdot)
,(":", ITcolon) -- (:) is a reserved op,
map (\ (x,y,z) -> (mkFastString x,(y,z)))
[ ("..", ITdotdot, Nothing)
,(":", ITcolon, Nothing) -- (:) is a reserved op,
-- meaning only list cons
,("::", ITdcolon)
,("=", ITequal)
,("\\", ITlam)
,("|", ITvbar)
,("<-", ITlarrow)
,("->", ITrarrow)
,("@", ITat)
,("~", ITtilde)
,("=>", ITdarrow)
,("-", ITminus)
,("!", ITbang)
,("*", ITstar)
,(".", ITdot) -- sadly, for 'forall a . t'
,("::", ITdcolon, Nothing)
,("=", ITequal, Nothing)
,("\\", ITlam, Nothing)
,("|", ITvbar, Nothing)
,("<-", ITlarrow, Nothing)
,("->", ITrarrow, Nothing)
,("@", ITat, Nothing)
,("~", ITtilde, Nothing)
,("=>", ITdarrow, Nothing)
,("-", ITminus, Nothing)
,("!", ITbang, Nothing)
,("*", ITstar, Just (bit glaExtsBit)) -- For data T (a::*) = MkT
,(".", ITdot, Just (bit glaExtsBit)) -- For 'forall a . t'
,("-<", ITlarrowtail, Just (bit arrowsBit))
,(">-", ITrarrowtail, Just (bit arrowsBit))
,("-<<", ITLarrowtail, Just (bit arrowsBit))
,(">>-", ITRarrowtail, Just (bit arrowsBit))
]
\end{code}
......@@ -537,8 +561,14 @@ lexToken cont exts buf =
case currentChar# buf of
-- special symbols ----------------------------------------------------
'('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'#
'('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'# &&
-- Unboxed tules: '(#' but not '(##'
not (lookAhead# buf 2# `eqChar#` '#'#)
-> cont IToubxparen (addToCurrentPos buf 2#)
-- Arrow notation extension: '(|' but not '(||'
| arrowsEnabled exts && lookAhead# buf 1# `eqChar#` '|'# &&
not (lookAhead# buf 2# `eqChar#` '|'#)
-> cont IToparenbar (addToCurrentPos buf 2#)
| otherwise
-> cont IToparen (incCurrentPos buf)
......@@ -572,12 +602,15 @@ lexToken cont exts buf =
'}'# | glaExtsEnabled exts -> cont ITccurlybar
(addToCurrentPos buf 2#)
-- MetaHaskell extension
']'# | glaExtsEnabled exts -> cont ITcloseQuote (addToCurrentPos buf 2#)
other -> lex_sym cont (incCurrentPos buf)
']'# | glaExtsEnabled exts -> cont ITcloseQuote (addToCurrentPos buf 2#)
-- arrow notation extension
')'# | arrowsEnabled exts -> cont ITcparenbar
(addToCurrentPos buf 2#)
other -> lex_sym cont exts (incCurrentPos buf)
':'# -> case lookAhead# buf 1# of
']'# | parrEnabled exts -> cont ITcpabrack
(addToCurrentPos buf 2#)
_ -> lex_sym cont (incCurrentPos buf)
_ -> lex_sym cont exts (incCurrentPos buf)
'#'# -> case lookAhead# buf 1# of
......@@ -585,8 +618,8 @@ lexToken cont exts buf =
-> cont ITcubxparen (addToCurrentPos buf 2#)
'-'# -> case lookAhead# buf 2# of
'}'# -> cont ITclose_prag (addToCurrentPos buf 3#)
_ -> lex_sym cont (incCurrentPos buf)
_ -> lex_sym cont (incCurrentPos buf)
_ -> lex_sym cont exts (incCurrentPos buf)
_ -> lex_sym cont exts (incCurrentPos buf)
'`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'#
-> lex_cstring cont (addToCurrentPos buf 2#)
......@@ -637,7 +670,7 @@ lexToken cont exts buf =
((lookAhead# buf 1#) `eqChar#` '('#) -> cont ITparenEscape (addToCurrentPos buf 2#)
c | is_digit c -> lex_num cont exts 0 buf
| is_symbol c -> lex_sym cont buf
| is_symbol c -> lex_sym cont exts buf
| is_upper c -> lex_con cont exts buf
| is_lower c -> lex_id cont exts buf
| otherwise -> lexError "illegal character" buf
......@@ -964,14 +997,16 @@ lex_id cont exts buf =
}}}
lex_sym cont buf =
lex_sym cont exts buf =
-- trace "lex_sym" $
case expandWhile# is_symbol buf of
buf' -> case lookupUFM haskellKeySymsFM lexeme of {
Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
cont kwd_token buf' ;
Nothing -> --trace ("sym: "++unpackFS lexeme) $
cont (mk_var_token lexeme) buf'
Just (kwd_token, Nothing)
-> cont kwd_token buf' ;
Just (kwd_token, Just validExts)
| validExts .&. toInt32 exts /= 0
-> cont kwd_token buf' ;
other -> cont (mk_var_token lexeme) buf'
}
where lexeme = lexemeToFastString buf'
......@@ -1275,12 +1310,14 @@ glaExtsBit = 0
ffiBit = 1
parrBit = 2
withBit = 3
arrowsBit = 4
glaExtsEnabled, ffiEnabled, parrEnabled :: Int# -> Bool
glaExtsEnabled flags = testBit (toInt32 flags) glaExtsBit
ffiEnabled flags = testBit (toInt32 flags) ffiBit
withEnabled flags = testBit (toInt32 flags) withBit
parrEnabled flags = testBit (toInt32 flags) parrBit
arrowsEnabled flags = testBit (toInt32 flags) arrowsBit
toInt32 :: Int# -> Int32
toInt32 x# = fromIntegral (I# x#)
......@@ -1293,7 +1330,8 @@ data ExtFlags = ExtFlags {
glasgowExtsEF :: Bool,
ffiEF :: Bool,
withEF :: Bool,
parrEF :: Bool
parrEF :: Bool,
arrowsEF :: Bool
}
-- create a parse state
......@@ -1313,6 +1351,7 @@ mkPState loc exts =
|| glasgowExtsEF exts)
.|. withBit `setBitIf` withEF exts
.|. parrBit `setBitIf` parrEF exts
.|. arrowsBit `setBitIf` arrowsEF exts
--
setBitIf :: Int -> Bool -> Int32
b `setBitIf` cond | cond = bit b
......
{- -*-haskell-*-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.119 2003/06/23 10:35:22 simonpj Exp $
$Id: Parser.y,v 1.120 2003/06/24 07:58:22 simonpj Exp $
Haskell grammar.
......@@ -130,6 +130,8 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
'stdcall' { ITstdcallconv }
'ccall' { ITccallconv }
'dotnet' { ITdotnet }
'proc' { ITproc } -- for arrow notation extension
'rec' { ITrec } -- for arrow notation extension
'_ccall_' { ITccall (False, False, PlayRisky) }
'_ccall_GC_' { ITccall (False, False, PlaySafe False) }
'_casm_' { ITccall (False, True, PlayRisky) }
......@@ -189,6 +191,10 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
'-' { ITminus }
'!' { ITbang }
'*' { ITstar }
'-<' { ITlarrowtail } -- for arrow notation
'>-' { ITrarrowtail } -- for arrow notation
'-<<' { ITLarrowtail } -- for arrow notation
'>>-' { ITRarrowtail } -- for arrow notation
'.' { ITdot }
'{' { ITocurly } -- special symbols
......@@ -204,6 +210,8 @@ Conflicts: 29 shift/reduce, [SDM 19/9/2002]
')' { ITcparen }
'(#' { IToubxparen }
'#)' { ITcubxparen }
'(|' { IToparenbar }
'|)' { ITcparenbar }
';' { ITsemi }
',' { ITcomma }
'`' { ITbackquote }
......@@ -927,6 +935,10 @@ sigdecl :: { RdrBinding }
exp :: { RdrNameHsExpr }
: infixexp '::' sigtype { ExprWithTySig $1 $3 }
| infixexp 'with' dbinding { HsLet (IPBinds $3 True{-not a let-}) $1 }
| fexp srcloc '-<' exp { HsArrApp $1 $4 placeHolderType HsFirstOrderApp True $2 }
| fexp srcloc '>-' exp { HsArrApp $4 $1 placeHolderType HsFirstOrderApp False $2 }
| fexp srcloc '-<<' exp { HsArrApp $1 $4 placeHolderType HsHigherOrderApp True $2 }
| fexp srcloc '>>-' exp { HsArrApp $4 $1 placeHolderType HsHigherOrderApp False $2 }
| infixexp { $1 }
infixexp :: { RdrNameHsExpr }
......@@ -958,6 +970,12 @@ exp10 :: { RdrNameHsExpr }
then HsSCC $1 $2
else HsPar $2 }
| 'proc' srcloc aexp '->' srcloc exp
{% checkPattern $2 $3 `thenP` \ p ->
returnP (HsProc p