Port to GHC 9.2 AST

lib/Language/Haskell/Stylish/Align.hs

@@ -8,7 +8,7 @@ module Language.Haskell.Stylish.Align
 
 --------------------------------------------------------------------------------
 import           Data.List                       (nub)
-import qualified SrcLoc                          as S
+import qualified GHC.Types.SrcLoc                          as GHC
 
 
 --------------------------------------------------------------------------------
@@ -55,9 +55,9 @@ data Alignable a = Alignable
 -- | Create changes that perform the alignment.
 
 align
-  :: Maybe Int                    -- ^ Max columns
-  -> [Alignable S.RealSrcSpan]    -- ^ Alignables
-  -> [Change String]              -- ^ Changes performing the alignment
+  :: Maybe Int                      -- ^ Max columns
+  -> [Alignable GHC.RealSrcSpan]    -- ^ Alignables
+  -> [Change String]                -- ^ Changes performing the alignment
 align _ [] = []
 align maxColumns alignment
   -- Do not make an changes if we would go past the maximum number of columns
@@ -70,29 +70,29 @@ align maxColumns alignment
       Just c  -> i > c
 
     -- The longest thing in the left column
-    longestLeft = maximum $ map (S.srcSpanEndCol . aLeft) alignment
+    longestLeft = maximum $ map (GHC.srcSpanEndCol . aLeft) alignment
 
     -- The longest thing in the right column
     longestRight = maximum
