summaryrefslogtreecommitdiff
path: root/ghc/compiler/parser
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/parser')
-rw-r--r--ghc/compiler/parser/Lex.lhs29
-rw-r--r--ghc/compiler/parser/ParseUtil.lhs27
-rw-r--r--ghc/compiler/parser/Parser.y90
-rw-r--r--ghc/compiler/parser/RdrHsSyn.lhs21
4 files changed, 92 insertions, 75 deletions
diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 6b1e21242c..ab4bf3c7bb 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -145,6 +145,9 @@ data Token
| ITbottom
| ITinteger_lit
| ITfloat_lit
+ | ITword_lit
+ | ITword64_lit
+ | ITint64_lit
| ITrational_lit
| ITaddr_lit
| ITlit_lit
@@ -158,8 +161,8 @@ data Token
| ITunfold InlinePragInfo
| ITstrict ([Demand], Bool)
| ITrules
+ | ITcprinfo
| ITdeprecated
- | ITcprinfo (CprInfo)
| IT__scc
| ITsccAllCafs
@@ -311,6 +314,9 @@ ghcExtensionKeywordsFM = listToUFM $
("__bot", ITbottom),
("__integer", ITinteger_lit),
("__float", ITfloat_lit),
+ ("__int64", ITint64_lit),
+ ("__word", ITword_lit),
+ ("__word64", ITword64_lit),
("__rational", ITrational_lit),
("__addr", ITaddr_lit),
("__litlit", ITlit_lit),
@@ -574,8 +580,8 @@ lexToken cont glaexts buf =
lex_demand cont (stepOnUntil (not . isSpace)
(stepOnBy# buf 3#)) -- past __S
'M'# ->
- lex_cpr cont (stepOnUntil (not . isSpace)
- (stepOnBy# buf 3#)) -- past __M
+ cont ITcprinfo (stepOnBy# buf 3#) -- past __M
+
's'# ->
case prefixMatch (stepOnBy# buf 3#) "cc" of
Just buf' -> lex_scc cont (stepOverLexeme buf')
@@ -799,23 +805,6 @@ lex_demand cont buf =
= case read_em [] buf of
(stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
-lex_cpr cont buf =
- case read_em [] buf of { (cpr_inf,buf') ->
- ASSERT ( null (tail cpr_inf) )
- cont (ITcprinfo $ head cpr_inf) buf'
- }
- where
- -- code snatched from lex_demand above
- read_em acc buf =
- case currentChar# buf of
- '-'# -> read_em (NoCPRInfo : acc) (stepOn buf)
- '('# -> do_unpack acc (stepOn buf)
- ')'# -> (reverse acc, stepOn buf)
- _ -> (reverse acc, buf)
-
- do_unpack acc buf
- = case read_em [] buf of
- (stuff, rest) -> read_em ((CPRInfo stuff) : acc) rest
------------------
lex_scc cont buf =
diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs
index e26415e4d9..2372e4a769 100644
--- a/ghc/compiler/parser/ParseUtil.lhs
+++ b/ghc/compiler/parser/ParseUtil.lhs
@@ -25,6 +25,7 @@ module ParseUtil (
, checkPatterns -- [HsExp] -> P [HsPat]
-- , checkExpr -- HsExp -> P HsExp
, checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
+ , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
-- some built-in names (all :: RdrName)
@@ -54,7 +55,7 @@ import RdrHsSyn
import RdrName
import CallConv
import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr )
-import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameFS )
+import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString )
import CmdLineOpts ( opt_NoImplicitPrelude )
import StringBuffer ( lexemeToString )
import FastString ( unpackFS )
@@ -318,17 +319,26 @@ checkValDef
-> Maybe RdrNameHsType
-> RdrNameGRHSs
-> SrcLoc
- -> P RdrNameMonoBinds
+ -> P RdrBinding
checkValDef lhs opt_sig grhss loc
= case isFunLhs lhs [] of
Just (f,inf,es) ->
checkPatterns es `thenP` \ps ->
- returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)
+ returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
Nothing ->
checkPattern lhs `thenP` \lhs ->
- returnP (PatMonoBind lhs grhss loc)
+ returnP (RdrValBinding (PatMonoBind lhs grhss loc))
+
+checkValSig
+ :: RdrNameHsExpr
+ -> RdrNameHsType
+ -> SrcLoc
+ -> P RdrBinding
+checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc))
+checkValSig other ty loc = parseError "Type signature given for an expression"
+
-- A variable binding is parsed as an RdrNamePatBind.
@@ -359,12 +369,15 @@ mkRecConstrOrUpdate exp fs@(_:_)
mkRecConstrOrUpdate _ _
= parseError "Empty record update"
--- supplying the ext_name in a foreign decl is optional ; if it
+-- Supplying the ext_name in a foreign decl is optional ; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
-- of the Haskell name is then performed, so if you foreign export (++),
--- it's external name will be "++". Too bad.
+-- it's external name will be "++". Too bad; it's important because we don't
+-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
+-- (This is why we use occNameUserString.)
mkExtName :: Maybe ExtName -> RdrName -> ExtName
-mkExtName Nothing rdrNm = ExtName (occNameFS (rdrNameOcc rdrNm)) Nothing
+mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm)))
+ Nothing
mkExtName (Just x) _ = x
-----------------------------------------------------------------------------
diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index bfb325789d..a1f02831e0 100644
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.27 2000/03/02 22:51:30 lewie Exp $
+$Id: Parser.y,v 1.28 2000/03/23 17:45:22 simonpj Exp $
Haskell grammar.
@@ -381,9 +381,8 @@ decls :: { [RdrBinding] }
| {- empty -} { [] }
decl :: { RdrBinding }
- : signdecl { $1 }
- | fixdecl { $1 }
- | valdef { RdrValBinding $1 }
+ : fixdecl { $1 }
+ | valdef { $1 }
| '{-# INLINE' srcloc opt_phase qvar '#-}' { RdrSig (InlineSig $4 $3 $2) }
| '{-# NOINLINE' srcloc opt_phase qvar '#-}' { RdrSig (NoInlineSig $4 $3 $2) }
| '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}'
@@ -422,29 +421,12 @@ fixdecl :: { RdrBinding }
(Fixity $3 $2) $1))
| n <- $4 ] }
-signdecl :: { RdrBinding }
- : vars srcloc '::' sigtype { foldr1 RdrAndBindings
- [ RdrSig (Sig n $4 $2) | n <- $1 ] }
-
sigtype :: { RdrNameHsType }
- : ctype { mkHsForAllTy Nothing [] $1 }
+ : ctype { mkHsForAllTy Nothing [] $1 }
-{-
- ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
- instead of qvar, we get another shift/reduce-conflict. Consider the
- following programs:
-
- { (+) :: ... } only var
- { (+) x y = ... } could (incorrectly) be qvar
-
- We re-use expressions for patterns, so a qvar would be allowed in patterns
- instead of a var only (which would be correct). But deciding what the + is,
- would require more lookahead. So let's check for ourselves...
--}
-
-vars :: { [RdrName] }
- : vars ',' var { $3 : $1 }
- | qvar { [ $1 ] }
+sig_vars :: { [RdrName] }
+ : sig_vars ',' var { $3 : $1 }
+ | var { [ $1 ] }
-----------------------------------------------------------------------------
-- Transformation Rules
@@ -583,9 +565,9 @@ constrs :: { [RdrNameConDecl] }
constr :: { RdrNameConDecl }
: srcloc forall context constr_stuff
- { ConDecl (fst $4) $2 $3 (snd $4) $1 }
+ { mkConDecl (fst $4) $2 $3 (snd $4) $1 }
| srcloc forall constr_stuff
- { ConDecl (fst $3) $2 [] (snd $3) $1 }
+ { mkConDecl (fst $3) $2 [] (snd $3) $1 }
forall :: { [RdrNameHsTyVar] }
: 'forall' tyvars '.' { $2 }
@@ -600,9 +582,9 @@ constr_stuff :: { (RdrName, RdrNameConDetails) }
| con '{' fielddecls '}' { ($1, RecCon (reverse $3)) }
newconstr :: { RdrNameConDecl }
- : srcloc conid atype { ConDecl $2 [] [] (NewCon $3 Nothing) $1 }
+ : srcloc conid atype { mkConDecl $2 [] [] (NewCon $3 Nothing) $1 }
| srcloc conid '{' var '::' type '}'
- { ConDecl $2 [] [] (NewCon $6 (Just $4)) $1 }
+ { mkConDecl $2 [] [] (NewCon $6 (Just $4)) $1 }
scontype :: { (RdrName, [RdrNameBangType]) }
: btype {% splitForConApp $1 [] }
@@ -625,7 +607,7 @@ fielddecls :: { [([RdrName],RdrNameBangType)] }
| fielddecl { [$1] }
fielddecl :: { ([RdrName],RdrNameBangType) }
- : vars '::' stype { (reverse $1, $3) }
+ : sig_vars '::' stype { (reverse $1, $3) }
stype :: { RdrNameBangType }
: ctype { Unbanged $1 }
@@ -644,9 +626,32 @@ dclasses :: { [RdrName] }
-----------------------------------------------------------------------------
-- Value definitions
-valdef :: { RdrNameMonoBinds }
- : infixexp {-ToDo: opt_sig-} srcloc rhs
- {% checkValDef $1 Nothing $3 $2 }
+{- There's an awkward overlap with a type signature. Consider
+ f :: Int -> Int = ...rhs...
+ Then we can't tell whether it's a type signature or a value
+ definition with a result signature until we see the '='.
+ So we have to inline enough to postpone reductions until we know.
+-}
+
+{-
+ ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
+ instead of qvar, we get another shift/reduce-conflict. Consider the
+ following programs:
+
+ { (^^) :: Int->Int ; } Type signature; only var allowed
+
+ { (^^) :: Int->Int = ... ; } Value defn with result signature;
+ qvar allowed (because of instance decls)
+
+ We can't tell whether to reduce var to qvar until after we've read the signatures.
+-}
+
+valdef :: { RdrBinding }
+ : infixexp srcloc opt_sig rhs {% checkValDef $1 $3 $4 $2 }
+ | infixexp srcloc '::' sigtype {% checkValSig $1 $4 $2 }
+ | var ',' sig_vars srcloc '::' sigtype { foldr1 RdrAndBindings
+ [ RdrSig (Sig n $6 $4) | n <- $1:$3 ]
+ }
rhs :: { RdrNameGRHSs }
: '=' srcloc exp wherebinds { GRHSs (unguardedRHS $3 $2)
@@ -658,8 +663,7 @@ gdrhs :: { [RdrNameGRHS] }
| gdrh { [$1] }
gdrh :: { RdrNameGRHS }
- : '|' srcloc quals '=' exp { GRHS (reverse
- (ExprStmt $5 $2 : $3)) $2 }
+ : '|' srcloc quals '=' exp { GRHS (reverse (ExprStmt $5 $2 : $3)) $2 }
-----------------------------------------------------------------------------
-- Expressions
@@ -685,10 +689,10 @@ exp10 :: { RdrNameHsExpr }
| '-' fexp { NegApp $2 (error "NegApp") }
| srcloc 'do' stmtlist { HsDo DoStmt $3 $1 }
- | '_ccall_' ccallid aexps0 { CCall $2 $3 False False cbot }
- | '_ccall_GC_' ccallid aexps0 { CCall $2 $3 True False cbot }
- | '_casm_' CLITLIT aexps0 { CCall $2 $3 False True cbot }
- | '_casm_GC_' CLITLIT aexps0 { CCall $2 $3 True True cbot }
+ | '_ccall_' ccallid aexps0 { HsCCall $2 $3 False False cbot }
+ | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 True False cbot }
+ | '_casm_' CLITLIT aexps0 { HsCCall $2 $3 False True cbot }
+ | '_casm_GC_' CLITLIT aexps0 { HsCCall $2 $3 True True cbot }
| '_scc_' STRING exp { if opt_SccProfilingOn
then HsSCC $2 $3
@@ -795,7 +799,7 @@ alt :: { RdrNameMatch }
opt_sig :: { Maybe RdrNameHsType }
: {- empty -} { Nothing }
- | '::' type { Just $2 }
+ | '::' sigtype { Just $2 }
opt_asig :: { Maybe RdrNameHsType }
: {- empty -} { Nothing }
@@ -881,7 +885,11 @@ var :: { RdrName }
qvar :: { RdrName }
: qvarid { $1 }
- | '(' qvarsym ')' { $2 }
+ | '(' varsym ')' { $2 }
+ | '(' qvarsym1 ')' { $2 }
+-- We've inlined qvarsym here so that the decision about
+-- whether it's a qvar or a var can be postponed until
+-- *after* we see the close paren.
ipvar :: { RdrName }
: IPVARID { (mkSrcUnqual ipName (tailFS $1)) }
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 41b9fdb0b4..4455fdba1e 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -53,7 +53,7 @@ module RdrHsSyn (
extractPatsTyVars,
extractRuleBndrsTyVars,
- mkOpApp, mkClassDecl, mkClassOpSig,
+ mkOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
cvBinds,
cvMonoBindsAndSigs,
@@ -65,7 +65,7 @@ module RdrHsSyn (
import HsSyn
import Name ( mkClassTyConOcc, mkClassDataConOcc )
-import OccName ( mkClassTyConOcc, mkClassDataConOcc,
+import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
mkSuperDictSelOcc, mkDefaultMethodOcc
)
import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc )
@@ -202,15 +202,17 @@ tycon and datacon corresponding to the class, by deriving them from the
name of the class itself. This saves recording the names in the interface
file (which would be equally good).
-Similarly for mkClassOpSig and default-method names.
+Similarly for mkConDecl, mkClassOpSig and default-method names.
\begin{code}
mkClassDecl cxt cname tyvars fds sigs mbinds prags loc
- = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname sc_sel_names loc
+ = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname dwname sc_sel_names loc
where
- cls_occ = rdrNameOcc cname
- dname = mkRdrUnqual (mkClassDataConOcc cls_occ)
- tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
+ cls_occ = rdrNameOcc cname
+ data_occ = mkClassDataConOcc cls_occ
+ dname = mkRdrUnqual data_occ
+ dwname = mkRdrUnqual (mkWorkerOcc data_occ)
+ tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
| n <- [1..length cxt]]
-- We number off the superclass selectors, 1, 2, 3 etc so that we
@@ -225,6 +227,11 @@ mkClassOpSig has_default_method op ty loc
= ClassOpSig op dm_rn has_default_method ty loc
where
dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
+
+mkConDecl cname ex_vars cxt details loc
+ = ConDecl cname wkr_name ex_vars cxt details loc
+ where
+ wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
\end{code}
A useful function for building @OpApps@. The operator is always a variable,
View Lorry Controller Status