From 15dd7007275a5dcdae2c9f104773eceaa56590dc Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 2 Aug 2015 10:26:59 +0200 Subject: Replace (SourceText,FastString) with StringLiteral data type Summary: Phab:D907 introduced SourceText for a number of data types, by replacing FastString with (SourceText,FastString). Since this has an Outputable instance, no warnings are generated when ppr is called on it, but unexpected output is generated. See Phab:D1096 for an example of this. Replace the (SourceText,FastString) tuples with a new data type, ```lang=hs data StringLiteral = StringLiteral SourceText FastString ``` Update haddock submodule accordingly Test Plan: ./validate Reviewers: hvr, austin, rwbarton, trofi, bgamari Reviewed By: trofi, bgamari Subscribers: thomie, trofi, rwbarton, mpickering Differential Revision: https://phabricator.haskell.org/D1101 GHC Trac Issues: #10692 --- compiler/parser/Parser.y | 33 +++++++++++++++++---------------- compiler/parser/RdrHsSyn.hs | 8 ++++---- 2 files changed, 21 insertions(+), 20 deletions(-) (limited to 'compiler/parser') diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 815c8cb798..b1863856a3 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -807,10 +807,10 @@ maybe_safe :: { ([AddAnn],Bool) } : 'safe' { ([mj AnnSafe $1],True) } | {- empty -} { ([],False) } -maybe_pkg :: { ([AddAnn],Maybe (SourceText,FastString)) } +maybe_pkg :: { ([AddAnn],Maybe StringLiteral) } : STRING {% let pkgFS = getSTRING $1 in if looksLikePackageName (unpackFS pkgFS) - then return ([mj AnnPackageName $1], Just (getSTRINGs $1,pkgFS)) + then return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) else parseErrorSDoc (getLoc $1) $ vcat [ text "parse error" <> colon <+> quotes (ppr pkgFS), text "Version number or non-alphanumeric" <+> @@ -1465,15 +1465,15 @@ deprecation :: { OrdList (LWarnDecl RdrName) } {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2))) (fst $ unLoc $2) } -strings :: { Located ([AddAnn],[Located (SourceText,FastString)]) } - : STRING { sL1 $1 ([],[L (gl $1) (getSTRINGs $1,getSTRING $1)]) } +strings :: { Located ([AddAnn],[Located StringLiteral]) } + : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) } | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) } -stringlist :: { Located (OrdList (Located (SourceText,FastString))) } +stringlist :: { Located (OrdList (Located StringLiteral)) } : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> (unLoc $1 `snocOL` - (L (gl $3) (getSTRINGs $3,getSTRING $3)))) } - | STRING { sLL $1 $> (unitOL (L (gl $1) (getSTRINGs $1,getSTRING $1))) } + (L (gl $3) (getStringLiteral $3)))) } + | STRING { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) } ----------------------------------------------------------------------------- -- Annotations @@ -1521,12 +1521,12 @@ safety :: { Located Safety } | 'interruptible' { sLL $1 $> PlayInterruptible } fspec :: { Located ([AddAnn] - ,(Located (SourceText,FastString), Located RdrName, LHsType RdrName)) } + ,(Located StringLiteral, Located RdrName, LHsType RdrName)) } : STRING var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $3] ,(L (getLoc $1) - (getSTRINGs $1,getSTRING $1), $2, $4)) } + (getStringLiteral $1), $2, $4)) } | var '::' sigtypedoc { sLL $1 $> ([mj AnnDcolon $2] - ,(noLoc ("",nilFS), $1, $3)) } + ,(noLoc (StringLiteral "" nilFS), $1, $3)) } -- if the entity string is missing, it defaults to the empty string; -- the meaning of an empty entity string depends on the calling -- convention @@ -2228,7 +2228,7 @@ exp10 :: { LHsExpr RdrName } -- TODO: is LL right here? [mj AnnProc $1,mj AnnRarrow $3] } - | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getSTRINGs $2,getSTRING $2) $4) + | '{-# CORE' STRING '#-}' exp {% ams (sLL $1 $> $ HsCoreAnn (getCORE_PRAGs $1) (getStringLiteral $2) $4) [mo $1,mj AnnVal $2 ,mc $3] } -- hdaume: core annotation @@ -2269,16 +2269,16 @@ optSemi :: { ([Located a],Bool) } : ';' { ([$1],True) } | {- empty -} { ([],False) } -scc_annot :: { Located (([AddAnn],SourceText),(SourceText,FastString)) } +scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) } : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2 ; return $ sLL $1 $> (([mo $1,mj AnnValStr $2 - ,mc $3],getSCC_PRAGs $1),(getSTRINGs $2,scc)) } + ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) } | '{-# SCC' VARID '#-}' { sLL $1 $> (([mo $1,mj AnnVal $2 ,mc $3],getSCC_PRAGs $1) - ,(unpackFS $ getVARID $2,getVARID $2)) } + ,(StringLiteral (unpackFS $ getVARID $2) (getVARID $2))) } -hpc_annot :: { Located (([AddAnn],SourceText),((SourceText,FastString),(Int,Int),(Int,Int))) } +hpc_annot :: { Located (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))) } : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' { sLL $1 $> $ (([mo $1,mj AnnVal $2 ,mj AnnVal $3,mj AnnColon $4 @@ -2286,7 +2286,7 @@ hpc_annot :: { Located (([AddAnn],SourceText),((SourceText,FastString),(Int,Int) ,mj AnnVal $7,mj AnnColon $8 ,mj AnnVal $9,mc $10], getGENERATED_PRAGs $1) - ,((getSTRINGs $2,getSTRING $2) + ,((getStringLiteral $2) ,( fromInteger $ getINTEGER $3 , fromInteger $ getINTEGER $5 ) @@ -3214,6 +3214,7 @@ getOVERLAPS_PRAGs (L _ (IToverlaps_prag src)) = src getINCOHERENT_PRAGs (L _ (ITincoherent_prag src)) = src getCTYPEs (L _ (ITctype src)) = src +getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) getSCC :: Located Token -> P FastString getSCC lt = do let s = getSTRING lt diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 357512be33..ab3f17d182 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -1226,9 +1226,9 @@ mkInlinePragma src (inl, match_info) mb_act -- mkImport :: Located CCallConv -> Located Safety - -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName) + -> (Located StringLiteral, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkImport (L lc cconv) (L ls safety) (L loc (esrc,entity), v, ty) +mkImport (L lc cconv) (L ls safety) (L loc (StringLiteral esrc entity), v, ty) | cconv == PrimCallConv = do let funcTarget = CFunction (StaticTarget esrc entity Nothing True) importSpec = CImport (L lc PrimCallConv) (L ls safety) Nothing funcTarget @@ -1305,9 +1305,9 @@ parseCImport cconv safety nm str sourceText = -- construct a foreign export declaration -- mkExport :: Located CCallConv - -> (Located (SourceText,FastString), Located RdrName, LHsType RdrName) + -> (Located StringLiteral, Located RdrName, LHsType RdrName) -> P (HsDecl RdrName) -mkExport (L lc cconv) (L le (esrc,entity), v, ty) = do +mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) = do return $ ForD (ForeignExport v ty noForeignExportCoercionYet (CExport (L lc (CExportStatic esrc entity' cconv)) (L le (unpackFS entity)))) -- cgit v1.2.1