{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.25 2000/02/28 09:17:54 simonmar Exp $
+$Id: Parser.y,v 1.32 2000/06/01 08:51:46 simonmar Exp $
Haskell grammar.
import HsSyn
import HsPragmas
+import HsTypes ( mkHsTupCon )
import RdrHsSyn
import Lex
import ParseUtil
import RdrName
-import PrelMods ( mAIN_Name )
-import OccName ( varName, ipName, dataName, tcClsName, tvName )
+import PrelInfo ( mAIN_Name )
+import OccName ( varName, ipName, tcName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
import CallConv
import CmdLineOpts ( opt_SccProfilingOn )
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) )
import Panic
import GlaExts
+import FastString ( tailFS )
#include "HsVersions.h"
}
-----------------------------------------------------------------------------
Conflicts: 14 shift/reduce
(note: it's currently 21 -- JRL, 31/1/2000)
- (note2: it's currently 36, but not because of me -- SUP, 15/2/2000 :-)
8 for abiguity in 'if x then y else z + 1'
(shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
| topdecl { [$1] }
topdecl :: { RdrBinding }
- : srcloc 'type' simpletype '=' type
+ : srcloc 'type' simpletype '=' sigtype
{ RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) }
| srcloc 'data' ctype '=' constrs deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
- (TyData DataType cs c ts (reverse $5) $6
+ (TyData DataType cs c ts (reverse $5) (length $5) $6
NoDataPragmas $1))) }
| srcloc 'newtype' ctype '=' newconstr deriving
{% checkDataHeader $3 `thenP` \(cs,c,ts) ->
returnP (RdrHsDecl (TyClD
- (TyData NewType cs c ts [$5] $6
+ (TyData NewType cs c ts [$5] 1 $6
NoDataPragmas $1))) }
| srcloc 'class' ctype fds where
{ RdrHsDecl (ForD (ForeignDecl $5 FoLabel $7 (mkExtName $4 $5)
defaultCallConv $1)) }
- | decl { $1 }
+ | '{-# DEPRECATED' deprecations '#-}' { $2 }
+ | '{-# RULES' rules '#-}' { $2 }
+ | decl { $1 }
decls :: { [RdrBinding] }
: decls ';' decl { $3 : $1 }
| {- 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 '#-}'
(map (\t -> RdrSig (SpecSig $3 t $2)) $5) }
| '{-# SPECIALISE' srcloc 'instance' inst_type '#-}'
{ RdrSig (SpecInstSig $4 $2) }
- | '{-# RULES' rules '#-}' { $2 }
- | '{-# DEPRECATED' deprecations '#-}' { $2 }
opt_phase :: { Maybe Int }
: INTEGER { Just (fromInteger $1) }
| {- empty -} { Nothing }
-sigtypes :: { [RdrNameHsType] }
- : sigtype { [ $1 ] }
- | sigtypes ',' sigtype { $3 : $1 }
-
wherebinds :: { RdrNameHsBinds }
: where { cvBinds cvValSig (groupBindings $1) }
(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 }
-
-{-
- 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 ] }
-
-----------------------------------------------------------------------------
-- Transformation Rules
rule :: { RdrBinding }
: STRING rule_forall fexp '=' srcloc exp
- { RdrHsDecl (RuleD (RuleDecl $1 [] $2 $3 $6 $5)) }
+ { RdrHsDecl (RuleD (HsRule $1 [] $2 $3 $6 $5)) }
rule_forall :: { [RdrNameRuleBndr] }
: 'forall' rule_var_list '.' { $2 }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { RdrBinding }
: srcloc exportlist STRING
- { foldr1 RdrAndBindings [ RdrSig (DeprecSig (Deprecation n $3) $1) | n <- $2 ] }
+ { foldr RdrAndBindings RdrNullBind
+ [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] }
-----------------------------------------------------------------------------
-- Foreign import/export
| STRING STRING { Just (ExtName $2 (Just $1)) }
| {- empty -} { Nothing }
+
+-----------------------------------------------------------------------------
+-- Type signatures
+
+opt_sig :: { Maybe RdrNameHsType }
+ : {- empty -} { Nothing }
+ | '::' sigtype { Just $2 }
+
+opt_asig :: { Maybe RdrNameHsType }
+ : {- empty -} { Nothing }
+ | '::' atype { Just $2 }
+
+sigtypes :: { [RdrNameHsType] }
+ : sigtype { [ $1 ] }
+ | sigtypes ',' sigtype { $3 : $1 }
+
+sigtype :: { RdrNameHsType }
+ : ctype { mkHsForAllTy Nothing [] $1 }
+
+sig_vars :: { [RdrName] }
+ : sig_vars ',' var { $3 : $1 }
+ | var { [ $1 ] }
+
-----------------------------------------------------------------------------
-- Types
| type { $1 }
type :: { RdrNameHsType }
- : btype '->' type { MonoFunTy $1 $3 }
- | IPVARID '::' type { MonoIParamTy (mkSrcUnqual ipName $1) $3 }
+ : btype '->' type { HsFunTy $1 $3 }
+ | ipvar '::' type { mkHsIParamTy $1 $3 }
| btype { $1 }
btype :: { RdrNameHsType }
- : btype atype { MonoTyApp $1 $2 }
+ : btype atype { HsAppTy $1 $2 }
| atype { $1 }
atype :: { RdrNameHsType }
- : gtycon { MonoTyVar $1 }
- | tyvar { MonoTyVar $1 }
- | '(' type ',' types ')' { MonoTupleTy ($2 : reverse $4) True }
- | '(#' types '#)' { MonoTupleTy (reverse $2) False }
- | '[' type ']' { MonoListTy $2 }
+ : gtycon { HsTyVar $1 }
+ | tyvar { HsTyVar $1 }
+ | '(' type ',' types ')' { HsTupleTy (mkHsTupCon tcName Boxed ($2:$4)) ($2 : reverse $4) }
+ | '(#' types '#)' { HsTupleTy (mkHsTupCon tcName Unboxed $2) (reverse $2) }
+ | '[' type ']' { HsListTy $2 }
| '(' ctype ')' { $2 }
gtycon :: { RdrName }
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 }
| 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 [] }
scontype1 :: { (RdrName, [RdrNameBangType]) }
: btype '!' atype {% splitForConApp $1 [Banged $3] }
| scontype1 satype { (fst $1, snd $1 ++ [$2] ) }
+ | '(' consym ')' { ($2,[]) }
satype :: { RdrNameBangType }
: atype { Unbanged $1 }
| fielddecl { [$1] }
fielddecl :: { ([RdrName],RdrNameBangType) }
- : vars '::' stype { (reverse $1, $3) }
+ : sig_vars '::' stype { (reverse $1, $3) }
stype :: { RdrNameBangType }
: ctype { Unbanged $1 }
-----------------------------------------------------------------------------
-- 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)
| 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
| '-' 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
aexp1 :: { RdrNameHsExpr }
: qvar { HsVar $1 }
- | IPVARID { HsIPVar (mkSrcUnqual ipName $1) }
+ | ipvar { HsIPVar $1 }
| gcon { HsVar $1 }
| literal { HsLit $1 }
| '(' exp ')' { HsPar $2 }
- | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) True }
- | '(#' texps '#)' { ExplicitTuple (reverse $2) False }
+ | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed}
+ | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed }
| '[' list ']' { $2 }
| '(' infixexp qop ')' { SectionL $2 $3 }
| '(' qopm infixexp ')' { SectionR $2 $3 }
returnP (Match [] [p] $2
(GRHSs $3 $4 Nothing)) }
-opt_sig :: { Maybe RdrNameHsType }
- : {- empty -} { Nothing }
- | '::' type { Just $2 }
-
-opt_asig :: { Maybe RdrNameHsType }
- : {- empty -} { Nothing }
- | '::' atype { Just $2 }
-
ralt :: { [RdrNameGRHS] }
: '->' srcloc exp { [GRHS [ExprStmt $3 $2] $2] }
| gdpats { (reverse $1) }
| {- empty -} { [] }
dbind :: { (RdrName, RdrNameHsExpr) }
-dbind : IPVARID '=' exp { (mkSrcUnqual ipName $1, $3) }
+dbind : ipvar '=' exp { ($1, $3) }
-----------------------------------------------------------------------------
-- Variables, Constructors and Operators.
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)) }
con :: { RdrName }
: conid { $1 }
projects / ghc-hetmet.git / blobdiff