diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2016-11-08 21:37:48 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2016-12-07 21:31:13 +0200 |
| commit | 499e43824bda967546ebf95ee33ec1f84a114a7c (patch) | |
| tree | 58b313d734cfba014395ea5876db48e8400296a8 | |
| parent | 83d69dca896c7df1f2a36268d5b45c9283985ebf (diff) | |
| download | haskell-499e43824bda967546ebf95ee33ec1f84a114a7c.tar.gz | |
Add HsSyn prettyprinter tests
Summary:
Add prettyprinter tests, which take a file, parse it, pretty print it,
re-parse the pretty printed version and then compare the original and
new ASTs (ignoring locations)
Updates haddock submodule to match the AST changes.
There are three issues outstanding
1. Extra parens around a context are not reproduced. This will require an
AST change and will be done in a separate patch.
2. Currently if an `HsTickPragma` is found, this is not pretty-printed,
to prevent noise in the output.
I am not sure what the desired behaviour in this case is, so have left
it as before. Test Ppr047 is marked as expected fail for this.
3. Apart from in a context, the ParsedSource AST keeps all the parens from
the original source. Something is happening in the renamer to remove the
parens around visible type application, causing T12530 to fail, as the
dumped splice decl is after the renamer.
This needs to be fixed by keeping the parens, but I do not know where they
are being removed. I have amended the test to pass, by removing the parens
in the expected output.
Test Plan: ./validate
Reviewers: goldfire, mpickering, simonpj, bgamari, austin
Reviewed By: simonpj, bgamari
Subscribers: simonpj, goldfire, thomie, mpickering
Differential Revision: https://phabricator.haskell.org/D2752
GHC Trac Issues: #3384
261 files changed, 5478 insertions, 1219 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 ---------------------------------------------------------------------- @@ -563,6 +563,7 @@ ghc/stage2/package-data.mk: compiler/stage2/package-data.mk utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk utils/ghctags/dist-install/package-data.mk: compiler/stage2/package-data.mk utils/check-api-annotations/dist-install/package-data.mk: compiler/stage2/package-data.mk +utils/check-ppr/dist-install/package-data.mk: compiler/stage2/package-data.mk utils/mkUserGuidePart/dist/package-data.mk: compiler/stage2/package-data.mk # add the final package.conf dependency: ghc-prim depends on RTS @@ -681,6 +682,7 @@ BUILD_DIRS += utils/ghc-pkg BUILD_DIRS += utils/testremove BUILD_DIRS += utils/ghctags BUILD_DIRS += utils/check-api-annotations +BUILD_DIRS += utils/check-ppr BUILD_DIRS += utils/dll-split BUILD_DIRS += utils/ghc-cabal BUILD_DIRS += utils/hpc @@ -734,6 +736,7 @@ ifneq "$(CrossCompiling) $(Stage1Only)" "NO NO" # See Note [Stage1Only vs stage=1] in mk/config.mk.in. BUILD_DIRS := $(filter-out utils/ghctags,$(BUILD_DIRS)) BUILD_DIRS := $(filter-out utils/check-api-annotations,$(BUILD_DIRS)) +BUILD_DIRS := $(filter-out utils/check-ppr,$(BUILD_DIRS)) endif endif # CLEANING diff --git a/testsuite/mk/boilerplate.mk b/testsuite/mk/boilerplate.mk index 93b4f01f40..0b684c7195 100644 --- a/testsuite/mk/boilerplate.mk +++ b/testsuite/mk/boilerplate.mk @@ -220,6 +220,7 @@ RM = rm -f PYTHON = python3 CHECK_API_ANNOTATIONS := $(abspath $(TOP)/../inplace/bin/check-api-annotations) +CHECK_PPR := $(abspath $(TOP)/../inplace/bin/check-ppr) # ----------------------------------------------------------------------------- # configuration of TEST_HC diff --git a/testsuite/tests/ado/ado002.stderr b/testsuite/tests/ado/ado002.stderr index fe730f6c91..c2fb6b63b1 100644 --- a/testsuite/tests/ado/ado002.stderr +++ b/testsuite/tests/ado/ado002.stderr @@ -6,9 +6,9 @@ ado002.hs:8:8: error: but its type ‘IO Char’ has none In a stmt of a 'do' block: y <- getChar 'a' In the expression: - do { x <- getChar; - y <- getChar 'a'; - print (x, y) } + do x <- getChar + y <- getChar 'a' + print (x, y) ado002.hs:9:3: error: • Couldn't match type ‘()’ with ‘Int’ @@ -16,31 +16,31 @@ ado002.hs:9:3: error: Actual type: IO () • In a stmt of a 'do' block: print (x, y) In the expression: - do { x <- getChar; - y <- getChar 'a'; - print (x, y) } + do x <- getChar + y <- getChar 'a' + print (x, y) In an equation for ‘f’: - f = do { x <- getChar; - y <- getChar 'a'; - print (x, y) } + f = do x <- getChar + y <- getChar 'a' + print (x, y) ado002.hs:15:11: error: • Couldn't match expected type ‘Int’ with actual type ‘Char’ • In the expression: y In a stmt of a 'do' block: return (y, x) In the expression: - do { x <- getChar; - y <- getChar; - return (y, x) } + do x <- getChar + y <- getChar + return (y, x) ado002.hs:15:13: error: • Couldn't match expected type ‘Int’ with actual type ‘Char’ • In the expression: x In a stmt of a 'do' block: return (y, x) In the expression: - do { x <- getChar; - y <- getChar; - return (y, x) } + do x <- getChar + y <- getChar + return (y, x) ado002.hs:23:9: error: • Couldn't match expected type ‘Char -> IO t0’ @@ -49,33 +49,33 @@ ado002.hs:23:9: error: but its type ‘IO Char’ has none In a stmt of a 'do' block: x5 <- getChar x4 In the expression: - do { x1 <- getChar; - x2 <- getChar; - x3 <- const (return ()) x1; - x4 <- getChar; - x5 <- getChar x4; - return (x2, x4) } + do x1 <- getChar + x2 <- getChar + x3 <- const (return ()) x1 + x4 <- getChar + x5 <- getChar x4 + return (x2, x4) ado002.hs:24:11: error: • Couldn't match expected type ‘Int’ with actual type ‘Char’ • In the expression: x2 In a stmt of a 'do' block: return (x2, x4) In the expression: - do { x1 <- getChar; - x2 <- getChar; - x3 <- const (return ()) x1; - x4 <- getChar; - x5 <- getChar x4; - return (x2, x4) } + do x1 <- getChar + x2 <- getChar + x3 <- const (return ()) x1 + x4 <- getChar + x5 <- getChar x4 + return (x2, x4) ado002.hs:24:14: error: • Couldn't match expected type ‘Int’ with actual type ‘Char’ • In the expression: x4 In a stmt of a 'do' block: return (x2, x4) In the expression: - do { x1 <- getChar; - x2 <- getChar; - x3 <- const (return ()) x1; - x4 <- getChar; - x5 <- getChar x4; - return (x2, x4) } + do x1 <- getChar + x2 <- getChar + x3 <- const (return ()) x1 + x4 <- getChar + x5 <- getChar x4 + return (x2, x4) diff --git a/testsuite/tests/ado/ado003.stderr b/testsuite/tests/ado/ado003.stderr index 5d04f15896..cdc5c59d38 100644 --- a/testsuite/tests/ado/ado003.stderr +++ b/testsuite/tests/ado/ado003.stderr @@ -4,6 +4,6 @@ ado003.hs:7:3: error: In the pattern: 'a' In a stmt of a 'do' block: 'a' <- return (3 :: Int) In the expression: - do { x <- getChar; - 'a' <- return (3 :: Int); - return () } + do x <- getChar + 'a' <- return (3 :: Int) + return () diff --git a/testsuite/tests/ado/ado005.stderr b/testsuite/tests/ado/ado005.stderr index 4bfc79eca4..90d0b023bf 100644 --- a/testsuite/tests/ado/ado005.stderr +++ b/testsuite/tests/ado/ado005.stderr @@ -11,11 +11,11 @@ ado005.hs:8:3: error: test :: Applicative f => (Int -> f Int) -> f Int In a stmt of a 'do' block: x <- f 3 In the expression: - do { x <- f 3; - y <- f x; - return (x + y) } + do x <- f 3 + y <- f x + return (x + y) In an equation for ‘test’: test f - = do { x <- f 3; - y <- f x; - return (x + y) } + = do x <- f 3 + y <- f x + return (x + y) diff --git a/testsuite/tests/arrows/should_fail/arrowfail004.stderr b/testsuite/tests/arrows/should_fail/arrowfail004.stderr index 1386d14ce2..e479369554 100644 --- a/testsuite/tests/arrows/should_fail/arrowfail004.stderr +++ b/testsuite/tests/arrows/should_fail/arrowfail004.stderr @@ -2,6 +2,6 @@ arrowfail004.hs:12:15: Proc patterns cannot use existential or GADT data constructors In the pattern: T x - In the expression: proc (T x) -> do { returnA -< T x } + In the expression: proc (T x) -> do returnA -< T x In an equation for ‘panic’: - panic = proc (T x) -> do { returnA -< T x } + panic = proc (T x) -> do returnA -< T x diff --git a/testsuite/tests/boxy/Base1.stderr b/testsuite/tests/boxy/Base1.stderr index 053a3bc105..75a8e0cfe2 100644 --- a/testsuite/tests/boxy/Base1.stderr +++ b/testsuite/tests/boxy/Base1.stderr @@ -13,6 +13,6 @@ Base1.hs:25:39: error: • In the expression: Just (x, y) In a case alternative: MRight y -> Just (x, y) In the expression: - case m of { + case m of MRight y -> Just (x, y) - _ -> Nothing } + _ -> Nothing diff --git a/testsuite/tests/dependent/should_fail/PromotedClass.stderr b/testsuite/tests/dependent/should_fail/PromotedClass.stderr index 544124ed07..f0683309bc 100644 --- a/testsuite/tests/dependent/should_fail/PromotedClass.stderr +++ b/testsuite/tests/dependent/should_fail/PromotedClass.stderr @@ -1,6 +1,5 @@ PromotedClass.hs:10:15: error: • Illegal constraint in a type: Show a0 - • In the first argument of ‘Proxy’, namely ‘MkX True’ - In the type signature: - foo :: Proxy (MkX True) + • In the first argument of ‘Proxy’, namely ‘( 'MkX 'True)’ + In the type signature: foo :: Proxy ( 'MkX 'True) diff --git a/testsuite/tests/dependent/should_fail/RAE_T32a.stderr b/testsuite/tests/dependent/should_fail/RAE_T32a.stderr index 1a54c7d53b..cb94dd2854 100644 --- a/testsuite/tests/dependent/should_fail/RAE_T32a.stderr +++ b/testsuite/tests/dependent/should_fail/RAE_T32a.stderr @@ -15,5 +15,5 @@ RAE_T32a.hs:28:20: error: RAE_T32a.hs:28:27: error: Expected kind ‘Sigma’, but ‘Sigma p r’ has kind ‘*’ - In the second argument of ‘Sing’, namely ‘Sigma p r’ + In the second argument of ‘Sing’, namely ‘(Sigma p r)’ In the data instance declaration for ‘Sing’ diff --git a/testsuite/tests/dependent/should_fail/T11334b.stderr b/testsuite/tests/dependent/should_fail/T11334b.stderr index 8f4251b0cd..effdf20828 100644 --- a/testsuite/tests/dependent/should_fail/T11334b.stderr +++ b/testsuite/tests/dependent/should_fail/T11334b.stderr @@ -3,22 +3,22 @@ T11334b.hs:8:14: error: • Cannot default kind variable ‘f0’ of kind: k0 -> * Perhaps enable PolyKinds or add a kind signature - • In an expression type signature: Proxy Compose - In the expression: Proxy :: Proxy Compose - In an equation for ‘p’: p = Proxy :: Proxy Compose + • In an expression type signature: Proxy 'Compose + In the expression: Proxy :: Proxy 'Compose + In an equation for ‘p’: p = Proxy :: Proxy 'Compose T11334b.hs:8:14: error: • Cannot default kind variable ‘g0’ of kind: k10 -> k0 Perhaps enable PolyKinds or add a kind signature - • In an expression type signature: Proxy Compose - In the expression: Proxy :: Proxy Compose - In an equation for ‘p’: p = Proxy :: Proxy Compose + • In an expression type signature: Proxy 'Compose + In the expression: Proxy :: Proxy 'Compose + In an equation for ‘p’: p = Proxy :: Proxy 'Compose T11334b.hs:8:14: error: • Cannot default kind variable ‘a0’ of kind: k10 Perhaps enable PolyKinds or add a kind signature - • In an expression type signature: Proxy Compose - In the expression: Proxy :: Proxy Compose - In an equation for ‘p’: p = Proxy :: Proxy Compose + • In an expression type signature: Proxy 'Compose + In the expression: Proxy :: Proxy 'Compose + In an equation for ‘p’: p = Proxy :: Proxy 'Compose diff --git a/testsuite/tests/ffi/should_fail/T10461.stderr b/testsuite/tests/ffi/should_fail/T10461.stderr index fae0f50b14..3421467715 100644 --- a/testsuite/tests/ffi/should_fail/T10461.stderr +++ b/testsuite/tests/ffi/should_fail/T10461.stderr @@ -4,4 +4,4 @@ T10461.hs:6:1: error: ‘Word#’ cannot be marshalled in a foreign call To marshal unlifted types, use UnliftedFFITypes When checking declaration: - foreign import prim safe "static cheneycopy" cheneycopy :: Any -> Word# + foreign import prim safe cheneycopy :: Any -> Word# diff --git a/testsuite/tests/ffi/should_fail/T3066.stderr b/testsuite/tests/ffi/should_fail/T3066.stderr index e6d292d4ec..3b6c3f9b47 100644 --- a/testsuite/tests/ffi/should_fail/T3066.stderr +++ b/testsuite/tests/ffi/should_fail/T3066.stderr @@ -3,5 +3,4 @@ T3066.hs:6:1: Unacceptable argument type in foreign declaration: ‘forall u. Ptr ()’ is not a data type When checking declaration: - foreign import ccall safe "static bla" bla - :: (forall u. X u) -> IO () + foreign import ccall safe bla :: (forall u. X u) -> IO () diff --git a/testsuite/tests/ffi/should_fail/T7506.stderr b/testsuite/tests/ffi/should_fail/T7506.stderr index dd893df155..9a1aa25a8e 100644 --- a/testsuite/tests/ffi/should_fail/T7506.stderr +++ b/testsuite/tests/ffi/should_fail/T7506.stderr @@ -4,5 +4,5 @@ T7506.hs:6:1: ‘Int -> IO ()’ cannot be marshalled in a foreign call A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a) When checking declaration: - foreign import ccall safe "static stdio.h &putchar" c_putchar + foreign import ccall safe "stdio.h &putchar" c_putchar :: Int -> IO () diff --git a/testsuite/tests/ffi/should_fail/capi_value_function.stderr b/testsuite/tests/ffi/should_fail/capi_value_function.stderr index 99ffad6ab8..6732c5c2da 100644 --- a/testsuite/tests/ffi/should_fail/capi_value_function.stderr +++ b/testsuite/tests/ffi/should_fail/capi_value_function.stderr @@ -2,5 +2,4 @@ capi_value_function.hs:8:1: `value' imports cannot have function types When checking declaration: - foreign import capi safe "static math.h value sqrt" f - :: CInt -> CInt + foreign import capi safe "math.h value sqrt" f :: CInt -> CInt diff --git a/testsuite/tests/ffi/should_fail/ccfail001.stderr b/testsuite/tests/ffi/should_fail/ccfail001.stderr index e890041b02..01c7ea5d15 100644 --- a/testsuite/tests/ffi/should_fail/ccfail001.stderr +++ b/testsuite/tests/ffi/should_fail/ccfail001.stderr @@ -3,5 +3,4 @@ ccfail001.hs:10:1: Unacceptable result type in foreign declaration: ‘State# RealWorld’ cannot be marshalled in a foreign call When checking declaration: - foreign import ccall safe "static foo" foo - :: Int -> State# RealWorld + foreign import ccall safe foo :: Int -> State# RealWorld diff --git a/testsuite/tests/ffi/should_fail/ccfail002.stderr b/testsuite/tests/ffi/should_fail/ccfail002.stderr index 309fa521d2..c3c04e25d5 100644 --- a/testsuite/tests/ffi/should_fail/ccfail002.stderr +++ b/testsuite/tests/ffi/should_fail/ccfail002.stderr @@ -3,5 +3,5 @@ ccfail002.hs:10:1: Unacceptable result type in foreign declaration: ‘(# Int#, Int#, Int# #)’ cannot be marshalled in a foreign call When checking declaration: - foreign import ccall unsafe "static foo" foo + foreign import ccall unsafe "foo" foo :: Int# -> Int# -> Int# -> (# Int#, Int#, Int# #) diff --git a/testsuite/tests/ffi/should_fail/ccfail004.stderr b/testsuite/tests/ffi/should_fail/ccfail004.stderr index 825c47ca1e..60aaf30188 100644 --- a/testsuite/tests/ffi/should_fail/ccfail004.stderr +++ b/testsuite/tests/ffi/should_fail/ccfail004.stderr @@ -5,7 +5,7 @@ ccfail004.hs:9:1: because its data constructor is not in scope Possible fix: import the data constructor to bring it into scope When checking declaration: - foreign import ccall safe "static f1" f1 :: NInt -> IO Int + foreign import ccall safe f1 :: NInt -> IO Int ccfail004.hs:10:1: Unacceptable result type in foreign declaration: @@ -13,7 +13,7 @@ ccfail004.hs:10:1: because its data constructor is not in scope Possible fix: import the data constructor to bring it into scope When checking declaration: - foreign import ccall safe "static f2" f2 :: Int -> IO NInt + foreign import ccall safe f2 :: Int -> IO NInt ccfail004.hs:11:1: Unacceptable result type in foreign declaration: @@ -21,16 +21,16 @@ ccfail004.hs:11:1: because the data constructor for ‘NIO’ is not in scope Possible fix: import the data constructor to bring it into scope When checking declaration: - foreign import ccall safe "static f3" f3 :: Int -> NIO Int + foreign import ccall safe f3 :: Int -> NIO Int ccfail004.hs:14:1: Unacceptable argument type in foreign declaration: ‘[NT]’ cannot be marshalled in a foreign call When checking declaration: - foreign import ccall safe "static f4" f4 :: NT -> IO () + foreign import ccall safe f4 :: NT -> IO () ccfail004.hs:15:1: Unacceptable result type in foreign declaration: ‘[NT]’ cannot be marshalled in a foreign call When checking declaration: - foreign import ccall safe "static f5" f5 :: IO NT + foreign import ccall safe f5 :: IO NT diff --git a/testsuite/tests/ffi/should_fail/ccfail005.stderr b/testsuite/tests/ffi/should_fail/ccfail005.stderr index 413faa702c..d5e2a27901 100644 --- a/testsuite/tests/ffi/should_fail/ccfail005.stderr +++ b/testsuite/tests/ffi/should_fail/ccfail005.stderr @@ -2,11 +2,9 @@ ccfail005.hs:14:1: Unacceptable argument type in foreign declaration: ‘D’ cannot be marshalled in a foreign call - When checking declaration: - foreign import ccall safe "static f1" f1 :: F Bool + When checking declaration: foreign import ccall safe f1 :: F Bool ccfail005.hs:15:1: Unacceptable result type in foreign declaration: ‘D’ cannot be marshalled in a foreign call - When checking declaration: - foreign import ccall safe "static f2" f2 :: F Char + When checking declaration: foreign import ccall safe f2 :: F Char diff --git a/testsuite/tests/generics/GenDerivOutput.stderr b/testsuite/tests/generics/GenDerivOutput.stderr index 65dcadba85..3e1f175178 100644 --- a/testsuite/tests/generics/GenDerivOutput.stderr +++ b/testsuite/tests/generics/GenDerivOutput.stderr @@ -4,7 +4,7 @@ Derived class instances: instance GHC.Generics.Generic (GenDerivOutput.List a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of GenDerivOutput.Nil -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) GenDerivOutput.Cons g1 g2 @@ -12,19 +12,19 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput.Nil - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) - -> GenDerivOutput.Cons g1 g2 } + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) + -> GenDerivOutput.Cons g1 g2 instance GHC.Generics.Generic1 GenDerivOutput.List where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of GenDerivOutput.Nil -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) GenDerivOutput.Cons g1 g2 @@ -32,15 +32,15 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.Par1 g1)) - (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput.Nil - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> GenDerivOutput.Cons - (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) } + (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) instance GHC.Base.Functor GenDerivOutput.List where GHC.Base.fmap f GenDerivOutput.Nil = GenDerivOutput.Nil @@ -50,7 +50,7 @@ Derived class instances: instance GHC.Generics.Generic (GenDerivOutput.Rose a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of GenDerivOutput.Empty -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) GenDerivOutput.Rose g1 g2 @@ -58,19 +58,19 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput.Empty - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) - -> GenDerivOutput.Rose g1 g2 } + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) + -> GenDerivOutput.Rose g1 g2 instance GHC.Generics.Generic1 GenDerivOutput.Rose where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of GenDerivOutput.Empty -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) GenDerivOutput.Rose g1 g2 @@ -80,17 +80,17 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.Par1 g1)) (GHC.Generics.M1 ((GHC.Base..) - GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g2)))) }) + GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput.Empty - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> GenDerivOutput.Rose (GHC.Generics.unPar1 g1) ((GHC.Base..) - (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g2) } + (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g2) Derived type family instances: diff --git a/testsuite/tests/generics/GenDerivOutput1_0.stderr b/testsuite/tests/generics/GenDerivOutput1_0.stderr index 162fa0fa08..bf9cf1590c 100644 --- a/testsuite/tests/generics/GenDerivOutput1_0.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_0.stderr @@ -4,7 +4,7 @@ Derived class instances: instance GHC.Generics.Generic1 GenDerivOutput1_0.List where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of GenDerivOutput1_0.Nil -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) GenDerivOutput1_0.Cons g1 g2 @@ -12,15 +12,15 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.Par1 g1)) - (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> GenDerivOutput1_0.Nil - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> GenDerivOutput1_0.Cons - (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) } + (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) Derived type family instances: diff --git a/testsuite/tests/generics/GenDerivOutput1_1.stderr b/testsuite/tests/generics/GenDerivOutput1_1.stderr index 31a9e4368a..5f4e7e241d 100644 --- a/testsuite/tests/generics/GenDerivOutput1_1.stderr +++ b/testsuite/tests/generics/GenDerivOutput1_1.stderr @@ -4,7 +4,7 @@ Derived class instances: instance GHC.Generics.Generic1 CanDoRep1_1.Dd where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of CanDoRep1_1.D0d -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) CanDoRep1_1.D1d g1 g2 @@ -12,20 +12,20 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.Par1 g1)) - (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0d - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> CanDoRep1_1.D1d - (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) } + (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) instance GHC.Generics.Generic (CanDoRep1_1.Dd a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of CanDoRep1_1.D0d -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) CanDoRep1_1.D1d g1 g2 @@ -33,19 +33,19 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0d - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) - -> CanDoRep1_1.D1d g1 g2 } + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) + -> CanDoRep1_1.D1d g1 g2 instance GHC.Generics.Generic (CanDoRep1_1.Dc a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of CanDoRep1_1.D0c -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) CanDoRep1_1.D1c g1 g2 @@ -53,19 +53,19 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0c - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) - -> CanDoRep1_1.D1c g1 g2 } + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) + -> CanDoRep1_1.D1c g1 g2 instance GHC.Generics.Generic1 CanDoRep1_1.Db where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of CanDoRep1_1.D0b -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) CanDoRep1_1.D1b g1 g2 @@ -73,57 +73,58 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.Par1 g1)) - (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0b - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> CanDoRep1_1.D1b - (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) } + (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) instance GHC.Generics.Generic (CanDoRep1_1.Da a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of CanDoRep1_1.D0 -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) CanDoRep1_1.D1 g1 g2 -> GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) -> CanDoRep1_1.D0 - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) - -> CanDoRep1_1.D1 g1 g2 } + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) + -> CanDoRep1_1.D0 + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) + -> CanDoRep1_1.D1 g1 g2 instance GHC.Generics.Generic1 CanDoRep1_1.Da where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of CanDoRep1_1.D0 -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) CanDoRep1_1.D1 g1 g2 -> GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.Par1 g1)) - (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) -> CanDoRep1_1.D0 - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) - -> CanDoRep1_1.D1 - (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) } + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) + -> CanDoRep1_1.D0 + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) + -> CanDoRep1_1.D1 (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) instance GHC.Generics.Generic (CanDoRep1_1.Db a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of CanDoRep1_1.D0b -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) CanDoRep1_1.D1b g1 g2 @@ -131,19 +132,19 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0b - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) - -> CanDoRep1_1.D1b g1 g2 } + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) + -> CanDoRep1_1.D1b g1 g2 instance GHC.Generics.Generic1 CanDoRep1_1.Dc where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of CanDoRep1_1.D0c -> GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) CanDoRep1_1.D1c g1 g2 @@ -151,15 +152,15 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.Par1 g1)) - (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 GHC.Generics.U1)) -> CanDoRep1_1.D0c - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> CanDoRep1_1.D1c - (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) } + (GHC.Generics.unPar1 g1) (GHC.Generics.unRec1 g2) Derived type family instances: diff --git a/testsuite/tests/generics/T10604/T10604_deriving.stderr b/testsuite/tests/generics/T10604/T10604_deriving.stderr index 9576346899..d90c2733b1 100644 --- a/testsuite/tests/generics/T10604/T10604_deriving.stderr +++ b/testsuite/tests/generics/T10604/T10604_deriving.stderr @@ -33,7 +33,7 @@ Derived class instances: T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1 }) GHC.Generics.to (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 GHC.Generics.U1 -> T10604_deriving.Proxy } + (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy } instance GHC.Generics.Generic1 k (T10604_deriving.Proxy k) where GHC.Generics.from1 x @@ -42,7 +42,7 @@ Derived class instances: T10604_deriving.Proxy -> GHC.Generics.M1 GHC.Generics.U1 }) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 GHC.Generics.U1 -> T10604_deriving.Proxy } + (GHC.Generics.M1 GHC.Generics.U1) -> T10604_deriving.Proxy } instance GHC.Generics.Generic (T10604_deriving.Wrap a) where GHC.Generics.from x @@ -52,7 +52,7 @@ Derived class instances: -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) }) GHC.Generics.to (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) -> T10604_deriving.Wrap g1 } instance GHC.Generics.Generic1 @@ -64,7 +64,7 @@ Derived class instances: -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.Rec1 g1)) }) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 (GHC.Generics.M1 g1) + (GHC.Generics.M1 (GHC.Generics.M1 g1)) -> T10604_deriving.Wrap (GHC.Generics.unRec1 g1) } instance forall k (a :: k -> GHC.Types.*). @@ -76,7 +76,7 @@ Derived class instances: -> GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) }) GHC.Generics.to (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) -> T10604_deriving.Wrap2 g1 } instance GHC.Generics.Generic1 @@ -91,7 +91,7 @@ Derived class instances: GHC.Generics.Comp1 (GHC.Base.fmap GHC.Generics.Rec1) g1)) }) GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { - GHC.Generics.M1 (GHC.Generics.M1 g1) + (GHC.Generics.M1 (GHC.Generics.M1 g1)) -> T10604_deriving.Wrap2 ((GHC.Base..) (GHC.Base.fmap GHC.Generics.unRec1) GHC.Generics.unComp1 g1) } @@ -100,7 +100,7 @@ Derived class instances: GHC.Generics.Generic (T10604_deriving.SumOfProducts k a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of T10604_deriving.Prod1 g1 g2 -> GHC.Generics.L1 (GHC.Generics.M1 @@ -112,21 +112,21 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) -> T10604_deriving.Prod1 g1 g2 - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) - (GHC.Generics.M1 (GHC.Generics.K1 g2)))) - -> T10604_deriving.Prod2 g1 g2 } + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.K1 g1)) + (GHC.Generics.M1 (GHC.Generics.K1 g2))))) + -> T10604_deriving.Prod2 g1 g2 instance GHC.Generics.Generic1 k (T10604_deriving.SumOfProducts k) where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of T10604_deriving.Prod1 g1 g2 -> GHC.Generics.L1 (GHC.Generics.M1 @@ -138,51 +138,51 @@ Derived class instances: (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 (GHC.Generics.Rec1 g1)) - (GHC.Generics.M1 (GHC.Generics.Rec1 g2)))) }) + (GHC.Generics.M1 (GHC.Generics.Rec1 g2))))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> T10604_deriving.Prod1 (GHC.Generics.unRec1 g1) (GHC.Generics.unRec1 g2) - GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) - (GHC.Generics.M1 g2))) + (GHC.Generics.R1 (GHC.Generics.M1 ((GHC.Generics.:*:) (GHC.Generics.M1 g1) + (GHC.Generics.M1 g2)))) -> T10604_deriving.Prod2 - (GHC.Generics.unRec1 g1) (GHC.Generics.unRec1 g2) } + (GHC.Generics.unRec1 g1) (GHC.Generics.unRec1 g2) instance GHC.Generics.Generic (T10604_deriving.Starify a) where GHC.Generics.from x = GHC.Generics.M1 - (case x of { + (case x of T10604_deriving.Starify1 g1 -> GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) T10604_deriving.Starify2 g1 -> GHC.Generics.R1 - (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) }) + (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))) GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))) -> T10604_deriving.Starify1 g1 - GHC.Generics.R1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) - -> T10604_deriving.Starify2 g1 } + (GHC.Generics.R1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))) + -> T10604_deriving.Starify2 g1 instance GHC.Generics.Generic1 * T10604_deriving.Starify where GHC.Generics.from1 x = GHC.Generics.M1 - (case x of { + (case x of T10604_deriving.Starify1 g1 -> GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.Par1 g1))) T10604_deriving.Starify2 g1 -> GHC.Generics.R1 - (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) }) + (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1)))) GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 g1)) + = case x of + (GHC.Generics.L1 (GHC.Generics.M1 (GHC.Generics.M1 g1))) -> T10604_deriving.Starify1 (GHC.Generics.unPar1 g1) - GHC.Generics.R1 (GHC.Generics.M1 (GHC.Generics.M1 g1)) - -> T10604_deriving.Starify2 (GHC.Generics.unK1 g1) } + (GHC.Generics.R1 (GHC.Generics.M1 (GHC.Generics.M1 g1))) + -> T10604_deriving.Starify2 (GHC.Generics.unK1 g1) Derived type family instances: diff --git a/testsuite/tests/ghc-api/annotations-literals/literals.stdout b/testsuite/tests/ghc-api/annotations-literals/literals.stdout index 077c570f2b..0e8ce7c9dc 100644 --- a/testsuite/tests/ghc-api/annotations-literals/literals.stdout +++ b/testsuite/tests/ghc-api/annotations-literals/literals.stdout @@ -24,7 +24,7 @@ (LiteralsTest.hs:5:3,ITequal,[=]), -(LiteralsTest.hs:5:5-8,ITinteger "0003" 3,[0003]), +(LiteralsTest.hs:5:5-8,ITinteger (SourceText "0003") 3,[0003]), (LiteralsTest.hs:6:1,ITsemi,[]), @@ -32,7 +32,7 @@ (LiteralsTest.hs:6:3,ITequal,[=]), -(LiteralsTest.hs:6:5-8,ITinteger "0x04" 4,[0x04]), +(LiteralsTest.hs:6:5-8,ITinteger (SourceText "0x04") 4,[0x04]), (LiteralsTest.hs:8:1,ITsemi,[]), @@ -48,7 +48,7 @@ (LiteralsTest.hs:9:3,ITequal,[=]), -(LiteralsTest.hs:9:5-10,ITstring "\"\\x20\"" " ",["\x20"]), +(LiteralsTest.hs:9:5-10,ITstring (SourceText "\"\\x20\"") " ",["\x20"]), (LiteralsTest.hs:11:1,ITsemi,[]), @@ -64,7 +64,7 @@ (LiteralsTest.hs:12:3,ITequal,[=]), -(LiteralsTest.hs:12:5-10,ITchar "'\\x20'" ' ',['\x20']), +(LiteralsTest.hs:12:5-10,ITchar (SourceText "'\\x20'") ' ',['\x20']), (LiteralsTest.hs:14:1,ITsemi,[]), @@ -98,7 +98,7 @@ (LiteralsTest.hs:19:11,ITequal,[=]), -(LiteralsTest.hs:19:13-19,ITprimchar "'\\x41'" 'A',['\x41'#]), +(LiteralsTest.hs:19:13-19,ITprimchar (SourceText "'\\x41'") 'A',['\x41'#]), (LiteralsTest.hs:20:5,ITsemi,[]), @@ -106,7 +106,7 @@ (LiteralsTest.hs:20:10,ITequal,[=]), -(LiteralsTest.hs:20:12-16,ITprimint "0004#" 4,[0004#]), +(LiteralsTest.hs:20:12-16,ITprimint (SourceText "0004#") 4,[0004#]), (LiteralsTest.hs:21:5,ITsemi,[]), @@ -114,7 +114,7 @@ (LiteralsTest.hs:21:11,ITequal,[=]), -(LiteralsTest.hs:21:13-17,ITprimword "005##" 5,[005##]), +(LiteralsTest.hs:21:13-17,ITprimword (SourceText "005##") 5,[005##]), (LiteralsTest.hs:22:5,ITsemi,[]), @@ -138,7 +138,7 @@ (LiteralsTest.hs:24:7,ITequal,[=]), -(LiteralsTest.hs:24:9,ITinteger "1" 1,[1]), +(LiteralsTest.hs:24:9,ITinteger (SourceText "1") 1,[1]), (LiteralsTest.hs:25:1,ITvccurly,[]), diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.hs b/testsuite/tests/ghc-api/annotations-literals/parsed.hs index 8664fdcf13..0170bc2949 100644 --- a/testsuite/tests/ghc-api/annotations-literals/parsed.hs +++ b/testsuite/tests/ghc-api/annotations-literals/parsed.hs @@ -3,7 +3,7 @@ -- argument. module Main where --- import Data.Generics +import BasicTypes import Data.Data import Data.List import System.IO @@ -42,21 +42,33 @@ testOneFile libdir fileName = do gq ast = everything (++) ([] `mkQ` doHsLit `extQ` doOverLit) ast doHsLit :: HsLit -> [String] - doHsLit (HsChar src c) = ["HsChar [" ++ src ++ "] " ++ show c] - doHsLit (HsCharPrim src c) = ["HsCharPrim [" ++ src ++ "] " ++ show c] - doHsLit (HsString src c) = ["HsString [" ++ src ++ "] " ++ show c] - doHsLit (HsStringPrim src c) = ["HsStringPrim [" ++ src ++ "] " ++ show c] - doHsLit (HsInt src c) = ["HsInt [" ++ src ++ "] " ++ show c] - doHsLit (HsIntPrim src c) = ["HsIntPrim [" ++ src ++ "] " ++ show c] - doHsLit (HsWordPrim src c) = ["HsWordPrim [" ++ src ++ "] " ++ show c] - doHsLit (HsInt64Prim src c) = ["HsInt64Prim [" ++ src ++ "] " ++ show c] - doHsLit (HsWord64Prim src c) = ["HsWord64Prim [" ++ src ++ "] " ++ show c] - doHsLit (HsInteger src c _) = ["HsInteger [" ++ src ++ "] " ++ show c] + doHsLit (HsChar (SourceText src) c) + = ["HsChar [" ++ src ++ "] " ++ show c] + doHsLit (HsCharPrim (SourceText src) c) + = ["HsCharPrim [" ++ src ++ "] " ++ show c] + doHsLit (HsString (SourceText src) c) + = ["HsString [" ++ src ++ "] " ++ show c] + doHsLit (HsStringPrim (SourceText src) c) + = ["HsStringPrim [" ++ src ++ "] " ++ show c] + doHsLit (HsInt (SourceText src) c) + = ["HsInt [" ++ src ++ "] " ++ show c] + doHsLit (HsIntPrim (SourceText src) c) + = ["HsIntPrim [" ++ src ++ "] " ++ show c] + doHsLit (HsWordPrim (SourceText src) c) + = ["HsWordPrim [" ++ src ++ "] " ++ show c] + doHsLit (HsInt64Prim (SourceText src) c) + = ["HsInt64Prim [" ++ src ++ "] " ++ show c] + doHsLit (HsWord64Prim (SourceText src) c) + = ["HsWord64Prim [" ++ src ++ "] " ++ show c] + doHsLit (HsInteger (SourceText src) c _) + = ["HsInteger [" ++ src ++ "] " ++ show c] doHsLit _ = [] doOverLit :: OverLitVal -> [String] - doOverLit (HsIntegral src c) = ["HsIntegral [" ++ src ++ "] " ++ show c] - doOverLit (HsIsString src c) = ["HsIsString [" ++ src ++ "] " ++ show c] + doOverLit (HsIntegral (SourceText src) c) + = ["HsIntegral [" ++ src ++ "] " ++ show c] + doOverLit (HsIsString (SourceText src) c) + = ["HsIsString [" ++ src ++ "] " ++ show c] doOverLit _ = [] pp a = showPpr unsafeGlobalDynFlags a diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout index ce7a004929..7984181504 100644 --- a/testsuite/tests/ghc-api/annotations-literals/parsed.stdout +++ b/testsuite/tests/ghc-api/annotations-literals/parsed.stdout @@ -1,12 +1,12 @@ HsIntegral [0003] 3 -HsString [] "noExpr" +HsString [noExpr] "noExpr" HsIntegral [0x04] 4 -HsString [] "noExpr" +HsString [noExpr] "noExpr" HsString ["\x20"] " " HsChar ['\x20'] ' ' -HsString [] "noExpr" +HsString [noExpr] "noExpr" HsCharPrim ['\x41'] 'A' HsIntPrim [0004#] 4 HsWordPrim [005##] 5 HsIntegral [1] 1 -HsString [] "noExpr" +HsString [noExpr] "noExpr" diff --git a/testsuite/tests/ghc-api/annotations/T10276.stderr b/testsuite/tests/ghc-api/annotations/T10276.stderr index d79fc3a6e3..fff4c8ce4f 100644 --- a/testsuite/tests/ghc-api/annotations/T10276.stderr +++ b/testsuite/tests/ghc-api/annotations/T10276.stderr @@ -8,8 +8,7 @@ Test10276.hs:11:29: error: In the Template Haskell quotation [|| fst $ runState - ($$(qqExpM x)) - ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] + $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] Test10276.hs:11:46: error: Not in scope: type constructor or class ‘M.Map’ @@ -17,8 +16,7 @@ Test10276.hs:11:46: error: In the Template Haskell quotation [|| fst $ runState - ($$(qqExpM x)) - ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] + $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] Test10276.hs:11:52: error: Not in scope: type constructor or class ‘L.Name’ @@ -26,8 +24,7 @@ Test10276.hs:11:52: error: In the Template Haskell quotation [|| fst $ runState - ($$(qqExpM x)) - ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] + $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] Test10276.hs:11:60: error: Not in scope: type constructor or class ‘L.Operand’ @@ -35,8 +32,7 @@ Test10276.hs:11:60: error: In the Template Haskell quotation [|| fst $ runState - ($$(qqExpM x)) - ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] + $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] Test10276.hs:14:3: error: ‘qqExp’ is not a (visible) method of class ‘QQExp2’ @@ -47,8 +43,7 @@ Test10276.hs:15:29: error: In the Template Haskell quotation [|| fst $ runState - ($$(qqExpM x)) - ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] + $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] Test10276.hs:15:46: error: Not in scope: type constructor or class ‘M.Map’ @@ -56,8 +51,7 @@ Test10276.hs:15:46: error: In the Template Haskell quotation [|| fst $ runState - ($$(qqExpM x)) - ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] + $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] Test10276.hs:15:52: error: Not in scope: type constructor or class ‘L.Name’ @@ -65,8 +59,7 @@ Test10276.hs:15:52: error: In the Template Haskell quotation [|| fst $ runState - ($$(qqExpM x)) - ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] + $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] Test10276.hs:15:60: error: Not in scope: type constructor or class ‘L.Operand’ @@ -74,5 +67,4 @@ Test10276.hs:15:60: error: In the Template Haskell quotation [|| fst $ runState - ($$(qqExpM x)) - ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] + $$(qqExpM x) ((0, M.empty) :: (Int, M.Map L.Name [L.Operand])) ||] diff --git a/testsuite/tests/ghc-api/annotations/T10313.stdout b/testsuite/tests/ghc-api/annotations/T10313.stdout index a2680a9582..d1cc35cb61 100644 --- a/testsuite/tests/ghc-api/annotations/T10313.stdout +++ b/testsuite/tests/ghc-api/annotations/T10313.stdout @@ -1,27 +1,17 @@ -[([i], [([", b, \, x, 6, 1, s, e, "], base)]), +[([i], [(SourceText "b\x61se", base)]), ([w], - [([", N, e, w, , Z, 3, , A, P, I, , s, u, p, p, o, r, t, , i, - s, , s, t, i, l, l, , i, n, c, o, m, p, l, e, t, e, , a, n, d, - , f, r, a, g, i, l, e, :, , \, -, , , , , , , , , , , - \, y, o, u, , m, a, y, , e, x, p, e, r, i, e, n, c, e, , s, e, - g, m, e, n, t, a, t, i, o, n, , f, a, u, l, t, s, !, "], + [(SourceText "New Z3 API support is still incomplete and fragile: \ + \you may experience segmentation faults!", New Z3 API support is still incomplete and fragile: you may experience segmentation faults!)]), ([d], - [([", D, e, p, r, e, c, a, t, i, o, n, :, , \, -, , , , , , - , , , , , \, y, o, u, , m, a, y, , e, x, p, e, r, i, e, n, - c, e, , s, e, g, m, e, n, t, a, t, i, o, n, , f, a, u, l, t, s, - !, "], + [(SourceText "Deprecation: \ + \you may experience segmentation faults!", Deprecation: you may experience segmentation faults!)]), - ([c], - [([", f, o, o, \, x, 6, 3, "], fooc), - ([", b, \, x, 6, 1, r, "], bar)]), - ([r], [([", f, o, o, 1, \, x, 6, 7, "], foo1g)]), - ([s, t], [([", a, \, x, 6, 2, "], ab)]), + ([c], [(SourceText "foo\x63", fooc), (SourceText "b\x61r", bar)]), + ([r], [(SourceText "foo1\x67", foo1g)]), + ([s, t], [(SourceText "a\x62", ab)]), ([c, o], - [([", S, t, r, i, c, t, , B, i, t, s, t, r, e, a, m, , s, t, r, - e, \, x, 6, 1, m, "], + [(SourceText "Strict Bitstream stre\x61m", Strict Bitstream stream)]), - ([s, c], [([", f, o, o, \, x, 6, 4, "], food)]), - ([t, p], [([", f, o, o, b, \, x, 6, 1, r, "], foobar)])] + ([s, c], [(SourceText "foo\x64", food)]), + ([t, p], [(SourceText "foob\x61r", foobar)])] diff --git a/testsuite/tests/ghc-api/annotations/T11430.stdout b/testsuite/tests/ghc-api/annotations/T11430.stdout index 32d7ff1b24..157c29bb06 100644 --- a/testsuite/tests/ghc-api/annotations/T11430.stdout +++ b/testsuite/tests/ghc-api/annotations/T11430.stdout @@ -3,4 +3,4 @@ ("ia",["1"]) ("ia",["0x999"]) ("ia",["1"]) -("tp",["((\"0x1\",\"0x2\"),(\"0x3\",\"0x4\"))"]) +("tp",["((SourceText \"0x1\",SourceText \"0x2\"),(SourceText \"0x3\",SourceText \"0x4\"))"]) diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs index 1f00d1d5d2..151efbe611 100644 --- a/testsuite/tests/ghc-api/annotations/t11430.hs +++ b/testsuite/tests/ghc-api/annotations/t11430.hs @@ -56,20 +56,24 @@ testOneFile libdir fileName = do ) ast doFixity :: Fixity -> [(String,[String])] - doFixity (Fixity ss _ _) = [("f",[ss])] + doFixity (Fixity (SourceText ss) _ _) = [("f",[ss])] doRuleDecl :: RuleDecl RdrName -> [(String,[String])] - doRuleDecl (HsRule _ (ActiveBefore ss _) _ _ _ _ _) = [("rb",[ss])] - doRuleDecl (HsRule _ (ActiveAfter ss _) _ _ _ _ _) = [("ra",[ss])] + doRuleDecl (HsRule _ (ActiveBefore (SourceText ss) _) _ _ _ _ _) + = [("rb",[ss])] + doRuleDecl (HsRule _ (ActiveAfter (SourceText ss) _) _ _ _ _ _) + = [("ra",[ss])] doRuleDecl (HsRule _ _ _ _ _ _ _) = [] doHsExpr :: HsExpr RdrName -> [(String,[String])] doHsExpr (HsTickPragma src (_,_,_) ss _) = [("tp",[show ss])] doHsExpr _ = [] - doInline (InlinePragma _ _ _ (ActiveBefore ss _) _) = [("ib",[ss])] - doInline (InlinePragma _ _ _ (ActiveAfter ss _) _) = [("ia",[ss])] + doInline (InlinePragma _ _ _ (ActiveBefore (SourceText ss) _) _) + = [("ib",[ss])] + doInline (InlinePragma _ _ _ (ActiveAfter (SourceText ss) _) _) + = [("ia",[ss])] doInline (InlinePragma _ _ _ _ _ ) = [] showAnns anns = "[\n" ++ (intercalate "\n" diff --git a/testsuite/tests/ghci/scripts/T8959b.stderr b/testsuite/tests/ghci/scripts/T8959b.stderr index d968f8ac56..28b48fdba8 100644 --- a/testsuite/tests/ghci/scripts/T8959b.stderr +++ b/testsuite/tests/ghci/scripts/T8959b.stderr @@ -6,8 +6,8 @@ T8959b.hs:5:7: error: T8959b.hs:8:7: error: • Couldn't match expected type ‘()’ with actual type ‘t0 → m0 t0’ - • In the expression: proc x -> do { return ⤙ x } - In an equation for ‘bar’: bar = proc x -> do { return ⤙ x } + • In the expression: proc x -> do return ⤙ x + In an equation for ‘bar’: bar = proc x -> do return ⤙ x T8959b.hs:10:7: error: • Couldn't match expected type ‘(∀ a2. a2 → a2) → a1’ diff --git a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr index c2994dc1a5..8f06390348 100644 --- a/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr +++ b/testsuite/tests/haddock/haddock_examples/haddock.Test.stderr @@ -127,7 +127,7 @@ data R1 <document comment> f :: C a => a -> Int <document comment> -foreign import ccall safe "static header.h g" g :: Int -> IO CInt +foreign import ccall safe "header.h" g :: Int -> IO CInt <document comment> h :: Int h = 42 @@ -169,7 +169,7 @@ newn :: -> N1 () one of the arguments -> IO Int newn = undefined <document comment> -foreign import ccall unsafe "static header.h o" o +foreign import ccall unsafe "header.h" o :: Float The input float -> IO Float The output float <document comment> newp :: Int diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr index 684a6f072a..060dd06ad2 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T11768.stderr @@ -3,7 +3,7 @@ module T11768 where data Foo = Foo - deriving (Eq Documenting a single type) + deriving Eq Documenting a single type data Bar = Bar deriving (Eq Documenting one of multiple types, Ord) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr index bd9ec257e7..47d2468ea5 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/haddockA028.stderr @@ -1,7 +1,7 @@ ==================== Parser ==================== module ShouldCompile where -data (<-->) a b = Mk a b +data a <--> b = Mk a b test :: [a] doc1 -> a <--> b -> [a] blabla test xs ys = xs diff --git a/testsuite/tests/indexed-types/should_fail/SimpleFail14.stderr b/testsuite/tests/indexed-types/should_fail/SimpleFail14.stderr index 7079d8cc84..f18894df85 100644 --- a/testsuite/tests/indexed-types/should_fail/SimpleFail14.stderr +++ b/testsuite/tests/indexed-types/should_fail/SimpleFail14.stderr @@ -1,6 +1,6 @@ SimpleFail14.hs:5:15: error: • Expected a type, but ‘a ~ a’ has kind ‘Constraint’ - • In the type ‘a ~ a’ + • In the type ‘(a ~ a)’ In the definition of data constructor ‘T’ In the data declaration for ‘T’ diff --git a/testsuite/tests/indexed-types/should_fail/T12867.stderr b/testsuite/tests/indexed-types/should_fail/T12867.stderr index e712c49c4f..40e566b3ec 100644 --- a/testsuite/tests/indexed-types/should_fail/T12867.stderr +++ b/testsuite/tests/indexed-types/should_fail/T12867.stderr @@ -2,8 +2,8 @@ T12867.hs:7:21: error: • Expecting one fewer arguments to ‘TestM’ Expected kind ‘k0 -> *’, but ‘TestM’ has kind ‘*’ - • In the first argument of ‘Eq’, namely ‘TestM a’ - In the type ‘Eq (TestM a)’ + • In the first argument of ‘Eq’, namely ‘(TestM a)’ + In the type ‘(Eq (TestM a))’ In the type declaration for ‘Test2’ T12867.hs:9:1: error: diff --git a/testsuite/tests/indexed-types/should_fail/T2664.stderr b/testsuite/tests/indexed-types/should_fail/T2664.stderr index eb06fa479b..1217196f8a 100644 --- a/testsuite/tests/indexed-types/should_fail/T2664.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2664.stderr @@ -14,16 +14,16 @@ T2664.hs:31:9: error: (O $ takeMVar v, E (pchoose Right v newPChan) (pchoose Left v newPChan)) In the expression: - do { v <- newEmptyMVar; - return - (O $ takeMVar v, - E (pchoose Right v newPChan) (pchoose Left v newPChan)) } + do v <- newEmptyMVar + return + (O $ takeMVar v, + E (pchoose Right v newPChan) (pchoose Left v newPChan)) In an equation for ‘newPChan’: newPChan - = do { v <- newEmptyMVar; - return - (O $ takeMVar v, - E (pchoose Right v newPChan) (pchoose Left v newPChan)) } + = do v <- newEmptyMVar + return + (O $ takeMVar v, + E (pchoose Right v newPChan) (pchoose Left v newPChan)) • Relevant bindings include v :: MVar (Either (PChan a) (PChan b)) (bound at T2664.hs:24:9) newPChan :: IO (PChan (a :*: b), PChan c) (bound at T2664.hs:23:5) diff --git a/testsuite/tests/indexed-types/should_fail/T2693.stderr b/testsuite/tests/indexed-types/should_fail/T2693.stderr index c0bd7329fd..f9485d1d42 100644 --- a/testsuite/tests/indexed-types/should_fail/T2693.stderr +++ b/testsuite/tests/indexed-types/should_fail/T2693.stderr @@ -39,6 +39,6 @@ T2693.hs:29:20: error: • In the first argument of ‘mapM’, namely ‘g’ In a stmt of a 'do' block: pvs <- mapM g undefined In the expression: - do { pvs <- mapM g undefined; - let n = (map pvrX pvs) `min` (map pvrX pvs); - undefined } + do pvs <- mapM g undefined + let n = (map pvrX pvs) `min` (map pvrX pvs) + undefined diff --git a/testsuite/tests/indexed-types/should_fail/T5439.stderr b/testsuite/tests/indexed-types/should_fail/T5439.stderr index 9cc8912814..f712d47f0e 100644 --- a/testsuite/tests/indexed-types/should_fail/T5439.stderr +++ b/testsuite/tests/indexed-types/should_fail/T5439.stderr @@ -8,8 +8,8 @@ T5439.hs:82:33: error: In a stmt of a 'do' block: c <- complete ev $ inj $ Failure (e :: SomeException) In the expression: - do { c <- complete ev $ inj $ Failure (e :: SomeException); - return $ c || not first } + do c <- complete ev $ inj $ Failure (e :: SomeException) + return $ c || not first • Relevant bindings include register :: Bool -> Peano n -> WaitOps (HDrop n rs) -> IO Bool (bound at T5439.hs:64:9) diff --git a/testsuite/tests/indexed-types/should_fail/T7786.stderr b/testsuite/tests/indexed-types/should_fail/T7786.stderr index 8fdb49bd8e..89984ca6b0 100644 --- a/testsuite/tests/indexed-types/should_fail/T7786.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7786.stderr @@ -7,12 +7,12 @@ T7786.hs:94:41: error: (Sing (Intersect (BuriedUnder sub k 'Empty) inv)) • In a stmt of a 'do' block: Nil :: Sing xxx <- foogle db k sub In the expression: - do { Nil :: Sing xxx <- foogle db k sub; - return $ Sub db k sub } + do Nil :: Sing xxx <- foogle db k sub + return $ Sub db k sub In an equation for ‘addSub’: addSub db k sub - = do { Nil :: Sing xxx <- foogle db k sub; - return $ Sub db k sub } + = do Nil :: Sing xxx <- foogle db k sub + return $ Sub db k sub • Relevant bindings include sub :: Database sub (bound at T7786.hs:94:13) k :: Sing k (bound at T7786.hs:94:11) @@ -36,8 +36,8 @@ T7786.hs:95:31: error: • In the second argument of ‘($)’, namely ‘Sub db k sub’ In a stmt of a 'do' block: return $ Sub db k sub In the expression: - do { Nil :: Sing xxx <- foogle db k sub; - return $ Sub db k sub } + do Nil :: Sing xxx <- foogle db k sub + return $ Sub db k sub • Relevant bindings include sub :: Database sub (bound at T7786.hs:94:13) k :: Sing k (bound at T7786.hs:94:11) diff --git a/testsuite/tests/monadfail/MonadFailErrors.stderr b/testsuite/tests/monadfail/MonadFailErrors.stderr index 84334b980b..1507984d14 100644 --- a/testsuite/tests/monadfail/MonadFailErrors.stderr +++ b/testsuite/tests/monadfail/MonadFailErrors.stderr @@ -13,12 +13,12 @@ MonadFailErrors.hs:16:5: error: general :: Monad m => m a • In a stmt of a 'do' block: Just x <- undefined In the expression: - do { Just x <- undefined; - undefined } + do Just x <- undefined + undefined In an equation for ‘general’: general - = do { Just x <- undefined; - undefined } + = do Just x <- undefined + undefined MonadFailErrors.hs:30:5: error: • No instance for (MonadFail Identity) @@ -26,12 +26,12 @@ MonadFailErrors.hs:30:5: error: with the failable pattern ‘Just x’ • In a stmt of a 'do' block: Just x <- undefined In the expression: - do { Just x <- undefined; - undefined } + do Just x <- undefined + undefined In an equation for ‘identity’: identity - = do { Just x <- undefined; - undefined } + = do Just x <- undefined + undefined MonadFailErrors.hs:44:5: error: • No instance for (MonadFail (ST s)) @@ -39,12 +39,12 @@ MonadFailErrors.hs:44:5: error: with the failable pattern ‘Just x’ • In a stmt of a 'do' block: Just x <- undefined In the expression: - do { Just x <- undefined; - undefined } + do Just x <- undefined + undefined In an equation for ‘st’: st - = do { Just x <- undefined; - undefined } + = do Just x <- undefined + undefined MonadFailErrors.hs:51:5: error: • No instance for (MonadFail ((->) r)) @@ -52,9 +52,9 @@ MonadFailErrors.hs:51:5: error: with the failable pattern ‘Just x’ • In a stmt of a 'do' block: Just x <- undefined In the expression: - do { Just x <- undefined; - undefined } + do Just x <- undefined + undefined In an equation for ‘reader’: reader - = do { Just x <- undefined; - undefined } + = do Just x <- undefined + undefined diff --git a/testsuite/tests/monadfail/MonadFailWarnings.stderr b/testsuite/tests/monadfail/MonadFailWarnings.stderr index 544f14aeb4..ac16d6cd9e 100644 --- a/testsuite/tests/monadfail/MonadFailWarnings.stderr +++ b/testsuite/tests/monadfail/MonadFailWarnings.stderr @@ -13,12 +13,12 @@ MonadFailWarnings.hs:19:5: warning: [-Wmissing-monadfail-instances (in -Wcompat) general :: Monad m => m a • In a stmt of a 'do' block: Just x <- undefined In the expression: - do { Just x <- undefined; - undefined } + do Just x <- undefined + undefined In an equation for ‘general’: general - = do { Just x <- undefined; - undefined } + = do Just x <- undefined + undefined MonadFailWarnings.hs:35:5: warning: [-Wmissing-monadfail-instances (in -Wcompat)] • No instance for (MonadFail Identity) @@ -26,12 +26,12 @@ MonadFailWarnings.hs:35:5: warning: [-Wmissing-monadfail-instances (in -Wcompat) (this will become an error in a future GHC release) • In a stmt of a 'do' block: Just x <- undefined In the expression: - do { Just x <- undefined; - undefined } + do Just x <- undefined + undefined In an equation for ‘identity’: identity - = do { Just x <- undefined; - undefined } + = do Just x <- undefined + undefined MonadFailWarnings.hs:51:5: warning: [-Wmissing-monadfail-instances (in -Wcompat)] • No instance for (MonadFail (ST s)) @@ -39,12 +39,12 @@ MonadFailWarnings.hs:51:5: warning: [-Wmissing-monadfail-instances (in -Wcompat) (this will become an error in a future GHC release) • In a stmt of a 'do' block: Just x <- undefined In the expression: - do { Just x <- undefined; - undefined } + do Just x <- undefined + undefined In an equation for ‘st’: st - = do { Just x <- undefined; - undefined } + = do Just x <- undefined + undefined MonadFailWarnings.hs:59:5: warning: [-Wmissing-monadfail-instances (in -Wcompat)] • No instance for (MonadFail ((->) r)) @@ -52,9 +52,9 @@ MonadFailWarnings.hs:59:5: warning: [-Wmissing-monadfail-instances (in -Wcompat) (this will become an error in a future GHC release) • In a stmt of a 'do' block: Just x <- undefined In the expression: - do { Just x <- undefined; - undefined } + do Just x <- undefined + undefined In an equation for ‘reader’: reader - = do { Just x <- undefined; - undefined } + = do Just x <- undefined + undefined diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr index fc12b71b6b..ea974895e2 100644 --- a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr @@ -3,7 +3,7 @@ SplicesUsed.hs:7:16: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Maybe Bool’ - • In the type signature: maybeBool :: _ + • In the type signature: maybeBool :: (_) SplicesUsed.hs:8:15: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_a’ standing for ‘w’ @@ -37,21 +37,21 @@ SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] at SplicesUsed.hs:14:1-16 - • In the type signature: filter' :: _ -> _ -> _ + • In the type signature: filter' :: (_ -> _ -> _) SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘[a]’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] at SplicesUsed.hs:14:1-16 - • In the type signature: filter' :: _ -> _ -> _ + • In the type signature: filter' :: (_ -> _ -> _) SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘[a]’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] at SplicesUsed.hs:14:1-16 - • In the type signature: filter' :: _ -> _ -> _ + • In the type signature: filter' :: (_ -> _ -> _) SplicesUsed.hs:16:3: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Eq a’ diff --git a/testsuite/tests/partial-sigs/should_compile/T12845.stderr b/testsuite/tests/partial-sigs/should_compile/T12845.stderr index 0d19b1a6ed..b9d7d60a97 100644 --- a/testsuite/tests/partial-sigs/should_compile/T12845.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T12845.stderr @@ -3,5 +3,5 @@ T12845.hs:18:70: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘() :: Constraint’ • In the type signature: broken :: forall r r' rngs. - ('(r, r') ~ Head rngs, Bar r r' ~ True, _) => + ('(r, r') ~ Head rngs, Bar r r' ~ 'True, _) => Foo r -> Proxy rngs -> () diff --git a/testsuite/tests/polykinds/PolyKinds04.stderr b/testsuite/tests/polykinds/PolyKinds04.stderr index 8162dd247b..2a88291623 100644 --- a/testsuite/tests/polykinds/PolyKinds04.stderr +++ b/testsuite/tests/polykinds/PolyKinds04.stderr @@ -3,5 +3,5 @@ PolyKinds04.hs:5:16: Expecting one more argument to ‘Maybe’ Expected a type, but ‘Maybe’ has kind ‘* -> *’ In the first argument of ‘A’, namely ‘Maybe’ - In the type ‘A Maybe’ + In the type ‘(A Maybe)’ In the definition of data constructor ‘B1’ diff --git a/testsuite/tests/polykinds/PolyKinds07.stderr b/testsuite/tests/polykinds/PolyKinds07.stderr index 3a38a6777f..ce70e7d07a 100644 --- a/testsuite/tests/polykinds/PolyKinds07.stderr +++ b/testsuite/tests/polykinds/PolyKinds07.stderr @@ -2,6 +2,6 @@ PolyKinds07.hs:10:11: Data constructor ‘A1’ cannot be used here (it is defined and used in the same recursive group) - In the first argument of ‘B’, namely ‘A1’ - In the type ‘B A1’ + In the first argument of ‘B’, namely ‘ 'A1’ + In the type ‘B 'A1’ In the definition of data constructor ‘B1’ diff --git a/testsuite/tests/polykinds/T10503.stderr b/testsuite/tests/polykinds/T10503.stderr index 43cd62fd5f..ac8972dec6 100644 --- a/testsuite/tests/polykinds/T10503.stderr +++ b/testsuite/tests/polykinds/T10503.stderr @@ -13,4 +13,5 @@ T10503.hs:8:6: error: To defer the ambiguity check to use sites, enable AllowAmbiguousTypes In the type signature: h :: forall r. - (Proxy (KProxy :: KProxy k) ~ Proxy (KProxy :: KProxy *) => r) -> r + (Proxy ( 'KProxy :: KProxy k) ~ Proxy ( 'KProxy :: KProxy *) => r) + -> r diff --git a/testsuite/tests/polykinds/T11399.stderr b/testsuite/tests/polykinds/T11399.stderr index 48af87efc4..cd78c24792 100644 --- a/testsuite/tests/polykinds/T11399.stderr +++ b/testsuite/tests/polykinds/T11399.stderr @@ -5,5 +5,5 @@ T11399.hs:10:32: error: a :: * -> * TYPE :: GHC.Types.RuntimeRep -> * Expected kind ‘* -> *’, but ‘UhOh a’ has kind ‘a * -> *’ - • In the first argument of ‘Functor’, namely ‘UhOh a’ + • In the first argument of ‘Functor’, namely ‘(UhOh a)’ In the instance declaration for ‘Functor (UhOh a)’ diff --git a/testsuite/tests/polykinds/T11520.stderr b/testsuite/tests/polykinds/T11520.stderr index f598d85551..11a81baf62 100644 --- a/testsuite/tests/polykinds/T11520.stderr +++ b/testsuite/tests/polykinds/T11520.stderr @@ -2,5 +2,5 @@ T11520.hs:15:77: error: • Expected kind ‘k20 -> k10’, but ‘g’ has kind ‘k’ • In the second argument of ‘Compose’, namely ‘g’ - In the first argument of ‘Typeable’, namely ‘Compose f g’ + In the first argument of ‘Typeable’, namely ‘(Compose f g)’ In the instance declaration for ‘Typeable (Compose f g)’ diff --git a/testsuite/tests/polykinds/T11611.stderr b/testsuite/tests/polykinds/T11611.stderr index 15d4749393..6c723786b0 100644 --- a/testsuite/tests/polykinds/T11611.stderr +++ b/testsuite/tests/polykinds/T11611.stderr @@ -2,5 +2,5 @@ T11611.hs:8:37: error: • Expected kind ‘[*]’, but ‘a’ has kind ‘*’ • In the first argument of ‘A’, namely ‘a’ - In the first argument of ‘Show’, namely ‘A a’ + In the first argument of ‘Show’, namely ‘(A a)’ In the stand-alone deriving instance for ‘Show a => Show (A a)’ diff --git a/testsuite/tests/polykinds/T5716.stderr b/testsuite/tests/polykinds/T5716.stderr index 8bc8883daf..d85166b0bb 100644 --- a/testsuite/tests/polykinds/T5716.stderr +++ b/testsuite/tests/polykinds/T5716.stderr @@ -2,6 +2,6 @@ T5716.hs:13:33: error: Data constructor ‘U1’ cannot be used here (Perhaps you intended to use TypeInType) - In the first argument of ‘I’, namely ‘U1 DFInt’ + In the first argument of ‘I’, namely ‘(U1 DFInt)’ In the type ‘I (U1 DFInt)’ In the definition of data constructor ‘I1’ diff --git a/testsuite/tests/polykinds/T5716a.stderr b/testsuite/tests/polykinds/T5716a.stderr index 5cee2edc2e..acec5e146d 100644 --- a/testsuite/tests/polykinds/T5716a.stderr +++ b/testsuite/tests/polykinds/T5716a.stderr @@ -2,6 +2,6 @@ T5716a.hs:10:27: Data constructor ‘Bar’ cannot be used here (it comes from a data family instance) - In the type ‘Bar a’ + In the type ‘(Bar a)’ In the definition of data constructor ‘Bar’ In the data instance declaration for ‘DF’ diff --git a/testsuite/tests/polykinds/T6054.stderr b/testsuite/tests/polykinds/T6054.stderr index c8b39b06ad..800b5599ce 100644 --- a/testsuite/tests/polykinds/T6054.stderr +++ b/testsuite/tests/polykinds/T6054.stderr @@ -3,7 +3,7 @@ T6054.hs:7:14: error: • No instance for (Bar '() a0) arising from an expression type signature • In the first argument of ‘print’, namely - ‘(Proxy :: Bar () a => Proxy a)’ - In the expression: print (Proxy :: Bar () a => Proxy a) + ‘(Proxy :: Bar '() a => Proxy a)’ + In the expression: print (Proxy :: Bar '() a => Proxy a) In an equation for ‘foo’: - foo = print (Proxy :: Bar () a => Proxy a) + foo = print (Proxy :: Bar '() a => Proxy a) diff --git a/testsuite/tests/polykinds/T7151.stderr b/testsuite/tests/polykinds/T7151.stderr index 00fed221c1..8b9ff9040e 100644 --- a/testsuite/tests/polykinds/T7151.stderr +++ b/testsuite/tests/polykinds/T7151.stderr @@ -1,4 +1,4 @@ T7151.hs:3:12: - Illegal type: ‘'[Int, String]’ + Illegal type: ‘[Int, String]’ Perhaps you intended to use DataKinds diff --git a/testsuite/tests/polykinds/T7328.stderr b/testsuite/tests/polykinds/T7328.stderr index 95b3a7782f..76f81555dd 100644 --- a/testsuite/tests/polykinds/T7328.stderr +++ b/testsuite/tests/polykinds/T7328.stderr @@ -2,5 +2,5 @@ T7328.hs:8:34: error: • Occurs check: cannot construct the infinite kind: k1 ~ k0 -> k1 • In the first argument of ‘Foo’, namely ‘f’ - In the first argument of ‘Proxy’, namely ‘Foo f’ + In the first argument of ‘Proxy’, namely ‘(Foo f)’ In the type signature: foo :: a ~ f i => Proxy (Foo f) diff --git a/testsuite/tests/polykinds/T7433.stderr b/testsuite/tests/polykinds/T7433.stderr index d3f57a9ee7..1cd2ad2f29 100644 --- a/testsuite/tests/polykinds/T7433.stderr +++ b/testsuite/tests/polykinds/T7433.stderr @@ -2,5 +2,5 @@ T7433.hs:2:10: Data constructor ‘Z’ cannot be used here (Perhaps you intended to use DataKinds) - In the type ‘Z’ + In the type ‘ 'Z’ In the type declaration for ‘T’ diff --git a/testsuite/tests/polykinds/T7805.stderr b/testsuite/tests/polykinds/T7805.stderr index 33b9d4df6b..9ca48645be 100644 --- a/testsuite/tests/polykinds/T7805.stderr +++ b/testsuite/tests/polykinds/T7805.stderr @@ -2,5 +2,5 @@ T7805.hs:7:21: error: Expected kind ‘forall a. a -> a’, but ‘x’ has kind ‘k0’ In the first argument of ‘HR’, namely ‘x’ - In the first argument of ‘F’, namely ‘HR x’ + In the first argument of ‘F’, namely ‘(HR x)’ In the type instance declaration for ‘F’ diff --git a/testsuite/tests/printer/.gitignore b/testsuite/tests/printer/.gitignore new file mode 100644 index 0000000000..2da49b2630 --- /dev/null +++ b/testsuite/tests/printer/.gitignore @@ -0,0 +1,17 @@ +*.ast +*.ppr.hs +*.ppr +*.o +*.hi +*.out +Ppr003 +Ppr004 +Ppr016 +Ppr026 +Ppr029 +Ppr034 +Ppr041 +Ppr042 +Ppr043 +Ppr044 +Ppr046
\ No newline at end of file diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile new file mode 100644 index 0000000000..b21419c30f --- /dev/null +++ b/testsuite/tests/printer/Makefile @@ -0,0 +1,195 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +clean: + rm -f *.o *.hi *.ppr.hs + rm Ppr003 Ppr004 + +.PHONY: ppr001 +ppr001: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr001.hs + +.PHONY: ppr002 +ppr002: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr002.hs + +.PHONY: ppr003 +ppr003: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr003.hs + +.PHONY: ppr004 +ppr004: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr004.hs + +.PHONY: ppr005 +ppr005: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr005.hs + +.PHONY: ppr006 +ppr006: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr006.hs + +.PHONY: ppr007 +ppr007: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr007.hs + +.PHONY: ppr008 +ppr008: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr008.hs + +.PHONY: ppr009 +ppr009: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr009.hs + +.PHONY: ppr010 +ppr010: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr010.hs + +.PHONY: ppr011 +ppr011: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr011.hs + +.PHONY: ppr012 +ppr012: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr012.hs + +.PHONY: ppr013 +ppr013: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr013.hs + +.PHONY: ppr014 +ppr014: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr014.hs + +.PHONY: ppr015 +ppr015: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr015.hs + +.PHONY: ppr016 +ppr016: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr016.hs + +.PHONY: ppr017 +ppr017: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr017.hs + +.PHONY: ppr018 +ppr018: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr018.hs + +.PHONY: ppr019 +ppr019: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr019.hs + +.PHONY: ppr020 +ppr020: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr020.hs + +.PHONY: ppr021 +ppr021: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr021.hs + +.PHONY: ppr022 +ppr022: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr022.hs + +.PHONY: ppr023 +ppr023: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr023.hs + +.PHONY: ppr024 +ppr024: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr024.hs + +.PHONY: ppr025 +ppr025: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr025.hs + +.PHONY: ppr026 +ppr026: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr026.hs + +.PHONY: ppr027 +ppr027: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr027.hs + +.PHONY: ppr028 +ppr028: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr028.hs + +.PHONY: ppr029 +ppr029: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr029.hs + +.PHONY: ppr030 +ppr030: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr030.hs + +.PHONY: ppr031 +ppr031: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr031.hs + +.PHONY: ppr032 +ppr032: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr032.hs + +.PHONY: ppr033 +ppr033: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr033.hs + +.PHONY: ppr034 +ppr034: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr034.hs + +.PHONY: ppr035 +ppr035: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr035.hs + +.PHONY: ppr036 +ppr036: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr036.hs + +.PHONY: ppr037 +ppr037: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr037.hs + +.PHONY: ppr038 +ppr038: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr038.hs + +.PHONY: ppr039 +ppr039: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr039.hs + +.PHONY: ppr040 +ppr040: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr040.hs + +.PHONY: ppr041 +ppr041: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr041.hs + +.PHONY: ppr042 +ppr042: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr042.hs + +.PHONY: ppr043 +ppr043: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr043.hs + +.PHONY: ppr044 +ppr044: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr044.hs + +.PHONY: ppr045 +ppr045: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr045.hs + +.PHONY: ppr046 +ppr046: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr046.hs + +.PHONY: ppr047 +ppr047: + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr047.hs diff --git a/testsuite/tests/printer/Ppr001.hs b/testsuite/tests/printer/Ppr001.hs new file mode 100644 index 0000000000..5277da5abf --- /dev/null +++ b/testsuite/tests/printer/Ppr001.hs @@ -0,0 +1,7 @@ +module Ppr001 where + +main = putStrLn "hello" + +foo x = y + 3 + where + y = 2 ^ x diff --git a/testsuite/tests/printer/Ppr002.hs b/testsuite/tests/printer/Ppr002.hs new file mode 100644 index 0000000000..a98e0689ee --- /dev/null +++ b/testsuite/tests/printer/Ppr002.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Arrows #-} +module Arrow where + +import Control.Arrow +import qualified Control.Category as Cat + +addA :: Arrow a => a b Int -> a b Int -> a b Int +addA f g = proc x -> do + y <- f -< x + z <- g -< x + returnA -< y + z + +newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) } + +instance Cat.Category Circuit where + id = Circuit $ \a -> (Cat.id, a) + (.) = dot + where + (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a -> + let (cir1', b) = cir1 a + (cir2', c) = cir2 b + in (cir2' `dot` cir1', c) + +instance Arrow Circuit where + arr f = Circuit $ \a -> (arr f, f a) + first (Circuit cir) = Circuit $ \(b, d) -> + let (cir', c) = cir b + in (first cir', (c, d)) + +-- | Accumulator that outputs a value determined by the supplied function. +accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b +accum acc f = Circuit $ \input -> + let (output, acc') = input `f` acc + in (accum acc' f, output) + +-- | Accumulator that outputs the accumulator value. +accum' :: b -> (a -> b -> b) -> Circuit a b +accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b')) + +total :: Num a => Circuit a a +total = accum' 0 (+) + +mean3 :: Fractional a => Circuit a a +mean3 = proc value -> do + (t, n) <- (| (&&&) (total -< value) (total -< 1) |) + returnA -< t / n diff --git a/testsuite/tests/printer/Ppr003.hs b/testsuite/tests/printer/Ppr003.hs new file mode 100644 index 0000000000..2cd738e4fe --- /dev/null +++ b/testsuite/tests/printer/Ppr003.hs @@ -0,0 +1,11 @@ +main = putStrLn "hello" + +foo x = + case x of + { ;;; -- leading + 0 -> 'a'; -- case 0 + 1 -> 'b' -- case 1 + ; 2 -> 'c' ; -- case 2 + ; 3 -> 'd' -- case 3 + ;;; -- case 4 + } diff --git a/testsuite/tests/printer/Ppr004.hs b/testsuite/tests/printer/Ppr004.hs new file mode 100644 index 0000000000..797d36106a --- /dev/null +++ b/testsuite/tests/printer/Ppr004.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +-- From https://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example + +import qualified Data.IntMap +import Prelude hiding (lookup) +import Data.Char (ord) + +class GMapKey k where + data GMap k :: * -> * + empty :: GMap k v + lookup :: k -> GMap k v -> Maybe v + insert :: k -> v -> GMap k v -> GMap k v + +-- An Int instance +instance GMapKey Int where + data GMap Int v = GMapInt (Data.IntMap.IntMap v) + empty = GMapInt Data.IntMap.empty + lookup k (GMapInt m) = Data.IntMap.lookup k m + insert k v (GMapInt m) = GMapInt (Data.IntMap.insert k v m) + +-- A Char instance +instance GMapKey Char where + data GMap Char v = GMapChar (GMap Int v) + empty = GMapChar empty + lookup k (GMapChar m) = lookup (ord k) m + insert k v (GMapChar m) = GMapChar (insert (ord k) v m) + +-- A Unit instance +instance GMapKey () where + data GMap () v = GMapUnit (Maybe v) + empty = GMapUnit Nothing + lookup () (GMapUnit v) = v + insert () v (GMapUnit _) = GMapUnit $ Just v + +-- Product and sum instances +instance (GMapKey a, GMapKey b) => GMapKey (a, b) where + data GMap (a, b) v = GMapPair (GMap a (GMap b v)) + empty = GMapPair empty + lookup (a, b) (GMapPair gm) = lookup a gm >>= lookup b + insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of + Nothing -> insert a (insert b v empty) gm + Just gm2 -> insert a (insert b v gm2 ) gm + +instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where + data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) + empty = GMapEither empty empty + lookup (Left a) (GMapEither gm1 _gm2) = lookup a gm1 + lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2 + insert (Left a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2 + insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2) + +myGMap :: GMap (Int, Either Char ()) String +myGMap = insert (5, Left 'c') "(5, Left 'c')" $ + insert (4, Right ()) "(4, Right ())" $ + insert (5, Right ()) "This is the one!" $ + insert (5, Right ()) "This is the two!" $ + insert (6, Right ()) "(6, Right ())" $ + insert (5, Left 'a') "(5, Left 'a')" $ + empty + +main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap + +-- (Type) Synonym Family + +type family Elem c + +type instance Elem [e] = e + +-- type instance Elem BitSet = Char + + +data family T a +data instance T Int = T1 Int | T2 Bool +newtype instance T Char = TC Bool + +data family G a b +data instance G [a] b where + G1 :: c -> G [Int] b + G2 :: G [a] Bool diff --git a/testsuite/tests/printer/Ppr005.hs b/testsuite/tests/printer/Ppr005.hs new file mode 100644 index 0000000000..8d4a920e76 --- /dev/null +++ b/testsuite/tests/printer/Ppr005.hs @@ -0,0 +1,11 @@ +module Ppr005 where + +import Data.List + +foo = do + let x = 1 + Just 5 + +f = undefined +go = undefined +e = undefined diff --git a/testsuite/tests/printer/Ppr006.hs b/testsuite/tests/printer/Ppr006.hs new file mode 100644 index 0000000000..280ec564b4 --- /dev/null +++ b/testsuite/tests/printer/Ppr006.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE QuasiQuotes #-} +module Ppr006 where + +commands :: [Command] +commands = [ + command "help" "display a list of all commands, and their current keybindings" $ do + macroGuesses <- Macro.guessCommands commandNames <$> getMacros + addTab (Other "Help") (makeHelpWidget commands macroGuesses) AutoClose + + , command "log" "show the error log" $ do + messages <- gets logMessages + let widget = ListWidget.moveLast (ListWidget.new $ reverse messages) + addTab (Other "Log") (AnyWidget . LogWidget $ widget) AutoClose + + , command "map" "display a list of all commands that are currently bound to keys" $ do + showMappings + + , command "map" "display the command that is currently bound to the key {name}" $ do + showMapping + + , command "map" [help| + Bind the command {expansion} to the key {name}. The same command may + be bound to different keys. + |] $ do + addMapping + + , command "unmap" "remove the binding currently bound to the key {name}" $ do + \(MacroName m) -> removeMacro m + + , command "mapclear" "" $ do + clearMacros + + , command "exit" "exit vimus" $ do + eval "quit" + + , command "quit" "exit vimus" $ do + liftIO exitSuccess :: Vimus () + + , command "close" "close the current window (not all windows can be closed)" $ do + void closeTab + + , command "source" "read the file {path} and interprets all lines found there as if they were entered as commands." $ do + \(Path p) -> liftIO (expandHome p) >>= either printError source_ + + , command "runtime" "" $ + \(Path p) -> liftIO (getDataFileName p) >>= source_ + + , command "color" "define the fore- and background color for a thing on the screen." $ do + \color fg bg -> liftIO (defineColor color fg bg) :: Vimus () + + , command "repeat" "set the playlist option *repeat*. When *repeat* is set, the playlist will start over when the last song has finished playing." $ do + MPD.repeat True :: Vimus () + + , command "norepeat" "Unset the playlist option *repeat*." $ do + MPD.repeat False :: Vimus () + + , command "consume" "set the playlist option *consume*. When *consume* is set, songs that have finished playing are automatically removed from the playlist." $ do + MPD.consume True :: Vimus () + + , command "noconsume" "Unset the playlist option *consume*." $ do + MPD.consume False :: Vimus () + + , command "random" "set the playlist option *random*. When *random* is set, songs in the playlist are played in random order." $ do + MPD.random True :: Vimus () + + , command "norandom" "Unset the playlist option *random*." $ do + MPD.random False :: Vimus () + + , command "single" "Set the playlist option *single*. When *single* is set, playback does not advance automatically to the next item in the playlist. Combine with *repeat* to repeatedly play the same song." $ do + MPD.single True :: Vimus () + + , command "nosingle" "Unset the playlist option *single*." $ do + MPD.single False :: Vimus () + + , command "autotitle" "Set the *autotitle* option. When *autotitle* is set, the console window title is automatically set to the currently playing song." $ do + setAutoTitle True + + , command "noautotitle" "Unset the *autotitle* option." $ do + setAutoTitle False + + , command "volume" "[+-] set volume to or adjust by [+-] num" $ do + volume :: Volume -> Vimus () + + , command "toggle-repeat" "Toggle the *repeat* option." $ do + MPD.status >>= MPD.repeat . not . MPD.stRepeat :: Vimus () + + , command "toggle-consume" "Toggle the *consume* option." $ do + MPD.status >>= MPD.consume . not . MPD.stConsume :: Vimus () + + , command "toggle-random" "Toggle the *random* option." $ do + MPD.status >>= MPD.random . not . MPD.stRandom :: Vimus () + + , command "toggle-single" "Toggle the *single* option." $ do + MPD.status >>= MPD.single . not . MPD.stSingle :: Vimus () + + , command "set-library-path" "While MPD knows where your songs are stored, vimus doesn't. If you want to use the *%* feature of the command :! you need to tell vimus where your songs are stored." $ do + \(Path p) -> setLibraryPath p + + , command "next" "stop playing the current song, and starts the next one" $ do + MPD.next :: Vimus () + + , command "previous" "stop playing the current song, and starts the previous one" $ do + MPD.previous :: Vimus () + + , command "toggle" "toggle between play and pause" $ do + MPDE.toggle :: Vimus () + + , command "stop" "stop playback" $ do + MPD.stop :: Vimus () + + , command "update" "tell MPD to update the music database. You must update your database when you add or delete files in your music directory, or when you edit the metadata of a song. MPD will only rescan a file already in the database if its modification time has changed." $ do + void (MPD.update Nothing) :: Vimus () + + , command "rescan" "" $ do + void (MPD.rescan Nothing) :: Vimus () + + , command "clear" "delete all songs from the playlist" $ do + MPD.clear :: Vimus () + + , command "search-next" "jump to the next occurrence of the search string in the current window" + searchNext + + , command "search-prev" "jump to the previous occurrence of the search string in the current window" + searchPrev + + + , command "window-library" "open the *Library* window" $ + selectTab Library + + , command "window-playlist" "open the *Playlist* window" $ + selectTab Playlist + + , command "window-search" "open the *SearchResult* window" $ + selectTab SearchResult + + , command "window-browser" "open the *Browser* window" $ + selectTab Browser + + , command "window-next" "open the window to the right of the current one" + nextTab + + , command "window-prev" "open the window to the left of the current one" + previousTab + + , command "!" "execute {cmd} on the system shell. See chapter \"Using an external tag editor\" for an example." + runShellCommand + + , command "seek" "jump to the given position in the current song" + seek + + , command "visual" "start visual selection" $ + sendEventCurrent EvVisual + + , command "novisual" "cancel visual selection" $ + sendEventCurrent EvNoVisual + + -- Remove current song from playlist + , command "remove" "remove the song under the cursor from the playlist" $ + sendEventCurrent EvRemove + + , command "paste" "add the last deleted song after the selected song in the playlist" $ + sendEventCurrent EvPaste + + , command "paste-prev" "" $ + sendEventCurrent EvPastePrevious + + , command "copy" "" $ + sendEventCurrent EvCopy + + , command "shuffle" "shuffle the current playlist" $ do + MPD.shuffle Nothing :: Vimus () + + , command "add" "append selected songs to the end of the playlist" $ do + sendEventCurrent EvAdd + + -- insert a song right after the current song + , command "insert" [help| + inserts a song to the playlist. The song is inserted after the currently + playing song. + |] $ do + st <- MPD.status + case MPD.stSongPos st of + Just n -> do + -- there is a current song, insert after + sendEventCurrent (EvInsert (n + 1)) + _ -> do + -- there is no current song, just add + sendEventCurrent EvAdd + + -- Playlist: play selected song + -- Library: add song to playlist and play it + -- Browse: either add song to playlist and play it, or :move-in + , command "default-action" [help| + depending on the item under the cursor, somthing different happens: + + - *Playlist* start playing the song under the cursor + + - *Library* append the song under the cursor to the playlist and start playing it + + - *Browser* on a song: append the song to the playlist and play it. On a directory: go down to that directory. + |] $ do + sendEventCurrent EvDefaultAction + + , command "add-album" "add all songs of the album of the selected song to the playlist" $ do + songs <- fromCurrent MPD.Album [MPD.Disc, MPD.Track] + maybe (printError "Song has no album metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs + + , command "add-artist" "add all songs of the artist of the selected song to the playlist" $ do + songs <- fromCurrent MPD.Artist [MPD.Date, MPD.Album, MPD.Disc, MPD.Track] + maybe (printError "Song has no artist metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs + + -- movement + , command "move-up" "move the cursor one line up" $ + sendEventCurrent EvMoveUp + + , command "move-down" "move the cursor one line down" $ + sendEventCurrent EvMoveDown + + , command "move-album-prev" "move the cursor up to the first song of an album" $ + sendEventCurrent EvMoveAlbumPrev + + , command "move-album-next" "move the cursor down to the first song of an album" $ + sendEventCurrent EvMoveAlbumNext + + , command "move-in" "go down one level the directory hierarchy in the *Browser* window" $ + sendEventCurrent EvMoveIn + + , command "move-out" "go up one level in the directory hierarchy in the *Browser* window" $ + sendEventCurrent EvMoveOut + + , command "move-first" "go to the first line in the current window" $ + sendEventCurrent EvMoveFirst + + , command "move-last" "go to the last line in the current window" $ + sendEventCurrent EvMoveLast + + , command "scroll-up" "scroll the contents of the current window up one line" $ + sendEventCurrent (EvScroll (-1)) + + , command "scroll-down" "scroll the contents of the current window down one line" $ + sendEventCurrent (EvScroll 1) + + , command "scroll-page-up" "scroll the contents of the current window up one page" $ + pageScroll >>= sendEventCurrent . EvScroll . negate + + , command "scroll-half-page-up" "scroll the contents of the current window up one half page" $ + pageScroll >>= sendEventCurrent . EvScroll . negate . (`div` 2) + + , command "scroll-page-down" "scroll the contents of the current window down one page" $ + pageScroll >>= sendEventCurrent . EvScroll + + , command "scroll-half-page-down" "scroll the contents of the current window down one half page" $ + pageScroll >>= sendEventCurrent . EvScroll . (`div` 2) + + , command "song-format" "set song rendering format" $ + sendEvent . EvChangeSongFormat + ] diff --git a/testsuite/tests/printer/Ppr006.stderr b/testsuite/tests/printer/Ppr006.stderr new file mode 100644 index 0000000000..d0b3c7b9b8 --- /dev/null +++ b/testsuite/tests/printer/Ppr006.stderr @@ -0,0 +1,45 @@ +Ppr006.hs:4:14: error: + Not in scope: type constructor or class ‘Command’ + +Ppr006.hs:7:23: error: + Not in scope: ‘Macro.guessCommands’ + No module named ‘Macro’ is imported. + +Ppr006.hs:12:20: error: + Not in scope: ‘ListWidget.moveLast’ + No module named ‘ListWidget’ is imported. + +Ppr006.hs:12:41: error: + Not in scope: ‘ListWidget.new’ + No module named ‘ListWidget’ is imported. + +Ppr006.hs:21:19: error: + • Not in scope: ‘help’ + • In the quasi-quotation: + [help| + Bind the command {expansion} to the key {name}. The same command may + be bound to different keys. + |] + +Ppr006.ppr.hs:3:14: error: + Not in scope: type constructor or class ‘Command’ + +Ppr006.ppr.hs:8:29: error: + Not in scope: ‘Macro.guessCommands’ + No module named ‘Macro’ is imported. + +Ppr006.ppr.hs:14:21: error: + Not in scope: ‘ListWidget.moveLast’ + No module named ‘ListWidget’ is imported. + +Ppr006.ppr.hs:14:42: error: + Not in scope: ‘ListWidget.new’ + No module named ‘ListWidget’ is imported. + +Ppr006.ppr.hs:26:8: error: + • Not in scope: ‘help’ + • In the quasi-quotation: + [help| + Bind the command {expansion} to the key {name}. The same command may + be bound to different keys. + |] diff --git a/testsuite/tests/printer/Ppr007.hs b/testsuite/tests/printer/Ppr007.hs new file mode 100644 index 0000000000..65ff9a7b63 --- /dev/null +++ b/testsuite/tests/printer/Ppr007.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ApplicativeDo #-} +module Ppr007 where + +g :: IO () +g = do + x <- getChar + 'a' <- return (3::Int) -- type error + return () diff --git a/testsuite/tests/printer/Ppr007.stderr b/testsuite/tests/printer/Ppr007.stderr new file mode 100644 index 0000000000..5bb122a269 --- /dev/null +++ b/testsuite/tests/printer/Ppr007.stderr @@ -0,0 +1,17 @@ +Ppr007.hs:7:3: error: + • Couldn't match expected type ‘Int’ with actual type ‘Char’ + • In the pattern: 'a' + In a stmt of a 'do' block: 'a' <- return (3 :: Int) + In the expression: + do x <- getChar + 'a' <- return (3 :: Int) + return () + +Ppr007.ppr.hs:5:8: error: + • Couldn't match expected type ‘Int’ with actual type ‘Char’ + • In the pattern: 'a' + In a stmt of a 'do' block: 'a' <- return (3 :: Int) + In the expression: + do x <- getChar + 'a' <- return (3 :: Int) + return () diff --git a/testsuite/tests/printer/Ppr008.hs b/testsuite/tests/printer/Ppr008.hs new file mode 100644 index 0000000000..b5b99e501c --- /dev/null +++ b/testsuite/tests/printer/Ppr008.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ScopedTypeVariables + , BangPatterns + #-} + +module Ppr008 + ( + -- * Managing the IO manager + Signal + , ControlMessage(..) + , Control + , newControl + , closeControl + -- ** Control message reception + , readControlMessage + -- *** File descriptors + , controlReadFd + , controlWriteFd + , wakeupReadFd + -- ** Control message sending + , sendWakeup + , sendDie + -- * Utilities + , setNonBlockingFD + ) where + +#include "EventConfig.h" + +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Base +import GHC.Conc.Signal (Signal) +import GHC.Real (fromIntegral) +import GHC.Show (Show) +import GHC.Word (Word8) +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.Types (CInt(..), CSize(..)) +import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) +import Foreign.Marshal (alloca, allocaBytes) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek, peekElemOff, poke) +import System.Posix.Internals (c_close, c_pipe, c_read, c_write, + setCloseOnExec, setNonBlockingFD) +import System.Posix.Types (Fd) + +#if defined(HAVE_EVENTFD) +import Foreign.C.Error (throwErrnoIfMinus1) +import Foreign.C.Types (CULLong(..)) +#else +import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno) +#endif + +data ControlMessage = CMsgWakeup + | CMsgDie + | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Signal + deriving (Eq, Show) + +-- | The structure used to tell the IO manager thread what to do. +data Control = W { + controlReadFd :: {-# UNPACK #-} !Fd + , controlWriteFd :: {-# UNPACK #-} !Fd +#if defined(HAVE_EVENTFD) + , controlEventFd :: {-# UNPACK #-} !Fd +#else + , wakeupReadFd :: {-# UNPACK #-} !Fd + , wakeupWriteFd :: {-# UNPACK #-} !Fd +#endif + , didRegisterWakeupFd :: !Bool + } deriving (Show) + +#if defined(HAVE_EVENTFD) +wakeupReadFd :: Control -> Fd +wakeupReadFd = controlEventFd +{-# INLINE wakeupReadFd #-} +#endif + +-- | Create the structure (usually a pipe) used for waking up the IO +-- manager thread from another thread. +newControl :: Bool -> IO Control +newControl shouldRegister = allocaArray 2 $ \fds -> do + let createPipe = do + throwErrnoIfMinus1_ "pipe" $ c_pipe fds + rd <- peekElemOff fds 0 + wr <- peekElemOff fds 1 + -- The write end must be non-blocking, since we may need to + -- poke the event manager from a signal handler. + setNonBlockingFD wr True + setCloseOnExec rd + setCloseOnExec wr + return (rd, wr) + (ctrl_rd, ctrl_wr) <- createPipe +#if defined(HAVE_EVENTFD) + ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0 + setNonBlockingFD ev True + setCloseOnExec ev + when shouldRegister $ c_setIOManagerWakeupFd ev +#else + (wake_rd, wake_wr) <- createPipe + when shouldRegister $ c_setIOManagerWakeupFd wake_wr +#endif + return W { controlReadFd = fromIntegral ctrl_rd + , controlWriteFd = fromIntegral ctrl_wr +#if defined(HAVE_EVENTFD) + , controlEventFd = fromIntegral ev +#else + , wakeupReadFd = fromIntegral wake_rd + , wakeupWriteFd = fromIntegral wake_wr +#endif + , didRegisterWakeupFd = shouldRegister + } + +-- | Close the control structure used by the IO manager thread. +-- N.B. If this Control is the Control whose wakeup file was registered with +-- the RTS, then *BEFORE* the wakeup file is closed, we must call +-- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup +-- file after it has been closed. +closeControl :: Control -> IO () +closeControl w = do + _ <- c_close . fromIntegral . controlReadFd $ w + _ <- c_close . fromIntegral . controlWriteFd $ w + when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1) +#if defined(HAVE_EVENTFD) + _ <- c_close . fromIntegral . controlEventFd $ w +#else + _ <- c_close . fromIntegral . wakeupReadFd $ w + _ <- c_close . fromIntegral . wakeupWriteFd $ w +#endif + return () + +io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8 +io_MANAGER_WAKEUP = 0xff +io_MANAGER_DIE = 0xfe + +foreign import ccall "__hscore_sizeof_siginfo_t" + sizeof_siginfo_t :: CSize + +readControlMessage :: Control -> Fd -> IO ControlMessage +readControlMessage ctrl fd + | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do + throwErrnoIfMinus1_ "readWakeupMessage" $ + c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize) + return CMsgWakeup + | otherwise = + alloca $ \p -> do + throwErrnoIfMinus1_ "readControlMessage" $ + c_read (fromIntegral fd) p 1 + s <- peek p + case s of + -- Wakeup messages shouldn't be sent on the control + -- file descriptor but we handle them anyway. + _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup + _ | s == io_MANAGER_DIE -> return CMsgDie + _ -> do -- Signal + fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) + withForeignPtr fp $ \p_siginfo -> do + r <- c_read (fromIntegral fd) (castPtr p_siginfo) + sizeof_siginfo_t + when (r /= fromIntegral sizeof_siginfo_t) $ + error "failed to read siginfo_t" + let !s' = fromIntegral s + return $ CMsgSignal fp s' + + where wakeupBufferSize = +#if defined(HAVE_EVENTFD) + 8 +#else + 4096 +#endif + +sendWakeup :: Control -> IO () +#if defined(HAVE_EVENTFD) +sendWakeup c = + throwErrnoIfMinus1_ "sendWakeup" $ + c_eventfd_write (fromIntegral (controlEventFd c)) 1 +#else +sendWakeup c = do + n <- sendMessage (wakeupWriteFd c) CMsgWakeup + case n of + _ | n /= -1 -> return () + | otherwise -> do + errno <- getErrno + when (errno /= eAGAIN && errno /= eWOULDBLOCK) $ + throwErrno "sendWakeup" +#endif + +sendDie :: Control -> IO () +sendDie c = throwErrnoIfMinus1_ "sendDie" $ + sendMessage (controlWriteFd c) CMsgDie + +sendMessage :: Fd -> ControlMessage -> IO Int +sendMessage fd msg = alloca $ \p -> do + case msg of + CMsgWakeup -> poke p io_MANAGER_WAKEUP + CMsgDie -> poke p io_MANAGER_DIE + CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS" + fromIntegral `fmap` c_write (fromIntegral fd) p 1 + +#if defined(HAVE_EVENTFD) +foreign import ccall unsafe "sys/eventfd.h eventfd" + c_eventfd :: CInt -> CInt -> IO CInt + +foreign import ccall unsafe "sys/eventfd.h eventfd_write" + c_eventfd_write :: CInt -> CULLong -> IO CInt +#endif + +foreign import ccall unsafe "setIOManagerWakeupFd" + c_setIOManagerWakeupFd :: CInt -> IO () + +foreign import ccall unsafe "static baz" + c_baz :: CInt -> IO () diff --git a/testsuite/tests/printer/Ppr009.hs b/testsuite/tests/printer/Ppr009.hs new file mode 100644 index 0000000000..d24ecdc517 --- /dev/null +++ b/testsuite/tests/printer/Ppr009.hs @@ -0,0 +1,9 @@ +module Ppr009 where + + +{-# INLINE strictStream #-} +strictStream (Bitstream l v) + = {-# CORE "Strict Bitstream stream" #-} + S.concatMap stream (GV.stream v) + `S.sized` + Exact l diff --git a/testsuite/tests/printer/Ppr009.stderr b/testsuite/tests/printer/Ppr009.stderr new file mode 100644 index 0000000000..3aabba4ceb --- /dev/null +++ b/testsuite/tests/printer/Ppr009.stderr @@ -0,0 +1,28 @@ +Ppr009.hs:5:15: error: Not in scope: data constructor ‘Bitstream’ + +Ppr009.hs:7:7: error: + Not in scope: ‘S.concatMap’ + No module named ‘S’ is imported. + +Ppr009.hs:7:27: error: + Not in scope: ‘GV.stream’ + No module named ‘GV’ is imported. + +Ppr009.hs:8:7: error: + Not in scope: ‘S.sized’ + No module named ‘S’ is imported. + +Ppr009.ppr.hs:4:15: error: + Not in scope: data constructor ‘Bitstream’ + +Ppr009.ppr.hs:6:5: error: + Not in scope: ‘S.concatMap’ + No module named ‘S’ is imported. + +Ppr009.ppr.hs:6:25: error: + Not in scope: ‘GV.stream’ + No module named ‘GV’ is imported. + +Ppr009.ppr.hs:6:38: error: + Not in scope: ‘S.sized’ + No module named ‘S’ is imported. diff --git a/testsuite/tests/printer/Ppr010.hs b/testsuite/tests/printer/Ppr010.hs new file mode 100644 index 0000000000..2373eb6494 --- /dev/null +++ b/testsuite/tests/printer/Ppr010.hs @@ -0,0 +1,17 @@ +{-# Language CPP #-} +module Ppr010 where + +#if __GLASGOW_HASKELL__ > 704 +foo :: Int +#else +foo :: Integer +#endif +foo = 3 + +bar :: ( +#if __GLASGOW_HASKELL__ > 704 + Int) +#else + Integer) +#endif +bar = 4 diff --git a/testsuite/tests/printer/Ppr011.hs b/testsuite/tests/printer/Ppr011.hs new file mode 100644 index 0000000000..b967e247b6 --- /dev/null +++ b/testsuite/tests/printer/Ppr011.hs @@ -0,0 +1,34 @@ +{-# Language DatatypeContexts #-} +{-# Language ExistentialQuantification #-} +{-# LAnguage GADTs #-} +{-# LAnguage KindSignatures #-} + +data Foo = A + | B + | C + +-- | data_or_newtype capi_ctype tycl_hdr constrs deriving +data {-# Ctype "Foo" "bar" #-} F1 = F1 +data {-# Ctype "baz" #-} Eq a => F2 a = F2 a + +data (Eq a,Ord a) => F3 a = F3 Int a + +data F4 a = forall x y. (Eq x,Eq y) => F4 a x y + | forall x y. (Eq x,Eq y) => F4b a x y + + +data G1 a :: * where + G1A, G1B :: Int -> G1 a + G1C :: Double -> G1 a + +data G2 a :: * where + G2A :: { g2a :: a, g2b :: Int } -> G2 a + G2C :: Double -> G2 a + + + +data (Eq a,Ord a) => G3 a = G3 + { g3A :: Int + , g3B :: Bool + , g3a :: a + } deriving (Eq,Ord) diff --git a/testsuite/tests/printer/Ppr011.stderr b/testsuite/tests/printer/Ppr011.stderr new file mode 100644 index 0000000000..d5b40af36c --- /dev/null +++ b/testsuite/tests/printer/Ppr011.stderr @@ -0,0 +1,12 @@ + +Ppr011.hs:1:14: warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +Ppr011.hs:1:1: error: + The IO action ‘main’ is not defined in module ‘Main’ + +Ppr011.ppr.hs:1:14: warning: + -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. + +Ppr011.ppr.hs:1:1: error: + The IO action ‘main’ is not defined in module ‘Main’ diff --git a/testsuite/tests/printer/Ppr012.hs b/testsuite/tests/printer/Ppr012.hs new file mode 100644 index 0000000000..b34b1470f4 --- /dev/null +++ b/testsuite/tests/printer/Ppr012.hs @@ -0,0 +1,42 @@ +{-# OPTIONS -O -ddump-stranal #-} + +module Dead1(foo) where + +foo :: Int -> Int +foo n = baz (n+1) (bar1 n) + +{-# NOINLINE bar1 #-} +bar1 n = 1 + bar n + +bar :: Int -> Int +{-# NOINLINE bar #-} +{-# RULES +"bar/foo" forall n. bar (foo n) = n + #-} +bar n = n-1 + +baz :: Int -> Int -> Int +{-# INLINE [0] baz #-} +baz m n = m + + +{- Ronam writes (Feb08) + + Note that bar becomes dead as soon as baz gets inlined. But strangely, + the simplifier only deletes it after full laziness and CSE. That is, it + is not deleted in the phase in which baz gets inlined. In fact, it is + still there after w/w and the subsequent simplifier run. It gets deleted + immediately if I comment out the rule. + + I stumbled over this when I removed one simplifier run after SpecConstr + (at the moment, it runs twice at the end but I don't think that should + be necessary). With this change, the original version of a specialised + loop (the one with the rules) is not longer deleted even if it isn't + used any more. I'll reenable the second simplifier run for now but + should this really be necessary? + +No, it should not be necessary. A refactoring in OccurAnal makes +this work right. Look at the simplifier output just before strictness +analysis; there should be a binding for 'foo', but for nothing else. + +-} diff --git a/testsuite/tests/printer/Ppr012.stderr b/testsuite/tests/printer/Ppr012.stderr new file mode 100644 index 0000000000..5dd1384f3c --- /dev/null +++ b/testsuite/tests/printer/Ppr012.stderr @@ -0,0 +1,8 @@ + +Ppr012.hs:14:1: warning: [-Winline-rule-shadowing] + Rule "bar/foo" may never fire because ‘foo’ might inline first + Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo’ + +Ppr012.ppr.hs:11:11: warning: [-Winline-rule-shadowing] + Rule "bar/foo" may never fire because ‘foo’ might inline first + Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo’ diff --git a/testsuite/tests/printer/Ppr012.stdout b/testsuite/tests/printer/Ppr012.stdout new file mode 100644 index 0000000000..b4e01eb8a3 --- /dev/null +++ b/testsuite/tests/printer/Ppr012.stdout @@ -0,0 +1,186 @@ + +==================== Demand analysis ==================== +Result size of Demand analysis + = {terms: 19, types: 8, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule_sK3 :: GHC.Types.TrName +[LclId, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +$trModule_sK3 = GHC.Types.TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule_sK4 :: GHC.Types.TrName +[LclId, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +$trModule_sK4 = GHC.Types.TrNameS "Dead1"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +Dead1.$trModule :: GHC.Types.Module +[LclIdX, + Str=m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +Dead1.$trModule = GHC.Types.Module $trModule_sK3 $trModule_sK4 + +-- RHS size: {terms: 8, types: 3, coercions: 0} +foo :: Int -> Int +[LclIdX, + Arity=1, + Str=<S(S),1*U(U)>m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 21 20}] +foo = + \ (n_axW [Dmd=<S(S),1*U(U)>] :: Int) -> + case n_axW of { GHC.Types.I# x_aKq [Dmd=<S,U>] -> + GHC.Types.I# (GHC.Prim.+# x_aKq 1#) + } + + + + +==================== Demand analysis ==================== +Result size of Demand analysis + = {terms: 19, types: 8, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule_sK3 :: GHC.Types.TrName +[LclId, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +$trModule_sK3 = GHC.Types.TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule_sK4 :: GHC.Types.TrName +[LclId, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +$trModule_sK4 = GHC.Types.TrNameS "Dead1"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +Dead1.$trModule :: GHC.Types.Module +[LclIdX, + Str=m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +Dead1.$trModule = GHC.Types.Module $trModule_sK3 $trModule_sK4 + +-- RHS size: {terms: 8, types: 3, coercions: 0} +foo :: Int -> Int +[LclIdX, + Arity=1, + Str=<S(S),1*U(U)>m, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (n_axW [Occ=Once!] :: Int) -> + case n_axW of { GHC.Types.I# x_aKq [Occ=Once] -> + GHC.Types.I# (GHC.Prim.+# x_aKq 1#) + }}] +foo = + \ (n_axW [Dmd=<S(S),1*U(U)>] :: Int) -> + case n_axW of { GHC.Types.I# x_aKq [Dmd=<S,U>] -> + GHC.Types.I# (GHC.Prim.+# x_aKq 1#) + } + + + + +==================== Demand analysis ==================== +Result size of Demand analysis + = {terms: 19, types: 8, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule_s1vS :: GHC.Types.TrName +[LclId, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +$trModule_s1vS = GHC.Types.TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule_s1vT :: GHC.Types.TrName +[LclId, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +$trModule_s1vT = GHC.Types.TrNameS "Dead1"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +Dead1.$trModule :: GHC.Types.Module +[LclIdX, + Str=m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +Dead1.$trModule = GHC.Types.Module $trModule_s1vS $trModule_s1vT + +-- RHS size: {terms: 8, types: 3, coercions: 0} +foo :: Int -> Int +[LclIdX, + Arity=1, + Str=<S(S),1*U(U)>m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 21 20}] +foo = + \ (n_a1jL [Dmd=<S(S),1*U(U)>] :: Int) -> + case n_a1jL of { GHC.Types.I# x_a1wf [Dmd=<S,U>] -> + GHC.Types.I# (GHC.Prim.+# x_a1wf 1#) + } + + + + +==================== Demand analysis ==================== +Result size of Demand analysis + = {terms: 19, types: 8, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule_s1vS :: GHC.Types.TrName +[LclId, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +$trModule_s1vS = GHC.Types.TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +$trModule_s1vT :: GHC.Types.TrName +[LclId, + Str=m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +$trModule_s1vT = GHC.Types.TrNameS "Dead1"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +Dead1.$trModule :: GHC.Types.Module +[LclIdX, + Str=m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +Dead1.$trModule = GHC.Types.Module $trModule_s1vS $trModule_s1vT + +-- RHS size: {terms: 8, types: 3, coercions: 0} +foo :: Int -> Int +[LclIdX, + Arity=1, + Str=<S(S),1*U(U)>m, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (n_a1jL [Occ=Once!] :: Int) -> + case n_a1jL of { GHC.Types.I# x_a1wf [Occ=Once] -> + GHC.Types.I# (GHC.Prim.+# x_a1wf 1#) + }}] +foo = + \ (n_a1jL [Dmd=<S(S),1*U(U)>] :: Int) -> + case n_a1jL of { GHC.Types.I# x_a1wf [Dmd=<S,U>] -> + GHC.Types.I# (GHC.Prim.+# x_a1wf 1#) + } + + + diff --git a/testsuite/tests/printer/Ppr013.hs b/testsuite/tests/printer/Ppr013.hs new file mode 100644 index 0000000000..2b0bca6b07 --- /dev/null +++ b/testsuite/tests/printer/Ppr013.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +import Data.Data + +data Foo = FooA | FooB + +deriving instance Show Foo + +deriving instance {-# Overlappable #-} Eq Foo +deriving instance {-# Overlapping #-} Ord Foo +deriving instance {-# Overlaps #-} Typeable Foo +deriving instance {-# Incoherent #-} Data Foo diff --git a/testsuite/tests/printer/Ppr013.stderr b/testsuite/tests/printer/Ppr013.stderr new file mode 100644 index 0000000000..5bfa1c790d --- /dev/null +++ b/testsuite/tests/printer/Ppr013.stderr @@ -0,0 +1,6 @@ + +Ppr013.hs:1:1: error: + The IO action ‘main’ is not defined in module ‘Main’ + +Ppr013.ppr.hs:1:1: error: + The IO action ‘main’ is not defined in module ‘Main’ diff --git a/testsuite/tests/printer/Ppr014.hs b/testsuite/tests/printer/Ppr014.hs new file mode 100644 index 0000000000..c0448688ba --- /dev/null +++ b/testsuite/tests/printer/Ppr014.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-19-existential-quantification.html + +data HashMap k v = HM -- ... -- actual implementation + +class Hashable v where + h :: v -> Int + +data HashMapM hm = HashMapM + { empty :: forall k v . hm k v + , lookup :: Hashable k => k -> hm k v -> Maybe v + , insert :: Hashable k => k -> v -> hm k v -> hm k v + , union :: Hashable k => hm k v -> hm k v -> hm k v + } + + +data HashMapE = forall hm . HashMapE (HashMapM hm) + +-- public +mkHashMapE :: Int -> HashMapE +mkHashMapE = HashMapE . mkHashMapM + +-- private +mkHashMapM :: Int -> HashMapM HashMap +mkHashMapM salt = HashMapM { {- implementation -} } + +instance Hashable String where + +type Name = String +data Gift = G String + +giraffe :: Gift +giraffe = G "giraffe" + +addGift :: HashMapM hm -> hm Name Gift -> hm Name Gift +addGift mod gifts = + let + HashMapM{..} = mod + in + insert "Ollie" giraffe gifts + +-- ------------------------------- + +santa'sSecretSalt = undefined +sendGiftToOllie = undefined +traverse_ = undefined + +sendGifts = + case mkHashMapE santa'sSecretSalt of + HashMapE (mod@HashMapM{..}) -> + let + gifts = addGift mod empty + in + traverse_ sendGiftToOllie $ lookup "Ollie" gifts diff --git a/testsuite/tests/printer/Ppr014.stderr b/testsuite/tests/printer/Ppr014.stderr new file mode 100644 index 0000000000..d7ef8c588b --- /dev/null +++ b/testsuite/tests/printer/Ppr014.stderr @@ -0,0 +1,76 @@ + +Ppr014.hs:16:24: error: Not in scope: type variable ‘k’ + +Ppr014.hs:16:29: error: Not in scope: type variable ‘k’ + +Ppr014.hs:16:37: error: Not in scope: type variable ‘k’ + +Ppr014.hs:16:39: error: Not in scope: type variable ‘v’ + +Ppr014.hs:16:50: error: Not in scope: type variable ‘v’ + +Ppr014.hs:17:24: error: Not in scope: type variable ‘k’ + +Ppr014.hs:17:29: error: Not in scope: type variable ‘k’ + +Ppr014.hs:17:34: error: Not in scope: type variable ‘v’ + +Ppr014.hs:17:42: error: Not in scope: type variable ‘k’ + +Ppr014.hs:17:44: error: Not in scope: type variable ‘v’ + +Ppr014.hs:17:52: error: Not in scope: type variable ‘k’ + +Ppr014.hs:17:54: error: Not in scope: type variable ‘v’ + +Ppr014.hs:18:24: error: Not in scope: type variable ‘k’ + +Ppr014.hs:18:32: error: Not in scope: type variable ‘k’ + +Ppr014.hs:18:34: error: Not in scope: type variable ‘v’ + +Ppr014.hs:18:42: error: Not in scope: type variable ‘k’ + +Ppr014.hs:18:44: error: Not in scope: type variable ‘v’ + +Ppr014.hs:18:52: error: Not in scope: type variable ‘k’ + +Ppr014.hs:18:54: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:11:34: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:11:39: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:11:47: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:11:49: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:11:60: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:12:34: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:12:39: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:12:44: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:12:52: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:12:54: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:12:62: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:12:64: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:13:33: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:13:41: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:13:43: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:13:51: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:13:53: error: Not in scope: type variable ‘v’ + +Ppr014.ppr.hs:13:61: error: Not in scope: type variable ‘k’ + +Ppr014.ppr.hs:13:63: error: Not in scope: type variable ‘v’ diff --git a/testsuite/tests/printer/Ppr015.hs b/testsuite/tests/printer/Ppr015.hs new file mode 100644 index 0000000000..531ebc77a0 --- /dev/null +++ b/testsuite/tests/printer/Ppr015.hs @@ -0,0 +1,5 @@ +module ExprPragmas where + +a = {-# SCC "name" #-} 0x5 + +b = {-# SCC foo #-} 006 diff --git a/testsuite/tests/printer/Ppr016.hs b/testsuite/tests/printer/Ppr016.hs new file mode 100644 index 0000000000..630045c0b2 --- /dev/null +++ b/testsuite/tests/printer/Ppr016.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ImplicitParams #-} + +explicit :: ((?above :: q, ?below :: a -> q) => b) -> q -> (a -> q) -> b +explicit x ab be = x where ?above = ab; ?below = be diff --git a/testsuite/tests/printer/Ppr016.stderr b/testsuite/tests/printer/Ppr016.stderr new file mode 100644 index 0000000000..2d508fa4dd --- /dev/null +++ b/testsuite/tests/printer/Ppr016.stderr @@ -0,0 +1,14 @@ + +Ppr016.hs:3:13: error: + • Illegal qualified type: (?above::q, ?below::a -> q) => b + Perhaps you intended to use RankNTypes or Rank2Types + • In the type signature: + explicit :: ((?above :: q, ?below :: a -> q) => b) + -> q -> (a -> q) -> b + +Ppr016.ppr.hs:3:3: error: + • Illegal qualified type: (?above::q, ?below::a -> q) => b + Perhaps you intended to use RankNTypes or Rank2Types + • In the type signature: + explicit :: ((?above :: q, ?below :: a -> q) => b) + -> q -> (a -> q) -> b diff --git a/testsuite/tests/printer/Ppr017.hs b/testsuite/tests/printer/Ppr017.hs new file mode 100644 index 0000000000..091ffee048 --- /dev/null +++ b/testsuite/tests/printer/Ppr017.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ExplicitNamespaces #-} +module Imports( f, type (+), pattern Single ) where + +import GHC.TypeLits + +pattern Single x = [x] + +f = undefined diff --git a/testsuite/tests/printer/Ppr018.hs b/testsuite/tests/printer/Ppr018.hs new file mode 100644 index 0000000000..c05ce66c8a --- /dev/null +++ b/testsuite/tests/printer/Ppr018.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} + +data Foo a = F Int | A a + deriving Show + +data Foo1 a = F1 Int | A1 a + deriving (Show) + +data Foo2 a = F2 Int | A2 a + deriving (Show, Eq) + +data FooStock = FS Int + deriving stock Show + +data FooAnyClass = Fa Int + deriving anyclass Show + +newtype FooNewType = Fn Int + deriving newtype (Show) diff --git a/testsuite/tests/printer/Ppr018.stderr b/testsuite/tests/printer/Ppr018.stderr new file mode 100644 index 0000000000..7172b4e8be --- /dev/null +++ b/testsuite/tests/printer/Ppr018.stderr @@ -0,0 +1,12 @@ + +Ppr018.hs:20:21: + Can't make a derived instance of + ‘Show FooNewType’ with the newtype strategy: + Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension + In the newtype declaration for ‘FooNewType’ + +Ppr018.ppr.hs:20:21: + Can't make a derived instance of + ‘Show FooNewType’ with the newtype strategy: + Try GeneralizedNewtypeDeriving for GHC's newtype-deriving extension + In the newtype declaration for ‘FooNewType’ diff --git a/testsuite/tests/printer/Ppr019.hs b/testsuite/tests/printer/Ppr019.hs new file mode 100644 index 0000000000..c934cc5ccc --- /dev/null +++ b/testsuite/tests/printer/Ppr019.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, + CPP #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE RoleAnnotations #-} +#endif + +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Array.IO.Internal +-- Copyright : (c) The University of Glasgow 2001-2012 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (uses Data.Array.Base) +-- +-- Mutable boxed and unboxed arrays in the IO monad. +-- +----------------------------------------------------------------------------- + +module Data.Array.IO.Internals ( + IOArray(..), -- instance of: Eq, Typeable + IOUArray(..), -- instance of: Eq, Typeable + castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b) + unsafeThawIOUArray, + ) where + +import Data.Int +import Data.Word +import Data.Typeable + +import Control.Monad.ST ( RealWorld, stToIO ) +import Foreign.Ptr ( Ptr, FunPtr ) +import Foreign.StablePtr ( StablePtr ) + +#if __GLASGOW_HASKELL__ < 711 +import Data.Ix +#endif +import Data.Array.Base + +import GHC.IOArray (IOArray(..)) + +----------------------------------------------------------------------------- +-- Flat unboxed mutable arrays (IO monad) + +-- | Mutable, unboxed, strict arrays in the 'IO' monad. The type +-- arguments are as follows: +-- +-- * @i@: the index type of the array (should be an instance of 'Ix') +-- +-- * @e@: the element type of the array. Only certain element types +-- are supported: see "Data.Array.MArray" for a list of instances. +-- +newtype IOUArray i e = IOUArray (STUArray RealWorld i e) + deriving Typeable +#if __GLASGOW_HASKELL__ >= 708 +-- Both parameters have class-based invariants. See also #9220. +type role IOUArray nominal nominal +#endif + +instance Eq (IOUArray i e) where + IOUArray s1 == IOUArray s2 = s1 == s2 + +instance MArray IOUArray Bool IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Char IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (Ptr a) IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (FunPtr a) IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Float IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Double IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray (StablePtr a) IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int8 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int16 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int32 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Int64 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word8 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word16 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word32 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +instance MArray IOUArray Word64 IO where + {-# INLINE getBounds #-} + getBounds (IOUArray arr) = stToIO $ getBounds arr + {-# INLINE getNumElements #-} + getNumElements (IOUArray arr) = stToIO $ getNumElements arr + {-# INLINE newArray #-} + newArray lu initialValue = stToIO $ do + marr <- newArray lu initialValue; return (IOUArray marr) + {-# INLINE unsafeNewArray_ #-} + unsafeNewArray_ lu = stToIO $ do + marr <- unsafeNewArray_ lu; return (IOUArray marr) + {-# INLINE newArray_ #-} + newArray_ = unsafeNewArray_ + {-# INLINE unsafeRead #-} + unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i) + {-# INLINE unsafeWrite #-} + unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e) + +-- | Casts an 'IOUArray' with one element type into one with a +-- different element type. All the elements of the resulting array +-- are undefined (unless you know what you\'re doing...). +castIOUArray :: IOUArray ix a -> IO (IOUArray ix b) +castIOUArray (IOUArray marr) = stToIO $ do + marr' <- castSTUArray marr + return (IOUArray marr') + +{-# INLINE unsafeThawIOUArray #-} +#if __GLASGOW_HASKELL__ >= 711 +unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e) +#else +unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +#endif +unsafeThawIOUArray arr = stToIO $ do + marr <- unsafeThawSTUArray arr + return (IOUArray marr) + +{-# RULES +"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray + #-} + +#if __GLASGOW_HASKELL__ >= 711 +thawIOUArray :: UArray ix e -> IO (IOUArray ix e) +#else +thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e) +#endif +thawIOUArray arr = stToIO $ do + marr <- thawSTUArray arr + return (IOUArray marr) + +{-# RULES +"thaw/IOUArray" thaw = thawIOUArray + #-} + +{-# INLINE unsafeFreezeIOUArray #-} +#if __GLASGOW_HASKELL__ >= 711 +unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e) +#else +unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +#endif +unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr) + +{-# RULES +"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray + #-} + +#if __GLASGOW_HASKELL__ >= 711 +freezeIOUArray :: IOUArray ix e -> IO (UArray ix e) +#else +freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e) +#endif +freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr) + +{-# RULES +"freeze/IOUArray" freeze = freezeIOUArray + #-} diff --git a/testsuite/tests/printer/Ppr020.hs b/testsuite/tests/printer/Ppr020.hs new file mode 100644 index 0000000000..f567f726a1 --- /dev/null +++ b/testsuite/tests/printer/Ppr020.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LambdaCase #-} + +foo = f >>= \case + Just h -> loadTestDB (h ++ "/.testdb") + Nothing -> fmap S.Right initTestDB + +{-| Is the alarm set - i.e. will it go off at some point in the future even if + `setAlarm` is not called? -} +isAlarmSetSTM :: AlarmClock -> STM Bool +isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting + >>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True } diff --git a/testsuite/tests/printer/Ppr020.stderr b/testsuite/tests/printer/Ppr020.stderr new file mode 100644 index 0000000000..bd82bca25e --- /dev/null +++ b/testsuite/tests/printer/Ppr020.stderr @@ -0,0 +1,31 @@ + +Ppr020.hs:5:25: + Not in scope: data constructor ‘S.Right’ + No module named ‘S’ is imported. + +Ppr020.hs:9:18: + Not in scope: type constructor or class ‘AlarmClock’ + +Ppr020.hs:9:32: + Not in scope: type constructor or class ‘STM’ + +Ppr020.hs:10:15: Not in scope: data constructor ‘AlarmClock’ + +Ppr020.hs:11:15: + Not in scope: data constructor ‘AlarmNotSet’ + +Ppr020.ppr.hs:6:27: + Not in scope: data constructor ‘S.Right’ + No module named ‘S’ is imported. + +Ppr020.ppr.hs:7:18: + Not in scope: type constructor or class ‘AlarmClock’ + +Ppr020.ppr.hs:7:32: + Not in scope: type constructor or class ‘STM’ + +Ppr020.ppr.hs:8:15: + Not in scope: data constructor ‘AlarmClock’ + +Ppr020.ppr.hs:12:11: + Not in scope: data constructor ‘AlarmNotSet’ diff --git a/testsuite/tests/printer/Ppr021.hs b/testsuite/tests/printer/Ppr021.hs new file mode 100644 index 0000000000..03bda3dcff --- /dev/null +++ b/testsuite/tests/printer/Ppr021.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# Language DeriveFoldable #-} +{-# LANGUAGE Safe #-} +{-# options_ghc -w #-} + +-- | A simple let expression, to ensure the layout is detected +-- With some haddock in the top +{- And a normal + multiline comment too -} + module {- brah -} LetExpr ( foo -- foo does .. + , bar -- bar does .. + , Baz () -- baz does .. + , Ba ( ..),Ca(Cc,Cd) , + bbb , aaa + , module Data.List + , pattern Bar + ) + where + +import Data.List +-- A comment in the middle +import {-# SOURCE #-} BootImport ( Foo(..) ) +import {-# SoURCE #-} safe qualified BootImport as BI +import qualified Data.Map as {- blah -} Foo.Map + +import Control.Monad ( ) +import Data.Word (Word8) +import Data.Tree hiding ( drawTree ) + +import qualified Data.Maybe as M hiding ( maybe , isJust ) + + +-- comment +foo = let x = 1 + y = 2 + in x + y + +bar = 3 +bbb x + | x == 1 = () + | otherwise = () + + +aaa [ ] _ = 0 +aaa x _unk = 1 + +aba () = 0 + +x `ccc` 1 = x + 1 +x `ccc` y = x + y + +x !@# y = x + y + +data Baz = Baz1 | Baz2 + +data Ba = Ba | Bb + +data Ca = Cc | Cd + +pattern Foo a <- RealFoo a +pattern Bar a <- RealBar a + +data Thing = RealFoo Thing | RealBar Int diff --git a/testsuite/tests/printer/Ppr021.stderr b/testsuite/tests/printer/Ppr021.stderr new file mode 100644 index 0000000000..c8eb1667c4 --- /dev/null +++ b/testsuite/tests/printer/Ppr021.stderr @@ -0,0 +1,16 @@ + +Ppr021.hs:22:1: error: + Could not find module ‘BootImport’ + Use -v to see a list of the files searched for. + +Ppr021.hs:23:1: error: + Could not find module ‘BootImport’ + Use -v to see a list of the files searched for. + +Ppr021.ppr.hs:10:1: error: + Could not find module ‘BootImport’ + Use -v to see a list of the files searched for. + +Ppr021.ppr.hs:11:1: error: + Could not find module ‘BootImport’ + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/printer/Ppr022.hs b/testsuite/tests/printer/Ppr022.hs new file mode 100644 index 0000000000..9d57907522 --- /dev/null +++ b/testsuite/tests/printer/Ppr022.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds, TemplateHaskell #-} + +applicate :: Bool -> [Stmt] -> ExpQ +applicate rawPatterns stmt = do + return $ foldl (\g e -> VarE '(<**>) `AppE` e `AppE` g) + (VarE 'pure `AppE` f') + es + +tuple :: Int -> ExpQ +tuple n = do + ns <- replicateM n (newName "x") + lamE [foldr (\x y -> conP '(:) [varP x,y]) wildP ns] (tupE $ map varE ns) diff --git a/testsuite/tests/printer/Ppr022.stderr b/testsuite/tests/printer/Ppr022.stderr new file mode 100644 index 0000000000..3094acae7a --- /dev/null +++ b/testsuite/tests/printer/Ppr022.stderr @@ -0,0 +1,28 @@ + +Ppr022.hs:3:23: + Not in scope: type constructor or class ‘Stmt’ + +Ppr022.hs:3:32: + Not in scope: type constructor or class ‘ExpQ’ + +Ppr022.hs:5:34: + Not in scope: ‘<**>’ + Perhaps you meant ‘<*>’ (imported from Prelude) + In the Template Haskell quotation '(<**>) + +Ppr022.hs:9:17: + Not in scope: type constructor or class ‘ExpQ’ + +Ppr022.ppr.hs:2:23: + Not in scope: type constructor or class ‘Stmt’ + +Ppr022.ppr.hs:2:32: + Not in scope: type constructor or class ‘ExpQ’ + +Ppr022.ppr.hs:6:29: + Not in scope: ‘<**>’ + Perhaps you meant ‘<*>’ (imported from Prelude) + In the Template Haskell quotation '(<**>) + +Ppr022.ppr.hs:7:17: + Not in scope: type constructor or class ‘ExpQ’ diff --git a/testsuite/tests/printer/Ppr023.hs b/testsuite/tests/printer/Ppr023.hs new file mode 100644 index 0000000000..7291854f07 --- /dev/null +++ b/testsuite/tests/printer/Ppr023.hs @@ -0,0 +1,37 @@ +class AwsType a where + toText :: a -> b + + + {-# MINIMAL toText #-} + +class Minimal a where + toText :: a -> b + {-# MINIMAL decimal, hexadecimal, realFloat, scientific #-} + +class Minimal a where + toText :: a -> b + {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-} + +class Minimal a where + toText :: a -> b + {-# MINIMAL (toSample | toSamples) #-} + +class ManyOps a where + aOp :: a -> a -> Bool + bOp :: a -> a -> Bool + cOp :: a -> a -> Bool + dOp :: a -> a -> Bool + eOp :: a -> a -> Bool + fOp :: a -> a -> Bool + {-# MINIMAL ( aOp) + | ( bOp , cOp) + | ((dOp | eOp) , fOp) + #-} + +class Foo a where + bar :: a -> a -> Bool + foo :: a -> a -> Bool + baq :: a -> a -> Bool + baz :: a -> a -> Bool + quux :: a -> a -> Bool + {-# MINIMAL bar, (foo, baq | foo, quux) #-} diff --git a/testsuite/tests/printer/Ppr023.stderr b/testsuite/tests/printer/Ppr023.stderr new file mode 100644 index 0000000000..35440a54cd --- /dev/null +++ b/testsuite/tests/printer/Ppr023.stderr @@ -0,0 +1,49 @@ +Ppr023.hs:15:1: error: + Multiple declarations of ‘Minimal’ + Declared at: Ppr023.hs:11:1 + Ppr023.hs:15:1 + +Ppr023.hs:15:1: error: + Multiple declarations of ‘Minimal’ + Declared at: Ppr023.hs:7:1 + Ppr023.hs:15:1 + +Ppr023.hs:16:3: error: + Multiple declarations of ‘toText’ + Declared at: Ppr023.hs:12:3 + Ppr023.hs:16:3 + +Ppr023.hs:16:3: error: + Multiple declarations of ‘toText’ + Declared at: Ppr023.hs:8:3 + Ppr023.hs:16:3 + +Ppr023.hs:16:3: error: + Multiple declarations of ‘toText’ + Declared at: Ppr023.hs:2:5 + Ppr023.hs:16:3 + +Ppr023.ppr.hs:11:1: error: + Multiple declarations of ‘Minimal’ + Declared at: Ppr023.ppr.hs:8:1 + Ppr023.ppr.hs:11:1 + +Ppr023.ppr.hs:11:1: error: + Multiple declarations of ‘Minimal’ + Declared at: Ppr023.ppr.hs:5:1 + Ppr023.ppr.hs:11:1 + +Ppr023.ppr.hs:12:3: error: + Multiple declarations of ‘toText’ + Declared at: Ppr023.ppr.hs:9:3 + Ppr023.ppr.hs:12:3 + +Ppr023.ppr.hs:12:3: error: + Multiple declarations of ‘toText’ + Declared at: Ppr023.ppr.hs:6:3 + Ppr023.ppr.hs:12:3 + +Ppr023.ppr.hs:12:3: error: + Multiple declarations of ‘toText’ + Declared at: Ppr023.ppr.hs:3:3 + Ppr023.ppr.hs:12:3 diff --git a/testsuite/tests/printer/Ppr024.hs b/testsuite/tests/printer/Ppr024.hs new file mode 100644 index 0000000000..cccd8b163c --- /dev/null +++ b/testsuite/tests/printer/Ppr024.hs @@ -0,0 +1,47 @@ +import Data.List () +import Data.List hiding () + +infixl 1 `f` +-- infixr 2 `\\\` +infix 3 :==> +infix 4 `MkFoo` + +data Foo = MkFoo Int | Float :==> Double + +x `f` y = x + +(\\\) :: (Eq a) => [a] -> [a] -> [a] +(\\\) xs ys = xs + +g x = x + if True then 1 else 2 +h x = x + 1::Int + +{-# SPECIALISe j :: Int -> Int + , Integer -> Integer #-} + +j n = n + 1 + +test = let k x y = x+y in 1 `k` 2 `k` 3 + +data Rec = (:<-:) { a :: Int, b :: Float } + +ng1 x y = negate y + +instance (Num a, Num b) => Num (a,b) + where + {-# Specialise instance Num (Int,Int) #-} + negate (a,b) = (ng 'c' a, ng1 'c' b) where ng x y = negate y + + + +class Foo1 a where + +class Foz a + +x = 2 where +y = 3 + +instance Foo1 Int where + +ff = ff where g = g where +type T = Int diff --git a/testsuite/tests/printer/Ppr024.stderr b/testsuite/tests/printer/Ppr024.stderr new file mode 100644 index 0000000000..3672a804b4 --- /dev/null +++ b/testsuite/tests/printer/Ppr024.stderr @@ -0,0 +1,6 @@ + +Ppr024.hs:1:1: error: + The IO action ‘main’ is not defined in module ‘Main’ + +Ppr024.ppr.hs:1:1: error: + The IO action ‘main’ is not defined in module ‘Main’ diff --git a/testsuite/tests/printer/Ppr025.hs b/testsuite/tests/printer/Ppr025.hs new file mode 100644 index 0000000000..c198e18a41 --- /dev/null +++ b/testsuite/tests/printer/Ppr025.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE Arrows #-} + +operator = describe "Operators on ProcessA"$ + do + describe "feedback" $ + do + it "acts like local variable with hold." $ + do + let + pa = proc evx -> + do + (\evy -> hold 10 -< evy) + `feedback` \y -> + do + returnA -< ((+y) <$> evx, (y+1) <$ evx) + run pa [1, 2, 3] `shouldBe` [11, 13, 15] + + it "correctly handles stream end." $ + do + let + pa = proc x -> + (\asx -> returnA -< asx) + `feedback` + (\asy -> returnA -< (asy::Event Int, x)) + comp = mkProc (PgPush PgStop) >>> pa + stateProc comp [0, 0] `shouldBe` ([], [0]) + + it "correctly handles stream end.(2)" $ + do + pendingWith "many utilities behave incorrectly at end of stream." diff --git a/testsuite/tests/printer/Ppr025.stderr b/testsuite/tests/printer/Ppr025.stderr new file mode 100644 index 0000000000..4d552b72f5 --- /dev/null +++ b/testsuite/tests/printer/Ppr025.stderr @@ -0,0 +1,6 @@ + +Ppr025.hs:24:47: error: + Not in scope: type constructor or class ‘Event’ + +Ppr025.ppr.hs:17:77: error: + Not in scope: type constructor or class ‘Event’ diff --git a/testsuite/tests/printer/Ppr026.hs b/testsuite/tests/printer/Ppr026.hs new file mode 100644 index 0000000000..9bdfad7104 --- /dev/null +++ b/testsuite/tests/printer/Ppr026.hs @@ -0,0 +1,14 @@ +{-# Language OverloadedStrings #-} +-- from https://ocharles.org.uk/blog/posts/2014-12-17-overloaded-strings.html + +import Data.String + +n :: Num a => a +n = 43 + +f :: Fractional a => a +f = 03.1420 + +-- foo :: Text +foo :: Data.String.IsString a => a +foo = "hello\n there" diff --git a/testsuite/tests/printer/Ppr026.stderr b/testsuite/tests/printer/Ppr026.stderr new file mode 100644 index 0000000000..5768dc97df --- /dev/null +++ b/testsuite/tests/printer/Ppr026.stderr @@ -0,0 +1,6 @@ + +Ppr026.hs:1:1: + The IO action ‘main’ is not defined in module ‘Main’ + +Ppr026.ppr.hs:1:1: + The IO action ‘main’ is not defined in module ‘Main’ diff --git a/testsuite/tests/printer/Ppr027.hs b/testsuite/tests/printer/Ppr027.hs new file mode 100644 index 0000000000..50de503689 --- /dev/null +++ b/testsuite/tests/printer/Ppr027.hs @@ -0,0 +1,5 @@ +{-# OPTIONS -XTemplateHaskell #-} +module TH( x ) where +import Language.Haskell.TH + +x = $(return (LitE (StringL "hello\ngoodbye\nand then"))) diff --git a/testsuite/tests/printer/Ppr028.hs b/testsuite/tests/printer/Ppr028.hs new file mode 100644 index 0000000000..8c9e7ddf09 --- /dev/null +++ b/testsuite/tests/printer/Ppr028.hs @@ -0,0 +1,12 @@ +{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, FlexibleContexts, + TypeSynonymInstances, NoMonomorphismRestriction, FlexibleInstances #-} + +valForm initVal vtor label = withInput $ + proc ((),nm,fi) -> do + s_curr <- keepState initVal -< fi + valid <- vtor -< s_curr + case valid of + Left err -> returnA -< (textField label (Just err) s_curr nm, + Nothing) + Right x -> returnA -< (textField label Nothing s_curr nm, + Just x) diff --git a/testsuite/tests/printer/Ppr028.stderr b/testsuite/tests/printer/Ppr028.stderr new file mode 100644 index 0000000000..c53770c3d0 --- /dev/null +++ b/testsuite/tests/printer/Ppr028.stderr @@ -0,0 +1,6 @@ + +Ppr028.hs:1:1: + The IO action ‘main’ is not defined in module ‘Main’ + +Ppr028.ppr.hs:1:1: + The IO action ‘main’ is not defined in module ‘Main’ diff --git a/testsuite/tests/printer/Ppr029.hs b/testsuite/tests/printer/Ppr029.hs new file mode 100644 index 0000000000..6018455e12 --- /dev/null +++ b/testsuite/tests/printer/Ppr029.hs @@ -0,0 +1,37 @@ +module Rules where + +import Data.Char + +{-# RULES "map-loop" [ ~ ] forall f . map' f = map' (id . f) #-} + +{-# NOINLINE map' #-} +map' f [] = [] +map' f (x:xs) = f x : map' f xs + +main = print (map' toUpper "Hello, World") + +-- Should warn +foo1 x = x +{-# RULES "foo1" [ 1] forall x. foo1 x = x #-} + +-- Should warn +foo2 x = x +{-# INLINE foo2 #-} +{-# RULES "foo2" [~ 1 ] forall x. foo2 x = x #-} + +-- Should not warn +foo3 x = x +{-# NOINLINE foo3 #-} +{-# RULES "foo3" forall x. foo3 x = x #-} + +{-# NOINLINE f #-} +f :: Int -> String +f x = "NOT FIRED" + +{-# NOINLINE neg #-} +neg :: Int -> Int +neg = negate + +{-# RULES + "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED" + #-} diff --git a/testsuite/tests/printer/Ppr029.stderr b/testsuite/tests/printer/Ppr029.stderr new file mode 100644 index 0000000000..a17efb9687 --- /dev/null +++ b/testsuite/tests/printer/Ppr029.stderr @@ -0,0 +1,16 @@ + +Ppr029.hs:15:11: warning: [-Winline-rule-shadowing] + Rule "foo1" may never fire because ‘foo1’ might inline first + Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo1’ + +Ppr029.hs:20:11: warning: [-Winline-rule-shadowing] + Rule "foo2" may never fire because ‘foo2’ might inline first + Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo2’ + +Ppr029.ppr.hs:10:11: warning: [-Winline-rule-shadowing] + Rule "foo1" may never fire because ‘foo1’ might inline first + Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo1’ + +Ppr029.ppr.hs:13:11: warning: [-Winline-rule-shadowing] + Rule "foo2" may never fire because ‘foo2’ might inline first + Probable fix: add an INLINE[n] or NOINLINE[n] pragma for ‘foo2’ diff --git a/testsuite/tests/printer/Ppr030.hs b/testsuite/tests/printer/Ppr030.hs new file mode 100644 index 0000000000..84364c0bea --- /dev/null +++ b/testsuite/tests/printer/Ppr030.hs @@ -0,0 +1,10 @@ +{-# RULES + "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; + "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x; + "cFloatConv/Float->CFloat" forall (x::Float). cFloatConv x = CFloat x; + "cFloatConv/CFloat->Float" forall (x::Float). cFloatConv CFloat x = x; + "cFloatConv/Double->CDouble" forall (x::Double). cFloatConv x = CDouble x; + "cFloatConv/CDouble->Double" forall (x::Double). cFloatConv CDouble x = x + #-}; + +cFloatConv = undefined diff --git a/testsuite/tests/printer/Ppr030.stderr b/testsuite/tests/printer/Ppr030.stderr new file mode 100644 index 0000000000..723d746d1a --- /dev/null +++ b/testsuite/tests/printer/Ppr030.stderr @@ -0,0 +1,6 @@ + +Ppr030.hs:1:1: error: + The IO action ‘main’ is not defined in module ‘Main’ + +Ppr030.ppr.hs:1:1: error: + The IO action ‘main’ is not defined in module ‘Main’ diff --git a/testsuite/tests/printer/Ppr031.hs b/testsuite/tests/printer/Ppr031.hs new file mode 100644 index 0000000000..b31896a9fc --- /dev/null +++ b/testsuite/tests/printer/Ppr031.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-} +spec :: Spec +spec = do + describe "split4'8" $ do + it "0xabc" $ do + split4'8 0xabc `shouldBe` (0x0a, 0xbc) + it "0xfff" $ do + split4'8 0xfff `shouldBe` (0x0f, 0xff) + + describe "(x, y) = split4'8 z" $ do + prop "x <= 0x0f" $ + \z -> let (x, _) = split4'8 z in x <= 0x0f + prop "x << 8 | y == z" $ do + \z -> let (x, y) = split4'8 z in + fromIntegral x `shiftL` 8 .|. fromIntegral y == z + +match s@Status{ pos, flips, captureAt, captureLen } + | isOne ?pat = ite (pos .>= strLen) __FAIL__ one + | otherwise = ite (pos + (toEnum $ minLen ?pat) .> strLen) __FAIL__ $ case ?pat of + POr ps -> choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps + +foo = 1 diff --git a/testsuite/tests/printer/Ppr031.stderr b/testsuite/tests/printer/Ppr031.stderr new file mode 100644 index 0000000000..bc9bc3779f --- /dev/null +++ b/testsuite/tests/printer/Ppr031.stderr @@ -0,0 +1,46 @@ + +Ppr031.hs:2:9: error: + Not in scope: type constructor or class ‘Spec’ + +Ppr031.hs:17:9: error: Not in scope: data constructor ‘Status’ + +Ppr031.hs:17:17: error: + Not in scope: ‘pos’ + Perhaps you meant ‘cos’ (imported from Prelude) + +Ppr031.hs:17:22: error: + Not in scope: ‘flips’ + Perhaps you meant ‘flip’ (imported from Prelude) + +Ppr031.hs:17:29: error: Not in scope: ‘captureAt’ + +Ppr031.hs:17:40: error: Not in scope: ‘captureLen’ + +Ppr031.hs:20:5: error: Not in scope: data constructor ‘POr’ + +Ppr031.hs:20:72: error: + Not in scope: ‘flips’ + Perhaps you meant ‘flip’ (imported from Prelude) + +Ppr031.ppr.hs:2:9: error: + Not in scope: type constructor or class ‘Spec’ + +Ppr031.ppr.hs:13:9: error: Not in scope: data constructor ‘Status’ + +Ppr031.ppr.hs:13:17: error: + Not in scope: ‘pos’ + Perhaps you meant ‘cos’ (imported from Prelude) + +Ppr031.ppr.hs:13:22: error: + Not in scope: ‘flips’ + Perhaps you meant ‘flip’ (imported from Prelude) + +Ppr031.ppr.hs:13:29: error: Not in scope: ‘captureAt’ + +Ppr031.ppr.hs:13:40: error: Not in scope: ‘captureLen’ + +Ppr031.ppr.hs:18:11: error: Not in scope: data constructor ‘POr’ + +Ppr031.ppr.hs:20:64: error: + Not in scope: ‘flips’ + Perhaps you meant ‘flip’ (imported from Prelude) diff --git a/testsuite/tests/printer/Ppr032.hs b/testsuite/tests/printer/Ppr032.hs new file mode 100644 index 0000000000..bd79f1e63b --- /dev/null +++ b/testsuite/tests/printer/Ppr032.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Sigs where + +-- TypeSig +f :: Num a => a -> a +f = undefined + +pattern Single :: () => (Show a) => a -> [a] +pattern Single x = [x] + +g :: (Show a) => [a] -> a +g (Single x) = x + +-- Fixities + +infixr 6 +++ +infixr 7 ***,/// + +(+++) :: Int -> Int -> Int +a +++ b = a + 2*b + +(***) :: Int -> Int -> Int +a *** b = a - 4*b + +(///) :: Int -> Int -> Int +a /// b = 2*a - 3*b + +-- Inline signatures + +{-# Inline g #-} +{-# INLINE [~34] f #-} + +-- Specialise signature + +-- Multiple sigs +x,y,z :: Int +x = 0 +y = 0 +z = 0 diff --git a/testsuite/tests/printer/Ppr032.stderr b/testsuite/tests/printer/Ppr032.stderr new file mode 100644 index 0000000000..cbca8d8f9c --- /dev/null +++ b/testsuite/tests/printer/Ppr032.stderr @@ -0,0 +1,18 @@ + +Ppr032.hs:10:21: + No instance for (Show a) + arising from the "provided" constraints claimed by + the signature of ‘Single’ + In other words, a successful match on the pattern + [x] + does not provide the constraint (Show a) + In the declaration for pattern synonym ‘Single’ + +Ppr032.ppr.hs:6:21: + No instance for (Show a) + arising from the "provided" constraints claimed by + the signature of ‘Single’ + In other words, a successful match on the pattern + [x] + does not provide the constraint (Show a) + In the declaration for pattern synonym ‘Single’ diff --git a/testsuite/tests/printer/Ppr033.hs b/testsuite/tests/printer/Ppr033.hs new file mode 100644 index 0000000000..1aa9060228 --- /dev/null +++ b/testsuite/tests/printer/Ppr033.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Language.Haskell.TH + +makeLenses '' PostscriptFont + +ty :: Q Type +ty = [t| Int |] + +f :: $ty +f = undefined + +g :: $(ty) +g = undefined + +thb = $(do { let x = mkName "x" + v = return (LamE [VarP x] $ VarE x) + ; [| $v . id |] }) + +foo2 :: A Bool +foo2 = $$(y) diff --git a/testsuite/tests/printer/Ppr033.stderr b/testsuite/tests/printer/Ppr033.stderr new file mode 100644 index 0000000000..4b3e8d55bf --- /dev/null +++ b/testsuite/tests/printer/Ppr033.stderr @@ -0,0 +1,8 @@ + +Ppr033.hs:5:12: + Not in scope: type constructor or class ‘PostscriptFont’ + In the Template Haskell quotation ''PostscriptFont + +Ppr033.ppr.hs:3:12: + Not in scope: type constructor or class ‘PostscriptFont’ + In the Template Haskell quotation ''PostscriptFont diff --git a/testsuite/tests/printer/Ppr034.hs b/testsuite/tests/printer/Ppr034.hs new file mode 100644 index 0000000000..c16e0bfbae --- /dev/null +++ b/testsuite/tests/printer/Ppr034.hs @@ -0,0 +1,423 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Algebra.Additive ( + -- * Class + C, + zero, + (+), (-), + negate, subtract, + + -- * Complex functions + sum, sum1, + sumNestedAssociative, + sumNestedCommutative, + + -- * Instance definition helpers + elementAdd, elementSub, elementNeg, + (<*>.+), (<*>.-), (<*>.-$), + + -- * Instances for atomic types + propAssociative, + propCommutative, + propIdentity, + propInverse, + ) where + +import qualified Algebra.Laws as Laws + +import Data.Int (Int, Int8, Int16, Int32, Int64, ) +import Data.Word (Word, Word8, Word16, Word32, Word64, ) + +import qualified NumericPrelude.Elementwise as Elem +import Control.Applicative (Applicative(pure, (<*>)), ) +import Data.Tuple.HT (fst3, snd3, thd3, ) +import qualified Data.List.Match as Match + +import qualified Data.Complex as Complex98 +import qualified Data.Ratio as Ratio98 +import qualified Prelude as P +import Prelude (Integer, Float, Double, fromInteger, ) +import NumericPrelude.Base + + +infixl 6 +, - + +{- | +Additive a encapsulates the notion of a commutative group, specified +by the following laws: + +@ + a + b === b + a + (a + b) + c === a + (b + c) + zero + a === a + a + negate a === 0 +@ + +Typical examples include integers, dollars, and vectors. + +Minimal definition: '+', 'zero', and ('negate' or '(-)') +-} + +class C a where + {-# MINIMAL zero, (+), ((-) | negate) #-} + -- | zero element of the vector space + zero :: a + -- | add and subtract elements + (+), (-) :: a -> a -> a + -- | inverse with respect to '+' + negate :: a -> a + + {-# INLINE negate #-} + negate a = zero - a + {-# INLINE (-) #-} + a - b = a + negate b + +{- | +'subtract' is @(-)@ with swapped operand order. +This is the operand order which will be needed in most cases +of partial application. +-} +subtract :: C a => a -> a -> a +subtract = flip (-) + + + + +{- | +Sum up all elements of a list. +An empty list yields zero. + +This function is inappropriate for number types like Peano. +Maybe we should make 'sum' a method of Additive. +This would also make 'lengthLeft' and 'lengthRight' superfluous. +-} +sum :: (C a) => [a] -> a +sum = foldl (+) zero + +{- | +Sum up all elements of a non-empty list. +This avoids including a zero which is useful for types +where no universal zero is available. +-} +sum1 :: (C a) => [a] -> a +sum1 = foldl1 (+) + + +{- | +Sum the operands in an order, +such that the dependencies are minimized. +Does this have a measurably effect on speed? + +Requires associativity. +-} +sumNestedAssociative :: (C a) => [a] -> a +sumNestedAssociative [] = zero +sumNestedAssociative [x] = x +sumNestedAssociative xs = sumNestedAssociative (sum2 xs) + +{- +Make sure that the last entries in the list +are equally often part of an addition. +Maybe this can reduce rounding errors. +The list that sum2 computes is a breadth-first-flattened binary tree. + +Requires associativity and commutativity. +-} +sumNestedCommutative :: (C a) => [a] -> a +sumNestedCommutative [] = zero +sumNestedCommutative xs@(_:rs) = + let ys = xs ++ Match.take rs (sum2 ys) + in last ys + +_sumNestedCommutative :: (C a) => [a] -> a +_sumNestedCommutative [] = zero +_sumNestedCommutative xs@(_:rs) = + let ys = xs ++ take (length rs) (sum2 ys) + in last ys + +{- +[a,b,c, a+b,c+(a+b)] +[a,b,c,d, a+b,c+d,(a+b)+(c+d)] +[a,b,c,d,e, a+b,c+d,e+(a+b),(c+d)+e+(a+b)] +[a,b,c,d,e,f, a+b,c+d,e+f,(a+b)+(c+d),(e+f)+((a+b)+(c+d))] +-} + +sum2 :: (C a) => [a] -> [a] +sum2 (x:y:rest) = (x+y) : sum2 rest +sum2 xs = xs + + + +{- | +Instead of baking the add operation into the element function, +we could use higher rank types +and pass a generic @uncurry (+)@ to the run function. +We do not do so in order to stay Haskell 98 +at least for parts of NumericPrelude. +-} +{-# INLINE elementAdd #-} +elementAdd :: + (C x) => + (v -> x) -> Elem.T (v,v) x +elementAdd f = + Elem.element (\(x,y) -> f x + f y) + +{-# INLINE elementSub #-} +elementSub :: + (C x) => + (v -> x) -> Elem.T (v,v) x +elementSub f = + Elem.element (\(x,y) -> f x - f y) + +{-# INLINE elementNeg #-} +elementNeg :: + (C x) => + (v -> x) -> Elem.T v x +elementNeg f = + Elem.element (negate . f) + + +-- like <*> +infixl 4 <*>.+, <*>.-, <*>.-$ + +{- | +> addPair :: (Additive.C a, Additive.C b) => (a,b) -> (a,b) -> (a,b) +> addPair = Elem.run2 $ Elem.with (,) <*>.+ fst <*>.+ snd +-} +{-# INLINE (<*>.+) #-} +(<*>.+) :: + (C x) => + Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a +(<*>.+) f acc = + f <*> elementAdd acc + +{-# INLINE (<*>.-) #-} +(<*>.-) :: + (C x) => + Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a +(<*>.-) f acc = + f <*> elementSub acc + +{-# INLINE (<*>.-$) #-} +(<*>.-$) :: + (C x) => + Elem.T v (x -> a) -> (v -> x) -> Elem.T v a +(<*>.-$) f acc = + f <*> elementNeg acc + + +-- * Instances for atomic types + +instance C Integer where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Float where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Double where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + + +instance C Int where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Int8 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Int16 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Int32 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Int64 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + + +instance C Word where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Word8 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Word16 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Word32 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + +instance C Word64 where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + negate = P.negate + (+) = (P.+) + (-) = (P.-) + + + + +-- * Instances for composed types + +instance (C v0, C v1) => C (v0, v1) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = (,) zero zero + (+) = Elem.run2 $ pure (,) <*>.+ fst <*>.+ snd + (-) = Elem.run2 $ pure (,) <*>.- fst <*>.- snd + negate = Elem.run $ pure (,) <*>.-$ fst <*>.-$ snd + +instance (C v0, C v1, C v2) => C (v0, v1, v2) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = (,,) zero zero zero + (+) = Elem.run2 $ pure (,,) <*>.+ fst3 <*>.+ snd3 <*>.+ thd3 + (-) = Elem.run2 $ pure (,,) <*>.- fst3 <*>.- snd3 <*>.- thd3 + negate = Elem.run $ pure (,,) <*>.-$ fst3 <*>.-$ snd3 <*>.-$ thd3 + + +instance (C v) => C [v] where + zero = [] + negate = map negate + (+) (x:xs) (y:ys) = (+) x y : (+) xs ys + (+) xs [] = xs + (+) [] ys = ys + (-) (x:xs) (y:ys) = (-) x y : (-) xs ys + (-) xs [] = xs + (-) [] ys = negate ys + + +instance (C v) => C (b -> v) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero _ = zero + (+) f g x = (+) (f x) (g x) + (-) f g x = (-) (f x) (g x) + negate f x = negate (f x) + +-- * Properties + +propAssociative :: (Eq a, C a) => a -> a -> a -> Bool +propCommutative :: (Eq a, C a) => a -> a -> Bool +propIdentity :: (Eq a, C a) => a -> Bool +propInverse :: (Eq a, C a) => a -> Bool + +propCommutative = Laws.commutative (+) +propAssociative = Laws.associative (+) +propIdentity = Laws.identity (+) zero +propInverse = Laws.inverse (+) negate zero + + + +-- legacy + +instance (P.Integral a) => C (Ratio98.Ratio a) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + (+) = (P.+) + (-) = (P.-) + negate = P.negate + +instance (P.RealFloat a) => C (Complex98.Complex a) where + {-# INLINE zero #-} + {-# INLINE negate #-} + {-# INLINE (+) #-} + {-# INLINE (-) #-} + zero = P.fromInteger 0 + (+) = (P.+) + (-) = (P.-) + negate = P.negate diff --git a/testsuite/tests/printer/Ppr034.stderr b/testsuite/tests/printer/Ppr034.stderr new file mode 100644 index 0000000000..a57a2860aa --- /dev/null +++ b/testsuite/tests/printer/Ppr034.stderr @@ -0,0 +1,42 @@ + +Ppr034.hs:25:1: + Could not find module ‘Algebra.Laws’ + Use -v to see a list of the files searched for. + +Ppr034.hs:30:1: + Could not find module ‘NumericPrelude.Elementwise’ + Use -v to see a list of the files searched for. + +Ppr034.hs:32:1: + Could not find module ‘Data.Tuple.HT’ + Perhaps you meant Data.Tuple (from base-4.9.0.0) + Use -v to see a list of the files searched for. + +Ppr034.hs:33:1: + Could not find module ‘Data.List.Match’ + Use -v to see a list of the files searched for. + +Ppr034.hs:39:1: + Could not find module ‘NumericPrelude.Base’ + Use -v to see a list of the files searched for. + +Ppr034.ppr.hs:8:1: + Could not find module ‘Algebra.Laws’ + Use -v to see a list of the files searched for. + +Ppr034.ppr.hs:11:1: + Could not find module ‘NumericPrelude.Elementwise’ + Use -v to see a list of the files searched for. + +Ppr034.ppr.hs:13:1: + Could not find module ‘Data.Tuple.HT’ + Perhaps you meant Data.Tuple (from base-4.9.0.0) + Use -v to see a list of the files searched for. + +Ppr034.ppr.hs:14:1: + Could not find module ‘Data.List.Match’ + Use -v to see a list of the files searched for. + +Ppr034.ppr.hs:19:1: + Could not find module ‘NumericPrelude.Base’ + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/printer/Ppr035.hs b/testsuite/tests/printer/Ppr035.hs new file mode 100644 index 0000000000..fa75e2e1e5 --- /dev/null +++ b/testsuite/tests/printer/Ppr035.hs @@ -0,0 +1,14 @@ +module Warning +{-# WARNINg ["This is a module warning", + "multi-line"] #-} + where + +{-# Warning foo , bar + ["This is a multi-line", + "deprecation message", + "for foo"] #-} +foo :: Int +foo = 4 + +bar :: Char +bar = 'c' diff --git a/testsuite/tests/printer/Ppr036.hs b/testsuite/tests/printer/Ppr036.hs new file mode 100644 index 0000000000..99bdeaf917 --- /dev/null +++ b/testsuite/tests/printer/Ppr036.hs @@ -0,0 +1,15 @@ +module Deprecation +{-# Deprecated ["This is a module \"deprecation\"", + "multi-line", + "with unicode: Frère" ] #-} + ( foo ) + where + +{-# DEPRECATEd foo + ["This is a multi-line", + "deprecation message", + "for foo"] #-} +foo :: Int +foo = 4 + +{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} diff --git a/testsuite/tests/printer/Ppr036.stderr b/testsuite/tests/printer/Ppr036.stderr new file mode 100644 index 0000000000..3fd1c71544 --- /dev/null +++ b/testsuite/tests/printer/Ppr036.stderr @@ -0,0 +1,6 @@ + +Ppr036.hs:15:16: + The deprecation for ‘withBool’ lacks an accompanying binding + +Ppr036.ppr.hs:13:16: + The deprecation for ‘withBool’ lacks an accompanying binding diff --git a/testsuite/tests/printer/Ppr037.hs b/testsuite/tests/printer/Ppr037.hs new file mode 100644 index 0000000000..a812643fed --- /dev/null +++ b/testsuite/tests/printer/Ppr037.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, + RankNTypes, FlexibleContexts, TemplateHaskell, + UndecidableInstances, GADTs, DefaultSignatures #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Singletons.Prelude.Eq +-- Copyright : (C) 2013 Richard Eisenberg +-- License : BSD-style (see LICENSE) +-- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) +-- Stability : experimental +-- Portability : non-portable +-- +-- Defines the SEq singleton version of the Eq type class. +-- +----------------------------------------------------------------------------- + +module Data.Singletons.Prelude.Eq ( + PEq(..), SEq(..), + (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$) + ) where + +import Data.Singletons.Prelude.Bool +import Data.Singletons +import Data.Singletons.Single +import Data.Singletons.Prelude.Instances +import Data.Singletons.Util +import Data.Singletons.Promote +import Data.Type.Equality + +-- NB: These must be defined by hand because of the custom handling of the +-- default for (:==) to use Data.Type.Equality.== + +-- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)', +-- then it defaults to a use of '(==)', from @Data.Type.Equality@. +class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where + type (:==) (x :: a) (y :: a) :: Bool + type (:/=) (x :: a) (y :: a) :: Bool + + type (x :: a) :== (y :: a) = x == y + type (x :: a) :/= (y :: a) = Not (x :== y) + +infix 4 :== +infix 4 :/= + +$(genDefunSymbols [''(:==), ''(:/=)]) + +-- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is +-- required that instances define a body for '(%:==)'. You may also supply a +-- body for '(%:/=)'. +class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where + -- | Boolean equality on singletons + (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) + infix 4 %:== + + -- | Boolean disequality on singletons + (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) + default (%:/=) :: forall (a :: k) (b :: k). + ((a :/= b) ~ Not (a :== b)) + => Sing a -> Sing b -> Sing (a :/= b) + a %:/= b = sNot (a %:== b) + infix 4 %:/= + +$(singEqInstances basicTypes) diff --git a/testsuite/tests/printer/Ppr037.stderr b/testsuite/tests/printer/Ppr037.stderr new file mode 100644 index 0000000000..da004e313e --- /dev/null +++ b/testsuite/tests/printer/Ppr037.stderr @@ -0,0 +1,48 @@ + +Ppr037.hs:23:1: error: + Could not find module ‘Data.Singletons.Prelude.Bool’ + Use -v to see a list of the files searched for. + +Ppr037.hs:24:1: error: + Could not find module ‘Data.Singletons’ + Use -v to see a list of the files searched for. + +Ppr037.hs:25:1: error: + Could not find module ‘Data.Singletons.Single’ + Use -v to see a list of the files searched for. + +Ppr037.hs:26:1: error: + Could not find module ‘Data.Singletons.Prelude.Instances’ + Use -v to see a list of the files searched for. + +Ppr037.hs:27:1: error: + Could not find module ‘Data.Singletons.Util’ + Use -v to see a list of the files searched for. + +Ppr037.hs:28:1: error: + Could not find module ‘Data.Singletons.Promote’ + Use -v to see a list of the files searched for. + +Ppr037.ppr.hs:8:1: error: + Could not find module ‘Data.Singletons.Prelude.Bool’ + Use -v to see a list of the files searched for. + +Ppr037.ppr.hs:9:1: error: + Could not find module ‘Data.Singletons’ + Use -v to see a list of the files searched for. + +Ppr037.ppr.hs:10:1: error: + Could not find module ‘Data.Singletons.Single’ + Use -v to see a list of the files searched for. + +Ppr037.ppr.hs:11:1: error: + Could not find module ‘Data.Singletons.Prelude.Instances’ + Use -v to see a list of the files searched for. + +Ppr037.ppr.hs:12:1: error: + Could not find module ‘Data.Singletons.Util’ + Use -v to see a list of the files searched for. + +Ppr037.ppr.hs:13:1: error: + Could not find module ‘Data.Singletons.Promote’ + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/printer/Ppr038.hs b/testsuite/tests/printer/Ppr038.hs new file mode 100644 index 0000000000..43fafaf01c --- /dev/null +++ b/testsuite/tests/printer/Ppr038.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE MagicHash #-} +module LiteralsTest2 where + +x,y :: Int +x = 0003 +y = 0x04 + +s :: String +s = "\x20" + +c :: Char +c = '\x20' + +d :: Double +d = 0.00 + +blah = x + where + charH = '\x41'# + intH = 0004# + wordH = 005## + floatH = 3.20# + doubleH = 04.16## + -- int64H = 00456L# + -- word64H = 00456L## + x = 1 diff --git a/testsuite/tests/printer/Ppr039.hs b/testsuite/tests/printer/Ppr039.hs new file mode 100644 index 0000000000..3650283986 --- /dev/null +++ b/testsuite/tests/printer/Ppr039.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiWayIf #-} +module MultiWayIf where + +foo = if | test1 -> e1 + | test2 witharg -> e2 + | otherwise -> def + +bar = if { | test1 -> if { | test2 -> e1 + | test3 -> e2 } + | test4 -> e3 + } + +-- taken from GHC's test suite +x = 10 +x1 = if | x < 10 -> "< 10" | otherwise -> "" +x2 = if | x < 10 -> "< 10" + | otherwise -> "" +x3 = if | x < 10 -> "< 10" + | otherwise -> "" +x4 = if | True -> "yes" +x5 = if | True -> if | False -> 1 | True -> 2 + +x6 = if | x < 10 -> if | True -> "yes" + | False -> "no" + | otherwise -> "maybe" + +x7 = (if | True -> 0) + +-- issue #98 +spam = if | () <- () -> () diff --git a/testsuite/tests/printer/Ppr039.stderr b/testsuite/tests/printer/Ppr039.stderr new file mode 100644 index 0000000000..004d5fe2a2 --- /dev/null +++ b/testsuite/tests/printer/Ppr039.stderr @@ -0,0 +1,73 @@ + +Ppr039.hs:4:12: error: Variable not in scope: test1 :: Bool + +Ppr039.hs:4:21: error: + • Variable not in scope: e1 + • Perhaps you meant ‘x1’ (line 15) + +Ppr039.hs:5:12: error: Variable not in scope: test2 :: t0 -> Bool + +Ppr039.hs:5:18: error: Variable not in scope: witharg + +Ppr039.hs:5:29: error: + • Variable not in scope: e2 + • Perhaps you meant ‘x2’ (line 16) + +Ppr039.hs:6:25: error: Variable not in scope: def + +Ppr039.hs:8:14: error: Variable not in scope: test1 :: Bool + +Ppr039.hs:8:30: error: Variable not in scope: test2 :: Bool + +Ppr039.hs:8:39: error: + • Variable not in scope: e1 + • Perhaps you meant ‘x1’ (line 15) + +Ppr039.hs:9:30: error: Variable not in scope: test3 :: Bool + +Ppr039.hs:9:39: error: + • Variable not in scope: e2 + • Perhaps you meant ‘x2’ (line 16) + +Ppr039.hs:10:14: error: Variable not in scope: test4 :: Bool + +Ppr039.hs:10:23: error: + • Variable not in scope: e3 + • Perhaps you meant ‘x3’ (line 18) + +Ppr039.ppr.hs:4:10: error: Variable not in scope: test1 :: Bool + +Ppr039.ppr.hs:4:19: error: + • Variable not in scope: e1 + • Perhaps you meant ‘x1’ (line 13) + +Ppr039.ppr.hs:5:10: error: + Variable not in scope: test2 :: t0 -> Bool + +Ppr039.ppr.hs:5:16: error: Variable not in scope: witharg + +Ppr039.ppr.hs:5:27: error: + • Variable not in scope: e2 + • Perhaps you meant ‘x2’ (line 16) + +Ppr039.ppr.hs:6:23: error: Variable not in scope: def + +Ppr039.ppr.hs:8:10: error: Variable not in scope: test1 :: Bool + +Ppr039.ppr.hs:9:20: error: Variable not in scope: test2 :: Bool + +Ppr039.ppr.hs:9:29: error: + • Variable not in scope: e1 + • Perhaps you meant ‘x1’ (line 13) + +Ppr039.ppr.hs:10:20: error: Variable not in scope: test3 :: Bool + +Ppr039.ppr.hs:10:29: error: + • Variable not in scope: e2 + • Perhaps you meant ‘x2’ (line 16) + +Ppr039.ppr.hs:11:10: error: Variable not in scope: test4 :: Bool + +Ppr039.ppr.hs:11:19: error: + • Variable not in scope: e3 + • Perhaps you meant ‘x3’ (line 19) diff --git a/testsuite/tests/printer/Ppr040.hs b/testsuite/tests/printer/Ppr040.hs new file mode 100644 index 0000000000..a9885a9d53 --- /dev/null +++ b/testsuite/tests/printer/Ppr040.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, + PolyKinds, TypeFamilies, GADTs, TypeInType #-} + +module RAE_T32a where + +import Data.Kind + +data family Sing (k :: *) :: k -> * + +data TyArr' (a :: *) (b :: *) :: * +type TyArr (a :: *) (b :: *) = TyArr' a b -> * +type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 +data TyPi' (a :: *) (b :: TyArr a *) :: * +type TyPi (a :: *) (b :: TyArr a *) = TyPi' a b -> * +type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b +$(return []) + +data MkStar (p :: *) (x :: TyArr' p *) +type instance MkStar p @@ x = * +$(return []) + +type instance (MkStar p) @@ x = * +$(return []) + +foo :: forall p x . MkStar p @@ x +foo = undefined + +data Sigma (p :: *) (r :: TyPi p (MkStar p)) :: * where + Sigma :: + forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). + Sing * p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b + -> Sigma p r +$(return []) + +data instance Sing Sigma (Sigma p r) x where + SSigma :: + forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) + (sp :: Sing * p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) + (sb :: Sing (r @@@ a) b). + Sing (Sing (r @@@ a) b) sb -> + Sing (Sigma p r) ('Sigma sp sr sa sb) + +-- I (RAE) believe this last definition is ill-typed. diff --git a/testsuite/tests/printer/Ppr040.stderr b/testsuite/tests/printer/Ppr040.stderr new file mode 100644 index 0000000000..5083b4cb7e --- /dev/null +++ b/testsuite/tests/printer/Ppr040.stderr @@ -0,0 +1,38 @@ + +Ppr040.hs:35:1: error: + • Too many parameters to Sing: + x is unexpected; + expected only two parameters + • In the data instance declaration for ‘Sing’ + +Ppr040.hs:35:20: error: + • Expecting two more arguments to ‘Sigma’ + Expected a type, but + ‘Sigma’ has kind + ‘forall p -> TyPi p (MkStar p) -> *’ + • In the first argument of ‘Sing’, namely ‘Sigma’ + In the data instance declaration for ‘Sing’ + +Ppr040.hs:35:27: error: + • Expected kind ‘Sigma’, but ‘Sigma p r’ has kind ‘*’ + • In the second argument of ‘Sing’, namely ‘(Sigma p r)’ + In the data instance declaration for ‘Sing’ + +Ppr040.ppr.hs:30:1: error: + • Too many parameters to Sing: + x is unexpected; + expected only two parameters + • In the data instance declaration for ‘Sing’ + +Ppr040.ppr.hs:30:20: error: + • Expecting two more arguments to ‘Sigma’ + Expected a type, but + ‘Sigma’ has kind + ‘forall p -> TyPi p (MkStar p) -> *’ + • In the first argument of ‘Sing’, namely ‘Sigma’ + In the data instance declaration for ‘Sing’ + +Ppr040.ppr.hs:30:27: error: + • Expected kind ‘Sigma’, but ‘Sigma p r’ has kind ‘*’ + • In the second argument of ‘Sing’, namely ‘(Sigma p r)’ + In the data instance declaration for ‘Sing’ diff --git a/testsuite/tests/printer/Ppr041.hs b/testsuite/tests/printer/Ppr041.hs new file mode 100644 index 0000000000..154a6097f7 --- /dev/null +++ b/testsuite/tests/printer/Ppr041.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE MagicHash #-} +module Main where + +import GHC.Prim + +data P = Positives Int# Float# Double# Char# Word# deriving Show +data N = Negatives Int# Float# Double# deriving Show + +main = do + print $ Positives 42# 4.23# 4.23## '4'# 4## + print $ Negatives -4# -4.0# -4.0## diff --git a/testsuite/tests/printer/Ppr042.hs b/testsuite/tests/printer/Ppr042.hs new file mode 100644 index 0000000000..1085dc1b48 --- /dev/null +++ b/testsuite/tests/printer/Ppr042.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MagicHash, GHCForeignImportPrim #-} + +module T10461 where +import GHC.Exts + +foreign import prim cheneycopy :: Any -> Word# + +foreign import prim "foo" foo :: Any -> Word# diff --git a/testsuite/tests/printer/Ppr042.stderr b/testsuite/tests/printer/Ppr042.stderr new file mode 100644 index 0000000000..8644650899 --- /dev/null +++ b/testsuite/tests/printer/Ppr042.stderr @@ -0,0 +1,28 @@ + +Ppr042.hs:6:1: error: + • Unacceptable result type in foreign declaration: + ‘Word#’ cannot be marshalled in a foreign call + To marshal unlifted types, use UnliftedFFITypes + • When checking declaration: + foreign import prim safe cheneycopy :: Any -> Word# + +Ppr042.hs:8:1: error: + • Unacceptable result type in foreign declaration: + ‘Word#’ cannot be marshalled in a foreign call + To marshal unlifted types, use UnliftedFFITypes + • When checking declaration: + foreign import prim safe "foo" foo :: Any -> Word# + +Ppr042.ppr.hs:4:1: error: + • Unacceptable result type in foreign declaration: + ‘Word#’ cannot be marshalled in a foreign call + To marshal unlifted types, use UnliftedFFITypes + • When checking declaration: + foreign import prim safe cheneycopy :: Any -> Word# + +Ppr042.ppr.hs:5:1: error: + • Unacceptable result type in foreign declaration: + ‘Word#’ cannot be marshalled in a foreign call + To marshal unlifted types, use UnliftedFFITypes + • When checking declaration: + foreign import prim safe "foo" foo :: Any -> Word# diff --git a/testsuite/tests/printer/Ppr043.hs b/testsuite/tests/printer/Ppr043.hs new file mode 100644 index 0000000000..3fe2519891 --- /dev/null +++ b/testsuite/tests/printer/Ppr043.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE MagicHash, TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +main :: IO () +main = do + putStrLn $([| 'a'# |] >>= stringE . show) + putStrLn $([| "abc"# |] >>= stringE . show) diff --git a/testsuite/tests/printer/Ppr044.hs b/testsuite/tests/printer/Ppr044.hs new file mode 100644 index 0000000000..5720aa7f64 --- /dev/null +++ b/testsuite/tests/printer/Ppr044.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE DeriveLift #-} +module T1830_2 where + +import Language.Haskell.TH.Syntax (Lift) + +data Nothing deriving Lift diff --git a/testsuite/tests/printer/Ppr045.hs b/testsuite/tests/printer/Ppr045.hs new file mode 100644 index 0000000000..73364982b4 --- /dev/null +++ b/testsuite/tests/printer/Ppr045.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} + +module T3927b where + +import Data.Proxy +import GHC.Exts + +data Message + +data SocketType = Dealer | Push | Pull + +data SocketOperation = Read | Write + +type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) + :: Constraint where + Restrict a (a ': as) = () + Restrict x (a ': as) = Restrict x as + Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!") + +type family Implements (t :: SocketType) :: [SocketOperation] where + Implements Dealer = ['Read, Write] + Implements Push = '[Write] + Implements Pull = '[ 'Read] + +data SockOp :: SocketType -> SocketOperation -> * where + SRead :: SockOp sock 'Read + SWrite :: SockOp sock Write + +data Socket :: SocketType -> * where + Socket :: proxy sock + -> (forall op . Restrict op (Implements sock) + => SockOp sock op -> Operation op) + -> Socket sock + +type family Operation (op :: SocketOperation) :: * where + Operation 'Read = IO Message + Operation Write = Message -> IO () + +class Restrict 'Read (Implements t) => Readable t where + readSocket :: Socket t -> Operation 'Read + readSocket (Socket _ f) = f (SRead :: SockOp t 'Read) + +instance Readable Dealer + +type family Writable (t :: SocketType) :: Constraint where + Writable Dealer = () + Writable Push = () + +dealer :: Socket Dealer +dealer = Socket (Proxy :: Proxy Dealer) f + where + f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op + f SRead = undefined + f SWrite = undefined + +push :: Socket Push +push = Socket (Proxy :: Proxy Push) f + where + f :: Restrict op (Implements Push) => SockOp Push op -> Operation op + f SWrite = undefined + +pull :: Socket Pull +pull = Socket (Proxy :: Proxy Pull) f + where + f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op + f SRead = undefined + +foo :: IO Message +foo = readSocket dealer diff --git a/testsuite/tests/printer/Ppr046.hs b/testsuite/tests/printer/Ppr046.hs new file mode 100644 index 0000000000..c2cb596263 --- /dev/null +++ b/testsuite/tests/printer/Ppr046.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE MagicHash, UnliftedFFITypes #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Test10313 where + +import "b\x61se" Data.List + +{-# WARNING Logic + , solverCheckAndGetModel + "New Z3 API support is still incomplete and fragile: \ + \you may experience segmentation faults!" + #-} + +{-# Deprecated Logic + , solverCheckAndGetModel + "Deprecation: \ + \you may experience segmentation faults!" + #-} + +data {-# ctype "foo\x63" "b\x61r" #-} Logic = Logic + +-- Should warn +foo1 x = x +{-# RULEs "foo1\x67" [ 1] forall x. foo1 x = x #-} + +foreign import prim unsafe "a\x62" a :: IO Int + +{-# INLINe strictStream #-} +strictStream (Bitstream l v) + = {-# CORe "Strict Bitstream stre\x61m" #-} + S.concatMap stream (GV.stream v) + `S.sized` + Exact l + +b = {-# SCc "foo\x64" #-} 006 diff --git a/testsuite/tests/printer/Ppr046.stderr b/testsuite/tests/printer/Ppr046.stderr new file mode 100644 index 0000000000..ebe2d0620e --- /dev/null +++ b/testsuite/tests/printer/Ppr046.stderr @@ -0,0 +1,61 @@ + +Ppr046.hs:9:13: error: + The deprecation for ‘solverCheckAndGetModel’ + lacks an accompanying binding + +Ppr046.hs:15:16: error: + Multiple warning declarations for ‘Logic’ + also at Ppr046.hs:9:13-17 + +Ppr046.hs:15:16: error: + The deprecation for ‘solverCheckAndGetModel’ + lacks an accompanying binding + +Ppr046.hs:16:13: error: + Multiple warning declarations for ‘solverCheckAndGetModel’ + also at Ppr046.hs:10:13-34 + +Ppr046.hs:30:15: error: Not in scope: data constructor ‘Bitstream’ + +Ppr046.hs:32:7: error: + Not in scope: ‘S.concatMap’ + No module named ‘S’ is imported. + +Ppr046.hs:32:27: error: + Not in scope: ‘GV.stream’ + No module named ‘GV’ is imported. + +Ppr046.hs:33:7: error: + Not in scope: ‘S.sized’ + No module named ‘S’ is imported. + +Ppr046.ppr.hs:6:13: error: + The deprecation for ‘solverCheckAndGetModel’ + lacks an accompanying binding + +Ppr046.ppr.hs:8:16: error: + Multiple warning declarations for ‘Logic’ + also at Ppr046.ppr.hs:6:13-17 + +Ppr046.ppr.hs:8:16: error: + The deprecation for ‘solverCheckAndGetModel’ + lacks an accompanying binding + +Ppr046.ppr.hs:8:23: error: + Multiple warning declarations for ‘solverCheckAndGetModel’ + also at Ppr046.ppr.hs:6:20-41 + +Ppr046.ppr.hs:15:15: error: + Not in scope: data constructor ‘Bitstream’ + +Ppr046.ppr.hs:17:5: error: + Not in scope: ‘S.concatMap’ + No module named ‘S’ is imported. + +Ppr046.ppr.hs:17:25: error: + Not in scope: ‘GV.stream’ + No module named ‘GV’ is imported. + +Ppr046.ppr.hs:17:38: error: + Not in scope: ‘S.sized’ + No module named ‘S’ is imported. diff --git a/testsuite/tests/printer/Ppr047.hs b/testsuite/tests/printer/Ppr047.hs new file mode 100644 index 0000000000..3ef54c4b38 --- /dev/null +++ b/testsuite/tests/printer/Ppr047.hs @@ -0,0 +1,4 @@ +module ExprPragmas where + +-- Should it be possible to ppr the following annotation? +c = {-# GENERATED "foobar" 1 : 2 - 3 : 4 #-} 0.00 diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T new file mode 100644 index 0000000000..c39656e892 --- /dev/null +++ b/testsuite/tests/printer/all.T @@ -0,0 +1,47 @@ +test('Ppr001', normal, run_command, ['$MAKE -s --no-print-directory ppr001']) +test('Ppr002', normal, run_command, ['$MAKE -s --no-print-directory ppr002']) +test('Ppr003', normal, run_command, ['$MAKE -s --no-print-directory ppr003']) +test('Ppr004', normal, run_command, ['$MAKE -s --no-print-directory ppr004']) +test('Ppr005', normal, run_command, ['$MAKE -s --no-print-directory ppr005']) +test('Ppr006', normal, run_command, ['$MAKE -s --no-print-directory ppr006']) +test('Ppr007', normal, run_command, ['$MAKE -s --no-print-directory ppr007']) +test('Ppr008', normal, run_command, ['$MAKE -s --no-print-directory ppr008']) +test('Ppr009', normal, run_command, ['$MAKE -s --no-print-directory ppr009']) +test('Ppr010', normal, run_command, ['$MAKE -s --no-print-directory ppr010']) +test('Ppr011', normal, run_command, ['$MAKE -s --no-print-directory ppr011']) +test('Ppr012', normal, run_command, ['$MAKE -s --no-print-directory ppr012']) +test('Ppr013', normal, run_command, ['$MAKE -s --no-print-directory ppr013']) +test('Ppr014', normal, run_command, ['$MAKE -s --no-print-directory ppr014']) +test('Ppr015', normal, run_command, ['$MAKE -s --no-print-directory ppr015']) +test('Ppr016', normal, run_command, ['$MAKE -s --no-print-directory ppr016']) +test('Ppr017', normal, run_command, ['$MAKE -s --no-print-directory ppr017']) +test('Ppr018', normal, run_command, ['$MAKE -s --no-print-directory ppr018']) +test('Ppr019', normal, run_command, ['$MAKE -s --no-print-directory ppr019']) +test('Ppr020', normal, run_command, ['$MAKE -s --no-print-directory ppr020']) +test('Ppr021', normal, run_command, ['$MAKE -s --no-print-directory ppr021']) +test('Ppr022', normal, run_command, ['$MAKE -s --no-print-directory ppr022']) +test('Ppr023', normal, run_command, ['$MAKE -s --no-print-directory ppr023']) +test('Ppr024', normal, run_command, ['$MAKE -s --no-print-directory ppr024']) +test('Ppr025', normal, run_command, ['$MAKE -s --no-print-directory ppr025']) +test('Ppr026', normal, run_command, ['$MAKE -s --no-print-directory ppr026']) +test('Ppr027', normal, run_command, ['$MAKE -s --no-print-directory ppr027']) +test('Ppr028', normal, run_command, ['$MAKE -s --no-print-directory ppr028']) +test('Ppr029', normal, run_command, ['$MAKE -s --no-print-directory ppr029']) +test('Ppr030', normal, run_command, ['$MAKE -s --no-print-directory ppr030']) +test('Ppr031', normal, run_command, ['$MAKE -s --no-print-directory ppr031']) +test('Ppr032', normal, run_command, ['$MAKE -s --no-print-directory ppr032']) +test('Ppr033', normal, run_command, ['$MAKE -s --no-print-directory ppr033']) +test('Ppr034', normal, run_command, ['$MAKE -s --no-print-directory ppr034']) +test('Ppr035', normal, run_command, ['$MAKE -s --no-print-directory ppr035']) +test('Ppr036', normal, run_command, ['$MAKE -s --no-print-directory ppr036']) +test('Ppr037', normal, run_command, ['$MAKE -s --no-print-directory ppr037']) +test('Ppr038', normal, run_command, ['$MAKE -s --no-print-directory ppr038']) +test('Ppr039', normal, run_command, ['$MAKE -s --no-print-directory ppr039']) +test('Ppr040', normal, run_command, ['$MAKE -s --no-print-directory ppr040']) +test('Ppr041', normal, run_command, ['$MAKE -s --no-print-directory ppr041']) +test('Ppr042', normal, run_command, ['$MAKE -s --no-print-directory ppr042']) +test('Ppr043', normal, run_command, ['$MAKE -s --no-print-directory ppr043']) +test('Ppr044', normal, run_command, ['$MAKE -s --no-print-directory ppr044']) +test('Ppr045', normal, run_command, ['$MAKE -s --no-print-directory ppr045']) +test('Ppr046', normal, run_command, ['$MAKE -s --no-print-directory ppr046']) +test('Ppr047', expect_fail, run_command, ['$MAKE -s --no-print-directory ppr047']) diff --git a/testsuite/tests/quasiquotation/T7918.hs b/testsuite/tests/quasiquotation/T7918.hs index 2d4577c963..0f32699415 100644 --- a/testsuite/tests/quasiquotation/T7918.hs +++ b/testsuite/tests/quasiquotation/T7918.hs @@ -35,7 +35,7 @@ traverse a = return () showTyVar :: Maybe (HsType Name) -> Traverse () - showTyVar (Just (HsTyVar (L _ v))) = + showTyVar (Just (HsTyVar _ (L _ v))) = modify $ \(loc, ids) -> (loc, (v, loc) : ids) showTyVar _ = return () diff --git a/testsuite/tests/rebindable/rebindable6.stderr b/testsuite/tests/rebindable/rebindable6.stderr index 712724d28f..342ee53de5 100644 --- a/testsuite/tests/rebindable/rebindable6.stderr +++ b/testsuite/tests/rebindable/rebindable6.stderr @@ -15,14 +15,14 @@ rebindable6.hs:110:17: error: -- Defined at rebindable6.hs:56:18 • In a stmt of a 'do' block: f In the expression: - do { f; - Just (b :: b) <- g; - return b } + do f + Just (b :: b) <- g + return b In an equation for ‘test_do’: test_do f g - = do { f; - Just (b :: b) <- g; - return b } + = do f + Just (b :: b) <- g + return b rebindable6.hs:111:17: error: • Ambiguous type variables ‘p0’, ‘t0’ arising from a do statement @@ -39,14 +39,14 @@ rebindable6.hs:111:17: error: -- Defined at rebindable6.hs:51:18 • In a stmt of a 'do' block: Just (b :: b) <- g In the expression: - do { f; - Just (b :: b) <- g; - return b } + do f + Just (b :: b) <- g + return b In an equation for ‘test_do’: test_do f g - = do { f; - Just (b :: b) <- g; - return b } + = do f + Just (b :: b) <- g + return b rebindable6.hs:112:17: error: • Ambiguous type variable ‘p0’ arising from a use of ‘return’ @@ -62,11 +62,11 @@ rebindable6.hs:112:17: error: instance HasReturn (a -> IO a) -- Defined at rebindable6.hs:46:18 • In a stmt of a 'do' block: return b In the expression: - do { f; - Just (b :: b) <- g; - return b } + do f + Just (b :: b) <- g + return b In an equation for ‘test_do’: test_do f g - = do { f; - Just (b :: b) <- g; - return b } + = do f + Just (b :: b) <- g + return b diff --git a/testsuite/tests/rename/should_fail/Misplaced.stderr b/testsuite/tests/rename/should_fail/Misplaced.stderr index 67d845d9a5..610281ca5c 100644 --- a/testsuite/tests/rename/should_fail/Misplaced.stderr +++ b/testsuite/tests/rename/should_fail/Misplaced.stderr @@ -1,4 +1,4 @@ Misplaced.hs:4:1: error: Misplaced SPECIALISE instance pragma: - {-# SPECIALIZE instance Eq (T Int) #-} + {-# SPECIALISE instance Eq (T Int) #-} diff --git a/testsuite/tests/rename/should_fail/rnfail026.stderr b/testsuite/tests/rename/should_fail/rnfail026.stderr index c44f655ccb..dc6ee9691a 100644 --- a/testsuite/tests/rename/should_fail/rnfail026.stderr +++ b/testsuite/tests/rename/should_fail/rnfail026.stderr @@ -3,7 +3,7 @@ rnfail026.hs:16:27: error: • Expecting one fewer arguments to ‘Set a’ Expected kind ‘* -> *’, but ‘Set a’ has kind ‘*’ • In the first argument of ‘Monad’, namely - ‘forall a. Eq a => Set a’ + ‘(forall a. Eq a => Set a)’ In the instance declaration for ‘Monad (forall a. Eq a => Set a)’ rnfail026.hs:19:10: error: diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index 5369daa5cd..28ef9ce128 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -62,7 +62,7 @@ T8958.$trModule AbsBinds [a] [] {Exports: [T8958.$fRepresentationala <= $dRepresentational wrap: <>] - Exported types: T8958.$fRepresentationala [InlPrag=[ALWAYS] CONLIKE] + Exported types: T8958.$fRepresentationala [InlPrag=CONLIKE] :: forall a. Representational a [LclIdX[DFunId], Unf=DFun: \ (@ a) -> T8958.C:Representational TYPE: a] @@ -71,7 +71,7 @@ AbsBinds [a] [] AbsBinds [a] [] {Exports: [T8958.$fNominala <= $dNominal wrap: <>] - Exported types: T8958.$fNominala [InlPrag=[ALWAYS] CONLIKE] + Exported types: T8958.$fNominala [InlPrag=CONLIKE] :: forall a. Nominal a [LclIdX[DFunId], Unf=DFun: \ (@ a) -> T8958.C:Nominal TYPE: a] Binds: $dNominal = T8958.C:Nominal @ a diff --git a/testsuite/tests/safeHaskell/ghci/p6.stderr b/testsuite/tests/safeHaskell/ghci/p6.stderr index 74beb053ca..2e68cd9a60 100644 --- a/testsuite/tests/safeHaskell/ghci/p6.stderr +++ b/testsuite/tests/safeHaskell/ghci/p6.stderr @@ -3,7 +3,7 @@ • Unacceptable result type in foreign declaration: Safe Haskell is on, all FFI imports must be in the IO monad • When checking declaration: - foreign import ccall safe "static sin" c_sin :: Double -> Double + foreign import ccall safe "sin" c_sin :: Double -> Double <interactive>:12:1: error: • Variable not in scope: c_sin :: Integer -> t diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr index 7d06e2f11c..ae5d658619 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang08.stderr @@ -3,5 +3,5 @@ SafeLang08.hs:9:1: Unacceptable result type in foreign declaration: Safe Haskell is on, all FFI imports must be in the IO monad When checking declaration: - foreign import ccall safe "static SafeLang08_A" c_sin + foreign import ccall safe "SafeLang08_A" c_sin :: CDouble -> CDouble diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr index d0c5c68d6a..557c4f4858 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang10.stderr @@ -15,6 +15,6 @@ SafeLang10.hs:8:13: In the expression: res [(1 :: Int)] In an equation for ‘r’: r = res [(1 :: Int)] In the expression: - do { let r = res ...; - putStrLn $ "Result: " ++ show r; - putStrLn $ "Result: " ++ show function } + do let r = res ... + putStrLn $ "Result: " ++ show r + putStrLn $ "Result: " ++ show function diff --git a/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr b/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr index c59f86670a..3585721654 100644 --- a/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr +++ b/testsuite/tests/safeHaskell/safeLanguage/SafeLang17.stderr @@ -15,6 +15,6 @@ SafeLang17.hs:8:13: In the expression: res [(1 :: Int)] In an equation for ‘r’: r = res [(1 :: Int)] In the expression: - do { let r = res ...; - putStrLn $ "Result: " ++ show r; - putStrLn $ "Result: " ++ show function } + do let r = res ... + putStrLn $ "Result: " ++ show r + putStrLn $ "Result: " ++ show function diff --git a/testsuite/tests/simplCore/should_compile/T7785.stderr b/testsuite/tests/simplCore/should_compile/T7785.stderr index c71a077b1d..c0e91b9169 100644 --- a/testsuite/tests/simplCore/should_compile/T7785.stderr +++ b/testsuite/tests/simplCore/should_compile/T7785.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core rules ==================== -"SPEC shared @ []" [ALWAYS] +"SPEC shared @ []" forall (irred :: Domain [] Int) ($dMyFunctor :: MyFunctor []). shared @ [] $dMyFunctor irred = bar_$sshared diff --git a/testsuite/tests/simplCore/should_compile/T8331.stderr b/testsuite/tests/simplCore/should_compile/T8331.stderr index 1b3c21eaea..322323be6c 100644 --- a/testsuite/tests/simplCore/should_compile/T8331.stderr +++ b/testsuite/tests/simplCore/should_compile/T8331.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core rules ==================== -"SPEC useAbstractMonad" [ALWAYS] +"SPEC useAbstractMonad" forall (@ s) ($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))). useAbstractMonad @ (ReaderT Int (ST s)) $dMonadAbstractIOST diff --git a/testsuite/tests/simplCore/should_compile/T8848a.stderr b/testsuite/tests/simplCore/should_compile/T8848a.stderr index f9f2597c6b..f6f8b4f247 100644 --- a/testsuite/tests/simplCore/should_compile/T8848a.stderr +++ b/testsuite/tests/simplCore/should_compile/T8848a.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core rules ==================== -"SPEC f" [ALWAYS] +"SPEC f" forall (@ b) ($dOrd :: Ord [Int]). f @ [Int] @ b $dOrd = f_$sf @ b diff --git a/testsuite/tests/simplCore/should_compile/simpl017.stderr b/testsuite/tests/simplCore/should_compile/simpl017.stderr index bb74213dfe..5a82506164 100644 --- a/testsuite/tests/simplCore/should_compile/simpl017.stderr +++ b/testsuite/tests/simplCore/should_compile/simpl017.stderr @@ -5,17 +5,17 @@ simpl017.hs:50:15: error: Expected type: E m (forall v. [E m i] -> E' v m a) Actual type: E' RValue m ([E m i] -> E' v0 m a) • In the expression: - E (do { let ix :: [E m i] -> m i - ix [i] = runE i - {-# INLINE f #-} - ....; - return f }) + E (do let ix :: [E m i] -> m i + ix [i] = runE i + {-# INLINE f #-} + .... + return f) In an equation for ‘liftArray’: liftArray a - = E (do { let ix :: [E m i] -> m i - ix [i] = runE i - ....; - return f }) + = E (do let ix :: [E m i] -> m i + ix [i] = runE i + .... + return f) • Relevant bindings include a :: arr i a (bound at simpl017.hs:50:11) liftArray :: arr i a -> E m (forall v. [E m i] -> E' v m a) diff --git a/testsuite/tests/th/T10598_TH.stderr b/testsuite/tests/th/T10598_TH.stderr index bcfbb089c5..434138eb76 100644 --- a/testsuite/tests/th/T10598_TH.stderr +++ b/testsuite/tests/th/T10598_TH.stderr @@ -1,41 +1,41 @@ T10598_TH.hs:(27,3)-(42,50): Splicing declarations - do { fooDataName <- newName "Foo"; - mkFooConName <- newName "MkFoo"; - let fooType = conT fooDataName; - sequence - [newtypeD - (cxt []) - fooDataName - [] - Nothing - (normalC - mkFooConName - [bangType - (bang noSourceUnpackedness noSourceStrictness) [t| Int |]]) - [derivClause (Just Stock) [[t| Eq |]], - derivClause (Just Anyclass) [[t| C |]], - derivClause (Just Newtype) [[t| Read |]]], - standaloneDerivWithStrategyD - (Just Stock) - (cxt []) - [t| Ord $fooType |] - pending(rn) [<splice, fooType>], - standaloneDerivWithStrategyD - (Just Anyclass) - (cxt []) - [t| D $fooType |] - pending(rn) [<splice, fooType>], - standaloneDerivWithStrategyD - (Just Newtype) - (cxt []) - [t| Show $fooType |] - pending(rn) [<splice, fooType>]] } + do fooDataName <- newName "Foo" + mkFooConName <- newName "MkFoo" + let fooType = conT fooDataName + sequence + [newtypeD + (cxt []) + fooDataName + [] + Nothing + (normalC + mkFooConName + [bangType + (bang noSourceUnpackedness noSourceStrictness) [t| Int |]]) + [derivClause (Just Stock) [[t| Eq |]], + derivClause (Just Anyclass) [[t| C |]], + derivClause (Just Newtype) [[t| Read |]]], + standaloneDerivWithStrategyD + (Just Stock) + (cxt []) + [t| Ord $(fooType) |] + pending(rn) [<splice, fooType>], + standaloneDerivWithStrategyD + (Just Anyclass) + (cxt []) + [t| D $(fooType) |] + pending(rn) [<splice, fooType>], + standaloneDerivWithStrategyD + (Just Newtype) + (cxt []) + [t| Show $(fooType) |] + pending(rn) [<splice, fooType>]] ======> newtype Foo = MkFoo Int - deriving stock (Eq) - deriving anyclass (C) - deriving newtype (Read) - deriving stock instance Ord Foo - deriving anyclass instance D Foo - deriving newtype instance Show Foo + deriving stock Eq + deriving anyclass C + deriving newtype Read + deriving stock instance () => Ord Foo + deriving anyclass instance () => D Foo + deriving newtype instance () => Show Foo diff --git a/testsuite/tests/th/T10638.stderr b/testsuite/tests/th/T10638.stderr index 3a626ce46a..cc4946a074 100644 --- a/testsuite/tests/th/T10638.stderr +++ b/testsuite/tests/th/T10638.stderr @@ -2,5 +2,4 @@ T10638.hs:26:11: ‘static test2’ is not a valid C identifier When checking declaration: - foreign import prim safe "static static test2" cmm_test2 - :: Int# -> Int# + foreign import prim safe "static test2" cmm_test2 :: Int# -> Int# diff --git a/testsuite/tests/th/T12530.stderr b/testsuite/tests/th/T12530.stderr index 0ba15360ac..d2d1820742 100644 --- a/testsuite/tests/th/T12530.stderr +++ b/testsuite/tests/th/T12530.stderr @@ -5,6 +5,6 @@ T12530.hs:(8,3)-(15,6): Splicing declarations g = undefined @(_) @(a) |] ======> f :: Maybe Int -> Maybe Int - f = id @(Maybe Int) + f = id @Maybe Int g :: forall a. a g = undefined @_ @a diff --git a/testsuite/tests/th/T3177a.stderr b/testsuite/tests/th/T3177a.stderr index 0b540a8bf2..e2e8cadbdc 100644 --- a/testsuite/tests/th/T3177a.stderr +++ b/testsuite/tests/th/T3177a.stderr @@ -2,11 +2,9 @@ T3177a.hs:8:8: error: • Expecting one fewer arguments to ‘Int’ Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ - • In the type signature: - f :: Int Int + • In the type signature: f :: (Int Int) T3177a.hs:11:6: error: • Expecting one fewer arguments to ‘Int’ Expected kind ‘* -> *’, but ‘Int’ has kind ‘*’ - • In the type signature: - g :: Int Int + • In the type signature: g :: Int Int diff --git a/testsuite/tests/th/T3319.stderr b/testsuite/tests/th/T3319.stderr index 87ba3f54c7..44ec90ffe7 100644 --- a/testsuite/tests/th/T3319.stderr +++ b/testsuite/tests/th/T3319.stderr @@ -4,4 +4,4 @@ T3319.hs:8:3-93: Splicing declarations (ImportF CCall Unsafe "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))] ======> - foreign import ccall unsafe "static &foo" foo :: Ptr GHC.Tuple.() + foreign import ccall unsafe "&" foo :: Ptr GHC.Tuple.() diff --git a/testsuite/tests/th/T3899a.hs b/testsuite/tests/th/T3899a.hs index 2ac985136f..73ed534786 100644 --- a/testsuite/tests/th/T3899a.hs +++ b/testsuite/tests/th/T3899a.hs @@ -10,5 +10,6 @@ data Nil = Nil nestedTuple n = do xs <- replicateM n (newName "x") - return $ LamE [foldr (\v prev -> ConP 'Cons [VarP v,prev]) (ConP 'Nil []) xs] + return $ LamE [foldr (\v prev -> ParensP (ConP 'Cons [VarP v,prev])) + (ConP 'Nil []) xs] (TupE $ map VarE xs) diff --git a/testsuite/tests/th/T4436.stderr b/testsuite/tests/th/T4436.stderr index 1b7fdf6277..d87bfc1a2f 100644 --- a/testsuite/tests/th/T4436.stderr +++ b/testsuite/tests/th/T4436.stderr @@ -1,11 +1,6 @@ T4436.hs:5:7-56: Splicing expression - return - (LitE - (StringL - "hello\n\ - \goodbye\n\ - \and then")) + return (LitE (StringL "hello/ngoodbye/nand then")) ======> - "hello\n\ - \goodbye\n\ - \and then" + "hello +goodbye +and then" diff --git a/testsuite/tests/th/T5217.stderr b/testsuite/tests/th/T5217.stderr index e1a92c89ca..17bbd7b00e 100644 --- a/testsuite/tests/th/T5217.stderr +++ b/testsuite/tests/th/T5217.stderr @@ -9,6 +9,6 @@ T5217.hs:(6,3)-(9,53): Splicing declarations data T a b where T1 :: Int -> T Int Char - T2 :: forall a. a -> T a a - T3 :: forall a. a -> T [a] a - T4 :: forall a b. a -> b -> T b [a] + T2 :: forall a. () => a -> T a a + T3 :: forall a. () => a -> T [a] a + T4 :: forall a b. () => a -> b -> T b [a] diff --git a/testsuite/tests/th/T5358.stderr b/testsuite/tests/th/T5358.stderr index 4a17272310..d9485cebb7 100644 --- a/testsuite/tests/th/T5358.stderr +++ b/testsuite/tests/th/T5358.stderr @@ -4,8 +4,8 @@ T5358.hs:14:12: error: runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool CallStack (from ImplicitParams): error, called at T5358.hs:15:18 in main:T5358 - Code: do { VarI _ t _ <- reify (mkName "prop_x1"); - ($) error ((++) "runTest called error: " pprint t) } + Code: do VarI _ t _ <- reify (mkName "prop_x1") + ($) error ((++) "runTest called error: " pprint t) In the untyped splice: - $(do { VarI _ t _ <- reify (mkName "prop_x1"); - error $ ("runTest called error: " ++ pprint t) }) + $(do VarI _ t _ <- reify (mkName "prop_x1") + error $ ("runTest called error: " ++ pprint t)) diff --git a/testsuite/tests/th/T5508.stderr b/testsuite/tests/th/T5508.stderr index 3cd9bf27ed..7000204913 100644 --- a/testsuite/tests/th/T5508.stderr +++ b/testsuite/tests/th/T5508.stderr @@ -1,7 +1,7 @@ T5508.hs:(7,9)-(9,28): Splicing expression - do { let x = mkName "x" - v = return (LamE [VarP x] $ VarE x); - [| $v . id |] - pending(rn) [<splice, v>] } + do let x = mkName "x" + v = return (LamE [VarP x] $ VarE x) + [| $v . id |] + pending(rn) [<splice, v>] ======> ((\ x -> x) . id) diff --git a/testsuite/tests/th/T5700.stderr b/testsuite/tests/th/T5700.stderr index 729a36604f..f2f428892e 100644 --- a/testsuite/tests/th/T5700.stderr +++ b/testsuite/tests/th/T5700.stderr @@ -1,6 +1,6 @@ T5700.hs:8:3-9: Splicing declarations mkC ''D ======> - instance C D where + instance () => C D where {-# INLINE inlinable #-} inlinable _ = GHC.Tuple.() diff --git a/testsuite/tests/th/T5883.stderr b/testsuite/tests/th/T5883.stderr index aa87a41052..b63ea2f38c 100644 --- a/testsuite/tests/th/T5883.stderr +++ b/testsuite/tests/th/T5883.stderr @@ -6,6 +6,6 @@ T5883.hs:(7,4)-(12,4): Splicing declarations {-# INLINE show #-} |] ======> data Unit = Unit - instance Show Unit where + instance () => Show Unit where {-# INLINE show #-} show _ = "" diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr index baaf04f3f5..21b753b5d3 100644 --- a/testsuite/tests/th/T7532.stderr +++ b/testsuite/tests/th/T7532.stderr @@ -6,10 +6,10 @@ instance C Bool where T7532.hs:11:3-7: Splicing declarations bang' ======> - instance C Int where + instance () => C Int where data D Int = T ==================== Renamer ==================== -instance C Int where +instance () => C Int where data D Int = T7532.T diff --git a/testsuite/tests/th/T8577.stderr b/testsuite/tests/th/T8577.stderr index ef95cc313d..1a0fb75bd1 100644 --- a/testsuite/tests/th/T8577.stderr +++ b/testsuite/tests/th/T8577.stderr @@ -4,5 +4,5 @@ T8577.hs:9:11: error: Expected type: Q (TExp (A Bool)) Actual type: Q (TExp (A Int)) In the expression: y - In the Template Haskell splice $$y - In the expression: $$y + In the Template Haskell splice $$(y) + In the expression: $$(y) diff --git a/testsuite/tests/th/T8761.stderr b/testsuite/tests/th/T8761.stderr index 6a7af1e9e3..86f175631b 100644 --- a/testsuite/tests/th/T8761.stderr +++ b/testsuite/tests/th/T8761.stderr @@ -3,34 +3,33 @@ pattern x1_0 Q2 x2_1 = ((x1_0, x2_1)) pattern Q3 {qx3, qy3, qz3} <- ((qx3, qy3), [qz3]) where Q3 qx3 qy3 qz3 = ((qx3, qy3), [qz3]) T8761.hs:(16,1)-(39,13): Splicing declarations - do { [qx1, qy1, qz1] <- mapM - (\ i -> newName $ "x" ++ show i) [1, 2, 3]; - let nm1 = mkName "Q1" - prefixPat - = patSynD - nm1 - (prefixPatSyn [qx1, qy1, qz1]) - unidir - (tupP [tupP [varP qx1, varP qy1], listP [varP qz1], wildP, wildP]); - [qx2, qy2] <- mapM (\ i -> newName $ "x" ++ show i) [1, 2]; - let nm2 = mkName "Q2" - infixPat - = patSynD - nm2 - (infixPatSyn qx2 qy2) - implBidir - (tupP [tupP [varP qx2, varP qy2]]); - let nm3 = mkName "Q3" - [qx3, qy3, qz3] = map mkName ["qx3", "qy3", "qz3"] - patP = tupP [tupP [varP qx3, varP qy3], listP [varP qz3]] - patE = tupE [tupE [varE qx3, varE qy3], listE [varE qz3]] - cls = clause [varP qx3, varP qy3, varP qz3] (normalB patE) [] - recordPat - = patSynD - nm3 (recordPatSyn [qx3, qy3, qz3]) (explBidir [cls]) patP; - pats <- sequence [prefixPat, infixPat, recordPat]; - mapM_ (runIO . hPutStrLn stderr . pprint) pats; - return pats } + do [qx1, qy1, qz1] <- mapM + (\ i -> newName $ "x" ++ show i) [1, 2, 3] + let nm1 = mkName "Q1" + prefixPat + = patSynD + nm1 + (prefixPatSyn [qx1, qy1, qz1]) + unidir + (tupP [tupP [varP qx1, varP qy1], listP [varP qz1], wildP, wildP]) + [qx2, qy2] <- mapM (\ i -> newName $ "x" ++ show i) [1, 2] + let nm2 = mkName "Q2" + infixPat + = patSynD + nm2 + (infixPatSyn qx2 qy2) + implBidir + (tupP [tupP [varP qx2, varP qy2]]) + let nm3 = mkName "Q3" + [qx3, qy3, qz3] = map mkName ["qx3", "qy3", "qz3"] + patP = tupP [tupP [varP qx3, varP qy3], listP [varP qz3]] + patE = tupE [tupE [varE qx3, varE qy3], listE [varE qz3]] + cls = clause [varP qx3, varP qy3, varP qz3] (normalB patE) [] + recordPat + = patSynD nm3 (recordPatSyn [qx3, qy3, qz3]) (explBidir [cls]) patP + pats <- sequence [prefixPat, infixPat, recordPat] + mapM_ (runIO . hPutStrLn stderr . pprint) pats + return pats ======> pattern Q1 x1 x2 x3 <- ((x1, x2), [x3], _, _) pattern x1 `Q2` x2 = ((x1, x2)) @@ -73,55 +72,58 @@ T8761.hs:(56,1)-(62,23): Splicing declarations T8761.hs:(71,1)-(105,39): Splicing declarations [d| pattern P :: Bool pattern P <- True - pattern Pe :: forall a. a -> Ex + pattern Pe :: () => forall a. a -> Ex pattern Pe x <- MkEx x pattern Pu :: forall a. a -> a pattern Pu x <- x - pattern Pue :: forall a. forall b. a -> b -> (a, Ex) + pattern Pue :: forall a. () => forall b. a -> b -> (a, Ex) pattern Pue x y <- (x, MkEx y) pattern Pur :: forall a. (Num a, Eq a) => a -> [a] pattern Pur x <- [x, 1] - pattern Purp :: forall a b. - (Num a, Eq a) => Show b => a -> b -> ([a], UnivProv b) + pattern Purp :: + forall a b. (Num a, Eq a) => Show b => a -> b -> ([a], UnivProv b) pattern Purp x y <- ([x, 1], MkUnivProv y) - pattern Pure :: forall a. - (Num a, Eq a) => forall b. a -> b -> ([a], Ex) + pattern Pure :: + forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex) pattern Pure x y <- ([x, 1], MkEx y) - pattern Purep :: forall a. + pattern Purep :: + forall a. (Num a, Eq a) => forall b. Show b => a -> b -> ([a], ExProv) pattern Purep x y <- ([x, 1], MkExProv y) - pattern Pep :: forall a. Show a => a -> ExProv + pattern Pep :: () => forall a. Show a => a -> ExProv pattern Pep x <- MkExProv x - pattern Pup :: forall a. Show a => a -> UnivProv a + pattern Pup :: forall a. () => Show a => a -> UnivProv a pattern Pup x <- MkUnivProv x - pattern Puep :: forall a. - forall b. (Show b) => a -> b -> (ExProv, a) + pattern Puep :: + forall a. () => forall b. (Show b) => a -> b -> (ExProv, a) pattern Puep x y <- (MkExProv y, x) |] ======> pattern P :: Bool pattern P <- True - pattern Pe :: forall a. a -> Ex + pattern Pe :: () => forall a. a -> Ex pattern Pe x <- MkEx x pattern Pu :: forall a. a -> a pattern Pu x <- x - pattern Pue :: forall a. forall b. a -> b -> (a, Ex) + pattern Pue :: forall a. () => forall b. a -> b -> (a, Ex) pattern Pue x y <- (x, MkEx y) pattern Pur :: forall a. (Num a, Eq a) => a -> [a] pattern Pur x <- [x, 1] - pattern Purp :: forall a b. - (Num a, Eq a) => Show b => a -> b -> ([a], UnivProv b) + pattern Purp :: + forall a b. (Num a, Eq a) => Show b => a -> b -> ([a], UnivProv b) pattern Purp x y <- ([x, 1], MkUnivProv y) - pattern Pure :: forall a. - (Num a, Eq a) => forall b. a -> b -> ([a], Ex) + pattern Pure :: + forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex) pattern Pure x y <- ([x, 1], MkEx y) - pattern Purep :: forall a. + pattern Purep :: + forall a. (Num a, Eq a) => forall b. Show b => a -> b -> ([a], ExProv) pattern Purep x y <- ([x, 1], MkExProv y) - pattern Pep :: forall a. Show a => a -> ExProv + pattern Pep :: () => forall a. Show a => a -> ExProv pattern Pep x <- MkExProv x - pattern Pup :: forall a. Show a => a -> UnivProv a + pattern Pup :: forall a. () => Show a => a -> UnivProv a pattern Pup x <- MkUnivProv x - pattern Puep :: forall a. forall b. Show b => a -> b -> (ExProv, a) + pattern Puep :: + forall a. () => forall b. Show b => a -> b -> (ExProv, a) pattern Puep x y <- (MkExProv y, x) pattern T8761.P :: GHC.Types.Bool pattern T8761.Pe :: () => forall (a0_0 :: *) . a0_0 -> T8761.Ex @@ -148,11 +150,11 @@ pattern T8761.Pup :: forall (a0_0 :: *) . () => GHC.Show.Show a0_0 => pattern T8761.Puep :: forall (a0_0 :: *) . () => forall (b0_1 :: *) . GHC.Show.Show b0_1 => a0_0 -> b0_1 -> (T8761.ExProv, a0_0) T8761.hs:(108,1)-(117,25): Splicing declarations - do { infos <- mapM - reify - ['P, 'Pe, 'Pu, 'Pue, 'Pur, 'Purp, 'Pure, 'Purep, 'Pep, 'Pup, - 'Puep]; - mapM_ (runIO . hPutStrLn stderr . pprint) infos; - [d| theAnswerIs = 42 |] } + do infos <- mapM + reify + ['P, 'Pe, 'Pu, 'Pue, 'Pur, 'Purp, 'Pure, 'Purep, 'Pep, 'Pup, + 'Puep] + mapM_ (runIO . hPutStrLn stderr . pprint) infos + [d| theAnswerIs = 42 |] ======> theAnswerIs = 42 diff --git a/testsuite/tests/th/TH_PromotedTuple.stderr b/testsuite/tests/th/TH_PromotedTuple.stderr index 06260a7bee..9619d52f51 100644 --- a/testsuite/tests/th/TH_PromotedTuple.stderr +++ b/testsuite/tests/th/TH_PromotedTuple.stderr @@ -1,7 +1,7 @@ TH_PromotedTuple.hs:(14,32)-(16,43): Splicing type - do { ty <- [t| '(Int, False) |]; - reportWarning (show ty); - return ty } + do ty <- [t| '(Int, False) |] + reportWarning (show ty) + return ty ======> '(Int, False) diff --git a/testsuite/tests/th/TH_exn2.stderr b/testsuite/tests/th/TH_exn2.stderr index 8cf8d452ce..3ccc9e1c0c 100644 --- a/testsuite/tests/th/TH_exn2.stderr +++ b/testsuite/tests/th/TH_exn2.stderr @@ -2,5 +2,5 @@ TH_exn2.hs:1:1: error: Exception when trying to run compile-time code: Prelude.tail: empty list - Code: do { ds <- [d| |]; - return (tail ds) } + Code: do ds <- [d| |] + return (tail ds) diff --git a/testsuite/tests/th/TH_foreignCallingConventions.stderr b/testsuite/tests/th/TH_foreignCallingConventions.stderr index 1ff81a4fc8..dae994539d 100644 --- a/testsuite/tests/th/TH_foreignCallingConventions.stderr +++ b/testsuite/tests/th/TH_foreignCallingConventions.stderr @@ -9,21 +9,20 @@ foreign import stdcall safe "bay" bay :: (GHC.Types.Int -> foreign import javascript unsafe "bax" bax :: GHC.Ptr.Ptr GHC.Types.Int -> GHC.Types.IO GHC.Base.String TH_foreignCallingConventions.hs:(13,4)-(23,25): Splicing declarations - do { let fi cconv safety lbl name ty - = ForeignD (ImportF cconv safety lbl name ty); - dec1 <- fi CCall Interruptible "&" (mkName "foo") - <$> [t| Ptr () |]; - dec2 <- fi Prim Safe "bar" (mkName "bar") <$> [t| Int# -> Int# |]; - dec3 <- fi CApi Unsafe "baz" (mkName "baz") - <$> [t| Double -> IO () |]; - dec4 <- fi StdCall Safe "bay" (mkName "bay") - <$> [t| (Int -> Bool) -> IO Int |]; - dec5 <- fi JavaScript Unsafe "bax" (mkName "bax") - <$> [t| Ptr Int -> IO String |]; - runIO - $ mapM_ (putStrLn . pprint) [dec1, dec2, dec3, dec4, dec5] - >> hFlush stdout; - return [dec1, dec2] } + do let fi cconv safety lbl name ty + = ForeignD (ImportF cconv safety lbl name ty) + dec1 <- fi CCall Interruptible "&" (mkName "foo") <$> [t| Ptr () |] + dec2 <- fi Prim Safe "bar" (mkName "bar") <$> [t| Int# -> Int# |] + dec3 <- fi CApi Unsafe "baz" (mkName "baz") + <$> [t| Double -> IO () |] + dec4 <- fi StdCall Safe "bay" (mkName "bay") + <$> [t| (Int -> Bool) -> IO Int |] + dec5 <- fi JavaScript Unsafe "bax" (mkName "bax") + <$> [t| Ptr Int -> IO String |] + runIO + $ mapM_ (putStrLn . pprint) [dec1, dec2, dec3, dec4, dec5] + >> hFlush stdout + return [dec1, dec2] ======> - foreign import ccall interruptible "static &foo" foo :: Ptr () - foreign import prim safe "static bar" bar :: Int# -> Int# + foreign import ccall interruptible "&" foo :: Ptr () + foreign import prim safe "bar" bar :: Int# -> Int# diff --git a/testsuite/tests/th/TH_foreignInterruptible.stderr b/testsuite/tests/th/TH_foreignInterruptible.stderr index 9cbf34ac87..7131eeee71 100644 --- a/testsuite/tests/th/TH_foreignInterruptible.stderr +++ b/testsuite/tests/th/TH_foreignInterruptible.stderr @@ -8,5 +8,4 @@ TH_foreignInterruptible.hs:8:3-100: Splicing declarations (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))] ======> - foreign import ccall interruptible "static &foo" foo - :: Ptr GHC.Tuple.() + foreign import ccall interruptible "&" foo :: Ptr GHC.Tuple.() diff --git a/testsuite/tests/th/TH_pragma.stderr b/testsuite/tests/th/TH_pragma.stderr index 0fcd167aa4..ddd5998b39 100644 --- a/testsuite/tests/th/TH_pragma.stderr +++ b/testsuite/tests/th/TH_pragma.stderr @@ -8,9 +8,9 @@ TH_pragma.hs:(6,4)-(8,26): Splicing declarations foo x = (x + 1) TH_pragma.hs:(10,4)-(12,31): Splicing declarations [d| bar :: Num a => a -> a - {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-} + {-# SPECIALISE INLINE [~1] bar :: Float -> Float #-} bar x = x * 10 |] ======> bar :: forall a. Num a => a -> a - {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-} + {-# SPECIALISE INLINE [~1] bar :: Float -> Float #-} bar x = (x * 10) diff --git a/testsuite/tests/th/TH_unresolvedInfix2.stderr b/testsuite/tests/th/TH_unresolvedInfix2.stderr index 6e17ef474a..4a5577f6fc 100644 --- a/testsuite/tests/th/TH_unresolvedInfix2.stderr +++ b/testsuite/tests/th/TH_unresolvedInfix2.stderr @@ -6,6 +6,6 @@ TH_unresolvedInfix2.hs:14:11: in the section: ‘:+ N :+ N’ In the untyped splice: $(let - plus = conE ':+ + plus = conE '(:+) n = conE 'N in infixE Nothing plus (Just $ uInfixE n plus n)) diff --git a/testsuite/tests/typecheck/should_compile/T11339.stderr b/testsuite/tests/typecheck/should_compile/T11339.stderr index 7fd50014f0..88250ef9a7 100644 --- a/testsuite/tests/typecheck/should_compile/T11339.stderr +++ b/testsuite/tests/typecheck/should_compile/T11339.stderr @@ -4,9 +4,9 @@ T11339.hs:15:5: error: t :: forall (f :: * -> *). Applicative f => (a -> f b) -> f t • In an equation for ‘failing’: failing left right afb s - = case pins t of { + = case pins t of [] -> right afb s - _ -> t afb } + _ -> t afb where t :: Applicative f => (a -> f b) -> f t Bazaar {getBazaar = t} = left sell s diff --git a/testsuite/tests/typecheck/should_compile/tc211.stderr b/testsuite/tests/typecheck/should_compile/tc211.stderr index 5cda3a1e97..c57c59b3fc 100644 --- a/testsuite/tests/typecheck/should_compile/tc211.stderr +++ b/testsuite/tests/typecheck/should_compile/tc211.stderr @@ -55,18 +55,18 @@ tc211.hs:68:8: error: with actual type ‘a2 -> a2’ • In the expression: Cons :: - (forall a. a -> a) - -> List (forall a. a -> a) -> List (forall a. a -> a) + ((forall a. a -> a) + -> List (forall a. a -> a) -> List (forall a. a -> a)) In the expression: (Cons :: - (forall a. a -> a) - -> List (forall a. a -> a) -> List (forall a. a -> a)) + ((forall a. a -> a) + -> List (forall a. a -> a) -> List (forall a. a -> a))) (\ x -> x) Nil In an equation for ‘xs2’: xs2 = (Cons :: - (forall a. a -> a) - -> List (forall a. a -> a) -> List (forall a. a -> a)) + ((forall a. a -> a) + -> List (forall a. a -> a) -> List (forall a. a -> a))) (\ x -> x) Nil tc211.hs:76:9: error: diff --git a/testsuite/tests/typecheck/should_fail/T11464.stderr b/testsuite/tests/typecheck/should_fail/T11464.stderr index f3402917b2..11dda61a9f 100644 --- a/testsuite/tests/typecheck/should_fail/T11464.stderr +++ b/testsuite/tests/typecheck/should_fail/T11464.stderr @@ -2,5 +2,5 @@ T11464.hs:5:14: error: • Expecting one more argument to ‘Either a’ Expected a type, but ‘Either a’ has kind ‘* -> *’ - • In the first argument of ‘Eq’, namely ‘Either a’ + • In the first argument of ‘Eq’, namely ‘(Either a)’ In the instance declaration for ‘Eq (Either a)’ diff --git a/testsuite/tests/typecheck/should_fail/T12124.stderr b/testsuite/tests/typecheck/should_fail/T12124.stderr index cf3c755f7e..bafc828304 100644 --- a/testsuite/tests/typecheck/should_fail/T12124.stderr +++ b/testsuite/tests/typecheck/should_fail/T12124.stderr @@ -4,6 +4,6 @@ T12124.hs:7:18: error: • In the pattern: Whoops a In a case alternative: Whoops a -> a In the first argument of ‘return’, namely - ‘(case Whoops 1 2 of { + ‘(case Whoops 1 2 of Whoops a -> a - _ -> 0 })’ + _ -> 0)’ diff --git a/testsuite/tests/typecheck/should_fail/T2994.stderr b/testsuite/tests/typecheck/should_fail/T2994.stderr index d4e07e4597..4777e486e6 100644 --- a/testsuite/tests/typecheck/should_fail/T2994.stderr +++ b/testsuite/tests/typecheck/should_fail/T2994.stderr @@ -14,7 +14,7 @@ T2994.hs:13:10: error: T2994.hs:13:23: error: • Expecting one more argument to ‘Reader' r’ Expected a type, but ‘Reader' r’ has kind ‘* -> *’ - • In the first argument of ‘MonadReader’, namely ‘Reader' r’ + • In the first argument of ‘MonadReader’, namely ‘(Reader' r)’ In the instance declaration for ‘MonadReader (Reader' r)’ T2994.hs:15:10: error: diff --git a/testsuite/tests/typecheck/should_fail/T3540.stderr b/testsuite/tests/typecheck/should_fail/T3540.stderr index 5df0972d58..1723e86bbe 100644 --- a/testsuite/tests/typecheck/should_fail/T3540.stderr +++ b/testsuite/tests/typecheck/should_fail/T3540.stderr @@ -1,25 +1,20 @@ T3540.hs:4:12: error: • Expected a type, but ‘a ~ Int’ has kind ‘Constraint’ - • In the type signature: - thing :: a ~ Int + • In the type signature: thing :: (a ~ Int) T3540.hs:7:20: error: • Expected a type, but ‘a ~ Int’ has kind ‘Constraint’ - • In the type signature: - thing1 :: Int -> (a ~ Int) + • In the type signature: thing1 :: Int -> (a ~ Int) T3540.hs:10:13: error: • Expected a type, but ‘a ~ Int’ has kind ‘Constraint’ - • In the type signature: - thing2 :: (a ~ Int) -> Int + • In the type signature: thing2 :: (a ~ Int) -> Int T3540.hs:13:12: error: • Expected a type, but ‘?dude::Int’ has kind ‘Constraint’ - • In the type signature: - thing3 :: (?dude :: Int) -> Int + • In the type signature: thing3 :: (?dude :: Int) -> Int T3540.hs:16:11: error: • Expected a type, but ‘Eq a’ has kind ‘Constraint’ - • In the type signature: - thing4 :: (Eq a) -> Int + • In the type signature: thing4 :: (Eq a) -> Int diff --git a/testsuite/tests/typecheck/should_fail/T3613.stderr b/testsuite/tests/typecheck/should_fail/T3613.stderr index 6d3c70346b..a221a95c17 100644 --- a/testsuite/tests/typecheck/should_fail/T3613.stderr +++ b/testsuite/tests/typecheck/should_fail/T3613.stderr @@ -14,9 +14,9 @@ T3613.hs:17:24: error: Actual type: IO () • In a stmt of a 'do' block: bar In the first argument of ‘fooThen’, namely - ‘(do { bar; - undefined })’ + ‘(do bar + undefined)’ In the expression: fooThen - (do { bar; - undefined }) + (do bar + undefined) diff --git a/testsuite/tests/typecheck/should_fail/T7748a.stderr b/testsuite/tests/typecheck/should_fail/T7748a.stderr index 17d60cc32d..ed9df46d15 100644 --- a/testsuite/tests/typecheck/should_fail/T7748a.stderr +++ b/testsuite/tests/typecheck/should_fail/T7748a.stderr @@ -9,10 +9,10 @@ T7748a.hs:16:24: error: • In the pattern: Just (Just p) In a case alternative: Just (Just p) -> p In the expression: - case zd of { + case zd of Nothing -> const () Just Nothing -> const () - Just (Just p) -> p } + Just (Just p) -> p • Relevant bindings include g :: r -> () (bound at T7748a.hs:13:16) f :: r -> () (bound at T7748a.hs:13:8) diff --git a/testsuite/tests/typecheck/should_fail/T7851.stderr b/testsuite/tests/typecheck/should_fail/T7851.stderr index b8ec6b8f32..1a0274f8a3 100644 --- a/testsuite/tests/typecheck/should_fail/T7851.stderr +++ b/testsuite/tests/typecheck/should_fail/T7851.stderr @@ -5,9 +5,9 @@ T7851.hs:5:10: error: • Probable cause: ‘print’ is applied to too few arguments In a stmt of a 'do' block: print In the expression: - do { print; - print "Hello" } + do print + print "Hello" In an equation for ‘bar’: bar - = do { print; - print "Hello" } + = do print + print "Hello" diff --git a/testsuite/tests/typecheck/should_fail/T8603.stderr b/testsuite/tests/typecheck/should_fail/T8603.stderr index baf3264734..d87bd635c4 100644 --- a/testsuite/tests/typecheck/should_fail/T8603.stderr +++ b/testsuite/tests/typecheck/should_fail/T8603.stderr @@ -13,7 +13,7 @@ T8603.hs:29:17: error: has only one In a stmt of a 'do' block: prize <- lift uniform [1, 2, 3] In the expression: - do { prize <- lift uniform [1, 2, ....]; - return False } + do prize <- lift uniform [1, 2, ....] + return False • Relevant bindings include testRVState1 :: RVState s Bool (bound at T8603.hs:28:1) diff --git a/testsuite/tests/typecheck/should_fail/T9201.stderr b/testsuite/tests/typecheck/should_fail/T9201.stderr index b6c187548b..28f2f1d391 100644 --- a/testsuite/tests/typecheck/should_fail/T9201.stderr +++ b/testsuite/tests/typecheck/should_fail/T9201.stderr @@ -2,6 +2,6 @@ T9201.hs:6:17: error: • Expected kind ‘x’, but ‘a’ has kind ‘y’ • In the first argument of ‘f’, namely ‘a’ - In the second argument of ‘d’, namely ‘f a’ + In the second argument of ‘d’, namely ‘(f a)’ In the type signature: ret :: d a (f a) diff --git a/testsuite/tests/typecheck/should_fail/T9612.stderr b/testsuite/tests/typecheck/should_fail/T9612.stderr index b5e6023664..462edc3e2d 100644 --- a/testsuite/tests/typecheck/should_fail/T9612.stderr +++ b/testsuite/tests/typecheck/should_fail/T9612.stderr @@ -7,12 +7,12 @@ T9612.hs:16:9: error: instance ‘MonadWriter w (WriterT w m)’ at T9612.hs:20:10-59 In a stmt of a 'do' block: tell (n, x) In the expression: - do { tell (n, x); - return (1, y) } + do tell (n, x) + return (1, y) In an equation for ‘f’: f y (n, x) - = do { tell (n, x); - return (1, y) } + = do tell (n, x) + return (1, y) Relevant bindings include x :: a (bound at T9612.hs:14:8) y :: a (bound at T9612.hs:14:3) diff --git a/testsuite/tests/typecheck/should_fail/tcfail028.stderr b/testsuite/tests/typecheck/should_fail/tcfail028.stderr index 38791e6c0f..518925575d 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail028.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail028.stderr @@ -2,6 +2,6 @@ tcfail028.hs:4:17: Expecting one more argument to ‘A a’ Expected a type, but ‘A a’ has kind ‘k0 -> *’ - In the type ‘A a’ + In the type ‘(A a)’ In the definition of data constructor ‘B’ In the data declaration for ‘A’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail070.stderr b/testsuite/tests/typecheck/should_fail/tcfail070.stderr index aa20e5d45f..0219626375 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail070.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail070.stderr @@ -2,5 +2,5 @@ tcfail070.hs:15:15: error: • Expecting one fewer arguments to ‘[Int]’ Expected kind ‘* -> k0’, but ‘[Int]’ has kind ‘*’ - • In the type ‘[Int] Bool’ + • In the type ‘([Int] Bool)’ In the type declaration for ‘State’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail103.stderr b/testsuite/tests/typecheck/should_fail/tcfail103.stderr index dd4d074223..ba0694b117 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail103.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail103.stderr @@ -14,10 +14,10 @@ tcfail103.hs:15:13: error: • In the expression: readSTRef v In an equation for ‘g’: g = readSTRef v In the expression: - do { v <- newSTRef 5; - let g :: ST s Int - g = readSTRef v; - g } + do v <- newSTRef 5 + let g :: ST s Int + g = readSTRef v + g • Relevant bindings include g :: ST s Int (bound at tcfail103.hs:15:9) v :: STRef t Int (bound at tcfail103.hs:12:5) diff --git a/testsuite/tests/typecheck/should_fail/tcfail128.stderr b/testsuite/tests/typecheck/should_fail/tcfail128.stderr index 63e314d80c..d78c46a191 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail128.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail128.stderr @@ -9,14 +9,14 @@ tcfail128.hs:18:16: error: (use -fprint-potential-instances to see them all) • In a stmt of a 'do' block: v <- thaw tmp In the expression: - do { let sL = ... - dim = length sL - ....; - v <- thaw tmp; - return () } + do let sL = ... + dim = length sL + .... + v <- thaw tmp + return () In an equation for ‘main’: main - = do { let sL = ... - ....; - v <- thaw tmp; - return () } + = do let sL = ... + .... + v <- thaw tmp + return () diff --git a/testsuite/tests/typecheck/should_fail/tcfail132.stderr b/testsuite/tests/typecheck/should_fail/tcfail132.stderr index 78209d2bc4..3f8f226468 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail132.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail132.stderr @@ -3,13 +3,13 @@ tcfail132.hs:17:37: error: • Expecting one fewer arguments to ‘Object f' f t’ Expected kind ‘* -> * -> * -> *’, but ‘Object f' f t’ has kind ‘* -> * -> *’ - • In the first argument of ‘T’, namely ‘Object f' f t’ + • In the first argument of ‘T’, namely ‘(Object f' f t)’ In the type ‘T (Object f' f t) (DUnit t)’ In the type declaration for ‘LiftObject’ tcfail132.hs:17:53: error: • Expected kind ‘* -> * -> * -> *’, but ‘DUnit t’ has kind ‘* -> * -> *’ - • In the second argument of ‘T’, namely ‘DUnit t’ + • In the second argument of ‘T’, namely ‘(DUnit t)’ In the type ‘T (Object f' f t) (DUnit t)’ In the type declaration for ‘LiftObject’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail146.stderr b/testsuite/tests/typecheck/should_fail/tcfail146.stderr index cf9341dfb3..ae126f5f1e 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail146.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail146.stderr @@ -1,6 +1,6 @@ tcfail146.hs:7:22: error: • Expected a type, but ‘SClass a’ has kind ‘Constraint’ - • In the type ‘SClass a’ + • In the type ‘(SClass a)’ In the definition of data constructor ‘SCon’ In the data declaration for ‘SData’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail162.stderr b/testsuite/tests/typecheck/should_fail/tcfail162.stderr index 3d1e79879b..228f18d5b8 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail162.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail162.stderr @@ -2,6 +2,6 @@ tcfail162.hs:10:33: Expecting one more argument to ‘ForeignPtr’ Expected a type, but ‘ForeignPtr’ has kind ‘* -> *’ - In the type ‘ForeignPtr’ + In the type ‘(ForeignPtr)’ In the definition of data constructor ‘Foo’ In the data declaration for ‘Foo’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail165.stderr b/testsuite/tests/typecheck/should_fail/tcfail165.stderr index 07d293dcd3..19fe79bb78 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail165.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail165.stderr @@ -7,6 +7,6 @@ tcfail165.hs:19:23: error: In a stmt of a 'do' block: putMVar var (show :: forall b. Show b => b -> String) In the expression: - do { var <- newEmptyMVar :: - IO (MVar (forall a. Show a => a -> String)); - putMVar var (show :: forall b. Show b => b -> String) } + do var <- newEmptyMVar :: + IO (MVar (forall a. Show a => a -> String)) + putMVar var (show :: forall b. Show b => b -> String) diff --git a/testsuite/tests/typecheck/should_fail/tcfail168.stderr b/testsuite/tests/typecheck/should_fail/tcfail168.stderr index 5f4656b13f..4ec71aaa1d 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail168.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail168.stderr @@ -5,14 +5,14 @@ tcfail168.hs:7:11: error: • Probable cause: ‘putChar’ is applied to too few arguments In a stmt of a 'do' block: putChar In the expression: - do { putChar; - putChar 'a'; - putChar 'a'; - putChar 'a'; - .... } + do putChar + putChar 'a' + putChar 'a' + putChar 'a' + .... In an equation for ‘foo’: foo - = do { putChar; - putChar 'a'; - putChar 'a'; - .... } + = do putChar + putChar 'a' + putChar 'a' + .... diff --git a/testsuite/tests/unboxedsums/ffi1.stderr b/testsuite/tests/unboxedsums/ffi1.stderr index 3a97270d0d..cdc77cea19 100644 --- a/testsuite/tests/unboxedsums/ffi1.stderr +++ b/testsuite/tests/unboxedsums/ffi1.stderr @@ -3,15 +3,14 @@ ffi1.hs:9:1: error: • Unacceptable argument type in foreign declaration: ‘(# Int | Int #)’ cannot be marshalled in a foreign call • When checking declaration: - foreign import ccall safe "static f1" f1 - :: (# Int | Int #) -> IO Int + foreign import ccall safe "f1" f1 :: (# Int | Int #) -> IO Int ffi1.hs:10:1: error: • Unacceptable argument type in foreign declaration: ‘(# (# Int, Int #) | (# Float#, Float# #) #)’ cannot be marshalled in a foreign call • When checking declaration: - foreign import ccall safe "static f2" f2 + foreign import ccall safe "f2" f2 :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int ffi1.hs:11:1: error: @@ -19,5 +18,5 @@ ffi1.hs:11:1: error: ‘(# (# #) | Void# | (# Int# | String #) #)’ cannot be marshalled in a foreign call • When checking declaration: - foreign import ccall safe "static f3" f3 + foreign import ccall safe "f3" f3 :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int diff --git a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr index 91d3189e60..b59b49c869 100644 --- a/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr +++ b/testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr @@ -13,12 +13,12 @@ WCompatWarningsOn.hs:13:5: warning: [-Wmissing-monadfail-instances (in -Wcompat) monadFail :: Monad m => m a • In a stmt of a 'do' block: Just _ <- undefined In the expression: - do { Just _ <- undefined; - undefined } + do Just _ <- undefined + undefined In an equation for ‘monadFail’: monadFail - = do { Just _ <- undefined; - undefined } + = do Just _ <- undefined + undefined WCompatWarningsOn.hs:16:1: warning: [-Wsemigroup (in -Wcompat)] Local definition of ‘<>’ clashes with a future Prelude name. diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs new file mode 100644 index 0000000000..c61b0e6d4c --- /dev/null +++ b/utils/check-ppr/Main.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + +import Data.Data hiding (Fixity) +import Data.List +import Bag +import FastString +import NameSet +import SrcLoc +import HsSyn +import OccName hiding (occName) +import GHC hiding (moduleName) +import Var +import DynFlags +import Outputable hiding (space) +import System.Environment( getArgs ) +import System.Exit +import System.FilePath + +import qualified Data.ByteString as B +import qualified Data.Map as Map + +main::IO() +main = do + args <- getArgs + case args of + [libdir,fileName] -> testOneFile libdir fileName + _ -> putStrLn "invoke with the libdir and a file to parse." + +testOneFile :: FilePath -> String -> IO () +testOneFile libdir fileName = do + p <- parseOneFile libdir fileName + let + origAst = showAstData 0 (pm_parsed_source p) + pped = pragmas ++ "\n" ++ pp (pm_parsed_source p) + anns = pm_annotations p + pragmas = getPragmas anns + + newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName + astFile = fileName <.> "ast" + + writeFile astFile origAst + writeFile newFile pped + + p' <- parseOneFile libdir newFile + + let newAstStr = showAstData 0 (pm_parsed_source p') + + if origAst == newAstStr + then do + -- putStrLn "ASTs matched" + exitSuccess + else do + putStrLn "AST Match Failed" + putStrLn "\n===================================\nOrig\n\n" + putStrLn origAst + putStrLn "\n===================================\nNew\n\n" + putStrLn newAstStr + exitFailure + + +parseOneFile :: FilePath -> FilePath -> IO ParsedModule +parseOneFile libdir fileName = do + let modByFile m = + case ml_hs_file $ ms_location m of + Nothing -> False + Just fn -> fn == fileName + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream + _ <- setSessionDynFlags dflags2 + addTarget Target { targetId = TargetFile fileName Nothing + , targetAllowObjCode = True + , targetContents = Nothing } + _ <- load LoadAllTargets + graph <- getModuleGraph + let + modSum = case filter modByFile graph of + [x] -> x + xs -> error $ "Can't find module, got:" + ++ show (map (ml_hs_file . ms_location) xs) + parseModule modSum + +getPragmas :: ApiAnns -> String +getPragmas anns = pragmaStr + where + tokComment (L _ (AnnBlockComment s)) = s + tokComment (L _ (AnnLineComment s)) = s + tokComment _ = "" + + comments = case Map.lookup noSrcSpan (snd anns) of + Nothing -> [] + Just cl -> map tokComment $ sortLocated cl + pragmas = filter (\c -> isPrefixOf "{-#" c ) comments + pragmaStr = intercalate "\n" pragmas + +pp :: (Outputable a) => a -> String +pp a = showPpr unsafeGlobalDynFlags a + + +-- | Show a GHC AST with SrcSpan's blanked out, to avoid comparing locations, +-- only structure +showAstData :: Data a => Int -> a -> String +showAstData n = + generic + `ext1Q` list + `extQ` string `extQ` fastString `extQ` srcSpan + `extQ` bytestring + `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon + `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet + `extQ` fixity + `ext2Q` located + where generic :: Data a => a -> String + generic t = indent n ++ "(" ++ showConstr (toConstr t) + ++ space (unwords (gmapQ (showAstData (n+1)) t)) ++ ")" + space "" = "" + space s = ' ':s + indent i = "\n" ++ replicate i ' ' + string = show :: String -> String + fastString = ("{FastString: "++) . (++"}") . show + :: FastString -> String + bytestring = show :: B.ByteString -> String + list l = indent n ++ "[" + ++ intercalate "," (map (showAstData (n+1)) l) + ++ "]" + + name = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr + :: Name -> String + occName = ("{OccName: "++) . (++"}") . OccName.occNameString + moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr + :: ModuleName -> String + + srcSpan :: SrcSpan -> String + srcSpan _ss = "{ "++ "ss" ++"}" + + var = ("{Var: "++) . (++"}") . showSDocDebug_ . ppr + :: Var -> String + dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr + :: DataCon -> String + + bagRdrName:: Bag (Located (HsBind RdrName)) -> String + bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") + . list . bagToList + bagName :: Bag (Located (HsBind Name)) -> String + bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") + . list . bagToList + bagVar :: Bag (Located (HsBind Var)) -> String + bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") + . list . bagToList + + nameSet = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable + + fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr + :: Fixity -> String + + located :: (Data b,Data loc) => GenLocated loc b -> String + located (L ss a) = + indent n ++ "(" + ++ case cast ss of + Just (s :: SrcSpan) -> + srcSpan s + Nothing -> "nnnnnnnn" + ++ showAstData (n+1) a + ++ ")" + +showSDoc_ :: SDoc -> String +showSDoc_ = showSDoc unsafeGlobalDynFlags + +showSDocDebug_ :: SDoc -> String +showSDocDebug_ = showSDocDebug unsafeGlobalDynFlags + +-- --------------------------------------------------------------------- + +-- Copied from syb for the test + + +-- | The type constructor for queries +newtype Q q x = Q { unQ :: x -> q } + +-- | Extend a generic query by a type-specific case +extQ :: ( Typeable a + , Typeable b + ) + => (a -> q) + -> (b -> q) + -> a + -> q +extQ f g a = maybe (f a) g (cast a) + +-- | Type extension of queries for type constructors +ext1Q :: (Data d, Typeable t) + => (d -> q) + -> (forall e. Data e => t e -> q) + -> d -> q +ext1Q def ext = unQ ((Q def) `ext1` (Q ext)) + + +-- | Type extension of queries for type constructors +ext2Q :: (Data d, Typeable t) + => (d -> q) + -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) + -> d -> q +ext2Q def ext = unQ ((Q def) `ext2` (Q ext)) + +-- | Flexible type extension +ext1 :: (Data a, Typeable t) + => c a + -> (forall d. Data d => c (t d)) + -> c a +ext1 def ext = maybe def id (dataCast1 ext) + + + +-- | Flexible type extension +ext2 :: (Data a, Typeable t) + => c a + -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2)) + -> c a +ext2 def ext = maybe def id (dataCast2 ext) diff --git a/utils/check-ppr/README b/utils/check-ppr/README new file mode 100644 index 0000000000..ac0eb55977 --- /dev/null +++ b/utils/check-ppr/README @@ -0,0 +1,20 @@ + +This programme is intended to be used by any GHC developers working on the AST +and/or pretty printer by providing a way to check that the same AST is generated +from the pretty printed AST as from the original source. + +i.e., it checks whether + + parse (ppr (parse s)) === parse s + + +This utility is also intended to be used in tests, so that when new features are +added the ability to round-trip the AST via ppr is tested. + +Usage + +In a test Makefile + + $(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" FileToParse.hs + +See examples in (REPO_HOME)/testsuite/tests/printer/Makefile diff --git a/utils/check-ppr/check-ppr.cabal b/utils/check-ppr/check-ppr.cabal new file mode 100644 index 0000000000..96863e58fa --- /dev/null +++ b/utils/check-ppr/check-ppr.cabal @@ -0,0 +1,32 @@ +Name: check-ppr +Version: 0.1 +Copyright: XXX +License: BSD3 +-- XXX License-File: LICENSE +Author: XXX +Maintainer: XXX +Synopsis: A utilities for checking the consistency of GHC's pretty printer +Description: + This utility is used to check the consistency of the GHC pretty printer, by + parsing a file, pretty printing it, and then re-parsing the pretty printed + version. See @utils/check-ppr/README@ in GHC's source distribution for + details. +Category: Development +build-type: Simple +cabal-version: >=1.10 + +Executable check-ppr + Default-Language: Haskell2010 + + Main-Is: Main.hs + + Ghc-Options: -Wall + + Build-Depends: base >= 4 && < 5, + bytestring, + containers, + -- Cabal >= 1.25 && <1.27, + Cabal >= 1.24 && <1.27, + directory, + filepath, + ghc diff --git a/utils/check-ppr/ghc.mk b/utils/check-ppr/ghc.mk new file mode 100644 index 0000000000..189b447171 --- /dev/null +++ b/utils/check-ppr/ghc.mk @@ -0,0 +1,18 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://ghc.haskell.org/trac/ghc/wiki/Building/Architecture +# http://ghc.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +utils/check-ppr_USES_CABAL = YES +utils/check-ppr_PACKAGE = check-ppr +utils/check-ppr_dist-install_PROGNAME = check-ppr +utils/check-ppr_dist-install_INSTALL = NO +utils/check-ppr_dist-install_INSTALL_INPLACE = YES +$(eval $(call build-prog,utils/check-ppr,dist-install,2)) diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y index 51ca9ad6eb..cd712d7584 100644 --- a/utils/genprimopcode/Parser.y +++ b/utils/genprimopcode/Parser.y @@ -77,9 +77,9 @@ pOption : lowerName '=' false { OptionFalse $1 } | fixity '=' pInfix { OptionFixity $3 } pInfix :: { Maybe Fixity } -pInfix : infix integer { Just $ Fixity (show $2) $2 InfixN } - | infixl integer { Just $ Fixity (show $2) $2 InfixL } - | infixr integer { Just $ Fixity (show $2) $2 InfixR } +pInfix : infix integer { Just $ Fixity NoSourceText $2 InfixN } + | infixl integer { Just $ Fixity NoSourceText $2 InfixL } + | infixr integer { Just $ Fixity NoSourceText $2 InfixR } | nothing { Nothing } diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs index 17c264d44a..b848863135 100644 --- a/utils/genprimopcode/Syntax.hs +++ b/utils/genprimopcode/Syntax.hs @@ -96,14 +96,18 @@ instance Show TyCon where -- Follow definitions of Fixity and FixityDirection in GHC --- The String exists so that it matches the SourceText field in +-- The SourceText exists so that it matches the SourceText field in -- BasicTypes.Fixity -data Fixity = Fixity String Int FixityDirection +data Fixity = Fixity SourceText Int FixityDirection deriving (Eq, Show) data FixityDirection = InfixN | InfixL | InfixR deriving (Eq, Show) +data SourceText = SourceText String + | NoSourceText + deriving (Eq,Show) + ------------------------------------------------------------------ -- Sanity checking ----------------------------------------------- ------------------------------------------------------------------ diff --git a/utils/haddock b/utils/haddock -Subproject f4e355f7023057924161160ce75aeaaa3a8d991 +Subproject 1dcefaddc52d968b20bb6107d620e1e0c683997 |