-- ---------------------------------------------------------------------------
{
-{-# OPTIONS -w #-}
+{-# 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
import HsSyn
import RdrHsSyn
-import HscTypes ( IsBootInterface, DeprecTxt )
+import HscTypes ( IsBootInterface, WarningTxt(..) )
import Lexer
import RdrName
import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon,
import Module
import StaticFlags ( opt_SccProfilingOn, opt_Hpc )
import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
+import Class ( FunDep )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- Activation(..), defaultInlineSpec )
+ Activation(..), RuleMatchInfo(..), defaultInlineSpec )
import DynFlags
import OrdList
import HaddockParse
'label' { L _ ITlabel }
'dynamic' { L _ ITdynamic }
'safe' { L _ ITsafe }
- 'threadsafe' { L _ ITthreadsafe }
+ 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias
'unsafe' { L _ ITunsafe }
'mdo' { L _ ITmdo }
'family' { L _ ITfamily }
'stdcall' { L _ ITstdcallconv }
'ccall' { L _ ITccallconv }
+ 'prim' { L _ ITprimcallconv }
'dotnet' { L _ ITdotnet }
'proc' { L _ ITproc } -- for arrow notation extension
'rec' { L _ ITrec } -- for arrow notation extension
'using' { L _ ITusing } -- for list transform extension
'{-# INLINE' { L _ (ITinline_prag _) }
+ '{-# INLINE_CONLIKE' { L _ (ITinline_conlike_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
-- know what they are doing. :-)
module :: { Located (HsModule RdrName) }
- : maybedocheader 'module' modid maybemoddeprec maybeexports 'where' body
+ : maybedocheader 'module' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
info doc) )}}
missing_module_keyword :: { () }
: {- empty -} {% pushCurrentContext }
-maybemoddeprec :: { Maybe DeprecTxt }
- : '{-# DEPRECATED' STRING '#-}' { Just (getSTRING $2) }
- | {- empty -} { Nothing }
+maybemodwarning :: { Maybe WarningTxt }
+ : '{-# DEPRECATED' STRING '#-}' { Just (DeprecatedTxt (getSTRING $2)) }
+ | '{-# WARNING' STRING '#-}' { Just (WarningTxt (getSTRING $2)) }
+ | {- empty -} { Nothing }
body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) }
: '{' top '}' { $2 }
-- Module declaration & imports only
header :: { Located (HsModule RdrName) }
- : maybedocheader 'module' modid maybemoddeprec maybeexports 'where' header_body
+ : maybedocheader 'module' modid maybemodwarning maybeexports 'where' header_body
{% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
return (L loc (HsModule (Just $3) $5 $7 [] $4
info doc))}}
| {- 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
-- 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
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) (reverse (unLoc $5)) (unLoc $6) }
+ -- 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
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 $6 $7) (unLoc $1) True $3
+ (unLoc $4) (reverse (unLoc $6)) (unLoc $7) }
+
+-- 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
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 $5 $6) (unLoc $1) True $2
+ (unLoc $3) (reverse (unLoc $5)) (unLoc $6) }
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 (LHsContext RdrName, LHsType RdrName) }
+ : context '=>' type { LL ($1, $3) }
+ | type { L1 (noLoc [], $1) }
-----------------------------------------------------------------------------
-- Stand-alone deriving
| '(' 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 STRING
+ { toOL [ LL $ WarningD (Warning n (WarningTxt (getSTRING $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 STRING
+ { toOL [ LL $ WarningD (Warning n (DeprecatedTxt (getSTRING $2)))
| n <- unLoc $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
callconv :: { CallConv }
: 'stdcall' { CCall StdCallConv }
| 'ccall' { CCall CCallConv }
+ | 'prim' { CCall PrimCallConv}
| 'dotnet' { DNCall }
safety :: { Safety }
: 'unsafe' { PlayRisky }
| 'safe' { PlaySafe False }
- | 'threadsafe' { PlaySafe True }
+ | '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 '=>' ctypedoc { 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 }
-- 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) }
+ | '$(' 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)) }
| '(' 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)) }
| vocurly gadt_constrs close { $2 }
gadt_constrs :: { Located [LConDecl RdrName] }
- : gadt_constrs ';' gadt_constr { LL ($3 : unLoc $1) }
+ : gadt_constrs ';' gadt_constr { sL (comb2 $1 (head $3)) ($3 ++ unLoc $1) }
| gadt_constrs ';' { $1 }
- | gadt_constr { L1 [$1] }
+ | gadt_constr { sL (getLoc (head $1)) $1 }
-- 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] }
+ : 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 [] }
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).
| 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 (mkInlineSpec $2 FunLike (getINLINE $1)))) }
+ | '{-# INLINE_CONLIKE' activation qvar '#-}'
+ { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) }
| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
{ 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)))
+ { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1)))
| t <- $5] }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{ LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
| fexp { $1 }
scc_annot :: { Located FastString }
- : '_scc_' STRING {% (addWarning Opt_WarnDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
+ : '_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 }
-- 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 }
: {- empty -} { [] }
| cvtopdecls { $1 }
--- tuple expressions: things that can appear unparenthesized as long as they're
+-- "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 }
- -- Technically, this should only be used for bang patterns,
- -- but we can be a little more liberal here and avoid parens
- -- inside tuples
- | infixexp qop { LL $ SectionL $1 $2 }
+
+ -- 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
+ -- 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
+
+ -- View patterns get parenthesized above
| exp '->' exp { LL $ EViewPat $1 $3 }
texps :: { [LHsExpr 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 }
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) }
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 }
+ : VARID { L1 $! mkUnqual varName (getVARID $1) }
+ | special_id { L1 $! mkUnqual varName (unLoc $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") }
| 'dynamic' { L1 (fsLit "dynamic") }
| 'stdcall' { L1 (fsLit "stdcall") }
| 'ccall' { L1 (fsLit "ccall") }
+ | 'prim' { L1 (fsLit "prim") }
special_sym :: { Located FastString }
special_sym : '!' { L1 (fsLit "!") }
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) }
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
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
getDOCNEXT (L _ (ITdocCommentNext x)) = x
projects / ghc-hetmet.git / blobdiff