diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2025-10-14 v1.14.0.0 + * Support GHC 9.14.1 2025-01-21 v1.12.0.0 * Harmonise layout processing so we do not have a special case for the top level This is a breaking change, in that the hand-crafted diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,12 +1,12 @@ cabal-version: 2.4 name: ghc-exactprint -version: 1.12.0.0 +version: 1.14.0.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 9.2.1, this library provides a means to round trip any code that can be compiled by GHC, currently excluding lhs files. . - Note: requires GHC 9.12.*. For earlier GHC + Note: requires GHC 9.14.*. For earlier GHC versions see lower version numbers. . @@ -16,12 +16,13 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 9.12.1 +tested-with: GHC == 9.14.1 extra-doc-files: ChangeLog extra-source-files: tests/examples/failing/*.hs tests/examples/failing/*.hs.bad tests/examples/ghc910/*.hs tests/examples/ghc912/*.hs + tests/examples/ghc914/*.hs tests/examples/pre-ghc910/*.hs tests/examples/pre-ghc910/*.hs-boot tests/examples/transform/*.hs @@ -55,10 +56,10 @@ , Language.Haskell.GHC.ExactPrint.Utils hs-source-dirs: src - build-depends: base >=4.21 && <4.22 - , containers >= 0.5 && < 0.8 - , ghc >= 9.12 && < 9.13 - , ghc-boot >= 9.12 && < 9.13 + build-depends: base >=4.22 && <4.23 + , containers >= 0.5 && < 0.9 + , ghc >= 9.14 && < 9.15 + , ghc-boot >= 9.14 && < 9.15 , mtl >= 2.2.1 && < 2.5 , syb >= 0.5 && < 0.8 @@ -82,25 +83,23 @@ , Test.Transform GHC-Options: -threaded Default-language: Haskell2010 - Build-depends: base < 4.22 + Build-depends: base < 4.23 , HUnit >= 1.2 , containers >= 0.5 , Diff , directory >= 1.2 - , extra , filepath >= 1.4 - , ghc >= 9.12 + , ghc >= 9.14 , ghc-paths >= 0.1 , syb >= 0.5 , silently >= 1.2 , ghc-boot - -- , os-string >= 2.0.2 if flag (dev) build-depends: mtl >= 2.2.1 else build-depends: ghc-exactprint - if impl (ghc < 9.12) + if impl (ghc < 9.14) buildable: False executable roundtrip @@ -110,18 +109,18 @@ other-modules: Test.Common Test.CommonUtils default-language: Haskell2010 - if impl (ghc >= 9.12) && flag (roundtrip) + if impl (ghc >= 9.14) && flag (roundtrip) build-depends: HUnit < 1.7 - , base < 4.22 - , containers < 0.8 + , base < 4.23 + , containers < 0.9 , directory < 1.4 - , extra < 1.8 + , extra < 1.9 , filepath < 1.6 - , ghc >= 9.12 && < 9.13 + , ghc >= 9.14 && < 9.15 , ghc-exactprint , ghc-paths < 0.2 - , time < 1.13 + , time < 1.16 , ghc-boot buildable: True else @@ -135,12 +134,12 @@ other-modules: Test.CommonUtils default-language: Haskell2010 if flag (roundtrip) - build-depends: base < 4.22 + build-depends: base < 4.23 , directory < 1.4 - , extra < 1.8 + , extra < 1.9 , filepath < 1.6 - , ghc >= 9.12 && < 9.13 - , Diff < 0.6 + , ghc >= 9.14 && < 9.15 + , Diff < 1.1 buildable: True else buildable: False diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -56,7 +56,6 @@ import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic - import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Control.Monad (forM, when, unless) @@ -322,10 +321,6 @@ trailing _ = [] setTrailing a _ = a -instance HasTrailing (Maybe EpAnnUnboundVar) where - trailing _ = [] - setTrailing a _ = a - instance HasTrailing GrhsAnn where trailing _ = [] setTrailing a _ = a @@ -334,7 +329,7 @@ trailing _ = [] setTrailing a _ = a -instance HasTrailing HsRuleAnn where +instance HasTrailing HsRuleBndrsAnn where trailing _ = [] setTrailing a _ = a @@ -551,7 +546,6 @@ else return [] !trailing' <- markTrailing trailing_anns addCommentsA following - debugM $ "enterAnn:done:(anchor,priorCs,postCs) =" ++ show (showAst anchor', priorCs, postCs) -- Update original anchor, comments based on the printing process -- TODO:AZ: probably need to put something appropriate in instead of noSrcSpan @@ -811,10 +805,8 @@ c' <- markEpUniToken c return (set l (ListBanana o c') a) ListNone -> return (set l ListNone a) --- ------------------------------------- --- markEpTokenM :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) --- => Maybe (EpToken tok) -> EP w m (Maybe (EpToken tok)) +-- ------------------------------------- markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) => EpToken tok -> EP w m (EpToken tok) @@ -841,25 +833,6 @@ -- --------------------------------------------------------------------- -markArrow :: (Monad m, Monoid w, ExactPrint a) => HsArrowOf a GhcPs -> EP w m (HsArrowOf a GhcPs) -markArrow (HsUnrestrictedArrow arr) = do - arr' <- markEpUniToken arr - return (HsUnrestrictedArrow arr') -markArrow (HsLinearArrow (EpPct1 pct1 arr)) = do - pct1' <- markEpToken pct1 - arr' <- markEpUniToken arr - return (HsLinearArrow (EpPct1 pct1' arr')) -markArrow (HsLinearArrow (EpLolly arr)) = do - arr' <- markEpToken arr - return (HsLinearArrow (EpLolly arr')) -markArrow (HsExplicitMult (pct, arr) t) = do - pct' <- markEpToken pct - t' <- markAnnotated t - arr' <- markEpUniToken arr - return (HsExplicitMult (pct', arr') t') - --- --------------------------------------------------------------------- - markAnnOpen' :: (Monad m, Monoid w) => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt @@ -968,6 +941,7 @@ -- { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword -- , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively -- , importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword +-- , importDeclAnnLevel :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword -- , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword -- , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) -- , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword @@ -985,6 +959,10 @@ limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) (k (importDeclAnnSafe annImp)) +limportDeclAnnLevel :: Lens EpAnnImportDecl (Maybe EpAnnLevel) +limportDeclAnnLevel k annImp = fmap (\new -> annImp { importDeclAnnLevel = new }) + (k (importDeclAnnLevel annImp)) + limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe (EpToken "qualified")) limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) (k (importDeclAnnQualified annImp)) @@ -1145,17 +1123,15 @@ -- --------------------------------------------------------------------- --- data HsRuleAnn --- = HsRuleAnn --- { ra_tyanns :: Maybe (TokForall, EpToken ".") --- , ra_tmanns :: Maybe (TokForall, EpToken ".") --- , ra_equal :: EpToken "=" --- , ra_rest :: ActivationAnn --- } deriving (Data, Eq) +-- data HsRuleBndrsAnn +-- = HsRuleBndrsAnn +-- { rb_tyanns :: Maybe (TokForall, EpToken ".") +-- , rb_tmanns :: Maybe (TokForall, EpToken ".") +-- } -lra_tyanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken ".")) -lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new }) - (k (ra_tyanns parent)) +lrb_tyanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken ".")) +lrb_tyanns k parent = fmap (\new -> parent { rb_tyanns = new }) + (k (rb_tyanns parent)) ff :: Maybe (a,b) -> (Maybe a,Maybe b) ff Nothing = (Nothing, Nothing) @@ -1172,30 +1148,21 @@ (k (ff parent)) -- (.) :: Lens' a b -> Lens' b c -> Lens' a c -lra_tyanns_fst :: Lens HsRuleAnn (Maybe TokForall) -lra_tyanns_fst = lra_tyanns . lff . lfst - -lra_tyanns_snd :: Lens HsRuleAnn (Maybe (EpToken ".")) -lra_tyanns_snd = lra_tyanns . lff . lsnd - -lra_tmanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken ".")) -lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new }) - (k (ra_tmanns parent)) - -lra_tmanns_fst :: Lens HsRuleAnn (Maybe TokForall) -lra_tmanns_fst = lra_tmanns . lff . lfst +lrb_tyanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall) +lrb_tyanns_fst = lrb_tyanns . lff . lfst -lra_tmanns_snd :: Lens HsRuleAnn (Maybe (EpToken ".")) -lra_tmanns_snd = lra_tmanns . lff . lsnd +lrb_tyanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken ".")) +lrb_tyanns_snd = lrb_tyanns . lff . lsnd -lra_equal :: Lens HsRuleAnn (EpToken "=") -lra_equal k parent = fmap (\new -> parent { ra_equal = new }) - (k (ra_equal parent)) +lrb_tmanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken ".")) +lrb_tmanns k parent = fmap (\new -> parent { rb_tmanns = new }) + (k (rb_tmanns parent)) -lra_rest :: Lens HsRuleAnn ActivationAnn -lra_rest k parent = fmap (\new -> parent { ra_rest = new }) - (k (ra_rest parent)) +lrb_tmanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall) +lrb_tmanns_fst = lrb_tmanns . lff . lfst +lrb_tmanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken ".")) +lrb_tmanns_snd = lrb_tmanns . lff . lsnd -- --------------------------------------------------------------------- -- data GrhsAnn @@ -1502,6 +1469,11 @@ setAnnotationAnchor ma _ _ _ = ma exact ma = mapM markAnnotated ma +instance (ExactPrint a) => ExactPrint (NonEmpty a) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor ls _ _ _ = ls + exact ls = mapM markAnnotated ls + -- --------------------------------------------------------------------- -- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' @@ -1642,7 +1614,7 @@ = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc ts cs} } exact (ImportDecl (XImportDeclPass ann msrc impl) - modname mpkg src safeflag qualFlag mAs hiding) = do + modname mpkg src st safeflag qualFlag mAs hiding) = do ann0 <- markLensFun' ann limportDeclAnnImport markEpToken let (EpAnn _anc an _cs) = ann0 @@ -1662,9 +1634,15 @@ printStringAtLsDelta (SameLine 1) "#-}" return Nothing NoSourceText -> return (importDeclAnnPragma an) + -- pre level + ann0' <- case st of + LevelStylePre _ -> markLensFun' ann0 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann0 + + ann1 <- if safeflag - then markLensFun' ann0 limportDeclAnnSafe (\mt -> mapM markEpToken mt) - else return ann0 + then markLensFun' ann0' limportDeclAnnSafe (\mt -> mapM markEpToken mt) + else return ann0' ann2 <- case qualFlag of QualifiedPre -- 'qualified' appears in prepositive position. @@ -1677,11 +1655,16 @@ _ -> return ann2 modname' <- markAnnotated modname + -- post level + ann3' <- case st of + LevelStylePost _ -> markLensFun' ann3 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann3 + ann4 <- case qualFlag of QualifiedPost -- 'qualified' appears in postpositive position. - -> markLensFun' ann3 limportDeclAnnQualified (\ml -> mapM markEpToken ml) - _ -> return ann3 + -> markLensFun' ann3' limportDeclAnnQualified (\ml -> mapM markEpToken ml) + _ -> return ann3' (importDeclAnnAs', mAs') <- case mAs of @@ -1704,8 +1687,11 @@ } return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) - modname' mpkg src safeflag qualFlag mAs' hiding') + modname' mpkg src st safeflag qualFlag mAs' hiding') +markEpAnnLevel :: (Monad m, Monoid w) => EpAnnLevel -> EP w m EpAnnLevel +markEpAnnLevel (EpAnnLevelSplice tok) = EpAnnLevelSplice <$> markEpToken tok +markEpAnnLevel (EpAnnLevelQuote tok) = EpAnnLevelQuote <$> markEpToken tok -- --------------------------------------------------------------------- @@ -2016,33 +2002,14 @@ getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do + exact (HsRule ((ann_act, ann_eq),nsrc) (L ln n) act bndrs lhs rhs) = do (L ln' _) <- markAnnotated (L ln (nsrc, n)) - an0 <- markActivationL an lra_rest act - (an1, mtybndrs') <- - case mtybndrs of - Nothing -> return (an0, Nothing) - Just bndrs -> do - an1 <- markLensFun an0 lra_tyanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall - bndrs' <- mapM markAnnotated bndrs - an2 <- markLensFun an1 lra_tyanns_snd (\mt -> mapM markEpToken mt) -- AnnDot - return (an2, Just bndrs') - - an2 <- markLensFun an1 lra_tmanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall - termbndrs' <- mapM markAnnotated termbndrs - an3 <- markLensFun an2 lra_tmanns_snd (\mt -> mapM markEpToken mt) -- AnnDot - + ann_act' <- markActivation ann_act act + bndrs' <- markAnnotated bndrs lhs' <- markAnnotated lhs - an4 <- markLensFun an3 lra_equal markEpToken + ann_eq' <- markEpToken ann_eq rhs' <- markAnnotated rhs - return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs') - - -markActivationL :: (Monad m, Monoid w) - => a -> Lens a ActivationAnn -> Activation -> EP w m a -markActivationL a l act = do - new <- markActivation (view l a) act - return (set l new a) + return (HsRule ((ann_act', ann_eq'),nsrc) (L ln' n) act bndrs' lhs' rhs') markActivation :: (Monad m, Monoid w) => ActivationAnn -> Activation -> EP w m ActivationAnn @@ -2113,6 +2080,26 @@ -- --------------------------------------------------------------------- +instance ExactPrint (RuleBndrs GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (RuleBndrs an0 mtybndrs termbndrs) = do + (an2, mtybndrs') <- + case mtybndrs of + Nothing -> return (an0, Nothing) + Just bndrs -> do + an1 <- markLensFun an0 lrb_tyanns_fst (traverse markEpUniToken) -- AnnForall + bndrs' <- mapM markAnnotated bndrs + an2 <- markLensFun an1 lrb_tyanns_snd (traverse markEpToken) -- AnnDot + return (an2, Just bndrs') + + an3 <- markLensFun an2 lrb_tmanns_fst (traverse markEpUniToken) -- AnnForall + termbndrs' <- mapM markAnnotated termbndrs + an4 <- markLensFun an3 lrb_tmanns_snd (traverse markEpToken) -- AnnDot + return (RuleBndrs an4 mtybndrs' termbndrs') + +-- --------------------------------------------------------------------- + instance ExactPrint (RuleBndr GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a @@ -2323,8 +2310,7 @@ return (FunBind x fun_id' matches') exact (PatBind x pat q grhss) = do - q' <- markAnnotated q - pat' <- markAnnotated pat + (q', pat') <- markMultAnnOf q (markAnnotated pat) grhss' <- markAnnotated grhss return (PatBind x pat' q' grhss') exact (PatSynBind x bind) = do @@ -2333,19 +2319,6 @@ exact x = error $ "HsBind: exact for " ++ showAst x -instance ExactPrint (HsMultAnn GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsNoMultAnn x) = return (HsNoMultAnn x) - exact (HsPct1Ann tok) = do - tok' <- markEpToken tok - return (HsPct1Ann tok') - exact (HsMultAnn tok ty) = do - tok' <- markEpToken tok - ty' <- markAnnotated ty - return (HsMultAnn tok' ty') - -- --------------------------------------------------------------------- instance ExactPrint (PatSynBind GhcPs GhcPs) where @@ -2364,11 +2337,10 @@ psyn' <- markAnnotated psyn v2' <- markAnnotated v2 return (ao, ac, psyn',InfixCon v1' v2') - PrefixCon tvs vs -> do + PrefixCon vs -> do psyn' <- markAnnotated psyn - tvs' <- markAnnotated tvs vs' <- markAnnotated vs - return (ao, ac, psyn', PrefixCon tvs' vs') + return (ao, ac, psyn', PrefixCon vs') RecCon vs -> do psyn' <- markAnnotated psyn ao' <- mapM markEpToken ao @@ -2677,11 +2649,19 @@ o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE act' <- markActivation act (inl_act inl) ln' <- markAnnotated ln - dc' <- markEpUniToken dc + dc' <- traverse markEpUniToken dc typs' <- markAnnotated typs c' <- markEpToken c return (SpecSig (AnnSpecSig o' c' dc' act') ln' typs' inl) + exact (SpecSigE (AnnSpecSig o c dc act) bndrs expr inl) = do + o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + act' <- markActivation act (inl_act inl) + bndrs' <- markAnnotated bndrs + expr' <- markAnnotated expr + c' <- markEpToken c + return (SpecSigE (AnnSpecSig o' c' dc act') bndrs' expr' inl) + exact (SpecInstSig ((o,i,c),src) typ) = do o' <- markAnnOpen'' o src "{-# SPECIALISE" i' <- markEpToken i @@ -2760,8 +2740,8 @@ exact (DefaultDecl (d,op,cp) cl tys) = do d' <- markEpToken d - op' <- markEpToken op cl' <- markAnnotated cl + op' <- markEpToken op tys' <- markAnnotated tys cp' <- markEpToken cp return (DefaultDecl (d',op',cp') cl' tys') @@ -2793,7 +2773,7 @@ -- --------------------------------------------------------------------- -instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where +instance ExactPrint (BF.BooleanFormula GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a @@ -2865,16 +2845,14 @@ then markAnnotated n else return n return (HsVar x n') - exact (HsUnboundVar an n) = do - case an of - Just (EpAnnUnboundVar (ob,cb) l) -> do - ob' <- markEpToken ob - l' <- markEpToken l - cb' <- markEpToken cb - return (HsUnboundVar (Just (EpAnnUnboundVar (ob',cb') l')) n) - _ -> do - printStringAdvanceA "_" >> return () - return (HsUnboundVar an n) + exact (HsHole (HoleVar n)) = do + let pun_RDR = "pun-right-hand-side" + n' <- if (showPprUnsafe n /= pun_RDR) + then markAnnotated n + else return n + return (HsHole (HoleVar n')) + -- TODO: Adapt 'HoleError' to include the 'SourceText': + exact (HsHole HoleError) = error "Cannot exact print HoleError" exact x@(HsOverLabel src l) = do printStringAdvanceA "#" >> return () case src of @@ -3117,9 +3095,8 @@ return (HsUntypedBracket a (VarBr an0 b e')) exact (HsTypedSplice an s) = do - an0 <- markEpToken an s' <- markAnnotated s - return (HsTypedSplice an0 s') + return (HsTypedSplice an s') exact (HsUntypedSplice an s) = do s' <- markAnnotated s @@ -3149,8 +3126,7 @@ return (HsEmbTy toktype' t') exact (HsFunArr _ mult arg res) = do - arg' <- markAnnotated arg - mult' <- markArrow mult + (mult', arg') <- markMultAnnOf mult (markAnnotated arg) res' <- markAnnotated res return (HsFunArr noExtField mult' arg' res') @@ -3214,7 +3190,17 @@ c' <- markEpToken c return (HsPragSCC (AnnPragma o' c' s l1' l2 t m,st) sl) +instance ExactPrint (HsTypedSplice GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsTypedSpliceExpr an e) = do + an0 <- markEpToken an + e' <- markAnnotated e + return (HsTypedSpliceExpr an0 e') + + -- --------------------------------------------------------------------- instance ExactPrint (HsUntypedSplice GhcPs) where @@ -3958,8 +3944,7 @@ ki' <- markAnnotated ki return (HsAppKindTy at' ty' ki') exact (HsFunTy an mult ty1 ty2) = do - ty1' <- markAnnotated ty1 - mult' <- markArrow mult + (mult', ty1') <- markMultAnnOf mult (markAnnotated ty1) ty2' <- markAnnotated ty2 return (HsFunTy an mult' ty1' ty2') exact (HsListTy an tys) = do @@ -4008,22 +3993,10 @@ exact (HsDocTy an ty doc) = do ty' <- markAnnotated ty return (HsDocTy an ty' doc) - exact (HsBangTy ((o,c,tk), mt) (HsBang up str) ty) = do - (o',c') <- - case mt of - NoSourceText -> return (o,c) - SourceText src -> do - debugM $ "HsBangTy: src=" ++ showAst src - o' <- printStringAtAA o (unpackFS src) - c' <- markEpToken c - return (o',c') - tk' <- - case str of - SrcLazy -> printStringAtAA tk "~" - SrcStrict -> printStringAtAA tk "!" - NoSrcStrict -> return tk + exact (XHsType (HsBangTy ann (HsSrcBang mt up str) ty)) = do + (ann', mt') <- exactBang (ann, mt) str ty' <- markAnnotated ty - return (HsBangTy ((o',c',tk'), mt) (HsBang up str) ty') + return (XHsType (HsBangTy ann' (HsSrcBang mt' up str) ty')) exact (HsExplicitListTy (sq,o,c) prom tys) = do sq' <- if (isPromoted prom) then markEpToken sq @@ -4318,11 +4291,10 @@ con' <- markAnnotated con t2' <- markAnnotated t2 return (con', InfixCon t1' t2') - exact_details (PrefixCon tyargs tys) = do + exact_details (PrefixCon tys) = do con' <- markAnnotated con - tyargs' <- markAnnotated tyargs tys' <- markAnnotated tys - return (con', PrefixCon tyargs' tys') + return (con', PrefixCon tys') exact_details (RecCon fields) = do con' <- markAnnotated con fields' <- markAnnotated fields @@ -4332,7 +4304,8 @@ exact (ConDeclGADT { con_g_ext = AnnConDeclGADT ops cps dcol , con_names = cons - , con_bndrs = bndrs + , con_outer_bndrs = outer_bndrs + , con_inner_bndrs = inner_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) = do cons' <- mapM markAnnotated cons @@ -4341,10 +4314,12 @@ epTokensToComments ")" cps -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 - bndrs' <- case bndrs of - L _ (HsOuterImplicit _) -> return bndrs - _ -> markAnnotated bndrs + outer_bndrs' <- case outer_bndrs of + L _ (HsOuterImplicit _) -> return outer_bndrs + _ -> markAnnotated outer_bndrs + inner_bndrs' <- mapM markAnnotated inner_bndrs + mcxt' <- mapM markAnnotated mcxt args' <- case args of @@ -4358,7 +4333,8 @@ res_ty' <- markAnnotated res_ty return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' , con_names = cons' - , con_bndrs = bndrs' + , con_outer_bndrs = outer_bndrs' + , con_inner_bndrs = inner_bndrs' , con_mb_cxt = mcxt', con_g_args = args' , con_res_ty = res_ty', con_doc = doc }) @@ -4387,15 +4363,14 @@ -- --------------------------------------------------------------------- -instance ExactPrint (ConDeclField GhcPs) where +instance ExactPrint (HsConDeclRecField GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (ConDeclField td names ftype mdoc) = do + exact (HsConDeclRecField _ names ftype) = do names' <- markAnnotated names - td' <- markEpUniToken td ftype' <- markAnnotated ftype - return (ConDeclField td' names' ftype' mdoc) + return (HsConDeclRecField noExtField names' ftype') -- --------------------------------------------------------------------- @@ -4408,14 +4383,61 @@ -- --------------------------------------------------------------------- -instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where +instance ExactPrint (HsConDeclField GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (HsScaled arr t) = do - t' <- markAnnotated t - arr' <- markArrow arr - return (HsScaled arr' t') + exact cdf@(CDF { cdf_ext, cdf_bang, cdf_multiplicity, cdf_type }) = do + (mult, (an, t)) <- markMultAnnOf cdf_multiplicity ((,) <$> exactBang cdf_ext cdf_bang <*> markAnnotated cdf_type) + return (cdf { cdf_ext = an, cdf_multiplicity = mult, cdf_type = t }) +markMultAnnOf :: (Monad m, Monoid w, ExactPrint a) => HsMultAnnOf a GhcPs -> EP w m b -> EP w m (HsMultAnnOf a GhcPs, b) +markMultAnnOf (HsUnannotated arrOrCol) tyM = do + ((), arrOrCol', ty') <- markArrOrCol (pure ()) arrOrCol tyM + return (HsUnannotated arrOrCol', ty') +markMultAnnOf (HsLinearAnn (EpPct1 pct1 arrOrCol)) tyM = do + (pct1', arrOrCol', ty') <- markArrOrCol (markEpToken pct1) arrOrCol tyM + return (HsLinearAnn (EpPct1 pct1' arrOrCol'), ty') +markMultAnnOf (HsLinearAnn (EpLolly arr)) tyM = do + ty' <- tyM + arr' <- markEpToken arr + return (HsLinearAnn (EpLolly arr'), ty') +markMultAnnOf (HsExplicitMult (pct, arrOrCol) t) tyM = do + ((pct', t'), arrOrCol', ty') <- markArrOrCol ((,) <$> markEpToken pct <*> markAnnotated t) arrOrCol tyM + return (HsExplicitMult (pct', arrOrCol') t', ty') + +markArrOrCol :: (Monad m, Monoid w) => EP w m a -> EpArrowOrColon -> EP w m b -> EP w m (a, EpArrowOrColon, b) +markArrOrCol multM (EpArrow arr) tyM = do + ty' <- tyM + mult' <- multM + arr' <- markEpUniToken arr + return (mult', EpArrow arr', ty') +markArrOrCol multM (EpColon col) tyM = do + mult' <- multM + col' <- markEpUniToken col + ty' <- tyM + return (mult', EpColon col', ty') +markArrOrCol multM EpPatBind patM = do + mult' <- multM + pat' <- patM + return (mult', EpPatBind, pat') + +exactBang :: (Monoid w, Monad m) => XConDeclField GhcPs -> SrcStrictness -> EP w m (XConDeclField GhcPs) +exactBang ((o,c,tk), mt) str = do + (o',c') <- + case mt of + NoSourceText -> return (o,c) + SourceText src -> do + debugM $ "HsBangTy: src=" ++ showAst src + o' <- printStringAtAA o (unpackFS src) + c' <- markEpToken c + return (o',c') + tk' <- + case str of + SrcLazy -> printStringAtAA tk "~" + SrcStrict -> printStringAtAA tk "!" + NoSrcStrict -> return tk + return ((o',c',tk'), mt) + -- --------------------------------------------------------------------- instance ExactPrint (LocatedP CType) where @@ -4507,15 +4529,15 @@ an1 <- markLensBracketsC an0 lal_brackets return (L an1 es') -instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where +instance ExactPrint (LocatedL [LocatedA (HsConDeclRecField GhcPs)]) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn exact (L an fs) = do - debugM $ "LocatedL [LConDeclField" + debugM $ "LocatedL [LHsConDeclRecField" (an', fs') <- markAnnList an (markAnnotated fs) return (L an' fs') -instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where +instance ExactPrint (LocatedL (BF.BooleanFormula GhcPs)) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn exact (L an bf) = do @@ -4606,6 +4628,10 @@ r' <- markEpToken r n' <- markAnnotated n return (IEType r' n') + exact (IEData r n) = do + r' <- markEpToken r + n' <- markAnnotated n + return (IEData r' n') -- --------------------------------------------------------------------- @@ -4768,8 +4794,6 @@ HsWord16Prim src v -> toSourceTextWithSuffix src v "" HsWord32Prim src v -> toSourceTextWithSuffix src v "" HsWord64Prim src v -> toSourceTextWithSuffix src v "" - HsInteger src v _ -> toSourceTextWithSuffix src v "" - HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl "" HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#" HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##" @@ -4798,20 +4822,11 @@ close' <- mapM markEpToken close return ((open', close'), c', details') -instance ExactPrint (HsConPatTyArg GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (HsConPatTyArg at tyarg) = do - at' <- markEpToken at - tyarg' <- markAnnotated tyarg - return (HsConPatTyArg at' tyarg') - exactConArgs :: (Monad m, Monoid w) => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) -exactConArgs (PrefixCon tyargs pats) = do - tyargs' <- markAnnotated tyargs +exactConArgs (PrefixCon pats) = do pats' <- markAnnotated pats - return (PrefixCon tyargs' pats') + return (PrefixCon pats') exactConArgs (InfixCon p1 p2) = do p1' <- markAnnotated p1 p2' <- markAnnotated p2 diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs --- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs @@ -348,12 +348,14 @@ -- Based on GHC backpack driver doBackPack dflags0 <- GHC.getSessionDynFlags let parser_opts0 = GHC.initParserOpts dflags0 - (_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 file - (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts + logger <- GHC.getLogger + (_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 (GHC.supportedLanguagePragmas dflags0) file + (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 src_opts -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Prevent parsing of .ghc.environment.* "package environment files" (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine + logger dflags2 [GHC.noLoc "-hide-all-packages"] _ <- GHC.setSessionDynFlags dflags3 @@ -375,13 +377,15 @@ -- as long as `parseDynamicFilePragma` is impure there seems to be -- no reason to use it. dflags0 <- GHC.getSessionDynFlags + logger <- GHC.getLogger let parser_opts0 = GHC.initParserOpts dflags0 - let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.stringToStringBuffer $ s) fp - (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo + let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.supportedLanguagePragmas dflags0) (GHC.stringToStringBuffer $ s) fp + (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 pragmaInfo -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Prevent parsing of .ghc.environment.* "package environment files" (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine + logger dflags2 [GHC.noLoc "-hide-all-packages"] _ <- GHC.setSessionDynFlags dflags3 diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs --- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs @@ -96,6 +96,8 @@ import GHC.Types.SrcLoc import Data.Data +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Generics @@ -259,7 +261,7 @@ where -- I suspect we should assume the comments are already in the -- right place, and just set the entry DP for this case. This - -- avoids suprises from the caller. + -- avoids surprises from the caller. (d', csd', cs') = case cs of EpaComments (h:t) -> let @@ -473,9 +475,8 @@ move = map snd move' stay = map snd stay' (l'', grhss', binds', _logInfo) - = case reverse grhss of - [] -> (l, [], binds, (EpaComments [], noSrcSpanA)) - (L lg (GRHS ag grs rhs):gs) -> + = case NE.reverse grhss of + L lg (GRHS ag grs rhs):|gs -> let anc1' = setFollowingComments anc1 stay an1' = setCommentsEpAnn l anc1' @@ -490,7 +491,7 @@ then EpAnn anc an lgc' else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move)) - in (an1', (reverse $ (L lg (GRHS ag' grs rhs):gs)), bindsm, (anc1',an1')) + in (an1', (NE.reverse $ L lg (GRHS ag' grs rhs):|gs), bindsm, (anc1',an1')) pushTrailingComments :: WithWhere -> EpAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs) pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b) @@ -698,9 +699,8 @@ = (L la' (Match anm mctxt pats (GRHSs x grhss' lb))) where simpleBreak n (r,_) = r > n - (la',grhss', _logInfo) = case reverse grhss of - [] -> (la,grhss,[]) - (L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))]) + (la',grhss', _logInfo) = case NE.reverse grhss of + L lg (GRHS ga gs rhs):|grs -> (la'',NE.reverse $ L lg (GRHS ga' gs rhs):|grs,[(gac,(csp,csf))]) where anc1 = comments la (EpAnn anc an _) = ga :: EpAnn GrhsAnn @@ -771,7 +771,6 @@ oldDecls = hsDecls t oldDeclsb = balanceCommentsList oldDecls oldDecls' = oldDeclsb - `debug` ("insertAt: oldDeclsb:" ++ showAst oldDeclsb) -- |Insert a declaration at the beginning or end of the subdecls of the given -- AST item diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -28,26 +28,26 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC910 - | GHC912 +data GHCVersion = GHC912 + | GHC914 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion -#if MIN_VERSION_ghc(9,12,0) -ghcVersion = GHC912 +#if MIN_VERSION_ghc(9,14,0) +ghcVersion = GHC914 #else -ghcVersion = GHC910 +ghcVersion = GHC912 #endif -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs = case ghcVersion of - GHC910 -> ["pre-ghc910", "ghc910"] GHC912 -> ["pre-ghc910", "ghc910", "ghc912"] - -- GHC912 -> ["ghc912"] - -- GHC912 -> ["ghc912-copied"] - -- GHC912 -> ["ghc912", "ghc912-copied"] + GHC914 -> ["pre-ghc910", "ghc910", "ghc912", "ghc914"] + -- GHC914 -> ["ghc914"] + -- GHC914 -> ["ghc914-copied"] + -- GHC914 -> ["ghc914", "ghc914-copied"] -- --------------------------------------------------------------------- @@ -214,9 +214,12 @@ -- mkParserTest libdir "ghc912" "tests.hs" -- mkParserTestMD libdir "ghc912" "Fff.hs" -- mkParserTestMD libdir "transform" "AddLocalDecl5.hs" - mkParserTestBC libdir "transform" "AddLocalDecl5.hs" + -- mkParserTestBC libdir "transform" "AddLocalDecl5.hs" -- mkParserTestMD libdir "ghc912" "Module.hs" -- mkParserTestMD libdir "ghc912" "Operator.hs" + + -- mkParserTest libdir "pre-ghc910" "AnnPackageName.hs" + mkParserTestMD libdir "pre-ghc910" "AnnPackageName.hs" -- Needs GHC changes diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -129,7 +129,7 @@ case res of Left m -> return . Left $ ParseFailure (showErrorMessages m) - Right (injectedComments, dflags, pmod) -> do + Right (!injectedComments, !dflags, !pmod) -> do (printed', pmod') <- GHC.liftIO (runRoundTrip libdir f pmod injectedComments) let useCpp = GHC.xopt LangExt.Cpp dflags printed = trimPrinted printed' @@ -186,7 +186,7 @@ -- putStrLn $ "comments:" ++ showAst cs let !parsedOrigWithComments = insertCppComments parsedOrig cs -- putStrLn $ "parsedOrigWithComments:" ++ showAst parsedOrigWithComments - pmod <- f libdir parsedOrigWithComments + !pmod <- f libdir parsedOrigWithComments let !printed = exactPrint pmod return (printed, pmod) diff --git a/tests/Test/CommonUtils.hs b/tests/Test/CommonUtils.hs --- a/tests/Test/CommonUtils.hs +++ b/tests/Test/CommonUtils.hs @@ -22,7 +22,7 @@ ) where import Control.Monad -import Control.Monad.Extra +import GHC.Utils.Monad import Data.List hiding (find) import qualified GHC.Data.StringBuffer as GHC import System.Directory diff --git a/tests/examples/ghc914/A.8.hs b/tests/examples/ghc914/A.8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/A.8.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NamedDefaults #-} +module A ( + Stringify(..), + default Stringify, + Bingify(..), + default Bingify + ) where + +class Stringify a where + stringify :: a -> String + +instance Stringify Int where + stringify n = "Int" + +instance Stringify Bool where + stringify b = "Bool" + +instance Stringify [Char] where + stringify s = "String" + +class Bingify a where + bingify :: a -> String + +instance Bingify Int where + bingify n = "Int" + +instance Bingify Bool where + bingify b = "Bool" + +instance Bingify [Char] where + bingify s = "String" + +default Stringify (Int) +default Bingify (Int) + diff --git a/tests/examples/ghc914/SI01.hs b/tests/examples/ghc914/SI01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/SI01.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI01 where + +-- Using a splice imported thing, inside an untyped and typed splice works +import splice SI01A + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) + diff --git a/tests/examples/ghc914/SI26.hs b/tests/examples/ghc914/SI26.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/SI26.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module SI26 where + +-- Test using 'quote' as a post-qualifier in imports +import Prelude quote +import Prelude quote qualified as P +import quote Prelude qualified as P2 + +-- Test using 'splice' as a post-qualifier in imports +import Language.Haskell.TH.Syntax splice + +import splice Language.Haskell.TH.Syntax qualified as TH +import Language.Haskell.TH.Syntax splice qualified as TH2 + +-- Use the imported modules +testQuote = [| id |] +testQuote2 = [| P.id |] +testQuote3 = [| P2.id |] + +testSplice = $(lift "Hello from splice") +testSplice2 = $(TH.lift "Hello from splice2") +testSplice3 = $(TH2.lift "Hello from splice3") +