ghc-exactprint 1.12.0.0 → 1.14.0.0
raw patch · 11 files changed
+318/−223 lines, 11 filesdep ~Diffdep ~basedep ~containers
Dependency ranges changed: Diff, base, containers, extra, ghc, ghc-boot, time
Files
- ChangeLog +2/−0
- ghc-exactprint.cabal +21/−22
- src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +190/−175
- src/Language/Haskell/GHC/ExactPrint/Parsers.hs +8/−4
- src/Language/Haskell/GHC/ExactPrint/Transform.hs +8/−9
- tests/Test.hs +13/−10
- tests/Test/Common.hs +2/−2
- tests/Test/CommonUtils.hs +1/−1
- tests/examples/ghc914/A.8.hs +35/−0
- tests/examples/ghc914/SI01.hs +10/−0
- tests/examples/ghc914/SI26.hs +28/−0
ChangeLog view
@@ -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
ghc-exactprint.cabal view
@@ -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
src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs view
@@ -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
src/Language/Haskell/GHC/ExactPrint/Parsers.hs view
@@ -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
src/Language/Haskell/GHC/ExactPrint/Transform.hs view
@@ -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
tests/Test.hs view
@@ -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
tests/Test/Common.hs view
@@ -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)
tests/Test/CommonUtils.hs view
@@ -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
+ tests/examples/ghc914/A.8.hs view
@@ -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)+
+ tests/examples/ghc914/SI01.hs view
@@ -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 () ||])+
+ tests/examples/ghc914/SI26.hs view
@@ -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")+