brittany 0.13.0.0 → 0.13.1.0
raw patch · 15 files changed
+431/−126 lines, 15 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- README.md +15/−1
- brittany.cabal +1/−1
- src-literatetests/10-tests.blt +55/−33
- src-literatetests/14-extensions.blt +1/−1
- src-literatetests/30-tests-context-free.blt +16/−16
- src-literatetests/Main.hs +4/−0
- src/Language/Haskell/Brittany/Internal.hs +22/−14
- src/Language/Haskell/Brittany/Internal/Backend.hs +7/−5
- src/Language/Haskell/Brittany/Internal/BackendUtils.hs +18/−14
- src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +23/−1
- src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +4/−1
- src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +106/−27
- src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +6/−5
- src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +149/−7
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for brittany +## 0.13.1.0 -- December 2020++* #330: Started sorting imports. Thanks @expipiplus1!+ ## 0.13.0.0 -- December 2020 * #324: Added support for GHC 8.10.
README.md view
@@ -70,7 +70,7 @@ - via `nix`: ~~~.sh- nix build -f release.nix # or 'nix-build -f release.nix'+ nix build nix-env -i ./result ~~~ @@ -101,6 +101,20 @@ ~~~~.sh aura -A brittany ~~~~++# Development tips++## Run a hoogle server++To host a local Hoogle server with all of Brittany's dependencies run:++```sh+echo brittany.cabal |+ $(nix-build '<nixpkgs>' --no-link -A entr)/bin/entr -r -- \+ sh -c "nix-shell --run 'hoogle server --local'"+```++This will watch `brittany.cabal` for changes and restart the server when new dependencies are added there. # Editor Integration
brittany.cabal view
@@ -1,5 +1,5 @@ name: brittany-version: 0.13.0.0+version: 0.13.1.0 synopsis: Haskell source code formatter description: { See <https://github.com/lspitzner/brittany/blob/master/README.md the README>.
src-literatetests/10-tests.blt view
@@ -1088,38 +1088,38 @@ 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- , that- , will+ , line+ , list , not- , quite- , fit , onA+ , quite , single- , line- , anymore+ , that+ , will+ , with ) #test with-things-import Test ( T+import Test ( (+)+ , (:!)(..)+ , (:*)((:.), T7, t7)+ , (:.)+ , T , T2() , T3(..) , T4(T4) , T5(T5, t5) , T6((<|>))- , (+)- , (:.)- , (:.)(..)- , (:.)(T7, (:.), t7) ) #test hiding@@ -1143,56 +1143,55 @@ ) #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+import TestJustAbitToLongModuleNameLikeTh+ hiding ( abc , def , ghci , jklm )-import TestJustAbitToLongModuleNameLikeTh- hiding ( abc+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@@ -1295,6 +1294,29 @@ -- Test import Test ( test ) +#test sorted-imports+import Aaa+import Baa++#test sorted-import-groups+import Zaa+import Zab+<BLANKLINE>+import Aaa+import Baa++#test sorted-qualified-imports+import Boo+import qualified Zoo++#test imports-groups-same-module+import Boo ( a )+<BLANKLINE>+import Boo ( b )++#test sorted-imports-nested+import A.B.C+import A.B.D ############################################################################### ###############################################################################
src-literatetests/14-extensions.blt view
@@ -78,8 +78,8 @@ {-# LANGUAGE PatternSynonyms #-} import Test ( type (++) , (++)- , pattern Foo , pattern (:.)+ , pattern Foo ) ###############################################################################
src-literatetests/30-tests-context-free.blt view
@@ -753,27 +753,27 @@ 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- , that- , will+ , line+ , list , not- , quite- , fit , onA+ , quite , single- , line- , anymore+ , that+ , will+ , 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 ()@@ -796,22 +796,22 @@ ) #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-literatetests/Main.hs view
@@ -159,6 +159,10 @@ (Parsec.noneOf "\r\n") , _ <- Parsec.eof ]+ , [ NormalLine mempty+ | _ <- Parsec.try $ Parsec.string "<BLANKLINE>"+ , _ <- Parsec.eof+ ] ] lineMapper :: Text -> InputLine lineMapper line = case Parsec.runParser specialLineParser () "" line of
src/Language/Haskell/Brittany/Internal.hs view
@@ -636,24 +636,32 @@ 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.- , _lstate_indLevels = [0]- , _lstate_indLevelLinger = 0- , _lstate_comments = anns- , _lstate_commentCol = Nothing- , _lstate_addSepSpace = Nothing- , _lstate_commentNewlines = 0- }+ 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+ , _lstate_commentCol = Nothing+ , _lstate_addSepSpace = Nothing+ , _lstate_commentNewlines = 0+ } 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 view
@@ -156,7 +156,9 @@ 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 @@ } 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 @@ -- 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@@ -373,7 +375,7 @@ BDSetParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd- BDDebug _ bd -> rec bd+ BDDebug _ bd -> rec bd -- In theory -- =========
src/Language/Haskell/Brittany/Internal/BackendUtils.hs view
@@ -28,6 +28,7 @@ , layoutMoveToCommentPos , layoutIndentRestorePostComment , moveToExactAnn+ , moveToY , ppmMoveToExactLoc , layoutWritePriorComments , layoutWritePostComments@@ -469,20 +470,23 @@ -- curY <- mGet <&> _lstate_curY let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann -- mModify $ \state -> state { _lstate_addNewline = Just x }- 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- in state- { _lstate_curYOrAddNewline = upd- , _lstate_addSepSpace = if Data.Either.isRight upd- then- _lstate_commentCol state- <|> _lstate_addSepSpace state- <|> Just (lstate_baseY state)- else Nothing- , _lstate_commentCol = Nothing- }+ 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+ in state+ { _lstate_curYOrAddNewline = upd+ , _lstate_addSepSpace = if Data.Either.isRight upd+ then+ _lstate_commentCol state+ <|> _lstate_addSepSpace state+ <|> Just (lstate_baseY state)+ else Nothing+ , _lstate_commentCol = Nothing+ } -- fixMoveToLineByIsNewline :: MonadMultiState -- LayoutState m => Int -> m Int -- fixMoveToLineByIsNewline x = do
src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs view
@@ -3,7 +3,6 @@ module Language.Haskell.Brittany.Internal.ExactPrintUtils ( parseModule , parseModuleFromString- , commentAnnFixTransform , commentAnnFixTransformGlob , extractToplevelAnns , foldedAnnKeys@@ -204,6 +203,29 @@ 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
src/Language/Haskell/Brittany/Internal/LayouterBasics.hs view
@@ -73,6 +73,8 @@ , hasAnyRegularCommentsRest , hasAnnKeywordComment , hasAnnKeyword+ , astAnn+ , allocNodeIndex ) where @@ -575,7 +577,8 @@ 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 view
@@ -2,6 +2,7 @@ ( layoutIE , layoutLLIEs , layoutAnnAndSepLLIEs+ , SortItemsFlag(..) ) where @@ -17,6 +18,7 @@ , moduleNameString , AnnKeywordId(..) , Located+ , ModuleName ) #if MIN_VERSION_ghc(8,10,1) /* ghc-8.10.1 */ import GHC.Hs@@ -50,18 +52,19 @@ : 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]@@ -91,6 +94,7 @@ name <- lrdrNameToTextAnn n docLit $ Text.pack "type " <> name +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.@@ -99,10 +103,18 @@ -- 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 -> []@@ -110,7 +122,46 @@ 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+ isProperIEThing = \case+ L _ (IEThingAbs _ _wn) -> True+ L _ (IEThingAll _ _wn) -> True+ L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True+ _ -> False+ 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+ thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))+ = L+ l+ (IEThingWith x+ wn+ NoIEWildcard+ (consItems1 ++ consItems2)+ (fieldLbls1 ++ fieldLbls2)+ )+ 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: -- (item, item, ..., item)@@ -124,26 +175,54 @@ -- () -- 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- [] -> do- addAlternativeCond (not hasComments) $- docLit $ Text.pack "()"- addAlternativeCond hasComments $- docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty])- docParenR- (ieDsH:ieDsT) -> do- addAlternativeCond (not hasComments && enableSingleline)- $ docSeq- $ [docLit (Text.pack "(")]- ++ (docForceSingleline <$> ieDs)- ++ [docParenR]- addAlternative- $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])- $ docLines- $ ieDsT- ++ [docParenR]+ runFilteredAlternative $ case ieDs of+ [] -> do+ addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"+ addAlternativeCond hasComments $ docPar+ (docSeq [docParenLSep, docWrapNodeRest llies docEmpty])+ docParenR+ (ieDsH : ieDsT) -> do+ addAlternativeCond (not hasComments && enableSingleline)+ $ docSeq+ $ [docLit (Text.pack "(")]+ ++ (docForceSingleline <$> ieDs)+ ++ [docParenR]+ addAlternative+ $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])+ $ 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.+wrappedNameToText :: LIEWrappedName RdrName -> Text+wrappedNameToText = \case+ L _ (IEName n) -> lrdrNameToText n+ L _ (IEPattern n) -> lrdrNameToText n+ L _ (IEType n) -> lrdrNameToText n++-- | 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+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"+ where+ moduleNameToText :: Located ModuleName -> Text+ moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)
src/Language/Haskell/Brittany/Internal/Layouters/Import.hs view
@@ -21,6 +21,7 @@ import FieldLabel import qualified FastString import BasicTypes+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.Brittany.Internal.Utils @@ -35,8 +36,8 @@ prepModName :: Located e -> e prepModName = unLoc -layoutImport :: ToBriDoc ImportDecl-layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of+layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered+layoutImport importD = case importD of ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack@@ -90,14 +91,14 @@ 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 view
@@ -1,3 +1,5 @@+{-# LANGUAGE ViewPatterns #-}+ module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where #include "prelude.inc"@@ -21,7 +23,12 @@ 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 @@ -30,8 +37,16 @@ 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@@ -53,7 +68,7 @@ , appSep $ docLit tn , docWrapNode lmod $ appSep $ case les of Nothing -> docEmpty- Just x -> layoutLLIEs True x+ Just x -> layoutLLIEs True KeepItemsUnsorted x , docSeparator , docLit $ Text.pack "where" ]@@ -62,13 +77,140 @@ [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] )- (docSeq [ docWrapNode lmod $ case les of- Nothing -> docEmpty- Just x -> layoutLLIEs False x+ (docSeq [+ docWrapNode lmod $ case les of+ Nothing -> docEmpty+ Just x -> layoutLLIEs False KeepItemsUnsorted x , docSeparator , 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)