X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=24d8d1be58c33dafa93963dc6a0f7dbe0e324fb4;hb=cc7fd02d59c5b15f2aee8f3a420d3f6ee3048096;hp=9f3dd27bdafdaa3dac86353f7b8e4b8e60f51785;hpb=21c5c9c09a8d36b4ae8a83b17b543c332bc9cb0c;p=ghc-hetmet.git diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 9f3dd27..24d8d1b 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -51,8 +51,6 @@ import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), Activation(..), RuleMatchInfo(..), defaultInlineSpec ) import DynFlags import OrdList -import HaddockParse -import {-# SOURCE #-} HaddockLex hiding ( Token ) import HaddockUtils import FastString @@ -264,9 +262,9 @@ incorrect. '{-# SCC' { L _ ITscc_prag } '{-# GENERATED' { L _ ITgenerated_prag } '{-# DEPRECATED' { L _ ITdeprecated_prag } - '{-# WARNING' { L _ ITwarning_prag } + '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } - '{-# ANN' { L _ ITann_prag } + '{-# ANN' { L _ ITann_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -382,18 +380,18 @@ identifier :: { Located RdrName } module :: { Located (HsModule RdrName) } : 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) )}} + {% 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 emptyHaddockModInfo - Nothing)) } + (fst $1) (snd $1) Nothing Nothing + )) } -maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) } +maybedocheader :: { Maybe LHsDocString } : moduleheader { $1 } - | {- empty -} { (emptyHaddockModInfo, Nothing) } + | {- empty -} { Nothing } missing_module_keyword :: { () } : {- empty -} {% pushCurrentContext } @@ -424,13 +422,13 @@ cvtopdecls :: { [LHsDecl RdrName] } header :: { Located (HsModule RdrName) } : 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))}} + {% 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 - emptyHaddockModInfo Nothing)) } + Nothing)) } header_body :: { [LImportDecl RdrName] } : '{' importdecls { $2 } @@ -561,17 +559,17 @@ topdecl :: { OrdList (LHsDecl RdrName) } | 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 } - | '{-# WARNING' warnings '#-}' { $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 -- @@ -613,10 +611,10 @@ ty_decl :: { LTyClDecl RdrName } -- ordinary GADT declaration | data_or_newtype tycl_hdr opt_kind_sig - 'where' gadt_constrlist + gadt_constrlist deriving {% mkTyData (comb4 $1 $2 $4 $5) (unLoc $1) False $2 - (unLoc $3) (reverse (unLoc $5)) (unLoc $6) } + (unLoc $3) (unLoc $4) (unLoc $5) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty @@ -631,10 +629,10 @@ ty_decl :: { LTyClDecl RdrName } -- GADT instance declaration | data_or_newtype 'instance' tycl_hdr opt_kind_sig - 'where' gadt_constrlist + gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $6 $7) (unLoc $1) True $3 - (unLoc $4) (reverse (unLoc $6)) (unLoc $7) } + {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) True $3 + (unLoc $4) (unLoc $5) (unLoc $6) } -- Associated type family declarations -- @@ -678,10 +676,10 @@ at_decl_inst :: { LTyClDecl RdrName } -- GADT instance declaration | data_or_newtype tycl_hdr opt_kind_sig - 'where' gadt_constrlist + gadt_constrlist deriving - {% mkTyData (comb4 $1 $2 $5 $6) (unLoc $1) True $2 - (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 } @@ -983,7 +981,7 @@ context :: { LHsContext RdrName } type :: { LHsType RdrName } : btype { $1 } - | btype qtyconop type { 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) } @@ -1081,14 +1079,15 @@ akind :: { Located Kind } ----------------------------------------------------------------------------- -- 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 { sL (comb2 $1 (head $3)) ($3 ++ unLoc $1) } - | gadt_constrs ';' { $1 } - | gadt_constr { sL (getLoc (head $1)) $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 @@ -1096,7 +1095,7 @@ gadt_constrs :: { Located [LConDecl RdrName] } -- D { x,y :: a } :: T a -- forall a. Eq a => D { x,y :: a } :: T a -gadt_constr :: { [LConDecl RdrName] } +gadt_constr :: { [LConDecl RdrName] } -- Returns a list because of: C,D :: ty : con_list '::' sigtype { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } @@ -1106,8 +1105,7 @@ gadt_constr :: { [LConDecl RdrName] } ; 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) } @@ -1192,7 +1190,7 @@ deriving :: { Located (Maybe [LHsType RdrName]) } 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) } @@ -1926,46 +1924,31 @@ commas :: { Int } ----------------------------------------------------------------------------- -- Documentation comments -docnext :: { LHsDoc RdrName } - : DOCNEXT {% case parseHaddockParagraphs (tokenise (getDOCNEXT $1)) of { - MyLeft err -> parseError (getLoc $1) err; - MyRight doc -> return (L1 doc) } } +docnext :: { LHsDocString } + : DOCNEXT {% return (L1 (HsDocString (mkFastString (getDOCNEXT $1)))) } -docprev :: { LHsDoc RdrName } - : DOCPREV {% case parseHaddockParagraphs (tokenise (getDOCPREV $1)) of { - MyLeft err -> parseError (getLoc $1) err; - MyRight 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 { - MyLeft err -> parseError (getLoc $1) err; - MyRight doc -> return (L1 (name, doc)) } } + in return (L1 (name, HsDocString (mkFastString rest))) } -docsection :: { Located (Int, HsDoc RdrName) } +docsection :: { Located (Int, HsDocString) } : DOCSECTION {% let (n, doc) = getDOCSECTION $1 in - case parseHaddockString (tokenise doc) of { - MyLeft err -> parseError (getLoc $1) err; - MyRight doc -> return (L1 (n, doc)) } } + 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 { - MyLeft err -> parseError (getLoc $1) err; - MyRight 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 }