diff options
Diffstat (limited to 'compiler/parser/Parser.y.pp')
| -rw-r--r-- | compiler/parser/Parser.y.pp | 78 |
1 files changed, 64 insertions, 14 deletions
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 4f4ec0b123..72dfc88fa6 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -16,8 +16,25 @@ -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module Parser ( parseModule, parseStmt, parseIdentifier, parseType, - parseHeader ) where +-- | This module provides the generated Happy parser for Haskell. It exports +-- a number of parsers which may be used in any library that uses the GHC API. +-- A common usage pattern is to initialize the parser state with a given string +-- and then parse that string: +-- +-- @ +-- runParser :: DynFlags -> String -> P a -> ParseResult a +-- runParser flags str parser = unP parser parseState +-- where +-- filename = "\<interactive\>" +-- location = mkRealSrcLoc (mkFastString filename) 1 1 +-- buffer = stringToStringBuffer str +-- parseState = mkPState flags buffer location in +-- @ +module Parser (parseModule, parseImport, parseStatement, + parseDeclaration, parseExpression, parseTypeSignature, + parseFullStmt, parseStmt, parseIdentifier, + parseType, parseHeader) where + import HsSyn import RdrHsSyn @@ -269,6 +286,10 @@ incorrect. '{-# NOVECTORISE' { L _ ITnovect_prag } '{-# MINIMAL' { L _ ITminimal_prag } '{-# CTYPE' { L _ ITctype } + '{-# OVERLAPPING' { L _ IToverlapping_prag } + '{-# OVERLAPPABLE' { L _ IToverlappable_prag } + '{-# OVERLAPS' { L _ IToverlaps_prag } + '{-# INCOHERENT' { L _ ITincoherent_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -360,12 +381,20 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } %monad { P } { >>= } { return } %lexer { lexer } { L _ ITeof } +%tokentype { (Located Token) } + +-- Exported parsers %name parseModule module +%name parseImport importdecl +%name parseStatement stmt +%name parseDeclaration topdecl +%name parseExpression exp +%name parseTypeSignature sigdecl +%name parseFullStmt stmt %name parseStmt maybe_stmt %name parseIdentifier identifier %name parseType ctype %partial parseHeader header -%tokentype { (Located Token) } %% ----------------------------------------------------------------------------- @@ -654,12 +683,13 @@ ty_decl :: { LTyClDecl RdrName } {% mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) } inst_decl :: { LInstDecl RdrName } - : 'instance' inst_type where_inst - { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $3) in - let cid = ClsInstDecl { cid_poly_ty = $2, cid_binds = binds + : 'instance' overlap_pragma inst_type where_inst + { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $4) in + let cid = ClsInstDecl { cid_poly_ty = $3, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = $2 , cid_datafam_insts = adts } - in L (comb3 $1 $2 $3) (ClsInstD { cid_inst = cid }) } + in L (comb3 $1 $3 $4) (ClsInstD { cid_inst = cid }) } -- type instance declarations | 'type' 'instance' ty_fam_inst_eqn @@ -677,6 +707,14 @@ inst_decl :: { LInstDecl RdrName } {% mkDataFamInst (comb4 $1 $4 $6 $7) (unLoc $1) $3 $4 (unLoc $5) (unLoc $6) (unLoc $7) } +overlap_pragma :: { Maybe OverlapMode } + : '{-# OVERLAPPABLE' '#-}' { Just Overlappable } + | '{-# OVERLAPPING' '#-}' { Just Overlapping } + | '{-# OVERLAPS' '#-}' { Just Overlaps } + | '{-# INCOHERENT' '#-}' { Just Incoherent } + | {- empty -} { Nothing } + + -- Closed type families where_type_family :: { Located (FamilyInfo RdrName) } @@ -783,7 +821,7 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTR -- Glasgow extension: stand-alone deriving declarations stand_alone_deriving :: { LDerivDecl RdrName } - : 'deriving' 'instance' inst_type { LL (DerivDecl $3) } + : 'deriving' 'instance' overlap_pragma inst_type { LL (DerivDecl $4 $3) } ----------------------------------------------------------------------------- -- Role annotations @@ -810,17 +848,29 @@ role : VARID { L1 $ Just $ getVARID $1 } -- Glasgow extension: pattern synonyms pattern_synonym_decl :: { LHsDecl RdrName } - : 'pattern' con vars0 patsyn_token pat { LL . ValD $ mkPatSynBind $2 (PrefixPatSyn $3) $5 $4 } - | 'pattern' varid conop varid patsyn_token pat { LL . ValD $ mkPatSynBind $3 (InfixPatSyn $2 $4) $6 $5 } + : 'pattern' pat '=' pat + {% do { (name, args) <- splitPatSyn $2 + ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional + }} + | 'pattern' pat '<-' pat + {% do { (name, args) <- splitPatSyn $2 + ; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional + }} + | 'pattern' pat '<-' pat where_decls + {% do { (name, args) <- splitPatSyn $2 + ; mg <- toPatSynMatchGroup name $5 + ; return $ LL . ValD $ + mkPatSynBind name args $4 (ExplicitBidirectional mg) + }} + +where_decls :: { Located (OrdList (LHsDecl RdrName)) } + : 'where' '{' decls '}' { $3 } + | 'where' vocurly decls close { $3 } vars0 :: { [Located RdrName] } : {- empty -} { [] } | varid vars0 { $1 : $2 } -patsyn_token :: { HsPatSynDir RdrName } - : '<-' { Unidirectional } - | '=' { ImplicitBidirectional } - ----------------------------------------------------------------------------- -- Nested declarations |