-- ---------------------------------------------------------------------------
{
+{-# OPTIONS -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
+
module Parser ( parseModule, parseStmt, parseIdentifier, parseType,
parseHeader ) where
import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
Activation(..), defaultInlineSpec )
+import DynFlags
import OrdList
import HaddockParse
import {-# SOURCE #-} HaddockLex hiding ( Token )
'data' { L _ ITdata }
'default' { L _ ITdefault }
'deriving' { L _ ITderiving }
- 'derive' { L _ ITderive }
'do' { L _ ITdo }
'else' { L _ ITelse }
'hiding' { L _ IThiding }
DOCPREV { L _ (ITdocCommentPrev _) }
DOCNAMED { L _ (ITdocCommentNamed _) }
DOCSECTION { L _ (ITdocSection _ _) }
- DOCOPTIONS { L _ (ITdocOptions _) }
-- Template Haskell
'[|' { L _ ITopenExpQuote }
| 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 maybemoddeprec maybeexports 'where' body
+ {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
+ return (L loc (HsModule (Just $3) $5 (fst $7) (snd $7) $4
+ info doc) )}}
| body2
{% fileSrcSpan >>= \ loc ->
- return (L loc (HsModule Nothing Nothing
- (fst $1) (snd $1) Nothing Nothing emptyHaddockModInfo
+ return (L loc (HsModule Nothing Nothing
+ (fst $1) (snd $1) Nothing emptyHaddockModInfo
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 :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
+ : moduleheader { (fst $1, snd $1) }
+ | {- empty -} { (emptyHaddockModInfo, Nothing) }
missing_module_keyword :: { () }
: {- empty -} {% pushCurrentContext }
-- 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 maybemoddeprec maybeexports 'where' header_body
+ {% fileSrcSpan >>= \ loc -> case $1 of { (info, doc) ->
+ return (L loc (HsModule (Just $3) $5 $7 [] $4
+ info doc))}}
| 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
+ emptyHaddockModInfo Nothing)) }
header_body :: { [LImportDecl RdrName] }
: '{' importdecls { $2 }
(unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
-- data/newtype family
- | data_or_newtype 'family' tycl_hdr opt_kind_sig
+ | '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
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $4)
- (TyFamily (DataFamily (unLoc $1)) tc tvs
- (unLoc $4)) } }
+ (TyFamily DataFamily tc tvs (unLoc $4)) } }
-- data/newtype instance declaration
| data_or_newtype 'instance' tycl_hdr constrs deriving
} }
-- data/newtype family declaration
- | data_or_newtype tycl_hdr opt_kind_sig
+ | '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
"A family declaration cannot have a context"
; return $
L (comb3 $1 $2 $3)
- (TyFamily (DataFamily (unLoc $1)) tc tvs
- (unLoc $3))
+ (TyFamily DataFamily tc tvs (unLoc $3))
} }
-- Associate type instances
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl RdrName }
- : 'derive' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) }
+ : 'deriving' 'instance' inst_type {% checkDerivDecl (LL (DerivDecl $3)) }
-----------------------------------------------------------------------------
-- Nested declarations
ctypedoc :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ctypedoc { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 }
- | context '=>' gentypedoc { LL $ mkImplicitHsForAllTy $1 $3 }
+ | context '=>' ctypedoc { LL $ mkImplicitHsForAllTy $1 $3 }
-- A type of form (context => type) is an *implicit* HsForAllTy
| gentypedoc { $1 }
: 'forall' tv_bndrs '.' { LL $2 }
| {- empty -} { noLoc [] }
-constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
+constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
-- We parse the constructor declaration
-- C t1 t2
-- as a btype (treating C as a type constructor) and then convert C to be
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL }
| btype conop btype { LL ($2, InfixCon $1 $3) }
-constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
+constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) }
: oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
| 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 }
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
- | '-' fexp { LL $ mkHsNegApp $2 }
+ | '-' fexp { LL $ NegApp $2 noSyntaxExpr }
| 'do' stmtlist {% let loc = comb2 $1 $2 in
checkDo loc (unLoc $2) >>= \ (stmts,body) ->
| fexp { $1 }
scc_annot :: { Located FastString }
- : '_scc_' STRING { LL $ getSTRING $2 }
+ : '_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 }
hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
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;
- return (LL r) }}
+ : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3
+ ; return (LL r) }}
| aexp2 { $1 }
-- Here was the syntax for type applications that I was planning
| 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) }
+-- | 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 Haskell98
+ -- (you'd have to write '((+ 3), (4 -))')
+ -- but the less cluttered version fell out of having texps.
+ | '(' texp ')' { LL (HsPar $2) }
| '(' texp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed }
| '(#' texps '#)' { LL $ ExplicitTuple (reverse $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
: {- empty -} { [] }
| cvtopdecls { $1 }
+-- 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
+ -- 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 }
+ | qopm infixexp { LL $ SectionR $1 $2 }
+ -- view patterns get parenthesized above
+ | exp '->' exp { LL $ EViewPat $1 $3 }
texps :: { [LHsExpr RdrName] }
: texps ',' texp { $3 : $1 }
-- Bangs inside are parsed as infix operator applications, so that
-- we parse them right when bang-patterns are off
pat :: { LPat RdrName }
-pat : infixexp {% checkPattern $1 }
+pat : exp {% checkPattern $1 }
| '!' aexp {% checkPattern (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
apat :: { LPat RdrName }
stmt :: { LStmt RdrName }
: qual { $1 }
--- What is this next production doing? I have no clue! SLPJ Dec06
- | infixexp '->' exp {% checkPattern $3 >>= \p ->
- return (LL $ mkBindStmt p $1) }
| 'rec' stmtlist { LL $ mkRecStmt (unLoc $2) }
qual :: { LStmt RdrName }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
-fbinds :: { HsRecordBinds RdrName }
- : fbinds1 { HsRecordBinds (reverse $1) }
- | {- empty -} { HsRecordBinds [] }
+fbinds :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
+ : fbinds1 { $1 }
+ | {- empty -} { ([], False) }
-fbinds1 :: { [(Located id, LHsExpr id)] }
- : fbinds1 ',' fbind { $3 : $1 }
- | fbind { [$1] }
+fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
+ : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) }
+ | fbind { ([$1], False) }
+ | '..' { ([], True) }
-fbind :: { (Located RdrName, LHsExpr RdrName) }
- : qvar '=' exp { ($1,$3) }
+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
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
: 'as' { L1 FSLIT("as") }
| 'qualified' { L1 FSLIT("qualified") }
| 'hiding' { L1 FSLIT("hiding") }
- | 'derive' { L1 FSLIT("derive") }
| 'export' { L1 FSLIT("export") }
| 'label' { L1 FSLIT("label") }
| 'dynamic' { L1 FSLIT("dynamic") }
docnext :: { LHsDoc RdrName }
: DOCNEXT {% case parseHaddockParagraphs (tokenise (getDOCNEXT $1)) of {
- Left err -> parseError (getLoc $1) err;
- Right doc -> return (L1 doc) } }
+ MyLeft err -> parseError (getLoc $1) err;
+ MyRight doc -> return (L1 doc) } }
docprev :: { LHsDoc RdrName }
: DOCPREV {% case parseHaddockParagraphs (tokenise (getDOCPREV $1)) of {
- Left err -> parseError (getLoc $1) err;
- Right doc -> return (L1 doc) } }
+ MyLeft err -> parseError (getLoc $1) err;
+ MyRight doc -> return (L1 doc) } }
docnamed :: { Located (String, (HsDoc RdrName)) }
: 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)) } }
+ MyLeft err -> parseError (getLoc $1) err;
+ MyRight doc -> return (L1 (name, doc)) } }
docsection :: { Located (n, HsDoc RdrName) }
: 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 }
+ MyLeft err -> parseError (getLoc $1) err;
+ MyRight doc -> return (L1 (n, doc)) } }
moduleheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
: 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);
+ MyLeft err -> parseError (getLoc $1) err;
+ MyRight doc -> return (info, Just doc);
};
Left err -> parseError (getLoc $1) err
} }
getDOCPREV (L _ (ITdocCommentPrev x)) = x
getDOCNAMED (L _ (ITdocCommentNamed x)) = x
getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
-getDOCOPTIONS (L _ (ITdocOptions x)) = x
-- Utilities for combining source spans
comb2 :: Located a -> Located b -> SrcSpan