diff options
Diffstat (limited to 'compiler/parser')
| -rw-r--r-- | compiler/parser/HaddockUtils.hs | 8 | ||||
| -rw-r--r-- | compiler/parser/Parser.y | 204 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 94 |
3 files changed, 167 insertions, 139 deletions
diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs index bf22cd77c1..387cbf8f08 100644 --- a/compiler/parser/HaddockUtils.hs +++ b/compiler/parser/HaddockUtils.hs @@ -9,13 +9,15 @@ import Control.Monad -- ----------------------------------------------------------------------------- -- Adding documentation to record fields (used in parsing). -addFieldDoc :: ConDeclField a -> Maybe LHsDocString -> ConDeclField a -addFieldDoc fld doc = fld { cd_fld_doc = cd_fld_doc fld `mplus` doc } +addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a +addFieldDoc (L l fld) doc + = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }) -addFieldDocs :: [ConDeclField a] -> Maybe LHsDocString -> [ConDeclField a] +addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a] addFieldDocs [] _ = [] addFieldDocs (x:xs) doc = addFieldDoc x doc : xs + addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a addConDoc decl Nothing = decl addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 4117d06930..30cd5525a1 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -452,9 +452,11 @@ maybedocheader :: { Maybe LHsDocString } missing_module_keyword :: { () } : {- empty -} {% pushCurrentContext } -maybemodwarning :: { Maybe WarningTxt } - : '{-# DEPRECATED' strings '#-}' { Just (DeprecatedTxt $ unLoc $2) } - | '{-# WARNING' strings '#-}' { Just (WarningTxt $ unLoc $2) } +maybemodwarning :: { Maybe (Located WarningTxt) } + : '{-# DEPRECATED' strings '#-}' { Just (sLL $1 $> $ + DeprecatedTxt $ unLoc $2) } + | '{-# WARNING' strings '#-}' { Just (sLL $1 $> $ + WarningTxt $ unLoc $2) } | {- empty -} { Nothing } body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } @@ -497,8 +499,8 @@ header_body2 :: { [LImportDecl RdrName] } ----------------------------------------------------------------------------- -- The Export List -maybeexports :: { Maybe [LIE RdrName] } - : '(' exportlist ')' { Just (fromOL $2) } +maybeexports :: { Maybe (Located [LIE RdrName]) } + : '(' exportlist ')' { Just (sLL $1 $> (fromOL $2)) } | {- empty -} { Nothing } exportlist :: { OrdList (LIE RdrName) } @@ -523,10 +525,10 @@ exp_doc :: { OrdList (LIE RdrName) } -- No longer allow things like [] and (,,,) to be exported -- They are built in syntax, always available export :: { OrdList (LIE RdrName) } - : qcname_ext export_subspec { unitOL (sLL $1 $> (mkModuleImpExp (unLoc $1) + : qcname_ext export_subspec { unitOL (sLL $1 $> (mkModuleImpExp $1 (unLoc $2))) } - | 'module' modid { unitOL (sLL $1 $> (IEModuleContents (unLoc $2))) } - | 'pattern' qcon { unitOL (sLL $1 $> (IEVar (unLoc $2))) } + | 'module' modid { unitOL (sLL $1 $> (IEModuleContents $2)) } + | 'pattern' qcon { unitOL (sLL $1 $> (IEVar $2)) } export_subspec :: { Located ImpExpSubSpec } : {- empty -} { sL0 ImpExpAbs } @@ -534,9 +536,9 @@ export_subspec :: { Located ImpExpSubSpec } | '(' ')' { sLL $1 $> (ImpExpList []) } | '(' qcnames ')' { sLL $1 $> (ImpExpList (reverse $2)) } -qcnames :: { [RdrName] } -- A reversed list - : qcnames ',' qcname_ext { unLoc $3 : $1 } - | qcname_ext { [unLoc $1] } +qcnames :: { [Located RdrName] } -- A reversed list + : qcnames ',' qcname_ext { $3 : $1 } + | qcname_ext { [$1] } qcname_ext :: { Located RdrName } -- Variable or data constructor -- or tagged type constructor @@ -555,7 +557,7 @@ qcname :: { Located RdrName } -- Variable or data constructor -- whereas topdecls must contain at least one topdecl. importdecls :: { [LImportDecl RdrName] } - : importdecls ';' importdecl { $3 : $1 } + : importdecls ';' importdecl { ($3 : $1) } | importdecls ';' { $1 } | importdecl { [ $1 ] } | {- empty -} { [] } @@ -588,13 +590,15 @@ maybeas :: { Located (Maybe ModuleName) } : 'as' modid { sLL $1 $> (Just (unLoc $2)) } | {- empty -} { noLoc Nothing } -maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) } +maybeimpspec :: { Located (Maybe (Bool, Located [LIE RdrName])) } : impspec { sL1 $1 (Just (unLoc $1)) } | {- empty -} { noLoc Nothing } -impspec :: { Located (Bool, [LIE RdrName]) } - : '(' exportlist ')' { sLL $1 $> (False, fromOL $2) } - | 'hiding' '(' exportlist ')' { sLL $1 $> (True, fromOL $3) } +impspec :: { Located (Bool, Located [LIE RdrName]) } + : '(' exportlist ')' { sLL $1 $> (False, + (sLL $1 $> $ fromOL $2)) } + | 'hiding' '(' exportlist ')' { sLL $1 $> (True, + (sLL $2 $> $ fromOL $3)) } ----------------------------------------------------------------------------- -- Fixity Declarations @@ -658,7 +662,8 @@ topdecl :: { OrdList (LHsDecl RdrName) } -- Type classes -- cl_decl :: { LTyClDecl RdrName } - : 'class' tycl_hdr fds where_cls {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 $4 } + : 'class' tycl_hdr fds where_cls + {% mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (unLoc $4) } -- Type declarations (toplevel) -- @@ -716,7 +721,7 @@ inst_decl :: { LInstDecl RdrName } -- data/newtype instance declaration | data_or_newtype 'instance' capi_ctype tycl_hdr constrs deriving {% mkDataFamInst (comb4 $1 $4 $5 $6) (unLoc $1) $3 $4 - Nothing (reverse (unLoc $5)) (unLoc $6) } + Nothing (reverse (unLoc $5)) (unLoc $6) } -- GADT instance declaration | data_or_newtype 'instance' capi_ctype tycl_hdr opt_kind_sig @@ -725,11 +730,11 @@ 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 } +overlap_pragma :: { Maybe (Located OverlapMode) } + : '{-# OVERLAPPABLE' '#-}' { Just (sLL $1 $> Overlappable) } + | '{-# OVERLAPPING' '#-}' { Just (sLL $1 $> Overlapping) } + | '{-# OVERLAPS' '#-}' { Just (sLL $1 $> Overlaps) } + | '{-# INCOHERENT' '#-}' { Just (sLL $1 $> Incoherent) } | {- empty -} { Nothing } @@ -829,10 +834,14 @@ tycl_hdr :: { Located (Maybe (LHsContext RdrName), LHsType RdrName) } : context '=>' type { sLL $1 $> (Just $1, $3) } | type { sL1 $1 (Nothing, $1) } -capi_ctype :: { Maybe CType } -capi_ctype : '{-# CTYPE' STRING STRING '#-}' { Just (CType (Just (Header (getSTRING $2))) (getSTRING $3)) } - | '{-# CTYPE' STRING '#-}' { Just (CType Nothing (getSTRING $2)) } - | { Nothing } +capi_ctype :: { Maybe (Located CType) } +capi_ctype : '{-# CTYPE' STRING STRING '#-}' + { Just $ sLL $1 $> (CType + (Just (Header (getSTRING $2))) + (getSTRING $3)) } + | '{-# CTYPE' STRING '#-}' + { Just $ sLL $1 $> (CType Nothing (getSTRING $2)) } + | { Nothing } ----------------------------------------------------------------------------- -- Stand-alone deriving @@ -1008,7 +1017,7 @@ rules :: { OrdList (LHsDecl RdrName) } rule :: { LHsDecl RdrName } : STRING rule_activation rule_forall infixexp '=' exp - { sLL $1 $> $ RuleD (HsRule (getSTRING $1) + { sLL $1 $> $ RuleD (HsRule (sL1 $1 (getSTRING $1)) ($2 `orElse` AlwaysActive) $3 $4 placeHolderNames $6 placeHolderNames) } @@ -1022,17 +1031,17 @@ rule_explicit_activation :: { Activation } -- In brackets | '[' '~' INTEGER ']' { ActiveBefore (fromInteger (getINTEGER $3)) } | '[' '~' ']' { NeverActive } -rule_forall :: { [RuleBndr RdrName] } +rule_forall :: { [LRuleBndr RdrName] } : 'forall' rule_var_list '.' { $2 } | {- empty -} { [] } -rule_var_list :: { [RuleBndr RdrName] } +rule_var_list :: { [LRuleBndr RdrName] } : rule_var { [$1] } | rule_var rule_var_list { $1 : $2 } -rule_var :: { RuleBndr RdrName } - : varid { RuleBndr $1 } - | '(' varid '::' ctype ')' { RuleBndrSig $2 (mkHsWithBndrs $4) } +rule_var :: { LRuleBndr RdrName } + : varid { sLL $1 $> $ RuleBndr $1 } + | '(' varid '::' ctype ')' { sLL $1 $> $ RuleBndrSig $2 (mkHsWithBndrs $4) } ----------------------------------------------------------------------------- -- Warnings and deprecations (c.f. rules) @@ -1061,13 +1070,14 @@ deprecation :: { OrdList (LHsDecl RdrName) } { toOL [ sLL $1 $> $ WarningD (Warning n (DeprecatedTxt $ unLoc $2)) | n <- unLoc $1 ] } -strings :: { Located [FastString] } - : STRING { sL1 $1 [getSTRING $1] } +strings :: { Located [Located FastString] } + : STRING { sL1 $1 [sL1 $1 (getSTRING $1)] } | '[' stringlist ']' { sLL $1 $> $ fromOL (unLoc $2) } -stringlist :: { Located (OrdList FastString) } - : stringlist ',' STRING { sLL $1 $> (unLoc $1 `snocOL` getSTRING $3) } - | STRING { sLL $1 $> (unitOL (getSTRING $1)) } +stringlist :: { Located (OrdList (Located FastString)) } + : stringlist ',' STRING { sLL $1 $> (unLoc $1 `snocOL` + (L (getLoc $3) (getSTRING $3))) } + | STRING { sLL $1 $> (unitOL (sLL $1 $> (getSTRING $1))) } ----------------------------------------------------------------------------- -- Annotations @@ -1084,22 +1094,22 @@ fdecl :: { LHsDecl RdrName } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (unLoc $4) >>= return.sLL $1 $> } | 'import' callconv fspec - {% do { d <- mkImport $2 PlaySafe (unLoc $3); + {% do { d <- mkImport $2 (noLoc PlaySafe) (unLoc $3); return (sLL $1 $> d) } } | 'export' callconv fspec {% mkExport $2 (unLoc $3) >>= return.sLL $1 $> } -callconv :: { CCallConv } - : 'stdcall' { StdCallConv } - | 'ccall' { CCallConv } - | 'capi' { CApiConv } - | 'prim' { PrimCallConv} - | 'javascript' { JavaScriptCallConv } +callconv :: { Located CCallConv } + : 'stdcall' { sLL $1 $> StdCallConv } + | 'ccall' { sLL $1 $> CCallConv } + | 'capi' { sLL $1 $> CApiConv } + | 'prim' { sLL $1 $> PrimCallConv } + | 'javascript' { sLL $1 $> JavaScriptCallConv } -safety :: { Safety } - : 'unsafe' { PlayRisky } - | 'safe' { PlaySafe } - | 'interruptible' { PlayInterruptible } +safety :: { Located Safety } + : 'unsafe' { sLL $1 $> PlayRisky } + | 'safe' { sLL $1 $> PlaySafe } + | 'interruptible' { sLL $1 $> PlayInterruptible } fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } : STRING var '::' sigtypedoc { sLL $1 $> (L (getLoc $1) (getSTRING $1), $2, $4) } @@ -1348,14 +1358,14 @@ both become a HsTyVar ("Zero", DataName) after the renamer. ----------------------------------------------------------------------------- -- Datatype declarations -gadt_constrlist :: { Located [LConDecl RdrName] } -- Returned in order +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_constr ';' gadt_constrs { L (comb2 (head $1) $3) ($1 ++ unLoc $3) } - | gadt_constr { L (getLoc (head $1)) $1 } + : gadt_constr ';' gadt_constrs { sLL $1 $> ($1 : unLoc $3) } + | gadt_constr { sLL $1 $> [$1] } | {- empty -} { noLoc [] } -- We allow the following forms: @@ -1364,15 +1374,16 @@ 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] } -- Returns a list because of: C,D :: ty +gadt_constr :: { LConDecl RdrName } + -- Returns a list because of: C,D :: ty : con_list '::' sigtype - { map (sL (comb2 $1 $3)) (mkGadtDecl (unLoc $1) $3) } + { sLL $1 $> $ mkGadtDecl (unLoc $1) $3 } -- Deprecated syntax for GADT record declarations | oqtycon '{' fielddecls '}' '::' sigtype {% do { cd <- mkDeprecatedGadtRecordDecl (comb2 $1 $6) $1 $3 $6 ; cd' <- checkRecordSyntax cd - ; return [cd'] } } + ; return cd' } } constrs :: { Located [LConDecl RdrName] } : maybe_docnext '=' constrs1 { L (comb2 $2 $3) (addConDocs (unLoc $3) $1) } @@ -1406,30 +1417,32 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } : btype {% splitCon $1 >>= return.sLL $1 $> } | btype conop btype { sLL $1 $> ($2, InfixCon $1 $3) } -fielddecls :: { [ConDeclField RdrName] } +fielddecls :: { [LConDeclField RdrName] } : {- empty -} { [] } | fielddecls1 { $1 } -fielddecls1 :: { [ConDeclField RdrName] } +fielddecls1 :: { [LConDeclField 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 } + { (addFieldDoc $1 $4) : addFieldDocs $5 $2 } + | fielddecl { [$1] } -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) ] } +fielddecl :: { LConDeclField RdrName } + -- A list because of f,g :: Int + : maybe_docnext sig_vars '::' ctype maybe_docprev + { L (comb2 $2 $4) + (ConDeclField (reverse (unLoc $2)) $4 ($1 `mplus` $5)) } -- 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). -- The 'C [a]' part is converted to an HsPredTy by checkInstType -- We don't allow a context, but that's sorted out by the type checker. -deriving :: { Located (Maybe [LHsType RdrName]) } - : {- empty -} { noLoc Nothing } - | 'deriving' qtycon { let { L loc tv = $2 } - in sLL $1 $> (Just [L loc (HsTyVar tv)]) } - | 'deriving' '(' ')' { sLL $1 $> (Just []) } - | 'deriving' '(' inst_types1 ')' { sLL $1 $> (Just $3) } +deriving :: { Located (Maybe (Located [LHsType RdrName])) } + : {- empty -} { noLoc Nothing } + | 'deriving' qtycon + { let { L loc tv = $2 } + in sLL $1 $> (Just (sLL $1 $> [L loc (HsTyVar tv)])) } + | 'deriving' '(' ')' { sLL $1 $> (Just (noLoc [])) } + | 'deriving' '(' inst_types1 ')' { sLL $1 $> (Just (sLL $1 $> $3)) } -- Glasgow extension: allow partial -- applications in derivings @@ -1512,19 +1525,24 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } {% do s <- checkValSig $1 $3 ; return (sLL $1 $> $ unitOL (sLL $1 $> $ SigD s)) } | var ',' sig_vars '::' sigtypedoc - { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] } - | infix prec ops { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) - | n <- unLoc $3 ] } + { sLL $1 $> $ toOL [ sLL $1 $> $ SigD + (TypeSig ($1 : reverse (unLoc $3)) $5) ] } + | infix prec ops + { sLL $1 $> $ toOL [ sLL $1 $> $ SigD + (FixSig (FixitySig (unLoc $3) (Fixity $2 (unLoc $1)))) ] } + | pattern_synonym_sig { sLL $1 $> $ unitOL $ sLL $1 $> . SigD . unLoc $ $1 } + | '{-# INLINE' activation qvar '#-}' { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) } | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' { let inl_prag = mkInlinePragma (EmptyInlineSpec, FunLike) $2 - in sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t inl_prag) - | t <- $5] } + in sLL $1 $> $ + toOL [ sLL $1 $> $ SigD (SpecSig $3 $5 inl_prag) ] } + | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 t (mkInlinePragma (getSPEC_INLINE $1) $2)) - | t <- $5] } + { sLL $1 $> $ toOL [ sLL $1 $> $ SigD (SpecSig $3 $5 + (mkInlinePragma (getSPEC_INLINE $1) $2)) ] } | '{-# SPECIALISE' 'instance' inst_type '#-}' { sLL $1 $> $ unitOL (sLL $1 $> $ SigD (SpecInstSig $3)) } -- A minimal complete definition @@ -1694,7 +1712,8 @@ aexp2 :: { LHsExpr RdrName } | '(' texp ')' { sLL $1 $> (HsPar $2) } | '(' tup_exprs ')' { sLL $1 $> (ExplicitTuple $2 Boxed) } - | '(#' texp '#)' { sLL $1 $> (ExplicitTuple [Present $2] Unboxed) } + | '(#' texp '#)' { sLL $1 $> (ExplicitTuple [L (getLoc $2) + (Present $2)] Unboxed) } | '(#' tup_exprs '#)' { sLL $1 $> (ExplicitTuple $2 Unboxed) } | '[' list ']' { sLL $1 $> (unLoc $2) } @@ -1773,19 +1792,20 @@ texp :: { LHsExpr RdrName } | exp '->' texp { sLL $1 $> $ EViewPat $1 $3 } -- Always at least one comma -tup_exprs :: { [HsTupArg RdrName] } - : texp commas_tup_tail { Present $1 : $2 } - | commas tup_tail { replicate $1 missingTupArg ++ $2 } +tup_exprs :: { [LHsTupArg RdrName] } + : texp commas_tup_tail { sL1 $1 (Present $1) : $2 } + | commas tup_tail { replicate $1 (noLoc missingTupArg) ++ $2 } -- Always starts with commas; always follows an expr -commas_tup_tail :: { [HsTupArg RdrName] } -commas_tup_tail : commas tup_tail { replicate ($1-1) missingTupArg ++ $2 } +commas_tup_tail :: { [LHsTupArg RdrName] } +commas_tup_tail : commas tup_tail + { replicate ($1-1) (noLoc missingTupArg) ++ $2 } -- Always follows a comma -tup_tail :: { [HsTupArg RdrName] } - : texp commas_tup_tail { Present $1 : $2 } - | texp { [Present $1] } - | {- empty -} { [missingTupArg] } +tup_tail :: { [LHsTupArg RdrName] } + : texp commas_tup_tail { sL1 $1 (Present $1) : $2 } + | texp { [sL1 $1 $ Present $1] } + | {- empty -} { [noLoc missingTupArg] } ----------------------------------------------------------------------------- -- List expressions @@ -1993,22 +2013,22 @@ qual :: { LStmt RdrName (LHsExpr RdrName) } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } +fbinds :: { ([LHsRecField RdrName (LHsExpr RdrName)], Bool) } : fbinds1 { $1 } | {- empty -} { ([], False) } -fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } +fbinds1 :: { ([LHsRecField RdrName (LHsExpr RdrName)], Bool) } : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) } | fbind { ([$1], False) } | '..' { ([], True) } -fbind :: { HsRecField RdrName (LHsExpr RdrName) } - : qvar '=' texp { HsRecField $1 $3 False } +fbind :: { LHsRecField RdrName (LHsExpr RdrName) } + : qvar '=' texp { sLL $1 $> $ HsRecField $1 $3 False } -- RHS is a 'texp', allowing view patterns (Trac #6038) -- and, incidentaly, sections. Eg -- f (R { x = show -> s }) = ... - | qvar { HsRecField $1 placeHolderPunRhs True } + | qvar { sLL $1 $> $ HsRecField $1 placeHolderPunRhs True } -- In the punning case, use a place-holder -- The renamer fills in the final value @@ -2419,7 +2439,7 @@ sL span a = span `seq` a `seq` L span a sL0 = L noSrcSpan -- #define L0 L noSrcSpan {-# INLINE sL1 #-} -sL1 x = sL (getLoc x) -- #define L1 sL (getLoc $1) +sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) {-# INLINE sLL #-} sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index e57af70e99..59a68ad318 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -121,12 +121,11 @@ mkInstD (L loc d) = L loc (InstD d) mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Located [Located (FunDep RdrName)] - -> Located (OrdList (LHsDecl RdrName)) + -> OrdList (LHsDecl RdrName) -> P (LTyClDecl RdrName) mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls - = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs (unLoc where_cls) - ; let cxt = fromMaybe (noLoc []) mcxt + = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls ; (cls, tparams) <- checkTyClHdr tycl_hdr ; tyvars <- checkTyVarsP (ptext (sLit "class")) whereDots cls tparams ; at_defs <- mapM (eitherToP . mkATDefault) at_insts @@ -152,11 +151,11 @@ mkATDefault (L loc (TyFamInstDecl { tfid_eqn = L _ e })) mkTyData :: SrcSpan -> NewOrData - -> Maybe CType + -> Maybe (Located CType) -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] - -> Maybe [LHsType RdrName] + -> Maybe (Located [LHsType RdrName]) -> P (LTyClDecl RdrName) mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr @@ -167,11 +166,11 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv tcdFVs = placeHolderNames })) } mkDataDefn :: NewOrData - -> Maybe CType + -> Maybe (Located CType) -> Maybe (LHsContext RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] - -> Maybe [LHsType RdrName] + -> Maybe (Located [LHsType RdrName]) -> P (HsDataDefn RdrName) mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt @@ -203,11 +202,11 @@ mkTyFamInstEqn lhs rhs mkDataFamInst :: SrcSpan -> NewOrData - -> Maybe CType + -> Maybe (Located CType) -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] - -> Maybe [LHsType RdrName] + -> Maybe (Located [LHsType RdrName]) -> P (LInstDecl RdrName) mkDataFamInst loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr @@ -458,7 +457,7 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) = mkDeprecatedGadtRecordDecl :: SrcSpan -> Located RdrName - -> [ConDeclField RdrName] + -> [LConDeclField RdrName] -> LHsType RdrName -> P (LConDecl RdrName) -- This one uses the deprecated syntax @@ -467,7 +466,7 @@ mkDeprecatedGadtRecordDecl :: SrcSpan mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty = do { data_con <- tyConToDataCon con_loc con ; return (L loc (ConDecl { con_old_rec = True - , con_name = data_con + , con_names = [data_con] , con_explicit = Implicit , con_qvars = mkHsQTvs [] , con_cxt = noLoc [] @@ -481,7 +480,7 @@ mkSimpleConDecl :: Located RdrName -> [LHsTyVarBndr RdrName] mkSimpleConDecl name qvars cxt details = ConDecl { con_old_rec = False - , con_name = name + , con_names = [name] , con_explicit = Explicit , con_qvars = mkHsQTvs qvars , con_cxt = cxt @@ -491,22 +490,22 @@ mkSimpleConDecl name qvars cxt details mkGadtDecl :: [Located RdrName] -> LHsType RdrName -- Always a HsForAllTy - -> [ConDecl RdrName] + -> ConDecl RdrName -- We allow C,D :: ty -- and expand it as if it had been -- C :: ty; D :: ty -- (Just like type signatures in general.) mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau)) - = [mk_gadt_con name | name <- names] + = mk_gadt_con names where (details, res_ty) -- See Note [Sorting out the result type] = case tau of L _ (HsFunTy (L _ (HsRecTy flds)) res_ty) -> (RecCon flds, res_ty) _other -> (PrefixCon [], tau) - mk_gadt_con name + mk_gadt_con names = ConDecl { con_old_rec = False - , con_name = name + , con_names = names , con_explicit = imp , con_qvars = qvars , con_cxt = cxt @@ -726,7 +725,8 @@ checkAPat msg loc e0 = do return (PArrPat ps placeHolderType) ExplicitTuple es b - | all tupArgPresent es -> do ps <- mapM (checkLPat msg) [e | Present e <- es] + | all tupArgPresent es -> do ps <- mapM (checkLPat msg) + [e | L _ (Present e) <- es] return (TuplePat ps b []) | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0) @@ -748,9 +748,10 @@ plus_RDR = mkUnqual varName (fsLit "+") -- Hack bang_RDR = mkUnqual varName (fsLit "!") -- Hack pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") -checkPatField :: SDoc -> HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName)) -checkPatField msg fld = do p <- checkLPat msg (hsRecFieldArg fld) - return (fld { hsRecFieldArg = p }) +checkPatField :: SDoc -> LHsRecField RdrName (LHsExpr RdrName) + -> P (LHsRecField RdrName (LPat RdrName)) +checkPatField msg (L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) + return (L l (fld { hsRecFieldArg = p })) patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a patFail msg loc e = parseErrorSDoc loc err @@ -771,12 +772,12 @@ checkValDef msg lhs (Just sig) grhss -- x :: ty = rhs parses as a *pattern* binding = checkPatBind msg (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss -checkValDef msg lhs opt_sig grhss +checkValDef msg lhs opt_sig g@(L l grhss) = do { mb_fun <- isFunLhs lhs ; case mb_fun of Just (fun, is_infix, pats) -> checkFunBind msg (getLoc lhs) - fun is_infix pats opt_sig grhss - Nothing -> checkPatBind msg lhs grhss } + fun is_infix pats opt_sig (L l grhss) + Nothing -> checkPatBind msg lhs g } checkFunBind :: SDoc -> SrcSpan @@ -1036,7 +1037,7 @@ checkPrecP (L l i) mkRecConstrOrUpdate :: LHsExpr RdrName -> SrcSpan - -> ([HsRecField RdrName (LHsExpr RdrName)], Bool) + -> ([LHsRecField RdrName (LHsExpr RdrName)], Bool) -> P (HsExpr RdrName) mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) @@ -1045,7 +1046,7 @@ mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) mkRecConstrOrUpdate exp _ (fs,dd) = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) -mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg +mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } @@ -1070,30 +1071,34 @@ mkInlinePragma (inl, match_info) mb_act -- construct a foreign import declaration -- -mkImport :: CCallConv - -> Safety +mkImport :: Located CCallConv + -> Located Safety -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkImport cconv safety (L loc entity, v, ty) +mkImport (L lc cconv) (L ls safety) (L loc entity, v, ty) | cconv == PrimCallConv = do let funcTarget = CFunction (StaticTarget entity Nothing True) - importSpec = CImport PrimCallConv safety Nothing funcTarget + importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget + (L loc entity) return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | cconv == JavaScriptCallConv = do let funcTarget = CFunction (StaticTarget entity Nothing True) - importSpec = CImport JavaScriptCallConv safety Nothing funcTarget + importSpec = CImport (L lc JavaScriptCallConv) (L ls safety) Nothing + funcTarget (L loc entity) return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) | otherwise = do - case parseCImport cconv safety (mkExtName (unLoc v)) (unpackFS entity) of + case parseCImport (L lc cconv) (L ls safety) (mkExtName (unLoc v)) + (unpackFS entity) (L loc entity) of Nothing -> parseErrorSDoc loc (text "Malformed entity string") Just importSpec -> return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec)) -- the string "foo" is ambigous: either a header or a C identifier. The -- C identifier case comes first in the alternatives below, so we pick -- that one. -parseCImport :: CCallConv -> Safety -> FastString -> String +parseCImport :: Located CCallConv -> Located Safety -> FastString -> String + -> Located FastString -> Maybe ForeignImport -parseCImport cconv safety nm str = +parseCImport cconv safety nm str sourceText = listToMaybe $ map fst $ filter (null.snd) $ readP_to_S parse str where @@ -1118,7 +1123,7 @@ parseCImport cconv safety nm str = | id_char c -> pfail _ -> return () - mk = CImport cconv safety + mk h n = CImport cconv safety h n sourceText hdr_char c = not (isSpace c) -- header files are filenames, which can contain -- pretty much any char (depending on the platform), @@ -1128,7 +1133,7 @@ parseCImport cconv safety nm str = cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) +++ (do isFun <- case cconv of - CApiConv -> + L _ CApiConv -> option True (do token "value" skipSpaces @@ -1145,11 +1150,12 @@ parseCImport cconv safety nm str = -- construct a foreign export declaration -- -mkExport :: CCallConv +mkExport :: Located CCallConv -> (Located FastString, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkExport cconv (L _ entity, v, ty) = return $ - ForD (ForeignExport v ty noForeignExportCoercionYet (CExport (CExportStatic entity' cconv))) +mkExport (L lc cconv) (L le entity, v, ty) = return $ + ForD (ForeignExport v ty noForeignExportCoercionYet + (CExport (L lc (CExportStatic entity' cconv)) (L le entity))) where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity @@ -1166,16 +1172,16 @@ mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) -------------------------------------------------------------------------------- -- Help with module system imports/exports -data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [ RdrName ] +data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [Located RdrName] -mkModuleImpExp :: RdrName -> ImpExpSubSpec -> IE RdrName -mkModuleImpExp name subs = +mkModuleImpExp :: Located RdrName -> ImpExpSubSpec -> IE RdrName +mkModuleImpExp n@(L l name) subs = case subs of ImpExpAbs - | isVarNameSpace (rdrNameSpace name) -> IEVar name + | isVarNameSpace (rdrNameSpace name) -> IEVar n | otherwise -> IEThingAbs nameT - ImpExpAll -> IEThingAll nameT - ImpExpList xs -> IEThingWith nameT xs + ImpExpAll -> IEThingAll (L l nameT) + ImpExpList xs -> IEThingWith (L l nameT) xs where nameT = setRdrNameSpace name tcClsName |