summaryrefslogtreecommitdiff
path: root/ghc/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/parser')
-rw-r--r--ghc/compiler/parser/UgenAll.lhs4
-rw-r--r--ghc/compiler/parser/UgenUtil.lhs11
-rw-r--r--ghc/compiler/parser/constr.ugn4
-rw-r--r--ghc/compiler/parser/hsparser.y94
-rw-r--r--ghc/compiler/parser/pbinding.ugn3
-rw-r--r--ghc/compiler/parser/syntax.c1
6 files changed, 86 insertions, 31 deletions
diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs
index b9edb427d7..b17b849638 100644
--- a/ghc/compiler/parser/UgenAll.lhs
+++ b/ghc/compiler/parser/UgenAll.lhs
@@ -24,7 +24,11 @@ module UgenAll (
EXP_MODULE(U_ttype)
) where
+#if __GLASGOW_HASKELL__ <= 201
import PreludeGlaST
+#else
+import GlaExts
+#endif
IMP_Ubiq(){-uitous-}
diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs
index 944b217612..bb0d68e631 100644
--- a/ghc/compiler/parser/UgenUtil.lhs
+++ b/ghc/compiler/parser/UgenUtil.lhs
@@ -14,12 +14,21 @@ module UgenUtil (
IMP_Ubiq()
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
import PreludeGlaST
+#else
+import GlaExts
+import Name
+#endif
-#if __GLASGOW_HASKELL__ >= 200
+#if __GLASGOW_HASKELL__ == 201
# define ADDR GHCbase.Addr
# define PACK_STR packCString
# define PACK_BYTES packCBytes
+#elif __GLASGOW_HASKELL >= 202
+# define ADDR GHC.Addr
+# define PACK_STR mkFastCharString
+# define PACK_BYTES mkFastCharString2
#else
# define ADDR _Addr
# define PACK_STR mkFastCharString
diff --git a/ghc/compiler/parser/constr.ugn b/ghc/compiler/parser/constr.ugn
index 30cd438121..65b5b67233 100644
--- a/ghc/compiler/parser/constr.ugn
+++ b/ghc/compiler/parser/constr.ugn
@@ -35,6 +35,10 @@ type constr;
gconnty : ttype;
gconnline : long; >;
+ /* constr with a prefixed context C => ... */
+ constrcxt : < gconcxt : list;
+ gconcon : constr; >;
+
field : < gfieldn : list;
gfieldt : ttype; >;
end;
diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y
index 77351a0740..4ca10ea9f0 100644
--- a/ghc/compiler/parser/hsparser.y
+++ b/ghc/compiler/parser/hsparser.y
@@ -236,7 +236,7 @@ BOOLEAN inpat;
maybefixes fixes fix ops
dtyclses dtycls_list
gdrhs gdpat valrhs
- lampats cexps
+ lampats cexps gd
%type <umaybe> maybeexports impspec deriving
@@ -244,7 +244,7 @@ BOOLEAN inpat;
%type <utree> exp oexp dexp kexp fexp aexp rbind texps
expL oexpL kexpL expLno oexpLno dexpLno kexpLno
- vallhs funlhs qual gd leftexp
+ vallhs funlhs qual leftexp
pat cpat bpat apat apatc conpat rpat
patk bpatk apatck conpatk
@@ -269,12 +269,12 @@ BOOLEAN inpat;
%type <upbinding> valrhs1 altrest
-%type <uttype> simple ctype type atype btype
+%type <uttype> simple ctype sigtype sigarrowtype type atype bigatype btype
gtyconvars
- bbtype batype bxtype bang_atype
- class tyvar
+ bbtype batype bxtype wierd_atype
+ class tyvar contype
-%type <uconstr> constr field
+%type <uconstr> constr constr_after_context field
%type <ustring> FLOAT INTEGER INTPRIM
FLOATPRIM DOUBLEPRIM CLITLIT
@@ -570,7 +570,7 @@ decls : decl
to real mischief (ugly, but likely to work).
*/
-decl : qvarsk DCOLON ctype
+decl : qvarsk DCOLON sigtype
{ $$ = mksbind($1,$3,startlineno);
PREVPATT = NULL; FN = NULL; SAMEFN = 0;
}
@@ -662,18 +662,34 @@ type_and_maybe_id :
context. Blaach!
*/
+/* A sigtype is a rank 2 type; it can have for-alls as function args:
+ f :: All a => (All b => ...) -> Int
+*/
+sigtype : type DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); }
+ | sigarrowtype
+ ;
+
+sigarrowtype : bigatype RARROW sigarrowtype { $$ = mktfun($1,$3); }
+ | btype RARROW sigarrowtype { $$ = mktfun($1,$3); }
+ | btype
+ ;
+
+/* A "big" atype can be a forall-type in brackets. */
+bigatype: OPAREN type DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); }
+ ;
+
/* 1 S/R conflict at DARROW -> shift */
ctype : type DARROW type { $$ = mkcontext(type2context($1),$3); }
| type
;
/* 1 S/R conflict at RARROW -> shift */
-type : btype { $$ = $1; }
- | btype RARROW type { $$ = mktfun($1,$3); }
+type : btype RARROW type { $$ = mktfun($1,$3); }
+ | btype { $$ = $1; }
;
-btype : atype { $$ = $1; }
- | btype atype { $$ = mktapp($1,$2); }
+btype : btype atype { $$ = mktapp($1,$2); }
+ | atype { $$ = $1; }
;
atype : gtycon { $$ = mktname($1); }
@@ -733,12 +749,11 @@ constrs : constr { $$ = lsing($1); }
| constrs VBAR constr { $$ = lapp($1,$3); }
;
-constr : btype { qid tyc; list tys;
- splittyconapp($1, &tyc, &tys);
- $$ = mkconstrpre(tyc,tys,hsplineno); }
- | bxtype { qid tyc; list tys;
- splittyconapp($1, &tyc, &tys);
- $$ = mkconstrpre(tyc,tys,hsplineno); }
+constr : constr_after_context
+ | type DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); }
+ ;
+
+constr_after_context :
/* We have to parse the constructor application as a *type*, else we get
into terrible ambiguity problems. Consider the difference between
@@ -752,31 +767,50 @@ constr : btype { qid tyc; list tys;
second.
*/
- | btype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
- | bang_atype qconop bbtype { $$ = mkconstrinf( $1, $2, $3, hsplineno ); }
+/* Con !Int (Tree a) */
+ contype { qid tyc; list tys;
+ splittyconapp($1, &tyc, &tys);
+ $$ = mkconstrpre(tyc,tys,hsplineno); }
+/* !Int `Con` Tree a */
+ | bbtype qconop bbtype { $$ = mkconstrinf($1,$2,$3,hsplineno); }
+/* (::) (Tree a) Int */
| OPAREN qconsym CPAREN batypes { $$ = mkconstrpre($2,$4,hsplineno); }
+
+/* Con { op1 :: Int } */
| gtycon OCURLY fields CCURLY { $$ = mkconstrrec($1,$3,hsplineno); }
/* 1 S/R conflict on OCURLY -> shift */
;
-/* S !Int Bool */
-bxtype : btype bang_atype { $$ = mktapp($1, $2); }
- | bxtype bbtype { $$ = mktapp($1, $2); }
+
+/* contype has to reduce to a btype unless there are !'s, so that
+ we don't get reduce/reduce conflicts with the second production of constr.
+ But as soon as we see a ! we must switch to using bxtype. */
+
+contype : btype { $$ = $1 }
+ | bxtype { $$ = $1 }
;
+/* S !Int Bool; at least one ! */
+bxtype : btype wierd_atype { $$ = mktapp($1, $2); }
+ | bxtype batype { $$ = mktapp($1, $2); }
+ ;
bbtype : btype { $$ = $1; }
- | bang_atype { $$ = $1; }
+ | wierd_atype { $$ = $1; }
;
batype : atype { $$ = $1; }
- | bang_atype { $$ = $1; }
+ | wierd_atype { $$ = $1; }
;
-bang_atype : BANG atype { $$ = mktbang( $2 ) }
- ;
+/* A wierd atype is one that isn't a regular atype;
+ it starts with a "!", or with a forall. */
+wierd_atype : BANG bigatype { $$ = mktbang( $2 ) }
+ | BANG atype { $$ = mktbang( $2 ) }
+ | bigatype
+ ;
batypes : { $$ = Lnil; }
| batypes batype { $$ = lapp($1,$2); }
@@ -787,8 +821,9 @@ fields : field { $$ = lsing($1); }
| fields COMMA field { $$ = lapp($1,$3); }
;
-field : qvars_list DCOLON type { $$ = mkfield($1,$3); }
+field : qvars_list DCOLON ctype { $$ = mkfield($1,$3); }
| qvars_list DCOLON BANG atype { $$ = mkfield($1,mktbang($4)); }
+ | qvars_list DCOLON BANG bigatype { $$ = mkfield($1,mktbang($4)); }
;
constr1 : gtycon atype { $$ = lsing(mkconstrnew($1,$2,hsplineno)); }
@@ -912,7 +947,7 @@ maybe_where:
| /* empty */ { $$ = mknullbind(); }
;
-gd : VBAR oexp { $$ = $2; }
+gd : VBAR quals { $$ = $2; }
;
@@ -1130,7 +1165,8 @@ quals : qual { $$ = lsing($1); }
qual : letdecls { $$ = mkseqlet($1); }
| expL { $$ = $1; }
- | {inpat=TRUE;} expLno {inpat=FALSE;}leftexp
+ | {inpat=TRUE;} expLno
+ {inpat=FALSE;} leftexp
{ if ($4 == NULL) {
expORpat(LEGIT_EXPR,$2);
$$ = mkguard($2);
diff --git a/ghc/compiler/parser/pbinding.ugn b/ghc/compiler/parser/pbinding.ugn
index f695eac811..2d734eaafd 100644
--- a/ghc/compiler/parser/pbinding.ugn
+++ b/ghc/compiler/parser/pbinding.ugn
@@ -26,6 +26,7 @@ type pbinding;
pnoguards : < gpnoguard : tree; >;
pguards : < gpguards : list; >;
- pgdexp : < gpguard : tree;
+
+ pgdexp : < gpguard : list; /* Experimental change: guards are lists of quals */
gpexp : tree; >;
end;
diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c
index a48b1198cb..4194377164 100644
--- a/ghc/compiler/parser/syntax.c
+++ b/ghc/compiler/parser/syntax.c
@@ -127,6 +127,7 @@ expORpat(int wanted, tree e)
case clitlit:
error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
+ break;
default: /* the others only occur in pragmas */
hsperror("not a valid literal pattern or expression");
View Lorry Controller Status