ghc-exactprint 1.12.1.0 → 1.14.3.0
raw patch · 43 files changed
Files
- ChangeLog +12/−2
- ghc-exactprint.cabal +22/−22
- src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +223/−200
- src/Language/Haskell/GHC/ExactPrint/Parsers.hs +8/−4
- src/Language/Haskell/GHC/ExactPrint/Transform.hs +268/−11
- tests/Test.hs +13/−10
- tests/Test/Common.hs +2/−2
- tests/Test/CommonUtils.hs +1/−1
- tests/Test/Transform.hs +84/−2
- tests/examples/ghc914/A.8.hs +35/−0
- tests/examples/ghc914/ArrowDoSemi.hs +12/−0
- tests/examples/ghc914/SI01.hs +10/−0
- tests/examples/ghc914/SI26.hs +28/−0
- tests/examples/transform/AddCaseClauses1.hs +2/−0
- tests/examples/transform/AddCaseClauses1.hs.expected +3/−0
- tests/examples/transform/AddCaseClauses2.hs +2/−0
- tests/examples/transform/AddCaseClauses2.hs.expected +3/−0
- tests/examples/transform/AddCaseClauses3.hs +1/−0
- tests/examples/transform/AddCaseClauses3.hs.expected +2/−0
- tests/examples/transform/AddCaseClauses4.hs +2/−0
- tests/examples/transform/AddCaseClauses4.hs.expected +3/−0
- tests/examples/transform/ArrowGraft.hs +17/−0
- tests/examples/transform/ArrowGraft.hs.expected +20/−0
- tests/examples/transform/DecBracketBracesGraft.hs +7/−0
- tests/examples/transform/DecBracketBracesGraft.hs.expected +8/−0
- tests/examples/transform/DecBracketGraft.hs +7/−0
- tests/examples/transform/DecBracketGraft.hs.expected +8/−0
- tests/examples/transform/GadtRename.hs +5/−0
- tests/examples/transform/GadtRename.hs.expected +5/−0
- tests/examples/transform/InstanceGraft.hs +8/−0
- tests/examples/transform/InstanceGraft.hs.expected +10/−0
- tests/examples/transform/LambdaRename.hs +14/−0
- tests/examples/transform/LambdaRename.hs.expected +14/−0
- tests/examples/transform/LetFirstGraft.hs +21/−0
- tests/examples/transform/LetFirstGraft.hs.expected +24/−0
- tests/examples/transform/MultiwayIfGraft.hs +8/−0
- tests/examples/transform/MultiwayIfGraft.hs.expected +9/−0
- tests/examples/transform/PatSynGraft.hs +7/−0
- tests/examples/transform/PatSynGraft.hs.expected +8/−0
- tests/examples/transform/RecGraft.hs +8/−0
- tests/examples/transform/RecGraft.hs.expected +9/−0
- tests/examples/transform/TypeFamilyRename.hs +5/−0
- tests/examples/transform/TypeFamilyRename.hs.expected +5/−0
ChangeLog view
@@ -1,5 +1,15 @@-2026-09-22 v1.12.1.0- * Fix space leak in the EP monad: use CPS RWST and a chunked writer (#152, @xich)+Unreleased+2026-10-06 v1.14.3.0+ * Constructing GADT decls using hand-crafted+ different line deltas will be printed at a different column. (#156, @simonhorlick)+ * Take `appendMissingPats` over from HLS (#148, @Aster89)+2026-09-21 v1.14.2.0+ * Fix space leak in the EP monad: use CPS RWST and a chunked writer (#150, @xich)+2026-08-06 v1.14.1.0+ * Add layout processing for HsLam+ * Establish a layout offset for class and instance bodies (@simonhorlick)+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.1.0+version: 1.14.3.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,11 @@ , 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+ , extra+ , ghc >= 9.14 && < 9.15+ , ghc-boot >= 9.14 && < 9.15 , mtl >= 2.3 && < 2.5 , syb >= 0.5 && < 0.8 @@ -82,25 +84,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 +110,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 +135,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)@@ -338,10 +337,6 @@ trailing _ = [] setTrailing a _ = a -instance HasTrailing (Maybe EpAnnUnboundVar) where- trailing _ = []- setTrailing a _ = a- instance HasTrailing GrhsAnn where trailing _ = [] setTrailing a _ = a@@ -350,7 +345,7 @@ trailing _ = [] setTrailing a _ = a -instance HasTrailing HsRuleAnn where+instance HasTrailing HsRuleBndrsAnn where trailing _ = [] setTrailing a _ = a @@ -567,7 +562,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@@ -827,10 +821,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)@@ -857,25 +849,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@@ -984,6 +957,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@@ -1001,6 +975,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))@@ -1161,17 +1139,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)@@ -1188,30 +1164,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@@ -1467,6 +1434,11 @@ markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a +markLamMatches :: (Monad m, Monoid w, ExactPrint ast) => HsLamVariant -> ast -> EP w m ast+markLamMatches LamSingle = markAnnotated+markLamMatches LamCase = markAnnotatedWithLayout+markLamMatches LamCases = markAnnotatedWithLayout+ -- --------------------------------------------------------------------- -- End of utility functions -- ---------------------------------------------------------------------@@ -1518,6 +1490,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'@@ -1658,7 +1635,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@@ -1678,9 +1655,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.@@ -1693,11 +1676,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@@ -1720,8 +1708,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 -- --------------------------------------------------------------------- @@ -2032,33 +2023,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@@ -2129,6 +2101,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@@ -2246,7 +2238,7 @@ (mbWarn', i', w', mbOverlap', inst_ty') <- top_matter oc' <- markEpToken oc semis' <- mapM markEpToken semis- (sortKey', ds) <- withSortKey sortKey+ (sortKey', ds) <- setLayoutBoth $ withSortKey sortKey [(ClsAtTag, prepareListAnnotationA ats), (ClsAtdTag, prepareListAnnotationF adts), (ClsMethodTag, prepareListAnnotationA binds),@@ -2339,8 +2331,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@@ -2349,19 +2340,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@@ -2380,11 +2358,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@@ -2693,11 +2670,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@@ -2776,8 +2761,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')@@ -2809,7 +2794,7 @@ -- --------------------------------------------------------------------- -instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where+instance ExactPrint (BF.BooleanFormula GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a @@ -2881,16 +2866,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@@ -2921,7 +2904,7 @@ LamSingle -> return an0 LamCase -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml) LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml)- mg' <- markAnnotated mg+ mg' <- markLamMatches lam_variant mg return (HsLam an1 lam_variant mg') exact (HsApp an e1 e2) = do@@ -2987,7 +2970,7 @@ an0 <- markLensFun an lhsCaseAnnCase markEpToken e' <- markAnnotated e an1 <- markLensFun an0 lhsCaseAnnOf markEpToken- alts' <- setLayoutBoth $ markAnnotated alts+ alts' <- markAnnotatedWithLayout alts return (HsCase an1 e' alts') exact (HsIf an e1 e2 e3) = do@@ -3004,14 +2987,14 @@ exact (HsMultiIf (i,o,c) mg) = do i0 <- markEpToken i o0 <- markEpToken o- mg' <- markAnnotated mg+ mg' <- markAnnotatedWithLayout mg c0 <- markEpToken c return (HsMultiIf (i0,o0,c0) mg') exact (HsLet (tkLet, tkIn) binds e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too tkLet' <- markEpToken tkLet- binds' <- setLayoutBoth $ markAnnotated binds+ binds' <- markAnnotatedWithLayout binds tkIn' <- markEpToken tkIn e' <- markAnnotated e return (HsLet (tkLet',tkIn') binds' e')@@ -3109,7 +3092,10 @@ exact (HsUntypedBracket a (DecBrL (o,c, (oc,cc)) e)) = do o' <- markEpToken o oc' <- markEpToken oc- e' <- markAnnotated e+ -- explicit braces don't open a layout context+ e' <- case oc of+ NoEpTok -> markAnnotatedWithLayout e+ EpTok{} -> markAnnotated e cc' <- markEpToken cc c' <- markEpUniToken c return (HsUntypedBracket a (DecBrL (o',c',(oc',cc')) e'))@@ -3133,9 +3119,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@@ -3165,8 +3150,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') @@ -3230,7 +3214,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@@ -3445,7 +3439,7 @@ LamSingle -> return an0 LamCase -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml) LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml)- matches' <- markAnnotated matches+ matches' <- markLamMatches lam_variant matches return (HsCmdLam an1 lam_variant matches') exact (HsCmdPar (lpar, rpar) e) = do@@ -3458,7 +3452,7 @@ an0 <- markLensFun an lhsCaseAnnCase markEpToken e' <- markAnnotated e an1 <- markLensFun an0 lhsCaseAnnOf markEpToken- alts' <- markAnnotated alts+ alts' <- markAnnotatedWithLayout alts return (HsCmdCase an1 e' alts') exact (HsCmdIf an a e1 e2 e3) = do@@ -3475,16 +3469,15 @@ exact (HsCmdLet (tkLet, tkIn) binds e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too tkLet' <- markEpToken tkLet- binds' <- setLayoutBoth $ markAnnotated binds+ binds' <- markAnnotatedWithLayout binds tkIn' <- markEpToken tkIn e' <- markAnnotated e return (HsCmdLet (tkLet', tkIn') binds' e') exact (HsCmdDo an es) = do debugM $ "HsCmdDo"- an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do")- es' <- markAnnotated es- return (HsCmdDo an0 es')+ (an', es') <- markAnnListA' an $ \a -> exactDo a (DoExpr Nothing) es+ return (HsCmdDo an' es') -- --------------------------------------------------------------------- @@ -3534,7 +3527,7 @@ exact (RecStmt an stmts a b c d e) = do debugM $ "RecStmt" an0 <- markLensFun an lal_rest markEpToken- (an1, stmts') <- markAnnList' an0 (markAnnotated stmts)+ (an1, stmts') <- markAnnList' an0 (markAnnotatedWithLayout stmts) return (RecStmt an1 stmts' a b c d e) -- ---------------------------------------------------------------------@@ -3636,7 +3629,7 @@ (c', w', vb', fds', lclas', tyvars',context') <- top_matter oc' <- markEpToken oc semis' <- mapM markEpToken semis- (sortKey', ds) <- withSortKey sortKey+ (sortKey', ds) <- setLayoutBoth $ withSortKey sortKey [(ClsSigTag, prepareListAnnotationA sigs), (ClsMethodTag, prepareListAnnotationA methods), (ClsAtTag, prepareListAnnotationA ats),@@ -3723,7 +3716,7 @@ dd' <- markEpToken dd return (dd', mb_eqns) Just eqns -> do- eqns' <- markAnnotated eqns+ eqns' <- markAnnotatedWithLayout eqns return (dd, Just eqns') cc' <- markEpToken cc return (w',oc',dd',cc', ClosedTypeFamily mb_eqns')@@ -3974,8 +3967,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@@ -4024,22 +4016,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@@ -4278,7 +4258,7 @@ exact_condecls eq cs | gadt_syntax -- In GADT syntax = do- cs' <- mapM markAnnotated cs+ cs' <- markAnnotatedWithLayout cs return (eq, cs') | otherwise -- In H98 syntax = do@@ -4334,11 +4314,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@@ -4348,7 +4327,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@@ -4357,10 +4337,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@@ -4374,7 +4356,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 }) @@ -4403,15 +4386,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') -- --------------------------------------------------------------------- @@ -4424,14 +4406,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@@ -4493,7 +4522,11 @@ an0 <- markLensFun' an lal_rest markEpToken an1 <- markLensBracketsO an0 lal_brackets an2 <- markEpAnnAllLT an1 lal_semis- a' <- markAnnotated a+ -- in an explicitly bidirectional pattern synonym, a match list introduced+ -- by its own 'where', is a layout block+ a' <- case al_rest (anns an) of+ EpTok{} -> markAnnotatedWithLayout a+ NoEpTok -> markAnnotated a an3 <- markLensBracketsC an2 lal_brackets return (L an3 a') @@ -4518,20 +4551,18 @@ setAnnotationAnchor = setAnchorAn exact (L ann es) = do debugM $ "LocatedL [CmdLStmt"- an0 <- markLensBracketsO ann lal_brackets- es' <- mapM markAnnotated es- an1 <- markLensBracketsC an0 lal_brackets- return (L an1 es')+ (an', es') <- markAnnList ann (mapM markAnnotated es)+ return (L an' 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@@ -4622,6 +4653,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') -- --------------------------------------------------------------------- @@ -4784,8 +4819,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 "##" @@ -4814,20 +4847,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@@ -4889,15 +4913,14 @@ setLayoutBoth k = do oldLHS <- getLayoutOffsetD oldAnchorOffset <- getLayoutOffsetP+ EPState{dMarkLayout = dPending, pMarkLayout = pPending} <- get debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) modify' (\a -> a { dMarkLayout = True , pMarkLayout = True } ) let reset = do debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset)- modify' (\a -> a { dMarkLayout = False- , dLHS = oldLHS- , pMarkLayout = False- , pLHS = oldAnchorOffset} )+ unless dPending $ modify' (\a -> a { dMarkLayout = False, dLHS = oldLHS })+ unless pPending $ modify' (\a -> a { pMarkLayout = False, pLHS = oldAnchorOffset }) k <* reset ------------------------------------------------------------------------
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
@@ -1,7 +1,10 @@+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -83,6 +86,11 @@ , transferEntryDP' , wrapSig, wrapDecl , decl2Sig, decl2Bind++ -- * Appending patterns to case expressions+ , appendMissingPats+ , Matches(..)+ , MatchLayout(..) ) where import Language.Haskell.GHC.ExactPrint.Types@@ -96,10 +104,17 @@ import GHC.Types.SrcLoc import Data.Data-import Data.Maybe+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty.Extra ((|:))+import Data.Function (on, (&))+import Data.Functor.Identity import Data.Generics+import Data.List.Extra (chunksOf, dropEnd, takeEnd)+import Data.Maybe+import Data.Semigroup (sconcat) -import Data.Functor.Identity+import Control.Applicative (ZipList(ZipList), getZipList) import Control.Monad.State ------------------------------------------------------------------------------@@ -259,7 +274,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 +488,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 +504,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 +712,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 +784,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@@ -1182,3 +1194,248 @@ let decls = hsDecls t decls' <- action decls return $ replaceDecls t decls'++-- | Isomorphic to @'Maybe' 'Matches'@, this type encodes whether a @case@-like+-- expression has braces; if it does, the type also records whether there are+-- pre-existing matches.+data MatchLayout = NonBraced | Braced Matches++-- | Isomorphic to @Maybe Int@, this type encodes whether there are+-- pre-existing matches in a @case@-like expression **with braces**, and - if+-- there are - what's the indentation of the first of them.+--+-- Note: it could also model the same concept for the non-braced case, but that's+-- not needed (see also 'MatchLayout').+data Matches = NoMatches | SomeMatches !Int++-- | Given a 'MatchGroup' and a 'NonEmpty' list of 'LMatch'es, this function+-- inserts the latter matches in the former group, honor the existing+-- 'MatchLayout', returning the new 'MatchGroup'.+--+-- For the meaning of the first argument of type @Maybe Int@, see+-- 'getIndentation'.+--+-- Honoring the existing layout means two things:+--+-- 1. producing valid code, which means:+--+-- - adding semicolons wherever they are needed, i.e.+--+-- - if matches are braced, for every matches,+--+-- - otherwise, for all but the last matches for groups of matches+-- that are not aligned vertically, e.g.+--+-- - matches shown on the same line, which this plugin can produce,+--+-- - matches shown on different lines but in a "staircase" way,+-- which this plugin never produces).+--+-- - using the correct indentation when matches are not braced (when+-- matches are braced, the code will stay valid irrespective of the+-- indentation of the alternatives).+--+-- 2. such valid code tries to adhere to the existing layout, which means:+--+-- - don't alter position of existing matches nor of the opening @{@;+--+-- - when matches are not braced, we align the first match we insert+-- with the pre-existing previous match+--+-- - we have to make some arbitrary decision+--+-- - when matches are not braced and no previous match exists,+-- we indent by @indentation def@ with respect to whatever layout+-- context is the current one;+--+-- - as regards the number of matches to print per line, we inspect the+-- last group of matches appearing on one line, to determine how many+-- matches per line we insert.+--+-- - when matches are braced, we also align them vertically (it would+-- not be necessary, in principle).+--+--+-- Refer to test cases to see practical examples.+appendMissingPats :: MatchGroup GhcPs (LHsExpr GhcPs)+ -> NonEmpty (LMatch GhcPs (LHsExpr GhcPs))+ -> MatchLayout+ -> MatchGroup GhcPs (LHsExpr GhcPs)+appendMissingPats mg@(MG { mg_alts = L altsLoc existingMatches }) missingMatches matchLayout+ = let -- Choose how many patterns per line we are emitting:+ chunkSize = case existingMatches of+ [] -> 1 -- trivially 1 if there's no existing matches,+ -- otherwise, set the size equal to the length+ -- of the last group of @existingMatches@ that+ -- are on the same line:+ _ -> NE.length+ $ NE.last+ $ NE.groupBy1 startSameLine (NE.fromList existingMatches)++ -- Chunkify the matches to be inserted:+ missingGroup :| missingGroups = prettyChunksOf chunkSize missingMatches++ -- Detect if the list of alternatives is between @{@ and @}@:+ isBraced = isJust $ getOpeningBraceCol altsLoc++ -- Finally, lay out the missing matches:+ missingMatchesEP = -- indent the first group and the following ones (see discussion above)+ mapFirst indentHead missingGroup :| map (mapFirst indentTail) missingGroups+ -- add a semicolon to the end of each group only if the alternatives are braced+ & (if isBraced then addSemicols else id)+ -- put each group on its own line+ & NE.map (mapFirst putOnNewLine)+ -- concatenate the groups+ & sconcat+ -- turn into an ordinary list+ & NE.toList+ where+ -- add semicolons:+ addSemicols = NE.zipWith ($)+ -- for each one-line group of matches,+ (replicate (length missingGroups)+ -- only to the last match of the group,+ (mapLast addSemiCol)+ -- except for the last group+ |: id)++ -- Indentation is complicated.+ --+ -- For a non-braced @case@-like expression, the first match **of the+ -- whole expression** (I mean, not the first match **to be inserted**)+ -- has some anchor that depends on the surrounding code, while the+ -- following matches all use their own predecessor as the anchor.+ --+ -- Otherwise (i.e. for a braced @case@-like expression), all matches+ -- including the first one have the same anchor that depends on the+ -- surrounding code.+ --+ -- Therefore, here's how we set the DeltaPos for the first and+ -- following matches:+ (setDPCol -> indentHead, setDPCol -> indentTail)+ = case matchLayout of+ NonBraced | null existingMatches -> (indentation def, 0)+ NonBraced -> (0, 0)+ Braced (SomeMatches indent) -> (indent, indent)+ Braced NoMatches -> let indent = indentation def+ in (indent, indent)++ -- Only if there's braces do we need to make sure the last of the+ -- existing matches ends with @;@:+ existingMatchesEP = if isBraced+ then dropEnd 1 existingMatches <> (addSemiCol <$> takeEnd 1 existingMatches)+ else existingMatches++ in mg { mg_alts = L altsLoc (existingMatchesEP <> missingMatchesEP) }++-- | Accepts a @NonEmpty (LocatedA a)@ and chunkifies it by the given 'size',+-- putting all matches of each chunk on the same line, leaving 1 space in between, and+-- keeping the code valid by adding semicolons to all but the last match of each chunk.+prettyChunksOf :: Int -> NonEmpty (LocatedA a) -> NonEmpty (NonEmpty (LocatedA a))+prettyChunksOf size allMatches = do+ -- For each chunk+ chunk <- chunksOf1 size allMatches+ pure $ fromZipList+ $ do -- of all the matches of chunk+ match <- toZipList chunk+ -- from the second match onwards, they go the same line, one space apart+ putBeside <- toZipList $ id :| repeat (setDP 0 1)+ -- all but the last match get a semicolon+ addSemicols <- toZipList $ replicate (length chunk - 1) addSemiCol |: id+ -- apply+ pure $ addSemicols $ putBeside match+ where+ toZipList = ZipList . NE.toList+ fromZipList = NE.fromList . getZipList++-- Other things that we could store here are:+--+-- - the maximum number of alternatives on one line+-- - whether or not to put the @;@ for the last alternative+data Default = Default {+ -- | Max number of underscores to show for the constructor of an alternative.+ -- Beyond this, the record syntax with empty braces is used.+ maxUnderscores :: Int+ -- | Indentation used when there's no existing alternatives to refer to.+ -- Such indentation is with respect to the current layout context.+, indentation :: Int+}++def :: Default+def = Default { maxUnderscores = 3+ , indentation = 2 }++-- | Predicate telling if two located annotations are (actually, start) on the+-- same line.+startSameLine :: LocatedAn ann e -> LocatedAn ann e -> Bool+startSameLine = (==) `on` getStartLine+ where+ -- | Get the starting line of an 'HasSrcSpan'.+ getStartLine :: GHC.LocatedAn ann e -> Int+ getStartLine = srcSpanStartLine . realSrcSpan . getHasLoc+++-- | Given an @EpAnn (AnnList a)@ return the starting column of+-- its opening brace, if any, otherwise 'Nothing'.+getOpeningBraceCol :: EpAnn (AnnList a) -> Maybe Int+getOpeningBraceCol (EpAnn _ (AnnList _ (ListBraces (EpTok col) _) _ _ _) _) = Just $ getStartCol $ getHasLoc col+getOpeningBraceCol _ = Nothing++-- | Get the starting column of an 'HasSrcSpan'.+getStartCol :: SrcSpan -> Int+getStartCol = srcSpanStartCol . realSrcSpan . getHasLoc++-- | Set the DeltaPos for the given annotation.+setDP :: Int -> Int -> LocatedAn t a -> LocatedAn t a+setDP deltaLine deltaColumn lann = setEntryDP lann $ deltaPos deltaLine deltaColumn++-- | Set the deltaColumn for the given annotation.+setDPCol :: Int -> LocatedAn t a -> LocatedAn t a+setDPCol deltaColumn lann = setEntryDP lann+ $ (\d -> deltaPos (getDeltaLine d) deltaColumn)+ $ getEntryDP lann++-- | Set the deltaLine for the given annotation.+setDPLine :: Int -> LocatedAn t a -> LocatedAn t a+setDPLine deltaLine lann = setEntryDP lann+ $ (\d -> deltaPos deltaLine (deltaColumn d))+ $ getEntryDP lann++-- | Useful helper.+putOnNewLine :: LocatedAn t a -> LocatedAn t a+putOnNewLine = setDPLine 1++-- | Add semicolon, unless one is already present.+addSemiCol :: LocatedA a -> LocatedA a+addSemiCol (L l@(EpAnn _ ls _) e)+ | none isSemiCol (lann_trailing ls)+ = L (addTrailingAnnToA (AddSemiAnn (EpTok d0)) emptyComments l) e+ where+ isSemiCol :: TrailingAnn -> Bool+ isSemiCol (AddSemiAnn _) = True+ isSemiCol _ = False+addSemiCol l = l++-- | Version of 'Data.List.Extra.chunksOf' (**not** to be confused with+-- 'Data.List.Split.chunksOf') for a 'NonEmpty' lists.+chunksOf1 :: Int -> NonEmpty a -> NonEmpty (NonEmpty a)+chunksOf1 n xs+ | n >= 1+ , (b:before, after) <- NE.splitAt n xs+ = (b :| before) :| case after of+ [] -> []+ _ -> map NE.fromList $ chunksOf n after+ | otherwise = error "chunksOf1: the `Int` argument should be ≥ 1"++-- | Maps a function @f@ over the first element of a 'NonEmpty' list.+mapFirst :: (a -> a) -> NonEmpty a -> NonEmpty a+mapFirst f (a :| as) = f a :| as++-- | Maps a function @f@ over the last element of a 'NonEmpty' list.+mapLast :: (a -> a) -> NonEmpty a -> NonEmpty a+mapLast f (a :| []) = f a :| []+mapLast f (a :| b : cs) = a :| NE.toList (mapLast f $ b :| cs)++-- | Convenient negation of 'any'.+none :: Foldable t => (a -> Bool) -> t a -> Bool+none p xs = not $ any p xs
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/Test/Transform.hs view
@@ -12,7 +12,7 @@ import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Utils -import GHC as GHC+import GHC as GHC hiding (parseExpr) import GHC.Data.FastString as GHC import GHC.Types.Name.Occurrence as GHC import GHC.Types.Name.Reader as GHC@@ -21,6 +21,7 @@ import System.FilePath import Data.List+import qualified Data.List.NonEmpty as NE import Test.Common @@ -29,7 +30,11 @@ transformTestsTT :: LibDir -> Test transformTestsTT libdir = TestLabel "transformTestsTT" $ TestList [- mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs"+ -- mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs"+ mkTestModChange libdir (addCaseClauses NonBraced) "AddCaseClauses1.hs"+ , mkTestModChange libdir (addCaseClauses (Braced (SomeMatches 1))) "AddCaseClauses2.hs"+ , mkTestModChange libdir (addCaseClauses NonBraced) "AddCaseClauses3.hs"+ , mkTestModChange libdir (addCaseClauses (Braced (SomeMatches 0))) "AddCaseClauses4.hs" ] transformTests :: LibDir -> Test@@ -62,6 +67,17 @@ , mkTestModChange libdir changeLocalDecls2 "LocalDecls2.hs" , mkTestModChange libdir changeWhereIn3a "WhereIn3a.hs" , mkTestModChange libdir changeWhereIn3b "WhereIn3b.hs"+ , mkTestModChange libdir changeGraft "InstanceGraft.hs"+ , mkTestModChange libdir changeGraft "MultiwayIfGraft.hs"+ , mkTestModChange libdir changeGraft "RecGraft.hs"+ , mkTestModChange libdir changeGraft "ArrowGraft.hs"+ , mkTestModChange libdir changeGraft "LetFirstGraft.hs"+ , mkTestModChange libdir changeGraft "PatSynGraft.hs"+ , mkTestModChange libdir changeGraft "DecBracketGraft.hs"+ , mkTestModChange libdir changeGraft "DecBracketBracesGraft.hs"+ , mkTestModChange libdir changeGadtRename "GadtRename.hs"+ , mkTestModChange libdir changeTypeFamilyRename "TypeFamilyRename.hs"+ , mkTestModChange libdir changeLambdaRename "LambdaRename.hs" -- , mkTestModChange changeCifToCase "C.hs" "C" ] @@ -102,6 +118,21 @@ -- --------------------------------------------------------------------- +-- | Replace instances of @graft@ with an expression that spans two lines. This+-- tests what indentation the printer uses (and whether the correct layout is+-- followed).+changeGraft :: Changer+changeGraft libdir top = do+ Right parsed <- withDynFlags libdir (\df -> parseExpr df "graft" "a\n + b")+ let graft = makeDeltaAst parsed+ replace :: LHsExpr GhcPs -> LHsExpr GhcPs+ replace x@(L _ (HsVar _ (L _ n)))+ | occNameString (rdrNameOcc n) == "graft" = transferEntryDP x graft+ replace x = x+ return (everywhere (mkT replace) (makeDeltaAst top))++-- ---------------------------------------------------------------------+ changeWhereIn3b :: Changer changeWhereIn3b _libdir (L l p) = do let decls0 = hsmodDecls p@@ -200,6 +231,15 @@ changeRenameCase2 :: Changer changeRenameCase2 _libdir parsed = return (rename "fooLonger" [((3,1),(3,4))] parsed) +changeGadtRename :: Changer+changeGadtRename _libdir parsed = return (rename "Tlonger" [((4,6),(4,7)),((4,21),(4,22)),((5,21),(5,22))] parsed)++changeTypeFamilyRename :: Changer+changeTypeFamilyRename _libdir parsed = return (rename "Flonger" [((4,13),(4,14)),((4,23),(4,24)),((5,23),(5,24))] parsed)++changeLambdaRename :: Changer+changeLambdaRename _libdir parsed = return (rename "l" [((7,14),(7,24)),((12,30),(12,40))] parsed)+ changeLayoutLet2 :: Changer changeLayoutLet2 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed) @@ -303,6 +343,14 @@ , mkTestModChange libdir addHiding2 "AddHiding2.hs" , mkTestModChange libdir cloneDecl1 "CloneDecl1.hs"++ -- TODO: I should add some test also for:+ -- without braces, no existing patterns+ -- with braces, no existing patterns+ , mkTestModChange libdir (addCaseClauses NonBraced) "AddCaseClauses1.hs"+ , mkTestModChange libdir (addCaseClauses (Braced (SomeMatches 1))) "AddCaseClauses2.hs"+ , mkTestModChange libdir (addCaseClauses NonBraced) "AddCaseClauses3.hs"+ , mkTestModChange libdir (addCaseClauses (Braced (SomeMatches 0))) "AddCaseClauses4.hs" ] -- ---------------------------------------------------------------------@@ -648,5 +696,39 @@ let lp' = doChange return lp'++-- ---------------------------------------------------------------------++addCaseClauses :: MatchLayout -> Changer+addCaseClauses layout _libdir lp = do+ pure $ case lp of+ -- TODO Probably the following can improve using lenses+ L a hsmod@HsModule { hsmodDecls = [L b (SpliceD c (SpliceDecl d (L e (HsUntypedSpliceExpr f (L g (HsCase h i mg)))) j))] }+ -> let m' = case mg of+ -- for the test where there's 1 existing match+ MG { mg_alts = L _ [L _ m] } -> m+ -- for the test where there's no existing matches+ MG { mg_alts = L _ [] } -> underscoreToUnderscore+ _ -> error "Unexpected input code and/or AST structure"++ -- Apply the 'appendMissingPats' function to be tested:+ mg' = appendMissingPats mg (NE.singleton (L noAnn m')) layout++ in L a hsmod{ hsmodDecls = [L b (SpliceD c (SpliceDecl d (L e (HsUntypedSpliceExpr f (L g (HsCase h i mg')))) j))] }+ _ -> error "Unexpected input code and/or AST structure"+ where+ underscoreToUnderscore+ = Match { m_ext = NoExtField+ , m_ctxt = CaseAlt+ , m_pats = L noSrcSpanA [nlWildPat]+ , m_grhss = GRHSs emptyComments+ (NE.singleton $ L noSrcSpanA $ GRHS (EpAnn noSrcSpanA+ (GrhsAnn{ ga_vbar = Nothing+ , ga_sep = Right $ EpUniTok d1 NormalSyntax })+ emptyComments)+ []+ $ L noSrcSpanA $ HsHole $ HoleVar $ L noAnnSrcSpanDP1 $ unnamedHoleRdrName)+ (EmptyLocalBinds NoExtField)+ } -- ---------------------------------------------------------------------
+ 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/ArrowDoSemi.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE Arrows #-}+module ArrowDoSemi where++import Control.Arrow++f :: Arrow k => k Int Int+f = proc x -> do { ; y <- returnA -< x ; returnA -< y }++g :: ArrowLoop k => k Int Int+g = proc x -> do { ; y <- returnA -< x+ ; rec { ; z <- returnA -< y }+ ; returnA -< z }
+ 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")+
+ tests/examples/transform/AddCaseClauses1.hs view
@@ -0,0 +1,2 @@+case a of+ b -> c
+ tests/examples/transform/AddCaseClauses1.hs.expected view
@@ -0,0 +1,3 @@+case a of+ b -> c+ b -> c
+ tests/examples/transform/AddCaseClauses2.hs view
@@ -0,0 +1,2 @@+case a of { b -> c+ }
+ tests/examples/transform/AddCaseClauses2.hs.expected view
@@ -0,0 +1,3 @@+case a of { b -> c;+ b -> c+ }
+ tests/examples/transform/AddCaseClauses3.hs view
@@ -0,0 +1,1 @@+case a of
+ tests/examples/transform/AddCaseClauses3.hs.expected view
@@ -0,0 +1,2 @@+case a of+ _ -> _
+ tests/examples/transform/AddCaseClauses4.hs view
@@ -0,0 +1,2 @@+case a of+ {}
+ tests/examples/transform/AddCaseClauses4.hs.expected view
@@ -0,0 +1,3 @@+case a of+ {+ _ -> _}
+ tests/examples/transform/ArrowGraft.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE LambdaCase #-}+module ArrowGraft where++import Control.Arrow++f :: Arrow k => k (Int, Int) Int+f = proc (a, b) -> do+ returnA -< graft++g :: ArrowChoice k => k (Bool, Int, Int) Int+g = proc (x, a, b) -> case x of+ True -> returnA -< graft++h :: ArrowChoice k => k (Bool, Int, Int) Int+h = proc (x, a, b) -> (\case+ True -> returnA -< graft) x
+ tests/examples/transform/ArrowGraft.hs.expected view
@@ -0,0 +1,20 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE LambdaCase #-}+module ArrowGraft where++import Control.Arrow++f :: Arrow k => k (Int, Int) Int+f = proc (a, b) -> do+ returnA -< a+ + b++g :: ArrowChoice k => k (Bool, Int, Int) Int+g = proc (x, a, b) -> case x of+ True -> returnA -< a+ + b++h :: ArrowChoice k => k (Bool, Int, Int) Int+h = proc (x, a, b) -> (\case+ True -> returnA -< a+ + b) x
+ tests/examples/transform/DecBracketBracesGraft.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+module DecBracketBracesGraft where++ds = graft [d| { f = x+ where+ x = 1+ ; g = 2 } |]
+ tests/examples/transform/DecBracketBracesGraft.hs.expected view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}+module DecBracketBracesGraft where++ds = a+ + b [d| { f = x+ where+ x = 1+ ; g = 2 } |]
+ tests/examples/transform/DecBracketGraft.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TemplateHaskell #-}+module DecBracketGraft where++ds = [d|+ f a b = graft+ g = 1+ |]
+ tests/examples/transform/DecBracketGraft.hs.expected view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}+module DecBracketGraft where++ds = [d|+ f a b = a+ + b+ g = 1+ |]
+ tests/examples/transform/GadtRename.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE GADTs #-}+module GadtRename where++data T where MkA :: T+ MkB :: T
+ tests/examples/transform/GadtRename.hs.expected view
@@ -0,0 +1,5 @@+{-# LANGUAGE GADTs #-}+module GadtRename where++data Tlonger where MkA :: Tlonger+ MkB :: Tlonger
+ tests/examples/transform/InstanceGraft.hs view
@@ -0,0 +1,8 @@+module InstanceGraft where++class C t where+ go :: t -> Int+ go n = graft++instance C Int where+ go n = graft
+ tests/examples/transform/InstanceGraft.hs.expected view
@@ -0,0 +1,10 @@+module InstanceGraft where++class C t where+ go :: t -> Int+ go n = a+ + b++instance C Int where+ go n = a+ + b
+ tests/examples/transform/LambdaRename.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE Arrows #-}+module LambdaRename where++import Control.Arrow++f :: IO Int+f = return 1 `longname` \y ->+ do+ return y++g :: Arrow k => k Int Int+g = proc x -> (returnA -< x) `longname` \y ->+ do+ returnA -< y
+ tests/examples/transform/LambdaRename.hs.expected view
@@ -0,0 +1,14 @@+{-# LANGUAGE Arrows #-}+module LambdaRename where++import Control.Arrow++f :: IO Int+f = return 1 `l` \y ->+ do+ return y++g :: Arrow k => k Int Int+g = proc x -> (returnA -< x) `l` \y ->+ do+ returnA -< y
+ tests/examples/transform/LetFirstGraft.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RecursiveDo #-}+module LetFirstGraft where++import Control.Arrow++f :: Int -> Int -> IO Int+f a b = do+ let z = a in return z+ return (graft)++g :: Int -> Int -> IO Int+g a b = do+ rec let z = a in return z+ x <- return (graft)+ return x++h :: Arrow k => k (Int, Int) Int+h = proc (a, b) -> do+ let c = a in returnA -< c+ returnA -< graft
+ tests/examples/transform/LetFirstGraft.hs.expected view
@@ -0,0 +1,24 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RecursiveDo #-}+module LetFirstGraft where++import Control.Arrow++f :: Int -> Int -> IO Int+f a b = do+ let z = a in return z+ return (a+ + b)++g :: Int -> Int -> IO Int+g a b = do+ rec let z = a in return z+ x <- return (a+ + b)+ return x++h :: Arrow k => k (Int, Int) Int+h = proc (a, b) -> do+ let c = a in returnA -< c+ returnA -< a+ + b
+ tests/examples/transform/MultiwayIfGraft.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE MultiWayIf #-}+module MultiwayIfGraft where++checkNumber :: Int -> String+checkNumber x =+ if | x > 0 -> "Positive"+ | graft < 0 -> "Negative"+ | otherwise -> "Zero"
+ tests/examples/transform/MultiwayIfGraft.hs.expected view
@@ -0,0 +1,9 @@+{-# LANGUAGE MultiWayIf #-}+module MultiwayIfGraft where++checkNumber :: Int -> String+checkNumber x =+ if | x > 0 -> "Positive"+ | a+ + b < 0 -> "Negative"+ | otherwise -> "Zero"
+ tests/examples/transform/PatSynGraft.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module PatSynGraft where++pattern P :: Int -> Int+pattern P x <- (subtract 1 -> x) where+ P a = graft
+ tests/examples/transform/PatSynGraft.hs.expected view
@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+module PatSynGraft where++pattern P :: Int -> Int+pattern P x <- (subtract 1 -> x) where+ P a = a+ + b
+ tests/examples/transform/RecGraft.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE RecursiveDo #-}+module RecGraft where++g :: Int -> Int -> IO Int+g a b = do+ rec x <- return (graft)+ y <- return x+ return y
+ tests/examples/transform/RecGraft.hs.expected view
@@ -0,0 +1,9 @@+{-# LANGUAGE RecursiveDo #-}+module RecGraft where++g :: Int -> Int -> IO Int+g a b = do+ rec x <- return (a+ + b)+ y <- return x+ return y
+ tests/examples/transform/TypeFamilyRename.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+module TypeFamilyRename where++type family F a where F Int = Bool+ F a = a
+ tests/examples/transform/TypeFamilyRename.hs.expected view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+module TypeFamilyRename where++type family Flonger a where Flonger Int = Bool+ Flonger a = a