-- ---------------------------------------------------------------------------
{
-module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where
+module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType ) where
#define INCLUDE #include
INCLUDE "HsVersions.h"
import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
import Type ( funTyCon )
-import ForeignCall ( Safety(..), CExportSpec(..),
+import ForeignCall ( Safety(..), CExportSpec(..), CLabelString,
CCallConv(..), CCallTarget(..), defaultCCallConv
)
import OccName ( UserFS, varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
- SrcSpan, combineLocs, mkGeneralSrcSpan, srcLocFile )
+ SrcSpan, combineLocs, srcLocFile,
+ mkSrcLoc, mkSrcSpan )
import Module
import CmdLineOpts ( opt_SccProfilingOn )
import Type ( Kind, mkArrowKind, liftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- NewOrData(..), Activation(..) )
+ Activation(..) )
+import OrdList
import Bag ( emptyBag )
import Panic
-import GLAEXTS
-import CStrings ( CLabelString )
import FastString
import Maybes ( orElse )
import Outputable
+import GLAEXTS
}
{-
-----------------------------------------------------------------------------
-Conflicts: 29 shift/reduce, [SDM 19/9/2002]
+Conflicts: 34 shift/reduce (1.15)
-10 for abiguity in 'if x then y else z + 1' [State 136]
+10 for abiguity in 'if x then y else z + 1' [State 178]
(shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
10 because op might be: : - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM
-1 for ambiguity in 'if x then y else z with ?x=3' [State 136]
- (shift parses as 'if x then y else (z with ?x=3)'
-
-1 for ambiguity in 'if x then y else z :: T' [State 136]
+1 for ambiguity in 'if x then y else z :: T' [State 178]
(shift parses as 'if x then y else (z :: T)', as per longest-parse rule)
-8 for ambiguity in 'e :: a `b` c'. Does this mean [States 160,246]
+4 for ambiguity in 'if x then y else z -< e' [State 178]
+ (shift parses as 'if x then y else (z -< T)', as per longest-parse rule)
+ There are four such operators: -<, >-, -<<, >>-
+
+
+2 for ambiguity in 'case v of { x :: T -> T ... } ' [States 11, 253]
+ Which of these two is intended?
+ case v of
+ (x::T) -> T -- Rhs is T
+ or
+ case v of
+ (x::T -> T) -> .. -- Rhs is ...
+
+8 for ambiguity in 'e :: a `b` c'. Does this mean [States 11, 253]
(e::a) `b` c, or
(e :: (a `b` c))
+ As well as `b` we can have !, QCONSYM, and CONSYM, hence 3 cases
+ Same duplication between states 11 and 253 as the previous case
-1 for ambiguity in 'let ?x ...' [State 268]
+1 for ambiguity in 'let ?x ...' [State 329]
the parser can't tell whether the ?x is the lhs of a normal binding or
an implicit binding. Fortunately resolving as shift gives it the only
sensible meaning, namely the lhs of an implicit binding.
-1 for ambiguity in '{-# RULES "name" [ ... #-} [State 332]
+1 for ambiguity in '{-# RULES "name" [ ... #-} [State 382]
we don't know whether the '[' starts the activation or not: it
might be the start of the declaration with the activation being
empty. --SDM 1/4/2002
-1 for ambiguity in '{-# RULES "name" forall = ... #-}' [State 394]
+6 for conflicts between `fdecl' and `fdeclDEPRECATED', [States 393,394]
+ which are resolved correctly, and moreover,
+ should go away when `fdeclDEPRECATED' is removed.
+
+1 for ambiguity in '{-# RULES "name" forall = ... #-}' [State 474]
since 'forall' is a valid variable name, we don't know whether
to treat a forall on the input as the beginning of a quantifier
or the beginning of the rule itself. Resolving to shift means
This saves explicitly defining a grammar for the rule lhs that
doesn't include 'forall'.
-6 for conflicts between `fdecl' and `fdeclDEPRECATED', [States 384,385]
- which are resolved correctly, and moreover,
- should go away when `fdeclDEPRECATED' is removed.
-
-- ---------------------------------------------------------------------------
-- Adding location info
%name parseStmt maybe_stmt
%name parseIdentifier identifier
%name parseIface iface
+%name parseType ctype
%tokentype { Located Token }
%%
module :: { Located (HsModule RdrName) }
: 'module' modid maybemoddeprec maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule (Just (L (getLoc $2)
- (mkHomeModule (unLoc $2))))
- $4 (fst $6) (snd $6) $3)) }
+ return (L loc (HsModule (Just $2) $4 (fst $6) (snd $6) $3)) }
| missing_module_keyword top close
{% fileSrcSpan >>= \ loc ->
return (L loc (HsModule Nothing Nothing
{ SigD (Sig $1 $3) }
| 'type' syn_hdr '=' ctype
{ let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) }
- | 'data' tycl_hdr
- { TyClD (mkTyData DataType (unLoc $2) [] Nothing) }
- | 'newtype' tycl_hdr
- { TyClD (mkTyData NewType (unLoc $2) [] Nothing) }
+ | 'data' tycl_hdr constrs -- No deriving in hi-boot
+ { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $3)) Nothing) }
+ | 'data' tycl_hdr 'where' gadt_constrlist
+ { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $4)) Nothing) }
+ | 'newtype' tycl_hdr -- Constructor is optional
+ { TyClD (mkTyData NewType $2 Nothing [] Nothing) }
+ | 'newtype' tycl_hdr '=' newconstr
+ { TyClD (mkTyData NewType $2 Nothing [$4] Nothing) }
| 'class' tycl_hdr fds
{ TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) }
: 'qualified' { True }
| {- empty -} { False }
-maybeas :: { Located (Maybe ModuleName) }
+maybeas :: { Located (Maybe Module) }
: 'as' modid { LL (Just (unLoc $2)) }
| {- empty -} { noLoc Nothing }
-----------------------------------------------------------------------------
-- Top-Level Declarations
-topdecls :: { [RdrBinding] } -- Reversed
- : topdecls ';' topdecl { $3 : $1 }
+topdecls :: { OrdList (LHsDecl RdrName) } -- Reversed
+ : topdecls ';' topdecl { $1 `appOL` $3 }
| topdecls ';' { $1 }
- | topdecl { [$1] }
+ | topdecl { $1 }
-topdecl :: { RdrBinding }
- : tycl_decl { RdrHsDecl (L1 (TyClD (unLoc $1))) }
+topdecl :: { OrdList (LHsDecl RdrName) }
+ : tycl_decl { unitOL (L1 (TyClD (unLoc $1))) }
| 'instance' inst_type where
{ let (binds,sigs) = cvBindsAndSigs (unLoc $3)
- in RdrHsDecl (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
- | 'default' '(' comma_types0 ')' { RdrHsDecl (LL $ DefD (DefaultDecl $3)) }
- | 'foreign' fdecl { RdrHsDecl (LL (unLoc $2)) }
- | '{-# DEPRECATED' deprecations '#-}' { RdrBindings (reverse $2) }
- | '{-# RULES' rules '#-}' { RdrBindings (reverse $2) }
- | '$(' exp ')' { RdrHsDecl (LL $ SpliceD (SpliceDecl $2)) }
+ in unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) }
+ | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
+ | 'foreign' fdecl { unitOL (LL (unLoc $2)) }
+ | '{-# DEPRECATED' deprecations '#-}' { $2 }
+ | '{-# RULES' rules '#-}' { $2 }
+ | '$(' exp ')' { unitOL (LL $ SpliceD (SpliceDecl $2)) }
| decl { unLoc $1 }
tycl_decl :: { LTyClDecl RdrName }
| 'data' tycl_hdr constrs deriving
{ L (comb4 $1 $2 $3 $4)
- (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) (unLoc $4)) }
+ (mkTyData DataType $2 Nothing (reverse (unLoc $3)) (unLoc $4)) }
+
+ | 'data' tycl_hdr opt_kind_sig 'where' gadt_constrlist -- No deriving for GADTs
+ { L (comb4 $1 $2 $4 $5)
+ (mkTyData DataType $2 $3 (reverse (unLoc $5)) Nothing) }
| 'newtype' tycl_hdr '=' newconstr deriving
{ L (comb3 $1 $4 $5)
- (mkTyData NewType (unLoc $2) [$4] (unLoc $5)) }
+ (mkTyData NewType $2 Nothing [$4] (unLoc $5)) }
| 'class' tycl_hdr fds where
{ let
L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs
binds) }
+opt_kind_sig :: { Maybe Kind }
+ : { Nothing }
+ | '::' kind { Just $2 }
+
syn_hdr :: { (Located RdrName, [LHsTyVarBndr RdrName]) }
-- We don't retain the syntax of an infix
-- type synonym declaration. Oh well.
-----------------------------------------------------------------------------
-- Nested declarations
-decls :: { Located [RdrBinding] } -- Reversed
- : decls ';' decl { LL (unLoc $3 : unLoc $1) }
+decls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
+ : decls ';' decl { LL (unLoc $1 `appOL` unLoc $3) }
| decls ';' { LL (unLoc $1) }
- | decl { L1 [unLoc $1] }
- | {- empty -} { noLoc [] }
+ | decl { $1 }
+ | {- empty -} { noLoc nilOL }
-decllist :: { Located [RdrBinding] } -- Reversed
+decllist :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
: '{' decls '}' { LL (unLoc $2) }
| vocurly decls close { $2 }
-where :: { Located [RdrBinding] } -- Reversed
+where :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
-- No implicit parameters
: 'where' decllist { LL (unLoc $2) }
- | {- empty -} { noLoc [] }
+ | {- empty -} { noLoc nilOL }
binds :: { Located [HsBindGroup RdrName] } -- May have implicit parameters
: decllist { L1 [cvBindGroup (unLoc $1)] }
-----------------------------------------------------------------------------
-- Transformation Rules
-rules :: { [RdrBinding] } -- Reversed
- : rules ';' rule { $3 : $1 }
+rules :: { OrdList (LHsDecl RdrName) } -- Reversed
+ : rules ';' rule { $1 `snocOL` $3 }
| rules ';' { $1 }
- | rule { [$1] }
- | {- empty -} { [] }
+ | rule { unitOL $1 }
+ | {- empty -} { nilOL }
-rule :: { RdrBinding }
+rule :: { LHsDecl RdrName }
: STRING activation rule_forall infixexp '=' exp
- { RdrHsDecl (LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6)) }
+ { LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6) }
activation :: { Activation } -- Omitted means AlwaysActive
: {- empty -} { AlwaysActive }
-----------------------------------------------------------------------------
-- Deprecations (c.f. rules)
-deprecations :: { [RdrBinding] } -- Reversed
- : deprecations ';' deprecation { $3 : $1 }
+deprecations :: { OrdList (LHsDecl RdrName) } -- Reversed
+ : deprecations ';' deprecation { $1 `appOL` $3 }
| deprecations ';' { $1 }
- | deprecation { [$1] }
- | {- empty -} { [] }
+ | deprecation { $1 }
+ | {- empty -} { nilOL }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
-deprecation :: { RdrBinding }
+deprecation :: { OrdList (LHsDecl RdrName) }
: depreclist STRING
- { RdrBindings [ RdrHsDecl (LL $ DeprecD (Deprecation n (getSTRING $2))) | n <- unLoc $1 ] }
+ { toOL [ LL $ DeprecD (Deprecation n (getSTRING $2))
+ | n <- unLoc $1 ] }
-----------------------------------------------------------------------------
: {- empty -} { Nothing }
| '::' atype { Just $2 }
-sigtypes :: { [LHsType RdrName] }
+sigtypes1 :: { [LHsType RdrName] }
: sigtype { [ $1 ] }
- | sigtypes ',' sigtype { $3 : $1 }
+ | sigtype ',' sigtypes1 { $1 : $3 }
sigtype :: { LHsType RdrName }
: ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
-----------------------------------------------------------------------------
-- Types
+strict_mark :: { Located HsBang }
+ : '!' { L1 HsStrict }
+ | '{-# UNPACK' '#-}' '!' { LL HsUnbox }
+
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
: btype {% checkContext $1 }
type :: { LHsType RdrName }
- : ipvar '::' gentype { LL (HsPredTy (LL $ HsIParam (unLoc $1) $3)) }
+ : ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) }
| gentype { $1 }
gentype :: { LHsType RdrName }
atype :: { LHsType RdrName }
: gtycon { L1 (HsTyVar (unLoc $1)) }
| tyvar { L1 (HsTyVar (unLoc $1)) }
+ | strict_mark atype { LL (HsBangTy (unLoc $1) $2) }
| '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 }
| '[' type ']' { LL $ HsListTy $2 }
-- It's kept as a single type, with a MonoDictTy at the right
-- hand corner, for convenience.
inst_type :: { LHsType RdrName }
- : ctype {% checkInstType $1 }
+ : sigtype {% checkInstType $1 }
+
+inst_types1 :: { [LHsType RdrName] }
+ : inst_type { [$1] }
+ | inst_type ',' inst_types1 { $1 : $3 }
comma_types0 :: { [LHsType RdrName] }
: comma_types1 { $1 }
-- Datatype declarations
newconstr :: { LConDecl RdrName }
- : conid atype { LL $ ConDecl $1 [] (noLoc [])
- (PrefixCon [(unbangedType $2)]) }
+ : conid atype { LL $ ConDecl $1 [] (noLoc []) (PrefixCon [$2]) }
| conid '{' var '::' ctype '}'
- { LL $ ConDecl $1 [] (noLoc [])
- (RecCon [($3, (unbangedType $5))]) }
+ { LL $ ConDecl $1 [] (noLoc []) (RecCon [($3, $5)]) }
+
+gadt_constrlist :: { Located [LConDecl RdrName] }
+ : '{' gadt_constrs '}' { LL (unLoc $2) }
+ | vocurly gadt_constrs close { $2 }
+
+gadt_constrs :: { Located [LConDecl RdrName] }
+ : gadt_constrs ';' gadt_constr { LL ($3 : unLoc $1) }
+ | gadt_constrs ';' { $1 }
+ | gadt_constr { L1 [$1] }
+
+gadt_constr :: { LConDecl RdrName }
+ : qcon '::' sigtype
+ { LL (GadtDecl $1 $3) }
constrs :: { Located [LConDecl RdrName] }
: {- empty; a GHC extension -} { noLoc [] }
| {- empty -} { noLoc [] }
constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
+-- We parse the constructor declaration
+-- C t1 t2
+-- as a btype (treating C as a type constructor) and then convert C to be
+-- a data constructor. Reason: it might continue like this:
+-- C t1 t2 %: D Int
+-- in which case C really would be a type constructor. We can't resolve this
+-- ambiguity till we come across the constructor oprerator :% (or not, more usually)
: btype {% mkPrefixCon $1 [] >>= return.LL }
- | btype bang_atype satypes {% do { r <- mkPrefixCon $1 ($2 : unLoc $3);
- return (L (comb3 $1 $2 $3) r) } }
| oqtycon '{' '}' {% mkRecCon $1 [] >>= return.LL }
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL }
- | sbtype conop sbtype { LL ($2, InfixCon $1 $3) }
-
-bang_atype :: { LBangType RdrName }
- : strict_mark atype { LL (BangType (unLoc $1) $2) }
-
-satypes :: { Located [LBangType RdrName] }
- : atype satypes { LL (unbangedType $1 : unLoc $2) }
- | bang_atype satypes { LL ($1 : unLoc $2) }
- | {- empty -} { noLoc [] }
-
-sbtype :: { LBangType RdrName }
- : btype { unbangedType $1 }
- | strict_mark atype { LL (BangType (unLoc $1) $2) }
+ | btype conop btype { LL ($2, InfixCon $1 $3) }
fielddecls :: { [([Located RdrName], LBangType RdrName)] }
: fielddecl ',' fielddecls { unLoc $1 : $3 }
| fielddecl { [unLoc $1] }
fielddecl :: { Located ([Located RdrName], LBangType RdrName) }
- : sig_vars '::' stype { LL (reverse (unLoc $1), $3) }
-
-stype :: { LBangType RdrName }
- : ctype { unbangedType $1 }
- | strict_mark atype { LL (BangType (unLoc $1) $2) }
-
-strict_mark :: { Located HsBang }
- : '!' { L1 HsStrict }
- | '{-# UNPACK' '#-}' '!' { LL HsUnbox }
-
-deriving :: { Located (Maybe (LHsContext RdrName)) }
- : {- empty -} { noLoc Nothing }
- | 'deriving' context { LL (Just $2) }
+ : sig_vars '::' ctype { LL (reverse (unLoc $1), $3) }
+
+-- We allow the odd-looking 'inst_type' in a deriving clause, so that
+-- we can do deriving( forall a. C [a] ) in a newtype (GHC extension).
+-- The 'C [a]' part is converted to an HsPredTy by checkInstType
+-- We don't allow a context, but that's sorted out by the type checker.
+deriving :: { Located (Maybe [LHsType RdrName]) }
+ : {- empty -} { noLoc Nothing }
+ | 'deriving' qtycon {% do { let { L loc tv = $2 }
+ ; p <- checkInstType (L loc (HsTyVar tv))
+ ; return (LL (Just [p])) } }
+ | 'deriving' '(' ')' { LL (Just []) }
+ | 'deriving' '(' inst_types1 ')' { LL (Just $3) }
-- Glasgow extension: allow partial
-- applications in derivings
We can't tell whether to reduce var to qvar until after we've read the signatures.
-}
-decl :: { Located RdrBinding }
+decl :: { Located (OrdList (LHsDecl RdrName)) }
: sigdecl { $1 }
- | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 (unLoc $3);
- return (LL $ RdrValBinding (LL r)) } }
+ | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3;
+ return (LL $ unitOL (LL $ ValD r)) } }
rhs :: { Located (GRHSs RdrName) }
- : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) placeHolderType }
- | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) placeHolderType }
+ : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
+ | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) }
gdrhs :: { Located [LGRHS RdrName] }
: gdrhs gdrh { LL ($2 : unLoc $1) }
: '|' quals '=' exp { LL $ GRHS (reverse (L (getLoc $4) (ResultStmt $4) :
unLoc $2)) }
-sigdecl :: { Located RdrBinding }
+sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
: infixexp '::' sigtype
{% do s <- checkValSig $1 $3;
- return (LL $ RdrHsDecl (LL $ SigD s)) }
+ return (LL $ unitOL (LL $ SigD s)) }
-- See the above notes for why we need infixexp here
| var ',' sig_vars '::' sigtype
- { LL $ mkSigDecls [ LL $ Sig n $5 | n <- $1 : unLoc $3 ] }
- | infix prec ops { LL $ mkSigDecls [ LL $ FixSig (FixitySig n (Fixity $2 (unLoc $1)))
+ { LL $ toOL [ LL $ SigD (Sig n $5) | n <- $1 : unLoc $3 ] }
+ | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
| n <- unLoc $3 ] }
| '{-# INLINE' activation qvar '#-}'
- { LL $ RdrHsDecl (LL $ SigD (InlineSig True $3 $2)) }
+ { LL $ unitOL (LL $ SigD (InlineSig True $3 $2)) }
| '{-# NOINLINE' inverse_activation qvar '#-}'
- { LL $ RdrHsDecl (LL $ SigD (InlineSig False $3 $2)) }
- | '{-# SPECIALISE' qvar '::' sigtypes '#-}'
- { LL $ mkSigDecls [ LL $ SpecSig $2 t | t <- $4] }
+ { LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) }
+ | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
+ { LL $ toOL [ LL $ SigD (SpecSig $2 t)
+ | t <- $4] }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
- { LL $ RdrHsDecl (LL $ SigD (SpecInstSig $3)) }
+ { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
-----------------------------------------------------------------------------
-- Expressions
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
- | fexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
- | fexp '>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False }
- | fexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
- | fexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
+ | infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
+ | infixexp '>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False }
+ | infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
+ | infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
| infixexp { $1 }
infixexp :: { LHsExpr RdrName }
exp10 :: { LHsExpr RdrName }
: '\\' aexp aexps opt_asig '->' exp
{% checkPatterns ($2 : reverse $3) >>= \ ps ->
- return (LL $ HsLam (LL $ Match ps $4
+ return (LL $ HsLam (mkMatchGroup [LL $ Match ps $4
(GRHSs (unguardedRHS $6) []
- placeHolderType))) }
+ )])) }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
| 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 }
- | 'case' exp 'of' altslist { LL $ HsCase $2 (unLoc $4) }
+ | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| '-' fexp { LL $ mkHsNegApp $2 }
| 'do' stmtlist {% let loc = comb2 $1 $2 in
| '_' { L1 EWildPat }
-- MetaHaskell Extension
- | TH_ID_SPLICE { L1 $ mkHsSplice
+ | TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice
(L1 $ HsVar (mkUnqual varName
- (getTH_ID_SPLICE $1))) } -- $x
- | '$(' exp ')' { LL $ mkHsSplice $2 } -- $( exp )
+ (getTH_ID_SPLICE $1)))) } -- $x
+ | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp )
+
| TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) }
- | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) }
+ | TH_VAR_QUOTE gcon { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr (unLoc $2)) }
| '[|' exp '|]' { LL $ HsBracket (ExpBr $2) }
: aexp2 { L1 $ HsCmdTop $1 [] placeHolderType undefined }
cvtopbody :: { [LHsDecl RdrName] }
- : '{' cvtopdecls '}' { $2 }
- | vocurly cvtopdecls close { $2 }
+ : '{' cvtopdecls0 '}' { $2 }
+ | vocurly cvtopdecls0 close { $2 }
+
+cvtopdecls0 :: { [LHsDecl RdrName] }
+ : {- empty -} { [] }
+ | cvtopdecls { $1 }
texps :: { [LHsExpr RdrName] }
: texps ',' exp { $3 : $1 }
return (LL (Match [p] $2 (unLoc $3))) }
alt_rhs :: { Located (GRHSs RdrName) }
- : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2)
- placeHolderType) }
+ : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2)) }
ralt :: { Located [LGRHS RdrName] }
: '->' exp { LL (unguardedRHS $2) }
-----------------------------------------------------------------------------
-- Data constructors
-qconid :: { Located RdrName } -- Qualified or unqualifiedb
+qconid :: { Located RdrName } -- Qualified or unqualified
: conid { $1 }
| QCONID { L1 $ mkQual dataName (getQCONID $1) }
-----------------------------------------------------------------------------
-- Miscellaneous (mostly renamings)
-modid :: { Located ModuleName }
- : CONID { L1 $ mkModuleNameFS (getCONID $1) }
+modid :: { Located Module }
+ : CONID { L1 $ mkModuleFS (getCONID $1) }
| QCONID { L1 $ let (mod,c) = getQCONID $1 in
- mkModuleNameFS
+ mkModuleFS
(mkFastString
(unpackFS mod ++ '.':unpackFS c))
}
sL :: SrcSpan -> a -> Located a
sL span a = span `seq` L span a
--- Make a source location that is just the filename. This seems slightly
--- neater than trying to construct the span of the text within the file.
+-- Make a source location for the file. We're a bit lazy here and just
+-- make a point SrcSpan at line 1, column 0. Strictly speaking we should
+-- try to find the span of the whole file (ToDo).
fileSrcSpan :: P SrcSpan
-fileSrcSpan = do l <- getSrcLoc; return (mkGeneralSrcSpan (srcLocFile l))
+fileSrcSpan = do
+ l <- getSrcLoc;
+ let loc = mkSrcLoc (srcLocFile l) 1 0;
+ return (mkSrcSpan loc loc)
}
projects / ghc-hetmet.git / blobdiff