stylish-haskell 0.14.0.1 → 0.14.1.0

raw patch · 15 files changed

+295/−246 lines, 15 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG +3/−0
• lib/Language/Haskell/Stylish/Align.hs +9/−9
• lib/Language/Haskell/Stylish/Editor.hs +142/−64
• lib/Language/Haskell/Stylish/Step/Data.hs +7/−9
• lib/Language/Haskell/Stylish/Step/Imports.hs +22/−24
• lib/Language/Haskell/Stylish/Step/LanguagePragmas.hs +8/−8
• lib/Language/Haskell/Stylish/Step/ModuleHeader.hs +5/−8
• lib/Language/Haskell/Stylish/Step/SimpleAlign.hs +11/−11
• lib/Language/Haskell/Stylish/Step/Squash.hs +58/−29
• lib/Language/Haskell/Stylish/Step/UnicodeSyntax.hs +12/−77
• stylish-haskell.cabal +1/−1
• tests/Language/Haskell/Stylish/Regressions.hs +1/−1
• tests/Language/Haskell/Stylish/Step/Data/Tests.hs +4/−4
• tests/Language/Haskell/Stylish/Step/Imports/Tests.hs +1/−1
• tests/Language/Haskell/Stylish/Step/Squash/Tests.hs +11/−0

@@ -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

@@ -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

@@ -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

@@ -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) 

@@ -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

@@ -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'

@@ -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 

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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     ]

@@ -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

@@ -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 <https://github.com/haskell/stylish-haskell/issues/355>+case06 :: Assertion+case06 = assertSnippet step+    [ "main  =  (\\x ->  putStrLn x) \"Hello, World!\""+    ]+    [ "main = (\\x -> putStrLn x) \"Hello, World!\""     ]