diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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 diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -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 diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs @@ -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 ------------------------------------------------------------------------ diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs --- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs @@ -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 diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -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) + } -- --------------------------------------------------------------------- diff --git a/tests/examples/ghc914/ArrowDoSemi.hs b/tests/examples/ghc914/ArrowDoSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/ArrowDoSemi.hs @@ -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 } diff --git a/tests/examples/transform/AddCaseClauses1.hs b/tests/examples/transform/AddCaseClauses1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses1.hs @@ -0,0 +1,2 @@ +case a of + b -> c diff --git a/tests/examples/transform/AddCaseClauses1.hs.expected b/tests/examples/transform/AddCaseClauses1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses1.hs.expected @@ -0,0 +1,3 @@ +case a of + b -> c + b -> c diff --git a/tests/examples/transform/AddCaseClauses2.hs b/tests/examples/transform/AddCaseClauses2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses2.hs @@ -0,0 +1,2 @@ +case a of { b -> c + } diff --git a/tests/examples/transform/AddCaseClauses2.hs.expected b/tests/examples/transform/AddCaseClauses2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses2.hs.expected @@ -0,0 +1,3 @@ +case a of { b -> c; + b -> c + } diff --git a/tests/examples/transform/AddCaseClauses3.hs b/tests/examples/transform/AddCaseClauses3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses3.hs @@ -0,0 +1,1 @@ +case a of diff --git a/tests/examples/transform/AddCaseClauses3.hs.expected b/tests/examples/transform/AddCaseClauses3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses3.hs.expected @@ -0,0 +1,2 @@ +case a of + _ -> _ diff --git a/tests/examples/transform/AddCaseClauses4.hs b/tests/examples/transform/AddCaseClauses4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses4.hs @@ -0,0 +1,2 @@ +case a of + {} diff --git a/tests/examples/transform/AddCaseClauses4.hs.expected b/tests/examples/transform/AddCaseClauses4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses4.hs.expected @@ -0,0 +1,3 @@ +case a of + { + _ -> _} diff --git a/tests/examples/transform/ArrowGraft.hs b/tests/examples/transform/ArrowGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/ArrowGraft.hs @@ -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 diff --git a/tests/examples/transform/ArrowGraft.hs.expected b/tests/examples/transform/ArrowGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/ArrowGraft.hs.expected @@ -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 diff --git a/tests/examples/transform/DecBracketBracesGraft.hs b/tests/examples/transform/DecBracketBracesGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/DecBracketBracesGraft.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module DecBracketBracesGraft where + +ds = graft [d| { f = x + where + x = 1 + ; g = 2 } |] diff --git a/tests/examples/transform/DecBracketBracesGraft.hs.expected b/tests/examples/transform/DecBracketBracesGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/DecBracketBracesGraft.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module DecBracketBracesGraft where + +ds = a + + b [d| { f = x + where + x = 1 + ; g = 2 } |] diff --git a/tests/examples/transform/DecBracketGraft.hs b/tests/examples/transform/DecBracketGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/DecBracketGraft.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module DecBracketGraft where + +ds = [d| + f a b = graft + g = 1 + |] diff --git a/tests/examples/transform/DecBracketGraft.hs.expected b/tests/examples/transform/DecBracketGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/DecBracketGraft.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module DecBracketGraft where + +ds = [d| + f a b = a + + b + g = 1 + |] diff --git a/tests/examples/transform/GadtRename.hs b/tests/examples/transform/GadtRename.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/GadtRename.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} +module GadtRename where + +data T where MkA :: T + MkB :: T diff --git a/tests/examples/transform/GadtRename.hs.expected b/tests/examples/transform/GadtRename.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/GadtRename.hs.expected @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} +module GadtRename where + +data Tlonger where MkA :: Tlonger + MkB :: Tlonger diff --git a/tests/examples/transform/InstanceGraft.hs b/tests/examples/transform/InstanceGraft.hs --- a/tests/examples/transform/InstanceGraft.hs +++ b/tests/examples/transform/InstanceGraft.hs @@ -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 diff --git a/tests/examples/transform/InstanceGraft.hs.expected b/tests/examples/transform/InstanceGraft.hs.expected --- a/tests/examples/transform/InstanceGraft.hs.expected +++ b/tests/examples/transform/InstanceGraft.hs.expected @@ -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 diff --git a/tests/examples/transform/LambdaRename.hs b/tests/examples/transform/LambdaRename.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LambdaRename.hs @@ -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 diff --git a/tests/examples/transform/LambdaRename.hs.expected b/tests/examples/transform/LambdaRename.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LambdaRename.hs.expected @@ -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 diff --git a/tests/examples/transform/LetFirstGraft.hs b/tests/examples/transform/LetFirstGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LetFirstGraft.hs @@ -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 diff --git a/tests/examples/transform/LetFirstGraft.hs.expected b/tests/examples/transform/LetFirstGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LetFirstGraft.hs.expected @@ -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 diff --git a/tests/examples/transform/MultiwayIfGraft.hs b/tests/examples/transform/MultiwayIfGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/MultiwayIfGraft.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MultiWayIf #-} +module MultiwayIfGraft where + +checkNumber :: Int -> String +checkNumber x = + if | x > 0 -> "Positive" + | graft < 0 -> "Negative" + | otherwise -> "Zero" diff --git a/tests/examples/transform/MultiwayIfGraft.hs.expected b/tests/examples/transform/MultiwayIfGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/MultiwayIfGraft.hs.expected @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiWayIf #-} +module MultiwayIfGraft where + +checkNumber :: Int -> String +checkNumber x = + if | x > 0 -> "Positive" + | a + + b < 0 -> "Negative" + | otherwise -> "Zero" diff --git a/tests/examples/transform/PatSynGraft.hs b/tests/examples/transform/PatSynGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/PatSynGraft.hs @@ -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 diff --git a/tests/examples/transform/PatSynGraft.hs.expected b/tests/examples/transform/PatSynGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/PatSynGraft.hs.expected @@ -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 diff --git a/tests/examples/transform/RecGraft.hs b/tests/examples/transform/RecGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RecGraft.hs @@ -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 diff --git a/tests/examples/transform/RecGraft.hs.expected b/tests/examples/transform/RecGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RecGraft.hs.expected @@ -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 diff --git a/tests/examples/transform/TypeFamilyRename.hs b/tests/examples/transform/TypeFamilyRename.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/TypeFamilyRename.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +module TypeFamilyRename where + +type family F a where F Int = Bool + F a = a diff --git a/tests/examples/transform/TypeFamilyRename.hs.expected b/tests/examples/transform/TypeFamilyRename.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/TypeFamilyRename.hs.expected @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +module TypeFamilyRename where + +type family Flonger a where Flonger Int = Bool + Flonger a = a