diff options
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 ---------------------------------------------------------------------- |