-- ---------------------------------------------------------------------------
{
-{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-}
--- The NoMonomorphismRestriction deals with a Happy infelicity
--- With OutsideIn's more conservativ monomorphism restriction
--- we aren't generalising
--- notHappyAtAll = error "urk"
--- which is terrible. Switching off the restriction allows
--- the generalisation. Better would be to make Happy generate
--- an appropriate signature.
-
+{-# 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
-- any warnings in the module. See
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,
'#)' { L _ ITcubxparen }
'(|' { L _ IToparenbar }
'|)' { L _ ITcparenbar }
+ '<[' { L _ ITopenBrak }
+ ']>' { L _ ITcloseBrak }
+ '~~' { L _ ITescape }
+ '~~$' { L _ ITescapeDollar }
+ '%%' { L _ ITdoublePercent }
';' { L _ ITsemi }
',' { L _ ITcomma }
'`' { L _ ITbackquote }
| '(' 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) }
| 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) }
: infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3
; return (LL $ unitOL (LL $ SigD s)) }
-- See Note [Declaration/signature overlap] for why we need infixexp here
+
| 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))))
; quoterId = mkUnqual varName quoter }
in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
+incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } }
+decdepth :: { Located () } : {% do { decrBracketDepth ; 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 }
+ | '~~$' decdepth exp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) }
infixexp :: { LHsExpr RdrName }
: exp10 { $1 }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
- return (LL $ HsIf $2 $5 $8) }
+ return (LL $ mkHsIf $2 $5 $8) }
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| '-' fexp { LL $ NegApp $2 noSyntaxExpr }
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)) }
+ return (L loc (mkHsDo MDoExpr
+ [L loc (mkRecStmt stmts)]
+ body)) }
| scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2
else HsPar $2 }
| 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) }
-- arrow notation extension
| '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) }
+ -- code type notation extension
+ | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) }
+ | '~~' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) }
+ | '%%' decdepth aexp incdepth { 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
| PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
varid :: { Located RdrName }
- : VARID { L1 $! mkUnqual varName (getVARID $1) }
+ : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual varName (fsLit "safe") }
| '-' { 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 depth) (getVARSYM $1)) } }
+ | special_sym {% do { depth <- getParserBrakDepth
+ ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } }
-- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these
projects / ghc-hetmet.git / blobdiff