diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2016-11-08 21:37:48 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2016-12-07 21:31:13 +0200 |
| commit | 499e43824bda967546ebf95ee33ec1f84a114a7c (patch) | |
| tree | 58b313d734cfba014395ea5876db48e8400296a8 /compiler | |
| parent | 83d69dca896c7df1f2a36268d5b45c9283985ebf (diff) | |
| download | haskell-499e43824bda967546ebf95ee33ec1f84a114a7c.tar.gz | |
Add HsSyn prettyprinter tests
Summary:
Add prettyprinter tests, which take a file, parse it, pretty print it,
re-parse the pretty printed version and then compare the original and
new ASTs (ignoring locations)
Updates haddock submodule to match the AST changes.
There are three issues outstanding
1. Extra parens around a context are not reproduced. This will require an
AST change and will be done in a separate patch.
2. Currently if an `HsTickPragma` is found, this is not pretty-printed,
to prevent noise in the output.
I am not sure what the desired behaviour in this case is, so have left
it as before. Test Ppr047 is marked as expected fail for this.
3. Apart from in a context, the ParsedSource AST keeps all the parens from
the original source. Something is happening in the renamer to remove the
parens around visible type application, causing T12530 to fail, as the
dumped splice decl is after the renamer.
This needs to be fixed by keeping the parens, but I do not know where they
are being removed. I have amended the test to pass, by removing the parens
in the expected output.
Test Plan: ./validate
Reviewers: goldfire, mpickering, simonpj, bgamari, austin
Reviewed By: simonpj, bgamari
Subscribers: simonpj, goldfire, thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D2752
GHC Trac Issues: #3384
Diffstat (limited to 'compiler')
61 files changed, 966 insertions, 587 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index ce00c45351..a9f1e63e1f 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -30,7 +30,7 @@ module BasicTypes( FunctionOrData(..), - WarningTxt(..), StringLiteral(..), + WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, minPrecedence, @@ -90,14 +90,17 @@ module BasicTypes( inlinePragmaSpec, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, + pprInline, pprInlineDebug, SuccessFlag(..), succeeded, failed, successIf, FractionalLit(..), negateFractionalLit, integralFractionalLit, - SourceText, + SourceText(..), pprWithSourceText, - IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit + IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, + + SpliceExplicitFlag(..) ) where import FastString @@ -312,6 +315,9 @@ data StringLiteral = StringLiteral instance Eq StringLiteral where (StringLiteral _ a) == (StringLiteral _ b) = a == b +instance Outputable StringLiteral where + ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) + -- | Warning Text -- -- reason/explanation from a WARNING or DEPRECATED pragma @@ -322,11 +328,30 @@ data WarningTxt = WarningTxt (Located SourceText) deriving (Eq, Data) instance Outputable WarningTxt where - ppr (WarningTxt _ ws) - = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) - ppr (DeprecatedTxt _ ds) - = text "Deprecated:" <+> - doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) + ppr (WarningTxt lsrc ws) + = case unLoc lsrc of + NoSourceText -> pp_ws ws + SourceText src -> text src <+> pp_ws ws <+> text "#-}" + + ppr (DeprecatedTxt lsrc ds) + = case unLoc lsrc of + NoSourceText -> pp_ws ds + SourceText src -> text src <+> pp_ws ds <+> text "#-}" + +pp_ws :: [Located StringLiteral] -> SDoc +pp_ws [l] = ppr $ unLoc l +pp_ws ws + = text "[" + <+> vcat (punctuate comma (map (ppr . unLoc) ws)) + <+> text "]" + + +pprWarningTxtForMsg :: WarningTxt -> SDoc +pprWarningTxtForMsg (WarningTxt _ ws) + = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) +pprWarningTxtForMsg (DeprecatedTxt _ ds) + = text "Deprecated:" <+> + doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) {- ************************************************************************ @@ -375,12 +400,12 @@ maxPrecedence = 9 minPrecedence = 0 defaultFixity :: Fixity -defaultFixity = Fixity (show maxPrecedence) maxPrecedence InfixL +defaultFixity = Fixity NoSourceText maxPrecedence InfixL negateFixity, funTyFixity :: Fixity -- Wired-in fixities -negateFixity = Fixity "6" 6 InfixL -- Fixity of unary negate -funTyFixity = Fixity "0" 0 InfixR -- Fixity of '->' +negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity NoSourceText 0 InfixR -- Fixity of '->' {- Consider @@ -979,8 +1004,21 @@ For OverLitVal HsIsString "\x41nd" == "And" -} -type SourceText = String -- Note [Literal source text],[Pragma source text] + -- Note [Literal source text],[Pragma source text] +data SourceText = SourceText String + | NoSourceText -- ^ For when code is generated, e.g. TH, + -- deriving. The pretty printer will then make + -- its own representation of the item. + deriving (Data, Show, Eq ) +instance Outputable SourceText where + ppr (SourceText s) = text "SourceText" <+> text s + ppr NoSourceText = text "NoSourceText" + +-- | Special combinator for showing string literals. +pprWithSourceText :: SourceText -> SDoc -> SDoc +pprWithSourceText NoSourceText d = d +pprWithSourceText (SourceText src) _ = text src {- ************************************************************************ @@ -1117,7 +1155,7 @@ isEmptyInlineSpec _ = False defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma -defaultInlinePragma = InlinePragma { inl_src = "{-# INLINE" +defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_act = AlwaysActive , inl_rule = FunLike , inl_inline = EmptyInlineSpec @@ -1175,8 +1213,8 @@ setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where - ppr AlwaysActive = brackets (text "ALWAYS") - ppr NeverActive = brackets (text "NEVER") + ppr AlwaysActive = empty + ppr NeverActive = brackets (text "~") ppr (ActiveBefore _ n) = brackets (char '~' <> int n) ppr (ActiveAfter _ n) = brackets (int n) @@ -1191,10 +1229,21 @@ instance Outputable InlineSpec where ppr EmptyInlineSpec = empty instance Outputable InlinePragma where - ppr (InlinePragma { inl_inline = inline, inl_act = activation - , inl_rule = info, inl_sat = mb_arity }) - = ppr inline <> pp_act inline activation <+> pp_sat <+> pp_info + ppr = pprInline + +pprInline :: InlinePragma -> SDoc +pprInline = pprInline' True + +pprInlineDebug :: InlinePragma -> SDoc +pprInlineDebug = pprInline' False + +pprInline' :: Bool -> InlinePragma -> SDoc +pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info where + pp_inl x = if emptyInline then empty else ppr x + pp_act Inline AlwaysActive = empty pp_act NoInline NeverActive = empty pp_act _ act = ppr act @@ -1356,3 +1405,8 @@ treatZeroAsInf n = Int n -- | Inject any integer into an 'IntWithInf' mkIntWithInf :: Int -> IntWithInf mkIntWithInf = Int + +data SpliceExplicitFlag + = ExplicitSplice | -- ^ <=> $(f x y) + ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression + deriving Data diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 1cd90d103f..f4cdb2159d 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -495,7 +495,7 @@ data DataConRep -- emit a warning (in checkValidDataCon) and treat it like -- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ data HsSrcBang = - HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes + HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes SrcUnpackedness SrcStrictness deriving Data.Data diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 649100a7c0..dc8b4d0672 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -1122,7 +1122,8 @@ seqId = pcMiscPrelId seqName ty info `setRuleInfo` mkRuleInfo [seq_cast_rule] inline_prag - = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter "0" 0 + = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter + NoSourceText 0 -- Make 'seq' not inline-always, so that simpleOptExpr -- (see CoreSubst.simple_app) won't inline 'seq' on the -- LHS of rules. That way we can have rules for 'seq'; diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs index a231cf7db7..e783efea0d 100644 --- a/compiler/basicTypes/Var.hs +++ b/compiler/basicTypes/Var.hs @@ -316,6 +316,9 @@ instance Data Var where gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Var" +instance HasOccName Var where + occName = nameOccName . varName + varUnique :: Var -> Unique varUnique var = mkUniqueGrimily (realUnique var) diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index 9129c9012f..5394697832 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -402,7 +402,7 @@ pprIdBndrInfo info has_lbv = not (hasNoOneShotInfo lbv_info) doc = showAttributes - [ (has_prag, text "InlPrag=" <> ppr prag_info) + [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) , (has_occ, text "Occ=" <> ppr occ_info) , (has_dmd, text "Dmd=" <> ppr dmd_info) , (has_lbv , text "OS=" <> ppr lbv_info) diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index b96491231a..51bfb1811d 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -888,9 +888,10 @@ addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = (return ty1) (return arr_ty) (return lr) -addTickHsCmd (HsCmdArrForm e fix cmdtop) = - liftM3 HsCmdArrForm +addTickHsCmd (HsCmdArrForm e f fix cmdtop) = + liftM4 HsCmdArrForm (addTickLHsExpr e) + (return f) (return fix) (mapM (liftL (addTickHsCmdTop)) cmdtop) diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index 0ce6f50656..16ec704ad8 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -607,7 +607,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do -- ----------------------------------- -- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn -dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do +dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ _ args) env_ids = do let env_ty = mkBigCoreVarTupTy env_ids core_op <- dsLExpr op (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs index 0d9bbb4362..d87d93527a 100644 --- a/compiler/deSugar/DsCCall.hs +++ b/compiler/deSugar/DsCCall.hs @@ -37,7 +37,6 @@ import TysPrim import TyCon import TysWiredIn import BasicTypes -import FastString ( unpackFS ) import Literal import PrelNames import DynFlags @@ -95,7 +94,7 @@ dsCCall lbl args may_gc result_ty uniq <- newUnique dflags <- getDynFlags let - target = StaticTarget (unpackFS lbl) lbl Nothing True + target = StaticTarget NoSourceText lbl Nothing True the_fcall = CCall (CCallSpec target CCallConv may_gc) the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty return (foldr ($) (res_wrapper the_prim_app) arg_wrappers) diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 981745e602..b7ea8ab777 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -218,7 +218,7 @@ dsFCall fn_id co fcall mDeclHeader = do CApiConv safety) -> do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) let fcall' = CCall (CCallSpec - (StaticTarget (unpackFS wrapperName) + (StaticTarget NoSourceText wrapperName mUnitId True) CApiConv safety) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 556fbf9513..ee64fa73f3 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -944,7 +944,7 @@ repTy :: HsType Name -> DsM (Core TH.TypeQ) repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty -repTy (HsTyVar (L _ n)) +repTy (HsTyVar _ (L _ n)) | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n @@ -970,7 +970,8 @@ repTy (HsListTy t) = do repTapp tcon t1 repTy (HsPArrTy t) = do t1 <- repLTy t - tcon <- repTy (HsTyVar (noLoc (tyConName parrTyCon))) + tcon <- repTy (HsTyVar NotPromoted + (noLoc (tyConName parrTyCon))) repTapp tcon t1 repTy (HsTupleTy HsUnboxedTuple tys) = do tys1 <- repLTys tys @@ -995,7 +996,7 @@ repTy (HsKindSig t k) = do k1 <- repLKind k repTSig t1 k1 repTy (HsSpliceTy splice _) = repSplice splice -repTy (HsExplicitListTy _ tys) = do +repTy (HsExplicitListTy _ _ tys) = do tys1 <- repLTys tys repTPromotedList tys1 repTy (HsExplicitTupleTy _ tys) = do @@ -1041,7 +1042,7 @@ repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind) repNonArrowLKind (L _ ki) = repNonArrowKind ki repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) -repNonArrowKind (HsTyVar (L _ name)) +repNonArrowKind (HsTyVar _ (L _ name)) | isLiftedTypeKindTyConName name = repKStar | name `hasKey` constraintKindTyConKey = repKConstraint | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar @@ -1073,10 +1074,10 @@ repRole (L _ Nothing) = rep2 inferRName [] repSplice :: HsSplice Name -> DsM (Core a) -- See Note [How brackets and nested splices are handled] in TcSplice -- We return a CoreExpr of any old type; the context should know -repSplice (HsTypedSplice n _) = rep_splice n -repSplice (HsUntypedSplice n _) = rep_splice n -repSplice (HsQuasiQuote n _ _ _) = rep_splice n -repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e) +repSplice (HsTypedSplice _ n _) = rep_splice n +repSplice (HsUntypedSplice _ n _) = rep_splice n +repSplice (HsQuasiQuote n _ _ _) = rep_splice n +repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e) rep_splice :: Name -> DsM (Core a) rep_splice splice_name @@ -2345,15 +2346,15 @@ repLiteral lit mk_integer :: Integer -> DsM HsLit mk_integer i = do integer_ty <- lookupType integerTyConName - return $ HsInteger "" i integer_ty + return $ HsInteger NoSourceText i integer_ty mk_rational :: FractionalLit -> DsM HsLit mk_rational r = do rat_ty <- lookupType rationalTyConName return $ HsRat r rat_ty mk_string :: FastString -> DsM HsLit -mk_string s = return $ HsString "" s +mk_string s = return $ HsString NoSourceText s mk_char :: Char -> DsM HsLit -mk_char c = return $ HsChar "" c +mk_char c = return $ HsChar NoSourceText c repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit) repOverloadedLiteral (OverLit { ol_val = val}) diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs index c66021f6b5..9849eec191 100644 --- a/compiler/deSugar/MatchLit.hs +++ b/compiler/deSugar/MatchLit.hs @@ -291,11 +291,11 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty -- which might be ok if we have 'instance IsString Int' -- | not type_change, isIntTy ty, Just int_lit <- mb_int_lit - = mk_con_pat intDataCon (HsIntPrim "" int_lit) + = mk_con_pat intDataCon (HsIntPrim NoSourceText int_lit) | not type_change, isWordTy ty, Just int_lit <- mb_int_lit - = mk_con_pat wordDataCon (HsWordPrim "" int_lit) + = mk_con_pat wordDataCon (HsWordPrim NoSourceText int_lit) | not type_change, isStringTy ty, Just str_lit <- mb_str_lit - = tidy_lit_pat (HsString "" str_lit) + = tidy_lit_pat (HsString NoSourceText str_lit) -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3 -- If we do convert to the constructor form, we'll generate a case -- expression on a Float# or Double# and that's not allowed in Core; see diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 6bb71991d4..2c863c75ca 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -39,8 +39,6 @@ import MonadUtils ( foldrM ) import qualified Data.ByteString as BS import Control.Monad( unless, liftM, ap ) -import Data.Char ( chr ) -import Data.Word ( Word8 ) import Data.Maybe( catMaybes, fromMaybe, isNothing ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH @@ -268,10 +266,10 @@ cvtDec (InstanceD o ctxt ty decs) where overlap pragma = case pragma of - TH.Overlaps -> Hs.Overlaps "OVERLAPS" - TH.Overlappable -> Hs.Overlappable "OVERLAPPABLE" - TH.Overlapping -> Hs.Overlapping "OVERLAPPING" - TH.Incoherent -> Hs.Incoherent "INCOHERENT" + TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS") + TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE") + TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING") + TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT") @@ -550,7 +548,7 @@ cvt_arg (Bang su ss, ty) = do { ty' <- cvtType ty ; let su' = cvtSrcUnpackedness su ; let ss' = cvtSrcStrictness ss - ; returnL $ HsBangTy (HsSrcBang Nothing su' ss') ty' } + ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' } cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName) cvt_id_arg (i, str, ty) @@ -582,12 +580,13 @@ cvtForD (ImportF callconv safety from nm ty) -- and are inserted verbatim, analogous to mkImport in RdrHsSyn | callconv == TH.Prim || callconv == TH.JavaScript = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing - (CFunction (StaticTarget from (mkFastString from) Nothing + (CFunction (StaticTarget (SourceText from) + (mkFastString from) Nothing True)) - (noLoc from)) + (noLoc $ quotedSourceText from)) | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') (mkFastString (TH.nameBase nm)) - from (noLoc from) + from (noLoc $ quotedSourceText from) = mk_imp impspec | otherwise = failWith $ text (show from) <+> text "is not a valid ccall impent" @@ -608,10 +607,10 @@ cvtForD (ImportF callconv safety from nm ty) cvtForD (ExportF callconv as nm ty) = do { nm' <- vNameL nm ; ty' <- cvtType ty - ; let e = CExport (noLoc (CExportStatic as + ; let e = CExport (noLoc (CExportStatic (SourceText as) (mkFastString as) (cvt_conv callconv))) - (noLoc as) + (noLoc (SourceText as)) ; return $ ForeignExport { fd_name = nm' , fd_sig_ty = mkLHsSigType ty' , fd_co = noForeignExportCoercionYet @@ -632,7 +631,10 @@ cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName)) cvtPragmaD (InlineP nm inline rm phases) = do { nm' <- vNameL nm ; let dflt = dfltActivation inline - ; let ip = InlinePragma { inl_src = "{-# INLINE" + ; let src TH.NoInline = "{-# NOINLINE" + src TH.Inline = "{-# INLINE" + src TH.Inlinable = "{-# INLINABLE" + ; let ip = InlinePragma { inl_src = SourceText $ src inline , inl_inline = cvtInline inline , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt @@ -642,10 +644,15 @@ cvtPragmaD (InlineP nm inline rm phases) cvtPragmaD (SpecialiseP nm ty inline phases) = do { nm' <- vNameL nm ; ty' <- cvtType ty - ; let (inline', dflt) = case inline of - Just inline1 -> (cvtInline inline1, dfltActivation inline1) - Nothing -> (EmptyInlineSpec, AlwaysActive) - ; let ip = InlinePragma { inl_src = "{-# INLINE" + ; let src TH.NoInline = "{-# SPECIALISE NOINLINE" + src TH.Inline = "{-# SPECIALISE INLINE" + src TH.Inlinable = "{-# SPECIALISE INLINE" + ; let (inline', dflt,srcText) = case inline of + Just inline1 -> (cvtInline inline1, dfltActivation inline1, + src inline1) + Nothing -> (EmptyInlineSpec, AlwaysActive, + "{-# SPECIALISE") + ; let ip = InlinePragma { inl_src = SourceText srcText , inl_inline = inline' , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt @@ -655,7 +662,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases) cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty ; returnJustL $ Hs.SigD $ - SpecInstSig "{-# SPECIALISE" (mkLHsSigType ty') } + SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') } cvtPragmaD (RuleP nm bndrs lhs rhs phases) = do { let nm' = mkFastString nm @@ -664,7 +671,8 @@ cvtPragmaD (RuleP nm bndrs lhs rhs phases) ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs ; returnJustL $ Hs.RuleD - $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc (nm,nm')) act bndrs' + $ HsRules (SourceText "{-# RULES") + [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs' lhs' placeHolderNames rhs' placeHolderNames] } @@ -679,7 +687,8 @@ cvtPragmaD (AnnP target exp) ValueAnnotation n -> do n' <- vcName n return (ValueAnnProvenance (noLoc n')) - ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp' + ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target' + exp' } cvtPragmaD (LineP line file) @@ -702,8 +711,8 @@ cvtRuleMatch TH.FunLike = Hs.FunLike cvtPhases :: TH.Phases -> Activation -> Activation cvtPhases AllPhases dflt = dflt -cvtPhases (FromPhase i) _ = ActiveAfter (show i) i -cvtPhases (BeforePhase i) _ = ActiveBefore (show i) i +cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i +cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName) cvtRuleBndr (RuleVar n) @@ -980,13 +989,13 @@ cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs cvtOverLit :: Lit -> CvtM (HsOverLit RdrName) cvtOverLit (IntegerL i) - = do { force i; return $ mkHsIntegral (show i) i placeHolderType} + = do { force i; return $ mkHsIntegral NoSourceText i placeHolderType} cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType} cvtOverLit (StringL s) = do { let { s' = mkFastString s } ; force s' - ; return $ mkHsIsString s s' placeHolderType + ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType } cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" -- An Integer is like an (overloaded) '3' in a Haskell source program @@ -1014,25 +1023,25 @@ allCharLs xs go _ _ = Nothing cvtLit :: Lit -> CvtM HsLit -cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim (show i) i } -cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) w } +cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } +cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) } cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) } -cvtLit (CharL c) = do { force c; return $ HsChar (show c) c } -cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim (show c) c } +cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } +cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } cvtLit (StringL s) = do { let { s' = mkFastString s } ; force s' - ; return $ HsString s s' } + ; return $ HsString (quotedSourceText s) s' } cvtLit (StringPrimL s) = do { let { s' = BS.pack s } ; force s' - ; return $ HsStringPrim (w8ToString s) s' } + ; return $ HsStringPrim NoSourceText s' } cvtLit _ = panic "Convert.cvtLit: Unexpected literal" -- cvtLit should not be called on IntegerL, RationalL -- That precondition is established right here in -- Convert.hs, hence panic -w8ToString :: [Word8] -> String -w8ToString ws = map (\w -> chr (fromIntegral w)) ws +quotedSourceText :: String -> SourceText +quotedSourceText s = SourceText $ "\"" ++ s ++ "\"" cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName] cvtPats pats = mapM cvtPat pats @@ -1153,13 +1162,14 @@ cvtTypeKind ty_str ty | n == 1 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) | otherwise - -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' + -> mk_apps (HsTyVar NotPromoted + (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' UnboxedTupleT n | length tys' == n -- Saturated -> returnL (HsTupleTy HsUnboxedTuple tys') | otherwise - -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n)))) - tys' + -> mk_apps (HsTyVar NotPromoted + (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys' UnboxedSumT n | n < 2 -> failWith $ @@ -1169,18 +1179,22 @@ cvtTypeKind ty_str ty | length tys' == n -- Saturated -> returnL (HsSumTy tys') | otherwise - -> mk_apps (HsTyVar (noLoc (getRdrName (sumTyCon n)))) tys' + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n)))) + tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') - | otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys' + | otherwise -> + mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon))) + tys' ListT | [x'] <- tys' -> returnL (HsListTy x') - | otherwise - -> mk_apps (HsTyVar (noLoc (getRdrName listTyCon))) tys' + | otherwise -> + mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon))) + tys' VarT nm -> do { nm' <- tNameL nm - ; mk_apps (HsTyVar nm') tys' } + ; mk_apps (HsTyVar NotPromoted nm') tys' } ConT nm -> do { nm' <- tconName nm - ; mk_apps (HsTyVar (noLoc nm')) tys' } + ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } ForallT tvs cxt ty | null tys' @@ -1213,7 +1227,7 @@ cvtTypeKind ty_str ty -> do { s' <- tconName s ; t1' <- cvtType t1 ; t2' <- cvtType t2 - ; mk_apps (HsTyVar (noLoc s')) [t1', t2'] + ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2'] } UInfixT t1 s t2 @@ -1229,7 +1243,7 @@ cvtTypeKind ty_str ty } PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar (noLoc nm')) tys' } + ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } -- Promoted data constructor; hence cName PromotedTupleT n @@ -1243,25 +1257,29 @@ cvtTypeKind ty_str ty m = length tys' PromotedNilT - -> returnL (HsExplicitListTy placeHolderKind []) + -> returnL (HsExplicitListTy Promoted placeHolderKind []) PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax - | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys' - -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2)) + | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys' + -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2)) | otherwise - -> mk_apps (HsTyVar (noLoc (getRdrName consDataCon))) tys' + -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon))) + tys' StarT - -> returnL (HsTyVar (noLoc (getRdrName liftedTypeKindTyCon))) + -> returnL (HsTyVar NotPromoted (noLoc + (getRdrName liftedTypeKindTyCon))) ConstraintT - -> returnL (HsTyVar (noLoc (getRdrName constraintKindTyCon))) + -> returnL (HsTyVar NotPromoted + (noLoc (getRdrName constraintKindTyCon))) EqualityT | [x',y'] <- tys' -> returnL (HsEqTy x' y') - | otherwise - -> mk_apps (HsTyVar (noLoc (getRdrName eqPrimTyCon))) tys' + | otherwise -> + mk_apps (HsTyVar NotPromoted + (noLoc (getRdrName eqPrimTyCon))) tys' _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) } @@ -1286,8 +1304,8 @@ split_ty_app ty = go ty [] go f as = return (f,as) cvtTyLit :: TH.TyLit -> HsTyLit -cvtTyLit (TH.NumTyLit i) = HsNumTy (show i) i -cvtTyLit (TH.StrTyLit s) = HsStrTy s (fsLit s) +cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i +cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) {- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy structure in them. @@ -1359,7 +1377,7 @@ cvtPatSynSigTy ty = cvtType ty ----------------------------------------------------------- cvtFixity :: TH.Fixity -> Hs.Fixity -cvtFixity (TH.Fixity prec dir) = Hs.Fixity (show prec) prec (cvt_dir dir) +cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir) where cvt_dir TH.InfixL = Hs.InfixL cvt_dir TH.InfixR = Hs.InfixR diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 487859249f..eeb446e838 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) -import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) +import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId,HasOccNameId ) import HsTypes import PprCore () import CoreSyn @@ -437,13 +437,15 @@ Specifically, it's just an error thunk -} -instance (OutputableBndrId idL, OutputableBndrId idR) +instance (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR) => Outputable (HsLocalBindsLR idL idR) where ppr (HsValBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs ppr EmptyLocalBinds = empty -instance (OutputableBndrId idL, OutputableBndrId idR) +instance (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR) => Outputable (HsValBindsLR idL idR) where ppr (ValBindsIn binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs) @@ -459,14 +461,16 @@ instance (OutputableBndrId idL, OutputableBndrId idR) pp_rec Recursive = text "rec" pp_rec NonRecursive = text "nonrec" -pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR) +pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds binds | isEmptyLHsBinds binds = empty | otherwise = pprDeclList (map ppr (bagToList binds)) pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR, - OutputableBndrId id2) + OutputableBndrId id2, HasOccNameId id2, + HasOccNameId idL, HasOccNameId idR) => LHsBindsLR idL idR -> [LSig id2] -> [SDoc] -- pprLHsBindsForUser is different to pprLHsBinds because -- a) No braces: 'let' and 'where' include a list of HsBindGroups @@ -504,6 +508,10 @@ isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds isEmptyLocalBinds EmptyLocalBinds = True +eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool +eqEmptyLocalBinds EmptyLocalBinds = True +eqEmptyLocalBinds _ = False + isEmptyValBinds :: HsValBindsLR a b -> Bool isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs @@ -553,11 +561,13 @@ So the desugarer tries to do a better job: in (fm,gm) -} -instance (OutputableBndrId idL, OutputableBndrId idR) +instance (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR) => Outputable (HsBindLR idL idR) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR) +ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR) => HsBindLR idL idR -> SDoc ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) @@ -613,7 +623,7 @@ instance (OutputableBndr id) => Outputable (ABExport id) where , nest 2 (pprTcSpecPrags prags) , nest 2 (text "wrap:" <+> ppr wrap)] -instance (OutputableBndr idL, OutputableBndrId idR) +instance (OutputableBndr idL, OutputableBndrId idR, HasOccNameId idR) => Outputable (PatSynBind idL idR) where ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, psb_dir = dir }) @@ -685,11 +695,12 @@ data IPBind id = IPBind (Either (Located HsIPName) id) (LHsExpr id) deriving instance (DataId name) => Data (IPBind name) -instance (OutputableBndrId id) => Outputable (HsIPBinds id) where +instance (OutputableBndrId id, HasOccNameId id) + => Outputable (HsIPBinds id) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) $$ ifPprDebug (ppr ds) -instance (OutputableBndrId id) => Outputable (IPBind id) where +instance (OutputableBndrId id, HasOccNameId id) => Outputable (IPBind id) where ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) where name = case lr of Left (L _ ip) -> pprBndr LetBind ip @@ -946,28 +957,36 @@ signatures. Since some of the signatures contain a list of names, testing for equality is not enough -- we have to check if they overlap. -} -instance (OutputableBndrId name) => Outputable (Sig name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (Sig name) where ppr sig = ppr_sig sig -ppr_sig :: (OutputableBndrId name) => Sig name -> SDoc +ppr_sig :: (OutputableBndrId name, HasOccNameId name) => Sig name -> SDoc ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (SpecSig var ty inl) - = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl) -ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) -ppr_sig (SpecInstSig _ ty) - = pragBrackets (text "SPECIALIZE instance" <+> ppr ty) +ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec })) + = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) + (interpp'SP ty) inl) + where + pragmaSrc = case spec of + EmptyInlineSpec -> "{-# SPECIALISE" + _ -> "{-# SPECIALISE_INLINE" +ppr_sig (InlineSig var inl) + = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl + <+> pprPrefixOcc (unLoc var)) +ppr_sig (SpecInstSig src ty) + = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty) ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf) ppr_sig (PatSynSig names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) ppr_sig (SCCFunSig _ fn Nothing) = pragBrackets (text "SCC" <+> ppr fn) -ppr_sig (SCCFunSig _ fn (Just str)) - = pragBrackets (text "SCC" <+> ppr fn <+> ppr (sl_st str)) +ppr_sig (SCCFunSig src fn (Just str)) + = pragSrcBrackets src "{-# SCC#-}" (ppr fn <+> ppr str) instance OutputableBndr name => Outputable (FixitySig name) where ppr (FixitySig names fixity) = sep [ppr fixity, pprops] @@ -975,7 +994,13 @@ instance OutputableBndr name => Outputable (FixitySig name) where pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) pragBrackets :: SDoc -> SDoc -pragBrackets doc = text "{-#" <+> doc <+> ptext (sLit "#-}") +pragBrackets doc = text "{-#" <+> doc <+> text "#-}" + +-- | Using SourceText in case the pragma was spelled differently or used mixed +-- case +pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc +pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}" +pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}" pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] @@ -983,19 +1008,21 @@ pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc -pprSpec var pp_ty inl = text "SPECIALIZE" <+> pp_inl <+> pprVarSig [var] pp_ty +pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty where pp_inl | isDefaultInlinePragma inl = empty - | otherwise = ppr inl + | otherwise = pprInline inl pprTcSpecPrags :: TcSpecPrags -> SDoc pprTcSpecPrags IsDefaultMethod = text "<default method>" pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) instance Outputable TcSpecPrag where - ppr (SpecPrag var _ inl) = pprSpec var (text "<type>") inl + ppr (SpecPrag var _ inl) + = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl -pprMinimalSig :: OutputableBndr name => LBooleanFormula (Located name) -> SDoc +pprMinimalSig :: (OutputableBndr name, HasOccName name) + => LBooleanFormula (Located name) -> SDoc pprMinimalSig (L _ bf) = text "MINIMAL" <+> ppr (fmap unLoc bf) {- diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 0d6bbf62cc..c82cd8b0f2 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -86,7 +86,8 @@ module HsDecls ( ) where -- friends: -import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, pprSplice ) +import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr, + pprSpliceDecl ) -- Because Expr imports Decls via HsBracket import HsBinds @@ -97,7 +98,8 @@ import Name import BasicTypes import Coercion import ForeignCall -import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId ) +import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId, + HasOccNameId ) import NameSet -- others: @@ -250,7 +252,8 @@ appendGroups hs_vects = vects1 ++ vects2, hs_docs = docs1 ++ docs2 } -instance (OutputableBndrId name) => Outputable (HsDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (HsDecl name) where ppr (TyClD dcl) = ppr dcl ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def @@ -266,7 +269,8 @@ instance (OutputableBndrId name) => Outputable (HsDecl name) where ppr (DocD doc) = ppr doc ppr (RoleAnnotD ra) = ppr ra -instance (OutputableBndrId name) => Outputable (HsGroup name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (HsGroup name) where ppr (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -300,10 +304,6 @@ instance (OutputableBndrId name) => Outputable (HsGroup name) where vcat_mb gap (Nothing : ds) = vcat_mb gap ds vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds -data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) - ImplicitSplice -- <=> f x y, i.e. a naked top level expression - deriving Data - -- | Located Splice Declaration type LSpliceDecl name = Located (SpliceDecl name) @@ -314,8 +314,9 @@ data SpliceDecl id SpliceExplicitFlag deriving instance (DataId id) => Data (SpliceDecl id) -instance (OutputableBndrId name) => Outputable (SpliceDecl name) where - ppr (SpliceDecl (L _ e) _) = pprSplice e +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (SpliceDecl name) where + ppr (SpliceDecl (L _ e) f) = pprSpliceDecl e f {- ************************************************************************ @@ -632,7 +633,8 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars -- Pretty-printing TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~ -instance (OutputableBndrId name) => Outputable (TyClDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (TyClDecl name) where ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs }) @@ -660,7 +662,8 @@ instance (OutputableBndrId name) => Outputable (TyClDecl name) where <+> pp_vanilla_decl_head lclas tyvars (unLoc context) <+> pprFundeps (map unLoc fds) -instance (OutputableBndrId name) => Outputable (TyClGroup name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (TyClGroup name) where ppr (TyClGroup { group_tyclds = tyclds , group_roles = roles , group_instds = instds @@ -670,13 +673,21 @@ instance (OutputableBndrId name) => Outputable (TyClGroup name) where ppr roles $$ ppr instds -pp_vanilla_decl_head :: (OutputableBndrId name) +pp_vanilla_decl_head :: (OutputableBndrId name, HasOccNameId name) => Located name -> LHsQTyVars name -> HsContext name -> SDoc -pp_vanilla_decl_head thing tyvars context - = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars] +pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) context + = hsep [pprHsContext context, pp_tyvars tyvars] + where + pp_tyvars (varl:varsr) + | isSymOcc $ occName (unLoc thing) + = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) + , hsep (map (ppr.unLoc) varsr)] + | otherwise = hsep [ pprPrefixOcc (unLoc thing) + , hsep (map (ppr.unLoc) (varl:varsr))] + pp_tyvars [] = ppr thing pprTyClDeclFlavour :: TyClDecl a -> SDoc pprTyClDeclFlavour (ClassDecl {}) = text "class" @@ -944,10 +955,11 @@ resultVariableName :: FamilyResultSig a -> Maybe a resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig resultVariableName _ = Nothing -instance (OutputableBndrId name) => Outputable (FamilyDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (FamilyDecl name) where ppr = pprFamilyDecl TopLevel -pprFamilyDecl :: (OutputableBndrId name) +pprFamilyDecl :: (OutputableBndrId name, HasOccNameId name) => TopLevelFlag -> FamilyDecl name -> SDoc pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon , fdTyVars = tyvars @@ -1064,12 +1076,20 @@ data HsDerivingClause name } deriving instance (DataId id) => Data (HsDerivingClause id) -instance (OutputableBndrId name) => Outputable (HsDerivingClause name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (HsDerivingClause name) where ppr (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L _ dct }) = hsep [ text "deriving" , ppDerivStrategy dcs - , parens (interpp'SP dct) ] + , pp_dct dct ] + where + -- This complexity is to distinguish between + -- deriving Show + -- deriving (Show) + pp_dct [a@(HsIB _ (L _ HsAppsTy{}))] = parens (ppr a) + pp_dct [a] = ppr a + pp_dct _ = parens (interpp'SP dct) data NewOrData = NewType -- ^ @newtype Blah ...@ @@ -1173,42 +1193,51 @@ hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -pp_data_defn :: (OutputableBndrId name) +pp_data_defn :: (OutputableBndrId name, HasOccNameId name) => (HsContext name -> SDoc) -- Printing the header -> HsDataDefn name -> SDoc pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context + , dd_cType = mb_ct , dd_kindSig = mb_sig , dd_cons = condecls, dd_derivs = derivings }) | null condecls - = ppr new_or_data <+> pp_hdr context <+> pp_sig + = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig + <+> pp_derivings derivings | otherwise - = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig) + = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) 2 (pp_condecls condecls $$ pp_derivings derivings) where + pp_ct = case mb_ct of + Nothing -> empty + Just ct -> ppr ct pp_sig = case mb_sig of Nothing -> empty Just kind -> dcolon <+> ppr kind pp_derivings (L _ ds) = vcat (map ppr ds) -instance (OutputableBndrId name) => Outputable (HsDataDefn name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (HsDataDefn name) where ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" -pp_condecls :: (OutputableBndrId name) => [LConDecl name] -> SDoc +pp_condecls :: (OutputableBndrId name, HasOccNameId name) + => [LConDecl name] -> SDoc pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) -instance (OutputableBndrId name) => Outputable (ConDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (ConDecl name) where ppr = pprConDecl -pprConDecl :: (OutputableBndrId name) => ConDecl name -> SDoc +pprConDecl :: (OutputableBndrId name, HasOccNameId name) + => ConDecl name -> SDoc pprConDecl (ConDeclH98 { con_name = L _ con , con_qvars = mtvs , con_cxt = mcxt @@ -1411,10 +1440,11 @@ data InstDecl name -- Both class and family instances { tfid_inst :: TyFamInstDecl name } deriving instance (DataId id) => Data (InstDecl id) -instance (OutputableBndrId name) => Outputable (TyFamInstDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (TyFamInstDecl name) where ppr = pprTyFamInstDecl TopLevel -pprTyFamInstDecl :: (OutputableBndrId name) +pprTyFamInstDecl :: (OutputableBndrId name, HasOccNameId name) => TopLevelFlag -> TyFamInstDecl name -> SDoc pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn @@ -1423,22 +1453,25 @@ ppr_instance_keyword :: TopLevelFlag -> SDoc ppr_instance_keyword TopLevel = text "instance" ppr_instance_keyword NotTopLevel = empty -ppr_fam_inst_eqn :: (OutputableBndrId name) => LTyFamInstEqn name -> SDoc +ppr_fam_inst_eqn :: (OutputableBndrId name, HasOccNameId name) + => LTyFamInstEqn name -> SDoc ppr_fam_inst_eqn (L _ (TyFamEqn { tfe_tycon = tycon , tfe_pats = pats , tfe_rhs = rhs })) = pp_fam_inst_lhs tycon pats [] <+> equals <+> ppr rhs -ppr_fam_deflt_eqn :: (OutputableBndrId name) => LTyFamDefltEqn name -> SDoc +ppr_fam_deflt_eqn :: (OutputableBndrId name, HasOccNameId name) + => LTyFamDefltEqn name -> SDoc ppr_fam_deflt_eqn (L _ (TyFamEqn { tfe_tycon = tycon , tfe_pats = tvs , tfe_rhs = rhs })) = text "type" <+> pp_vanilla_decl_head tycon tvs [] <+> equals <+> ppr rhs -instance (OutputableBndrId name) => Outputable (DataFamInstDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (DataFamInstDecl name) where ppr = pprDataFamInstDecl TopLevel -pprDataFamInstDecl :: (OutputableBndrId name) +pprDataFamInstDecl :: (OutputableBndrId name, HasOccNameId name) => TopLevelFlag -> DataFamInstDecl name -> SDoc pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon , dfid_pats = pats @@ -1451,16 +1484,25 @@ pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd }) }) = ppr nd -pp_fam_inst_lhs :: (OutputableBndrId name) +pp_fam_inst_lhs :: (OutputableBndrId name, HasOccNameId name) => Located name -> HsTyPats name -> HsContext name -> SDoc -pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) context -- explicit type patterns - = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing) - , hsep (map (pprParendHsType.unLoc) typats)] - -instance (OutputableBndrId name) => Outputable (ClsInstDecl name) where +pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) context + -- explicit type patterns + = hsep [ pprHsContext context, pp_pats typats] + where + pp_pats (patl:patsr) + | isSymOcc $ occName (unLoc thing) + = hsep [pprParendHsType (unLoc patl), pprInfixOcc (unLoc thing) + , hsep (map (pprParendHsType.unLoc) patsr)] + | otherwise = hsep [ pprPrefixOcc (unLoc thing) + , hsep (map (pprParendHsType.unLoc) (patl:patsr))] + pp_pats [] = empty + +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (ClsInstDecl name) where ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds , cid_sigs = sigs, cid_tyfam_insts = ats , cid_overlap_mode = mbOverlap @@ -1488,14 +1530,18 @@ ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc ppOverlapPragma mb = case mb of Nothing -> empty - Just (L _ (NoOverlap _)) -> text "{-# NO_OVERLAP #-}" - Just (L _ (Overlappable _)) -> text "{-# OVERLAPPABLE #-}" - Just (L _ (Overlapping _)) -> text "{-# OVERLAPPING #-}" - Just (L _ (Overlaps _)) -> text "{-# OVERLAPS #-}" - Just (L _ (Incoherent _)) -> text "{-# INCOHERENT #-}" + Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}" + Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}" + Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" + Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" + Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" + where + maybe_stext NoSourceText alt = text alt + maybe_stext (SourceText src) _ = text src <+> text "#-}" -instance (OutputableBndrId name) => Outputable (InstDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (InstDecl name) where ppr (ClsInstD { cid_inst = decl }) = ppr decl ppr (TyFamInstD { tfid_inst = decl }) = ppr decl ppr (DataFamInstD { dfid_inst = decl }) = ppr decl @@ -1536,7 +1582,8 @@ data DerivDecl name = DerivDecl } deriving instance (DataId name) => Data (DerivDecl name) -instance (OutputableBndrId name) => Outputable (DerivDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (DerivDecl name) where ppr (DerivDecl { deriv_type = ty , deriv_strategy = ds , deriv_overlap_mode = o }) @@ -1570,7 +1617,8 @@ data DefaultDecl name -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (DefaultDecl name) -instance (OutputableBndrId name) => Outputable (DefaultDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (DefaultDecl name) where ppr (DefaultDecl tys) = text "default" <+> parens (interpp'SP tys) @@ -1673,7 +1721,8 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- pretty printing of foreign declarations -- -instance (OutputableBndrId name) => Outputable (ForeignDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (ForeignDecl name) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) = hang (text "foreign import" <+> ppr fimport <+> ppr n) 2 (dcolon <+> ppr ty) @@ -1682,24 +1731,32 @@ instance (OutputableBndrId name) => Outputable (ForeignDecl name) where 2 (dcolon <+> ppr ty) instance Outputable ForeignImport where - ppr (CImport cconv safety mHeader spec _) = - ppr cconv <+> ppr safety <+> - char '"' <> pprCEntity spec <> char '"' + ppr (CImport cconv safety mHeader spec (L _ srcText)) = + ppr cconv <+> ppr safety + <+> pprWithSourceText srcText (pprCEntity spec "") where pp_hdr = case mHeader of Nothing -> empty Just (Header _ header) -> ftext header - pprCEntity (CLabel lbl) = - text "static" <+> pp_hdr <+> char '&' <> ppr lbl - pprCEntity (CFunction (StaticTarget _ lbl _ isFun)) = - text "static" - <+> pp_hdr - <+> (if isFun then empty else text "value") - <+> ppr lbl - pprCEntity (CFunction (DynamicTarget)) = - text "dynamic" - pprCEntity (CWrapper) = text "wrapper" + pprCEntity (CLabel lbl) _ = + doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl + pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = + if dqNeeded then doubleQuotes ce else empty + where + dqNeeded = (take 6 src == "static") + || isJust mHeader + || not isFun + || st /= NoSourceText + ce = + -- We may need to drop leading spaces first + (if take 6 src == "static" then text "static" else empty) + <+> pp_hdr + <+> (if isFun then empty else text "value") + <+> (pprWithSourceText st empty) + pprCEntity (CFunction DynamicTarget) _ = + doubleQuotes $ text "dynamic" + pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" instance Outputable ForeignExport where ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) = @@ -1769,24 +1826,28 @@ collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] pprFullRuleName :: Located (SourceText, RuleName) -> SDoc -pprFullRuleName (L _ (_, n)) = doubleQuotes $ ftext n +pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) -instance (OutputableBndrId name) => Outputable (RuleDecls name) where - ppr (HsRules _ rules) = ppr rules +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (RuleDecls name) where + ppr (HsRules st rules) + = pprWithSourceText st (text "{-# RULES") + <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" -instance (OutputableBndrId name) => Outputable (RuleDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs _fv_lhs rhs _fv_rhs) - = sep [text "{-# RULES" <+> pprFullRuleName name - <+> ppr act, + = sep [pprFullRuleName name <+> ppr act, nest 4 (pp_forall <+> pprExpr (unLoc lhs)), - nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ] + nest 6 (equals <+> pprExpr (unLoc rhs)) ] where pp_forall | null ns = empty | otherwise = forAllLit <+> fsep (map ppr ns) <> dot -instance (OutputableBndrId name) => Outputable (RuleBndr name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name - ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty + ppr (RuleBndrSig name ty) = parens (ppr name <> dcolon <> ppr ty) {- ************************************************************************ @@ -1871,7 +1932,8 @@ lvectInstDecl (L _ (HsVectInstIn _)) = True lvectInstDecl (L _ (HsVectInstOut _)) = True lvectInstDecl _ = False -instance (OutputableBndrId name) => Outputable (VectDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (VectDecl name) where ppr (HsVect _ v rhs) = sep [text "{-# VECTORISE" <+> ppr v, nest 4 $ @@ -1960,11 +2022,14 @@ data WarnDecl name = Warning [Located name] WarningTxt deriving Data instance OutputableBndr name => Outputable (WarnDecls name) where - ppr (Warnings _ decls) = ppr decls + ppr (Warnings (SourceText src) decls) + = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" + ppr (Warnings NoSourceText _decls) = panic "WarnDecls" instance OutputableBndr name => Outputable (WarnDecl name) where ppr (Warning thing txt) - = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] + = hsep ( punctuate comma (map ppr thing)) + <+> ppr txt {- ************************************************************************ @@ -1989,7 +2054,8 @@ data AnnDecl name = HsAnnotation -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (AnnDecl name) -instance (OutputableBndrId name) => Outputable (AnnDecl name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (AnnDecl name) where ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index df60084a50..78ee4e05a0 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -22,7 +22,7 @@ import HsDecls import HsPat import HsLit import PlaceHolder ( PostTc,PostRn,DataId,DataIdPost, - NameOrRdrName,OutputableBndrId ) + NameOrRdrName,OutputableBndrId, HasOccNameId ) import HsTypes import HsBinds @@ -84,7 +84,7 @@ type PostTcExpr = HsExpr Id type PostTcTable = [(Name, PostTcExpr)] noPostTcExpr :: PostTcExpr -noPostTcExpr = HsLit (HsString "" (fsLit "noPostTcExpr")) +noPostTcExpr = HsLit (HsString NoSourceText (fsLit "noPostTcExpr")) noPostTcTable :: PostTcTable noPostTcTable = [] @@ -116,11 +116,12 @@ deriving instance (DataId id) => Data (SyntaxExpr id) -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) noExpr :: HsExpr id -noExpr = HsLit (HsString "" (fsLit "noExpr")) +noExpr = HsLit (HsString (SourceText "noExpr") (fsLit "noExpr")) noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after, -- (if the syntax slot makes no sense) -noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString "" (fsLit "noSyntaxExpr")) +noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString NoSourceText + (fsLit "noSyntaxExpr")) , syn_arg_wraps = [] , syn_res_wrap = WpHole } @@ -133,7 +134,8 @@ mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name -- don't care about filling in syn_arg_wraps because we're clearly -- not past the typechecker -instance (OutputableBndrId id) => Outputable (SyntaxExpr id) where +instance (OutputableBndrId id, HasOccNameId id) + => Outputable (SyntaxExpr id) where ppr (SyntaxExpr { syn_expr = expr , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) @@ -769,16 +771,17 @@ RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. -} -instance (OutputableBndrId id) => Outputable (HsExpr id) where +instance (OutputableBndrId id, HasOccNameId id) + => Outputable (HsExpr id) where ppr expr = pprExpr expr ----------------------- -- pprExpr, pprLExpr, pprBinds call pprDeeper; -- the underscore versions do not -pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +pprLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc pprLExpr (L _ e) = pprExpr e -pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc +pprExpr :: (OutputableBndrId id,HasOccNameId id) => HsExpr id -> SDoc pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e | otherwise = pprDeeper (ppr_expr e) @@ -794,15 +797,17 @@ isQuietHsExpr (HsAppTypeOut _ _) = True isQuietHsExpr (OpApp _ _ _ _) = True isQuietHsExpr _ = False -pprBinds :: (OutputableBndrId idL, OutputableBndrId idR) +pprBinds :: (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR) => HsLocalBindsLR idL idR -> SDoc pprBinds b = pprDeeper (ppr b) ----------------------- -ppr_lexpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +ppr_lexpr :: (OutputableBndrId id,HasOccNameId id) => LHsExpr id -> SDoc ppr_lexpr e = ppr_expr (unLoc e) -ppr_expr :: forall id. (OutputableBndrId id) => HsExpr id -> SDoc +ppr_expr :: forall id. (OutputableBndrId id,HasOccNameId id) + => HsExpr id -> SDoc ppr_expr (HsVar (L _ v)) = pprPrefixOcc v ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv) ppr_expr (HsIPVar v) = ppr v @@ -811,8 +816,10 @@ ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit ppr_expr (HsPar e) = parens (ppr_lexpr e) -ppr_expr (HsCoreAnn _ (StringLiteral _ s) e) - = vcat [text "HsCoreAnn" <+> ftext s, ppr_lexpr e] +ppr_expr (HsCoreAnn stc (StringLiteral sta s) e) + = vcat [pprWithSourceText stc (text "{-# CORE") + <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" + , ppr_lexpr e] ppr_expr e@(HsApp {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e [] @@ -831,7 +838,7 @@ ppr_expr (OpApp e1 op _ e2) = hang (ppr op) 2 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]] + = hang pp_e1 2 (sep [pprInfixOcc v, nest 2 pp_e2]) ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e @@ -877,12 +884,15 @@ ppr_expr (HsLam matches) = pprMatches matches ppr_expr (HsLamCase matches) - = sep [ sep [text "\\case {"], - nest 2 (pprMatches matches <+> char '}') ] + = sep [ sep [text "\\case"], + nest 2 (pprMatches matches) ] -ppr_expr (HsCase expr matches) +ppr_expr (HsCase expr matches@(MG { mg_alts = L _ [_] })) = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], - nest 2 (pprMatches matches <+> char '}') ] + nest 2 (pprMatches matches) <+> char '}'] +ppr_expr (HsCase expr matches) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + nest 2 (pprMatches matches) ] ppr_expr (HsIf _ e1 e2 e3) = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], @@ -891,10 +901,14 @@ ppr_expr (HsIf _ e1 e2 e3) nest 4 (ppr e3)] ppr_expr (HsMultiIf _ alts) - = sep $ text "if" : map ppr_alt alts + = hang (text "if") 3 (vcat (map ppr_alt alts)) where ppr_alt (L _ (GRHS guards expr)) = - sep [ vbar <+> interpp'SP guards - , text "->" <+> pprDeeper (ppr expr) ] + hang vbar 2 (ppr_one one_alt) + where + ppr_one [] = panic "ppr_exp HsMultiIf" + ppr_one (h:t) = hang h 2 (sep t) + one_alt = [ interpp'SP guards + , text "->" <+> pprDeeper (ppr expr) ] -- special case: let ... in let ... ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _))) @@ -934,8 +948,11 @@ ppr_expr (ELazyPat e) = char '~' <> pprParendLExpr e ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendLExpr e ppr_expr (EViewPat p e) = ppr p <+> text "->" <+> ppr e -ppr_expr (HsSCC _ (StringLiteral _ lbl) expr) - = sep [ text "{-# SCC" <+> doubleQuotes (ftext lbl) <+> ptext (sLit "#-}"), +ppr_expr (HsSCC st (StringLiteral stl lbl) expr) + = sep [ pprWithSourceText st (text "{-# SCC") + -- no doublequotes if stl empty, for the case where the SCC was written + -- without quotes. + <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", pprParendLExpr expr ] ppr_expr (HsWrap co_fn e) @@ -993,9 +1010,10 @@ ppr_expr (HsRecFld f) = ppr f -- We must tiresomely make the "id" parameter to the LHsWcType existential -- because it's different in the HsAppType case and the HsAppTypeOut case -- | Located Haskell Wildcard Type Expression -data LHsWcTypeX = forall id. (OutputableBndrId id) => LHsWcTypeX (LHsWcType id) +data LHsWcTypeX = forall id. (OutputableBndrId id, HasOccNameId id) + => LHsWcTypeX (LHsWcType id) -ppr_apps :: (OutputableBndrId id) +ppr_apps :: (OutputableBndrId id,HasOccNameId id) => HsExpr id -> [Either (LHsExpr id) LHsWcTypeX] -> SDoc @@ -1027,16 +1045,17 @@ fixities should do the job, except in debug mode (-dppr-debug) so we can see the structure of the parse tree. -} -pprDebugParendExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +pprDebugParendExpr :: (OutputableBndrId id, HasOccNameId id) + => LHsExpr id -> SDoc pprDebugParendExpr expr = getPprStyle (\sty -> if debugStyle sty then pprParendLExpr expr else pprLExpr expr) -pprParendLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +pprParendLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc pprParendLExpr (L _ e) = pprParendExpr e -pprParendExpr :: (OutputableBndrId id) => HsExpr id -> SDoc +pprParendExpr :: (OutputableBndrId id, HasOccNameId id) => HsExpr id -> SDoc pprParendExpr expr | hsExprNeedsParens expr = parens (pprExpr expr) | otherwise = pprExpr expr @@ -1064,6 +1083,9 @@ hsExprNeedsParens (HsTcBracketOut {}) = False hsExprNeedsParens (HsDo sc _ _) | isListCompExpr sc = False hsExprNeedsParens (HsRecFld{}) = False +hsExprNeedsParens (RecordCon{}) = False +hsExprNeedsParens (HsSpliceE{}) = False +hsExprNeedsParens (RecordUpd{}) = False hsExprNeedsParens _ = True @@ -1114,9 +1136,11 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) - (LHsExpr id) -- the operator - -- after type-checking, a type abstraction to be + (LHsExpr id) -- The operator. + -- After type-checking, a type abstraction to be -- applied to the type of the local environment tuple + FunctionFixity -- Whether the operator appeared prefix or infix when + -- parsed. (Maybe Fixity) -- fixity (filled in by the renamer), for forms that -- were converted from OpApp's by the renamer [LHsCmdTop id] -- argument commands @@ -1199,16 +1223,17 @@ data HsCmdTop id (CmdSyntaxTable id) -- See Note [CmdSyntaxTable] deriving instance (DataId id) => Data (HsCmdTop id) -instance (OutputableBndrId id) => Outputable (HsCmd id) where +instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsCmd id) where ppr cmd = pprCmd cmd ----------------------- -- pprCmd and pprLCmd call pprDeeper; -- the underscore versions do not -pprLCmd :: (OutputableBndrId id) => LHsCmd id -> SDoc +pprLCmd :: (OutputableBndrId id, HasOccName id, HasOccName (NameOrRdrName id)) + => LHsCmd id -> SDoc pprLCmd (L _ c) = pprCmd c -pprCmd :: (OutputableBndrId id) => HsCmd id -> SDoc +pprCmd :: (OutputableBndrId id, HasOccNameId id) => HsCmd id -> SDoc pprCmd c | isQuietHsCmd c = ppr_cmd c | otherwise = pprDeeper (ppr_cmd c) @@ -1222,10 +1247,11 @@ isQuietHsCmd (HsCmdApp _ _) = True isQuietHsCmd _ = False ----------------------- -ppr_lcmd :: (OutputableBndrId id) => LHsCmd id -> SDoc +ppr_lcmd :: (OutputableBndrId id, HasOccNameId id) => LHsCmd id -> SDoc ppr_lcmd c = ppr_cmd (unLoc c) -ppr_cmd :: forall id. (OutputableBndrId id) => HsCmd id -> SDoc +ppr_cmd :: forall id. (OutputableBndrId id, HasOccNameId id) + => HsCmd id -> SDoc ppr_cmd (HsCmdPar c) = parens (ppr_lcmd c) ppr_cmd (HsCmdApp c e) @@ -1239,8 +1265,8 @@ ppr_cmd (HsCmdLam matches) = pprMatches matches ppr_cmd (HsCmdCase expr matches) - = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], - nest 2 (pprMatches matches <+> char '}') ] + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + nest 2 (pprMatches matches) ] ppr_cmd (HsCmdIf _ e ct ce) = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], @@ -1270,19 +1296,22 @@ ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True) ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False) = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] -ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2]) - = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]] -ppr_cmd (HsCmdArrForm op _ args) +ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) _ (Just _) [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) Infix _ [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm op _ _ args) = hang (text "(|" <> ppr_lexpr op) 4 (sep (map (pprCmdArg.unLoc) args) <> text "|)") -pprCmdArg :: (OutputableBndrId id) => HsCmdTop id -> SDoc -pprCmdArg (HsCmdTop cmd@(L _ (HsCmdArrForm _ Nothing [])) _ _ _) - = ppr_lcmd cmd +pprCmdArg :: (OutputableBndrId id, HasOccNameId id) => HsCmdTop id -> SDoc pprCmdArg (HsCmdTop cmd _ _ _) - = parens (ppr_lcmd cmd) + = ppr_lcmd cmd -instance (OutputableBndrId id) => Outputable (HsCmdTop id) where +instance (OutputableBndrId id, HasOccNameId id) + => Outputable (HsCmdTop id) where ppr = pprCmdArg {- @@ -1347,7 +1376,7 @@ data Match id body } deriving instance (Data body,DataId id) => Data (Match id body) -instance (OutputableBndrId idR, Outputable body) +instance (OutputableBndrId idR, HasOccNameId idR, Outputable body) => Outputable (Match idR body) where ppr = pprMatch @@ -1442,25 +1471,29 @@ deriving instance (Data body,DataId id) => Data (GRHS id body) -- We know the list must have at least one @Match@ in it. -pprMatches :: (OutputableBndrId idR, Outputable body) +pprMatches :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) => MatchGroup idR body -> SDoc pprMatches MG { mg_alts = matches } = vcat (map pprMatch (map unLoc (unLoc matches))) -- Don't print the type; it's only a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndrId idR, Outputable body) +pprFunBind :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) => MatchGroup idR body -> SDoc pprFunBind matches = pprMatches matches -- Exported to HsBinds, which can't see the defn of HsMatchContext pprPatBind :: forall bndr id body. (OutputableBndrId bndr, - OutputableBndrId id, Outputable body) + OutputableBndrId id, + HasOccNameId id, + HasOccNameId bndr, + Outputable body) => LPat bndr -> GRHSs id body -> SDoc pprPatBind pat (grhss) = sep [ppr pat, nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)] -pprMatch :: (OutputableBndrId idR, Outputable body) => Match idR body -> SDoc +pprMatch :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) + => Match idR body -> SDoc pprMatch match = sep [ sep (herald : map (nest 2 . pprParendLPat) other_pats) , nest 2 ppr_maybe_ty @@ -1495,14 +1528,16 @@ pprMatch match Nothing -> empty -pprGRHSs :: (OutputableBndrId idR, Outputable body) +pprGRHSs :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) => HsMatchContext idL -> GRHSs idR body -> SDoc pprGRHSs ctxt (GRHSs grhss (L _ binds)) = vcat (map (pprGRHS ctxt . unLoc) grhss) - $$ ppUnless (isEmptyLocalBinds binds) + -- Print the "where" even if the contents of the binds is empty. Only + -- EmptyLocalBinds means no "where" keyword + $$ ppUnless (eqEmptyLocalBinds binds) (text "where" $$ nest 4 (pprBinds binds)) -pprGRHS :: (OutputableBndrId idR, Outputable body) +pprGRHS :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) => HsMatchContext idL -> GRHS idR body -> SDoc pprGRHS ctxt (GRHS [] body) = pp_rhs ctxt body @@ -1848,14 +1883,17 @@ In any other context than 'MonadComp', the fields for most of these 'SyntaxExpr's stay bottom. -} -instance (OutputableBndrId idL) => Outputable (ParStmtBlock idL idR) where +instance (OutputableBndrId idL, HasOccNameId idL) + => Outputable (ParStmtBlock idL idR) where ppr (ParStmtBlock stmts _ _) = interpp'SP stmts -instance (OutputableBndrId idL, OutputableBndrId idR, Outputable body) +instance (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR, Outputable body) => Outputable (StmtLR idL idR body) where ppr stmt = pprStmt stmt pprStmt :: forall idL idR body . (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR, Outputable body) => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr ret_stripped _) @@ -1886,7 +1924,7 @@ pprStmt (ApplicativeStmt args mb_join _) -- make all the Applicative stuff invisible in error messages by -- flattening the whole ApplicativeStmt nest back to a sequence -- of statements. - pp_for_user = vcat $ punctuate semi $ concatMap flattenArg args + pp_for_user = vcat $ concatMap flattenArg args -- ppr directly rather than transforming here, because we need to -- inject a "return" which is hard when we're polymorphic in the id @@ -1919,7 +1957,7 @@ pprStmt (ApplicativeStmt args mb_join _) (stmts ++ [noLoc (LastStmt (noLoc return) False noSyntaxExpr)])) (error "pprStmt")) -pprTransformStmt :: (OutputableBndrId id) +pprTransformStmt :: (OutputableBndrId id, HasOccNameId id) => [id] -> LHsExpr id -> Maybe (LHsExpr id) -> SDoc pprTransformStmt bndrs using by = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs)) @@ -1936,7 +1974,7 @@ pprBy :: Outputable body => Maybe body -> SDoc pprBy Nothing = empty pprBy (Just e) = text "by" <+> ppr e -pprDo :: (OutputableBndrId id, Outputable body) +pprDo :: (OutputableBndrId id, HasOccNameId id, Outputable body) => HsStmtContext any -> [LStmt id body] -> SDoc pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts @@ -1947,15 +1985,13 @@ pprDo PArrComp stmts = paBrackets $ pprComp stmts pprDo MonadComp stmts = brackets $ pprComp stmts pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) +ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR, Outputable body) => [LStmtLR idL idR body] -> SDoc --- Print a bunch of do stmts, with explicit braces and semicolons, --- so that we are not vulnerable to layout bugs -ppr_do_stmts stmts - = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) - <+> rbrace +-- Print a bunch of do stmts +ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) -pprComp :: (OutputableBndrId id, Outputable body) +pprComp :: (OutputableBndrId id, HasOccNameId id, Outputable body) => [LStmt id body] -> SDoc pprComp quals -- Prints: body | qual1, ..., qualn | Just (initStmts, L _ (LastStmt body _ _)) <- snocView quals @@ -1970,7 +2006,7 @@ pprComp quals -- Prints: body | qual1, ..., qualn | otherwise = pprPanic "pprComp" (pprQuals quals) -pprQuals :: (OutputableBndrId id, Outputable body) +pprQuals :: (OutputableBndrId id, HasOccNameId id, Outputable body) => [LStmt id body] -> SDoc -- Show list comprehension qualifiers separated by commas pprQuals quals = interpp'SP quals @@ -1986,10 +2022,12 @@ pprQuals quals = interpp'SP quals -- | Haskell Splice data HsSplice id = HsTypedSplice -- $$z or $$(f 4) + HasParens -- Whether $$( ) variant found, for pretty printing id -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] | HsUntypedSplice -- $z or $(f 4) + HasParens -- Whether $( ) variant found, for pretty printing id -- A unique name to identify this splice point (LHsExpr id) -- See Note [Pending Splices] @@ -2007,9 +2045,17 @@ data HsSplice id ThModFinalizers -- TH finalizers produced by the splice. (HsSplicedThing id) -- The result of splicing deriving Typeable - deriving instance (DataId id) => Data (HsSplice id) +data HasParens = HasParens + | NoParens + deriving (Data, Eq, Show) + +instance Outputable HasParens where + ppr HasParens = text "HasParens" + ppr NoParens = text "NoParens" + + isTypedSplice :: HsSplice id -> Bool isTypedSplice (HsTypedSplice {}) = True isTypedSplice _ = False -- Quasi-quotes are untyped splices @@ -2135,41 +2181,53 @@ splices. In contrast, when pretty printing the output of the type checker, we sense, although I hate to add another constructor to HsExpr. -} -instance OutputableBndrId id => Outputable (HsSplicedThing id) where +instance (OutputableBndrId id, HasOccNameId id) + => Outputable (HsSplicedThing id) where ppr (HsSplicedExpr e) = ppr_expr e ppr (HsSplicedTy t) = ppr t ppr (HsSplicedPat p) = ppr p -instance (OutputableBndrId id) => Outputable (HsSplice id) where +instance (OutputableBndrId id, HasOccNameId id) + => Outputable (HsSplice id) where ppr s = pprSplice s -pprPendingSplice :: (OutputableBndrId id) +pprPendingSplice :: (OutputableBndrId id, HasOccNameId id) => SplicePointName -> LHsExpr id -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) -pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc -pprSplice (HsTypedSplice n e) = ppr_splice (text "$$") n e -pprSplice (HsUntypedSplice n e) = ppr_splice (text "$") n e -pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s -pprSplice (HsSpliced _ thing) = ppr thing +pprSpliceDecl :: (OutputableBndrId id, HasOccNameId id) + => HsSplice id -> SpliceExplicitFlag -> SDoc +pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e +pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" +pprSpliceDecl e ImplicitSplice = ppr_splice_decl e + +ppr_splice_decl :: (OutputableBndrId id, HasOccNameId id) + => HsSplice id -> SDoc +ppr_splice_decl (HsUntypedSplice _ n e) = ppr_splice empty n e empty +ppr_splice_decl e = pprSplice e + +pprSplice :: (OutputableBndrId id, HasOccNameId id) + => HsSplice id -> SDoc +pprSplice (HsTypedSplice HasParens n e) + = ppr_splice (text "$$(") n e (text ")") +pprSplice (HsTypedSplice NoParens n e) + = ppr_splice (text "$$") n e empty +pprSplice (HsUntypedSplice HasParens n e) + = ppr_splice (text "$(") n e (text ")") +pprSplice (HsUntypedSplice NoParens n e) + = ppr_splice (text "$") n e empty +pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s +pprSplice (HsSpliced _ thing) = ppr thing ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" -ppr_splice :: (OutputableBndrId id) => SDoc -> id -> LHsExpr id -> SDoc -ppr_splice herald n e - = herald <> ifPprDebug (brackets (ppr n)) <> eDoc - where - -- We use pprLExpr to match pprParendLExpr: - -- Using pprLExpr makes sure that we go 'deeper' - -- I think that is usually (always?) right - pp_as_was = pprLExpr e - eDoc = case unLoc e of - HsPar _ -> pp_as_was - HsVar _ -> pp_as_was - _ -> parens pp_as_was +ppr_splice :: (OutputableBndrId id, HasOccNameId id) + => SDoc -> id -> LHsExpr id -> SDoc -> SDoc +ppr_splice herald n e trail + = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail -- | Haskell Bracket data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] @@ -2186,18 +2244,21 @@ isTypedBracket :: HsBracket id -> Bool isTypedBracket (TExpBr {}) = True isTypedBracket _ = False -instance (OutputableBndrId id) => Outputable (HsBracket id) where +instance (OutputableBndrId id, HasOccNameId id) + => Outputable (HsBracket id) where ppr = pprHsBracket -pprHsBracket :: (OutputableBndrId id) => HsBracket id -> SDoc +pprHsBracket :: (OutputableBndrId id, HasOccNameId id) => HsBracket id -> SDoc pprHsBracket (ExpBr e) = thBrackets empty (ppr e) pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr True n) = char '\'' <> ppr n -pprHsBracket (VarBr False n) = text "''" <> ppr n +pprHsBracket (VarBr True n) + = char '\'' <> pprPrefixVar (isSymOcc $ occName n) (ppr n) +pprHsBracket (VarBr False n) + = text "''" <> pprPrefixVar (isSymOcc $ occName n) (ppr n) pprHsBracket (TExpBr e) = thTyBrackets (ppr e) thBrackets :: SDoc -> SDoc -> SDoc @@ -2233,7 +2294,8 @@ data ArithSeqInfo id (LHsExpr id) deriving instance (DataId id) => Data (ArithSeqInfo id) -instance (OutputableBndrId id) => Outputable (ArithSeqInfo id) where +instance (OutputableBndrId id, HasOccName id, HasOccName (NameOrRdrName id)) + => Outputable (ArithSeqInfo id) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] @@ -2420,7 +2482,7 @@ matchContextErrString (StmtCtxt ListComp) = text "list comprehension" matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" matchContextErrString (StmtCtxt PArrComp) = text "array comprehension" -pprMatchInCtxt :: (OutputableBndrId idR, +pprMatchInCtxt :: (OutputableBndrId idR, HasOccNameId idR, Outputable (NameOrRdrName (NameOrRdrName idR)), Outputable body) => Match idR body -> SDoc @@ -2428,7 +2490,9 @@ pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) <> colon) 4 (pprMatch match) -pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) +pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, + HasOccNameId idL, HasOccNameId idR, + Outputable body) => HsStmtContext idL -> StmtLR idL idR body -> SDoc pprStmtInCtxt ctxt (LastStmt e _ _) | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot index 022ca6bbc4..070465e1cc 100644 --- a/compiler/hsSyn/HsExpr.hs-boot +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -10,7 +10,8 @@ module HsExpr where import SrcLoc ( Located ) import Outputable ( SDoc, Outputable ) import {-# SOURCE #-} HsPat ( LPat ) -import PlaceHolder ( DataId, OutputableBndrId ) +import BasicTypes ( SpliceExplicitFlag(..)) +import PlaceHolder ( DataId, OutputableBndrId, HasOccNameId ) import Data.Data hiding ( Fixity ) type role HsExpr nominal @@ -33,20 +34,27 @@ instance (Data body,DataId id) => Data (MatchGroup id body) instance (Data body,DataId id) => Data (GRHSs id body) instance (DataId id) => Data (SyntaxExpr id) -instance (OutputableBndrId id) => Outputable (HsExpr id) -instance (OutputableBndrId id) => Outputable (HsCmd id) +instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsExpr id) +instance (OutputableBndrId id, HasOccNameId id) => Outputable (HsCmd id) type LHsExpr a = Located (HsExpr a) -pprLExpr :: (OutputableBndrId id) => LHsExpr id -> SDoc +pprLExpr :: (OutputableBndrId id, HasOccNameId id) => LHsExpr id -> SDoc -pprExpr :: (OutputableBndrId id) => HsExpr id -> SDoc +pprExpr :: (OutputableBndrId id,HasOccNameId id) => HsExpr id -> SDoc -pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc +pprSplice :: (OutputableBndrId id, HasOccNameId id) + => HsSplice id -> SDoc + +pprSpliceDecl :: (OutputableBndrId id, HasOccNameId id) + => HsSplice id -> SpliceExplicitFlag -> SDoc pprPatBind :: (OutputableBndrId bndr, - OutputableBndrId id, Outputable body) + OutputableBndrId id, + HasOccNameId id, + HasOccNameId bndr, + Outputable body) => LPat bndr -> GRHSs id body -> SDoc -pprFunBind :: (OutputableBndrId idR, Outputable body) +pprFunBind :: (OutputableBndrId idR, HasOccNameId idR, Outputable body) => MatchGroup idR body -> SDoc diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs index 011a80af22..8641f1ff3f 100644 --- a/compiler/hsSyn/HsImpExp.hs +++ b/compiler/hsSyn/HsImpExp.hs @@ -12,8 +12,8 @@ module HsImpExp where import Module ( ModuleName ) import HsDoc ( HsDocString ) -import OccName ( HasOccName(..), isTcOcc, isSymOcc ) -import BasicTypes ( SourceText, StringLiteral(..) ) +import OccName ( HasOccName(..), isTcOcc, isSymOcc, isDataOcc ) +import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) import FieldLabel ( FieldLbl(..) ) import Outputable @@ -45,7 +45,7 @@ type LImportDecl name = Located (ImportDecl name) -- A single Haskell @import@ declaration. data ImportDecl name = ImportDecl { - ideclSourceSrc :: Maybe SourceText, + ideclSourceSrc :: SourceText, -- Note [Pragma source text] in BasicTypes ideclName :: Located ModuleName, -- ^ Module name. ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. @@ -77,7 +77,7 @@ data ImportDecl name simpleImportDecl :: ModuleName -> ImportDecl name simpleImportDecl mn = ImportDecl { - ideclSourceSrc = Nothing, + ideclSourceSrc = NoSourceText, ideclName = noLoc mn, ideclPkgQual = Nothing, ideclSource = False, @@ -89,7 +89,8 @@ simpleImportDecl mn = ImportDecl { } instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) where - ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg + ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' + , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe , ideclQualified = qual, ideclImplicit = implicit , ideclAs = as, ideclHiding = spec }) @@ -100,8 +101,9 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) pp_implicit False = empty pp_implicit True = ptext (sLit ("(implicit)")) - pp_pkg Nothing = empty - pp_pkg (Just (StringLiteral _ p)) = doubleQuotes (ftext p) + pp_pkg Nothing = empty + pp_pkg (Just (StringLiteral st p)) + = pprWithSourceText st (doubleQuotes (ftext p)) pp_qual False = empty pp_qual True = text "qualified" @@ -112,7 +114,9 @@ instance (OutputableBndr name, HasOccName name) => Outputable (ImportDecl name) pp_as Nothing = empty pp_as (Just a) = text "as" <+> ppr a - ppr_imp True = text "{-# SOURCE #-}" + ppr_imp True = case mSrcText of + NoSourceText -> text "{-# SOURCE #-}" + SourceText src -> text src <+> text "#-}" ppr_imp False = empty pp_spec Nothing = empty @@ -241,7 +245,10 @@ pprImpExp name = type_pref <+> pprPrefixOcc name | otherwise = empty instance (HasOccName name, OutputableBndr name) => Outputable (IE name) where - ppr (IEVar var) = pprPrefixOcc (unLoc var) + ppr (IEVar var) + -- This is a messy test, should perhaps create IEPatternVar + = (if isDataOcc $ occName $ unLoc var then text "pattern" else empty) + <+> pprPrefixOcc (unLoc var) ppr (IEThingAbs thing) = pprImpExp (unLoc thing) ppr (IEThingAll thing) = hcat [pprImpExp (unLoc thing), text "(..)"] ppr (IEThingWith thing wc withs flds) diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 4cf571917c..e513fe9e00 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -19,11 +19,11 @@ module HsLit where #include "HsVersions.h" import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) -import BasicTypes ( FractionalLit(..),SourceText ) +import BasicTypes ( FractionalLit(..),SourceText(..),pprWithSourceText ) import Type ( Type ) import Outputable import FastString -import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) +import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId, HasOccNameId ) import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -166,29 +166,34 @@ instance Ord OverLitVal where compare (HsIsString _ _) (HsFractional _) = GT instance Outputable HsLit where - ppr (HsChar _ c) = pprHsChar c - ppr (HsCharPrim _ c) = pprPrimChar c - ppr (HsString _ s) = pprHsString s - ppr (HsStringPrim _ s) = pprHsBytes s - ppr (HsInt _ i) = integer i - ppr (HsInteger _ i _) = integer i - ppr (HsRat f _) = ppr f - ppr (HsFloatPrim f) = ppr f <> primFloatSuffix - ppr (HsDoublePrim d) = ppr d <> primDoubleSuffix - ppr (HsIntPrim _ i) = pprPrimInt i - ppr (HsWordPrim _ w) = pprPrimWord w - ppr (HsInt64Prim _ i) = pprPrimInt64 i - ppr (HsWord64Prim _ w) = pprPrimWord64 w + ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) + ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) + ppr (HsString st s) = pprWithSourceText st (pprHsString s) + ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) + ppr (HsInt st i) = pprWithSourceText st (integer i) + ppr (HsInteger st i _) = pprWithSourceText st (integer i) + ppr (HsRat f _) = ppr f + ppr (HsFloatPrim f) = ppr f <> primFloatSuffix + ppr (HsDoublePrim d) = ppr d <> primDoubleSuffix + ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) + ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) + ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) + ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) + +pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc +pp_st_suffix NoSourceText _ doc = doc +pp_st_suffix (SourceText st) suffix _ = text st <> suffix -- in debug mode, print the expression that it's resolved to, too -instance (OutputableBndrId id) => Outputable (HsOverLit id) where +instance (OutputableBndrId id, HasOccNameId id) + => Outputable (HsOverLit id) where ppr (OverLit {ol_val=val, ol_witness=witness}) = ppr val <+> (ifPprDebug (parens (pprExpr witness))) instance Outputable OverLitVal where - ppr (HsIntegral _ i) = integer i + ppr (HsIntegral st i) = pprWithSourceText st (integer i) ppr (HsFractional f) = ppr f - ppr (HsIsString _ s) = pprHsString s + ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern -- match warnings. All are printed the same (i.e., without hashes if they are @@ -199,7 +204,7 @@ instance Outputable OverLitVal where pmPprHsLit :: HsLit -> SDoc pmPprHsLit (HsChar _ c) = pprHsChar c pmPprHsLit (HsCharPrim _ c) = pprHsChar c -pmPprHsLit (HsString _ s) = pprHsString s +pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) pmPprHsLit (HsStringPrim _ s) = pprHsBytes s pmPprHsLit (HsInt _ i) = integer i pmPprHsLit (HsIntPrim _ i) = integer i diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index ec5578f36d..853e8cb70d 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -409,7 +409,8 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl ************************************************************************ -} -instance (OutputableBndrId name) => Outputable (Pat name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (Pat name) where ppr = pprPat pprPatBndr :: OutputableBndr name => name -> SDoc @@ -421,10 +422,11 @@ pprPatBndr var -- Print with type info if -dppr-debug is on else pprPrefixOcc var -pprParendLPat :: (OutputableBndrId name) => LPat name -> SDoc +pprParendLPat :: (OutputableBndrId name, HasOccNameId name) + => LPat name -> SDoc pprParendLPat (L _ p) = pprParendPat p -pprParendPat :: (OutputableBndrId name) => Pat name -> SDoc +pprParendPat :: (OutputableBndrId name, HasOccNameId name) => Pat name -> SDoc pprParendPat p = sdocWithDynFlags $ \ dflags -> if need_parens dflags p then parens (pprPat p) @@ -438,7 +440,7 @@ pprParendPat p = sdocWithDynFlags $ \ dflags -> -- But otherwise the CoPat is discarded, so it -- is the pattern inside that matters. Sigh. -pprPat :: (OutputableBndrId name) => Pat name -> SDoc +pprPat :: (OutputableBndrId name, HasOccNameId name) => Pat name -> SDoc pprPat (VarPat (L _ var)) = pprPatBndr var pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> pprParendLPat pat @@ -475,12 +477,13 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, else pprUserCon (unLoc con) details -pprUserCon :: (OutputableBndr con, OutputableBndrId id) +pprUserCon :: (OutputableBndr con, OutputableBndrId id, HasOccNameId id) => con -> HsConPatDetails id -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details = pprPrefixOcc c <+> pprConArgs details -pprConArgs :: (OutputableBndrId id) => HsConPatDetails id -> SDoc +pprConArgs :: (OutputableBndrId id, HasOccNameId id) + => HsConPatDetails id -> SDoc pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats) pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2] pprConArgs (RecCon rpats) = ppr rpats @@ -519,7 +522,7 @@ mkPrefixConPat dc pats tys mkNilPat :: Type -> OutPat id mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] -mkCharLitPat :: String -> Char -> OutPat id +mkCharLitPat :: SourceText -> Char -> OutPat id mkCharLitPat src c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim src c)] [] @@ -595,7 +598,7 @@ looksLazyLPat (L _ (VarPat {})) = False looksLazyLPat (L _ (WildPat {})) = False looksLazyLPat _ = True -isIrrefutableHsPat :: (OutputableBndrId id) => LPat id -> Bool +isIrrefutableHsPat :: (OutputableBndrId id, HasOccNameId id) => LPat id -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- in the sense of falling through to the next pattern. -- (NB: this is not quite the same as the (silly) defn @@ -670,9 +673,9 @@ hsPatNeedsParens (LitPat {}) = False hsPatNeedsParens (NPat {}) = False conPatNeedsParens :: HsConDetails a b -> Bool -conPatNeedsParens (PrefixCon args) = not (null args) -conPatNeedsParens (InfixCon {}) = True -conPatNeedsParens (RecCon {}) = True +conPatNeedsParens (PrefixCon {}) = False +conPatNeedsParens (InfixCon {}) = True +conPatNeedsParens (RecCon {}) = False {- % Collect all EvVars from all constructor patterns diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot index aba5686085..8bcaa5a1e0 100644 --- a/compiler/hsSyn/HsPat.hs-boot +++ b/compiler/hsSyn/HsPat.hs-boot @@ -10,11 +10,11 @@ import SrcLoc( Located ) import Data.Data hiding (Fixity) import Outputable -import PlaceHolder ( DataId, OutputableBndrId ) +import PlaceHolder ( DataId, OutputableBndrId,HasOccNameId ) type role Pat nominal data Pat (i :: *) type LPat i = Located (Pat i) instance (DataId id) => Data (Pat id) -instance (OutputableBndrId name) => Outputable (Pat name) +instance (OutputableBndrId name, HasOccNameId name) => Outputable (Pat name) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index 1e5a4bb273..93e43546a9 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -46,7 +46,6 @@ import HsUtils import HsDoc -- others: -import OccName ( HasOccName ) import Outputable import SrcLoc import Module ( ModuleName ) @@ -109,7 +108,7 @@ data HsModule name -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (HsModule name) -instance (OutputableBndrId name, HasOccName name) +instance (OutputableBndrId name, HasOccNameId name) => Outputable (HsModule name) where ppr (HsModule Nothing _ imports decls _ mbDoc) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 6d82f92474..e3e5246f4b 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -24,6 +24,7 @@ module HsTypes ( HsWildCardBndrs(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), + Promoted(..), HsContext, LHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, @@ -70,7 +71,7 @@ module HsTypes ( import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..), - OutputableBndrId ) + OutputableBndrId, HasOccNameId ) import Id ( Id ) import Name( Name ) @@ -112,7 +113,7 @@ getBangType ty = ty getBangStrictness :: LHsType a -> HsSrcBang getBangStrictness (L _ (HsBangTy s _)) = s -getBangStrictness _ = (HsSrcBang Nothing NoSrcUnpack NoSrcStrict) +getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) {- ************************************************************************ @@ -432,7 +433,9 @@ data HsType name { hst_ctxt :: LHsContext name -- Context C => blah , hst_body :: LHsType name } - | HsTyVar (Located name) + | HsTyVar Promoted -- whether explictly promoted, for the pretty + -- printer + (Located name) -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] -- See Note [Located RdrNames] in HsExpr @@ -440,7 +443,7 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation - | HsAppsTy [LHsAppType name] -- Used only before renaming, + | HsAppsTy [LHsAppType name] -- Used only before renaming, -- Note [HsAppsTy] -- ^ - 'ApiAnnotation.AnnKeywordId' : None @@ -555,6 +558,7 @@ data HsType name -- For details on above see note [Api annotations] in ApiAnnotation | HsExplicitListTy -- A promoted explicit list + Promoted -- whether explcitly promoted, for pretty printer (PostTc name Kind) -- See Note [Promoted lists and tuples] [LHsType name] -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, @@ -606,7 +610,8 @@ data HsAppType name | HsAppPrefix (LHsType name) -- anything else, including things like (+) deriving instance (DataId name) => Data (HsAppType name) -instance (OutputableBndrId name) => Outputable (HsAppType name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (HsAppType name) where ppr = ppr_app_ty TopPrec {- @@ -661,6 +666,9 @@ HsTyVar: A name in a type or kind. Tv: kind variable TcCls: kind constructor or promoted type constructor + The 'Promoted' field in an HsTyVar captures whether the type was promoted in + the source code by prefixing an apostrophe. + Note [HsAppsTy] ~~~~~~~~~~~~~~~ How to parse @@ -724,6 +732,11 @@ data HsTupleSort = HsUnboxedTuple deriving Data +-- | Promoted data types. +data Promoted = Promoted + | NotPromoted + deriving (Data, Eq, Show) + -- | Located Constructor Declaration Field type LConDeclField name = Located (ConDeclField name) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when @@ -742,7 +755,8 @@ data ConDeclField name -- Record fields have Haddoc docs on them -- For details on above see note [Api annotations] in ApiAnnotation deriving instance (DataId name) => Data (ConDeclField name) -instance (OutputableBndrId name) => Outputable (ConDeclField name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (ConDeclField name) where ppr (ConDeclField fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty -- HsConDetails is used for patterns/expressions *and* for data type @@ -873,9 +887,9 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name hsLTyVarBndrToType = fmap cvt - where cvt (UserTyVar n) = HsTyVar n + where cvt (UserTyVar n) = HsTyVar NotPromoted n cvt (KindedTyVar (L name_loc n) kind) - = HsKindSig (L name_loc (HsTyVar (L name_loc n))) kind + = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. @@ -942,7 +956,7 @@ splitHsFunType (L _ (HsFunTy x y)) splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) = go t1 [t2] where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar (L _ fn))) tys | fn == funTyConName + go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName , [t1,t2] <- tys , (args, res) <- splitHsFunType t2 = (t1:args, res) @@ -960,7 +974,8 @@ getAppsTyHead_maybe tys = case splitHsAppsTy tys of ([app1:apps], []) -> -- no symbols, some normal types Just (mkHsAppTys app1 apps, []) ([app1l:appsl, app1r:appsr], [L loc op]) -> -- one operator - Just (L loc (HsTyVar (L loc op)), [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr]) + Just ( L loc (HsTyVar NotPromoted (L loc op)) + , [mkHsAppTys app1l appsl, mkHsAppTys app1r appsr]) _ -> -- can't figure it out Nothing @@ -986,7 +1001,7 @@ splitHsAppsTy = go [] [] [] hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) hsTyGetAppHead_maybe = go [] where - go tys (L _ (HsTyVar ln)) = Just (ln, tys) + go tys (L _ (HsTyVar _ ln)) = Just (ln, tys) go tys (L _ (HsAppsTy apps)) | Just (head, args) <- getAppsTyHead_maybe apps = go (args ++ tys) head @@ -1137,16 +1152,19 @@ ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel ************************************************************************ -} -instance (OutputableBndrId name) => Outputable (HsType name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (HsType name) where ppr ty = pprHsType ty instance Outputable HsTyLit where ppr = ppr_tylit -instance (OutputableBndrId name) => Outputable (LHsQTyVars name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (LHsQTyVars name) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs -instance (OutputableBndrId name) => Outputable (HsTyVarBndr name) where +instance (OutputableBndrId name, HasOccNameId name) + => Outputable (HsTyVarBndr name) where ppr (UserTyVar n) = ppr n ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] @@ -1159,7 +1177,7 @@ instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where instance Outputable (HsWildCardInfo name) where ppr (AnonWildCard _) = char '_' -pprHsForAll :: (OutputableBndrId name) +pprHsForAll :: (OutputableBndrId name, HasOccNameId name) => [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAll = pprHsForAllExtra Nothing @@ -1170,7 +1188,7 @@ pprHsForAll = pprHsForAllExtra Nothing -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: (OutputableBndrId name) +pprHsForAllExtra :: (OutputableBndrId name, HasOccNameId name) => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAllExtra extra qtvs cxt @@ -1178,26 +1196,38 @@ pprHsForAllExtra extra qtvs cxt where show_extra = isJust extra -pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc +pprHsForAllTvs :: (OutputableBndrId name, HasOccNameId name) + => [LHsTyVarBndr name] -> SDoc pprHsForAllTvs qtvs | show_forall = forAllLit <+> interppSP qtvs <> dot | otherwise = empty where show_forall = opt_PprStyle_Debug || not (null qtvs) -pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc +pprHsContext :: (OutputableBndrId name, HasOccNameId name) + => HsContext name -> SDoc pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe -pprHsContextNoArrow :: (OutputableBndrId name) => HsContext name -> SDoc +pprHsContextNoArrow :: (OutputableBndrId name, HasOccNameId name) + => HsContext name -> SDoc pprHsContextNoArrow = fromMaybe empty . pprHsContextMaybe -pprHsContextMaybe :: (OutputableBndrId name) => HsContext name -> Maybe SDoc +pprHsContextMaybe :: (OutputableBndrId name, HasOccNameId name) + => HsContext name -> Maybe SDoc pprHsContextMaybe [] = Nothing pprHsContextMaybe [L _ pred] = Just $ ppr_mono_ty FunPrec pred pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) +-- For use in a HsQualTy, which always gets printed if it exists. +pprHsContextAlways :: (OutputableBndrId name, HasOccNameId name) + => HsContext name -> SDoc +pprHsContextAlways [] = parens empty <+> darrow +pprHsContextAlways [L _ ty] = ppr_mono_ty FunPrec ty <+> darrow +pprHsContextAlways cxt = parens (interpp'SP cxt) <+> darrow + -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ -pprHsContextExtra :: (OutputableBndrId name) => Bool -> HsContext name -> SDoc +pprHsContextExtra :: (OutputableBndrId name, HasOccNameId name) + => Bool -> HsContext name -> SDoc pprHsContextExtra show_extra ctxt | not show_extra = pprHsContext ctxt @@ -1208,7 +1238,8 @@ pprHsContextExtra show_extra ctxt where ctxt' = map ppr ctxt ++ [char '_'] -pprConDeclFields :: (OutputableBndrId name) => [LConDeclField name] -> SDoc +pprConDeclFields :: (OutputableBndrId name, HasOccNameId name) + => [LConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) where ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, @@ -1232,32 +1263,32 @@ seems like the Right Thing anyway.) -- Printing works more-or-less as for Types -pprHsType, pprParendHsType :: (OutputableBndrId name) => HsType name -> SDoc +pprHsType, pprParendHsType :: (OutputableBndrId name, HasOccNameId name) + => HsType name -> SDoc -pprHsType ty = ppr_mono_ty TopPrec (prepare ty) +pprHsType ty = ppr_mono_ty TopPrec ty pprParendHsType ty = ppr_mono_ty TyConPrec ty --- Before printing a type, remove outermost HsParTy parens -prepare :: HsType name -> HsType name -prepare (HsParTy ty) = prepare (unLoc ty) -prepare (HsAppsTy [L _ (HsAppPrefix (L _ ty))]) = prepare ty -prepare ty = ty - -ppr_mono_lty :: (OutputableBndrId name) => TyPrec -> LHsType name -> SDoc +ppr_mono_lty :: (OutputableBndrId name, HasOccNameId name) + => TyPrec -> LHsType name -> SDoc ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) -ppr_mono_ty :: (OutputableBndrId name) => TyPrec -> HsType name -> SDoc +ppr_mono_ty :: (OutputableBndrId name, HasOccNameId name) + => TyPrec -> HsType name -> SDoc ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) = maybeParen ctxt_prec FunPrec $ sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty] -ppr_mono_ty ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty }) - = maybeParen ctxt_prec FunPrec $ - sep [pprHsContext ctxt, ppr_mono_lty TopPrec ty] +ppr_mono_ty _ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty }) + = sep [pprHsContextAlways ctxt, ppr_mono_lty TopPrec ty] ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds -ppr_mono_ty _ (HsTyVar (L _ name))= pprPrefixOcc name +ppr_mono_ty _ (HsTyVar NotPromoted (L _ name))= pprPrefixOcc name +ppr_mono_ty _ (HsTyVar Promoted (L _ name)) + = space <> quote (pprPrefixOcc name) + -- We need a space before the ' above, so the parser + -- does not attach it to the previous symbol ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2 ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys) where std_con = case con of @@ -1270,7 +1301,10 @@ ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty) ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty) ppr_mono_ty _ (HsSpliceTy s _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty -ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys) +ppr_mono_ty _ (HsExplicitListTy Promoted _ tys) + = quote $ brackets (interpp'SP tys) +ppr_mono_ty _ (HsExplicitListTy NotPromoted _ tys) + = brackets (interpp'SP tys) ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) ppr_mono_ty _ (HsTyLit t) = ppr_tylit t ppr_mono_ty _ (HsWildCardTy {}) = char '_' @@ -1279,13 +1313,11 @@ ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) = maybeParen ctxt_prec TyOpPrec $ ppr_mono_lty TyOpPrec ty1 <+> char '~' <+> ppr_mono_lty TyOpPrec ty2 -ppr_mono_ty ctxt_prec (HsAppsTy tys) - = maybeParen ctxt_prec TyConPrec $ - hsep (map (ppr_app_ty TopPrec . unLoc) tys) +ppr_mono_ty _ctxt_prec (HsAppsTy tys) + = hsep (map (ppr_app_ty TopPrec . unLoc) tys) -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) - = maybeParen ctxt_prec TyConPrec $ - hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty] +ppr_mono_ty _ctxt_prec (HsAppTy fun_ty arg_ty) + = hsep [ppr_mono_lty FunPrec fun_ty, ppr_mono_lty TyConPrec arg_ty] ppr_mono_ty ctxt_prec (HsOpTy ty1 (L _ op) ty2) = maybeParen ctxt_prec TyOpPrec $ @@ -1305,7 +1337,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty doc) -- postfix operators -------------------------- -ppr_fun_ty :: (OutputableBndrId name) +ppr_fun_ty :: (OutputableBndrId name, HasOccNameId name) => TyPrec -> LHsType name -> LHsType name -> SDoc ppr_fun_ty ctxt_prec ty1 ty2 = let p1 = ppr_mono_lty FunPrec ty1 @@ -1315,9 +1347,15 @@ ppr_fun_ty ctxt_prec ty1 ty2 sep [p1, text "->" <+> p2] -------------------------- -ppr_app_ty :: (OutputableBndrId name) => TyPrec -> HsAppType name -> SDoc +ppr_app_ty :: (OutputableBndrId name, HasOccNameId name) + => TyPrec -> HsAppType name -> SDoc ppr_app_ty _ (HsAppInfix (L _ n)) = pprInfixOcc n -ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar (L _ n)))) = pprPrefixOcc n +ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar NotPromoted (L _ n)))) + = pprPrefixOcc n +ppr_app_ty _ (HsAppPrefix (L _ (HsTyVar Promoted (L _ n)))) + = space <> quote (pprPrefixOcc n) -- We need a space before the ' above, so + -- the parser does not attach it to the + -- previous symbol ppr_app_ty ctxt (HsAppPrefix ty) = ppr_mono_lty ctxt ty -------------------------- diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index f1500bb9a0..b49cd98f25 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -49,13 +49,13 @@ module HsUtils( -- Patterns mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, - nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, + nlWildPatName, nlWildPatId, nlTuplePat, mkParPat, nlParPat, mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs, mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv, - nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, + nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, -- Stmts mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt, @@ -207,14 +207,18 @@ mkParPat :: LPat name -> LPat name mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp) | otherwise = lp +nlParPat :: LPat name -> LPat name +nlParPat p = noLoc (ParPat p) ------------------------------- -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName +mkHsIntegral :: SourceText -> Integer -> PostTc RdrName Type + -> HsOverLit RdrName mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName -mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName +mkHsIsString :: SourceText -> FastString -> PostTc RdrName Type + -> HsOverLit RdrName mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName -> HsExpr RdrName @@ -312,17 +316,18 @@ mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op))) unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -mkUntypedSplice :: LHsExpr RdrName -> HsSplice RdrName -mkUntypedSplice e = HsUntypedSplice unqualSplice e +mkUntypedSplice :: HasParens -> LHsExpr RdrName -> HsSplice RdrName +mkUntypedSplice hasParen e = HsUntypedSplice hasParen unqualSplice e -mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName -mkHsSpliceE e = HsSpliceE (mkUntypedSplice e) +mkHsSpliceE :: HasParens -> LHsExpr RdrName -> HsExpr RdrName +mkHsSpliceE hasParen e = HsSpliceE (mkUntypedSplice hasParen e) -mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName -mkHsSpliceTE e = HsSpliceE (HsTypedSplice unqualSplice e) +mkHsSpliceTE :: HasParens -> LHsExpr RdrName -> HsExpr RdrName +mkHsSpliceTE hasParen e = HsSpliceE (HsTypedSplice hasParen unqualSplice e) -mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName -mkHsSpliceTy e = HsSpliceTy (HsUntypedSplice unqualSplice e) placeHolderKind +mkHsSpliceTy :: HasParens -> LHsExpr RdrName -> HsType RdrName +mkHsSpliceTy hasParen e + = HsSpliceTy (HsUntypedSplice hasParen unqualSplice e) placeHolderKind mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote @@ -333,11 +338,11 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) -- identify the quasi-quote mkHsString :: String -> HsLit -mkHsString s = HsString s (mkFastString s) +mkHsString s = HsString NoSourceText (mkFastString s) mkHsStringPrimLit :: FastString -> HsLit mkHsStringPrimLit fs - = HsStringPrim (unpackFS fs) (fastStringToByteString fs) + = HsStringPrim NoSourceText (fastStringToByteString fs) ------------- userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name] @@ -385,7 +390,7 @@ nlHsSyntaxApps (SyntaxExpr { syn_expr = fun mkLHsWrap arg_wraps args)) nlHsIntLit :: Integer -> LHsExpr id -nlHsIntLit n = noLoc (HsLit (HsInt (show n) n)) +nlHsIntLit n = noLoc (HsLit (HsInt NoSourceText n)) nlHsApps :: id -> [LHsExpr id] -> LHsExpr id nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs @@ -455,10 +460,12 @@ nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) nlHsAppTy :: LHsType name -> LHsType name -> LHsType name nlHsTyVar :: name -> LHsType name nlHsFunTy :: LHsType name -> LHsType name -> LHsType name +nlHsParTy :: LHsType name -> LHsType name nlHsAppTy f t = noLoc (HsAppTy f t) -nlHsTyVar x = noLoc (HsTyVar (noLoc x)) +nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x)) nlHsFunTy a b = noLoc (HsFunTy a b) +nlHsParTy t = noLoc (HsParTy t) nlHsTyConApp :: name -> [LHsType name] -> LHsType name nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys @@ -613,8 +620,8 @@ typeToLHsType ty , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) - go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) - go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) + go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy NoSourceText n) + go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy NoSourceText s) go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') where args' = filterOutInvisibleTypes tc args diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 2e195df799..c29e8f9cb4 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -142,3 +142,10 @@ type OutputableBndrId id = ( OutputableBndr id , OutputableBndr (NameOrRdrName id) ) + +-- |Constraint type to bundle up the requirement for 'HasOccName' on both +-- the @id@ and the 'NameOrRdrName' type for it +type HasOccNameId id = + ( HasOccName id + , HasOccName (NameOrRdrName id) + ) diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 0337abcefc..b291bc53fd 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -390,7 +390,7 @@ buildClass tycon_name binders roles sc_theta ; traceIf (text "buildClass" <+> ppr tycon) ; return result } where - no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem mk_op_item rec_clas (op_name, _, dm_spec) diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 48bc316d0a..921943afb9 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -923,7 +923,8 @@ ghcPrimIface mi_fix_fn = mkIfaceFixCache fixities } where - fixities = (getOccName seqId, Fixity "0" 0 InfixR) -- seq is infixr 0 + fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR) + -- seq is infixr 0 : (occName funTyConName, funTyFixity) -- trac #10145 : mapMaybe mkFixity allThePrimOps mkFixity op = (,) (primOpOcc op) <$> primOpFixity op diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 6baffedc67..123b02fc81 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -803,7 +803,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons ; return (HsUnpack (Just co)) } src_strict :: IfaceSrcBang -> HsSrcBang - src_strict (IfSrcBang unpk bang) = HsSrcBang Nothing unpk bang + src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] tcIfaceEqSpec spec diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 2c27de156c..ceb566ca6d 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -117,7 +117,7 @@ mkPrelImports this_mod loc implicit_prelude import_decls preludeImportDecl :: LImportDecl RdrName preludeImportDecl - = L loc $ ImportDecl { ideclSourceSrc = Nothing, + = L loc $ ImportDecl { ideclSourceSrc = NoSourceText, ideclName = L loc pRELUDE_NAME, ideclPkgQual = Nothing, ideclSource = False, diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 6800fab57e..14a7cb2ffa 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -114,7 +114,7 @@ import DynFlags import SrcLoc import Module import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..), - SourceText ) + SourceText(..) ) -- compiler/parser import Ctype @@ -1126,7 +1126,7 @@ rulePrag :: Action rulePrag span buf len = do setExts (.|. xbit InRulePragBit) let !src = lexemeToString buf len - return (L span (ITrules_prag src)) + return (L span (ITrules_prag (SourceText src))) endPrag :: Action endPrag span _buf _len = do @@ -1260,13 +1260,13 @@ sym con span buf len = !fs = lexemeToFastString buf len -- Variations on the integral numeric literal. -tok_integral :: (String -> Integer -> Token) +tok_integral :: (SourceText -> Integer -> Token) -> (Integer -> Integer) -> Int -> Int -> (Integer, (Char -> Int)) -> Action tok_integral itint transint transbuf translen (radix,char_to_int) span buf len - = return $ L span $ itint (lexemeToString buf len) + = return $ L span $ itint (SourceText $ lexemeToString buf len) $! transint $ parseUnsignedInteger (offsetBytes transbuf buf) (subtract translen len) radix char_to_int @@ -1452,8 +1452,8 @@ lex_string_tok span buf _len = do (AI end bufEnd) <- getInput let tok' = case tok of - ITprimstring _ bs -> ITprimstring src bs - ITstring _ s -> ITstring src s + ITprimstring _ bs -> ITprimstring (SourceText src) bs + ITstring _ s -> ITstring (SourceText src) s _ -> panic "lex_string_tok" src = lexemeToString buf (cur bufEnd - cur buf) return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok') @@ -1476,11 +1476,13 @@ lex_string s = do if any (> '\xFF') s then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" else let bs = unsafeMkByteString (reverse s) - in return (ITprimstring "" bs) + in return (ITprimstring (SourceText (reverse s)) bs) _other -> - return (ITstring "" (mkFastString (reverse s))) + return (ITstring (SourceText (reverse s)) + (mkFastString (reverse s))) else - return (ITstring "" (mkFastString (reverse s))) + return (ITstring (SourceText (reverse s)) + (mkFastString (reverse s))) Just ('\\',i) | Just ('&',i) <- next -> do @@ -1555,14 +1557,16 @@ finish_char_tok buf loc ch -- We've already seen the closing quote i@(AI end bufEnd) <- getInput let src = lexemeToString buf (cur bufEnd - cur buf) if magicHash then do - case alexGetChar' i of - Just ('#',i@(AI end _)) -> do - setInput i - return (L (mkRealSrcSpan loc end) (ITprimchar src ch)) - _other -> - return (L (mkRealSrcSpan loc end) (ITchar src ch)) + case alexGetChar' i of + Just ('#',i@(AI end _)) -> do + setInput i + return (L (mkRealSrcSpan loc end) + (ITprimchar (SourceText src) ch)) + _other -> + return (L (mkRealSrcSpan loc end) + (ITchar (SourceText src) ch)) else do - return (L (mkRealSrcSpan loc end) (ITchar src ch)) + return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch)) isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c @@ -2713,37 +2717,46 @@ ignoredPrags = Map.fromList (map ignored pragmas) pragmas = options_pragmas ++ ["cfiles", "contract"] oneWordPrags = Map.fromList([ - ("rules", rulePrag), - ("inline", strtoken (\s -> (ITinline_prag s Inline FunLike))), - ("inlinable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), - ("inlineable", strtoken (\s -> (ITinline_prag s Inlinable FunLike))), - -- Spelling variant - ("notinline", strtoken (\s -> (ITinline_prag s NoInline FunLike))), - ("specialize", strtoken (\s -> ITspec_prag s)), - ("source", strtoken (\s -> ITsource_prag s)), - ("warning", strtoken (\s -> ITwarning_prag s)), - ("deprecated", strtoken (\s -> ITdeprecated_prag s)), - ("scc", strtoken (\s -> ITscc_prag s)), - ("generated", strtoken (\s -> ITgenerated_prag s)), - ("core", strtoken (\s -> ITcore_prag s)), - ("unpack", strtoken (\s -> ITunpack_prag s)), - ("nounpack", strtoken (\s -> ITnounpack_prag s)), - ("ann", strtoken (\s -> ITann_prag s)), - ("vectorize", strtoken (\s -> ITvect_prag s)), - ("novectorize", strtoken (\s -> ITnovect_prag s)), - ("minimal", strtoken (\s -> ITminimal_prag s)), - ("overlaps", strtoken (\s -> IToverlaps_prag s)), - ("overlappable", strtoken (\s -> IToverlappable_prag s)), - ("overlapping", strtoken (\s -> IToverlapping_prag s)), - ("incoherent", strtoken (\s -> ITincoherent_prag s)), - ("ctype", strtoken (\s -> ITctype s))]) + ("rules", rulePrag), + ("inline", + strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))), + ("inlinable", + strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), + ("inlineable", + strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), + -- Spelling variant + ("notinline", + strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))), + ("specialize", strtoken (\s -> ITspec_prag (SourceText s))), + ("source", strtoken (\s -> ITsource_prag (SourceText s))), + ("warning", strtoken (\s -> ITwarning_prag (SourceText s))), + ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))), + ("scc", strtoken (\s -> ITscc_prag (SourceText s))), + ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))), + ("core", strtoken (\s -> ITcore_prag (SourceText s))), + ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))), + ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))), + ("ann", strtoken (\s -> ITann_prag (SourceText s))), + ("vectorize", strtoken (\s -> ITvect_prag (SourceText s))), + ("novectorize", strtoken (\s -> ITnovect_prag (SourceText s))), + ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))), + ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))), + ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))), + ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))), + ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))), + ("ctype", strtoken (\s -> ITctype (SourceText s)))]) twoWordPrags = Map.fromList([ - ("inline conlike", strtoken (\s -> (ITinline_prag s Inline ConLike))), - ("notinline conlike", strtoken (\s -> (ITinline_prag s NoInline ConLike))), - ("specialize inline", strtoken (\s -> (ITspec_inline_prag s True))), - ("specialize notinline", strtoken (\s -> (ITspec_inline_prag s False))), - ("vectorize scalar", strtoken (\s -> ITvect_scalar_prag s))]) + ("inline conlike", + strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))), + ("notinline conlike", + strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))), + ("specialize inline", + strtoken (\s -> (ITspec_inline_prag (SourceText s) True))), + ("specialize notinline", + strtoken (\s -> (ITspec_inline_prag (SourceText s) False))), + ("vectorize scalar", + strtoken (\s -> ITvect_scalar_prag (SourceText s)))]) dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 2c90086c56..b31ca79729 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -824,10 +824,10 @@ importdecl :: { LImportDecl RdrName } ((mj AnnImport $1 : (fst $ fst $2) ++ fst $3 ++ fst $4 ++ fst $5 ++ fst $7)) } -maybe_src :: { (([AddAnn],Maybe SourceText),IsBootInterface) } - : '{-# SOURCE' '#-}' { (([mo $1,mc $2],Just (getSOURCE_PRAGs $1)) +maybe_src :: { (([AddAnn],SourceText),IsBootInterface) } + : '{-# SOURCE' '#-}' { (([mo $1,mc $2],getSOURCE_PRAGs $1) ,True) } - | {- empty -} { (([],Nothing),False) } + | {- empty -} { (([],NoSourceText),False) } maybe_safe :: { ([AddAnn],Bool) } : 'safe' { ([mj AnnSafe $1],True) } @@ -871,7 +871,7 @@ impspec :: { Located (Bool, Located [LIE RdrName]) } -- Fixity Declarations prec :: { Located (SourceText,Int) } - : {- empty -} { noLoc ("",9) } + : {- empty -} { noLoc (NoSourceText,9) } | INTEGER {% checkPrecP (sL1 $1 (getINTEGERs $1,fromInteger (getINTEGER $1))) } @@ -1444,11 +1444,11 @@ binds :: { Located ([AddAnn],Located (HsLocalBinds RdrName)) } ,sL1 $1 $ HsValBinds val_binds)) } } | '{' dbinds '}' { sLL $1 $> ([moc $1,mcc $3] - ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2) + ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) emptyTcEvBinds)) } | vocurly dbinds close { L (getLoc $2) ([] - ,sL1 $2 $ HsIPBinds (IPBinds (unLoc $2) + ,sL1 $2 $ HsIPBinds (IPBinds (reverse $ unLoc $2) emptyTcEvBinds)) } @@ -1521,7 +1521,7 @@ warnings :: { OrdList (LWarnDecl RdrName) } -- SUP: TEMPORARY HACK, not checking for `module Foo' warning :: { OrdList (LWarnDecl RdrName) } : namelist strings - {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc "") $ snd $ unLoc $2))) + {% amsu (sLL $1 $> (Warning (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) (fst $ unLoc $2) } deprecations :: { OrdList (LWarnDecl RdrName) } @@ -1536,7 +1536,7 @@ deprecations :: { OrdList (LWarnDecl RdrName) } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { OrdList (LWarnDecl RdrName) } : namelist strings - {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc "") $ snd $ unLoc $2))) + {% amsu (sLL $1 $> $ (Warning (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) (fst $ unLoc $2) } strings :: { Located ([AddAnn],[Located StringLiteral]) } @@ -1601,7 +1601,7 @@ fspec :: { Located ([AddAnn] ,(L (getLoc $1) (getStringLiteral $1), $2, mkLHsSigType $4)) } | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] - ,(noLoc (StringLiteral "" nilFS), $1, mkLHsSigType $3)) } + ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $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 @@ -1639,7 +1639,7 @@ sigtypes1 :: { (OrdList (LHsSigType RdrName)) } -- Types strict_mark :: { Located ([AddAnn],HsSrcBang) } - : strictness { sL1 $1 (let (a, str) = unLoc $1 in (a, HsSrcBang Nothing NoSrcUnpack str)) } + : strictness { sL1 $1 (let (a, str) = unLoc $1 in (a, HsSrcBang NoSourceText NoSrcUnpack str)) } | unpackedness { sL1 $1 (let (a, prag, unpk) = unLoc $1 in (a, HsSrcBang prag unpk NoSrcStrict)) } | unpackedness strictness { sLL $1 $> (let { (a, prag, unpk) = unLoc $1 ; (a', str) = unLoc $2 } @@ -1651,9 +1651,9 @@ strictness :: { Located ([AddAnn], SrcStrictness) } : '!' { sL1 $1 ([mj AnnBang $1], SrcStrict) } | '~' { sL1 $1 ([mj AnnTilde $1], SrcLazy) } -unpackedness :: { Located ([AddAnn], Maybe SourceText, SrcUnpackedness) } - : '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], Just $ getUNPACK_PRAGs $1, SrcUnpack) } - | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], Just $ getNOUNPACK_PRAGs $1, SrcNoUnpack) } +unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) } + : '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) } + | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) } -- A ctype is a for-all type ctype :: { LHsType RdrName } @@ -1785,8 +1785,8 @@ tyapp :: { LHsAppType RdrName } [mj AnnSimpleQuote $1] } atype :: { LHsType RdrName } - : ntgtycon { sL1 $1 (HsTyVar $1) } -- Not including unit tuples - | tyvar { sL1 $1 (HsTyVar $1) } -- (See Note [Unit tuples]) + : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples + | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples]) | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2)) (fst $ unLoc $1) } -- Constructor sigs only | '{' fielddecls '}' {% amms (checkRecordSyntax @@ -1813,21 +1813,21 @@ atype :: { LHsType RdrName } | '(' ctype '::' kind ')' {% ams (sLL $1 $> $ HsKindSig $2 $4) [mop $1,mu AnnDcolon $3,mcp $5] } | quasiquote { sL1 $1 (HsSpliceTy (unLoc $1) placeHolderKind) } - | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy $2) + | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } - | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy $ sL1 $1 $ HsVar $ + | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy NoParens $ sL1 $1 $ HsVar $ (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1)))) [mj AnnThIdSplice $1] } -- see Note [Promotion] for the followings - | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar $2) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $3) AnnComma (gl $4) >> ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) [mj AnnSimpleQuote $1,mop $2,mcp $6] } - | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy + | SIMPLEQUOTE '[' comma_types0 ']' {% ams (sLL $1 $> $ HsExplicitListTy Promoted placeHolderKind $3) [mj AnnSimpleQuote $1,mos $2,mcs $4] } - | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar $2) + | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } -- Two or more [ty, ty, ty] must be a promoted list type, just as @@ -1836,7 +1836,7 @@ atype :: { LHsType RdrName } -- so you have to quote those.) | '[' ctype ',' comma_types1 ']' {% addAnnotation (gl $2) AnnComma (gl $3) >> - ams (sLL $1 $> $ HsExplicitListTy + ams (sLL $1 $> $ HsExplicitListTy NotPromoted placeHolderKind ($2 : $4)) [mos $1,mcs $5] } | INTEGER { sLL $1 $> $ HsTyLit $ HsNumTy (getINTEGERs $1) @@ -2362,7 +2362,7 @@ scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) } ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) } | '{-# SCC' VARID '#-}' { sLL $1 $> (([mo $1,mj AnnVal $2 ,mc $3],getSCC_PRAGs $1) - ,(StringLiteral (unpackFS $ getVARID $2) (getVARID $2))) } + ,(StringLiteral NoSourceText (getVARID $2))) } hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), ((SourceText,SourceText),(SourceText,SourceText)) @@ -2471,17 +2471,17 @@ aexp2 :: { LHsExpr RdrName } [mo $1,mc $4] } splice_exp :: { LHsExpr RdrName } - : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE + : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE NoParens (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1))))) [mj AnnThIdSplice $1] } - | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE $2) + | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } - | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE + | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE NoParens (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName (getTH_ID_TY_SPLICE $1))))) [mj AnnThIdTySplice $1] } - | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE $2) + | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2) [mj AnnOpenPTE $1,mj AnnCloseP $3] } cmdargs :: { [LHsCmdTop RdrName] } @@ -3046,8 +3046,8 @@ qtycon :: { Located RdrName } -- Qualified or unqualified | tycon { $1 } qtycondoc :: { LHsType RdrName } -- Qualified or unqualified - : qtycon { sL1 $1 (HsTyVar $1) } - | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar $1)) $2) } + : qtycon { sL1 $1 (HsTyVar NotPromoted $1) } + | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) } tycon :: { Located RdrName } -- Unqualified : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index ab5708e51d..d964cc2469 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -281,7 +281,7 @@ mkSpliceDecl lexpr@(L loc expr) = SpliceD (SpliceDecl (L loc splice) ExplicitSplice) | otherwise - = SpliceD (SpliceDecl (L loc (mkUntypedSplice lexpr)) ImplicitSplice) + = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan -> Located RdrName -- type being annotated @@ -465,8 +465,8 @@ splitCon ty where -- This is used somewhere where HsAppsTy is not used split (L _ (HsAppTy t u)) ts = split t (u : ts) - split (L l (HsTyVar (L _ tc))) ts = do data_con <- tyConToDataCon l tc - return (data_con, mk_rest ts) + split (L l (HsTyVar _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc + return (data_con, mk_rest ts) split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) [] = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts) split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) @@ -681,9 +681,9 @@ checkTyVars pp_what equals_or_where tc tparms -- Check that the name space is correct! chk (L l (HsKindSig - (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar (L _ tv))))])) k)) + (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k)) | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) - chk (L l (HsTyVar (L ltv tv))) + chk (L l (HsTyVar _ (L ltv tv))) | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv))) chk t@(L loc _) = Left (loc, @@ -732,7 +732,7 @@ checkTyClHdr is_cls ty where goL (L l ty) acc ann = go l ty acc ann - go l (HsTyVar (L _ tc)) acc ann + go l (HsTyVar _ (L _ tc)) acc ann | isRdrTc tc = return (L l tc, acc, ann) go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann | isRdrTc tc = return (ltc, t1:t2:acc, ann) @@ -1088,7 +1088,8 @@ isFunLhs e = go e [] [] splitTilde :: LHsType RdrName -> P (LHsType RdrName) splitTilde t = go t where go (L loc (HsAppTy t1 t2)) - | L lo (HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcLazy) t2') <- t2 + | L lo (HsBangTy (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) t2') + <- t2 = do moveAnnotations lo loc t1' <- go t1 @@ -1116,7 +1117,7 @@ splitTildeApps (t : rest) = do return (t : rest') where go (L l (HsAppPrefix (L loc (HsBangTy - (HsSrcBang Nothing NoSrcUnpack SrcLazy) + (HsSrcBang NoSourceText NoSrcUnpack SrcLazy) ty)))) = addAnnotation l AnnTilde tilde_loc >> return @@ -1160,7 +1161,7 @@ checkCmd :: SrcSpan -> HsExpr RdrName -> P (HsCmd RdrName) checkCmd _ (HsArrApp e1 e2 ptt haat b) = return $ HsCmdArrApp e1 e2 ptt haat b checkCmd _ (HsArrForm e mf args) = - return $ HsCmdArrForm e mf args + return $ HsCmdArrForm e Prefix mf args checkCmd _ (HsApp e1 e2) = checkCommand e1 >>= (\c -> return $ HsCmdApp c e2) checkCmd _ (HsLam mg) = @@ -1184,7 +1185,7 @@ checkCmd _ (OpApp eLeft op _fixity eRight) = do c2 <- checkCommand eRight let arg1 = L (getLoc c1) $ HsCmdTop c1 placeHolderType placeHolderType [] arg2 = L (getLoc c2) $ HsCmdTop c2 placeHolderType placeHolderType [] - return $ HsCmdArrForm op Nothing [arg1, arg2] + return $ HsCmdArrForm op Infix Nothing [arg1, arg2] checkCmd l e = cmdFail l e @@ -1274,7 +1275,7 @@ mk_rec_upd_field :: HsRecField RdrName (LHsExpr RdrName) -> HsRecUpdField RdrNam mk_rec_upd_field (HsRecField (L loc (FieldOcc rdr _)) arg pun) = HsRecField (L loc (Unambiguous rdr PlaceHolder)) arg pun -mkInlinePragma :: String -> (InlineSpec, RuleMatchInfo) -> Maybe Activation +mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -> InlinePragma -- The (Maybe Activation) is because the user can omit -- the activation spec (and usually does) @@ -1357,7 +1358,8 @@ parseCImport cconv safety nm str sourceText = ((mk Nothing <$> cimp nm) +++ (do h <- munch1 hdr_char skipSpaces - mk (Just (Header h (mkFastString h))) <$> cimp nm)) + mk (Just (Header (SourceText h) (mkFastString h))) + <$> cimp nm)) ] skipSpaces return r @@ -1386,7 +1388,7 @@ parseCImport cconv safety nm str sourceText = return False) _ -> return True cid' <- cid - return (CFunction (StaticTarget (unpackFS cid') cid' + return (CFunction (StaticTarget NoSourceText cid' Nothing isFun))) where cid = return nm +++ @@ -1405,7 +1407,7 @@ mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty) ForeignExport { fd_name = v, fd_sig_ty = ty , fd_co = noForeignExportCoercionYet , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv)) - (L le (unpackFS entity)) } + (L le esrc) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs index 8411f11e71..ff893ede02 100644 --- a/compiler/prelude/ForeignCall.hs +++ b/compiler/prelude/ForeignCall.hs @@ -22,7 +22,7 @@ import FastString import Binary import Outputable import Module -import BasicTypes ( SourceText ) +import BasicTypes ( SourceText, pprWithSourceText ) import Data.Char import Data.Data @@ -203,14 +203,14 @@ instance Outputable CCallSpec where gc_suf | playSafe safety = text "_GC" | otherwise = empty - ppr_fun (StaticTarget _ fn mPkgId isFun) + ppr_fun (StaticTarget st _fn mPkgId isFun) = text (if isFun then "__pkg_ccall" else "__pkg_ccall_value") <> gc_suf <+> (case mPkgId of Nothing -> empty Just pkgId -> ppr pkgId) - <+> pprCLabelString fn + <+> (pprWithSourceText st empty) ppr_fun DynamicTarget = text "__dyn_ccall" <> gc_suf <+> text "\"\"" @@ -221,7 +221,7 @@ data Header = Header SourceText FastString deriving (Eq, Data) instance Outputable Header where - ppr (Header _ h) = quotes $ ppr h + ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) -- | A C type, used in CAPI FFI calls -- @@ -236,7 +236,9 @@ data CType = CType SourceText -- Note [Pragma source text] in BasicTypes deriving (Eq, Data) instance Outputable CType where - ppr (CType _ mh (_,ct)) = hDoc <+> ftext ct + ppr (CType stp mh (stct,ct)) + = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc + <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" where hDoc = case mh of Nothing -> empty Just h -> ppr h diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs index e174aedcf4..0acac6639f 100644 --- a/compiler/prelude/PrimOp.hs +++ b/compiler/prelude/PrimOp.hs @@ -38,7 +38,8 @@ import OccName ( OccName, pprOccName, mkVarOccFS ) import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import Type import RepType ( typePrimRep, tyConPrimRep ) -import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..) ) +import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..), + SourceText(..) ) import ForeignCall ( CLabelString ) import Unique ( Unique, mkPrimOpIdUnique ) import Outputable diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 1c47922a36..18cf53093d 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -144,7 +144,8 @@ import Class ( Class, mkClass ) import RdrName import Name import NameSet ( NameSet, mkNameSet, elemNameSet ) -import BasicTypes ( Arity, Boxity(..), TupleSort(..), ConTagZ ) +import BasicTypes ( Arity, Boxity(..), TupleSort(..), ConTagZ, + SourceText(..) ) import ForeignCall import SrcLoc ( noSrcSpan ) import Unique @@ -525,7 +526,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys (mkDataConWorkId wrk_name data_con) NoDataConRep -- Wired-in types are too simple to need wrappers - no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict wrk_name = mkDataConWorkerName data_con wrk_key @@ -1179,8 +1180,9 @@ charTy = mkTyConTy charTyCon charTyCon :: TyCon charTyCon = pcNonEnumTyCon charTyConName - (Just (CType "" Nothing ("HsChar",fsLit "HsChar"))) - [] [charDataCon] + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsChar"))) + [] [charDataCon] charDataCon :: DataCon charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon @@ -1192,8 +1194,8 @@ intTy = mkTyConTy intTyCon intTyCon :: TyCon intTyCon = pcNonEnumTyCon intTyConName - (Just (CType "" Nothing ("HsInt",fsLit "HsInt"))) [] - [intDataCon] + (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) + [] [intDataCon] intDataCon :: DataCon intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon @@ -1202,8 +1204,8 @@ wordTy = mkTyConTy wordTyCon wordTyCon :: TyCon wordTyCon = pcNonEnumTyCon wordTyConName - (Just (CType "" Nothing ("HsWord", fsLit "HsWord"))) [] - [wordDataCon] + (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) + [] [wordDataCon] wordDataCon :: DataCon wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon @@ -1212,7 +1214,8 @@ word8Ty = mkTyConTy word8TyCon word8TyCon :: TyCon word8TyCon = pcNonEnumTyCon word8TyConName - (Just (CType "" Nothing ("HsWord8", fsLit "HsWord8"))) [] + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsWord8"))) [] [word8DataCon] word8DataCon :: DataCon word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon @@ -1222,7 +1225,8 @@ floatTy = mkTyConTy floatTyCon floatTyCon :: TyCon floatTyCon = pcNonEnumTyCon floatTyConName - (Just (CType "" Nothing ("HsFloat", fsLit "HsFloat"))) [] + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsFloat"))) [] [floatDataCon] floatDataCon :: DataCon floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon @@ -1232,7 +1236,8 @@ doubleTy = mkTyConTy doubleTyCon doubleTyCon :: TyCon doubleTyCon = pcNonEnumTyCon doubleTyConName - (Just (CType "" Nothing ("HsDouble",fsLit "HsDouble"))) [] + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsDouble"))) [] [doubleDataCon] doubleDataCon :: DataCon @@ -1293,7 +1298,8 @@ boolTy = mkTyConTy boolTyCon boolTyCon :: TyCon boolTyCon = pcTyCon True boolTyConName - (Just (CType "" Nothing ("HsBool", fsLit "HsBool"))) + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsBool"))) [] [falseDataCon, trueDataCon] falseDataCon, trueDataCon :: DataCon diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 801bc2724f..f8969a8e13 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -75,7 +75,8 @@ import DataCon import TyCon import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR ) import ErrUtils ( MsgDoc ) -import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, defaultFixity ) +import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, + defaultFixity, pprWarningTxtForMsg, SourceText(..) ) import SrcLoc import Outputable import Util @@ -1072,7 +1073,7 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) <+> pprNonVarNameSpace (occNameSpace occ) <+> quotes (ppr occ) , parens imp_msg <> colon ] - , ppr txt ] + , pprWarningTxtForMsg txt ] where imp_mod = importSpecModule imp_spec imp_msg = text "imported from" <+> ppr imp_mod <> extra @@ -1438,7 +1439,7 @@ lookupFixityRn_help' :: Name -> RnM (Bool, Fixity) lookupFixityRn_help' name occ | isUnboundName name - = return (False, Fixity (show minPrecedence) minPrecedence InfixL) + = return (False, Fixity NoSourceText minPrecedence InfixL) -- Minimise errors from ubound names; eg -- a>0 `foo` b>0 -- where 'foo' is not in scope, should not give an error (Trac #7937) @@ -1517,7 +1518,7 @@ lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName" [ (_, fix):_ ] -> return fix ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) - >> return (Fixity(show minPrecedence) minPrecedence InfixL) + >> return (Fixity NoSourceText minPrecedence InfixL) lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 991162dec8..7cafc2b22f 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -168,7 +168,7 @@ rnExpr (OpApp e1 op _ e2) ; fixity <- case op' of L _ (HsVar (L _ n)) -> lookupFixityRn n L _ (HsRecFld f) -> lookupFieldFixityRn f - _ -> return (Fixity (show minPrecedence) minPrecedence InfixL) + _ -> return (Fixity NoSourceText minPrecedence InfixL) -- c.f. lookupFixity for unbound ; final_e <- mkOpAppRn e1' op' fixity e2' @@ -474,7 +474,7 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) -- inside 'arrow'. In the higher-order case (-<<), they are. -- infix form -rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) +rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2]) = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) ; let L _ (HsVar (L _ op_name)) = op' ; (arg1',fv_arg1) <- rnCmdTop arg1 @@ -484,10 +484,10 @@ rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) ; final_e <- mkOpFormRn arg1' op' fixity arg2' ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } -rnCmd (HsCmdArrForm op fixity cmds) +rnCmd (HsCmdArrForm op f fixity cmds) = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) ; (cmds',fvCmds) <- rnCmdArgs cmds - ; return (HsCmdArrForm op' fixity cmds', fvOp `plusFV` fvCmds) } + ; return (HsCmdArrForm op' f fixity cmds', fvOp `plusFV` fvCmds) } rnCmd (HsCmdApp fun arg) = do { (fun',fvFun) <- rnLCmd fun diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index e67be63fa4..2122c70c97 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -817,7 +817,7 @@ rnLit _ = return () -- Integer-looking literal. generalizeOverLitVal :: OverLitVal -> OverLitVal generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_value=val})) - | denominator val == 1 = HsIntegral src (numerator val) + | denominator val == 1 = HsIntegral (SourceText src) (numerator val) generalizeOverLitVal lit = lit rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars) diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 57c35873a8..0c41ed30b6 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -22,7 +22,7 @@ import Kind import RnEnv import RnSource ( rnSrcDecls, findSplice ) import RnPat ( rnPat ) -import BasicTypes ( TopLevelFlag, isTopLevel ) +import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) ) import Outputable import Module import SrcLoc @@ -309,7 +309,7 @@ runRnSplice flavour run_meta ppr_res splice = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) ; let the_expr = case splice' of - HsUntypedSplice _ e -> e + HsUntypedSplice _ _ e -> e HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) @@ -350,7 +350,7 @@ runRnSplice flavour run_meta ppr_res splice makePending :: UntypedSpliceFlavour -> HsSplice Name -> PendingRnSplice -makePending flavour (HsUntypedSplice n e) +makePending flavour (HsUntypedSplice _ n e) = PendingRnSplice flavour n e makePending flavour (HsQuasiQuote n quoter q_span quote) = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) @@ -370,7 +370,7 @@ mkQuasiQuoteExpr flavour quoter q_span quote quoteExpr where quoterExpr = L q_span $! HsVar $! (L q_span quoter) - quoteExpr = L q_span $! HsLit $! HsString "" quote + quoteExpr = L q_span $! HsLit $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName UntypedPatSplice -> quotePatName @@ -380,19 +380,19 @@ mkQuasiQuoteExpr flavour quoter q_span quote --------------------- rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) -- Not exported...used for all -rnSplice (HsTypedSplice splice_name expr) +rnSplice (HsTypedSplice hasParen splice_name expr) = do { checkTH expr "Template Haskell typed splice" ; loc <- getSrcSpanM ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr - ; return (HsTypedSplice n' expr', fvs) } + ; return (HsTypedSplice hasParen n' expr', fvs) } -rnSplice (HsUntypedSplice splice_name expr) +rnSplice (HsUntypedSplice hasParen splice_name expr) = do { checkTH expr "Template Haskell untyped splice" ; loc <- getSrcSpanM ; n' <- newLocalBndrRn (L loc splice_name) ; (expr', fvs) <- rnLExpr expr - ; return (HsUntypedSplice n' expr', fvs) } + ; return (HsUntypedSplice hasParen n' expr', fvs) } rnSplice (HsQuasiQuote splice_name quoter q_loc quote) = do { checkTH quoter "Template Haskell quasi-quote" diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index c548c4d0a6..00e27152de 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -464,9 +464,9 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' } , fvs1 `plusFV` fvs2) } -rnHsTyKi env (HsTyVar (L loc rdr_name)) +rnHsTyKi env (HsTyVar ip (L loc rdr_name)) = do { name <- rnTyVar env rdr_name - ; return (HsTyVar (L loc name), unitFV name) } + ; return (HsTyVar ip (L loc name), unitFV name) } rnHsTyKi env ty@(HsOpTy ty1 l_op ty2) = setSrcSpan (getLoc l_op) $ @@ -586,7 +586,8 @@ rnHsTyKi env overall_ty@(HsAppsTy tys) (non_syms1 : non_syms2 : non_syms) (L loc star : ops) | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey = deal_with_star acc1 acc2 - ((non_syms1 ++ L loc (HsTyVar (L loc star)) : non_syms2) : non_syms) + ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star)) + : non_syms2) : non_syms) ops deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops) = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops @@ -643,12 +644,12 @@ rnHsTyKi _ (HsCoreTy ty) -- The emptyFVs probably isn't quite right -- but I don't think it matters -rnHsTyKi env ty@(HsExplicitListTy k tys) +rnHsTyKi env ty@(HsExplicitListTy ip k tys) = do { checkTypeInType env ty ; data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env ty)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys - ; return (HsExplicitListTy k tys', fvs) } + ; return (HsExplicitListTy ip k tys', fvs) } rnHsTyKi env ty@(HsExplicitTupleTy kis tys) = do { checkTypeInType env ty @@ -1034,7 +1035,7 @@ collectAnonWildCards lty = go lty HsDocTy ty _ -> go ty HsBangTy _ ty -> go ty HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds - HsExplicitListTy _ tys -> gos tys + HsExplicitListTy _ _ tys -> gos tys HsExplicitTupleTy _ tys -> gos tys HsForAllTy { hst_bndrs = bndrs , hst_body = ty } -> collectAnonWildCardsBndrs bndrs @@ -1247,15 +1248,16 @@ mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged -> RnM (HsCmd Name) -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _)) +mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1) + [a11,a12])) _ _ _)) op2 fix2 a2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) - return (HsCmdArrForm op2 (Just fix2) [a1, a2]) + return (HsCmdArrForm op2 f (Just fix2) [a1, a2]) | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 - return (HsCmdArrForm op1 (Just fix1) + return (HsCmdArrForm op1 f (Just fix1) [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])]) -- TODO: locs are wrong @@ -1264,7 +1266,7 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ -- Default case mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = return (HsCmdArrForm op (Just fix) [arg1, arg2]) + = return (HsCmdArrForm op Infix (Just fix) [arg1, arg2]) -------------------------------------- @@ -1600,7 +1602,7 @@ extract_lkind = extract_lty KindLevel extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars extract_lty t_or_k (L _ ty) acc = case ty of - HsTyVar ltv -> extract_tv t_or_k ltv acc + HsTyVar _ ltv -> extract_tv t_or_k ltv acc HsBangTy _ ty -> extract_lty t_or_k ty acc HsRecTy flds -> foldrM (extract_lty t_or_k . cd_fld_type . unLoc) acc @@ -1624,7 +1626,7 @@ extract_lty t_or_k (L _ ty) acc HsCoreTy {} -> return acc -- The type is closed HsSpliceTy {} -> return acc -- Type splices mention no tvs HsDocTy ty _ -> extract_lty t_or_k ty acc - HsExplicitListTy _ tys -> extract_ltys t_or_k tys acc + HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc HsTyLit _ -> return acc HsKindSig ty ki -> extract_lty t_or_k ty =<< diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs index 9acc461c20..2db3a7157a 100644 --- a/compiler/stranal/WorkWrap.hs +++ b/compiler/stranal/WorkWrap.hs @@ -371,7 +371,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs Just (work_demands, wrap_fn, work_fn) -> do work_uniq <- getUniqueM let work_rhs = work_fn rhs - work_prag = InlinePragma { inl_src = "{-# INLINE" + work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_inline = inl_inline inl_prag , inl_sat = Nothing , inl_act = wrap_act @@ -410,9 +410,9 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs -- arity is consistent with the demand type goes through - wrap_act = ActiveAfter "0" 0 + wrap_act = ActiveAfter NoSourceText 0 wrap_rhs = wrap_fn work_id - wrap_prag = InlinePragma { inl_src = "{-# INLINE" + wrap_prag = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_inline = Inline , inl_sat = Nothing , inl_act = wrap_act diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 5015913880..3069d80128 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -34,6 +34,7 @@ module Inst ( import {-# SOURCE #-} TcExpr( tcPolyExpr, tcSyntaxOp ) import {-# SOURCE #-} TcUnify( unifyType, unifyKind, noThing ) +import BasicTypes ( SourceText(..) ) import FastString import HsSyn import TcHsSyn @@ -639,9 +640,9 @@ getOverlapFlag overlap_mode incoherent_ok = xopt LangExt.IncoherentInstances dflags use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags , overlapMode = x } - default_oflag | incoherent_ok = use (Incoherent "") - | overlap_ok = use (Overlaps "") - | otherwise = use (NoOverlap "") + default_oflag | incoherent_ok = use (Incoherent NoSourceText) + | overlap_ok = use (Overlaps NoSourceText) + | otherwise = use (NoOverlap NoSourceText) final_oflag = setOverlapModeMaybe default_oflag overlap_mode ; return final_oflag } diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 33eb83b401..ddd29b13ed 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -65,6 +65,6 @@ annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod #endif -annCtxt :: (OutputableBndrId id) => AnnDecl id -> SDoc +annCtxt :: (OutputableBndrId id, HasOccNameId id) => AnnDecl id -> SDoc annCtxt ann = hang (text "In the annotation:") 2 (ppr ann) diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index 8285276fae..7bb863d8f9 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -293,7 +293,7 @@ tc_cmd env (HsCmdDo (L l stmts) _) (cmd_stk, res_ty) -- ---------------------------------------------- -- D; G |-a (| e c1 ... cn |) : stk --> t -tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) +tc_cmd env cmd@(HsCmdArrForm expr f fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args -- We use alphaTyVar for 'w' @@ -301,7 +301,7 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) mkFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty ; expr' <- tcPolyExpr expr e_ty - ; return (HsCmdArrForm expr' fixity cmd_args') } + ; return (HsCmdArrForm expr' f fixity cmd_args') } where tc_cmd_arg :: LHsCmdTop Name -> TcM (LHsCmdTop TcId, TcType) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 2206480585..31d650d6dc 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -1703,7 +1703,7 @@ the common case.) -} -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name -patMonoBindsCtxt :: (OutputableBndrId id, Outputable body) +patMonoBindsCtxt :: (OutputableBndrId id, HasOccNameId id, Outputable body) => LPat id -> GRHSs Name body -> SDoc patMonoBindsCtxt pat grhss = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss) diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 6135800752..0d4b8f5609 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -827,10 +827,11 @@ data InstBindings a -- Used only to improve error messages } -instance (OutputableBndrId a) => Outputable (InstInfo a) where +instance (OutputableBndrId a, HasOccNameId a) => Outputable (InstInfo a) where ppr = pprInstInfoDetails -pprInstInfoDetails :: (OutputableBndrId a) => InstInfo a -> SDoc +pprInstInfoDetails :: (OutputableBndrId a, HasOccNameId a) + => InstInfo a -> SDoc pprInstInfoDetails info = hang (pprInstanceHdr (iSpec info) <+> text "where") 2 (details (iBinds info)) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 672f4b3660..84ee6a1f35 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -198,8 +198,8 @@ gen_Eq_binds loc tycon ------------------------------------------------------------------ pats_etc data_con = let - con1_pat = nlConVarPat data_con_RDR as_needed - con2_pat = nlConVarPat data_con_RDR bs_needed + con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed + con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed data_con_RDR = getRdrName data_con con_arity = length tys_needed @@ -439,7 +439,7 @@ gen_Ord_binds loc tycon , mkHsCaseAlt nlWildPat (gtResult op) ] where tag = get_tag data_con - tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag))) + tag_lit = noLoc (HsLit (HsIntPrim NoSourceText (toInteger tag))) mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName) -- First argument 'a' known to be built with K @@ -602,7 +602,7 @@ gen_Enum_binds loc tycon (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") (nlHsApp (nlHsVar (tag2con_RDR tycon)) (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], - nlHsLit (HsInt "-1" (-1))])) + nlHsLit (HsInt NoSourceText (-1))])) to_enum = mk_easy_FunBind loc toEnum_RDR [a_Pat] $ @@ -1118,7 +1118,7 @@ gen_Show_binds get_fixity loc tycon | otherwise = ([a_Pat, con_pat], showParen_Expr (genOpApp a_Expr ge_RDR - (nlHsLit (HsInt "" con_prec_plus_one))) + (nlHsLit (HsInt NoSourceText con_prec_plus_one))) (nlHsPar (nested_compose_Expr show_thingies))) where data_con_RDR = getRdrName data_con @@ -1201,7 +1201,8 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st -- | showsPrec :: Show a => Int -> a -> ShowS mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName -mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x] +mk_showsPrec_app p x + = nlHsApps showsPrec_RDR [nlHsLit (HsInt NoSourceText p), x] -- | shows :: Show a => a -> ShowS mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName @@ -1359,7 +1360,7 @@ gen_data dflags data_type_name constr_names loc rep_tc -- redundant test, and annoying warning | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor | otherwise = nlConPat intDataCon_RDR - [nlLitPat (HsIntPrim "" (toInteger tag))] + [nlLitPat (HsIntPrim NoSourceText (toInteger tag))] where tag = dataConTag dc @@ -1684,7 +1685,7 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty nlHsAppType :: LHsExpr RdrName -> Type -> LHsExpr RdrName nlHsAppType e s = noLoc (e `HsAppType` hs_ty) where - hs_ty = mkHsWildCardBndrs (typeToLHsType s) + hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s) nlExprWithTySig :: LHsExpr RdrName -> Type -> LHsExpr RdrName nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty) @@ -1755,7 +1756,7 @@ genAuxBindSpec loc (DerivCon2Tag tycon) mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName) mk_eqn con = ([nlWildConPat con], - nlHsLit (HsIntPrim "" + nlHsLit (HsIntPrim NoSourceText (toInteger ((dataConTag con) - fIRST_TAG)))) genAuxBindSpec loc (DerivTag2Con tycon) @@ -1776,7 +1777,8 @@ genAuxBindSpec loc (DerivMaxTag tycon) where rdr_name = maxtag_RDR tycon sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy)) - rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag)) + rhs = nlHsApp (nlHsVar intDataCon_RDR) + (nlHsLit (HsIntPrim NoSourceText max_tag)) max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index c57740324e..96dfd4cb61 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -310,7 +310,10 @@ mkSimpleConMatch :: Monad m => HsMatchContext RdrName mkSimpleConMatch ctxt fold extra_pats con insides = do let con_name = getRdrName con let vars_needed = takeList insides as_RDRs - let pat = nlConVarPat con_name vars_needed + let bare_pat = nlConVarPat con_name vars_needed + let pat = if null vars_needed + then bare_pat + else nlParPat bare_pat rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed)) return $ mkMatch ctxt (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds) diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 0c65f686c2..66cf122f63 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -760,8 +760,8 @@ genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName genLR_P i n p | n == 0 = error "impossible" | n == 1 = p - | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] - | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] + | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] + | otherwise = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] where m = div n 2 -- Generates the L1/R1 sum expression @@ -832,12 +832,12 @@ mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars) -- These M1s are meta-information for the constructor where appVars = unzipWith (wrapArg_P gk) varTys - prod a b = prodDataCon_RDR `nlConPat` [a,b] + prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b] wrapArg_P :: GenericKind -> RdrName -> Type -> LPat RdrName -wrapArg_P Gen0 v ty = mkM1_P (boxRepRDR ty `nlConVarPat` [v]) +wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v]) -- This M1 is meta-information for the selector -wrapArg_P Gen1 v _ = m1DataCon_RDR `nlConVarPat` [v] +wrapArg_P Gen1 v _ = nlParPat $ m1DataCon_RDR `nlConVarPat` [v] mkGenericLocal :: US -> RdrName mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) @@ -855,7 +855,7 @@ mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e mkM1_P :: LPat RdrName -> LPat RdrName -mkM1_P p = m1DataCon_RDR `nlConPat` [p] +mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p] nlHsCompose :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName nlHsCompose x y = compose_RDR `nlHsApps` [x, y] diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 3926532628..9f320f5835 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -874,10 +874,10 @@ zonkCmd env (HsCmdArrApp e1 e2 ty ho rl) new_ty <- zonkTcTypeToType env ty return (HsCmdArrApp new_e1 new_e2 new_ty ho rl) -zonkCmd env (HsCmdArrForm op fixity args) +zonkCmd env (HsCmdArrForm op f fixity args) = do new_op <- zonkLExpr env op new_args <- mapM (zonkCmdTop env) args - return (HsCmdArrForm new_op fixity new_args) + return (HsCmdArrForm new_op f fixity new_args) zonkCmd env (HsCmdApp c e) = do new_c <- zonkLCmd env c diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 96d598ea83..d96e74e6d9 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -430,7 +430,7 @@ tc_infer_lhs_type mode (L span ty) -- | Infer the kind of a type and desugar. This is the "up" type-checker, -- as described in Note [Bidirectional type checking] tc_infer_hs_type :: TcTyMode -> HsType Name -> TcM (TcType, TcKind) -tc_infer_hs_type mode (HsTyVar (L _ tv)) = tcTyVar mode tv +tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv tc_infer_hs_type mode (HsAppTy ty1 ty2) = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty @@ -602,7 +602,7 @@ tc_hs_type mode (HsSumTy hs_tys) exp_kind } --------- Promoted lists and tuples -tc_hs_type mode (HsExplicitListTy _k tys) exp_kind +tc_hs_type mode (HsExplicitListTy _ _k tys) exp_kind = do { tks <- mapM (tc_infer_lhs_type mode) tys ; (taus', kind) <- unifyKinds tks ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index dc951b9f83..623458a453 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1293,7 +1293,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys [ getRuntimeRep "tcInstanceMethods.tc_default" meth_tau , meth_tau]) nO_METHOD_BINDING_ERROR_ID - error_msg dflags = L inst_loc (HsLit (HsStringPrim "" + error_msg dflags = L inst_loc (HsLit (HsStringPrim NoSourceText (unsafeMkByteString (error_string dflags)))) meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys) error_string dflags = showSDoc dflags diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index b1d444aee5..10e50d40ae 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -1186,7 +1186,8 @@ polyPatSig sig_ty = hang (text "Illegal polymorphic type signature in pattern:") 2 (ppr sig_ty) -lazyUnliftedPatErr :: (OutputableBndrId name) => Pat name -> TcM () +lazyUnliftedPatErr :: (OutputableBndrId name, HasOccNameId name) + => Pat name -> TcM () lazyUnliftedPatErr pat = failWithTc $ hang (text "A lazy (~) pattern cannot contain unlifted types:") diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 47a27b3853..3e6897117b 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -764,19 +764,22 @@ tcCheckPatSynPat = go go1 SigPatOut{} = panic "SigPatOut in output of renamer" go1 CoPat{} = panic "CoPat in output of renamer" -asPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a +asPatInPatSynErr :: (OutputableBndrId name, HasOccNameId name) + => Pat name -> TcM a asPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain as-patterns (@):") 2 (ppr pat) -thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a +thInPatSynErr :: (OutputableBndrId name, HasOccNameId name) + => Pat name -> TcM a thInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain Template Haskell:") 2 (ppr pat) -nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a +nPlusKPatInPatSynErr :: (OutputableBndrId name, HasOccNameId name) + => Pat name -> TcM a nPlusKPatInPatSynErr pat = failWithTc $ hang (text "Pattern synonym definition cannot contain n+k-pattern:") diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index dd5c9f3191..a0838ee544 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -441,7 +441,7 @@ When a variable is used, we compare ************************************************************************ -} -tcSpliceExpr splice@(HsTypedSplice name expr) res_ty +tcSpliceExpr splice@(HsTypedSplice _ name expr) res_ty = addErrCtxt (spliceCtxtDoc splice) $ setSrcSpan (getLoc expr) $ do { stage <- getStage diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index b9bc595189..24666cfc87 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1157,7 +1157,7 @@ kcDataDefn fam_name (HsIB { hsib_body = pats }) Just k -> do { k' <- tcLHsKind k ; unifyKind (Just hs_ty_pats) res_k k' } } where - hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar (noLoc fam_name)) pats + hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noLoc fam_name)) pats {- Kind check type patterns and kind annotate the embedded type variables. diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index f2a868d4c0..e8046c7876 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -885,7 +885,7 @@ mkOneRecordSelector all_cons idDetails fl inst_tys = substTyVars eq_subst univ_tvs unit_rhs = mkLHsTupleExpr [] - msg_lit = HsStringPrim "" (fastStringToByteString lbl) + msg_lit = HsStringPrim NoSourceText (fastStringToByteString lbl) {- Note [Polymorphic selectors] diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index 04d07d16eb..dd8ed86281 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -8,6 +8,7 @@ module TcTypeable(mkTypeableBinds) where +import BasicTypes ( SourceText(..) ) import TcBinds( addTypecheckedBinds ) import IfaceEnv( newGlobalBinder ) import TcEnv @@ -286,5 +287,6 @@ mkTyConRepRHS (Stuff {..}) tycon = rep_rhs Fingerprint high low = fingerprintString hashThis word64 :: Word64 -> HsLit - word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n) - | otherwise = \n -> HsWordPrim (show n) (toInteger n) + word64 + | wORD_SIZE dflags == 4 = \n -> HsWord64Prim NoSourceText (toInteger n) + | otherwise = \n -> HsWordPrim NoSourceText (toInteger n) diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 26a4d19366..07eb3bcda8 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -980,3 +980,18 @@ instance Binary Serialized where the_type <- get bh bytes <- get bh return (Serialized the_type bytes) + +instance Binary SourceText where + put_ bh NoSourceText = putByte bh 0 + put_ bh (SourceText s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return NoSourceText + 1 -> do + s <- get bh + return (SourceText s) + _ -> panic $ "Binary SourceText:" ++ show h diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs index 4764b1bfce..ec9a8892c6 100644 --- a/compiler/utils/BooleanFormula.hs +++ b/compiler/utils/BooleanFormula.hs @@ -23,6 +23,7 @@ import MonadUtils import Outputable import Binary import SrcLoc +import OccName ( HasOccName(..), isSymOcc ) ---------------------------------------------------------------------- -- Boolean formula type and smart constructors @@ -200,8 +201,19 @@ pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) -instance Outputable a => Outputable (BooleanFormula a) where - pprPrec = pprBooleanFormula pprPrec +instance (Outputable a, HasOccName a) => Outputable (BooleanFormula a) where + ppr = pprBooleanFormulaNormal + +pprBooleanFormulaNormal :: (Outputable a, HasOccName a) + => BooleanFormula a -> SDoc +pprBooleanFormulaNormal = go + where + go (Var x) = pprPrefixVar (isSymOcc (occName x)) (ppr x) + go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) + go (Or []) = keyword $ text "FALSE" + go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) + go (Parens x) = parens (go $ unLoc x) + ---------------------------------------------------------------------- -- Binary diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 1231ab03e5..16f257e017 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -53,7 +53,9 @@ module Outputable ( pprInfixVar, pprPrefixVar, pprHsChar, pprHsString, pprHsBytes, - primFloatSuffix, primDoubleSuffix, + primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, + primInt64Suffix, primWord64Suffix, primIntSuffix, + pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, pprFastFilePath, diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index e5b94b1f38..4560c83e8b 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -14,6 +14,7 @@ import Vectorise.Generic.Description import Vectorise.Utils import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) +import BasicTypes ( SourceText(..) ) import BuildTyCl import DataCon import TyCon @@ -89,7 +90,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) repr_tc where - no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict -- buildPDatasTyCon ----------------------------------------------------------- @@ -133,7 +134,7 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr (mkFamilyTyConApp repr_tc (mkTyVarTys tvs)) repr_tc where - no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict -- Utils ---------------------------------------------------------------------- |