-- ---------------------------------------------------------------------------
{
+{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
{-# OPTIONS -Wwarn -w #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
import ForeignCall ( Safety(..), CExportSpec(..), CLabelString,
CCallConv(..), CCallTarget(..), defaultCCallConv
)
-import OccName ( varName, dataName, tcClsName, tvName )
+import OccName ( varName, varNameDepth, dataName, tcClsName, tvName )
import DataCon ( DataCon, dataConName )
-import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans,
- SrcSpan, combineLocs, srcLocFile,
- mkSrcLoc, mkSrcSpan )
+import SrcLoc
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, liftedTypeKind, unliftedTypeKind )
import Coercion ( mkArrowKind )
import Class ( FunDep )
-import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- Activation(..), RuleMatchInfo(..), defaultInlinePragma )
+import BasicTypes
import DynFlags
import OrdList
import HaddockUtils
import GHC.Exts
import Data.Char
import Control.Monad ( mplus )
+
}
+
{-
-----------------------------------------------------------------------------
24 Februar 2006
'dynamic' { L _ ITdynamic }
'safe' { L _ ITsafe }
'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias
+ 'interruptible' { L _ ITinterruptible }
'unsafe' { L _ ITunsafe }
'mdo' { L _ ITmdo }
'family' { L _ ITfamily }
'by' { L _ ITby } -- for list transform extension
'using' { L _ ITusing } -- for list transform extension
- '{-# INLINE' { L _ (ITinline_prag _) }
- '{-# INLINE_CONLIKE' { L _ (ITinline_conlike_prag _) }
- '{-# SPECIALISE' { L _ ITspec_prag }
+ '{-# INLINE' { L _ (ITinline_prag _ _) }
+ '{-# SPECIALISE' { L _ ITspec_prag }
'{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) }
- '{-# SOURCE' { L _ ITsource_prag }
- '{-# RULES' { L _ ITrules_prag }
- '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
- '{-# SCC' { L _ ITscc_prag }
- '{-# GENERATED' { L _ ITgenerated_prag }
- '{-# DEPRECATED' { L _ ITdeprecated_prag }
- '{-# WARNING' { L _ ITwarning_prag }
- '{-# UNPACK' { L _ ITunpack_prag }
- '{-# ANN' { L _ ITann_prag }
- '#-}' { L _ ITclose_prag }
+ '{-# SOURCE' { L _ ITsource_prag }
+ '{-# RULES' { L _ ITrules_prag }
+ '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
+ '{-# SCC' { L _ ITscc_prag }
+ '{-# GENERATED' { L _ ITgenerated_prag }
+ '{-# DEPRECATED' { L _ ITdeprecated_prag }
+ '{-# WARNING' { L _ ITwarning_prag }
+ '{-# UNPACK' { L _ ITunpack_prag }
+ '{-# ANN' { L _ ITann_prag }
+ '{-# VECTORISE' { L _ ITvect_prag }
+ '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag }
+ '{-# NOVECTORISE' { L _ ITnovect_prag }
+ '#-}' { L _ ITclose_prag }
'..' { L _ ITdotdot } -- reserved symbols
':' { L _ ITcolon }
'|' { L _ ITvbar }
'<-' { L _ ITlarrow }
'->' { L _ ITrarrow }
+ '~~>' { L _ ITkappa }
'@' { L _ ITat }
'~' { L _ ITtilde }
'=>' { L _ ITdarrow }
'#)' { L _ ITcubxparen }
'(|' { L _ IToparenbar }
'|)' { L _ ITcparenbar }
+ '<[' { L _ ITopenBrak }
+ ']>' { L _ ITcloseBrak }
+ '<{' { L _ ITopenBrak1 }
+ '}>' { L _ ITcloseBrak1 }
+ '~~' { L _ ITescape }
+ '~~$' { L _ ITescapeDollar }
+ '%%' { L _ ITdoublePercent }
';' { L _ ITsemi }
',' { L _ ITcomma }
'`' { L _ ITbackquote }
| oqtycon '(' ')' { LL (IEThingWith (unLoc $1) []) }
| oqtycon '(' qcnames ')' { LL (IEThingWith (unLoc $1) (reverse $3)) }
| 'module' modid { LL (IEModuleContents (unLoc $2)) }
-
+ | '<[' incdepth export decdepth ']>' { $3 }
+ | '<{' incdepth1 export decdepth '}>' { $3 }
qcnames :: { [RdrName] }
: qcnames ',' qcname_ext { unLoc $3 : $1 }
| qcname_ext { [unLoc $1] }
-- Top-Level Declarations
topdecls :: { OrdList (LHsDecl RdrName) }
- : topdecls ';' topdecl { $1 `appOL` $3 }
- | topdecls ';' { $1 }
- | topdecl { $1 }
+ : topdecls ';' topdecl { $1 `appOL` $3 }
+ | topdecls ';' { $1 }
+ | topdecl { $1 }
topdecl :: { OrdList (LHsDecl RdrName) }
- : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
- | ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
- | 'instance' inst_type where_inst
- { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
- in
- unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
+ : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ | ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
+ | 'instance' inst_type where_inst
+ { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
+ in
+ unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
- | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
- | 'foreign' fdecl { unitOL (LL (unLoc $2)) }
+ | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
+ | 'foreign' fdecl { unitOL (LL (unLoc $2)) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# WARNING' warnings '#-}' { $2 }
- | '{-# RULES' rules '#-}' { $2 }
- | annotation { unitOL $1 }
- | decl { unLoc $1 }
-
- -- Template Haskell Extension
- -- The $(..) form is one possible form of infixexp
- -- but we treat an arbitrary expression just as if
- -- it had a $(..) wrapped around it
- | infixexp { unitOL (LL $ mkTopSpliceDecl $1) }
+ | '{-# RULES' rules '#-}' { $2 }
+ | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) }
+ | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) }
+ | '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) }
+ | annotation { unitOL $1 }
+ | decl { unLoc $1 }
+
+ -- Template Haskell Extension
+ -- The $(..) form is one possible form of infixexp
+ -- but we treat an arbitrary expression just as if
+ -- it had a $(..) wrapped around it
+ | infixexp { unitOL (LL $ mkTopSpliceDecl $1) }
-- Type classes
--
-- (Eq a, Ord b) => T a b
-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
-tycl_hdr :: { Located (LHsContext RdrName, LHsType RdrName) }
- : context '=>' type { LL ($1, $3) }
- | type { L1 (noLoc [], $1) }
+tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
+ : context '=>' type { LL (Just $1, $3) }
+ | type { L1 (Nothing, $1) }
-----------------------------------------------------------------------------
-- Stand-alone deriving
decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) }
| decl { $1 }
+ -- A 'default' signature used with the generic-programming extension
+ | 'default' infixexp '::' sigtypedoc
+ {% do { (TypeSig l ty) <- checkValSig $2 $4
+ ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } }
+
decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
: decls_cls ';' decl_cls { LL (unLoc $1 `appOL` unLoc $3) }
| decls_cls ';' { LL (unLoc $1) }
binds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
-- No type declarations
: decllist { L1 (HsValBinds (cvBindGroup (unLoc $1))) }
- | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
- | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
+ | '{' dbinds '}' { LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
+ | vocurly dbinds close { L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
wherebinds :: { Located (HsLocalBinds RdrName) } -- May have implicit parameters
-- No type declarations
safety :: { Safety }
: 'unsafe' { PlayRisky }
| 'safe' { PlaySafe False }
+ | 'interruptible' { PlayInterruptible }
| 'threadsafe' { PlaySafe True } -- deprecated alias
fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
strict_mark :: { Located HsBang }
: '!' { L1 HsStrict }
- | '{-# UNPACK' '#-}' '!' { LL HsUnbox }
+ | '{-# UNPACK' '#-}' '!' { LL HsUnpack }
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
| btype qtyconop type { LL $ HsOpTy $1 $2 $3 }
| btype tyvarop type { LL $ HsOpTy $1 $2 $3 }
| btype '->' ctype { LL $ HsFunTy $1 $3 }
+ | btype '~~>' ctype { LL $ HsKappaTy $1 $3 }
| btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) }
typedoc :: { LHsType RdrName }
| '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 }
| '[' ctype ']' { LL $ HsListTy $2 }
+ | '<[' ctype ']>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 }
| '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) }
- | '$(' exp ')' { LL $ HsSpliceTy (mkHsSplice $2 ) }
- | TH_ID_SPLICE { LL $ HsSpliceTy (mkHsSplice
- (L1 $ HsVar (mkUnqual varName
- (getTH_ID_SPLICE $1)))) } -- $x
--- Generics
- | INTEGER { L1 (HsNumTy (getINTEGER $1)) }
+ | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) }
+ | '$(' exp ')' { LL $ mkHsSpliceTy $2 }
+ | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
+ mkUnqual varName (getTH_ID_SPLICE $1) }
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr RdrName }
- : tyvar { L1 (UserTyVar (unLoc $1)) }
+ : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2)
(unLoc $4)) }
-----------------------------------------------------------------------------
-- Value definitions
-{- There's an awkward overlap with a type signature. Consider
+{- Note [Declaration/signature overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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 '='.
| docsection { L1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) }
decl :: { Located (OrdList (LHsDecl RdrName)) }
- : sigdecl { $1 }
- | '!' aexp 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;
- let { l = comb2 $1 $> };
- return $! (sL l (unitOL $! (sL l $ ValD r))) } }
- | docdecl { LL $ unitOL $1 }
+ : sigdecl { $1 }
+
+ | '!' aexp rhs {% do { let { e = LL (SectionR (LL (HsVar bang_RDR)) $2) };
+ pat <- checkPattern e;
+ return $ LL $ unitOL $ LL $ ValD $
+ PatBind pat (unLoc $3)
+ placeHolderType placeHolderNames } }
+ -- Turn it all into an expression so that
+ -- checkPattern can check that bangs are enabled
+
+ | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3;
+ let { l = comb2 $1 $> };
+ return $! (sL l (unitOL $! (sL l $ ValD r))) } }
+
+ | docdecl { LL $ unitOL $1 }
rhs :: { Located (GRHSs RdrName) }
: '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
: '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
- : infixexp '::' sigtypedoc
- {% do s <- checkValSig $1 $3;
- return (LL $ unitOL (LL $ SigD s)) }
- -- See the above notes for why we need infixexp here
+ :
+ -- See Note [Declaration/signature overlap] for why we need infixexp here
+ infixexp '::' sigtypedoc
+ {% do s <- checkValSig $1 $3
+ ; return (LL $ unitOL (LL $ SigD s)) }
| var ',' sig_vars '::' sigtypedoc
{ 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 $3 (mkInlinePragma $2 FunLike (getINLINE $1)))) }
- | '{-# INLINE_CONLIKE' activation qvar '#-}'
- { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) }
+ { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
{ LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma)
| t <- $4] }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1)))
+ { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2))
| t <- $5] }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{ LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
-----------------------------------------------------------------------------
-- Expressions
+quasiquote :: { Located (HsQuasiQuote RdrName) }
+ : TH_QUASIQUOTE { let { loc = getLoc $1
+ ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
+ ; quoterId = mkUnqual varName quoter }
+ in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
+
+incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } }
+incdepth1 :: { Located () } : {% do { incrBracketDepth1 ; return $ noLoc () } }
+decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } }
+pushdepth :: { Located () } : {% do { pushBracketDepth ; return $ noLoc () } }
+popdepth :: { Located () } : {% do { popBracketDepth ; return $ noLoc () } }
+
+
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
| infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
| infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True }
| infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False}
| infixexp { $1 }
+ | '~~$' pushdepth exp popdepth {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } }
infixexp :: { LHsExpr RdrName }
: exp10 { $1 }
exp10 :: { LHsExpr RdrName }
: '\\' apat apats opt_asig '->' exp
- { LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4
- (unguardedGRHSs $6)
- ]) }
+ {% do { x <- getParserBrakDepth
+ ; return
+ $ case x of
+ KappaFlavor:_ -> LL $ HsKappa (mkMatchGroup[LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ])
+ _ -> LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 (unguardedGRHSs $6) ])
+ } }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
- | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 }
+ | 'if' exp optSemi 'then' exp optSemi 'else' exp
+ {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
+ return (LL $ mkHsIf $2 $5 $8) }
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| '-' fexp { LL $ NegApp $2 noSyntaxExpr }
- | 'do' stmtlist {% let loc = comb2 $1 $2 in
- checkDo loc (unLoc $2) >>= \ (stmts,body) ->
- return (L loc (mkHsDo DoExpr stmts body)) }
- | 'mdo' stmtlist {% let loc = comb2 $1 $2 in
- checkDo loc (unLoc $2) >>= \ (stmts,body) ->
- return (L loc (mkHsDo (MDoExpr noPostTcTable) stmts body)) }
+ | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) }
+ | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
+
| scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2
else HsPar $2 }
-- hdaume: core annotation
| fexp { $1 }
+optSemi :: { Bool }
+ : ';' { True }
+ | {- empty -} { False }
+
scc_annot :: { Located FastString }
: '_scc_' STRING {% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
( do scc <- getSCC $2; return $ LL scc ) }
}
fexp :: { LHsExpr RdrName }
- : fexp aexp { LL $ HsApp $1 $2 }
+ : fexp aexp {% do { x <- getParserBrakDepth
+ ; return $ case x of
+ [] -> LL $ HsApp $1 $2
+ LambdaFlavor:_ -> LL $ HsApp $1 $2
+ KappaFlavor:_ -> LL $ HsKappaApp $1 $2
+ } }
| aexp { $1 }
aexp :: { LHsExpr RdrName }
| RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) }
-- N.B.: sections get parsed by these next two productions.
- -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't correct Haskell98
- -- (you'd have to write '((+ 3), (4 -))')
+ -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't
+ -- correct Haskell (you'd have to write '((+ 3), (4 -))')
-- but the less cluttered version fell out of having texps.
| '(' texp ')' { LL (HsPar $2) }
| '(' tup_exprs ')' { LL (ExplicitTuple $2 Boxed) }
-- Template Haskell Extension
| TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice
(L1 $ HsVar (mkUnqual varName
- (getTH_ID_SPLICE $1)))) } -- $x
- | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp )
-
- | TH_QUASIQUOTE { let { loc = getLoc $1
- ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
- ; quoterId = mkUnqual varName quoter
- }
- in sL loc $ HsQuasiQuoteE (mkHsQuasiQuote quoterId quoteSpan quote) }
+ (getTH_ID_SPLICE $1)))) }
+ | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) }
+
+
| TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) }
| TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) }
| '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) }
| '[p|' infixexp '|]' {% checkPattern $2 >>= \p ->
return (LL $ HsBracket (PatBr p)) }
- | '[d|' cvtopbody '|]' {% checkDecBrGroup $2 >>= \g ->
- return (LL $ HsBracket (DecBr g)) }
+ | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBrL $2) }
+ | quasiquote { L1 (HsQuasiQuoteE (unLoc $1)) }
-- arrow notation extension
| '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) }
+ -- code type notation extension
+ | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) }
+ | '<{' incdepth1 exp decdepth '}>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) }
+ | '~~' pushdepth aexp popdepth {% do { x <- mkHsHetMetEsc placeHolderType placeHolderType $3; return $ sL (comb2 $3 $>) x } }
+ | '%%' pushdepth aexp popdepth { sL (comb2 $3 $>) (HsHetMetCSP placeHolderType $3) }
+
cmdargs :: { [LHsCmdTop RdrName] }
: cmdargs acmd { $2 : $1 }
| {- empty -} { [] }
-- Note [Parsing sections]
-- ~~~~~~~~~~~~~~~~~~~~~~~
-- We include left and right sections here, which isn't
- -- technically right according to Haskell 98. For example
- -- (3 +, True) isn't legal
+ -- technically right according to the Haskell standard.
+ -- For example (3 +, True) isn't legal.
-- However, we want to parse bang patterns like
-- (!x, !y)
-- and it's convenient to do so here as a section
| qopm infixexp { LL $ SectionR $1 $2 }
-- View patterns get parenthesized above
- | exp '->' exp { LL $ EViewPat $1 $3 }
+ | exp '->' texp { LL $ EViewPat $1 $3 }
-- Always at least one comma
tup_exprs :: { [HsTupArg RdrName] }
| 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 '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 }
+ | texp '|' flattenedpquals
+ {% checkMonadComp >>= \ ctxt ->
+ return (sL (comb2 $1 $>) $
+ mkHsComp ctxt (unLoc $3) $1) }
lexps :: { Located [LHsExpr RdrName] }
: lexps ',' texp { LL (((:) $! $3) $! unLoc $1) }
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
- qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]]
+ qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr]
-- We actually found some actual parallel lists so
-- we wrap them into as a ParStmt
}
-- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |}
-- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user
--- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile
--- a program that makes use of this temporary syntax you must supply that flag to GHC
+-- demand.
transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
-- Function is applied to a list of stmts *in order*
(reverse (unLoc $1)) }
| texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 }
+ | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 }
-- We are reusing `lexps' and `flattenedpquals' from the list case.
| '..' { ([], True) }
fbind :: { HsRecField RdrName (LHsExpr RdrName) }
- : qvar '=' exp { HsRecField $1 $3 False }
- | qvar { HsRecField $1 (L (getLoc $1) placeHolderPunRhs) True }
- -- Here's where we say that plain 'x'
- -- means exactly 'x = x'. The pun-flag boolean is
- -- there so we can still print it right
+ : qvar '=' exp { HsRecField $1 $3 False }
+ | qvar { HsRecField $1 placeHolderPunRhs True }
+ -- In the punning case, use a place-holder
+ -- The renamer fills in the final value
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
| special_id { L1 $! mkUnqual tvName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual tvName (fsLit "safe") }
+ | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") }
| 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") }
tyvarsym :: { Located RdrName }
| PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
varid :: { Located RdrName }
- : VARID { L1 $! mkUnqual varName (getVARID $1) }
+ : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARID $1)) } }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual varName (fsLit "safe") }
+ | 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") }
| 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") }
| 'forall' { L1 $! mkUnqual varName (fsLit "forall") }
| 'family' { L1 $! mkUnqual varName (fsLit "family") }
| '-' { L1 $ mkUnqual varName (fsLit "-") }
varsym_no_minus :: { Located RdrName } -- varsym not including '-'
- : VARSYM { L1 $ mkUnqual varName (getVARSYM $1) }
- | special_sym { L1 $ mkUnqual varName (unLoc $1) }
-
+ : VARSYM {% do { depth <- getParserBrakDepth
+ ; return (L1 $! mkUnqual (varNameDepth $ length depth) (getVARSYM $1)) } }
+ | special_sym {% do { depth <- getParserBrakDepth
+ ; return (L1 $! mkUnqual (varNameDepth $ length depth) (unLoc $1)) } }
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
--- except 'unsafe', 'forall', and 'family' whose treatment differs
+-- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs
-- depending on context
special_id :: { Located FastString }
special_id
getPRIMFLOAT (L _ (ITprimfloat x)) = x
getPRIMDOUBLE (L _ (ITprimdouble x)) = x
getTH_ID_SPLICE (L _ (ITidEscape x)) = x
-getINLINE (L _ (ITinline_prag b)) = b
-getINLINE_CONLIKE (L _ (ITinline_conlike_prag b)) = b
-getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b
+getINLINE (L _ (ITinline_prag inl conl)) = (inl,conl)
+getSPEC_INLINE (L _ (ITspec_inline_prag True)) = (Inline, FunLike)
+getSPEC_INLINE (L _ (ITspec_inline_prag False)) = (NoInline,FunLike)
getDOCNEXT (L _ (ITdocCommentNext x)) = x
getDOCPREV (L _ (ITdocCommentPrev x)) = x
l <- getSrcLoc;
let loc = mkSrcLoc (srcLocFile l) 1 1;
return (mkSrcSpan loc loc)
+
+mkHsHetMetEsc a b c = do { depth <- getParserBrakDepth
+ ; return $ case head depth of
+ { LambdaFlavor -> HsHetMetEsc a b c
+ ; KappaFlavor -> HsHetMetEsc a b c
+ }
+ }
+
}
projects / ghc-hetmet.git / blobdiff