diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,8 @@ # CHANGELOG +- 0.14.1.0 (2022-03-31) + * Unify the Editor modules, deal with overlap better + - 0.14.0.1 (2022-03-17) * Use GHC API directly if >= 9.2.2 * Bump `bytestring` upper bound to 0.12 diff --git a/lib/Language/Haskell/Stylish/Align.hs b/lib/Language/Haskell/Stylish/Align.hs --- a/lib/Language/Haskell/Stylish/Align.hs +++ b/lib/Language/Haskell/Stylish/Align.hs @@ -8,11 +8,11 @@ -------------------------------------------------------------------------------- import Data.List (nub) -import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Editor +import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Util @@ -57,13 +57,13 @@ align :: Maybe Int -- ^ Max columns -> [Alignable GHC.RealSrcSpan] -- ^ Alignables - -> [Change String] -- ^ Changes performing the alignment -align _ [] = [] + -> Editor.Edits -- ^ Changes performing the alignment +align _ [] = mempty align maxColumns alignment -- Do not make an changes if we would go past the maximum number of columns - | exceedsColumns (longestLeft + longestRight) = [] - | not (fixable alignment) = [] - | otherwise = map align' alignment + | exceedsColumns (longestLeft + longestRight) = mempty + | not (fixable alignment) = mempty + | otherwise = foldMap align' alignment where exceedsColumns i = case maxColumns of Nothing -> False @@ -79,10 +79,10 @@ | a <- alignment ] - align' a = changeLine (GHC.srcSpanStartLine $ aContainer a) $ \str -> + align' a = Editor.changeLine (GHC.srcSpanStartLine $ aContainer a) $ \str -> let column = GHC.srcSpanEndCol $ aLeft a (pre, post) = splitAt column str - in [padRight longestLeft (trimRight pre) ++ trimLeft post] + in [padRight longestLeft (trimRight pre) ++ trimLeft post] -------------------------------------------------------------------------------- -- | Checks that all the alignables appear on a single line, and that they do diff --git a/lib/Language/Haskell/Stylish/Editor.hs b/lib/Language/Haskell/Stylish/Editor.hs --- a/lib/Language/Haskell/Stylish/Editor.hs +++ b/lib/Language/Haskell/Stylish/Editor.hs @@ -1,4 +1,4 @@ -{-# language LambdaCase #-} +{-# LANGUAGE LambdaCase #-} -------------------------------------------------------------------------------- -- | This module provides you with a line-based editor. It's main feature is @@ -11,19 +11,21 @@ module Language.Haskell.Stylish.Editor ( module Language.Haskell.Stylish.Block - , Change - , applyChanges + , Edits + , apply - , change + , replace + , replaceRealSrcSpan , changeLine - , delete - , deleteLine - , insert + , changeLines + , insertLines ) where -------------------------------------------------------------------------------- -import Data.List (intercalate, sortOn) +import qualified Data.Map as M +import Data.Maybe (fromMaybe) +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- @@ -31,83 +33,159 @@ -------------------------------------------------------------------------------- --- | Changes the lines indicated by the 'Block' into the given 'Lines' -data Change a = Change - { changeBlock :: Block a - , changeLines :: [a] -> [a] - } +data Change + -- | Insert some lines. + = CInsert [String] + -- | Replace the block of N lines by the given lines. + | CBlock Int ([String] -> [String]) + -- | Replace (startCol, endCol) by the given string on this line. + | CLine Int Int String -------------------------------------------------------------------------------- -moveChange :: Int -> Change a -> Change a -moveChange offset (Change block ls) = Change (moveBlock offset block) ls +-- | Due to the function in CBlock we cannot write a lawful Ord instance, but +-- this lets us merge-sort changes. +beforeChange :: Change -> Change -> Bool +beforeChange (CInsert _) _ = True +beforeChange _ (CInsert _) = False +beforeChange (CBlock _ _) _ = True +beforeChange _ (CBlock _ _) = False +beforeChange (CLine x _ _) (CLine y _ _) = x <= y -------------------------------------------------------------------------------- -applyChanges :: [Change a] -> [a] -> [a] -applyChanges changes0 - | overlapping blocks = error $ - "Language.Haskell.Stylish.Editor.applyChanges: " ++ - "refusing to make overlapping changes on lines " ++ - intercalate ", " (map printBlock blocks) - | otherwise = go 1 changes1 +prettyChange :: Int -> Change -> String +prettyChange l (CInsert ls) = + show l ++ " insert " ++ show (length ls) ++ " lines" +prettyChange l (CBlock n _) = show l ++ "-" ++ show (l + n) ++ " replace lines" +prettyChange l (CLine start end x) = + show l ++ ":" ++ show start ++ "-" ++ show end ++ " replace by " ++ show x + + +-------------------------------------------------------------------------------- +-- | Merge in order +mergeChanges :: [Change] -> [Change] -> [Change] +mergeChanges = go where - changes1 = sortOn (blockStart . changeBlock) changes0 - blocks = map changeBlock changes1 + go [] ys = ys + go xs [] = xs + go (x : xs) (y : ys) = + if x `beforeChange` y then x : go xs (y : ys) else y : go (x : xs) ys - printBlock b = show (blockStart b) ++ "-" ++ show (blockEnd b) - go _ [] ls = ls - go n (ch : chs) ls = - -- Divide the remaining lines into: - -- - -- > pre - -- > old (lines that are affected by the change) - -- > post - -- - -- And generate: - -- - -- > pre - -- > new - -- > (recurse) - -- - let block = changeBlock ch - (pre, ls') = splitAt (blockStart block - n) ls - (old, post) = splitAt (blockLength block) ls' - new = changeLines ch old - extraLines = length new - blockLength block - chs' = map (moveChange extraLines) chs - n' = blockStart block + blockLength block + extraLines - in pre ++ new ++ go n' chs' post +-------------------------------------------------------------------------------- +-- Stores sorted spans to change per line. +newtype Edits = Edits {unEdits :: M.Map Int [Change]} -------------------------------------------------------------------------------- --- | Change a block of lines for some other lines -change :: Block a -> ([a] -> [a]) -> Change a -change = Change +instance Show Edits where + show edits = unlines $ do + (line, changes) <- M.toAscList $ unEdits edits + prettyChange line <$> changes -------------------------------------------------------------------------------- --- | Change a single line for some other lines -changeLine :: Int -> (a -> [a]) -> Change a -changeLine start f = change (Block start start) $ \case - [] -> [] - (x : _) -> f x +instance Semigroup Edits where + Edits l <> Edits r = Edits $ M.unionWith mergeChanges l r -------------------------------------------------------------------------------- --- | Delete a block of lines -delete :: Block a -> Change a -delete block = Change block $ const [] +instance Monoid Edits where + mempty = Edits mempty -------------------------------------------------------------------------------- --- | Delete a single line -deleteLine :: Int -> Change a -deleteLine start = delete (Block start start) +replaceRealSrcSpan :: GHC.RealSrcSpan -> String -> Edits +replaceRealSrcSpan rss repl + | GHC.srcSpanStartLine rss /= GHC.srcSpanEndLine rss = mempty + | otherwise = replace + (GHC.srcSpanStartLine rss) + (GHC.srcSpanStartCol rss) + (GHC.srcSpanEndCol rss) + repl -------------------------------------------------------------------------------- --- | Insert something /before/ the given lines -insert :: Int -> [a] -> Change a -insert start = Change (Block start (start - 1)) . const +replace :: Int -> Int -> Int -> String -> Edits +replace line startCol endCol repl + | startCol > endCol = mempty + | otherwise = + Edits $ M.singleton line [CLine startCol endCol repl] + + +-------------------------------------------------------------------------------- +changeLine :: Int -> (String -> [String]) -> Edits +changeLine start f = changeLines (Block start start) $ \ls -> case ls of + l : _ -> f l + _ -> f "" + + +-------------------------------------------------------------------------------- +changeLines :: Block String -> ([String] -> [String]) -> Edits +changeLines (Block start end) f = + Edits $ M.singleton start [CBlock (end - start + 1) f] + + +-------------------------------------------------------------------------------- +insertLines :: Int -> [String] -> Edits +insertLines line ls = Edits $ M.singleton line [CInsert ls] + + +-------------------------------------------------------------------------------- +data Conflict = Conflict Int Change Int Change + + +-------------------------------------------------------------------------------- +prettyConflict :: Conflict -> String +prettyConflict (Conflict l1 c1 l2 c2) = unlines + [ "Conflict between edits:" + , "- " ++ prettyChange l1 c1 + , "- " ++ prettyChange l2 c2 + ] + + +-------------------------------------------------------------------------------- +conflicts :: Edits -> [Conflict] +conflicts (Edits edits) = M.toAscList edits >>= uncurry checkChanges + where + checkChanges _ [] = [] + checkChanges i (CInsert _ : cs) = checkChanges i cs + checkChanges i (c1@(CBlock _ _) : c2 : _) = [Conflict i c1 i c2] + checkChanges i [c1@(CBlock n _)] = do + i' <- [i + 1 .. i + n - 1] + case M.lookup i' edits of + Just (c2 : _) -> [Conflict i c1 i' c2] + _ -> [] + checkChanges i (c1@(CLine xstart xend _) : c2@(CLine ystart _ _) : cs) + | xstart == ystart = [Conflict i c1 i c2] + | xend > ystart = [Conflict i c1 i c2] + | otherwise = checkChanges i (c2 : cs) + checkChanges _ (CLine _ _ _ : _) = [] + + +-------------------------------------------------------------------------------- +apply :: Edits -> [String] -> [String] +apply (Edits edits) = case conflicts (Edits edits) of + c : _ -> error $ "Language.Haskell.Stylish.Editor: " ++ prettyConflict c + _ -> go 1 (editsFor 1) + where + editsFor i = fromMaybe [] $ M.lookup i edits + + go _ _ [] = [] + go i [] (l : ls) = l : go (i + 1) (editsFor $ i + 1) ls + go i (CInsert ls' : cs) ls = ls' ++ go i cs ls + go i (CBlock n f : _cs) ls = + let (domain, ls') = splitAt n ls in + f domain ++ go (i + n) (editsFor $ i + n) ls' + go i (CLine xstart xend x : cs) (l : ls) = + let l' = take (xstart - 1) l ++ x ++ drop (xend - 1) l in + go i (adjust xstart xend x <$> cs) (l' : ls) + + adjust _ _ _ (CInsert xs) = CInsert xs + adjust _ _ _ (CBlock n f) = CBlock n f + adjust xstart xend x (CLine ystart yend y) + | ystart >= xend = + let offset = length x - (xend - xstart) in + CLine (ystart + offset) (yend + offset) y + | otherwise = CLine ystart yend y diff --git a/lib/Language/Haskell/Stylish/Step/Data.hs b/lib/Language/Haskell/Stylish/Step/Data.hs --- a/lib/Language/Haskell/Stylish/Step/Data.hs +++ b/lib/Language/Haskell/Stylish/Step/Data.hs @@ -28,8 +28,8 @@ -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Editor import Language.Haskell.Stylish.Comments +import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Ordering @@ -87,10 +87,10 @@ } step :: Config -> Step -step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls +step cfg = makeStep "Data" \ls m -> Editor.apply (changes m) ls where - changes :: Module -> [ChangeLine] - changes m = formatDataDecl cfg <$> dataDecls m + changes :: Module -> Editor.Edits + changes = foldMap (formatDataDecl cfg) . dataDecls dataDecls :: Module -> [DataDecl] dataDecls m = do @@ -108,8 +108,6 @@ } _ -> [] -type ChangeLine = Change String - data DataDecl = MkDataDecl { dataComments :: [GHC.LEpaComment] , dataLoc :: GHC.RealSrcSpan @@ -120,11 +118,11 @@ } -formatDataDecl :: Config -> DataDecl -> ChangeLine +formatDataDecl :: Config -> DataDecl -> Editor.Edits formatDataDecl cfg@Config{..} decl@MkDataDecl {..} = - change originalDeclBlock (const printedDecl) + Editor.changeLines originalDeclBlock (const printedDecl) where - originalDeclBlock = Block + originalDeclBlock = Editor.Block (GHC.srcSpanStartLine dataLoc) (GHC.srcSpanEndLine dataLoc) diff --git a/lib/Language/Haskell/Stylish/Step/Imports.hs b/lib/Language/Haskell/Stylish/Step/Imports.hs --- a/lib/Language/Haskell/Stylish/Step/Imports.hs +++ b/lib/Language/Haskell/Stylish/Step/Imports.hs @@ -16,28 +16,28 @@ ) where -------------------------------------------------------------------------------- -import Control.Monad (forM_, when, void) -import Data.Foldable (toList) -import Data.Function ((&), on) -import Data.Functor (($>)) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.List (sortBy) -import Data.Maybe (fromMaybe, isJust) -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified GHC.Data.FastString as GHC -import qualified GHC.Hs as GHC -import qualified GHC.Types.Name.Reader as GHC -import qualified GHC.Types.SourceText as GHC -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Unit.Module.Name as GHC -import qualified GHC.Unit.Types as GHC +import Control.Monad (forM_, void, when) +import Data.Foldable (toList) +import Data.Function (on, (&)) +import Data.Functor (($>)) +import Data.List (sortBy) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Set as Set +import qualified GHC.Data.FastString as GHC +import qualified GHC.Hs as GHC +import qualified GHC.Types.Name.Reader as GHC +import qualified GHC.Types.SourceText as GHC +import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Unit.Module.Name as GHC +import qualified GHC.Unit.Types as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block -import Language.Haskell.Stylish.Editor +import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Ordering import Language.Haskell.Stylish.Printer @@ -111,20 +111,18 @@ -------------------------------------------------------------------------------- printImports :: Maybe Int -> Options -> Lines -> Module -> Lines -printImports maxCols align ls m = applyChanges changes ls +printImports maxCols align ls m = Editor.apply changes ls where groups = moduleImportGroups m moduleStats = foldMap importStats . fmap GHC.unLoc $ concatMap toList groups - changes = do - group <- groups - pure $ formatGroup maxCols align moduleStats group + changes = foldMap (formatGroup maxCols align moduleStats) groups formatGroup :: Maybe Int -> Options -> ImportStats - -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Change String + -> NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Editor.Edits formatGroup maxCols options moduleStats imports = let newLines = formatImports maxCols options moduleStats imports in - change (importBlock imports) (const newLines) + Editor.changeLines (importBlock imports) (const newLines) importBlock :: NonEmpty (GHC.LImportDecl GHC.GhcPs) -> Block String importBlock group = Block diff --git a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs --- a/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +++ b/lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs @@ -17,12 +17,12 @@ -------------------------------------------------------------------------------- import qualified GHC.Hs as GHC -import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Block -import Language.Haskell.Stylish.Editor +import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util @@ -121,7 +121,7 @@ step' :: Maybe Int -> Style -> Bool -> Bool -> String -> Lines -> Module -> Lines step' columns style align removeRedundant lngPrefix ls m | null languagePragmas = ls - | otherwise = applyChanges changes ls + | otherwise = Editor.apply changes ls where isRedundant' | removeRedundant = isRedundant m @@ -144,18 +144,18 @@ groups :: [(Block String, NonEmpty String)] groups = [(b, pgs) | (b, pgs) <- groupAdjacent' (convertFstToBlock languagePragmas)] - changes = - [ change b (const $ prettyPragmas lngPrefix columns longest align style pg) + changes = mconcat + [ Editor.changeLines b (const $ prettyPragmas lngPrefix columns longest align style pg) | (b, pg) <- filterRedundant isRedundant' groups ] -------------------------------------------------------------------------------- -- | Add a LANGUAGE pragma to a module if it is not present already. -addLanguagePragma :: String -> String -> Module -> [Change String] +addLanguagePragma :: String -> String -> Module -> Editor.Edits addLanguagePragma lg prag modu - | prag `elem` present = [] - | otherwise = [insert line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"]] + | prag `elem` present = mempty + | otherwise = Editor.insertLines line ["{-# " ++ lg ++ " " ++ prag ++ " #-}"] where pragmas' = moduleLanguagePragmas modu present = concatMap (toList . snd) pragmas' diff --git a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs --- a/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +++ b/lib/Language/Haskell/Stylish/Step/ModuleHeader.hs @@ -23,7 +23,7 @@ -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Comments -import Language.Haskell.Stylish.Editor +import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.GHC import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Ordering @@ -110,14 +110,11 @@ (printHeader conf name exportGroups haddocks moduleComment whereComment) - deletes = delete (Block startLine endLine) - - additions = [insert startLine printedModuleHeader] - - changes = deletes : additions in - - applyChanges changes ls + changes = Editor.changeLines + (Editor.Block startLine endLine) + (const printedModuleHeader) in + Editor.apply changes ls where doSort = if sort conf then fmap (commentGroupSort compareLIE) else id diff --git a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs --- a/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +++ b/lib/Language/Haskell/Stylish/Step/SimpleAlign.hs @@ -21,7 +21,7 @@ -------------------------------------------------------------------------------- import Language.Haskell.Stylish.Align -import Language.Haskell.Stylish.Editor +import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util @@ -186,14 +186,14 @@ let changes :: (GHC.Located Hs.HsModule -> [a]) -> (a -> [[Alignable GHC.RealSrcSpan]]) - -> [Change String] - changes search toAlign = - (concatMap . concatMap) (align maxColumns) . map toAlign $ - search module' + -> Editor.Edits + changes search toAlign = mconcat $ do + item <- search module' + pure $ foldMap (align maxColumns) (toAlign item) - configured :: [Change String] - configured = concat $ - [changes records (recordToAlignable config)] ++ - [changes everything (matchGroupToAlignable config)] ++ - [changes everything (multiWayIfToAlignable config)] in - applyChanges configured ls + configured :: Editor.Edits + configured = + changes records (recordToAlignable config) <> + changes everything (matchGroupToAlignable config) <> + changes everything (multiWayIfToAlignable config) in + Editor.apply configured ls diff --git a/lib/Language/Haskell/Stylish/Step/Squash.hs b/lib/Language/Haskell/Stylish/Step/Squash.hs --- a/lib/Language/Haskell/Stylish/Step/Squash.hs +++ b/lib/Language/Haskell/Stylish/Step/Squash.hs @@ -1,6 +1,7 @@ -------------------------------------------------------------------------------- {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module Language.Haskell.Stylish.Step.Squash ( step @@ -8,53 +9,81 @@ -------------------------------------------------------------------------------- -import Control.Monad (guard) -import Data.Maybe (mapMaybe) -import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Hs as GHC +import Data.Maybe (listToMaybe) +import qualified GHC.Hs as GHC +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Editor +import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Util -------------------------------------------------------------------------------- -squash :: GHC.SrcSpan -> GHC.SrcSpan -> Maybe (Change String) -squash left right = do - l <- GHC.srcSpanToRealSrcSpan left - r <- GHC.srcSpanToRealSrcSpan right - guard $ - GHC.srcSpanEndLine l == GHC.srcSpanStartLine r || - GHC.srcSpanEndLine l + 1 == GHC.srcSpanStartLine r - pure $ changeLine (GHC.srcSpanEndLine l) $ \str -> - let (pre, post) = splitAt (GHC.srcSpanEndCol l) str - in [trimRight pre ++ " " ++ trimLeft post] +-- | Removes anything between two RealSrcSpans, providing they are on the same +-- line. +squash :: GHC.RealSrcSpan -> GHC.RealSrcSpan -> Editor.Edits +squash l r + | GHC.srcSpanEndLine l /= GHC.srcSpanStartLine r = mempty + | GHC.srcSpanEndCol l >= GHC.srcSpanStartCol r = mempty + | otherwise = Editor.replace + (GHC.srcSpanEndLine l) + (GHC.srcSpanEndCol l) + (GHC.srcSpanStartCol r) + " " -------------------------------------------------------------------------------- -squashFieldDecl :: GHC.ConDeclField GHC.GhcPs -> Maybe (Change String) -squashFieldDecl (GHC.ConDeclField _ names type' _) - | null names = Nothing - | otherwise = squash (GHC.getLoc $ last names) (GHC.getLocA type') +squashFieldDecl :: GHC.ConDeclField GHC.GhcPs -> Editor.Edits +squashFieldDecl (GHC.ConDeclField ext names@(_ : _) type' _) + | Just left <- GHC.srcSpanToRealSrcSpan . GHC.getLoc $ last names + , Just sep <- fieldDeclSeparator ext + , Just right <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA type' = + squash left sep <> squash sep right +squashFieldDecl _ = mempty -------------------------------------------------------------------------------- +fieldDeclSeparator :: GHC.EpAnn [GHC.AddEpAnn]-> Maybe GHC.RealSrcSpan +fieldDeclSeparator GHC.EpAnn {..} = listToMaybe $ do + GHC.AddEpAnn GHC.AnnDcolon (GHC.EpaSpan s) <- anns + pure s +fieldDeclSeparator _ = Nothing + + +-------------------------------------------------------------------------------- squashMatch - :: GHC.Match GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Maybe (Change String) -squashMatch (GHC.Match _ (GHC.FunRhs name _ _) [] grhss) = do - body <- unguardedRhsBody grhss - squash (GHC.getLocA name) (GHC.getLocA body) -squashMatch (GHC.Match _ _ pats grhss) = do - body <- unguardedRhsBody grhss - squash (GHC.getLocA $ last pats) (GHC.getLocA body) + :: GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) -> Editor.Edits +squashMatch lmatch = case GHC.m_grhss match of + GHC.GRHSs _ [lgrhs] _ + | GHC.GRHS ext [] body <- GHC.unLoc lgrhs + , Just left <- mbLeft + , Just sep <- matchSeparator ext + , Just right <- GHC.srcSpanToRealSrcSpan $ GHC.getLocA body -> + squash left sep <> squash sep right + _ -> mempty + where + match = GHC.unLoc lmatch + mbLeft = case match of + GHC.Match _ (GHC.FunRhs name _ _) [] _ -> + GHC.srcSpanToRealSrcSpan $ GHC.getLocA name + GHC.Match _ _ pats@(_ : _) _ -> + GHC.srcSpanToRealSrcSpan . GHC.getLocA $ last pats + _ -> Nothing -------------------------------------------------------------------------------- +matchSeparator :: GHC.EpAnn GHC.GrhsAnn -> Maybe GHC.RealSrcSpan +matchSeparator GHC.EpAnn {..} + | GHC.AddEpAnn _ (GHC.EpaSpan s) <- GHC.ga_sep anns = Just s +matchSeparator _ = Nothing + + +-------------------------------------------------------------------------------- step :: Step step = makeStep "Squash" $ \ls (module') -> let changes = - mapMaybe squashFieldDecl (everything module') ++ - mapMaybe squashMatch (everything module') in - applyChanges changes ls + foldMap squashFieldDecl (everything module') <> + foldMap squashMatch (everything module') in + Editor.apply changes ls diff --git a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs --- a/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +++ b/lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs @@ -5,100 +5,37 @@ -------------------------------------------------------------------------------- -import qualified Data.Map as M -import qualified GHC.Hs as GHC -import qualified GHC.Types.SrcLoc as GHC +import qualified GHC.Hs as GHC +import qualified GHC.Types.SrcLoc as GHC -------------------------------------------------------------------------------- -import Language.Haskell.Stylish.Editor +import qualified Language.Haskell.Stylish.Editor as Editor import Language.Haskell.Stylish.Module import Language.Haskell.Stylish.Step import Language.Haskell.Stylish.Step.LanguagePragmas (addLanguagePragma) import Language.Haskell.Stylish.Util (everything) -{- -------------------------------------------------------------------------------- -unicodeReplacements :: Map String String -unicodeReplacements = M.fromList - [ ("::", "∷") - , ("=>", "⇒") - , ("->", "→") - , ("<-", "←") - , ("forall", "∀") - , ("-<", "↢") - , (">-", "↣") - ] --} - --------------------------------------------------------------------------------- --- Simple type that can do replacments on single lines (not spanning, removing --- or adding lines). -newtype Replacement = Replacement - { unReplacement :: M.Map Int [(Int, Int, String)] - } deriving (Show) - - --------------------------------------------------------------------------------- -instance Semigroup Replacement where - Replacement l <> Replacement r = Replacement $ M.unionWith (++) l r - - --------------------------------------------------------------------------------- -instance Monoid Replacement where - mempty = Replacement mempty - - --------------------------------------------------------------------------------- -mkReplacement :: GHC.RealSrcSpan -> String -> Replacement -mkReplacement rss repl - | GHC.srcSpanStartLine rss /= GHC.srcSpanEndLine rss = Replacement mempty - | otherwise = Replacement $ - M.singleton - (GHC.srcSpanStartLine rss) - [(GHC.srcSpanStartCol rss, GHC.srcSpanEndCol rss, repl)] - - --------------------------------------------------------------------------------- -applyReplacement :: Replacement -> [String] -> [String] -applyReplacement (Replacement repl) ls = do - (i, l) <- zip [1 ..] ls - case M.lookup i repl of - Nothing -> pure l - Just repls -> pure $ go repls l - where - go [] l = l - go ((xstart, xend, x) : repls) l = - let l' = take (xstart - 1) l ++ x ++ drop (xend - 1) l in - go (adjust (xstart, xend, x) <$> repls) l' - - adjust (xstart, xend, x) (ystart, yend, y) - | ystart > xend = - let offset = length x - (xend - xstart) in - (ystart + offset, yend + offset, y) - | otherwise = (ystart, yend, y) - - --------------------------------------------------------------------------------- -hsTyReplacements :: GHC.HsType GHC.GhcPs -> Replacement +hsTyReplacements :: GHC.HsType GHC.GhcPs -> Editor.Edits hsTyReplacements (GHC.HsFunTy xann arr _ _) | GHC.HsUnrestrictedArrow GHC.NormalSyntax <- arr , GHC.AddRarrowAnn (GHC.EpaSpan loc) <- GHC.anns xann = - mkReplacement loc "→" + Editor.replaceRealSrcSpan loc "→" hsTyReplacements (GHC.HsQualTy _ (Just ctx) _) | Just arrow <- GHC.ac_darrow . GHC.anns . GHC.ann $ GHC.getLoc ctx , (GHC.NormalSyntax, GHC.EpaSpan loc) <- arrow = - mkReplacement loc "⇒" + Editor.replaceRealSrcSpan loc "⇒" hsTyReplacements _ = mempty -------------------------------------------------------------------------------- -hsSigReplacements :: GHC.Sig GHC.GhcPs -> Replacement +hsSigReplacements :: GHC.Sig GHC.GhcPs -> Editor.Edits hsSigReplacements (GHC.TypeSig ann _ _) | GHC.AddEpAnn GHC.AnnDcolon epaLoc <- GHC.asDcolon $ GHC.anns ann , GHC.EpaSpan loc <- epaLoc = - mkReplacement loc "∷" + Editor.replaceRealSrcSpan loc "∷" hsSigReplacements _ = mempty @@ -109,11 +46,9 @@ -------------------------------------------------------------------------------- step' :: Bool -> String -> Lines -> Module -> Lines -step' alp lg ls modu = - applyChanges - (if alp then addLanguagePragma lg "UnicodeSyntax" modu else []) $ - applyReplacement replacement ls +step' alp lg ls modu = Editor.apply edits ls where - replacement = + edits = foldMap hsTyReplacements (everything modu) <> - foldMap hsSigReplacements (everything modu) + foldMap hsSigReplacements (everything modu) <> + (if alp then addLanguagePragma lg "UnicodeSyntax" modu else mempty) diff --git a/stylish-haskell.cabal b/stylish-haskell.cabal --- a/stylish-haskell.cabal +++ b/stylish-haskell.cabal @@ -1,6 +1,6 @@ Cabal-version: 2.4 Name: stylish-haskell -Version: 0.14.0.1 +Version: 0.14.1.0 Synopsis: Haskell code prettifier Homepage: https://github.com/haskell/stylish-haskell License: BSD-3-Clause diff --git a/tests/Language/Haskell/Stylish/Regressions.hs b/tests/Language/Haskell/Stylish/Regressions.hs --- a/tests/Language/Haskell/Stylish/Regressions.hs +++ b/tests/Language/Haskell/Stylish/Regressions.hs @@ -13,7 +13,7 @@ tests :: Test tests = testGroup "Language.Haskell.Stylish.Regressions" - [ testCase "case 00 (#198)" case00 + [ testCase "case 00 (issue #198)" case00 ] -- | Error parsing '(,) #198 diff --git a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/Data/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Data/Tests.hs @@ -32,7 +32,7 @@ , testCase "case 17" case17 , testCase "case 18" case18 , testCase "case 19" case19 - , testCase "case 20 (issue 262)" case20 + , testCase "case 20 (issue #262)" case20 , testCase "case 21" case21 , testCase "case 22" case22 , testCase "case 23" case23 @@ -73,9 +73,9 @@ , testCase "case 58" case58 , testCase "case 59" case59 , testCase "case 60" case60 - , testCase "case 61 (issue 282)" case61 - , testCase "case 62 (issue 273)" case62 - , testCase "case 63 (issue 338)" case63 + , testCase "case 61 (issue #282)" case61 + , testCase "case 62 (issue #273)" case62 + , testCase "case 63 (issue #338)" case63 , testCase "case 64" case64 , testCase "case 65" case65 ] diff --git a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Imports/Tests.hs @@ -57,7 +57,7 @@ , testCase "case 23b" case23b , testCase "case 24" case24 , testCase "case 25" case25 - , testCase "case 26 (issue 185)" case26 + , testCase "case 26 (issue #185)" case26 , testCase "case 27" case27 , testCase "case 28" case28 , testCase "case 29" case29 diff --git a/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs b/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs --- a/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs +++ b/tests/Language/Haskell/Stylish/Step/Squash/Tests.hs @@ -24,6 +24,7 @@ , testCase "case 03" case03 , testCase "case 04" case04 , testCase "case 05" case05 + , testCase "case 06 (issue #355)" case06 ] @@ -99,4 +100,14 @@ ] [ "maybe y0 _ Nothing = y" , "maybe _ f (Just x) = f x" + ] + + +-------------------------------------------------------------------------------- +-- See +case06 :: Assertion +case06 = assertSnippet step + [ "main = (\\x -> putStrLn x) \"Hello, World!\"" + ] + [ "main = (\\x -> putStrLn x) \"Hello, World!\"" ]