X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FParser.y.pp;h=c56b0c10018d3a1c86cee526828810d821b904e8;hp=6712f4ed8f020b0b8fe04cce8c010bf4edc338f3;hb=26f164e5759e9eca73deb0531ddec422d36a6924;hpb=1fede4bc9501744bf2269ce2a4cb9fb735969caa diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 6712f4e..c56b0c1 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -45,14 +45,13 @@ import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, mkSrcLoc, mkSrcSpan ) import Module import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) -import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind ) +import Type ( Kind, liftedTypeKind, unliftedTypeKind ) +import Coercion ( mkArrowKind ) import Class ( FunDep ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), RuleMatchInfo(..), defaultInlineSpec ) + Activation(..), RuleMatchInfo(..), defaultInlinePragma ) import DynFlags import OrdList -import HaddockParse -import {-# SOURCE #-} HaddockLex hiding ( Token ) import HaddockUtils import FastString @@ -264,9 +263,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,25 +381,25 @@ 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 } maybemodwarning :: { Maybe WarningTxt } - : '{-# DEPRECATED' STRING '#-}' { Just (DeprecatedTxt (getSTRING $2)) } - | '{-# WARNING' STRING '#-}' { Just (WarningTxt (getSTRING $2)) } + : '{-# DEPRECATED' strings '#-}' { Just (DeprecatedTxt $ unLoc $2) } + | '{-# WARNING' strings '#-}' { Just (WarningTxt $ unLoc $2) } | {- empty -} { Nothing } body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } @@ -424,13 +423,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 +560,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 +612,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 +630,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 +677,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 } @@ -707,7 +706,7 @@ tycl_hdr :: { Located (LHsContext RdrName, LHsType RdrName) } -- 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 @@ -839,8 +838,8 @@ warnings :: { OrdList (LHsDecl RdrName) } -- SUP: TEMPORARY HACK, not checking for `module Foo' warning :: { OrdList (LHsDecl RdrName) } - : namelist STRING - { toOL [ LL $ WarningD (Warning n (WarningTxt (getSTRING $2))) + : namelist strings + { toOL [ LL $ WarningD (Warning n (WarningTxt $ unLoc $2)) | n <- unLoc $1 ] } deprecations :: { OrdList (LHsDecl RdrName) } @@ -851,10 +850,18 @@ deprecations :: { OrdList (LHsDecl RdrName) } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { OrdList (LHsDecl RdrName) } - : namelist STRING - { toOL [ LL $ WarningD (Warning n (DeprecatedTxt (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 } @@ -975,7 +982,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) } @@ -1006,10 +1013,12 @@ atype :: { LHsType RdrName } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } + | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } | '$(' 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)) } @@ -1073,14 +1082,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 @@ -1088,7 +1098,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) } @@ -1098,8 +1108,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) } @@ -1161,7 +1170,9 @@ deriving :: { Located (Maybe [LHsType RdrName]) } ----------------------------------------------------------------------------- -- 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 '='. @@ -1184,7 +1195,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) } @@ -1213,30 +1224,35 @@ gdrh :: { LGRHS RdrName } : '|' 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 FunLike (getINLINE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 FunLike (getINLINE $1)))) } | '{-# INLINE_CONLIKE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) } | '{-# 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 FunLike (getSPEC_INLINE $1))) + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1))) | 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 } @@ -1351,11 +1367,7 @@ aexp2 :: { LHsExpr RdrName } (getTH_ID_SPLICE $1)))) } -- $x | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp ) - | TH_QUASIQUOTE { let { loc = getLoc $1 - ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 - ; quoterId = mkUnqual varName quoter - } - in sL loc $ HsQuasiQuoteE (mkHsQuasiQuote quoterId quoteSpan quote) } + | TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) } | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) } | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) } @@ -1364,8 +1376,8 @@ aexp2 :: { LHsExpr RdrName } | '[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) } @@ -1409,7 +1421,7 @@ texp :: { LHsExpr RdrName } | qopm infixexp { LL $ SectionR $1 $2 } -- View patterns get parenthesized above - | exp '->' exp { LL $ EViewPat $1 $3 } + | exp '->' texp { LL $ EViewPat $1 $3 } -- Always at least one comma tup_exprs :: { [HsTupArg RdrName] } @@ -1450,35 +1462,27 @@ lexps :: { Located [LHsExpr RdrName] } flattenedpquals :: { Located [LStmt RdrName] } : pquals { case (unLoc $1) of - ParStmt [(qs, _)] -> L1 qs + [qs] -> L1 qs -- We just had one thing in our "parallel" list so -- we simply return that thing directly - _ -> L1 [$1] + qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]] -- We actually found some actual parallel lists so - -- we leave them into as a ParStmt + -- we wrap them into as a ParStmt } -pquals :: { LStmt RdrName } - : pquals1 { L1 (ParStmt [(qs, undefined) | qs <- (reverse (unLoc $1))]) } - -pquals1 :: { Located [[LStmt RdrName]] } - : pquals1 '|' squals { LL (unLoc $3 : unLoc $1) } - | squals { L (getLoc $1) [unLoc $1] } +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] } - : squals1 { L (getLoc $1) (reverse (unLoc $1)) } - -squals1 :: { Located [LStmt RdrName] } - : transformquals1 { LL (unLoc $1) } - -transformquals1 :: { Located [LStmt RdrName] } - : transformquals1 ',' transformqual { LL $ [LL ((unLoc $3) (unLoc $1))] } - | transformquals1 ',' qual { LL ($3 : unLoc $1) } --- | transformquals1 ',' '{|' pquals '|}' { LL ($4 : unLoc $1) } - | transformqual { LL $ [LL ((unLoc $1) [])] } - | qual { L1 [$1] } --- | '{|' pquals '|}' { L1 [$2] } +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 {| |} @@ -1487,11 +1491,22 @@ transformquals1 :: { Located [LStmt RdrName] } -- a program that makes use of this temporary syntax you must supply that flag to GHC transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } - : 'then' exp { LL $ \leftStmts -> (mkTransformStmt (reverse leftStmts) $2) } - | 'then' exp 'by' exp { LL $ \leftStmts -> (mkTransformByStmt (reverse leftStmts) $2 $4) } - | 'then' 'group' 'by' exp { LL $ \leftStmts -> (mkGroupByStmt (reverse leftStmts) $4) } - | 'then' 'group' 'using' exp { LL $ \leftStmts -> (mkGroupUsingStmt (reverse leftStmts) $4) } - | 'then' 'group' 'by' exp 'using' exp { LL $ \leftStmts -> (mkGroupByUsingStmt (reverse leftStmts) $4 $6) } + -- 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 @@ -1621,7 +1636,7 @@ fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } fbind :: { HsRecField RdrName (LHsExpr RdrName) } : qvar '=' exp { HsRecField $1 $3 False } - | qvar { HsRecField $1 (L (getLoc $1) (HsVar (unLoc $1))) True } + | qvar { HsRecField $1 (L (getLoc $1) placeHolderPunRhs) 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 @@ -1841,6 +1856,7 @@ special_id | 'stdcall' { L1 (fsLit "stdcall") } | 'ccall' { L1 (fsLit "ccall") } | 'prim' { L1 (fsLit "prim") } + | 'group' { L1 (fsLit "group") } special_sym :: { Located FastString } special_sym : '!' { L1 (fsLit "!") } @@ -1907,46 +1923,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 } @@ -2017,6 +2018,6 @@ sL span a = span `seq` a `seq` L span a 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) }