summaryrefslogtreecommitdiff
path: root/ghc/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/parser')
-rw-r--r--ghc/compiler/parser/Lex.lhs16
-rw-r--r--ghc/compiler/parser/ParseUtil.lhs9
-rw-r--r--ghc/compiler/parser/Parser.y24
-rw-r--r--ghc/compiler/parser/RdrHsSyn.lhs11
-rw-r--r--ghc/compiler/parser/ctypes.c116
-rw-r--r--ghc/compiler/parser/ctypes.h6
6 files changed, 109 insertions, 73 deletions
diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index c86721c9f6..8dae914d65 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -128,6 +128,7 @@ data Token
| ITlabel
| ITdynamic
| ITunsafe
+ | ITwith
| ITstdcallconv
| ITccallconv
@@ -208,6 +209,8 @@ data Token
| ITqvarsym (FAST_STRING,FAST_STRING)
| ITqconsym (FAST_STRING,FAST_STRING)
+ | ITipvarid FAST_STRING -- GHC extension: implicit param: ?x
+
| ITpragma StringBuffer
| ITchar Char
@@ -282,6 +285,7 @@ ghcExtensionKeywordsFM = listToUFM $
( "label", ITlabel ),
( "dynamic", ITdynamic ),
( "unsafe", ITunsafe ),
+ ( "with", ITwith ),
( "stdcall", ITstdcallconv),
( "ccall", ITccallconv),
("_ccall_", ITccall (False, False, False)),
@@ -590,6 +594,8 @@ lexToken cont glaexts buf =
trace "lexIface: misplaced NUL?" $
cont (ITunknown "\NUL") (stepOn buf)
+ '?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
+ lex_ip cont (setCurrentPos# buf 1#)
c | is_digit c -> lex_num cont glaexts 0 buf
| is_symbol c -> lex_sym cont buf
| is_upper c -> lex_con cont glaexts buf
@@ -892,12 +898,18 @@ is_ident = is_ctype 1
is_symbol = is_ctype 2
is_any = is_ctype 4
is_space = is_ctype 8
-is_upper = is_ctype 16
-is_digit = is_ctype 32
+is_lower = is_ctype 16
+is_upper = is_ctype 32
+is_digit = is_ctype 64
-----------------------------------------------------------------------------
-- identifiers, symbols etc.
+lex_ip cont buf =
+ case expandWhile# is_ident buf of
+ buf' -> cont (ITipvarid lexeme) buf'
+ where lexeme = lexemeToFastString buf'
+
lex_id cont glaexts buf =
case expandWhile# is_ident buf of { buf1 ->
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index a679d3aafd..b410fee27c 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -137,15 +137,15 @@ checkInstType t
checkContext :: RdrNameHsType -> P RdrNameContext
checkContext (MonoTupleTy ts True)
= mapP (\t -> checkAssertion t []) ts `thenP` \cs ->
- returnP cs
+ returnP (map (uncurry HsPClass) cs)
checkContext (MonoTyVar t) -- empty contexts are allowed
| t == unitTyCon_RDR = returnP []
checkContext t
- = checkAssertion t [] `thenP` \c ->
- returnP [c]
+ = checkAssertion t [] `thenP` \(c,ts) ->
+ returnP [HsPClass c ts]
checkAssertion :: RdrNameHsType -> [RdrNameHsType]
- -> P (ClassAssertion RdrName)
+ -> P (HsClassAssertion RdrName)
checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t)
= returnP (t,args)
checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args)
@@ -239,6 +239,7 @@ patterns).
checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr
checkExpr e = case e of
HsVar _ -> returnP e
+ HsIPVar _ -> returnP e
HsLit _ -> returnP e
HsLam match -> checkMatch match `thenP` (returnP.HsLam)
HsApp e1 e2 -> check2Exprs e1 e2 HsApp
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 87f6458f79..759c2dcff1 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.18 1999/12/01 17:01:36 simonmar Exp $
+$Id: Parser.y,v 1.19 2000/01/28 20:52:39 lewie Exp $
Haskell grammar.
@@ -19,7 +19,7 @@ import Lex
import ParseUtil
import RdrName
import PrelMods ( mAIN_Name )
-import OccName ( varName, dataName, tcClsName, tvName )
+import OccName ( varName, ipName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
import CallConv
@@ -85,6 +85,7 @@ Conflicts: 14 shift/reduce
'then' { ITthen }
'type' { ITtype }
'where' { ITwhere }
+ 'with' { ITwith }
'_scc_' { ITscc }
'forall' { ITforall } -- GHC extension keywords
@@ -173,6 +174,7 @@ Conflicts: 14 shift/reduce
QCONID { ITqconid $$ }
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
+ IPVARID { ITipvarid $$ }
PRAGMA { ITpragma $$ }
@@ -633,6 +635,7 @@ gdrh :: { RdrNameGRHS }
exp :: { RdrNameHsExpr }
: infixexp '::' sigtype { ExprWithTySig $1 $3 }
+ | infixexp 'with' dbinding { HsWith $1 $3 }
| infixexp { $1 }
infixexp :: { RdrNameHsExpr }
@@ -683,6 +686,7 @@ aexp :: { RdrNameHsExpr }
aexp1 :: { RdrNameHsExpr }
: qvar { HsVar $1 }
+ | IPVARID { HsIPVar (mkSrcUnqual ipName $1) }
| gcon { HsVar $1 }
| literal { HsLit $1 }
| '(' exp ')' { HsPar $2 }
@@ -816,6 +820,22 @@ fbind :: { (RdrName, RdrNameHsExpr, Bool) }
: qvar '=' exp { ($1,$3,False) }
-----------------------------------------------------------------------------
+-- Implicit Parameter Bindings
+
+dbinding :: { [(RdrName, RdrNameHsExpr)] }
+ : '{' dbinds '}' { $2 }
+ | layout_on dbinds close { $2 }
+
+dbinds :: { [(RdrName, RdrNameHsExpr)] }
+ : dbinds ';' dbind { $3 : $1 }
+ | dbinds ';' { $1 }
+ | dbind { [$1] }
+ | {- empty -} { [] }
+
+dbind :: { (RdrName, RdrNameHsExpr) }
+dbind : IPVARID '=' exp { (mkSrcUnqual ipName $1, $3) }
+
+-----------------------------------------------------------------------------
-- Variables, Constructors and Operators.
gcon :: { RdrName }
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 23801c75f2..32085d4730 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -88,7 +88,7 @@ type RdrNameBangType = BangType RdrName
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
type RdrNameConDetails = ConDetails RdrName
-type RdrNameContext = Context RdrName
+type RdrNameContext = HsContext RdrName
type RdrNameHsDecl = HsDecl RdrName RdrNamePat
type RdrNameSpecDataSig = SpecDataSig RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
@@ -147,12 +147,13 @@ extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
go (RuleBndr _) acc = acc
go (RuleBndrSig _ ty) acc = extract_ty ty acc
-extractHsCtxtRdrNames :: Context RdrName -> [RdrName]
+extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
-extract_ctxt ctxt acc = foldr extract_ass acc ctxt
- where
- extract_ass (cls, tys) acc = foldr extract_ty (cls : acc) tys
+extract_ctxt ctxt acc = foldr extract_pred acc ctxt
+
+extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
+extract_pred (HsPIParam n ty) acc = extract_ty ty acc
extract_tys tys acc = foldr extract_ty acc tys
diff --git a/ghc/compiler/parser/ctypes.c b/ghc/compiler/parser/ctypes.c
index cb0937991b..0e3daafae1 100644
--- a/ghc/compiler/parser/ctypes.c
+++ b/ghc/compiler/parser/ctypes.c
@@ -103,34 +103,34 @@ const unsigned char char_types[] =
C_Any | C_Symbol, /* \ */
C_Any, /* ] */
C_Any | C_Symbol, /* ^ */
- C_Any | C_Ident, /* _ */
+ C_Any | C_Ident | C_Lower, /* _ */
C_Any, /* ` */
- C_Any | C_Ident, /* a */
- C_Any | C_Ident, /* b */
- C_Any | C_Ident, /* c */
- C_Any | C_Ident, /* d */
- C_Any | C_Ident, /* e */
- C_Any | C_Ident, /* f */
- C_Any | C_Ident, /* g */
- C_Any | C_Ident, /* h */
- C_Any | C_Ident, /* i */
- C_Any | C_Ident, /* j */
- C_Any | C_Ident, /* k */
- C_Any | C_Ident, /* l */
- C_Any | C_Ident, /* m */
- C_Any | C_Ident, /* n */
- C_Any | C_Ident, /* o */
- C_Any | C_Ident, /* p */
- C_Any | C_Ident, /* q */
- C_Any | C_Ident, /* r */
- C_Any | C_Ident, /* s */
- C_Any | C_Ident, /* t */
- C_Any | C_Ident, /* u */
- C_Any | C_Ident, /* v */
- C_Any | C_Ident, /* w */
- C_Any | C_Ident, /* x */
- C_Any | C_Ident, /* y */
- C_Any | C_Ident, /* z */
+ C_Any | C_Ident | C_Lower, /* a */
+ C_Any | C_Ident | C_Lower, /* b */
+ C_Any | C_Ident | C_Lower, /* c */
+ C_Any | C_Ident | C_Lower, /* d */
+ C_Any | C_Ident | C_Lower, /* e */
+ C_Any | C_Ident | C_Lower, /* f */
+ C_Any | C_Ident | C_Lower, /* g */
+ C_Any | C_Ident | C_Lower, /* h */
+ C_Any | C_Ident | C_Lower, /* i */
+ C_Any | C_Ident | C_Lower, /* j */
+ C_Any | C_Ident | C_Lower, /* k */
+ C_Any | C_Ident | C_Lower, /* l */
+ C_Any | C_Ident | C_Lower, /* m */
+ C_Any | C_Ident | C_Lower, /* n */
+ C_Any | C_Ident | C_Lower, /* o */
+ C_Any | C_Ident | C_Lower, /* p */
+ C_Any | C_Ident | C_Lower, /* q */
+ C_Any | C_Ident | C_Lower, /* r */
+ C_Any | C_Ident | C_Lower, /* s */
+ C_Any | C_Ident | C_Lower, /* t */
+ C_Any | C_Ident | C_Lower, /* u */
+ C_Any | C_Ident | C_Lower, /* v */
+ C_Any | C_Ident | C_Lower, /* w */
+ C_Any | C_Ident | C_Lower, /* x */
+ C_Any | C_Ident | C_Lower, /* y */
+ C_Any | C_Ident | C_Lower, /* z */
C_Any, /* { */
C_Any | C_Symbol, /* | */
C_Any, /* } */
@@ -223,7 +223,7 @@ const unsigned char char_types[] =
C_Any | C_Ident | C_Upper, /* Ô */
C_Any | C_Ident | C_Upper, /* Õ */
C_Any | C_Ident | C_Upper, /* Ö */
- C_Any | C_Symbol, /* × */
+ C_Any | C_Symbol | C_Lower, /* × */
C_Any | C_Ident | C_Upper, /* Ø */
C_Any | C_Ident | C_Upper, /* Ù */
C_Any | C_Ident | C_Upper, /* Ú */
@@ -232,36 +232,36 @@ const unsigned char char_types[] =
C_Any | C_Ident | C_Upper, /* Ý */
C_Any | C_Ident | C_Upper, /* Þ */
C_Any | C_Ident, /* ß */
- C_Any | C_Ident, /* à */
- C_Any | C_Ident, /* á */
- C_Any | C_Ident, /* â */
- C_Any | C_Ident, /* ã */
- C_Any | C_Ident, /* ä */
- C_Any | C_Ident, /* å */
- C_Any | C_Ident, /* æ */
- C_Any | C_Ident, /* ç */
- C_Any | C_Ident, /* è */
- C_Any | C_Ident, /* é */
- C_Any | C_Ident, /* ê */
- C_Any | C_Ident, /* ë */
- C_Any | C_Ident, /* ì */
- C_Any | C_Ident, /* í */
- C_Any | C_Ident, /* î */
- C_Any | C_Ident, /* ï */
- C_Any | C_Ident, /* ð */
- C_Any | C_Ident, /* ñ */
- C_Any | C_Ident, /* ò */
- C_Any | C_Ident, /* ó */
- C_Any | C_Ident, /* ô */
- C_Any | C_Ident, /* õ */
- C_Any | C_Ident, /* ö */
+ C_Any | C_Ident | C_Lower, /* à */
+ C_Any | C_Ident | C_Lower, /* á */
+ C_Any | C_Ident | C_Lower, /* â */
+ C_Any | C_Ident | C_Lower, /* ã */
+ C_Any | C_Ident | C_Lower, /* ä */
+ C_Any | C_Ident | C_Lower, /* å */
+ C_Any | C_Ident | C_Lower, /* æ */
+ C_Any | C_Ident | C_Lower, /* ç */
+ C_Any | C_Ident | C_Lower, /* è */
+ C_Any | C_Ident | C_Lower, /* é */
+ C_Any | C_Ident | C_Lower, /* ê */
+ C_Any | C_Ident | C_Lower, /* ë */
+ C_Any | C_Ident | C_Lower, /* ì */
+ C_Any | C_Ident | C_Lower, /* í */
+ C_Any | C_Ident | C_Lower, /* î */
+ C_Any | C_Ident | C_Lower, /* ï */
+ C_Any | C_Ident | C_Lower, /* ð */
+ C_Any | C_Ident | C_Lower, /* ñ */
+ C_Any | C_Ident | C_Lower, /* ò */
+ C_Any | C_Ident | C_Lower, /* ó */
+ C_Any | C_Ident | C_Lower, /* ô */
+ C_Any | C_Ident | C_Lower, /* õ */
+ C_Any | C_Ident | C_Lower, /* ö */
C_Any | C_Symbol, /* ÷ */
C_Any | C_Ident, /* ø */
- C_Any | C_Ident, /* ù */
- C_Any | C_Ident, /* ú */
- C_Any | C_Ident, /* û */
- C_Any | C_Ident, /* ü */
- C_Any | C_Ident, /* ý */
- C_Any | C_Ident, /* þ */
- C_Any | C_Ident, /* ÿ */
+ C_Any | C_Ident | C_Lower, /* ù */
+ C_Any | C_Ident | C_Lower, /* ú */
+ C_Any | C_Ident | C_Lower, /* û */
+ C_Any | C_Ident | C_Lower, /* ü */
+ C_Any | C_Ident | C_Lower, /* ý */
+ C_Any | C_Ident | C_Lower, /* þ */
+ C_Any | C_Ident | C_Lower, /* ÿ */
};
diff --git a/ghc/compiler/parser/ctypes.h b/ghc/compiler/parser/ctypes.h
index 03cf2ceab6..a67e1620a2 100644
--- a/ghc/compiler/parser/ctypes.h
+++ b/ghc/compiler/parser/ctypes.h
@@ -8,8 +8,9 @@
#define C_Symbol 1<<1
#define C_Any 1<<2
#define C_Space 1<<3
-#define C_Upper 1<<4
-#define C_Digit 1<<5
+#define C_Lower 1<<4
+#define C_Upper 1<<5
+#define C_Digit 1<<6
#define _IsType(c,flags) (char_types[(int)(c)] & flags)
@@ -17,6 +18,7 @@
#define IsIdent(c) (_IsType(c,C_Ident))
#define IsAny(c) (_IsType(c,C_Any))
#define IsSymbol(c) (_IsType(c,C_Symbol))
+#define IsLower(c) (_IsType(c,C_Lower))
#define IsUpper(c) (_IsType(c,C_Upper))
#define IsDigit(c) (_IsType(c,C_Digit))
View Lorry Controller Status