Fix ghc version compat

src-literatetests/10-tests.blt

@@ -1090,38 +1090,38 @@ import qualified Data.List                                ( )
 import           Data.List                                ( nub )
 
 #test several-elements
-import           Data.List                                ( nub
-                                                          , foldl'
+import           Data.List                                ( foldl'
                                                           , indexElem
+                                                          , nub
                                                           )
 
 #test a-ridiculous-amount-of-elements
 import           Test                                     ( Long
-                                                          , list
-                                                          , with
+                                                          , anymore
+                                                          , fit
                                                           , items
+                                                          , line
+                                                          , list
+                                                          , not
+                                                          , onA
+                                                          , quite
+                                                          , single
                                                           , that
                                                           , will
-                                                          , not
-                                                          , quite
-                                                          , fit
-                                                          , onA
-                                                          , single
-                                                          , line
-                                                          , anymore
+                                                          , with
                                                           )
 
 #test with-things
-import           Test                                     ( T
+import           Test                                     ( (+)
+                                                          , (:!)(..)
+                                                          , (:*)((:.), T7, t7)
+                                                          , (:.)
+                                                          , T
                                                           , T2()
                                                           , T3(..)
                                                           , T4(T4)
                                                           , T5(T5, t5)
                                                           , T6((<|>))
-                                                          , (+)
-                                                          , (:.)
-                                                          , (:.)(..)
-                                                          , (:.)(T7, (:.), t7)
                                                           )
 
 #test hiding
@@ -1145,56 +1145,55 @@ import           Prelude                                 as X
                                                           )
 
 #test long-module-name-simple
-import           TestJustShortEnoughModuleNameLikeThisOne ( )
 import           TestJustAbitToLongModuleNameLikeThisOneIs
                                                           ( )
+import           TestJustShortEnoughModuleNameLikeThisOne ( )
 
 #test long-module-name-as
-import           TestJustShortEnoughModuleNameLikeThisOn as T
 import           TestJustAbitToLongModuleNameLikeThisOneI
                                                          as T
+import           TestJustShortEnoughModuleNameLikeThisOn as T
 
 #test long-module-name-hiding
-import           TestJustShortEnoughModuleNameLike hiding ( )
 import           TestJustAbitToLongModuleNameLikeTh
                                                    hiding ( )
+import           TestJustShortEnoughModuleNameLike hiding ( )
 
 #test long-module-name-simple-items
 import           MoreThanSufficientlyLongModuleNameWithSome
-                                                          ( items
-                                                          , that
-                                                          , will
-                                                          , not
+                                                          ( compact
                                                           , fit
                                                           , inA
-                                                          , compact
+                                                          , items
                                                           , layout
+                                                          , not
+                                                          , that
+                                                          , will
                                                           )
 
 #test long-module-name-hiding-items
-import           TestJustShortEnoughModuleNameLike hiding ( abc
-                                                          , def
-                                                          , ghci
-                                                          , jklm
-                                                          )
 import           TestJustAbitToLongModuleNameLikeTh
                                                    hiding ( abc
                                                           , def
                                                           , ghci
                                                           , jklm
                                                           )
+import           TestJustShortEnoughModuleNameLike hiding ( abc
+                                                          , def
+                                                          , ghci
+                                                          , jklm
+                                                          )
 
 #test long-module-name-other
-import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( )
-import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe
-                                                          ( )
-
-import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T
-import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff
-                                                         as T
 import {-# SOURCE #-} safe qualified "qualifier" A hiding ( )
 import {-# SOURCE #-} safe qualified "qualifiers" A
                                                    hiding ( )
+import {-# SOURCE #-} safe qualified "qualifiers" AlsoAf as T
+import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( )
+import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff
+                                                         as T
+import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe
+                                                          ( )
 
 #test import-with-comments
 -- Test

src-literatetests/14-extensions.blt

@@ -78,8 +78,8 @@ module Test (type (++), (++), pattern Foo) where
 {-# LANGUAGE PatternSynonyms #-}
 import           Test                                     ( type (++)
                                                           , (++)
-                                                          , pattern Foo
                                                           , pattern (:.)
+                                                          , pattern Foo
                                                           )
 
 ###############################################################################

src-literatetests/30-tests-context-free.blt

@@ -755,27 +755,27 @@ import qualified Data.List ()
 import Data.List (nub)
 
 #test several-elements
-import Data.List (nub, foldl', indexElem)
+import Data.List (foldl', indexElem, nub)
 
 #test a-ridiculous-amount-of-elements
 import Test
   ( Long
-  , list
-  , with
+  , anymore
+  , fit
   , items
+  , line
+  , list
+  , not
+  , onA
+  , quite
+  , single
   , that
   , will
-  , not
-  , quite
-  , fit
-  , onA
-  , single
-  , line
-  , anymore
+  , with
   )
 
 #test with-things
-import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+))
+import Test ((+), T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)))
 
 #test hiding
 import Test hiding ()
@@ -798,22 +798,22 @@ import Prelude as X
     )
 
 #test long-module-name-simple
-import TestJustShortEnoughModuleNameLikeThisOne ()
-import TestJustAbitToLongModuleNameLikeThisOneIs ()
 import MoreThanSufficientlyLongModuleNameWithSome
-  (items, that, will, not, fit, inA, compact, layout)
+  (compact, fit, inA, items, layout, not, that, will)
+import TestJustAbitToLongModuleNameLikeThisOneIs ()
+import TestJustShortEnoughModuleNameLikeThisOne ()
 
 #test long-module-name-as
-import TestJustShortEnoughModuleNameLikeThisOn as T
 import TestJustAbitToLongModuleNameLikeThisOneI as T
+import TestJustShortEnoughModuleNameLikeThisOn as T
 
 #test long-module-name-hiding
-import TestJustShortEnoughModuleNameLike hiding ()
 import TestJustAbitToLongModuleNameLikeTh hiding ()
+import TestJustShortEnoughModuleNameLike hiding ()
 
 #test long-module-name-simple-items
 import MoreThanSufficientlyLongModuleNameWithSome
-  (items, that, will, not, fit, inA, compact, layout)
+  (compact, fit, inA, items, layout, not, that, will)
 
 #test long-module-name-hiding-items
 import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm)

src/Language/Haskell/Brittany/Internal.hs

@@ -645,12 +645,11 @@ layoutBriDoc briDoc = do
 
   anns :: ExactPrint.Anns <- mAsk
 
-  let state = LayoutState
-        { _lstate_baseYs           = [0]
-        , _lstate_curYOrAddNewline = Right 0 -- important that we use left here
-                                             -- because moveToAnn stuff of the
-                                             -- first node needs to do its
-                                             -- thing properly.
+  let state = LayoutState { _lstate_baseYs           = [0]
+                          , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
+                                             -- here because moveToAnn stuff
+                                             -- of the first node needs to do
+                                             -- its thing properly.
                           , _lstate_indLevels        = [0]
                           , _lstate_indLevelLinger   = 0
                           , _lstate_comments         = anns
@@ -662,7 +661,16 @@ layoutBriDoc briDoc = do
   state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
 
   let remainingComments =
-        extractAllComments =<< Map.elems (_lstate_comments state')
+        [ c
+        | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
+          (_lstate_comments state')
+          -- With the new import layouter, we manually process comments
+          -- without relying on the backend to consume the comments out of
+          -- the state/map. So they will end up here, and we need to ignore
+          -- them.
+        , ExactPrint.unConName con /= "ImportDecl"
+        , c <- extractAllComments elemAnns
+        ]
   remainingComments
     `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)
 

src/Language/Haskell/Brittany/Internal/Backend.hs

@@ -156,7 +156,9 @@ layoutBriDocM = \case
   BDAnnotationPrior annKey bd -> do
     state <- mGet
     let m = _lstate_comments state
-    let allowMTEL = Data.Either.isRight (_lstate_curYOrAddNewline state)
+    let moveToExactLocationAction = case _lstate_curYOrAddNewline state of
+          Left{} -> pure ()
+          Right{} -> moveToExactAnn annKey
     mAnn <- do
       let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
       mSet $ state
@@ -167,8 +169,8 @@ layoutBriDocM = \case
         }
       return mAnn
     case mAnn of
-      Nothing     -> when allowMTEL $ moveToExactAnn annKey
-      Just []     -> when allowMTEL $ moveToExactAnn annKey
+      Nothing     -> moveToExactLocationAction
+      Just []     -> moveToExactLocationAction
       Just priors -> do
         -- layoutResetSepSpace
         priors
@@ -184,7 +186,7 @@ layoutBriDocM = \case
                       -- layoutMoveToIndentCol y
                       layoutWriteAppendMultiline commentLines
           -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
-        when allowMTEL $ moveToExactAnn annKey
+        moveToExactLocationAction
     layoutBriDocM bd
   BDAnnotationKW annKey keyword bd -> do
     layoutBriDocM bd

src/Language/Haskell/Brittany/Internal/BackendUtils.hs

@@ -28,6 +28,7 @@ module Language.Haskell.Brittany.Internal.BackendUtils
   , layoutMoveToCommentPos
   , layoutIndentRestorePostComment
   , moveToExactAnn
+  , moveToY
   , ppmMoveToExactLoc
   , layoutWritePriorComments
   , layoutWritePostComments
@@ -469,7 +470,10 @@ moveToExactAnn annKey = do
       -- curY <- mGet <&> _lstate_curY
       let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
       -- mModify $ \state -> state { _lstate_addNewline = Just x }
-      mModify $ \state ->
+      moveToY y
+
+moveToY :: MonadMultiState LayoutState m => Int -> m ()
+moveToY y = mModify $ \state ->
   let upd = case _lstate_curYOrAddNewline state of
         Left  i -> if y == 0 then Left i else Right y
         Right i -> Right $ max y i

src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs

@@ -3,7 +3,6 @@
 module Language.Haskell.Brittany.Internal.ExactPrintUtils
   ( parseModule
   , parseModuleFromString
-  , commentAnnFixTransform
   , commentAnnFixTransformGlob
   , extractToplevelAnns
   , foldedAnnKeys
@@ -189,54 +188,56 @@ commentAnnFixTransformGlob ast = do
       ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
   
 
+-- TODO: this is unused by now, but it contains one detail that
+--       commentAnnFixTransformGlob does not include: Moving of comments for
+--       "RecordUpd"s.
+-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
+-- commentAnnFixTransform modul = SYB.everything (>>) genF modul
+--  where
+--   genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
+--   genF = (\_ -> return ()) `SYB.extQ` exprF
+--   exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
+--   exprF lexpr@(L _ expr) = case expr of
+-- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
+--     RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->
+-- #else
+--     RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) ->
+-- #endif
+--       moveTrailingComments lexpr (List.last fs)
+-- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
+--     RecordUpd _ _e fs@(_:_) ->
+-- #else
+--     RecordUpd _e fs@(_:_) _cons _ _ _ ->
+-- #endif
+--       moveTrailingComments lexpr (List.last fs)
+--     _ -> return ()
 
-commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()
-commentAnnFixTransform modul = SYB.everything (>>) genF modul
- where
-  genF :: Data.Data.Data a => a -> ExactPrint.Transform ()
-  genF = (\_ -> return ()) `SYB.extQ` exprF
-  exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()
-  exprF lexpr@(L _ expr) = case expr of
-#if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
-    RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->
-#else
-    RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) ->
-#endif
-      moveTrailingComments lexpr (List.last fs)
-#if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
-    RecordUpd _ _e fs@(_:_) ->
-#else
-    RecordUpd _e fs@(_:_) _cons _ _ _ ->
-#endif
-      moveTrailingComments lexpr (List.last fs)
-    _ -> return ()
-
-moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
-                     => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
-moveTrailingComments astFrom astTo = do
-  let
-    k1 = ExactPrint.mkAnnKey astFrom
-    k2 = ExactPrint.mkAnnKey astTo
-    moveComments ans = ans'
-      where
-        an1 = Data.Maybe.fromJust $ Map.lookup k1 ans
-        an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
-        cs1f = ExactPrint.annFollowingComments an1
-        cs2f = ExactPrint.annFollowingComments an2
-        (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)
-             $ \case
-               (ExactPrint.AnnComment com, dp) -> Left (com, dp)
-               x -> Right x
-        an1' = an1
-          { ExactPrint.annsDP               = nonComments
-          , ExactPrint.annFollowingComments = []
-          }
-        an2' = an2
-          { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments
-          }
-        ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
-
-  ExactPrint.modifyAnnsT moveComments
+-- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)
+--                      => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()
+-- moveTrailingComments astFrom astTo = do
+--   let
+--     k1 = ExactPrint.mkAnnKey astFrom
+--     k2 = ExactPrint.mkAnnKey astTo
+--     moveComments ans = ans'
+--       where
+--         an1 = Data.Maybe.fromJust $ Map.lookup k1 ans
+--         an2 = Data.Maybe.fromJust $ Map.lookup k2 ans
+--         cs1f = ExactPrint.annFollowingComments an1
+--         cs2f = ExactPrint.annFollowingComments an2
+--         (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)
+--              $ \case
+--                (ExactPrint.AnnComment com, dp) -> Left (com, dp)
+--                x -> Right x
+--         an1' = an1
+--           { ExactPrint.annsDP               = nonComments
+--           , ExactPrint.annFollowingComments = []
+--           }
+--         an2' = an2
+--           { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments
+--           }
+--         ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
+--
+--   ExactPrint.modifyAnnsT moveComments
 
 -- | split a set of annotations in a module into a map from top-level module
 -- elements to the relevant annotations. Avoids quadratic behaviour a trivial

src/Language/Haskell/Brittany/Internal/LayouterBasics.hs

@@ -73,6 +73,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , hasAnyRegularCommentsRest
   , hasAnnKeywordComment
   , hasAnnKeyword
+  , astAnn
+  , allocNodeIndex
   )
 where
 
@@ -575,7 +577,8 @@ docSeparator = allocateNode BDFSeparator
 
 docAnnotationPrior
   :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm
+docAnnotationPrior annKey bdm =
+  allocateNode . BDFAnnotationPrior annKey =<< bdm
 
 docAnnotationKW
   :: AnnKey

src/Language/Haskell/Brittany/Internal/Layouters/IE.hs

@@ -2,6 +2,7 @@ module Language.Haskell.Brittany.Internal.Layouters.IE
   ( layoutIE
   , layoutLLIEs
   , layoutAnnAndSepLLIEs
+  , SortItemsFlag(..)
   )
 where
 
@@ -12,14 +13,14 @@ import           Language.Haskell.Brittany.Internal.LayouterBasics
 import           Language.Haskell.Brittany.Internal.Config.Types
 
 import           GHC                            ( unLoc
-                         , runGhc
                                                 , GenLocated(L)
                                                 , moduleNameString
                                                 , AnnKeywordId(..)
                                                 , Located
+                                                , runGhc
+                                                , ModuleName
                                                 )
 import           HsSyn
-import           Name
 import           HsImpExp
 import           FieldLabel
 import qualified FastString
@@ -70,18 +71,19 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
       : hasAnyCommentsBelow x
       : map hasAnyCommentsBelow ns
       )
+    let sortedNs = List.sortOn wrappedNameToText ns
     runFilteredAlternative $ do
       addAlternativeCond (not hasComments)
         $  docSeq
         $  [layoutWrapped lie x, docLit $ Text.pack "("]
-        ++ intersperse docCommaSep (map nameDoc ns)
+        ++ intersperse docCommaSep (map nameDoc sortedNs)
         ++ [docParenR]
       addAlternative
         $ docWrapNodeRest lie
         $ docAddBaseY BrIndentRegular
         $ docPar
             (layoutWrapped lie x)
-            (layoutItems (splitFirstLast ns))
+            (layoutItems (splitFirstLast sortedNs))
    where
     nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName
     layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
@@ -126,6 +128,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
       | otherwise  -> name
 #endif
 
+data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
 -- Helper function to deal with Located lists of LIEs.
 -- In particular this will also associate documentation
 -- from the located list that actually belongs to the last IE.
@@ -134,10 +137,18 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
 -- handling of the resulting list. Adding parens is
 -- left to the caller since that is context sensitive
 layoutAnnAndSepLLIEs
-  :: Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered]
-layoutAnnAndSepLLIEs llies@(L _ lies) = do
+  :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered]
+layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
   let makeIENode ie = docSeq [docCommaSep, ie]
-  let ieDocs = layoutIE <$> lies
+  let sortedLies =
+        [ items
+        | group <- Data.List.Extra.groupOn lieToText
+          $ List.sortOn lieToText lies
+        , items <- mergeGroup group
+        ]
+  let ieDocs = fmap layoutIE $ case shouldSort of
+        ShouldSortItems -> sortedLies
+        KeepItemsUnsorted -> lies
   ieCommaDocs <-
     docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of
       FirstLastEmpty        -> []
@@ -145,6 +156,64 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do
       FirstLast ie1 ieMs ieN ->
         [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
   pure $ fmap pure ieCommaDocs -- returned shared nodes
+ where
+  mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
+  mergeGroup []        = []
+  mergeGroup items@[_] = items
+  mergeGroup items     = if
+    | all isProperIEThing items -> [List.foldl1' thingFolder items]
+    | all isIEVar items         -> [List.foldl1' thingFolder items]
+    | otherwise                 -> items
+  -- proper means that if it is a ThingWith, it does not contain a wildcard
+  -- (because I don't know what a wildcard means if it is not already a
+  -- IEThingAll).
+  isProperIEThing :: LIE GhcPs -> Bool
+#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */
+  isProperIEThing = \case
+    L _ (IEThingAbs _ _wn) -> True
+    L _ (IEThingAll _ _wn) -> True
+    L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True
+    _ -> False
+#else                      /* 8.0 8.2 8.4 */
+  isProperIEThing = \case
+    L _ (IEThingAbs _wn) -> True
+    L _ (IEThingAll _wn) -> True
+    L _ (IEThingWith _wn NoIEWildcard _ _) -> True
+    _ -> False
+#endif
+  isIEVar :: LIE GhcPs -> Bool
+  isIEVar = \case
+    L _ IEVar{} -> True
+    _           -> False
+  thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
+  thingFolder l1@(L _ IEVar{}     ) _                     = l1
+  thingFolder l1@(L _ IEThingAll{}) _                     = l1
+  thingFolder _                     l2@(L _ IEThingAll{}) = l2
+  thingFolder l1                    (   L _ IEThingAbs{}) = l1
+  thingFolder (L _ IEThingAbs{})    l2                    = l2
+#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */
+  thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
+    = L
+      l
+      (IEThingWith x
+                   wn
+                   NoIEWildcard
+                   (consItems1 ++ consItems2)
+                   (fieldLbls1 ++ fieldLbls2)
+      )
+#else                      /* 8.0 8.2 8.4 */
+  thingFolder (L l (IEThingWith wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ consItems2 fieldLbls2))
+    = L
+      l
+      (IEThingWith wn
+                   NoIEWildcard
+                   (consItems1 ++ consItems2)
+                   (fieldLbls1 ++ fieldLbls2)
+      )
+#endif
+  thingFolder _ _ =
+    error "thingFolder should be exhaustive because we have a guard above"
+
 
 -- Builds a complete layout for the given located
 -- list of LIEs. The layout provides two alternatives:
@@ -159,19 +228,17 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do
 -- () -- no comments
 -- ( -- a comment
 -- )
-layoutLLIEs :: Bool -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
-layoutLLIEs enableSingleline llies = do
-  ieDs        <- layoutAnnAndSepLLIEs llies
+layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
+layoutLLIEs enableSingleline shouldSort llies = do
+  ieDs        <- layoutAnnAndSepLLIEs shouldSort llies
   hasComments <- hasAnyCommentsBelow llies
-  runFilteredAlternative $
-    case ieDs of
+  runFilteredAlternative $ case ieDs of
     [] -> do
-        addAlternativeCond (not hasComments) $
-          docLit $ Text.pack "()"
-        addAlternativeCond hasComments $
-          docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty])
+      addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"
+      addAlternativeCond hasComments $ docPar
+        (docSeq [docParenLSep, docWrapNodeRest llies docEmpty])
         docParenR
-      (ieDsH:ieDsT) -> do
+    (ieDsH : ieDsT) -> do
       addAlternativeCond (not hasComments && enableSingleline)
         $  docSeq
         $  [docLit (Text.pack "(")]
@@ -182,3 +249,52 @@ layoutLLIEs enableSingleline llies = do
         $  docLines
         $  ieDsT
         ++ [docParenR]
+
+-- | Returns a "fingerprint string", not a full text representation, nor even
+-- a source code representation of this syntax node.
+-- Used for sorting, not for printing the formatter's output source code.
+#if MIN_VERSION_ghc(8,2,0)
+wrappedNameToText :: LIEWrappedName RdrName -> Text
+wrappedNameToText = \case
+  L _ (IEName    n) -> lrdrNameToText n
+  L _ (IEPattern n) -> lrdrNameToText n
+  L _ (IEType    n) -> lrdrNameToText n
+#else
+wrappedNameToText :: Located RdrName -> Text
+wrappedNameToText = lrdrNameToText
+#endif
+-- | Returns a "fingerprint string", not a full text representation, nor even
+-- a source code representation of this syntax node.
+-- Used for sorting, not for printing the formatter's output source code.
+lieToText :: LIE GhcPs -> Text
+#if MIN_VERSION_ghc(8,6,0) /* 8.6+ */
+lieToText = \case
+  L _ (IEVar      _ wn       ) -> wrappedNameToText wn
+  L _ (IEThingAbs _ wn       ) -> wrappedNameToText wn
+  L _ (IEThingAll _ wn       ) -> wrappedNameToText wn
+  L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn
+  -- TODO: These _may_ appear in exports!
+  -- Need to check, and either put them at the top (for module) or do some
+  -- other clever thing.
+  L _ (IEModuleContents _ n) -> moduleNameToText n
+  L _ (IEGroup _ _ _         ) -> Text.pack "@IEGroup"
+  L _ (IEDoc      _ _        ) -> Text.pack "@IEDoc"
+  L _ (IEDocNamed _ _        ) -> Text.pack "@IEDocNamed"
+  L _ (XIE _                 ) -> Text.pack "@XIE"
+#else                      /* 8.0 8.2 8.4 */                    
+lieToText = \case
+  L _ (IEVar      wn       ) -> wrappedNameToText wn
+  L _ (IEThingAbs wn       ) -> wrappedNameToText wn
+  L _ (IEThingAll wn       ) -> wrappedNameToText wn
+  L _ (IEThingWith wn _ _ _) -> wrappedNameToText wn
+  -- TODO: These _may_ appear in exports!
+  -- Need to check, and either put them at the top (for module) or do some
+  -- other clever thing.
+  L _ (IEModuleContents n  ) -> moduleNameToText n
+  L _ (IEGroup _ _         ) -> Text.pack "@IEGroup"
+  L _ (IEDoc      _        ) -> Text.pack "@IEDoc"
+  L _ (IEDocNamed _        ) -> Text.pack "@IEDocNamed"
+#endif
+ where
+  moduleNameToText :: Located ModuleName -> Text
+  moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)

src/Language/Haskell/Brittany/Internal/Layouters/Import.hs

@@ -17,6 +17,7 @@ import           Name
 import           FieldLabel
 import qualified FastString
 import           BasicTypes
+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
 
 import           Language.Haskell.Brittany.Internal.Utils
 
@@ -41,8 +42,8 @@ prepModName :: e -> e
 prepModName = id
 #endif
 
-layoutImport :: ToBriDoc ImportDecl
-layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of
+layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered
+layoutImport importD = case importD of
 #if MIN_VERSION_ghc(8,6,0)
   ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do
 #else
@@ -92,14 +93,14 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of
           hasComments <- hasAnyCommentsBelow llies
           if compact
           then docAlt
-            [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True llies]
+            [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies]
             , let makeParIfHiding = if hiding
                     then docAddBaseY BrIndentRegular . docPar hidDoc
                     else id
-              in makeParIfHiding (layoutLLIEs True llies)
+              in makeParIfHiding (layoutLLIEs True ShouldSortItems llies)
             ]
           else do
-            ieDs <- layoutAnnAndSepLLIEs llies
+            ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies
             docWrapNodeRest llies
               $ docEnsureIndent (BrIndentSpecial hidDocCol)
               $ case ieDs of

src/Language/Haskell/Brittany/Internal/Layouters/Module.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ViewPatterns #-}
+
 module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where
 
 #include "prelude.inc"
@@ -16,7 +18,12 @@ import           FieldLabel
 import qualified FastString
 import           BasicTypes
 import           Language.Haskell.GHC.ExactPrint as ExactPrint
-import           Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
+import           Language.Haskell.GHC.ExactPrint.Types
+                                                ( DeltaPos(..)
+                                                , deltaRow
+                                                , commentContents
+                                                )
 
 import           Language.Haskell.Brittany.Internal.Utils
 
@@ -25,8 +32,16 @@ import           Language.Haskell.Brittany.Internal.Utils
 layoutModule :: ToBriDoc HsModule
 layoutModule lmod@(L _ mod') = case mod' of
     -- Implicit module Main
-  HsModule Nothing  _   imports _ _ _ -> docLines $ map layoutImport imports
+  HsModule Nothing  _   imports _ _ _ -> do
+    commentedImports <- transformToCommentedImport imports
+    -- groupify commentedImports `forM_` tellDebugMessShow
+    docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
+    -- sortedImports <- sortImports imports
+    -- docLines $ [layoutImport y i | (y, i) <- sortedImports]
   HsModule (Just n) les imports _ _ _ -> do
+    commentedImports <- transformToCommentedImport imports
+    -- groupify commentedImports `forM_` tellDebugMessShow
+    -- sortedImports <- sortImports imports
     let tn = Text.pack $ moduleNameString $ unLoc n
     allowSingleLineExportList <- mAsk
       <&> _conf_layout
@@ -48,7 +63,7 @@ layoutModule lmod@(L _ mod') = case mod' of
                 , appSep $ docLit tn
                 , docWrapNode lmod $ appSep $ case les of
                   Nothing -> docEmpty
-                  Just x  -> layoutLLIEs True x
+                  Just x  -> layoutLLIEs True KeepItemsUnsorted x
                 , docLit $ Text.pack "where"
                 ]
             addAlternative
@@ -58,9 +73,135 @@ layoutModule lmod@(L _ mod') = case mod' of
                 )
                 (docWrapNode lmod $ case les of
                   Nothing -> docEmpty
-                  Just x  -> layoutLLIEs False x
+                  Just x  -> layoutLLIEs False KeepItemsUnsorted x
                 )
               , docLit $ Text.pack "where"
               ]
           ]
-      : map layoutImport imports
+      : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports]
+
+data CommentedImport
+  = EmptyLine
+  | IndependentComment (Comment, DeltaPos)
+  | ImportStatement ImportStatementRecord
+
+instance Show CommentedImport where
+  show = \case
+    EmptyLine            -> "EmptyLine"
+    IndependentComment _ -> "IndependentComment"
+    ImportStatement r ->
+      "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
+        (length $ commentsAfter r)
+
+data ImportStatementRecord = ImportStatementRecord
+  { commentsBefore :: [(Comment, DeltaPos)]
+  , commentsAfter :: [(Comment, DeltaPos)]
+  , importStatement :: ImportDecl GhcPs
+  }
+
+instance Show ImportStatementRecord where
+  show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
+        (length $ commentsAfter r)
+
+transformToCommentedImport
+  :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
+transformToCommentedImport is = do
+  nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do
+    annotionMay <- astAnn i
+    pure (annotionMay, rawImport)
+  let
+    convertComment (c, DP (y, x)) =
+      replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]
+    accumF
+      :: [(Comment, DeltaPos)]
+      -> (Maybe Annotation, ImportDecl GhcPs)
+      -> ([(Comment, DeltaPos)], [CommentedImport])
+    accumF accConnectedComm (annMay, decl) = case annMay of
+      Nothing ->
+        ( []
+        , [ ImportStatement ImportStatementRecord { commentsBefore  = []
+                                                  , commentsAfter   = []
+                                                  , importStatement = decl
+                                                  }
+          ]
+        )
+      Just ann ->
+        let
+          blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1
+          (newAccumulator, priorComments') =
+            List.span ((== 0) . deltaRow . snd) (annPriorComments ann)
+          go
+            :: [(Comment, DeltaPos)]
+            -> [(Comment, DeltaPos)]
+            -> ([CommentedImport], [(Comment, DeltaPos)], Int)
+          go acc []                       = ([], acc, 0)
+          go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)
+          go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
+          go acc ((c1, DP (y, x)) : xs) =
+            ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine
+            , (c1, DP (1, x)) : acc
+            , 0
+            )
+          (convertedIndependentComments, beforeComments, initialBlanks) =
+            if blanksBeforeImportDecl /= 0
+              then (convertComment =<< priorComments', [], 0)
+              else go [] (reverse priorComments')
+        in
+          ( newAccumulator
+          , convertedIndependentComments
+          ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine
+          ++ [ ImportStatement ImportStatementRecord
+                 { commentsBefore  = beforeComments
+                 , commentsAfter   = accConnectedComm
+                 , importStatement = decl
+                 }
+             ]
+          )
+  let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations
+  pure $ join $ (convertComment =<< finalAcc) : finalList
+
+sortCommentedImports :: [CommentedImport] -> [CommentedImport]
+sortCommentedImports =
+  unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify
+ where
+  unpackImports :: [CommentedImport] -> [CommentedImport]
+  unpackImports xs = xs >>= \case
+    l@EmptyLine            -> [l]
+    l@IndependentComment{} -> [l]
+    ImportStatement r ->
+      map IndependentComment (commentsBefore r) ++ [ImportStatement r]
+  mergeGroups
+    :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport]
+  mergeGroups xs = xs >>= \case
+    Left  x -> [x]
+    Right y -> ImportStatement <$> y
+  sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
+  sortGroups =
+    List.sortOn (moduleNameString . unLoc . ideclName . importStatement)
+  groupify
+    :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]]
+  groupify cs = go [] cs
+   where
+    go [] = \case
+      (l@EmptyLine            : rest) -> Left l : go [] rest
+      (l@IndependentComment{} : rest) -> Left l : go [] rest
+      (ImportStatement r      : rest) -> go [r] rest
+      []                              -> []
+    go acc = \case
+      (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest
+      (l@IndependentComment{} : rest) ->
+        Left l : Right (reverse acc) : go [] rest
+      (ImportStatement r : rest) -> go (r : acc) rest
+      []                         -> [Right (reverse acc)]
+
+commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered
+commentedImportsToDoc = \case
+  EmptyLine -> docLitS ""
+  IndependentComment c -> commentToDoc c
+  ImportStatement r ->
+    docSeq
+      ( layoutImport (importStatement r)
+      : map commentToDoc (commentsAfter r)
+      )
+ where
+  commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)