import ForeignCall ( Safety(..), CExportSpec(..), CLabelString,
CCallConv(..), CCallTarget(..), defaultCCallConv
)
-import OccName ( UserFS, varName, dataName, tcClsName, tvName )
+import OccName ( varName, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
SrcSpan, combineLocs, srcLocFile,
import StaticFlags ( opt_SccProfilingOn )
import Type ( Kind, mkArrowKind, liftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- Activation(..) )
+ Activation(..), defaultInlineSpec )
import OrdList
-import Panic
import FastString
import Maybes ( orElse )
'proc' { L _ ITproc } -- for arrow notation extension
'rec' { L _ ITrec } -- for arrow notation extension
- '{-# SPECIALISE' { L _ ITspecialise_prag }
+ '{-# INLINE' { L _ (ITinline_prag _) }
+ '{-# SPECIALISE' { L _ ITspec_prag }
+ '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) }
'{-# SOURCE' { L _ ITsource_prag }
- '{-# INLINE' { L _ ITinline_prag }
- '{-# NOINLINE' { L _ ITnoinline_prag }
'{-# RULES' { L _ ITrules_prag }
'{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
'{-# SCC' { L _ ITscc_prag }
%name parseIdentifier identifier
%name parseType ctype
%partial parseHeader header
-%tokentype { Located Token }
+%tokentype { (Located Token) }
%%
-----------------------------------------------------------------------------
{% do { (tc,tvs) <- checkSynHdr $2
; return (LL (TySynonym tc tvs $4)) } }
- | 'data' tycl_hdr constrs deriving
+ | data_or_newtype tycl_hdr constrs deriving
{ L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr
-- in case constrs and deriving are both empty
- (mkTyData DataType $2 Nothing (reverse (unLoc $3)) (unLoc $4)) }
+ (mkTyData (unLoc $1) (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) }
- | 'data' tycl_hdr opt_kind_sig
- 'where' gadt_constrlist -- No deriving for GADTs
+ | data_or_newtype tycl_hdr opt_kind_sig
+ 'where' gadt_constrlist
deriving
{ L (comb4 $1 $2 $4 $5)
- (mkTyData DataType $2 $3 (reverse (unLoc $5)) (unLoc $6)) }
-
- | 'newtype' tycl_hdr '=' newconstr deriving
- { L (comb3 $1 $4 $5)
- (mkTyData NewType $2 Nothing [$4] (unLoc $5)) }
+ (mkTyData (unLoc $1) (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
| 'class' tycl_hdr fds where
{ let
L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs
binds) }
+data_or_newtype :: { Located NewOrData }
+ : 'data' { L1 DataType }
+ | 'newtype' { L1 NewType }
+
opt_kind_sig :: { Maybe Kind }
: { Nothing }
| '::' kind { Just $2 }
rule :: { LHsDecl RdrName }
: STRING activation rule_forall infixexp '=' exp
- { LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6) }
+ { LL $ RuleD (HsRule (getSTRING $1)
+ ($2 `orElse` AlwaysActive)
+ $3 $4 placeHolderNames $6 placeHolderNames) }
-activation :: { Activation } -- Omitted means AlwaysActive
- : {- empty -} { AlwaysActive }
- | explicit_activation { $1 }
-
-inverse_activation :: { Activation } -- Omitted means NeverActive
- : {- empty -} { NeverActive }
- | explicit_activation { $1 }
+activation :: { Maybe Activation }
+ : {- empty -} { Nothing }
+ | explicit_activation { Just $1 }
explicit_activation :: { Activation } -- In brackets
: '[' INTEGER ']' { ActiveAfter (fromInteger (getINTEGER $2)) }
: btype { $1 }
| btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 }
| btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 }
- | btype '->' gentype { LL $ HsFunTy $1 $3 }
+ | btype '->' ctype { LL $ HsFunTy $1 $3 }
btype :: { LHsType RdrName }
: btype atype { LL $ HsAppTy $1 $2 }
: 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) }
+ | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 }
- | '[' type ']' { LL $ HsListTy $2 }
- | '[:' type ':]' { LL $ HsPArrTy $2 }
+ | '[' ctype ']' { LL $ HsListTy $2 }
+ | '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 }
-- Generics
| {- empty -} { [] }
comma_types1 :: { [LHsType RdrName] }
- : type { [$1] }
- | type ',' comma_types1 { $1 : $3 }
+ : ctype { [$1] }
+ | ctype ',' comma_types1 { $1 : $3 }
tv_bndrs :: { [LHsTyVarBndr RdrName] }
: tv_bndr tv_bndrs { $1 : $2 }
-----------------------------------------------------------------------------
-- Datatype declarations
-newconstr :: { LConDecl RdrName }
- : conid atype { LL $ ConDecl $1 [] (noLoc []) (PrefixCon [$2]) }
- | conid '{' var '::' ctype '}'
- { LL $ ConDecl $1 [] (noLoc []) (RecCon [($3, $5)]) }
-
gadt_constrlist :: { Located [LConDecl RdrName] }
: '{' gadt_constrs '}' { LL (unLoc $2) }
| vocurly gadt_constrs close { $2 }
| gadt_constrs ';' { $1 }
| gadt_constr { L1 [$1] }
+-- We allow the following forms:
+-- C :: Eq a => a -> T a
+-- C :: forall a. Eq a => !a -> T a
+-- D { x,y :: a } :: T a
+-- forall a. Eq a => D { x,y :: a } :: T a
+
gadt_constr :: { LConDecl RdrName }
: con '::' sigtype
- { LL (GadtDecl $1 $3) }
+ { LL (mkGadtDecl $1 $3) }
+ -- Syntax: Maybe merge the record stuff with the single-case above?
+ -- (to kill the mostly harmless reduce/reduce error)
+ -- XXX revisit autrijus
+ | constr_stuff_record '::' sigtype
+ { let (con,details) = unLoc $1 in
+ LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3)) }
+{-
+ | forall context '=>' constr_stuff_record '::' sigtype
+ { let (con,details) = unLoc $4 in
+ LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6)) }
+ | forall constr_stuff_record '::' sigtype
+ { let (con,details) = unLoc $2 in
+ LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4)) }
+-}
+
constrs :: { Located [LConDecl RdrName] }
: {- empty; a GHC extension -} { noLoc [] }
constr :: { LConDecl RdrName }
: forall context '=>' constr_stuff
{ let (con,details) = unLoc $4 in
- LL (ConDecl con (unLoc $1) $2 details) }
+ LL (ConDecl con Explicit (unLoc $1) $2 details ResTyH98) }
| forall constr_stuff
{ let (con,details) = unLoc $2 in
- LL (ConDecl con (unLoc $1) (noLoc []) details) }
+ LL (ConDecl con Explicit (unLoc $1) (noLoc []) details ResTyH98) }
forall :: { Located [LHsTyVarBndr RdrName] }
: 'forall' tv_bndrs '.' { LL $2 }
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL }
| btype conop btype { LL ($2, InfixCon $1 $3) }
+constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
+ : oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
+ | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
+
fielddecls :: { [([Located RdrName], LBangType RdrName)] }
: fielddecl ',' fielddecls { unLoc $1 : $3 }
| fielddecl { [unLoc $1] }
decl :: { Located (OrdList (LHsDecl RdrName)) }
: sigdecl { $1 }
+ | '!' infixexp rhs {% do { pat <- checkPattern $2;
+ return (LL $ unitOL $ LL $ ValD $
+ PatBind (LL $ BangPat pat) (unLoc $3)
+ placeHolderType placeHolderNames) } }
| infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3;
return (LL $ unitOL (LL $ ValD r)) } }
return (LL $ unitOL (LL $ SigD s)) }
-- See the above notes for why we need infixexp here
| var ',' sig_vars '::' sigtype
- { LL $ toOL [ LL $ SigD (Sig n $5) | n <- $1 : unLoc $3 ] }
+ { LL $ toOL [ LL $ SigD (TypeSig 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 $ unitOL (LL $ SigD (InlineSig True $3 $2)) }
- | '{-# NOINLINE' inverse_activation qvar '#-}'
- { LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) }
+ { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) }
| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $2 t)
+ { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec)
| t <- $4] }
+ | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
+ { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1)))
+ | t <- $5] }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{ LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
aexp :: { LHsExpr RdrName }
: qvar '@' aexp { LL $ EAsPat $1 $3 }
| '~' aexp { LL $ ELazyPat $2 }
+-- | '!' aexp { LL $ EBangPat $2 }
| aexp1 { $1 }
aexp1 :: { LHsExpr RdrName }
| INTEGER { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) }
| RATIONAL { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) }
| '(' exp ')' { LL (HsPar $2) }
- | '(' exp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
+ | '(' texp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
| '(#' texps '#)' { LL $ ExplicitTuple (reverse $2) Unboxed }
| '[' list ']' { LL (unLoc $2) }
| '[:' parr ':]' { LL (unLoc $2) }
: {- empty -} { [] }
| cvtopdecls { $1 }
+texp :: { LHsExpr RdrName }
+ : exp { $1 }
+ | qopm infixexp { LL $ SectionR $1 $2 }
+ -- The second production is really here only for bang patterns
+ -- but
+
texps :: { [LHsExpr RdrName] }
- : texps ',' exp { $3 : $1 }
- | exp { [$1] }
+ : texps ',' texp { $3 : $1 }
+ | texp { [$1] }
-----------------------------------------------------------------------------
-- avoiding another shift/reduce-conflict.
list :: { LHsExpr RdrName }
- : exp { L1 $ ExplicitList placeHolderType [$1] }
+ : texp { L1 $ ExplicitList placeHolderType [$1] }
| lexps { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) }
- | exp '..' { LL $ ArithSeq noPostTcExpr (From $1) }
- | exp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
- | exp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
- | exp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | exp pquals { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 }
+ | texp '..' { LL $ ArithSeq noPostTcExpr (From $1) }
+ | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
+ | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
+ | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
+ | texp pquals { sL (comb2 $1 $>) $ mkHsDo ListComp (reverse (unLoc $2)) $1 }
lexps :: { Located [LHsExpr RdrName] }
- : lexps ',' exp { LL ($3 : unLoc $1) }
- | exp ',' exp { LL [$3,$1] }
+ : lexps ',' texp { LL ($3 : unLoc $1) }
+ | texp ',' texp { LL [$3,$1] }
-----------------------------------------------------------------------------
-- List Comprehensions
| 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) }
qual :: { LStmt RdrName }
- : infixexp '<-' exp {% checkPattern $1 >>= \p ->
+ : exp '<-' exp {% checkPattern $1 >>= \p ->
return (LL $ mkBindStmt p $3) }
| exp { L1 $ mkExprStmt $1 }
| 'let' binds { LL $ LetStmt (unLoc $2) }
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
-- except 'unsafe' and 'forall' whose treatment differs depending on context
-special_id :: { Located UserFS }
+special_id :: { Located FastString }
special_id
: 'as' { L1 FSLIT("as") }
| 'qualified' { L1 FSLIT("qualified") }
| 'stdcall' { L1 FSLIT("stdcall") }
| 'ccall' { L1 FSLIT("ccall") }
-special_sym :: { Located UserFS }
+special_sym :: { Located FastString }
special_sym : '!' { L1 FSLIT("!") }
| '.' { L1 FSLIT(".") }
| '*' { L1 FSLIT("*") }
getPRIMFLOAT (L _ (ITprimfloat x)) = x
getPRIMDOUBLE (L _ (ITprimdouble x)) = x
getTH_ID_SPLICE (L _ (ITidEscape x)) = x
+getINLINE (L _ (ITinline_prag b)) = b
+getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b
-- Utilities for combining source spans
comb2 :: Located a -> Located b -> SrcSpan