-- ---------------------------------------------------------------------------
{
+{-# 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
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
+{-# OPTIONS_GHC -O0 -fno-ignore-interface-pragmas #-}
+{-
+Careful optimisation of the parser: we don't want to throw everything
+at it, because that takes too long and doesn't buy much, but we do want
+to inline certain key external functions, so we instruct GHC not to
+throw away inlinings as it would normally do in -O0 mode.
+-}
+
module Parser ( parseModule, parseStmt, parseIdentifier, parseType,
parseHeader ) where
-#define INCLUDE #include
-INCLUDE "HsVersions.h"
-
import HsSyn
import RdrHsSyn
-import HscTypes ( IsBootInterface, DeprecTxt )
+import HscTypes ( IsBootInterface, WarningTxt(..) )
import Lexer
import RdrName
import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
+ unboxedSingletonTyCon, unboxedSingletonDataCon,
listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR )
import Type ( funTyCon )
import ForeignCall ( Safety(..), CExportSpec(..), CLabelString,
mkSrcLoc, mkSrcSpan )
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
-import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
-import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- Activation(..), defaultInlineSpec )
+import Type ( Kind, liftedTypeKind, unliftedTypeKind )
+import Coercion ( mkArrowKind )
+import Class ( FunDep )
+import BasicTypes
import DynFlags
import OrdList
-import HaddockParse
-import {-# SOURCE #-} HaddockLex hiding ( Token )
import HaddockUtils
import FastString
'label' { L _ ITlabel }
'dynamic' { L _ ITdynamic }
'safe' { L _ ITsafe }
- 'threadsafe' { L _ ITthreadsafe }
+ 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias
+ 'interruptible' { L _ ITinterruptible }
'unsafe' { L _ ITunsafe }
'mdo' { L _ ITmdo }
'family' { L _ ITfamily }
'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv }
- 'dotnet' { L _ ITdotnet }
+ 'prim' { L _ ITprimcallconv }
'proc' { L _ ITproc } -- for arrow notation extension
'rec' { L _ ITrec } -- for arrow notation extension
+ 'group' { L _ ITgroup } -- for list transform extension
+ 'by' { L _ ITby } -- for list transform extension
+ 'using' { L _ ITusing } -- for list transform extension
- '{-# INLINE' { L _ (ITinline_prag _) }
+ '{-# INLINE' { L _ (ITinline_prag _ _) }
'{-# SPECIALISE' { L _ ITspec_prag }
'{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) }
'{-# SOURCE' { L _ ITsource_prag }
'{-# 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 }
'..' { L _ ITdotdot } -- reserved symbols
QCONID { L _ (ITqconid _) }
QVARSYM { L _ (ITqvarsym _) }
QCONSYM { L _ (ITqconsym _) }
+ PREFIXQVARSYM { L _ (ITprefixqvarsym _) }
+ PREFIXQCONSYM { L _ (ITprefixqconsym _) }
IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension
PRIMCHAR { L _ (ITprimchar _) }
PRIMSTRING { L _ (ITprimstring _) }
PRIMINTEGER { L _ (ITprimint _) }
+ PRIMWORD { L _ (ITprimword _) }
PRIMFLOAT { L _ (ITprimfloat _) }
PRIMDOUBLE { L _ (ITprimdouble _) }
DOCPREV { L _ (ITdocCommentPrev _) }
DOCNAMED { L _ (ITdocCommentNamed _) }
DOCSECTION { L _ (ITdocSection _ _) }
- DOCOPTIONS { L _ (ITdocOptions _) }
-- Template Haskell
'[|' { L _ ITopenExpQuote }
'$(' { L _ ITparenEscape } -- $( exp )
TH_VAR_QUOTE { L _ ITvarQuote } -- 'x
TH_TY_QUOTE { L _ ITtyQuote } -- ''T
+TH_QUASIQUOTE { L _ (ITquasiQuote _) }
%monad { P } { >>= } { return }
%lexer { lexer } { L _ ITeof }
| qcon { $1 }
| qvarop { $1 }
| qconop { $1 }
+ | '(' '->' ')' { LL $ getRdrName funTyCon }
-----------------------------------------------------------------------------
-- Module Header
-- know what they are doing. :-)
module :: { Located (HsModule RdrName) }
- : optdoc 'module' modid maybemoddeprec maybeexports 'where' body
- {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) ->
- return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
- opt info doc) )}}
+ : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
+ {% fileSrcSpan >>= \ loc ->
+ return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4 $1
+ ) )}
| body2
{% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule Nothing Nothing
- (fst $1) (snd $1) Nothing Nothing emptyHaddockModInfo
- Nothing)) }
+ return (L loc (HsModule Nothing Nothing
+ (fst $1) (snd $1) Nothing Nothing
+ )) }
-optdoc :: { (Maybe String, HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
- : moduleheader { (Nothing, fst $1, snd $1) }
- | docoptions { (Just $1, emptyHaddockModInfo, Nothing)}
- | docoptions moduleheader { (Just $1, fst $2, snd $2) }
- | moduleheader docoptions { (Just $2, fst $1, snd $1) }
- | {- empty -} { (Nothing, emptyHaddockModInfo, Nothing) }
+maybedocheader :: { Maybe LHsDocString }
+ : moduleheader { $1 }
+ | {- empty -} { Nothing }
missing_module_keyword :: { () }
: {- empty -} {% pushCurrentContext }
-maybemoddeprec :: { Maybe DeprecTxt }
- : '{-# DEPRECATED' STRING '#-}' { Just (getSTRING $2) }
- | {- empty -} { Nothing }
+maybemodwarning :: { Maybe WarningTxt }
+ : '{-# DEPRECATED' strings '#-}' { Just (DeprecatedTxt $ unLoc $2) }
+ | '{-# WARNING' strings '#-}' { Just (WarningTxt $ unLoc $2) }
+ | {- empty -} { Nothing }
body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
: '{' top '}' { $2 }
-- Module declaration & imports only
header :: { Located (HsModule RdrName) }
- : optdoc 'module' modid maybemoddeprec maybeexports 'where' header_body
- {% fileSrcSpan >>= \ loc -> case $1 of { (opt, info, doc) ->
- return (L loc (HsModule (Just $3) $5 $7 [] $4
- opt info doc))}}
+ : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
+ {% fileSrcSpan >>= \ loc ->
+ return (L loc (HsModule (Just $3) $5 $7 [] $4 $1
+ ))}
| missing_module_keyword importdecls
{% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule Nothing Nothing $2 [] Nothing
- Nothing emptyHaddockModInfo Nothing)) }
+ return (L loc (HsModule Nothing Nothing $2 [] Nothing
+ Nothing)) }
header_body :: { [LImportDecl RdrName] }
: '{' importdecls { $2 }
| {- empty -} { [] }
importdecl :: { LImportDecl RdrName }
- : 'import' maybe_src optqualified modid maybeas maybeimpspec
- { L (comb4 $1 $4 $5 $6) (ImportDecl $4 $2 $3 (unLoc $5) (unLoc $6)) }
+ : 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec
+ { L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) }
maybe_src :: { IsBootInterface }
: '{-# SOURCE' '#-}' { True }
| {- empty -} { False }
+maybe_pkg :: { Maybe FastString }
+ : STRING { Just (getSTRING $1) }
+ | {- empty -} { Nothing }
+
optqualified :: { Bool }
: 'qualified' { True }
| {- empty -} { False }
| stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) }
| 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) }
| 'foreign' fdecl { unitOL (LL (unLoc $2)) }
- | '{-# DEPRECATED' deprecations '#-}' { $2 }
+ | '{-# DEPRECATED' deprecations '#-}' { $2 }
+ | '{-# WARNING' warnings '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
+ | annotation { unitOL $1 }
| decl { unLoc $1 }
-- Template Haskell Extension
- | '$(' exp ')' { unitOL (LL $ SpliceD (SpliceDecl $2)) }
- | TH_ID_SPLICE { unitOL (LL $ SpliceD (SpliceDecl $
- L1 $ HsVar (mkUnqual varName (getTH_ID_SPLICE $1))
- )) }
+ -- 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
--
cl_decl :: { LTyClDecl RdrName }
- : 'class' tycl_hdr fds where_cls
- {% do { let { (binds, sigs, ats, docs) =
- cvBindsAndSigs (unLoc $4)
- ; (ctxt, tc, tvs, tparms) = unLoc $2}
- ; checkTyVars tparms -- only type vars allowed
- ; checkKindSigs ats
- ; return $ L (comb4 $1 $2 $3 $4)
- (mkClassDecl (ctxt, tc, tvs)
- (unLoc $3) sigs binds ats docs) } }
+ : 'class' tycl_hdr fds where_cls {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 $4 }
-- Type declarations (toplevel)
--
ty_decl :: { LTyClDecl RdrName }
-- ordinary type synonyms
- : 'type' type '=' ctype
+ : 'type' type '=' ctypedoc
-- Note ctype, not sigtype, on the right of '='
-- We allow an explicit for-all but we don't insert one
-- in type Foo a = (b,b)
--
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- {% do { (tc, tvs, _) <- checkSynHdr $2 False
- ; return (L (comb2 $1 $4)
- (TySynonym tc tvs Nothing $4))
- } }
+ {% mkTySynonym (comb2 $1 $4) False $2 $4 }
-- type family declarations
| 'type' 'family' type opt_kind_sig
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- --
- {% do { (tc, tvs, _) <- checkSynHdr $3 False
- ; return (L (comb3 $1 $3 $4)
- (TyFamily TypeFamily tc tvs (unLoc $4)))
- } }
+ {% mkTyFamily (comb3 $1 $3 $4) TypeFamily $3 (unLoc $4) }
-- type instance declarations
| 'type' 'instance' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- --
- {% do { (tc, tvs, typats) <- checkSynHdr $3 True
- ; return (L (comb2 $1 $5)
- (TySynonym tc tvs (Just typats) $5))
- } }
+ {% mkTySynonym (comb2 $1 $5) True $3 $5 }
-- ordinary data type or newtype declaration
| data_or_newtype tycl_hdr constrs deriving
- {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
- ; checkTyVars tparms -- no type pattern
- ; return $
- L (comb4 $1 $2 $3 $4)
+ {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) False $2
+ Nothing (reverse (unLoc $3)) (unLoc $4) }
-- We need the location on tycl_hdr in case
-- constrs and deriving are both empty
- (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing)
- Nothing (reverse (unLoc $3)) (unLoc $4)) } }
-- ordinary GADT declaration
| data_or_newtype tycl_hdr opt_kind_sig
- 'where' gadt_constrlist
+ gadt_constrlist
deriving
- {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
- ; checkTyVars tparms -- can have type pats
- ; return $
- L (comb4 $1 $2 $4 $5)
- (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing)
- (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
+ {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2
+ (unLoc $3) (unLoc $4) (unLoc $5) }
+ -- We need the location on tycl_hdr in case
+ -- constrs and deriving are both empty
-- data/newtype family
- | 'data' 'family' tycl_hdr opt_kind_sig
- {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
- ; checkTyVars tparms -- no type pattern
- ; unless (null (unLoc ctxt)) $ -- and no context
- parseError (getLoc ctxt)
- "A family declaration cannot have a context"
- ; return $
- L (comb3 $1 $2 $4)
- (TyFamily DataFamily tc tvs (unLoc $4)) } }
+ | 'data' 'family' type opt_kind_sig
+ {% mkTyFamily (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
- {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
- -- can have type pats
- ; return $
- L (comb4 $1 $3 $4 $5)
- -- We need the location on tycl_hdr in case
- -- constrs and deriving are both empty
- (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
- Nothing (reverse (unLoc $4)) (unLoc $5)) } }
+ {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) True $3
+ Nothing (reverse (unLoc $4)) (unLoc $5) }
-- GADT instance declaration
| data_or_newtype 'instance' tycl_hdr opt_kind_sig
- 'where' gadt_constrlist
+ gadt_constrlist
deriving
- {% do { let {(ctxt, tc, tvs, tparms) = unLoc $3}
- -- can have type pats
- ; return $
- L (comb4 $1 $3 $6 $7)
- (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
- (unLoc $4) (reverse (unLoc $6)) (unLoc $7)) } }
-
--- Associate type family declarations
+ {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3
+ (unLoc $4) (unLoc $5) (unLoc $6) }
+
+-- Associated type family declarations
--
-- * They have a different syntax than on the toplevel (no family special
-- identifier).
: 'type' type opt_kind_sig
-- Note the use of type for the head; this allows
-- infix type constructors to be declared
- --
- {% do { (tc, tvs, _) <- checkSynHdr $2 False
- ; return (L (comb3 $1 $2 $3)
- (TyFamily TypeFamily tc tvs (unLoc $3)))
- } }
+ {% mkTyFamily (comb3 $1 $2 $3) TypeFamily $2 (unLoc $3) }
-- default type instance
| 'type' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- --
- {% do { (tc, tvs, typats) <- checkSynHdr $2 True
- ; return (L (comb2 $1 $4)
- (TySynonym tc tvs (Just typats) $4))
- } }
+ {% mkTySynonym (comb2 $1 $4) True $2 $4 }
-- data/newtype family declaration
- | 'data' tycl_hdr opt_kind_sig
- {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
- ; checkTyVars tparms -- no type pattern
- ; unless (null (unLoc ctxt)) $ -- and no context
- parseError (getLoc ctxt)
- "A family declaration cannot have a context"
- ; return $
- L (comb3 $1 $2 $3)
- (TyFamily DataFamily tc tvs (unLoc $3))
- } }
-
--- Associate type instances
+ | 'data' type opt_kind_sig
+ {% mkTyFamily (comb3 $1 $2 $3) DataFamily $2 (unLoc $3) }
+
+-- Associated type instances
--
at_decl_inst :: { LTyClDecl RdrName }
-- type instance declarations
: 'type' type '=' ctype
-- Note the use of type for the head; this allows
-- infix type constructors and type patterns
- --
- {% do { (tc, tvs, typats) <- checkSynHdr $2 True
- ; return (L (comb2 $1 $4)
- (TySynonym tc tvs (Just typats) $4))
- } }
+ {% mkTySynonym (comb2 $1 $4) True $2 $4 }
-- data/newtype instance declaration
| data_or_newtype tycl_hdr constrs deriving
- {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
- -- can have type pats
- ; return $
- L (comb4 $1 $2 $3 $4)
- -- We need the location on tycl_hdr in case
- -- constrs and deriving are both empty
- (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
- Nothing (reverse (unLoc $3)) (unLoc $4)) } }
+ {% mkTyData (comb4 $1 $2 $3 $4) (unLoc $1) True $2
+ Nothing (reverse (unLoc $3)) (unLoc $4) }
-- GADT instance declaration
| data_or_newtype tycl_hdr opt_kind_sig
- 'where' gadt_constrlist
+ gadt_constrlist
deriving
- {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
- -- can have type pats
- ; return $
- L (comb4 $1 $2 $5 $6)
- (mkTyData (unLoc $1) (ctxt, tc, tvs, Just tparms)
- (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
+ {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) True $2
+ (unLoc $3) (unLoc $4) (unLoc $5) }
data_or_newtype :: { Located NewOrData }
: 'data' { L1 DataType }
-- (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,
- Located RdrName,
- [LHsTyVarBndr RdrName],
- [LHsType RdrName]) }
- : context '=>' type {% checkTyClHdr $1 $3 >>= return.LL }
- | type {% checkTyClHdr (noLoc []) $1 >>= return.L1 }
+tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) }
+ : context '=>' type { LL (Just $1, $3) }
+ | type { L1 (Nothing, $1) }
-----------------------------------------------------------------------------
-- Stand-alone deriving
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
- : 'deriving' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) }
+ : 'deriving' 'instance' inst_type { LL (DerivDecl $3) }
-----------------------------------------------------------------------------
-- Nested declarations
-- Declarations in binding groups other than classes and instances
--
decls :: { Located (OrdList (LHsDecl RdrName)) }
- : decls ';' decl { LL (unLoc $1 `appOL` unLoc $3) }
+ : decls ';' decl { let { this = unLoc $3;
+ rest = unLoc $1;
+ these = rest `appOL` this }
+ in rest `seq` this `seq` these `seq`
+ LL these }
| decls ';' { LL (unLoc $1) }
| decl { $1 }
| {- empty -} { noLoc nilOL }
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
| '(' varid '::' ctype ')' { RuleBndrSig $2 $4 }
-----------------------------------------------------------------------------
--- Deprecations (c.f. rules)
+-- Warnings and deprecations (c.f. rules)
+
+warnings :: { OrdList (LHsDecl RdrName) }
+ : warnings ';' warning { $1 `appOL` $3 }
+ | warnings ';' { $1 }
+ | warning { $1 }
+ | {- empty -} { nilOL }
+
+-- SUP: TEMPORARY HACK, not checking for `module Foo'
+warning :: { OrdList (LHsDecl RdrName) }
+ : namelist strings
+ { toOL [ LL $ WarningD (Warning n (WarningTxt $ unLoc $2))
+ | n <- unLoc $1 ] }
deprecations :: { OrdList (LHsDecl RdrName) }
: deprecations ';' deprecation { $1 `appOL` $3 }
-- SUP: TEMPORARY HACK, not checking for `module Foo'
deprecation :: { OrdList (LHsDecl RdrName) }
- : depreclist STRING
- { toOL [ LL $ DeprecD (Deprecation n (getSTRING $2))
+ : namelist strings
+ { toOL [ LL $ WarningD (Warning n (DeprecatedTxt $ unLoc $2))
| n <- unLoc $1 ] }
+strings :: { Located [FastString] }
+ : STRING { L1 [getSTRING $1] }
+ | '[' stringlist ']' { LL $ fromOL (unLoc $2) }
+
+stringlist :: { Located (OrdList FastString) }
+ : stringlist ',' STRING { LL (unLoc $1 `snocOL` getSTRING $3) }
+ | STRING { LL (unitOL (getSTRING $1)) }
+
+-----------------------------------------------------------------------------
+-- Annotations
+annotation :: { LHsDecl RdrName }
+ : '{-# ANN' name_var aexp '#-}' { LL (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc $2)) $3) }
+ | '{-# ANN' 'type' tycon aexp '#-}' { LL (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc $3)) $4) }
+ | '{-# ANN' 'module' aexp '#-}' { LL (AnnD $ HsAnnotation ModuleAnnProvenance $3) }
+
-----------------------------------------------------------------------------
-- Foreign import and export declarations
| 'export' callconv fspec
{% mkExport $2 (unLoc $3) >>= return.LL }
-callconv :: { CallConv }
- : 'stdcall' { CCall StdCallConv }
- | 'ccall' { CCall CCallConv }
- | 'dotnet' { DNCall }
+callconv :: { CCallConv }
+ : 'stdcall' { StdCallConv }
+ | 'ccall' { CCallConv }
+ | 'prim' { PrimCallConv}
safety :: { Safety }
: 'unsafe' { PlayRisky }
| 'safe' { PlaySafe False }
- | 'threadsafe' { PlaySafe True }
+ | 'interruptible' { PlayInterruptible }
+ | 'threadsafe' { PlaySafe True } -- deprecated alias
fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
: STRING var '::' sigtypedoc { LL (L (getLoc $1) (getSTRING $1), $2, $4) }
: {- empty -} { Nothing }
| '::' atype { Just $2 }
-sigtypes1 :: { [LHsType RdrName] }
- : sigtype { [ $1 ] }
- | sigtype ',' sigtypes1 { $1 : $3 }
-
-sigtype :: { LHsType RdrName }
+sigtype :: { LHsType RdrName } -- Always a HsForAllTy,
+ -- to tell the renamer where to generalise
: ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
-- Wrap an Implicit forall if there isn't one there already
-sigtypedoc :: { LHsType RdrName }
+sigtypedoc :: { LHsType RdrName } -- Always a HsForAllTy
: ctypedoc { L1 (mkImplicitHsForAllTy (noLoc []) $1) }
-- Wrap an Implicit forall if there isn't one there already
: sig_vars ',' var { LL ($3 : unLoc $1) }
| var { L1 [$1] }
+sigtypes1 :: { [LHsType RdrName] } -- Always HsForAllTys
+ : sigtype { [ $1 ] }
+ | sigtype ',' sigtypes1 { $1 : $3 }
+
-----------------------------------------------------------------------------
-- Types
infixtype :: { LHsType RdrName }
- : btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 }
- | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 }
+ : btype qtyconop type { LL $ HsOpTy $1 $2 $3 }
+ | btype tyvarop type { LL $ HsOpTy $1 $2 $3 }
-infixtypedoc :: { LHsType RdrName }
- : infixtype { $1 }
- | infixtype docprev { LL $ HsDocTy $1 $2 }
-
-gentypedoc :: { LHsType RdrName }
- : btype { $1 }
- | btypedoc { $1 }
- | infixtypedoc { $1 }
- | btype '->' ctypedoc { LL $ HsFunTy $1 $3 }
- | btypedoc '->' ctypedoc { LL $ HsFunTy $1 $3 }
-
-ctypedoc :: { LHsType RdrName }
- : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
- | context '=>' gentypedoc { LL $ mkImplicitHsForAllTy $1 $3 }
- -- A type of form (context => type) is an *implicit* HsForAllTy
- | gentypedoc { $1 }
-
strict_mark :: { Located HsBang }
: '!' { L1 HsStrict }
- | '{-# UNPACK' '#-}' '!' { LL HsUnbox }
+ | '{-# UNPACK' '#-}' '!' { LL HsUnpack }
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
- | context '=>' type { LL $ mkImplicitHsForAllTy $1 $3 }
+ | context '=>' ctype { LL $ mkImplicitHsForAllTy $1 $3 }
+ -- A type of form (context => type) is an *implicit* HsForAllTy
+ | ipvar '::' type { LL (HsPredTy (HsIParam (unLoc $1) $3)) }
+ | type { $1 }
+
+----------------------
+-- Notes for 'ctypedoc'
+-- It would have been nice to simplify the grammar by unifying `ctype` and
+-- ctypedoc` into one production, allowing comments on types everywhere (and
+-- rejecting them after parsing, where necessary). This is however not possible
+-- since it leads to ambiguity. The reason is the support for comments on record
+-- fields:
+-- data R = R { field :: Int -- ^ comment on the field }
+-- If we allow comments on types here, it's not clear if the comment applies
+-- to 'field' or to 'Int'. So we must use `ctype` to describe the type.
+
+ctypedoc :: { LHsType RdrName }
+ : 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
+ | context '=>' ctypedoc { LL $ mkImplicitHsForAllTy $1 $3 }
-- A type of form (context => type) is an *implicit* HsForAllTy
- | type { $1 }
+ | ipvar '::' type { LL (HsPredTy (HsIParam (unLoc $1) $3)) }
+ | typedoc { $1 }
+----------------------
+-- Notes for 'context'
-- We parse a context as a btype so that we don't get reduce/reduce
-- errors in ctype. The basic problem is that
-- (Eq a, Ord a)
-- looks so much like a tuple type. We can't tell until we find the =>
---
--- We have the t1 ~ t2 form here and in gentype, to permit an individual
--- equational constraint without parenthesis.
+
+-- We have the t1 ~ t2 form both in 'context' and in type,
+-- to permit an individual equational constraint without parenthesis.
+-- Thus for some reason we allow f :: a~b => blah
+-- but not f :: ?x::Int => blah
context :: { LHsContext RdrName }
: btype '~' btype {% checkContext
(LL $ HsPredTy (HsEqualP $1 $3)) }
| btype {% checkContext $1 }
type :: { LHsType RdrName }
- : ipvar '::' gentype { LL (HsPredTy (HsIParam (unLoc $1) $3)) }
- | gentype { $1 }
-
-gentype :: { LHsType RdrName }
: btype { $1 }
- | btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 }
- | btype tyvarop gentype { LL $ HsOpTy $1 $2 $3 }
+ | btype qtyconop type { LL $ HsOpTy $1 $2 $3 }
+ | btype tyvarop type { LL $ HsOpTy $1 $2 $3 }
| btype '->' ctype { LL $ HsFunTy $1 $3 }
| btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) }
+typedoc :: { LHsType RdrName }
+ : btype { $1 }
+ | btype docprev { LL $ HsDocTy $1 $2 }
+ | btype qtyconop type { LL $ HsOpTy $1 $2 $3 }
+ | btype qtyconop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
+ | btype tyvarop type { LL $ HsOpTy $1 $2 $3 }
+ | btype tyvarop type docprev { LL $ HsDocTy (L (comb3 $1 $2 $3) (HsOpTy $1 $2 $3)) $4 }
+ | btype '->' ctypedoc { LL $ HsFunTy $1 $3 }
+ | btype docprev '->' ctypedoc { LL $ HsFunTy (L (comb2 $1 $2) (HsDocTy $1 $2)) $4 }
+ | btype '~' btype { LL $ HsPredTy (HsEqualP $1 $3) }
+
btype :: { LHsType RdrName }
: btype atype { LL $ HsAppTy $1 $2 }
| atype { $1 }
-btypedoc :: { LHsType RdrName }
- : btype atype docprev { LL $ HsDocTy (L (comb2 $1 $2) (HsAppTy $1 $2)) $3 }
- | atype docprev { LL $ HsDocTy $1 $2 }
-
atype :: { LHsType RdrName }
: gtycon { L1 (HsTyVar (unLoc $1)) }
| tyvar { L1 (HsTyVar (unLoc $1)) }
- | strict_mark atype { LL (HsBangTy (unLoc $1) $2) }
+ | strict_mark atype { LL (HsBangTy (unLoc $1) $2) } -- Constructor sigs only
+ | '{' fielddecls '}' { LL $ HsRecTy $2 } -- Constructor sigs only
| '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) }
| '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 }
| '[' ctype ']' { LL $ HsListTy $2 }
| '[:' ctype ':]' { LL $ HsPArrTy $2 }
| '(' ctype ')' { LL $ HsParTy $2 }
| '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) }
+ | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) }
+ | '$(' exp ')' { LL $ mkHsSpliceTy $2 }
+ | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
+ mkUnqual varName (getTH_ID_SPLICE $1) }
-- Generics
| INTEGER { L1 (HsNumTy (getINTEGER $1)) }
| {- empty -} { [] }
tv_bndr :: { LHsTyVarBndr RdrName }
- : tyvar { L1 (UserTyVar (unLoc $1)) }
+ : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) }
| '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2)
(unLoc $4)) }
-fds :: { Located [Located ([RdrName], [RdrName])] }
+fds :: { Located [Located (FunDep RdrName)] }
: {- empty -} { noLoc [] }
| '|' fds1 { LL (reverse (unLoc $2)) }
-fds1 :: { Located [Located ([RdrName], [RdrName])] }
+fds1 :: { Located [Located (FunDep RdrName)] }
: fds1 ',' fd { LL ($3 : unLoc $1) }
| fd { L1 [$1] }
-fd :: { Located ([RdrName], [RdrName]) }
+fd :: { Located (FunDep RdrName) }
: varids0 '->' varids0 { L (comb3 $1 $2 $3)
(reverse (unLoc $1), reverse (unLoc $3)) }
-----------------------------------------------------------------------------
-- Datatype declarations
-gadt_constrlist :: { Located [LConDecl RdrName] }
- : '{' gadt_constrs '}' { LL (unLoc $2) }
- | vocurly gadt_constrs close { $2 }
+gadt_constrlist :: { Located [LConDecl RdrName] } -- Returned in order
+ : 'where' '{' gadt_constrs '}' { L (comb2 $1 $3) (unLoc $3) }
+ | 'where' vocurly gadt_constrs close { L (comb2 $1 $3) (unLoc $3) }
+ | {- empty -} { noLoc [] }
gadt_constrs :: { Located [LConDecl RdrName] }
- : gadt_constrs ';' gadt_constr { LL ($3 : unLoc $1) }
- | gadt_constrs ';' { $1 }
- | gadt_constr { L1 [$1] }
+ : gadt_constr ';' gadt_constrs { L (comb2 (head $1) $3) ($1 ++ unLoc $3) }
+ | gadt_constr { L (getLoc (head $1)) $1 }
+ | {- empty -} { noLoc [] }
-- We allow the following forms:
-- C :: 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 (mkGadtDecl $1 $3) }
- -- Syntax: Maybe merge the record stuff with the single-case above?
- -- (to kill the mostly harmless reduce/reduce error)
- -- XXX revisit audreyt
- | constr_stuff_record '::' sigtype
- { let (con,details) = unLoc $1 in
- LL (ConDecl con Implicit [] (noLoc []) details (ResTyGADT $3) Nothing) }
-{-
- | forall context '=>' constr_stuff_record '::' sigtype
- { let (con,details) = unLoc $4 in
- LL (ConDecl con Implicit (unLoc $1) $2 details (ResTyGADT $6) Nothing ) }
- | forall constr_stuff_record '::' sigtype
- { let (con,details) = unLoc $2 in
- LL (ConDecl con Implicit (unLoc $1) (noLoc []) details (ResTyGADT $4) Nothing) }
--}
+gadt_constr :: { [LConDecl RdrName] } -- Returns a list because of: C,D :: ty
+ : con_list '::' sigtype
+ { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) }
+ -- Deprecated syntax for GADT record declarations
+ | oqtycon '{' fielddecls '}' '::' sigtype
+ {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6
+ ; return [cd] } }
constrs :: { Located [LConDecl RdrName] }
- : {- empty; a GHC extension -} { noLoc [] }
- | maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) }
+ : maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) }
constrs1 :: { Located [LConDecl RdrName] }
: constrs1 maybe_docnext '|' maybe_docprev constr { LL (addConDoc $5 $2 : addConDocFirst (unLoc $1) $4) }
constr :: { LConDecl RdrName }
: maybe_docnext forall context '=>' constr_stuff maybe_docprev
{ let (con,details) = unLoc $5 in
- L (comb4 $2 $3 $4 $5) (ConDecl con Explicit (unLoc $2) $3 details ResTyH98 ($1 `mplus` $6)) }
+ addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con (unLoc $2) $3 details))
+ ($1 `mplus` $6) }
| maybe_docnext forall constr_stuff maybe_docprev
{ let (con,details) = unLoc $3 in
- L (comb2 $2 $3) (ConDecl con Explicit (unLoc $2) (noLoc []) details ResTyH98 ($1 `mplus` $4)) }
+ addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con (unLoc $2) (noLoc []) details))
+ ($1 `mplus` $4) }
forall :: { Located [LHsTyVarBndr RdrName] }
: 'forall' tv_bndrs '.' { LL $2 }
-- 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 }
- | oqtycon '{' '}' {% mkRecCon $1 [] >>= return.LL }
- | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL }
- | btype conop btype { LL ($2, InfixCon $1 $3) }
+ : btype {% splitCon $1 >>= return.LL }
+ | btype conop btype { LL ($2, InfixCon $1 $3) }
-constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) }
- : oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
- | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
+fielddecls :: { [ConDeclField RdrName] }
+ : {- empty -} { [] }
+ | fielddecls1 { $1 }
-fielddecls :: { [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] }
- : fielddecl maybe_docnext ',' maybe_docprev fielddecls { addFieldDoc (unLoc $1) $4 : addFieldDocs $5 $2 }
- | fielddecl { [unLoc $1] }
+fielddecls1 :: { [ConDeclField RdrName] }
+ : fielddecl maybe_docnext ',' maybe_docprev fielddecls1
+ { [ addFieldDoc f $4 | f <- $1 ] ++ addFieldDocs $5 $2 }
+ -- This adds the doc $4 to each field separately
+ | fielddecl { $1 }
-fielddecl :: { Located ([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName)) }
- : maybe_docnext sig_vars '::' ctype maybe_docprev { L (comb3 $2 $3 $4) (reverse (unLoc $2), $4, $1 `mplus` $5) }
+fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int
+ : maybe_docnext sig_vars '::' ctype maybe_docprev { [ ConDeclField fld $4 ($1 `mplus` $5)
+ | fld <- reverse (unLoc $2) ] }
-- 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).
-----------------------------------------------------------------------------
-- 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 '='.
docdecl :: { LHsDecl RdrName }
: docdecld { L1 (DocD (unLoc $1)) }
-docdecld :: { LDocDecl RdrName }
+docdecld :: { LDocDecl }
: docnext { L1 (DocCommentNext (unLoc $1)) }
| docprev { L1 (DocCommentPrev (unLoc $1)) }
| docnamed { L1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) }
| 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;
- return (LL $ unitOL (LL $ 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 { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
+ : '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
| gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) }
gdrhs :: { Located [LGRHS RdrName] }
| gdrh { L1 [$1] }
gdrh :: { LGRHS RdrName }
- : '|' quals '=' exp { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
+ : '|' 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
+ : 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))))
| n <- unLoc $3 ] }
| '{-# INLINE' activation qvar '#-}'
- { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) }
+ { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec)
+ { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma)
| t <- $4] }
| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (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)) }
+ { 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 quoteSpan quote) }
+
exp :: { LHsExpr RdrName }
: infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 }
| infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True }
(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 }
-- hdaume: core annotation
| fexp { $1 }
+optSemi :: { Bool }
+ : ';' { True }
+ | {- empty -} { False }
+
scc_annot :: { Located FastString }
- : '_scc_' STRING {% (addWarning Opt_WarnDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
- (return $ LL $ getSTRING $2) }
- | '{-# SCC' STRING '#-}' { LL $ getSTRING $2 }
+ : '_scc_' STRING {% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
+ ( do scc <- getSCC $2; return $ LL scc ) }
+ | '{-# SCC' STRING '#-}' {% do scc <- getSCC $2; return $ LL scc }
hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
: '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
aexp :: { LHsExpr RdrName }
: qvar '@' aexp { LL $ EAsPat $1 $3 }
| '~' aexp { LL $ ELazyPat $2 }
- | aexp1 { $1 }
+ | aexp1 { $1 }
aexp1 :: { LHsExpr RdrName }
: aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3
-- so it's not enabled yet.
-- But this case *is* used for the left hand side of a generic definition,
-- which is parsed as an expression before being munged into a pattern
- | qcname '{|' gentype '|}' { LL $ HsApp (sL (getLoc $1) (HsVar (unLoc $1)))
+ | qcname '{|' type '|}' { LL $ HsApp (sL (getLoc $1) (HsVar (unLoc $1)))
(sL (getLoc $3) (HsType $3)) }
aexp2 :: { LHsExpr RdrName }
| literal { L1 (HsLit $! unLoc $1) }
-- This will enable overloaded strings permanently. Normally the renamer turns HsString
-- into HsOverLit when -foverloaded-strings is on.
--- | STRING { L1 (HsOverLit $! mkHsIsString (getSTRING $1)) }
- | INTEGER { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) }
- | RATIONAL { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) }
- | '(' exp ')' { LL (HsPar $2) }
- | '(' texp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
- | '(#' texps '#)' { LL $ ExplicitTuple (reverse $2) Unboxed }
+-- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRING $1) placeHolderType) }
+ | INTEGER { sL (getLoc $1) (HsOverLit $! mkHsIntegral (getINTEGER $1) placeHolderType) }
+ | 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 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) }
+
+ | '(#' texp '#)' { LL (ExplicitTuple [Present $2] Unboxed) }
+ | '(#' tup_exprs '#)' { LL (ExplicitTuple $2 Unboxed) }
+
| '[' list ']' { LL (unLoc $2) }
| '[:' parr ':]' { LL (unLoc $2) }
- | '(' infixexp qop ')' { LL $ SectionL $2 $3 }
- | '(' qopm infixexp ')' { LL $ SectionR $2 $3 }
| '_' { L1 EWildPat }
-- Template Haskell Extension
| TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice
(L1 $ HsVar (mkUnqual varName
- (getTH_ID_SPLICE $1)))) } -- $x
- | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp )
+ (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)) }
| '[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) }
: {- empty -} { [] }
| cvtopdecls { $1 }
+-----------------------------------------------------------------------------
+-- Tuple expressions
+
+-- "texp" is short for tuple expressions:
+-- things that can appear unparenthesized as long as they're
+-- inside parens or delimitted by commas
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 ',' texp { $3 : $1 }
- | texp { [$1] }
+ -- Note [Parsing sections]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~
+ -- We include left and right sections here, which isn't
+ -- 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
+ -- Then when converting expr to pattern we unravel it again
+ -- Meanwhile, the renamer checks that real sections appear
+ -- inside parens.
+ | infixexp qop { LL $ SectionL $1 $2 }
+ | qopm infixexp { LL $ SectionR $1 $2 }
+
+ -- View patterns get parenthesized above
+ | exp '->' texp { LL $ EViewPat $1 $3 }
+
+-- Always at least one comma
+tup_exprs :: { [HsTupArg RdrName] }
+ : texp commas_tup_tail { Present $1 : $2 }
+ | commas tup_tail { replicate $1 missingTupArg ++ $2 }
+
+-- Always starts with commas; always follows an expr
+commas_tup_tail :: { [HsTupArg RdrName] }
+commas_tup_tail : commas tup_tail { replicate ($1-1) missingTupArg ++ $2 }
+
+-- Always follows a comma
+tup_tail :: { [HsTupArg RdrName] }
+ : texp commas_tup_tail { Present $1 : $2 }
+ | texp { [Present $1] }
+ | {- empty -} { [missingTupArg] }
-----------------------------------------------------------------------------
-- List expressions
| 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 }
+ | texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 }
lexps :: { Located [LHsExpr RdrName] }
- : lexps ',' texp { LL ($3 : unLoc $1) }
+ : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) }
| texp ',' texp { LL [$3,$1] }
-----------------------------------------------------------------------------
-- List Comprehensions
-pquals :: { Located [LStmt RdrName] } -- Either a singleton ParStmt,
- -- or a reversed list of Stmts
- : pquals1 { case unLoc $1 of
- [qs] -> L1 qs
- qss -> L1 [L1 (ParStmt stmtss)]
- where
- stmtss = [ (reverse qs, undefined)
- | qs <- qss ]
- }
-
-pquals1 :: { Located [[LStmt RdrName]] }
- : pquals1 '|' quals { LL (unLoc $3 : unLoc $1) }
- | '|' quals { L (getLoc $2) [unLoc $2] }
-
-quals :: { Located [LStmt RdrName] }
- : quals ',' qual { LL ($3 : unLoc $1) }
- | qual { L1 [$1] }
+flattenedpquals :: { Located [LStmt RdrName] }
+ : pquals { case (unLoc $1) of
+ [qs] -> L1 qs
+ -- We just had one thing in our "parallel" list so
+ -- we simply return that thing directly
+
+ qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]]
+ -- We actually found some actual parallel lists so
+ -- we wrap them into as a ParStmt
+ }
+
+pquals :: { Located [[LStmt RdrName]] }
+ : squals '|' pquals { L (getLoc $2) (reverse (unLoc $1) : unLoc $3) }
+ | squals { L (getLoc $1) [reverse (unLoc $1)] }
+
+squals :: { Located [LStmt RdrName] } -- In reverse order, because the last
+ -- one can "grab" the earlier ones
+ : squals ',' transformqual { LL [L (getLoc $3) ((unLoc $3) (reverse (unLoc $1)))] }
+ | squals ',' qual { LL ($3 : unLoc $1) }
+ | transformqual { LL [L (getLoc $1) ((unLoc $1) [])] }
+ | qual { L1 [$1] }
+-- | transformquals1 ',' '{|' pquals '|}' { LL ($4 : unLoc $1) }
+-- | '{|' pquals '|}' { L1 [$2] }
+
+
+-- 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
+
+transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
+ -- Function is applied to a list of stmts *in order*
+ : 'then' exp { LL $ \leftStmts -> (mkTransformStmt leftStmts $2) }
+ -- >>>
+ | 'then' exp 'by' exp { LL $ \leftStmts -> (mkTransformByStmt leftStmts $2 $4) }
+ | 'then' 'group' 'by' exp { LL $ \leftStmts -> (mkGroupByStmt leftStmts $4) }
+ -- <<<
+ -- These two productions deliberately have a shift-reduce conflict. I have made 'group' into a special_id,
+ -- which means you can enable TransformListComp while still using Data.List.group. However, this makes the two
+ -- productions ambiguous. I've set things up so that Happy chooses to resolve the conflict in that case by
+ -- choosing the "group by" variant, which is what we want.
+ --
+ -- This is rather dubious: the user might be confused as to how to parse this statement. However, it is a good
+ -- practical choice. NB: Data.List.group :: [a] -> [[a]], so using the first production would not even type check
+ -- if /that/ is the group function we conflict with.
+ | 'then' 'group' 'using' exp { LL $ \leftStmts -> (mkGroupUsingStmt leftStmts $4) }
+ | 'then' 'group' 'by' exp 'using' exp { LL $ \leftStmts -> (mkGroupByUsingStmt leftStmts $4 $6) }
-----------------------------------------------------------------------------
-- Parallel array expressions
(reverse (unLoc $1)) }
| texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | texp pquals { sL (comb2 $1 $>) $ mkHsDo PArrComp (reverse (unLoc $2)) $1 }
+ | texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 }
+
+-- We are reusing `lexps' and `flattenedpquals' from the list case.
--- We are reusing `lexps' and `pquals' from the list case.
+-----------------------------------------------------------------------------
+-- Guards
+
+guardquals :: { Located [LStmt RdrName] }
+ : guardquals1 { L (getLoc $1) (reverse (unLoc $1)) }
+
+guardquals1 :: { Located [LStmt RdrName] }
+ : guardquals1 ',' qual { LL ($3 : unLoc $1) }
+ | qual { L1 [$1] }
-----------------------------------------------------------------------------
-- Case alternatives
| gdpat { L1 [$1] }
gdpat :: { LGRHS RdrName }
- : '|' quals '->' exp { sL (comb2 $1 $>) $ GRHS (reverse (unLoc $2)) $4 }
+ : '|' guardquals '->' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
-- 'pat' recognises a pattern, including one with a bang at the top
-- e.g. "!x" or "!(x,y)" or "C a b" etc
| {- nothing -} { Nothing }
stmt :: { LStmt RdrName }
- : qual { $1 }
+ : qual { $1 }
| 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) }
qual :: { LStmt RdrName }
- : pat '<-' exp { LL $ mkBindStmt $1 $3 }
- | exp { L1 $ mkExprStmt $1 }
- | 'let' binds { LL $ LetStmt (unLoc $2) }
+ : pat '<-' exp { LL $ mkBindStmt $1 $3 }
+ | exp { L1 $ mkExprStmt $1 }
+ | 'let' binds { LL $ LetStmt (unLoc $2) }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
| '..' { ([], True) }
fbind :: { HsRecField RdrName (LHsExpr RdrName) }
- : qvar '=' exp { HsRecField $1 $3 False }
- | qvar { HsRecField $1 (L (getLoc $1) (HsVar (unLoc $1))) 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
dbinds :: { Located [LIPBind RdrName] }
- : dbinds ';' dbind { LL ($3 : unLoc $1) }
+ : dbinds ';' dbind { let { this = $3; rest = unLoc $1 }
+ in rest `seq` this `seq` LL (this : rest) }
| dbinds ';' { LL (unLoc $1) }
- | dbind { L1 [$1] }
+ | dbind { let this = $1 in this `seq` L1 [this] }
-- | {- empty -} { [] }
dbind :: { LIPBind RdrName }
: IPDUPVARID { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) }
-----------------------------------------------------------------------------
--- Deprecations
+-- Warnings and deprecations
-depreclist :: { Located [RdrName] }
-depreclist : deprec_var { L1 [unLoc $1] }
- | deprec_var ',' depreclist { LL (unLoc $1 : unLoc $3) }
+namelist :: { Located [RdrName] }
+namelist : name_var { L1 [unLoc $1] }
+ | name_var ',' namelist { LL (unLoc $1 : unLoc $3) }
-deprec_var :: { Located RdrName }
-deprec_var : var { $1 }
- | con { $1 }
+name_var :: { Located RdrName }
+name_var : var { $1 }
+ | con { $1 }
-----------------------------------------
-- Data constructors
| '(' consym ')' { LL (unLoc $2) }
| sysdcon { L1 $ nameRdrName (dataConName (unLoc $1)) }
+con_list :: { Located [Located RdrName] }
+con_list : con { L1 [$1] }
+ | con ',' con_list { LL ($1 : unLoc $3) }
+
sysdcon :: { Located DataCon } -- Wired in data constructors
: '(' ')' { LL unitDataCon }
- | '(' commas ')' { LL $ tupleCon Boxed $2 }
+ | '(' commas ')' { LL $ tupleCon Boxed ($2 + 1) }
+ | '(#' '#)' { LL $ unboxedSingletonDataCon }
+ | '(#' commas '#)' { LL $ tupleCon Unboxed ($2 + 1) }
| '[' ']' { LL nilDataCon }
conop :: { Located RdrName }
gtycon :: { Located RdrName } -- A "general" qualified tycon
: oqtycon { $1 }
| '(' ')' { LL $ getRdrName unitTyCon }
- | '(' commas ')' { LL $ getRdrName (tupleTyCon Boxed $2) }
+ | '(' commas ')' { LL $ getRdrName (tupleTyCon Boxed ($2 + 1)) }
+ | '(#' '#)' { LL $ getRdrName unboxedSingletonTyCon }
+ | '(#' commas '#)' { LL $ getRdrName (tupleTyCon Unboxed ($2 + 1)) }
| '(' '->' ')' { LL $ getRdrName funTyCon }
| '[' ']' { LL $ listTyCon_RDR }
| '[:' ':]' { LL $ parrTyCon_RDR }
qtycon :: { Located RdrName } -- Qualified or unqualified
: QCONID { L1 $! mkQual tcClsName (getQCONID $1) }
+ | PREFIXQCONSYM { L1 $! mkQual tcClsName (getPREFIXQCONSYM $1) }
| tycon { $1 }
tycon :: { Located RdrName } -- Unqualified
tyvarop :: { Located RdrName }
tyvarop : '`' tyvarid '`' { LL (unLoc $2) }
| tyvarsym { $1 }
+ | '.' {% parseErrorSDoc (getLoc $1)
+ (vcat [ptext (sLit "Illegal symbol '.' in type"),
+ ptext (sLit "Perhaps you intended -XRankNTypes or similar flag"),
+ ptext (sLit "to enable explicit-forall syntax: forall <tvs>. <type>")])
+ }
tyvarid :: { Located RdrName }
: VARID { L1 $! mkUnqual tvName (getVARID $1) }
| special_id { L1 $! mkUnqual tvName (unLoc $1) }
- | 'unsafe' { L1 $! mkUnqual tvName FSLIT("unsafe") }
- | 'safe' { L1 $! mkUnqual tvName FSLIT("safe") }
- | 'threadsafe' { L1 $! mkUnqual tvName FSLIT("threadsafe") }
+ | '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 }
-- Does not include "!", because that is used for strictness marks
qvarid :: { Located RdrName }
: varid { $1 }
- | QVARID { L1 $ mkQual varName (getQVARID $1) }
+ | QVARID { L1 $! mkQual varName (getQVARID $1) }
+ | PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) }
varid :: { Located RdrName }
- : varid_no_unsafe { $1 }
- | 'unsafe' { L1 $! mkUnqual varName FSLIT("unsafe") }
- | 'safe' { L1 $! mkUnqual varName FSLIT("safe") }
- | 'threadsafe' { L1 $! mkUnqual varName FSLIT("threadsafe") }
-
-varid_no_unsafe :: { Located RdrName }
: VARID { L1 $! mkUnqual varName (getVARID $1) }
| special_id { L1 $! mkUnqual varName (unLoc $1) }
- | 'forall' { L1 $! mkUnqual varName FSLIT("forall") }
- | 'family' { L1 $! mkUnqual varName FSLIT("family") }
+ | '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") }
qvarsym :: { Located RdrName }
: varsym { $1 }
varsym :: { Located RdrName }
: varsym_no_minus { $1 }
- | '-' { L1 $ mkUnqual varName FSLIT("-") }
+ | '-' { L1 $ mkUnqual varName (fsLit "-") }
varsym_no_minus :: { Located RdrName } -- varsym not including '-'
: VARSYM { L1 $ mkUnqual varName (getVARSYM $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
- : 'as' { L1 FSLIT("as") }
- | 'qualified' { L1 FSLIT("qualified") }
- | 'hiding' { L1 FSLIT("hiding") }
- | 'export' { L1 FSLIT("export") }
- | 'label' { L1 FSLIT("label") }
- | 'dynamic' { L1 FSLIT("dynamic") }
- | 'stdcall' { L1 FSLIT("stdcall") }
- | 'ccall' { L1 FSLIT("ccall") }
+ : 'as' { L1 (fsLit "as") }
+ | 'qualified' { L1 (fsLit "qualified") }
+ | 'hiding' { L1 (fsLit "hiding") }
+ | 'export' { L1 (fsLit "export") }
+ | 'label' { L1 (fsLit "label") }
+ | 'dynamic' { L1 (fsLit "dynamic") }
+ | 'stdcall' { L1 (fsLit "stdcall") }
+ | 'ccall' { L1 (fsLit "ccall") }
+ | 'prim' { L1 (fsLit "prim") }
+ | 'group' { L1 (fsLit "group") }
special_sym :: { Located FastString }
-special_sym : '!' { L1 FSLIT("!") }
- | '.' { L1 FSLIT(".") }
- | '*' { L1 FSLIT("*") }
+special_sym : '!' { L1 (fsLit "!") }
+ | '.' { L1 (fsLit ".") }
+ | '*' { L1 (fsLit "*") }
-----------------------------------------------------------------------------
-- Data constructors
qconid :: { Located RdrName } -- Qualified or unqualified
: conid { $1 }
- | QCONID { L1 $ mkQual dataName (getQCONID $1) }
+ | QCONID { L1 $! mkQual dataName (getQCONID $1) }
+ | PREFIXQCONSYM { L1 $! mkQual dataName (getPREFIXQCONSYM $1) }
conid :: { Located RdrName }
: CONID { L1 $ mkUnqual dataName (getCONID $1) }
: CHAR { L1 $ HsChar $ getCHAR $1 }
| STRING { L1 $ HsString $ getSTRING $1 }
| PRIMINTEGER { L1 $ HsIntPrim $ getPRIMINTEGER $1 }
+ | PRIMWORD { L1 $ HsWordPrim $ getPRIMWORD $1 }
| PRIMCHAR { L1 $ HsCharPrim $ getPRIMCHAR $1 }
| PRIMSTRING { L1 $ HsStringPrim $ getPRIMSTRING $1 }
| PRIMFLOAT { L1 $ HsFloatPrim $ getPRIMFLOAT $1 }
commas :: { Int }
: commas ',' { $1 + 1 }
- | ',' { 2 }
+ | ',' { 1 }
-----------------------------------------------------------------------------
-- Documentation comments
-docnext :: { LHsDoc RdrName }
- : DOCNEXT {% case parseHaddockParagraphs (tokenise (getDOCNEXT $1)) of {
- Left err -> parseError (getLoc $1) err;
- Right doc -> return (L1 doc) } }
+docnext :: { LHsDocString }
+ : DOCNEXT {% return (L1 (HsDocString (mkFastString (getDOCNEXT $1)))) }
-docprev :: { LHsDoc RdrName }
- : DOCPREV {% case parseHaddockParagraphs (tokenise (getDOCPREV $1)) of {
- Left err -> parseError (getLoc $1) err;
- Right doc -> return (L1 doc) } }
+docprev :: { LHsDocString }
+ : DOCPREV {% return (L1 (HsDocString (mkFastString (getDOCPREV $1)))) }
-docnamed :: { Located (String, (HsDoc RdrName)) }
+docnamed :: { Located (String, HsDocString) }
: DOCNAMED {%
let string = getDOCNAMED $1
(name, rest) = break isSpace string
- in case parseHaddockParagraphs (tokenise rest) of {
- Left err -> parseError (getLoc $1) err;
- Right doc -> return (L1 (name, doc)) } }
+ in return (L1 (name, HsDocString (mkFastString rest))) }
-docsection :: { Located (n, HsDoc RdrName) }
+docsection :: { Located (Int, HsDocString) }
: DOCSECTION {% let (n, doc) = getDOCSECTION $1 in
- case parseHaddockString (tokenise doc) of {
- Left err -> parseError (getLoc $1) err;
- Right doc -> return (L1 (n, doc)) } }
-
-docoptions :: { String }
- : DOCOPTIONS { getDOCOPTIONS $1 }
+ return (L1 (n, HsDocString (mkFastString doc))) }
-moduleheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
+moduleheader :: { Maybe LHsDocString }
: DOCNEXT {% let string = getDOCNEXT $1 in
- case parseModuleHeader string of {
- Right (str, info) ->
- case parseHaddockParagraphs (tokenise str) of {
- Left err -> parseError (getLoc $1) err;
- Right doc -> return (info, Just doc);
- };
- Left err -> parseError (getLoc $1) err
- } }
-
-maybe_docprev :: { Maybe (LHsDoc RdrName) }
+ return (Just (L1 (HsDocString (mkFastString string)))) }
+
+maybe_docprev :: { Maybe LHsDocString }
: docprev { Just $1 }
| {- empty -} { Nothing }
-maybe_docnext :: { Maybe (LHsDoc RdrName) }
+maybe_docnext :: { Maybe LHsDocString }
: docnext { Just $1 }
| {- empty -} { Nothing }
getQCONID (L _ (ITqconid x)) = x
getQVARSYM (L _ (ITqvarsym x)) = x
getQCONSYM (L _ (ITqconsym x)) = x
+getPREFIXQVARSYM (L _ (ITprefixqvarsym x)) = x
+getPREFIXQCONSYM (L _ (ITprefixqconsym x)) = x
getIPDUPVARID (L _ (ITdupipvarid x)) = x
getCHAR (L _ (ITchar x)) = x
getSTRING (L _ (ITstring x)) = x
getPRIMCHAR (L _ (ITprimchar x)) = x
getPRIMSTRING (L _ (ITprimstring x)) = x
getPRIMINTEGER (L _ (ITprimint x)) = x
+getPRIMWORD (L _ (ITprimword x)) = x
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
+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
getDOCNAMED (L _ (ITdocCommentNamed x)) = x
getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
-getDOCOPTIONS (L _ (ITdocOptions x)) = x
+
+getSCC :: Located Token -> P FastString
+getSCC lt = do let s = getSTRING lt
+ err = "Spaces are not allowed in SCCs"
+ -- We probably actually want to be more restrictive than this
+ if ' ' `elem` unpackFS s
+ then failSpanMsgP (getLoc lt) (text err)
+ else return s
-- Utilities for combining source spans
comb2 :: Located a -> Located b -> SrcSpan
-comb2 = combineLocs
+comb2 a b = a `seq` b `seq` combineLocs a b
comb3 :: Located a -> Located b -> Located c -> SrcSpan
-comb3 a b c = combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
+comb3 a b c = a `seq` b `seq` c `seq`
+ combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
-comb4 a b c d = combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
- combineSrcSpans (getLoc c) (getLoc d)
+comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
+ (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $
+ combineSrcSpans (getLoc c) (getLoc d))
-- strict constructor version:
{-# INLINE sL #-}
sL :: SrcSpan -> a -> Located a
-sL span a = span `seq` L span a
+sL span a = span `seq` a `seq` L span a
-- 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
fileSrcSpan :: P SrcSpan
fileSrcSpan = do
l <- getSrcLoc;
- let loc = mkSrcLoc (srcLocFile l) 1 0;
+ let loc = mkSrcLoc (srcLocFile l) 1 1;
return (mkSrcSpan loc loc)
}
projects / ghc-hetmet.git / blobdiff