-      [ S.srcSpanEndCol (aRight a) - S.srcSpanStartCol (aRight a)
+      [ GHC.srcSpanEndCol (aRight a) - GHC.srcSpanStartCol (aRight a)
           + aRightLead a
       | a <- alignment
       ]
 
-    align' a = changeLine (S.srcSpanStartLine $ aContainer a) $ \str ->
-      let column = S.srcSpanEndCol $ aLeft a
+    align' a = changeLine (GHC.srcSpanStartLine $ aContainer a) $ \str ->
+      let column = GHC.srcSpanEndCol $ aLeft a
           (pre, post) = splitAt column str
       in [padRight longestLeft (trimRight pre) ++ trimLeft post] 
 
 --------------------------------------------------------------------------------
 -- | Checks that all the alignables appear on a single line, and that they do
 -- not overlap.
 
-fixable :: [Alignable S.RealSrcSpan] -> Bool
+fixable :: [Alignable GHC.RealSrcSpan] -> Bool
 fixable []     = False
 fixable [_]    = False
 fixable fields = all singleLine containers && nonOverlapping containers
   where
     containers        = map aContainer fields
-    singleLine s      = S.srcSpanStartLine s == S.srcSpanEndLine s
-    nonOverlapping ss = length ss == length (nub $ map S.srcSpanStartLine ss)
+    singleLine s      = GHC.srcSpanStartLine s == GHC.srcSpanEndLine s
+    nonOverlapping ss = length ss == length (nub $ map GHC.srcSpanStartLine ss)

lib/Language/Haskell/Stylish/Block.hs

@@ -2,6 +2,7 @@
 module Language.Haskell.Stylish.Block
     ( Block (..)
     , LineBlock
+    , realSrcSpanToLineBlock
     , SpanBlock
     , blockLength
     , moveBlock
@@ -14,16 +15,21 @@ module Language.Haskell.Stylish.Block
 
 
 --------------------------------------------------------------------------------
-import qualified Data.IntSet as IS
+import qualified Data.IntSet      as IS
+import qualified GHC.Types.SrcLoc as GHC
 
 
 --------------------------------------------------------------------------------
 -- | Indicates a line span
 data Block a = Block
     { blockStart :: Int
     , blockEnd   :: Int
-    }
-    deriving (Eq, Ord, Show)
+    } deriving (Eq, Ord, Show)
+
+
+--------------------------------------------------------------------------------
+instance Semigroup (Block a) where
+    (<>) = merge
 
 
 --------------------------------------------------------------------------------
@@ -34,10 +40,16 @@ type LineBlock = Block String
 type SpanBlock = Block Char
 
 
+--------------------------------------------------------------------------------
+realSrcSpanToLineBlock :: GHC.RealSrcSpan -> Block String
+realSrcSpanToLineBlock s = Block (GHC.srcSpanStartLine s) (GHC.srcSpanEndLine s)
+
+
 --------------------------------------------------------------------------------
 blockLength :: Block a -> Int
 blockLength (Block start end) = end - start + 1
 
+
 --------------------------------------------------------------------------------
 moveBlock :: Int -> Block a -> Block a
 moveBlock offset (Block start end) = Block (start + offset) (end + offset)
@@ -47,7 +59,7 @@ moveBlock offset (Block start end) = Block (start + offset) (end + offset)
 adjacent :: Block a -> Block a -> Bool
 adjacent b1 b2 = follows b1 b2 || follows b2 b1
   where
-    follows (Block _ e1) (Block s2 _) = e1 + 1 == s2
+    follows (Block _ e1) (Block s2 _) = e1 == s2 || e1 + 1 == s2
 
 
 --------------------------------------------------------------------------------

lib/Language/Haskell/Stylish/Comments.hs

@@ -0,0 +1,145 @@
+--------------------------------------------------------------------------------
+-- | Utilities for assocgating comments with things in a list.
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Language.Haskell.Stylish.Comments
+    ( CommentGroup (..)
+    , commentGroups
+    , commentGroupHasComments
+    , commentGroupSort
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Data.Function                  (on)
+import           Data.List                      (sortBy, sortOn)
+import           Data.Maybe                     (isNothing, maybeToList)
+import qualified GHC.Hs                         as GHC
+import qualified GHC.Types.SrcLoc               as GHC
+import qualified GHC.Utils.Outputable           as GHC
+
+
+--------------------------------------------------------------------------------
+import           Language.Haskell.Stylish.Block
+import           Language.Haskell.Stylish.GHC
+
+
+--------------------------------------------------------------------------------
+data CommentGroup a = CommentGroup
+    { cgBlock     :: LineBlock
+    , cgPrior     :: [GHC.LEpaComment]
+    , cgItems     :: [(a, Maybe GHC.LEpaComment)]
+    , cgFollowing :: [GHC.LEpaComment]
+    }
+
+
+--------------------------------------------------------------------------------
+instance GHC.Outputable a => Show (CommentGroup a) where
+    show CommentGroup {..} = "(CommentGroup (" ++
+        show cgBlock ++ ") (" ++
+        showOutputable cgPrior ++ ") (" ++
+        showOutputable cgItems ++ ") (" ++
+        showOutputable cgFollowing ++ "))"
+
+
+--------------------------------------------------------------------------------
+commentGroups
+    :: forall a.
+       (a -> Maybe GHC.RealSrcSpan)
+    -> [a]
+    -> [GHC.LEpaComment]
+    -> [CommentGroup a]
+commentGroups getSpan allItems allComments =
+    work Nothing (sortOn fst allItemsWithLines) (sortOn fst commentsWithLines)
+  where
+    allItemsWithLines :: [(LineBlock, a)]
+    allItemsWithLines = do
+        item <- allItems
+        s <- maybeToList $ getSpan item
+        pure (realSrcSpanToLineBlock s, item)
+
+    commentsWithLines :: [(LineBlock, GHC.LEpaComment)]
+    commentsWithLines = do
+        comment <- allComments
+        let s = GHC.anchor $ GHC.getLoc comment
+        pure (realSrcSpanToLineBlock s, comment)
+
+    work
+        :: Maybe (CommentGroup a)
+        -> [(LineBlock, a)]
+        -> [(LineBlock, GHC.LEpaComment)]
+        -> [CommentGroup a]
+    work mbCurrent items comments = case takeNext items comments of
+        Nothing -> maybeToList mbCurrent
+        Just (b, next, items', comments') ->
+            let (flush, current) = case mbCurrent of
+                    Just c  | adjacent (cgBlock c) b
+                            , nextThingItem next
+                            , following@(_ : _) <- cgFollowing c ->
+                        ([c {cgFollowing = []}], CommentGroup b following [] [])
+                    Just c  | adjacent (cgBlock c) b ->
+                        ([], c {cgBlock = cgBlock c <> b})
+                    _ -> (maybeToList mbCurrent, CommentGroup b [] [] [])
+                current' = case next of
+                    NextItem i -> current {cgItems = cgItems current <> [(i, Nothing)]}
+                    NextComment c
+                        | null (cgItems current) -> current {cgPrior = cgPrior current <> [c]}
+                        | otherwise -> current {cgFollowing = cgFollowing current <> [c]}
+                    NextItemWithComment i c ->
+                        current {cgItems = cgItems current <> [(i, Just c)]} in
+            flush ++ work (Just current') items' comments'
+
+
+
+--------------------------------------------------------------------------------
+takeNext
+    :: [(LineBlock, a)]
+    -> [(LineBlock, GHC.LEpaComment)]
+    -> Maybe (LineBlock, NextThing a, [(LineBlock, a)], [(LineBlock, GHC.LEpaComment)])
+takeNext [] [] = Nothing
+takeNext [] ((cb, c) : comments) =
+    Just (cb, NextComment c, [], comments)
+takeNext ((ib, i) : items) [] =
+    Just (ib, NextItem i, items, [])
+takeNext ((ib, i) : items) ((cb, c) : comments)
+    | blockStart ib == blockStart cb =
+        Just (ib <> cb, NextItemWithComment i c, items, comments)
+    | blockStart ib < blockStart cb =
+        Just (ib, NextItem i, items, (cb, c) : comments)
+    | otherwise =
+        Just (cb, NextComment c, (ib, i) : items, comments)
+
+
+--------------------------------------------------------------------------------
+data NextThing a
+    = NextComment GHC.LEpaComment
+    | NextItem a
+    | NextItemWithComment a GHC.LEpaComment
+
+
+--------------------------------------------------------------------------------
+instance GHC.Outputable a => Show (NextThing a) where
+    show (NextComment c) = "NextComment " ++ showOutputable c
+    show (NextItem i) = "NextItem " ++ showOutputable i
+    show (NextItemWithComment i c) =
+        "NextItemWithComment " ++ showOutputable i ++ " " ++ showOutputable c
+
+
+--------------------------------------------------------------------------------
+nextThingItem :: NextThing a -> Bool
+nextThingItem (NextComment _)           = False
+nextThingItem (NextItem _)              = True
+nextThingItem (NextItemWithComment _ _) = True
+
+
+--------------------------------------------------------------------------------
+commentGroupHasComments :: CommentGroup a -> Bool
+commentGroupHasComments CommentGroup {..} = not $
+    null cgPrior && all (isNothing . snd) cgItems && null cgFollowing
+
+
+--------------------------------------------------------------------------------
+commentGroupSort :: (a -> a -> Ordering) -> CommentGroup a -> CommentGroup a
+commentGroupSort cmp cg = cg
+    { cgItems = sortBy (cmp `on` fst) (cgItems cg)
+    }

lib/Language/Haskell/Stylish/Config.hs

@@ -260,17 +260,14 @@ parseRecords c o = Data.step
       maybe Data.NoMaxColumns Data.MaxColumns (configColumns c)
 
 parseIndent :: A.Value -> A.Parser Data.Indent
-parseIndent = A.withText "Indent" $ \t ->
-  if t == "same_line"
-     then return Data.SameLine
-     else
-         if "indent " `T.isPrefixOf` t
-             then
-                 case readMaybe (T.unpack $ T.drop 7 t) of
-                     Just n -> return $ Data.Indent n
-                     Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t)
-             else fail $ "can't parse indent setting: " <> T.unpack t
-
+parseIndent = \case
+    A.String "same_line" -> return Data.SameLine
+    A.String t | "indent " `T.isPrefixOf` t ->
+        case readMaybe (T.unpack $ T.drop 7 t) of
+             Just n -> return $ Data.Indent n
+             Nothing -> fail $ "Indent: not a number" <> T.unpack (T.drop 7 t)
+    A.String t -> fail $ "can't parse indent setting: " <> T.unpack t
+    _ -> fail "Expected string for indent value"
 
 --------------------------------------------------------------------------------
 parseSquash :: Config -> A.Object -> A.Parser Step

lib/Language/Haskell/Stylish/Config/Cabal.hs

@@ -11,7 +11,6 @@ import           Data.Maybe                               (maybeToList)
 import qualified Distribution.PackageDescription          as Cabal
 import qualified Distribution.PackageDescription.Parsec   as Cabal
 import qualified Distribution.Simple.Utils                as Cabal
-import qualified Distribution.Types.CondTree              as Cabal
 import qualified Distribution.Verbosity                   as Cabal
 import qualified Language.Haskell.Extension               as Language
 import           Language.Haskell.Stylish.Verbose

lib/Language/Haskell/Stylish/Editor.hs

@@ -9,7 +9,9 @@
 -- when this is evaluated, we take into account that 4th line will become the
 -- 3rd line before it needs changing.
 module Language.Haskell.Stylish.Editor
-    ( Change
+    ( module Language.Haskell.Stylish.Block
+
+    , Change
     , applyChanges
 
     , change