packages feed

ghc-exactprint 1.14.2.0 → 1.14.3.0

raw patch · 36 files changed

+618/−55 lines, 36 filesdep ~extraPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: extra

API changes (from Hackage documentation)

+ Language.Haskell.GHC.ExactPrint.Transform: Braced :: Matches -> MatchLayout
+ Language.Haskell.GHC.ExactPrint.Transform: NoMatches :: Matches
+ Language.Haskell.GHC.ExactPrint.Transform: NonBraced :: MatchLayout
+ Language.Haskell.GHC.ExactPrint.Transform: SomeMatches :: Int -> Matches
+ Language.Haskell.GHC.ExactPrint.Transform: appendMissingPats :: MatchGroup GhcPs (LHsExpr GhcPs) -> NonEmpty (LMatch GhcPs (LHsExpr GhcPs)) -> MatchLayout -> MatchGroup GhcPs (LHsExpr GhcPs)
+ Language.Haskell.GHC.ExactPrint.Transform: data MatchLayout
+ Language.Haskell.GHC.ExactPrint.Transform: data Matches

Files

ChangeLog view
@@ -1,3 +1,8 @@+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
ghc-exactprint.cabal view
@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                ghc-exactprint-version:             1.14.2.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@@ -58,6 +58,7 @@   hs-source-dirs:      src   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
src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs view
@@ -1434,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 -- ---------------------------------------------------------------------@@ -2899,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' <- setLayoutBoth $ markAnnotated mg+    mg' <- markLamMatches lam_variant mg     return (HsLam an1 lam_variant mg')    exact (HsApp an e1 e2) = do@@ -2965,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@@ -2982,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')@@ -3087,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'))@@ -3431,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@@ -3444,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@@ -3461,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')  -- --------------------------------------------------------------------- @@ -3520,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)  -- ---------------------------------------------------------------------@@ -3709,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')@@ -4251,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@@ -4515,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') @@ -4540,10 +4551,8 @@   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 (HsConDeclRecField GhcPs)]) where   getAnnotationEntry = entryFromLocatedA@@ -4904,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/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@@ -98,10 +106,15 @@ import Data.Data import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE-import Data.Maybe+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  ------------------------------------------------------------------------------@@ -1181,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/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,7 +21,7 @@  import System.FilePath import Data.List-import Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE  import Test.Common @@ -30,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@@ -63,7 +67,17 @@   , mkTestModChange libdir changeLocalDecls2 "LocalDecls2.hs"   , mkTestModChange libdir changeWhereIn3a   "WhereIn3a.hs"   , mkTestModChange libdir changeWhereIn3b   "WhereIn3b.hs"-  , mkTestModChange libdir changeInstanceGraft "InstanceGraft.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"   ] @@ -104,23 +118,18 @@  -- --------------------------------------------------------------------- --- | A delta-anchored expression grafted into a class or instance method--- must indent its continuation lines relative to the method declarations--- layout column.-changeInstanceGraft :: Changer-changeInstanceGraft _libdir top = do-  let lp = makeDeltaAst top-      grab :: HsBind GhcPs -> [LHsExpr GhcPs]-      grab FunBind{ fun_id = L _ n-                  , fun_matches = MG{mg_alts = L _ [L _ Match{m_grhss = GRHSs _ (L _ (GRHS _ _ e) :| []) _}]}}-        | occNameString (rdrNameOcc n) == "combine" = [e]-      grab _ = []-      [body] = everything (++) ([] `mkQ` grab) lp+-- | 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 (L _ (HsVar _ (L _ n)))-        | occNameString (rdrNameOcc n) == "todo" = setEntryDP body (SameLine 1)+      replace x@(L _ (HsVar _ (L _ n)))+        | occNameString (rdrNameOcc n) == "graft" = transferEntryDP x graft       replace x = x-  return (everywhere (mkT replace) lp)+  return (everywhere (mkT replace) (makeDeltaAst top))  -- --------------------------------------------------------------------- @@ -222,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) @@ -325,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"   ]  -- ---------------------------------------------------------------------@@ -670,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/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/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
@@ -1,12 +1,8 @@ module InstanceGraft where -combine :: Int -> Int -> Int-combine a b = a-  + b- class C t where   go :: t -> Int-  go n = todo+  go n = graft  instance C Int where-  go n = todo+  go n = graft
tests/examples/transform/InstanceGraft.hs.expected view
@@ -1,9 +1,5 @@ module InstanceGraft where -combine :: Int -> Int -> Int-combine a b = a-  + b- class C t where   go :: t -> Int   go n = a
+ 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