From ee9abff9e8e56e96ba0bb78a84c1f6a7491b60ea Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Sat, 16 Dec 2017 14:00:49 +0100 Subject: [PATCH 01/23] Add import and module support --- brittany.cabal | 3 + src-literatetests/10-tests.blt | 162 ++++++++++++++++++ src/Language/Haskell/Brittany/Internal.hs | 74 +++++--- .../Haskell/Brittany/Internal/Layouters/IE.hs | 70 ++++++++ .../Brittany/Internal/Layouters/Import.hs | 62 +++++++ .../Brittany/Internal/Layouters/Module.hs | 73 ++++++++ 6 files changed, 419 insertions(+), 25 deletions(-) create mode 100644 src/Language/Haskell/Brittany/Internal/Layouters/IE.hs create mode 100644 src/Language/Haskell/Brittany/Internal/Layouters/Import.hs create mode 100644 src/Language/Haskell/Brittany/Internal/Layouters/Module.hs diff --git a/brittany.cabal b/brittany.cabal index bfba1dc..173345e 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -67,6 +67,9 @@ library { Language.Haskell.Brittany.Internal.Layouters.Expr Language.Haskell.Brittany.Internal.Layouters.Stmt Language.Haskell.Brittany.Internal.Layouters.Pattern + Language.Haskell.Brittany.Internal.Layouters.IE + Language.Haskell.Brittany.Internal.Layouters.Import + Language.Haskell.Brittany.Internal.Layouters.Module Language.Haskell.Brittany.Internal.Transformations.Alt Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Par diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index c6d4203..f1ea640 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -544,3 +544,165 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] +### +#group module +### + +#test simple +module Main where + +#test no-exports +module Main () where + +#test one-export +module Main (main) where + +#test several-exports +module Main (main, test1, test2) where + +#test many-exports +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) +where + +#test exports-with-comments +module Main + ( main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + ) +where + +#test simple-export-with-things +module Main (Test(..)) where + +#test simple-export-with-module-contents +module Main (module Main) where + +#test export-with-things +module Main (Test(Test, a, b)) where + +#test export-with-empty-thing +module Main (Test()) where + +#test empty-with-comment +-- Intentionally left empty + +### +#group import +### + +#test simple-import +import Data.List + +#test simple-import-alias +import Data.List as L + +#test simple-qualified-import +import qualified Data.List + +#test simple-qualified-import-alias +import qualified Data.List as L + +#test simple-safe +import safe Data.List + +#test simple-source +import {-# SOURCE #-} Data.List + +#test simple-safe-qualified +import safe qualified Data.List + +#test simple-safe-qualified-source +import {-# SOURCE #-} safe qualified Data.List + +#test simple-qualified-package +import qualified "base" Data.List + +#test instances-only +import qualified Data.List () + +#test one-element +import Data.List (nub) + +#test several-elements +import Data.List (nub, foldl', indexElem) + +#test with-things +import Test (T, T2(), T3(..), T4(T4), T5(T5, t5)) + +#test hiding +import Test hiding () +import Test as T hiding () + +#test horizontal-layout +import Data.List (nub) +import qualified Data.List as L (foldl') + +import Test (test) +import Main hiding + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) + +#test import-with-comments +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +-- Test +import Test (test) + +#test preamble full-preamble +{-# LANGUAGE BangPatterns #-} + +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + ) +where + +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +-- Test +import Test (test) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index e6256ec..73a6799 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -33,6 +33,7 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Decl +import Language.Haskell.Brittany.Internal.Layouters.Module import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Backend import Language.Haskell.Brittany.Internal.BackendUtils @@ -155,7 +156,7 @@ pPrintModule conf anns parsedModule = in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do - -- + -- -- debugStrings `forM_` \s -> -- trace s $ return () @@ -243,30 +244,8 @@ parsePrintModuleTests conf filename input = do -- else return $ TextL.toStrict $ Text.Builder.toLazyText out ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM () -ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do - let emptyModule = L loc m { hsmodDecls = [] } - (anns', post) <- do - anns <- mAsk - -- evil partiality. but rather unlikely. - return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of - Nothing -> (anns, []) - Just mAnn -> - let modAnnsDp = ExactPrint.Types.annsDP mAnn - isWhere (ExactPrint.Types.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.Types.G AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post) = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp - (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.Types.annsDP = pre } - anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns - in (anns', post) - MultiRWSS.withMultiReader anns' $ processDefault emptyModule +ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do + post <- ppPreamble lmod decls `forM_` \decl -> do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap @@ -336,6 +315,51 @@ ppDecl d@(L loc decl) = case decl of layoutBriDoc briDoc _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc +-- Prints the information associated with the module annotation +-- This includes the imports +ppPreamble :: GenLocated SrcSpan (HsModule RdrName) + -> PPM [(ExactPrint.Types.KeywordId, ExactPrint.Types.DeltaPos)] +ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do + filteredAnns <- mAsk <&> \annMap -> + Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey lmod) annMap + -- Since ghc-exactprint adds annotations following (implicit) + -- modules to both HsModule and the elements in the module + -- this can cause duplication of comments. So strip + -- attached annotations that come after the module's where + -- from the module node + let (filteredAnns', post) = + case (ExactPrint.Types.mkAnnKey lmod) `Map.lookup` filteredAnns of + Nothing -> (filteredAnns, []) + Just mAnn -> + let modAnnsDp = ExactPrint.Types.annsDP mAnn + isWhere (ExactPrint.Types.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.Types.G AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post') = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + mAnn' = mAnn { ExactPrint.Types.annsDP = pre } + filteredAnns'' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' filteredAnns + in (filteredAnns'', post') + in do + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns' + + config <- mAsk + + MultiRWSS.withoutMultiReader $ do + MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil + withTransformedAnns lmod $ do + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc + return post + _sigHead :: Sig RdrName -> String _sigHead = \case TypeSig names _ -> diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs new file mode 100644 index 0000000..8f09d91 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -0,0 +1,70 @@ +module Language.Haskell.Brittany.Internal.Layouters.IE + ( layoutIE + , layoutIEList + ) +where + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName (RdrName(..)) +import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import HsSyn +import Name +import HsImpExp +import FieldLabel +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Internal.Utils + + +layoutIE :: ToBriDoc IE +layoutIE lie@(L _ _ie) = + docWrapNode lie + $ let + ien = docLit $ rdrNameToText $ ieName _ie + in + case _ie of + IEVar _ -> ien + IEThingAbs _ -> ien + IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ (IEWildcard _) _ _ -> + docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ _ ns fs -> + let + prepareFL = + docLit . Text.pack . FastString.unpackFS . flLabel . unLoc + in + docSeq + $ [ien, docLit $ Text.pack "("] + ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText) ns) + ++ intersperse docCommaSep (map (prepareFL) fs) + ) + ++ [docLit $ Text.pack ")"] + IEModuleContents n -> docSeq + [ docLit $ Text.pack "module" + , docSeparator + , docLit . Text.pack . moduleNameString $ unLoc n + ] + _ -> docEmpty + +layoutIEList :: [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutIEList lies = do + ies <- mapM (docSharedWrapper layoutIE) lies + case ies of + [] -> docLit $ Text.pack "()" + (x:xs) -> docAlt + [ docSeq + $ [docLit $ Text.pack "(", x] + ++ map (\x' -> docSeq [docCommaSep, x']) xs + ++ [docLit $ Text.pack ")"] + , docLines + ( docSeq [docLit $ Text.pack "(", docSeparator, x] + : map (\x' -> docSeq [docCommaSep, x']) xs + ++ [docLit $ Text.pack ")"] + ) + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs new file mode 100644 index 0000000..b4e3e0c --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -0,0 +1,62 @@ +module Language.Haskell.Brittany.Internal.Layouters.Import (layoutImport) where + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName (RdrName(..)) +import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import HsSyn +import Name +import HsImpExp +import FieldLabel +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Internal.Utils + +layoutImport :: ToBriDoc ImportDecl +layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of + ImportDecl _ (L _ modName) pkg src safe q False as llies -> + let + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . sl_st <$> pkg + asT = Text.pack . moduleNameString <$> as + sig = ColBindingLine (Just (Text.pack "import")) + importQualifiers = docSeq + [ appSep $ docLit $ Text.pack "import" + , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty + , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty + , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty + , fromMaybe docEmpty (appSep . docLit <$> pkgNameT) + ] + makeAs asT' = + appSep $ docSeq [docLit (Text.pack "as"), docSeparator, docLit asT'] + importIds = + docSeq $ [appSep $ docLit modNameT, fromMaybe docEmpty (makeAs <$> asT)] + in + do + (hiding, ies) <- case llies of + Just (h, L _ lies) -> do + sies <- docSharedWrapper layoutIEList lies + return (h, sies) + Nothing -> return (False, docEmpty) + h <- docSharedWrapper + ( const + ( docSeq + [ docCols sig [importQualifiers, importIds] + , if hiding + then appSep $ docLit $ Text.pack "hiding" + else docEmpty + ] + ) + ) + () + docAlt + [ docSeq [h, docForceSingleline ies] + , docAddBaseY BrIndentRegular $ docPar h (docForceMultiline ies) + ] + _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs new file mode 100644 index 0000000..0093c46 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -0,0 +1,73 @@ +module Language.Haskell.Brittany.Internal.Layouters.Module (layoutModule) where + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Layouters.IE +import Language.Haskell.Brittany.Internal.Layouters.Import +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName (RdrName(..)) +import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import HsSyn +import Name +import HsImpExp +import FieldLabel +import qualified FastString +import BasicTypes +import Language.Haskell.GHC.ExactPrint as ExactPrint +import Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types + +import Language.Haskell.Brittany.Internal.Utils + +layoutModule :: ToBriDoc HsModule +layoutModule lmod@(L _ mod') = do + case mod' of + -- Implicit module Main + HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule (Just n) les imports _ _ _ -> + let + tn = Text.pack $ moduleNameString $ unLoc n + in + do + cs <- do + anns <- mAsk + case ExactPrint.Types.mkAnnKey lmod `Map.lookup` anns of + Just mAnn -> return $ extractAllComments mAnn + Nothing -> return [] + (hasComments, es) <- case les of + Nothing -> return (False, docEmpty) + Just llies@(L _ lies) -> do + hasComments <- hasAnyCommentsBelow llies + return (hasComments, docWrapNode llies $ layoutIEList lies) + docLines + ( [ -- A pseudo node that serves merely to force documentation + -- before the node + docWrapNode lmod $ docEmpty + | [] /= cs + ] + ++ [ docAlt + ( [ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , appSep $ docForceSingleline es + , docLit $ Text.pack "where" + ] + | not hasComments + ] + ++ [ docLines + [ docAddBaseY BrIndentRegular $ docPar + ( docSeq + [ appSep $ docLit $ Text.pack "module" + , docLit tn + ] + ) + (docForceMultiline es) + , docLit $ Text.pack "where" + ] + ] + ) + ] + ++ map layoutImport imports + ) From a72465ebef408468a06dfe9fa89f9d33edb8f92c Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Sun, 17 Dec 2017 13:13:19 +0100 Subject: [PATCH 02/23] Add context-free tests --- src-literatetests/tests-context-free.blt | 163 ++++++++++++++++++++++- 1 file changed, 162 insertions(+), 1 deletion(-) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 7700adb..b8b0c4a 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -593,6 +593,168 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] +### +#group module +### + +#test simple +module Main where + +#test no-exports +module Main () where + +#test one-export +module Main (main) where + +#test several-exports +module Main (main, test1, test2) where + +#test many-exports +module Main + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) +where + +#test exports-with-comments +module Main + ( main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + ) +where + +#test simple-export-with-things +module Main (Test(..)) where + +#test simple-export-with-module-contents +module Main (module Main) where + +#test export-with-things +module Main (Test(Test, a, b)) where + +#test export-with-empty-thing +module Main (Test()) where + +#test empty-with-comment +-- Intentionally left empty + +### +#group import +### + +#test simple-import +import Data.List + +#test simple-import-alias +import Data.List as L + +#test simple-qualified-import +import qualified Data.List + +#test simple-qualified-import-alias +import qualified Data.List as L + +#test simple-safe +import safe Data.List + +#test simple-source +import {-# SOURCE #-} Data.List + +#test simple-safe-qualified +import safe qualified Data.List + +#test simple-safe-qualified-source +import {-# SOURCE #-} safe qualified Data.List + +#test simple-qualified-package +import qualified "base" Data.List + +#test instances-only +import qualified Data.List () + +#test one-element +import Data.List (nub) + +#test several-elements +import Data.List (nub, foldl', indexElem) + +#test with-things +import Test (T, T2(), T3(..), T4(T4), T5(T5, t5)) + +#test hiding +import Test hiding () +import Test as T hiding () + +#test horizontal-layout +import Data.List (nub) +import qualified Data.List as L (foldl') + +import Test (test) +import Main hiding + ( main + , test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + ) + +#test import-with-comments +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +-- Test +import Test (test) + +#test preamble full-preamble +{-# LANGUAGE BangPatterns #-} + +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + ) +where + +-- Test +import Data.List (nub) -- Test +{- Test -} +import qualified Data.List as L (foldl') {- Test -} + +-- Test +import Test (test) ############################################################################### ############################################################################### @@ -1128,4 +1290,3 @@ foo = ## ] ## where ## role = stringProperty "WM_WINDOW_ROLE" - From e140cd01e07838699e8a74777de707ebda179bfd Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Sun, 17 Dec 2017 14:00:16 +0100 Subject: [PATCH 03/23] Add directives for ghc > 8.2 --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 4 ++++ .../Brittany/Internal/Layouters/Import.hs | 19 +++++++++++++++++-- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 8f09d91..e6b83b7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -41,7 +41,11 @@ layoutIE lie@(L _ _ie) = in docSeq $ [ien, docLit $ Text.pack "("] +#if MIN_VERSION_ghc(8,2,0) + ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText . ieLWrappedName) ns) +#else ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText) ns) +#endif ++ intersperse docCommaSep (map (prepareFL) fs) ) ++ [docLit $ Text.pack ")"] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index b4e3e0c..6bfd63f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -23,8 +23,23 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ImportDecl _ (L _ modName) pkg src safe q False as llies -> let modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . sl_st <$> pkg - asT = Text.pack . moduleNameString <$> as +#if MIN_VERSION_ghc(8,2,0) + prepPkg rawN = + case rawN of + SourceText n -> n + -- This would be odd to encounter and the + -- result will most certainly be wrong + NoSourceText -> "" +#else + prepPkg = id +#endif + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg +#if MIN_VERSION_ghc(8,2,0) + prepModName = unLoc +#else + prepModName = id +#endif + asT = Text.pack . moduleNameString . prepModName <$> as sig = ColBindingLine (Just (Text.pack "import")) importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" From 204f0aff0857968a24d0f0e2f968c3bd91a51e26 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 17 Dec 2017 20:47:52 +0100 Subject: [PATCH 04/23] import+module: Refactor and Simplify slightly --- src-literatetests/10-tests.blt | 19 ++-- src-literatetests/tests-context-free.blt | 16 +++- .../Brittany/Internal/LayouterBasics.hs | 4 + .../Haskell/Brittany/Internal/Layouters/IE.hs | 84 +++++++++--------- .../Brittany/Internal/Layouters/Import.hs | 87 ++++++++++--------- .../Brittany/Internal/Layouters/Module.hs | 80 ++++++++--------- .../Haskell/Brittany/Internal/Types.hs | 1 + 7 files changed, 159 insertions(+), 132 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index f1ea640..6b838a3 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -544,9 +544,14 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] -### + +############################################################################### +############################################################################### +############################################################################### #group module -### +############################################################################### +############################################################################### +############################################################################### #test simple module Main where @@ -603,9 +608,13 @@ module Main (Test()) where #test empty-with-comment -- Intentionally left empty -### -#group import -### +############################################################################### +############################################################################### +############################################################################### +#group module.import +############################################################################### +############################################################################### +############################################################################### #test simple-import import Data.List diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index b8b0c4a..c588436 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -593,9 +593,13 @@ func = ] ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc] -### +############################################################################### +############################################################################### +############################################################################### #group module -### +############################################################################### +############################################################################### +############################################################################### #test simple module Main where @@ -652,9 +656,13 @@ module Main (Test()) where #test empty-with-comment -- Intentionally left empty -### +############################################################################### +############################################################################### +############################################################################### #group import -### +############################################################################### +############################################################################### +############################################################################### #test simple-import import Data.List diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 52c9e08..151dd65 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -42,6 +42,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , appSep , docCommaSep , docParenLSep + , docParenR , docTick , spacifyDocs , briDocMToPPM @@ -465,6 +466,9 @@ docCommaSep = appSep $ docLit $ Text.pack "," docParenLSep :: ToBriDocM BriDocNumbered docParenLSep = appSep $ docLit $ Text.pack "(" +docParenR :: ToBriDocM BriDocNumbered +docParenR = docLit $ Text.pack ")" + docTick :: ToBriDocM BriDocNumbered docTick = docLit $ Text.pack "'" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index e6b83b7..df1b6ff 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -11,7 +11,13 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types import RdrName (RdrName(..)) -import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import GHC ( unLoc + , runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + , Located + ) import HsSyn import Name import HsImpExp @@ -22,53 +28,53 @@ import BasicTypes import Language.Haskell.Brittany.Internal.Utils -layoutIE :: ToBriDoc IE -layoutIE lie@(L _ _ie) = - docWrapNode lie - $ let - ien = docLit $ rdrNameToText $ ieName _ie - in - case _ie of - IEVar _ -> ien - IEThingAbs _ -> ien - IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] - IEThingWith _ (IEWildcard _) _ _ -> - docSeq [ien, docLit $ Text.pack "(..)"] - IEThingWith _ _ ns fs -> - let - prepareFL = - docLit . Text.pack . FastString.unpackFS . flLabel . unLoc - in - docSeq - $ [ien, docLit $ Text.pack "("] + #if MIN_VERSION_ghc(8,2,0) - ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText . ieLWrappedName) ns) +prepareName :: LIEWrappedName name -> Located name +prepareName = ieLWrappedName #else - ++ ( intersperse docCommaSep (map (docLit . lrdrNameToText) ns) +prepareName :: Located name -> Located name +prepareName = id #endif - ++ intersperse docCommaSep (map (prepareFL) fs) - ) - ++ [docLit $ Text.pack ")"] - IEModuleContents n -> docSeq - [ docLit $ Text.pack "module" - , docSeparator - , docLit . Text.pack . moduleNameString $ unLoc n - ] - _ -> docEmpty + +layoutIE :: ToBriDoc IE +layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of + IEVar _ -> ien + IEThingAbs _ -> ien + IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] + IEThingWith _ _ ns fs -> + docSeq + $ [ien, docLit $ Text.pack "("] + ++ ( intersperse docCommaSep + (map (docLit . lrdrNameToText . prepareName) ns) + ++ intersperse docCommaSep (map prepareFL fs) + ) + ++ [docLit $ Text.pack ")"] + where + prepareFL = docLit . Text.pack . FastString.unpackFS . flLabel . unLoc + IEModuleContents n -> docSeq + [ docLit $ Text.pack "module" + , docSeparator + , docLit . Text.pack . moduleNameString $ unLoc n + ] + _ -> docEmpty + where ien = docLit $ rdrNameToText $ ieName ie layoutIEList :: [LIE RdrName] -> ToBriDocM BriDocNumbered layoutIEList lies = do ies <- mapM (docSharedWrapper layoutIE) lies case ies of - [] -> docLit $ Text.pack "()" - (x:xs) -> docAlt + [] -> docLit $ Text.pack "()" + xs@(x1:xr) -> docAlt [ docSeq - $ [docLit $ Text.pack "(", x] - ++ map (\x' -> docSeq [docCommaSep, x']) xs - ++ [docLit $ Text.pack ")"] + [ docLit $ Text.pack "(" + , docSeq $ List.intersperse docCommaSep xs + , docLit $ Text.pack ")" + ] , docLines - ( docSeq [docLit $ Text.pack "(", docSeparator, x] - : map (\x' -> docSeq [docCommaSep, x']) xs - ++ [docLit $ Text.pack ")"] + ( [docSeq [docParenLSep, x1]] + ++ [ docSeq [docCommaSep, x] | x <- xr ] + ++ [docParenR] ) ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 6bfd63f..ea5d49c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -8,7 +8,13 @@ import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Config.Types import RdrName (RdrName(..)) -import GHC (unLoc, runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..)) +import GHC ( unLoc + , runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId(..) + , Located + ) import HsSyn import Name import HsImpExp @@ -18,29 +24,36 @@ import BasicTypes import Language.Haskell.Brittany.Internal.Utils + + +#if MIN_VERSION_ghc(8,2,0) +prepPkg :: SourceText -> String +prepPkg rawN = + case rawN of + SourceText n -> n + -- This would be odd to encounter and the + -- result will most certainly be wrong + NoSourceText -> "" +#else +prepPkg :: String -> String +prepPkg = id +#endif +#if MIN_VERSION_ghc(8,2,0) +prepModName :: Located e -> e +prepModName = unLoc +#else +prepModName :: e -> e +prepModName = id +#endif + layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of - ImportDecl _ (L _ modName) pkg src safe q False as llies -> + ImportDecl _ (L _ modName) pkg src safe q False as llies -> do let modNameT = Text.pack $ moduleNameString modName -#if MIN_VERSION_ghc(8,2,0) - prepPkg rawN = - case rawN of - SourceText n -> n - -- This would be odd to encounter and the - -- result will most certainly be wrong - NoSourceText -> "" -#else - prepPkg = id -#endif pkgNameT = Text.pack . prepPkg . sl_st <$> pkg -#if MIN_VERSION_ghc(8,2,0) - prepModName = unLoc -#else - prepModName = id -#endif + asT = Text.pack . moduleNameString . prepModName <$> as - sig = ColBindingLine (Just (Text.pack "import")) importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty @@ -52,26 +65,22 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of appSep $ docSeq [docLit (Text.pack "as"), docSeparator, docLit asT'] importIds = docSeq $ [appSep $ docLit modNameT, fromMaybe docEmpty (makeAs <$> asT)] - in - do - (hiding, ies) <- case llies of - Just (h, L _ lies) -> do - sies <- docSharedWrapper layoutIEList lies - return (h, sies) - Nothing -> return (False, docEmpty) - h <- docSharedWrapper - ( const - ( docSeq - [ docCols sig [importQualifiers, importIds] - , if hiding - then appSep $ docLit $ Text.pack "hiding" - else docEmpty - ] - ) - ) - () - docAlt - [ docSeq [h, docForceSingleline ies] - , docAddBaseY BrIndentRegular $ docPar h (docForceMultiline ies) + (hiding, ies) <- case llies of + Just (h, L _ lies) -> do + sies <- docSharedWrapper layoutIEList lies + return (h, sies) + Nothing -> return (False, docEmpty) + h <- docSharedWrapper + ( const + ( docSeq + [ docCols ColImport [importQualifiers, importIds] + , if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty ] + ) + ) + () + docAlt + [ docSeq [h, docForceSingleline ies] + , docAddBaseY BrIndentRegular $ docPar h (docForceMultiline ies) + ] _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 0093c46..d7ce6ea 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -21,53 +21,43 @@ import Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.Brittany.Internal.Utils + + layoutModule :: ToBriDoc HsModule layoutModule lmod@(L _ mod') = do case mod' of -- Implicit module Main - HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports - HsModule (Just n) les imports _ _ _ -> - let - tn = Text.pack $ moduleNameString $ unLoc n - in - do - cs <- do - anns <- mAsk - case ExactPrint.Types.mkAnnKey lmod `Map.lookup` anns of - Just mAnn -> return $ extractAllComments mAnn - Nothing -> return [] - (hasComments, es) <- case les of - Nothing -> return (False, docEmpty) - Just llies@(L _ lies) -> do - hasComments <- hasAnyCommentsBelow llies - return (hasComments, docWrapNode llies $ layoutIEList lies) - docLines - ( [ -- A pseudo node that serves merely to force documentation + HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule (Just n) les imports _ _ _ -> do + let tn = Text.pack $ moduleNameString $ unLoc n + (hasComments, es) <- case les of + Nothing -> return (False, docEmpty) + Just llies@(L _ lies) -> do + hasComments <- hasAnyCommentsBelow llies + return (hasComments, docWrapNode llies $ layoutIEList lies) + docLines + $ docSeq + [ docWrapNode lmod $ docEmpty + -- A pseudo node that serves merely to force documentation -- before the node - docWrapNode lmod $ docEmpty - | [] /= cs - ] - ++ [ docAlt - ( [ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , appSep $ docForceSingleline es - , docLit $ Text.pack "where" - ] - | not hasComments - ] - ++ [ docLines - [ docAddBaseY BrIndentRegular $ docPar - ( docSeq - [ appSep $ docLit $ Text.pack "module" - , docLit tn - ] - ) - (docForceMultiline es) - , docLit $ Text.pack "where" - ] - ] - ) - ] - ++ map layoutImport imports - ) + , docAlt + ( [ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , appSep $ docForceSingleline es + , docLit $ Text.pack "where" + ] + | not hasComments + ] + ++ [ docLines + [ docAddBaseY BrIndentRegular $ docPar + ( docSeq + [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docForceMultiline es) + , docLit $ Text.pack "where" + ] + ] + ) + ] + : map layoutImport imports diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 557f9b3..2784c1d 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -178,6 +178,7 @@ data ColSig | ColTuple | ColTuples | ColOpPrefix -- merge with ColList ? other stuff? + | ColImport -- TODO deriving (Eq, Ord, Data.Data.Data, Show) From c3b6e172614eb53468fb8cec50000b99b3681c2b Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Mon, 18 Dec 2017 12:01:22 +0100 Subject: [PATCH 05/23] Improve layout for imports --- src-literatetests/10-tests.blt | 88 ++++++++------ src-literatetests/tests-context-free.blt | 79 +++++++------ .../Brittany/Internal/Layouters/Import.hs | 108 +++++++++++------- 3 files changed, 166 insertions(+), 109 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 6b838a3..97a5463 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -617,22 +617,22 @@ module Main (Test()) where ############################################################################### #test simple-import -import Data.List +import Data.List #test simple-import-alias -import Data.List as L +import Data.List as L #test simple-qualified-import import qualified Data.List #test simple-qualified-import-alias -import qualified Data.List as L +import qualified Data.List as L #test simple-safe -import safe Data.List +import safe Data.List as L #test simple-source -import {-# SOURCE #-} Data.List +import {-# SOURCE #-} Data.List ( ) #test simple-safe-qualified import safe qualified Data.List @@ -643,48 +643,69 @@ import {-# SOURCE #-} safe qualified Data.List #test simple-qualified-package import qualified "base" Data.List +#test qualifier-effect +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List ( ) +import {-# SOURCE #-} safe qualified Data.List hiding ( ) + #test instances-only -import qualified Data.List () +import qualified Data.List ( ) #test one-element -import Data.List (nub) +import Data.List ( nub ) #test several-elements -import Data.List (nub, foldl', indexElem) +import Data.List ( nub + , foldl' + , indexElem + ) #test with-things -import Test (T, T2(), T3(..), T4(T4), T5(T5, t5)) +import Test ( T + , T2() + , T3(..) + , T4(T4) + , T5(T5, t5) + ) #test hiding -import Test hiding () -import Test as T hiding () +import Test hiding ( ) +import Test as T + hiding ( ) -#test horizontal-layout -import Data.List (nub) -import qualified Data.List as L (foldl') +#test long-module-name +import TestJustShortEnoughModuleNameLikeThisOne ( ) +import TestJustAbitToLongModuleNameLikeThisOneIs + ( ) -import Test (test) -import Main hiding - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI + as T + +import TestJustShortEnoughModuleNameLike hiding ( ) +import TestJustAbitToLongModuleNameLikeTh + hiding ( ) + +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 ( ) #test import-with-comments -- Test -import Data.List (nub) -- Test +import Data.List ( nub ) -- Test {- Test -} -import qualified Data.List as L (foldl') {- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} -- Test -import Test (test) +import Test ( test ) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} @@ -709,9 +730,10 @@ module Test where -- Test -import Data.List (nub) -- Test +import Data.List ( nub ) -- Test {- Test -} -import qualified Data.List as L (foldl') {- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} -- Test -import Test (test) +import Test ( test ) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index c588436..f9b4eb6 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -665,25 +665,25 @@ module Main (Test()) where ############################################################################### #test simple-import -import Data.List +import Data.List #test simple-import-alias -import Data.List as L +import Data.List as L #test simple-qualified-import import qualified Data.List #test simple-qualified-import-alias -import qualified Data.List as L +import qualified Data.List as L #test simple-safe -import safe Data.List +import safe Data.List as L #test simple-source -import {-# SOURCE #-} Data.List +import {-# SOURCE #-} Data.List ( ) #test simple-safe-qualified -import safe qualified Data.List +import safe qualified Data.Lis hiding ( nub ) #test simple-safe-qualified-source import {-# SOURCE #-} safe qualified Data.List @@ -691,48 +691,56 @@ import {-# SOURCE #-} safe qualified Data.List #test simple-qualified-package import qualified "base" Data.List +#test qualifier-effect +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List ( ) +import {-# SOURCE #-} safe qualified Data.List hiding ( ) + #test instances-only -import qualified Data.List () +import qualified Data.List ( ) #test one-element -import Data.List (nub) +import Data.List ( nub ) #test several-elements -import Data.List (nub, foldl', indexElem) +import Data.List ( nub + , foldl' + , indexElem + ) #test with-things -import Test (T, T2(), T3(..), T4(T4), T5(T5, t5)) +import Test ( T + , T2() + , T3(..) + , T4(T4) + , T5(T5, t5) + ) #test hiding -import Test hiding () -import Test as T hiding () +import Test hiding ( ) +import Test as T + hiding ( ) -#test horizontal-layout -import Data.List (nub) -import qualified Data.List as L (foldl') - -import Test (test) -import Main hiding - ( main - , test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - ) +#test long-module-name +import TestJustShortEnoughModuleNameLikeThisOne ( ) +import TestJustAbitToLongModuleNameLikeThisOneIs + ( ) +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI + as T +import TestJustShortEnoughModuleNameLike hiding ( ) +import TestJustAbitToLongModuleNameLikeTh + hiding ( ) #test import-with-comments -- Test -import Data.List (nub) -- Test +import Data.List ( nub ) -- Test {- Test -} -import qualified Data.List as L (foldl') {- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} -- Test -import Test (test) +import Test ( test ) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} @@ -757,12 +765,13 @@ module Test where -- Test -import Data.List (nub) -- Test +import Data.List ( nub ) -- Test {- Test -} -import qualified Data.List as L (foldl') {- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} -- Test -import Test (test) +import Test ( test ) ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index ea5d49c..83343bb 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -7,17 +7,14 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Config.Types -import RdrName (RdrName(..)) -import GHC ( unLoc - , runGhc - , GenLocated(L) - , moduleNameString - , AnnKeywordId(..) - , Located - ) +import RdrName ( RdrName(..) ) +import GHC ( unLoc + , GenLocated(L) + , moduleNameString + , Located + ) import HsSyn import Name -import HsImpExp import FieldLabel import qualified FastString import BasicTypes @@ -28,12 +25,11 @@ import Language.Haskell.Brittany.Internal.Utils #if MIN_VERSION_ghc(8,2,0) prepPkg :: SourceText -> String -prepPkg rawN = - case rawN of - SourceText n -> n - -- This would be odd to encounter and the - -- result will most certainly be wrong - NoSourceText -> "" +prepPkg rawN = case rawN of + SourceText n -> n + -- This would be odd to encounter and the + -- result will most certainly be wrong + NoSourceText -> "" #else prepPkg :: String -> String prepPkg = id @@ -49,11 +45,26 @@ prepModName = id layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ImportDecl _ (L _ modName) pkg src safe q False as llies -> do + importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack let - modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - - asT = Text.pack . moduleNameString . prepModName <$> as + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg + asT = Text.pack . moduleNameString . prepModName <$> as + (hiding, mlies) = case llies of + Just (h, L _ lies') -> (h, Just lies') + Nothing -> (False, Nothing) + minQLength = length "import qualified " + qLengthReal = + let qualifiedPart = if q then length "qualified " else 0 + safePart = if safe then length "safe " else 0 + pkgPart = fromMaybe 0 ((+ 1) . Text.length <$> pkgNameT) + srcPart = if src then length "{-# SOURCE #-} " else 0 + in length "import " + srcPart + safePart + qualifiedPart + pkgPart + qLength = max minQLength qLengthReal + -- Cost in columns of importColumn + asCost = length "as " + bindingCost = if hiding then length "hiding ( " else length "( " + nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty @@ -61,26 +72,41 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty , fromMaybe docEmpty (appSep . docLit <$> pkgNameT) ] - makeAs asT' = - appSep $ docSeq [docLit (Text.pack "as"), docSeparator, docLit asT'] - importIds = - docSeq $ [appSep $ docLit modNameT, fromMaybe docEmpty (makeAs <$> asT)] - (hiding, ies) <- case llies of - Just (h, L _ lies) -> do - sies <- docSharedWrapper layoutIEList lies - return (h, sies) - Nothing -> return (False, docEmpty) - h <- docSharedWrapper - ( const - ( docSeq - [ docCols ColImport [importQualifiers, importIds] - , if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty - ] - ) - ) - () - docAlt - [ docSeq [h, docForceSingleline ies] - , docAddBaseY BrIndentRegular $ docPar h (docForceMultiline ies) - ] + modNameD = + docEnsureIndent (BrIndentSpecial qLength) $ appSep $ docLit modNameT + hidDoc = + if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty + importHead = docSeq [importQualifiers, modNameD] + Just lies = mlies + (ieH:ieT) = map layoutIE lies + makeIENode ie = docSeq [docCommaSep, ie] + bindings@(bindingsH:bindingsT) = + docSeq [docParenLSep, ieH] + : map makeIENode ieT + ++ [docSeq [docSeparator, docParenR]] + bindingsD = case mlies of + Nothing -> docSeq [docEmpty] + -- ..[hiding].( ) + Just [] -> docSeq [hidDoc, docParenLSep, docParenR] + -- ..[hiding].( b ) + Just [_] -> docSeq $ hidDoc : bindings + -- ..[hiding].( b + -- , b' + -- ) + Just _ -> + docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) $ docLines bindingsT + bindingLine = + docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD + case asT of + Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] + | otherwise -> docLines [importHead, asDoc, bindingLine] + where + enoughRoom = nameCost < importCol - asCost + asDoc = + docEnsureIndent (BrIndentSpecial (importCol - asCost)) + $ docSeq + $ [appSep $ docLit $ Text.pack "as", docLit n] + Nothing | enoughRoom -> docSeq [importHead, bindingLine] + | otherwise -> docLines [importHead, bindingLine] + where enoughRoom = nameCost < importCol - bindingCost _ -> docEmpty From 8c3a9bec251eb80df64e5e6b5b539ebbff9d3f78 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 18 Dec 2017 18:56:50 +0100 Subject: [PATCH 06/23] Fix operators in import list --- src-literatetests/10-tests.blt | 1 + src-literatetests/tests-context-free.blt | 1 + src/Language/Haskell/Brittany/Internal/Layouters/IE.hs | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 97a5463..6091095 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -666,6 +666,7 @@ import Test ( T , T3(..) , T4(T4) , T5(T5, t5) + , (+) ) #test hiding diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index f9b4eb6..7a004ce 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -714,6 +714,7 @@ import Test ( T , T3(..) , T4(T4) , T5(T5, t5) + , (+) ) #test hiding diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index df1b6ff..4333d8e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -59,7 +59,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of , docLit . Text.pack . moduleNameString $ unLoc n ] _ -> docEmpty - where ien = docLit $ rdrNameToText $ ieName ie + where ien = docLit =<< lrdrNameToTextAnn (ieName <$> lie) layoutIEList :: [LIE RdrName] -> ToBriDocM BriDocNumbered layoutIEList lies = do From eac17b1bf28637f608da973df7b137115b18bdc1 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 01:11:25 +0100 Subject: [PATCH 07/23] Also render comments on the binding list --- .../Haskell/Brittany/Internal/Layouters/Import.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 83343bb..4f00f00 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -44,13 +44,13 @@ prepModName = id layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of - ImportDecl _ (L _ modName) pkg src safe q False as llies -> do + ImportDecl _ (L _ modName) pkg src safe q False as mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack let modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg asT = Text.pack . moduleNameString . prepModName <$> as - (hiding, mlies) = case llies of + (hiding, mlies) = case mllies of Just (h, L _ lies') -> (h, Just lies') Nothing -> (False, Nothing) minQLength = length "import qualified " @@ -78,6 +78,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty importHead = docSeq [importQualifiers, modNameD] Just lies = mlies + Just (_, llies) = mllies (ieH:ieT) = map layoutIE lies makeIENode ie = docSeq [docCommaSep, ie] bindings@(bindingsH:bindingsT) = @@ -93,8 +94,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of -- ..[hiding].( b -- , b' -- ) - Just _ -> - docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) $ docLines bindingsT + Just _ -> docWrapNode llies $ docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) $ docLines bindingsT bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD case asT of From 7c51a181c8af97bd1b9ac8f50eca2e98cb351d9d Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 01:17:19 +0100 Subject: [PATCH 08/23] Fix operators for ThingWith --- src-literatetests/10-tests.blt | 1 + src-literatetests/tests-context-free.blt | 1 + src/Language/Haskell/Brittany/Internal/Layouters/IE.hs | 2 +- 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 6091095..8c5b547 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -666,6 +666,7 @@ import Test ( T , T3(..) , T4(T4) , T5(T5, t5) + , T6((<|>)) , (+) ) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 7a004ce..5f21502 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -714,6 +714,7 @@ import Test ( T , T3(..) , T4(T4) , T5(T5, t5) + , T6((<|>)) , (+) ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 4333d8e..9876f01 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -47,7 +47,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of docSeq $ [ien, docLit $ Text.pack "("] ++ ( intersperse docCommaSep - (map (docLit . lrdrNameToText . prepareName) ns) + (map ((docLit =<<) . lrdrNameToTextAnn . prepareName) ns) ++ intersperse docCommaSep (map prepareFL fs) ) ++ [docLit $ Text.pack ")"] From a59df1f3913344768e4d5d2b7835652e787eecef Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 14:28:22 +0100 Subject: [PATCH 09/23] Fix comments!! :hooray: --- src-literatetests/10-tests.blt | 23 +++++++++++ src-literatetests/tests-context-free.blt | 23 +++++++++++ .../Brittany/Internal/Layouters/Import.hs | 41 +++++++++++++++---- 3 files changed, 79 insertions(+), 8 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 8c5b547..6b49e57 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -709,6 +709,29 @@ import qualified Data.List as L -- Test import Test ( test ) +#test import-with-comments-2 + +import Test ( abc + , def + -- comment + ) + +#test import-with-comments-3 + +import Test ( abc + -- comment + ) + +#test import-with-comments-4 +import Test ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 5f21502..1bc25ac 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -741,6 +741,29 @@ import Data.List ( nub ) -- Test import qualified Data.List as L ( foldl' ) {- Test -} +#test import-with-comments-2 + +import Test ( abc + , def + -- comment + ) + +#test import-with-comments-3 + +import Test ( abc + -- comment + ) + +#test import-with-comments-4 +import Test ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) + -- Test import Test ( test ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 4f00f00..e2ba394 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -76,25 +76,50 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of docEnsureIndent (BrIndentSpecial qLength) $ appSep $ docLit modNameT hidDoc = if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty - importHead = docSeq [importQualifiers, modNameD] - Just lies = mlies + importHead = docSeq [importQualifiers, modNameD] + Just lies = mlies Just (_, llies) = mllies - (ieH:ieT) = map layoutIE lies + (ieH:ieT) = map layoutIE lies makeIENode ie = docSeq [docCommaSep, ie] bindings@(bindingsH:bindingsT) = docSeq [docParenLSep, ieH] - : map makeIENode ieT + : bindingsT' ++ [docSeq [docSeparator, docParenR]] + where + -- Handle the last element with docWrapNode llies + bindingsT' = + case ieT of + [] -> [] + [ie] -> [makeIENode $ docWrapNode llies $ ie] + _ -> map makeIENode (List.init ieT) ++ [makeIENode $ docWrapNode llies $ List.last ieT] bindingsD = case mlies of - Nothing -> docSeq [docEmpty] + Nothing -> docSeq [docEmpty] -- ..[hiding].( ) - Just [] -> docSeq [hidDoc, docParenLSep, docParenR] + Just [] -> do + hasComments <- hasAnyCommentsBelow llies + if hasComments + then + docWrapNodeRest llies + $ docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + $ docLines [docParenR] + else + docWrapNodeRest llies $ docSeq [hidDoc, docParenLSep, docParenR] -- ..[hiding].( b ) - Just [_] -> docSeq $ hidDoc : bindings + Just [_] -> do + hasComments <- hasAnyCommentsBelow llies + if hasComments + then + docWrapNodeRest llies $ docPar (docSeq [hidDoc, docWrapNode llies $ bindingsH]) $ docLines + bindingsT + else + docWrapNodeRest llies $ docSeq $ hidDoc : bindings -- ..[hiding].( b -- , b' -- ) - Just _ -> docWrapNode llies $ docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) $ docLines bindingsT + Just _ -> + docWrapNodeRest llies $ docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) + $ docLines bindingsT bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD case asT of From 162b6e6bfda6fc64b6f5fc28345bca41fab383d7 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 16:33:13 +0100 Subject: [PATCH 10/23] Also fix export comments Also refactored a little to improve reuse of the docWrapNode logic --- src-literatetests/10-tests.blt | 11 +++ src-literatetests/tests-context-free.blt | 10 +++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 57 +++++++++----- .../Brittany/Internal/Layouters/Import.hs | 75 ++++++++----------- .../Brittany/Internal/Layouters/Module.hs | 4 +- 5 files changed, 94 insertions(+), 63 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 6b49e57..e560296 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -583,6 +583,7 @@ where #test exports-with-comments module Main ( main + -- main , test1 , test2 -- Test 3 @@ -590,6 +591,7 @@ module Main , test4 -- Test 5 , test5 + -- Test 6 ) where @@ -732,6 +734,14 @@ import Test ( abc -- comment ) +#test import-with-comments-5 +import Test ( -- comment + ) + +#test long-bindings +import Test ( longbindingNameThatoverflowsColum ) +import Test ( Long(List, Of, Things) ) + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} @@ -751,6 +761,7 @@ module Test , test8 , test9 , test10 + -- Test 10 ) where diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 1bc25ac..8be4666 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -631,6 +631,7 @@ where #test exports-with-comments module Main ( main + -- main , test1 , test2 -- Test 3 @@ -638,6 +639,7 @@ module Main , test4 -- Test 5 , test5 + -- Test 6 ) where @@ -767,6 +769,14 @@ import Test ( abc -- Test import Test ( test ) +#test import-with-comments-5 +import Test ( -- comment + ) + +#test long-bindings +import Test ( longbindingNameThatoverflowsColum ) +import Test ( Long(List, Of, Things) ) + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 9876f01..bf87b6d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -1,6 +1,7 @@ module Language.Haskell.Brittany.Internal.Layouters.IE ( layoutIE - , layoutIEList + , layoutLLIEs + , layoutAnnAndSepLLIEs ) where @@ -61,20 +62,42 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of _ -> docEmpty where ien = docLit =<< lrdrNameToTextAnn (ieName <$> lie) -layoutIEList :: [LIE RdrName] -> ToBriDocM BriDocNumbered -layoutIEList lies = do - ies <- mapM (docSharedWrapper layoutIE) lies - case ies of - [] -> docLit $ Text.pack "()" - xs@(x1:xr) -> docAlt - [ docSeq - [ docLit $ Text.pack "(" - , docSeq $ List.intersperse docCommaSep xs - , docLit $ Text.pack ")" +-- Helper function to deal with Located lists of LIEs. +-- In particular this will also associate documentation +-- from the LIES that actually belongs to the last IE. +-- It also add docCommaSep to all but he last element +-- This configuration allows both vertical and horizontal +-- handling of the resulting list. Adding parens is +-- left to the caller since that is context sensitive +layoutAnnAndSepLLIEs :: (Located [LIE RdrName]) -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs llies@(L _ lies) = do + let makeIENode ie = docSeq [docCommaSep, ie] + layoutAnnAndSepLLIEs' ies = case ies of + [] -> [] + [ie] -> [docWrapNode llies $ ie] + (ie:ies') -> ie:map makeIENode (List.init ies') + ++ [makeIENode $ docWrapNode llies $ List.last ies'] + layoutAnnAndSepLLIEs' <$> mapM (docSharedWrapper layoutIE) lies + +-- Builds a complete layout for the given located +-- list of LIEs. The layout provides two alternatives: +-- (item, item, ..., item) +-- ( item +-- , item +-- ... +-- , item +-- ) +-- Empty lists will always be rendered as () +layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutLLIEs llies = docWrapNodeRest llies $ do + ieDs <- layoutAnnAndSepLLIEs llies + case ieDs of + [] -> docLit $ Text.pack "()" + ieDs@(ieDsH:ieDsT) -> + docAlt + [ docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR] + , docLines $ + docSeq [docParenLSep, ieDsH] + : ieDsT + ++ [docParenR] ] - , docLines - ( [docSeq [docParenLSep, x1]] - ++ [ docSeq [docCommaSep, x] | x <- xr ] - ++ [docParenR] - ) - ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index e2ba394..cc4172f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -50,9 +50,9 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg asT = Text.pack . moduleNameString . prepModName <$> as - (hiding, mlies) = case mllies of - Just (h, L _ lies') -> (h, Just lies') - Nothing -> (False, Nothing) + hiding = case mllies of + Just (h, _) -> h + Nothing -> False minQLength = length "import qualified " qLengthReal = let qualifiedPart = if q then length "qualified " else 0 @@ -77,49 +77,36 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of hidDoc = if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty importHead = docSeq [importQualifiers, modNameD] - Just lies = mlies - Just (_, llies) = mllies - (ieH:ieT) = map layoutIE lies - makeIENode ie = docSeq [docCommaSep, ie] - bindings@(bindingsH:bindingsT) = - docSeq [docParenLSep, ieH] - : bindingsT' - ++ [docSeq [docSeparator, docParenR]] - where - -- Handle the last element with docWrapNode llies - bindingsT' = - case ieT of - [] -> [] - [ie] -> [makeIENode $ docWrapNode llies $ ie] - _ -> map makeIENode (List.init ieT) ++ [makeIENode $ docWrapNode llies $ List.last ieT] - bindingsD = case mlies of + bindingsH = docParenLSep + bindingsT = [docSeq [docSeparator, docParenR]] + bindingsD = case mllies of Nothing -> docSeq [docEmpty] - -- ..[hiding].( ) - Just [] -> do + Just (_, llies) -> do + ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies - if hasComments - then - docWrapNodeRest llies - $ docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - $ docLines [docParenR] - else - docWrapNodeRest llies $ docSeq [hidDoc, docParenLSep, docParenR] - -- ..[hiding].( b ) - Just [_] -> do - hasComments <- hasAnyCommentsBelow llies - if hasComments - then - docWrapNodeRest llies $ docPar (docSeq [hidDoc, docWrapNode llies $ bindingsH]) $ docLines - bindingsT - else - docWrapNodeRest llies $ docSeq $ hidDoc : bindings - -- ..[hiding].( b - -- , b' - -- ) - Just _ -> - docWrapNodeRest llies $ docPar (docSeq [hidDoc, docSetBaseY $ bindingsH]) - $ docLines bindingsT + case ieDs of + -- ..[hiding].( ) + [] -> do + if hasComments + then + docWrapNodeRest llies $ docPar (docSeq [hidDoc, bindingsH, docWrapNode llies docEmpty]) $ docLines + bindingsT + else + docWrapNodeRest llies $ docSeq $ hidDoc : bindingsH : bindingsT + -- ..[hiding].( b ) + [ieD] -> do + if hasComments + then + docWrapNodeRest llies $ docPar (docSeq [hidDoc, bindingsH, ieD ]) $ docLines $ + bindingsT + else + docWrapNodeRest llies $ docSeq $ hidDoc : bindingsH : ieD : bindingsT + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> do + docWrapNodeRest llies $ docPar (docSeq [hidDoc, docSetBaseY $ docSeq [bindingsH, ieD]]) + $ docLines $ ieDs' ++ bindingsT bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD case asT of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index d7ce6ea..509b24a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -32,9 +32,9 @@ layoutModule lmod@(L _ mod') = do let tn = Text.pack $ moduleNameString $ unLoc n (hasComments, es) <- case les of Nothing -> return (False, docEmpty) - Just llies@(L _ lies) -> do + Just llies -> do hasComments <- hasAnyCommentsBelow llies - return (hasComments, docWrapNode llies $ layoutIEList lies) + return (hasComments, layoutLLIEs llies) docLines $ docSeq [ docWrapNode lmod $ docEmpty From ce7ec0b4679d5fd3cb8a2e51a67752d34dd2390b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 19 Dec 2017 17:52:33 +0100 Subject: [PATCH 11/23] Fix warning --- src/Language/Haskell/Brittany/Internal/Layouters/IE.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index bf87b6d..3daf877 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -93,7 +93,7 @@ layoutLLIEs llies = docWrapNodeRest llies $ do ieDs <- layoutAnnAndSepLLIEs llies case ieDs of [] -> docLit $ Text.pack "()" - ieDs@(ieDsH:ieDsT) -> + (ieDsH:ieDsT) -> docAlt [ docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR] , docLines $ From 33f23a65ec44d70aecde50dcdaf16b09a4f8c470 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 21 Dec 2017 15:44:58 +0100 Subject: [PATCH 12/23] Refactor and Add missing docSharedWrapper --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 15 +++-- .../Brittany/Internal/Layouters/Import.hs | 55 +++++++++---------- .../Brittany/Internal/Layouters/Module.hs | 11 ++-- 3 files changed, 41 insertions(+), 40 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 3daf877..926f642 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -71,12 +71,15 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -- left to the caller since that is context sensitive layoutAnnAndSepLLIEs :: (Located [LIE RdrName]) -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs llies@(L _ lies) = do - let makeIENode ie = docSeq [docCommaSep, ie] - layoutAnnAndSepLLIEs' ies = case ies of - [] -> [] - [ie] -> [docWrapNode llies $ ie] - (ie:ies') -> ie:map makeIENode (List.init ies') - ++ [makeIENode $ docWrapNode llies $ List.last ies'] + let + makeIENode ie = docSeq [docCommaSep, ie] + layoutAnnAndSepLLIEs' ies = case splitFirstLast ies of + FirstLastEmpty -> [] + FirstLastSingleton ie -> [docWrapNodeRest llies $ ie] + FirstLast ie1 ieMs ieN -> + [ie1] + ++ map makeIENode ieMs + ++ [makeIENode $ docWrapNodeRest llies $ ieN] layoutAnnAndSepLLIEs' <$> mapM (docSharedWrapper layoutIE) lies -- Builds a complete layout for the given located diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index cc4172f..7aac868 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -46,13 +46,16 @@ layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ImportDecl _ (L _ modName) pkg src safe q False as mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack + -- NB we don't need to worry about sharing in the below code + -- (docSharedWrapper etc.) because we do not use any docAlt nodes; all + -- "decisions" are made statically. let - modNameT = Text.pack $ moduleNameString modName - pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - asT = Text.pack . moduleNameString . prepModName <$> as - hiding = case mllies of + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg + asT = Text.pack . moduleNameString . prepModName <$> as + hiding = case mllies of Just (h, _) -> h - Nothing -> False + Nothing -> False minQLength = length "import qualified " qLengthReal = let qualifiedPart = if q then length "qualified " else 0 @@ -76,37 +79,31 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of docEnsureIndent (BrIndentSpecial qLength) $ appSep $ docLit modNameT hidDoc = if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty - importHead = docSeq [importQualifiers, modNameD] - bindingsH = docParenLSep - bindingsT = [docSeq [docSeparator, docParenR]] - bindingsD = case mllies of - Nothing -> docSeq [docEmpty] + importHead = docSeq [importQualifiers, modNameD] + bindingsD = case mllies of + Nothing -> docSeq [docEmpty] Just (_, llies) -> do - ieDs <- layoutAnnAndSepLLIEs llies + ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies - case ieDs of + docWrapNodeRest llies $ case ieDs of -- ..[hiding].( ) - [] -> do - if hasComments - then - docWrapNodeRest llies $ docPar (docSeq [hidDoc, bindingsH, docWrapNode llies docEmpty]) $ docLines - bindingsT - else - docWrapNodeRest llies $ docSeq $ hidDoc : bindingsH : bindingsT + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + docParenR + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] -- ..[hiding].( b ) - [ieD] -> do - if hasComments - then - docWrapNodeRest llies $ docPar (docSeq [hidDoc, bindingsH, ieD ]) $ docLines $ - bindingsT - else - docWrapNodeRest llies $ docSeq $ hidDoc : bindingsH : ieD : bindingsT + [ieD] -> if hasComments + then docPar (docSeq [hidDoc, docParenLSep, ieD]) docParenR + else docSeq [hidDoc, docParenLSep, ieD, docSeparator, docParenR] -- ..[hiding].( b -- , b' -- ) - (ieD:ieDs') -> do - docWrapNodeRest llies $ docPar (docSeq [hidDoc, docSetBaseY $ docSeq [bindingsH, ieD]]) - $ docLines $ ieDs' ++ bindingsT + (ieD:ieDs') -> + docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + $ docLines + $ ieDs' + ++ [docParenR] bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD case asT of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 509b24a..c0f569b 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -30,11 +30,12 @@ layoutModule lmod@(L _ mod') = do HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports HsModule (Just n) les imports _ _ _ -> do let tn = Text.pack $ moduleNameString $ unLoc n - (hasComments, es) <- case les of - Nothing -> return (False, docEmpty) + (hasComments, exportsDoc) <- case les of + Nothing -> return (False, docEmpty) Just llies -> do hasComments <- hasAnyCommentsBelow llies - return (hasComments, layoutLLIEs llies) + exportsDoc <- docSharedWrapper layoutLLIEs llies + return (hasComments, exportsDoc) docLines $ docSeq [ docWrapNode lmod $ docEmpty @@ -44,7 +45,7 @@ layoutModule lmod@(L _ mod') = do ( [ docSeq [ appSep $ docLit $ Text.pack "module" , appSep $ docLit tn - , appSep $ docForceSingleline es + , appSep $ docForceSingleline exportsDoc , docLit $ Text.pack "where" ] | not hasComments @@ -54,7 +55,7 @@ layoutModule lmod@(L _ mod') = do ( docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) - (docForceMultiline es) + (docForceMultiline exportsDoc) , docLit $ Text.pack "where" ] ] From 82a5ffb3b3ce02f4370784e416c999518bd07d5a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 21 Dec 2017 17:56:54 +0100 Subject: [PATCH 13/23] Refactor a bit more - remove unnecessary docWrapNodeRest - make sure that sharing is correct and non-redundant --- .../Haskell/Brittany/Internal/Layouters/IE.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 926f642..bce0a4a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -69,18 +69,18 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -- This configuration allows both vertical and horizontal -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive -layoutAnnAndSepLLIEs :: (Located [LIE RdrName]) -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs + :: Located [LIE RdrName] -> ToBriDocM [ToBriDocM BriDocNumbered] layoutAnnAndSepLLIEs llies@(L _ lies) = do - let - makeIENode ie = docSeq [docCommaSep, ie] - layoutAnnAndSepLLIEs' ies = case splitFirstLast ies of + let makeIENode ie = docSeq [docCommaSep, ie] + let ieDocs = layoutIE <$> lies + ieCommaDocs <- + docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of FirstLastEmpty -> [] - FirstLastSingleton ie -> [docWrapNodeRest llies $ ie] + FirstLastSingleton ie -> [ie] FirstLast ie1 ieMs ieN -> - [ie1] - ++ map makeIENode ieMs - ++ [makeIENode $ docWrapNodeRest llies $ ieN] - layoutAnnAndSepLLIEs' <$> mapM (docSharedWrapper layoutIE) lies + [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] + pure $ fmap pure ieCommaDocs -- returned shared nodes -- Builds a complete layout for the given located -- list of LIEs. The layout provides two alternatives: @@ -92,7 +92,7 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- ) -- Empty lists will always be rendered as () layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered -layoutLLIEs llies = docWrapNodeRest llies $ do +layoutLLIEs llies = do ieDs <- layoutAnnAndSepLLIEs llies case ieDs of [] -> docLit $ Text.pack "()" From 21c080572b39fb4307edfe19107998a2a2b4f2d9 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Thu, 21 Dec 2017 23:51:27 +0100 Subject: [PATCH 14/23] Add compact version of import layout Also let layoutLLIEs deal with comments --- src-literatetests/10-tests.blt | 11 ++ src-literatetests/tests-context-free.blt | 117 ++++++++---------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 34 ++--- .../Brittany/Internal/Layouters/Import.hs | 93 ++++++++------ .../Brittany/Internal/Layouters/Module.hs | 18 +-- 5 files changed, 144 insertions(+), 129 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 123eccc..758efe0 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -704,6 +704,17 @@ import TestJustShortEnoughModuleNameLike hiding ( ) import TestJustAbitToLongModuleNameLikeTh hiding ( ) +import MoreThanSufficientlyLongModuleNameWithSome + ( items + , that + , will + , not + , fit + , inA + , compact + , layout + ) + import {-# SOURCE #-} safe qualified "qualifiers" AlsoAff ( ) import {-# SOURCE #-} safe qualified "qualifiers" AlsoAffe ( ) diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 8be4666..a48890a 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -667,25 +667,25 @@ module Main (Test()) where ############################################################################### #test simple-import -import Data.List +import Data.List #test simple-import-alias -import Data.List as L +import Data.List as L #test simple-qualified-import import qualified Data.List #test simple-qualified-import-alias -import qualified Data.List as L +import qualified Data.List as L #test simple-safe -import safe Data.List as L +import safe Data.List as L #test simple-source -import {-# SOURCE #-} Data.List ( ) +import {-# SOURCE #-} Data.List () #test simple-safe-qualified -import safe qualified Data.Lis hiding ( nub ) +import safe qualified Data.List hiding (nub) #test simple-safe-qualified-source import {-# SOURCE #-} safe qualified Data.List @@ -694,88 +694,82 @@ import {-# SOURCE #-} safe qualified Data.List import qualified "base" Data.List #test qualifier-effect -import {-# SOURCE #-} safe qualified "base" Data.List as L -import {-# SOURCE #-} safe qualified "base" Data.List ( ) -import {-# SOURCE #-} safe qualified Data.List hiding ( ) +import {-# SOURCE #-} safe qualified "base" Data.List as L +import {-# SOURCE #-} safe qualified "base" Data.List () +import {-# SOURCE #-} safe qualified Data.List hiding () #test instances-only -import qualified Data.List ( ) +import qualified Data.List () #test one-element -import Data.List ( nub ) +import Data.List (nub) #test several-elements -import Data.List ( nub - , foldl' - , indexElem - ) +import Data.List (nub, foldl', indexElem) #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 ( ) -import Test as T - hiding ( ) +import Test hiding () +import Test as T hiding () #test long-module-name -import TestJustShortEnoughModuleNameLikeThisOne ( ) -import TestJustAbitToLongModuleNameLikeThisOneIs - ( ) -import TestJustShortEnoughModuleNameLikeThisOn as T -import TestJustAbitToLongModuleNameLikeThisOneI - as T -import TestJustShortEnoughModuleNameLike hiding ( ) -import TestJustAbitToLongModuleNameLikeTh - hiding ( ) +import TestJustShortEnoughModuleNameLikeThisOne () +import TestJustAbitToLongModuleNameLikeThisOneIs () +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI as T +import TestJustShortEnoughModuleNameLike hiding () +import TestJustAbitToLongModuleNameLikeTh hiding () +import MoreThanSufficientlyLongModuleNameWithSome ( items + , that + , will + , not + , fit + , inA + , compact + , layout + ) #test import-with-comments -- Test -import Data.List ( nub ) -- Test +import Data.List (nub) -- Test {- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} +import qualified Data.List as L (foldl') {- Test -} #test import-with-comments-2 -import Test ( abc - , def - -- comment - ) +import Test ( abc + , def + -- comment + ) #test import-with-comments-3 -import Test ( abc - -- comment - ) +import Test ( abc + -- comment + ) #test import-with-comments-4 -import Test ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) +import Test ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) -- Test -import Test ( test ) +import Test (test) #test import-with-comments-5 -import Test ( -- comment - ) +import Test ( -- comment + ) #test long-bindings -import Test ( longbindingNameThatoverflowsColum ) -import Test ( Long(List, Of, Things) ) +import Test (longbindingNameThatoverflowsColum) +import Test (Long(List, Of, Things)) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} @@ -800,13 +794,12 @@ module Test where -- Test -import Data.List ( nub ) -- Test +import Data.List (nub) -- Test {- Test -} -import qualified Data.List as L - ( foldl' ) {- Test -} +import qualified Data.List as L (foldl') {- Test -} -- Test -import Test ( test ) +import Test (test) ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index bce0a4a..262108e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -47,12 +47,10 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEThingWith _ _ ns fs -> docSeq $ [ien, docLit $ Text.pack "("] - ++ ( intersperse docCommaSep - (map ((docLit =<<) . lrdrNameToTextAnn . prepareName) ns) - ++ intersperse docCommaSep (map prepareFL fs) - ) + ++ intersperse docCommaSep (map nameDoc ns ++ map prepareFL fs) ++ [docLit $ Text.pack ")"] where + nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName prepareFL = docLit . Text.pack . FastString.unpackFS . flLabel . unLoc IEModuleContents n -> docSeq [ docLit $ Text.pack "module" @@ -64,8 +62,8 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of -- Helper function to deal with Located lists of LIEs. -- In particular this will also associate documentation --- from the LIES that actually belongs to the last IE. --- It also add docCommaSep to all but he last element +-- from the located list that actually belongs to the last IE. +-- It also adds docCommaSep to all but the first element -- This configuration allows both vertical and horizontal -- handling of the resulting list. Adding parens is -- left to the caller since that is context sensitive @@ -90,17 +88,25 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- ... -- , item -- ) --- Empty lists will always be rendered as () +-- If the llies contains comments the list will +-- always expand over multiple lines, even when empty: +-- () -- no comments +-- ( -- a comment +-- ) layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered layoutLLIEs llies = do ieDs <- layoutAnnAndSepLLIEs llies + hasComments <- hasAnyCommentsBelow llies case ieDs of - [] -> docLit $ Text.pack "()" + [] -> docAltFilter + [ (not hasComments, docLit $ Text.pack "()") + , (otherwise, docPar (docSeq [docParenLSep, docWrapNode llies docEmpty]) + $ docLines [docParenR]) + ] (ieDsH:ieDsT) -> - docAlt - [ docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR] - , docLines $ - docSeq [docParenLSep, ieDsH] - : ieDsT - ++ [docParenR] + docAltFilter + [ (not hasComments, docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR]) + , (otherwise, docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) $ + docLines $ ieDsT + ++ [docParenR]) ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 7aac868..97284a8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -44,23 +44,23 @@ prepModName = id layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of - ImportDecl _ (L _ modName) pkg src safe q False as mllies -> do + ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack -- NB we don't need to worry about sharing in the below code -- (docSharedWrapper etc.) because we do not use any docAlt nodes; all -- "decisions" are made statically. let + compact = indentPolicy == IndentPolicyLeft modNameT = Text.pack $ moduleNameString modName pkgNameT = Text.pack . prepPkg . sl_st <$> pkg - asT = Text.pack . moduleNameString . prepModName <$> as - hiding = case mllies of - Just (h, _) -> h - Nothing -> False + masT = Text.pack . moduleNameString . prepModName <$> mas + hiding = maybe False fst mllies minQLength = length "import qualified " qLengthReal = let qualifiedPart = if q then length "qualified " else 0 safePart = if safe then length "safe " else 0 - pkgPart = fromMaybe 0 ((+ 1) . Text.length <$> pkgNameT) + pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT srcPart = if src then length "{-# SOURCE #-} " else 0 in length "import " + srcPart + safePart + qualifiedPart + pkgPart qLength = max minQLength qLengthReal @@ -73,49 +73,60 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of , if src then appSep $ docLit $ Text.pack "{-# SOURCE #-}" else docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty - , fromMaybe docEmpty (appSep . docLit <$> pkgNameT) + , maybe docEmpty (appSep . docLit) pkgNameT ] + indentName = + if compact then id else docEnsureIndent (BrIndentSpecial qLength) modNameD = - docEnsureIndent (BrIndentSpecial qLength) $ appSep $ docLit modNameT + indentName $ appSep $ docLit modNameT hidDoc = if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty importHead = docSeq [importQualifiers, modNameD] bindingsD = case mllies of - Nothing -> docSeq [docEmpty] + Nothing -> docEmpty Just (_, llies) -> do - ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies - docWrapNodeRest llies $ case ieDs of - -- ..[hiding].( ) - [] -> if hasComments - then docPar - (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) - docParenR - else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] - -- ..[hiding].( b ) - [ieD] -> if hasComments - then docPar (docSeq [hidDoc, docParenLSep, ieD]) docParenR - else docSeq [hidDoc, docParenLSep, ieD, docSeparator, docParenR] - -- ..[hiding].( b - -- , b' - -- ) - (ieD:ieDs') -> - docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) - $ docLines - $ ieDs' - ++ [docParenR] + if compact + then docSeq [hidDoc, layoutLLIEs llies] + else do + ieDs <- layoutAnnAndSepLLIEs llies + docWrapNodeRest llies $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + docParenR + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> if hasComments + then docPar (docSeq [hidDoc, docParenLSep, ieD]) docParenR + else docSeq [hidDoc, docParenLSep, ieD, docSeparator, docParenR] + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> + docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + $ docLines + $ ieDs' + ++ [docParenR] bindingLine = docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD - case asT of - Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] - | otherwise -> docLines [importHead, asDoc, bindingLine] - where - enoughRoom = nameCost < importCol - asCost - asDoc = - docEnsureIndent (BrIndentSpecial (importCol - asCost)) - $ docSeq - $ [appSep $ docLit $ Text.pack "as", docLit n] - Nothing | enoughRoom -> docSeq [importHead, bindingLine] - | otherwise -> docLines [importHead, bindingLine] - where enoughRoom = nameCost < importCol - bindingCost + makeAsDoc asT = + docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] + if compact + then + let asDoc = maybe docEmpty makeAsDoc masT + in docSeq [importHead, asDoc, docSetBaseY $ bindingsD] + else + case masT of + Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] + | otherwise -> docLines [importHead, asDoc, bindingLine] + where + enoughRoom = nameCost < importCol - asCost + asDoc = + docEnsureIndent (BrIndentSpecial (importCol - asCost)) + $ makeAsDoc n + Nothing | enoughRoom -> docSeq [importHead, bindingLine] + | otherwise -> docLines [importHead, bindingLine] + where enoughRoom = nameCost < importCol - bindingCost _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index c0f569b..db2e2af 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -24,31 +24,25 @@ import Language.Haskell.Brittany.Internal.Utils layoutModule :: ToBriDoc HsModule -layoutModule lmod@(L _ mod') = do +layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports HsModule (Just n) les imports _ _ _ -> do - let tn = Text.pack $ moduleNameString $ unLoc n - (hasComments, exportsDoc) <- case les of - Nothing -> return (False, docEmpty) - Just llies -> do - hasComments <- hasAnyCommentsBelow llies - exportsDoc <- docSharedWrapper layoutLLIEs llies - return (hasComments, exportsDoc) + let tn = Text.pack $ moduleNameString $ unLoc n + exportsDoc = maybe docEmpty layoutLLIEs les docLines $ docSeq - [ docWrapNode lmod $ docEmpty + [ docWrapNode lmod docEmpty -- A pseudo node that serves merely to force documentation -- before the node , docAlt - ( [ docSeq + ( [ docForceSingleline $ docSeq [ appSep $ docLit $ Text.pack "module" , appSep $ docLit tn - , appSep $ docForceSingleline exportsDoc + , appSep exportsDoc , docLit $ Text.pack "where" ] - | not hasComments ] ++ [ docLines [ docAddBaseY BrIndentRegular $ docPar From 3708838b6a4a7618afbadb5182d81ff2fa9ad5e8 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Fri, 22 Dec 2017 06:58:39 +0100 Subject: [PATCH 15/23] Also handle comments inside ThingWith --- src-literatetests/10-tests.blt | 22 ++++++++++++- src-literatetests/tests-context-free.blt | 22 +++++++++++++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 32 +++++++++++++++---- 3 files changed, 68 insertions(+), 8 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 758efe0..7164f77 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -765,7 +765,27 @@ import Test ( -- comment #test long-bindings import Test ( longbindingNameThatoverflowsColum ) -import Test ( Long(List, Of, Things) ) +import Test ( Long( List + , Of + , Things + ) ) + +#test things-with-with-comments +import Test ( Thing( -- Comments + ) + ) +import Test ( Thing( Item + -- and Comment + ) + ) +import Test ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index a48890a..2795da8 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -771,6 +771,28 @@ import Test ( -- comment import Test (longbindingNameThatoverflowsColum) import Test (Long(List, Of, Things)) +#test things-with-with-comments +import Test ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) +import Test ( Thing( Item + -- and Comment + ) + ) +import Test ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 262108e..85a4ef8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -44,14 +44,32 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEThingAbs _ -> ien IEThingAll _ -> docSeq [ien, docLit $ Text.pack "(..)"] IEThingWith _ (IEWildcard _) _ _ -> docSeq [ien, docLit $ Text.pack "(..)"] - IEThingWith _ _ ns fs -> - docSeq - $ [ien, docLit $ Text.pack "("] - ++ intersperse docCommaSep (map nameDoc ns ++ map prepareFL fs) - ++ [docLit $ Text.pack ")"] + IEThingWith _ _ ns _ -> do + hasComments <- hasAnyCommentsBelow lie + docAltFilter + [(not hasComments, docSeq $ [ien, docLit $ Text.pack "("] + ++ intersperse docCommaSep (map nameDoc ns) + ++ [docParenR]) + ,(otherwise, docSeq [ien, layoutItems (splitFirstLast ns)]) + ] where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName - prepareFL = docLit . Text.pack . FastString.unpackFS . flLabel . unLoc + layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] + layoutItems FirstLastEmpty = + docSetBaseY $ + docLines [docSeq [docParenLSep, docWrapNodeRest lie docEmpty] + ,docParenR + ] + layoutItems (FirstLastSingleton n) = + docSetBaseY $ docLines + [docSeq [docParenLSep, docWrapNodeRest lie $ nameDoc n], docParenR] + layoutItems (FirstLast n1 nMs nN) = + docSetBaseY $ docLines $ + [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] + ++ map layoutItem nMs + ++ [ docSeq [docCommaSep, docWrapNodeRest lie $ nameDoc nN] + , docParenR + ] IEModuleContents n -> docSeq [ docLit $ Text.pack "module" , docSeparator @@ -101,7 +119,7 @@ layoutLLIEs llies = do [] -> docAltFilter [ (not hasComments, docLit $ Text.pack "()") , (otherwise, docPar (docSeq [docParenLSep, docWrapNode llies docEmpty]) - $ docLines [docParenR]) + docParenR) ] (ieDsH:ieDsT) -> docAltFilter From ad34a8b9b99a277c4ba11413a08fdc21ea85ce41 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Fri, 22 Dec 2017 10:08:30 +0100 Subject: [PATCH 16/23] Only expand empty binding list with comments --- src-literatetests/10-tests.blt | 3 +++ src-literatetests/tests-context-free.blt | 3 +++ src/Language/Haskell/Brittany/Internal/Layouters/IE.hs | 7 +++++-- 3 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 7164f77..95d8593 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -786,6 +786,9 @@ import Test ( Thing( With -- ! ) ) +#test prefer-dense-empty-list +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + ( ) #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 2795da8..6e8c523 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -793,6 +793,9 @@ import Test ( Thing( With ) ) +#test prefer-dense-empty-list +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine () + #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 85a4ef8..ebf9b36 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -118,8 +118,11 @@ layoutLLIEs llies = do case ieDs of [] -> docAltFilter [ (not hasComments, docLit $ Text.pack "()") - , (otherwise, docPar (docSeq [docParenLSep, docWrapNode llies docEmpty]) - docParenR) + , ( hasComments + , docPar + (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + ) ] (ieDsH:ieDsT) -> docAltFilter From 98c93f0d63ed24d67ab28ec6518769494c1b97f2 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Fri, 22 Dec 2017 16:35:39 +0100 Subject: [PATCH 17/23] Move expanded binding list to standard indent level for compact layout --- src-literatetests/10-tests.blt | 16 +++ src-literatetests/tests-context-free.blt | 112 ++++++++++-------- .../Brittany/Internal/Layouters/Import.hs | 10 +- 3 files changed, 87 insertions(+), 51 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 95d8593..680d6f1 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -676,6 +676,22 @@ import Data.List ( nub , indexElem ) +#test a-ridiculous-amount-of-elements +import Test ( Long + , list + , with + , items + , that + , will + , not + , quite + , fit + , onA + , single + , line + , anymore + ) + #test with-things import Test ( T , T2() diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index 6e8c523..f4c4d6d 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -707,6 +707,23 @@ import Data.List (nub) #test several-elements import Data.List (nub, foldl', indexElem) +#test a-ridiculous-amount-of-elements +import Test + ( Long + , list + , with + , items + , that + , will + , not + , quite + , fit + , onA + , single + , line + , anymore + ) + #test with-things import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+)) @@ -721,15 +738,8 @@ import TestJustShortEnoughModuleNameLikeThisOn as T import TestJustAbitToLongModuleNameLikeThisOneI as T import TestJustShortEnoughModuleNameLike hiding () import TestJustAbitToLongModuleNameLikeTh hiding () -import MoreThanSufficientlyLongModuleNameWithSome ( items - , that - , will - , not - , fit - , inA - , compact - , layout - ) +import MoreThanSufficientlyLongModuleNameWithSome + (items, that, will, not, fit, inA, compact, layout) #test import-with-comments -- Test @@ -739,62 +749,70 @@ import qualified Data.List as L (foldl') {- Test -} #test import-with-comments-2 -import Test ( abc - , def - -- comment - ) +import Test + ( abc + , def + -- comment + ) #test import-with-comments-3 -import Test ( abc - -- comment - ) +import Test + ( abc + -- comment + ) #test import-with-comments-4 -import Test ( abc - -- comment - , def - , ghi - {- comment -} - , jkl - -- comment - ) +import Test + ( abc + -- comment + , def + , ghi + {- comment -} + , jkl + -- comment + ) -- Test import Test (test) #test import-with-comments-5 -import Test ( -- comment - ) +import Test + ( -- comment + ) #test long-bindings import Test (longbindingNameThatoverflowsColum) import Test (Long(List, Of, Things)) #test things-with-with-comments -import Test ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) - ) -import Test ( Thing( Item - -- and Comment - ) - ) -import Test ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) - ) +import Test + ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) +import Test + ( Thing( Item + -- and Comment + ) + ) +import Test + ( Thing( With + -- Comments + , and + -- also + , items + -- ! + ) + ) #test prefer-dense-empty-list -import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine () +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + () #test preamble full-preamble {-# LANGUAGE BangPatterns #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 97284a8..5fa05a2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -47,9 +47,6 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ImportDecl _ (L _ modName) pkg src safe q False mas mllies -> do importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack - -- NB we don't need to worry about sharing in the below code - -- (docSharedWrapper etc.) because we do not use any docAlt nodes; all - -- "decisions" are made statically. let compact = indentPolicy == IndentPolicyLeft modNameT = Text.pack $ moduleNameString modName @@ -116,7 +113,12 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of if compact then let asDoc = maybe docEmpty makeAsDoc masT - in docSeq [importHead, asDoc, docSetBaseY $ bindingsD] + in docAlt + [ docForceSingleline $ + docSeq [importHead, asDoc, docSetBaseY $ bindingsD] + , docAddBaseY BrIndentRegular $ + docPar (docSeq [importHead, asDoc]) bindingsD + ] else case masT of Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] From af7f9017b82d9fa9d8886716a7e82cd2e9854dd9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 11 Mar 2018 22:07:12 +0100 Subject: [PATCH 18/23] Fix Alt-transformation bug with BDFEnsureIndents multiple BDFEnsureIndent nodes were mistreated previously --- .../Brittany/Internal/Transformations/Alt.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 93c31c6..9c0a34e 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -319,11 +319,16 @@ transformAlts briDoc = BrIndentNone -> 0 BrIndentRegular -> indAmount BrIndentSpecial i -> i - mSet $ acp { _acp_indentPrep = 0 -- TODO: i am not sure this is valid, - -- in general. - , _acp_indent = _acp_indent acp + indAdd - , _acp_line = _acp_line acp + indAdd - } + mSet $ acp + { _acp_indentPrep = 0 + -- TODO: i am not sure this is valid, in general. + , _acp_indent = _acp_indent acp + indAdd + , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd) + -- we cannot use just _acp_line acp + indAdd because of the case + -- where there are multiple BDFEnsureIndents in the same line. + -- Then, the actual indentation is relative to the current + -- indentation, not the current cursor position. + } r <- rec bd acp' <- mGet mSet $ acp' { _acp_indent = _acp_indent acp } From 20f9c009ee18e18ca5c4d4db440f4e565757cbc4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 11 Mar 2018 22:42:47 +0100 Subject: [PATCH 19/23] Stop hanging indent for IEThingWith plus minor refactors/cleanups this is more in line with IndentPolicyLeft and imo also looks nicer in general --- src-literatetests/10-tests.blt | 40 +++++++++------- src-literatetests/tests-context-free.blt | 37 +++++++------- .../Haskell/Brittany/Internal/Layouters/IE.hs | 48 ++++++++++++------- .../Brittany/Internal/Layouters/Import.hs | 22 +++++++-- 4 files changed, 90 insertions(+), 57 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 3a5941c..802a6fc 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -787,27 +787,33 @@ import Test ( -- comment ) #test long-bindings -import Test ( longbindingNameThatoverflowsColum ) -import Test ( Long( List - , Of - , Things - ) ) +import Test ( longbindingNameThatoverflowsColum + ) +import Test ( Long + ( List + , Of + , Things + ) + ) #test things-with-with-comments -import Test ( Thing( -- Comments - ) +import Test ( Thing + ( -- Comments + ) ) -import Test ( Thing( Item - -- and Comment - ) +import Test ( Thing + ( Item + -- and Comment + ) ) -import Test ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) +import Test ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) ) #test prefer-dense-empty-list import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index d1a27b3..8ab4d7e 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -792,27 +792,30 @@ import Test (Long(List, Of, Things)) #test things-with-with-comments import Test - ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) + ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) ) import Test - ( Thing( Item - -- and Comment - ) + ( Thing + ( Item + -- and Comment + ) ) import Test - ( Thing( With - -- Comments - , and - -- also - , items - -- ! - ) + ( Thing + ( With + -- Comments + , and + -- also + , items + -- ! + ) ) #test prefer-dense-empty-list diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index ebf9b36..126d519 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -47,10 +47,16 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of IEThingWith _ _ ns _ -> do hasComments <- hasAnyCommentsBelow lie docAltFilter - [(not hasComments, docSeq $ [ien, docLit $ Text.pack "("] + [ ( not hasComments + , docSeq + $ [ien, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) - ++ [docParenR]) - ,(otherwise, docSeq [ien, layoutItems (splitFirstLast ns)]) + ++ [docParenR] + ) + , (otherwise + , docAddBaseY BrIndentRegular + $ docPar ien (layoutItems (splitFirstLast ns)) + ) ] where nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName @@ -113,21 +119,27 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- ) layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered layoutLLIEs llies = do - ieDs <- layoutAnnAndSepLLIEs llies + ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies case ieDs of [] -> docAltFilter - [ (not hasComments, docLit $ Text.pack "()") - , ( hasComments - , docPar - (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) - docParenR - ) - ] - (ieDsH:ieDsT) -> - docAltFilter - [ (not hasComments, docSeq $ docLit (Text.pack "("):ieDs ++ [docParenR]) - , (otherwise, docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) $ - docLines $ ieDsT - ++ [docParenR]) - ] + [ (not hasComments, docLit $ Text.pack "()") + , ( hasComments + , docPar (docSeq [docParenLSep, docWrapNodeRest llies docEmpty]) + docParenR + ) + ] + (ieDsH:ieDsT) -> docAltFilter + [ ( not hasComments + , docSeq + $ [docLit (Text.pack "(")] + ++ (docForceSingleline <$> ieDs) + ++ [docParenR] + ) + , ( otherwise + , docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) + $ docLines + $ ieDsT + ++ [docParenR] + ) + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 5fa05a2..613f2d2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -95,9 +95,22 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of docParenR else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] -- ..[hiding].( b ) - [ieD] -> if hasComments - then docPar (docSeq [hidDoc, docParenLSep, ieD]) docParenR - else docSeq [hidDoc, docParenLSep, ieD, docSeparator, docParenR] + [ieD] -> docAltFilter + [ ( not hasComments + , docSeq + [ hidDoc + , docParenLSep + , docForceSingleline $ ieD + , docSeparator + , docParenR + ] + ) + , ( otherwise + , docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + docParenR + ) + ] -- ..[hiding].( b -- , b' -- ) @@ -114,8 +127,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of then let asDoc = maybe docEmpty makeAsDoc masT in docAlt - [ docForceSingleline $ - docSeq [importHead, asDoc, docSetBaseY $ bindingsD] + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] , docAddBaseY BrIndentRegular $ docPar (docSeq [importHead, asDoc]) bindingsD ] From 9531edb2a79d7e53e8fad06726b72f6c675ce6fc Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 16:29:47 +0100 Subject: [PATCH 20/23] Improve module layouting in two aspects - IEThingWith in export list can now be single-line - Now respect offset of the "module" keyword (retain empty lines after pragmas, for example) --- src-literatetests/10-tests.blt | 9 +++ src/Language/Haskell/Brittany/Internal.hs | 62 +++++++++++------- .../Haskell/Brittany/Internal/Backend.hs | 19 ++++++ .../Brittany/Internal/LayouterBasics.hs | 18 ++++++ .../Haskell/Brittany/Internal/Layouters/IE.hs | 6 +- .../Brittany/Internal/Layouters/Import.hs | 2 +- .../Brittany/Internal/Layouters/Module.hs | 64 ++++++++++--------- .../Brittany/Internal/Transformations/Alt.hs | 4 ++ .../Internal/Transformations/Columns.hs | 1 + .../Haskell/Brittany/Internal/Types.hs | 5 ++ 10 files changed, 131 insertions(+), 59 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 802a6fc..c57e33a 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -625,6 +625,15 @@ module Main (module Main) where #test export-with-things module Main (Test(Test, a, b)) where +#test export-with-things-comment +-- comment1 + +module Main + ( Test(Test, a, b) + , foo -- comment2 + ) -- comment3 +where + #test export-with-empty-thing module Main (Test()) where diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 25b7b9a..a283e89 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -16,7 +16,7 @@ where #include "prelude.inc" import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data @@ -133,7 +133,7 @@ parsePrintModule configRaw inputText = runExceptT $ do -- can occur. pPrintModule :: Config - -> ExactPrint.Types.Anns + -> ExactPrint.Anns -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf anns parsedModule = @@ -169,7 +169,7 @@ pPrintModule conf anns parsedModule = -- if it does not. pPrintModuleAndCheck :: Config - -> ExactPrint.Types.Anns + -> ExactPrint.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf anns parsedModule = do @@ -253,7 +253,7 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do post <- ppPreamble lmod decls `forM_` \decl -> do filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap + Map.findWithDefault Map.empty (ExactPrint.mkAnnKey decl) annMap traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations @@ -266,26 +266,26 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do ppDecl decl let finalComments = filter ( fst .> \case - ExactPrint.Types.AnnComment{} -> True + ExactPrint.AnnComment{} -> True _ -> False ) post post `forM_` \case - (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do + (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr - (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) -> + (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> let - folder (acc, _) (kw, ExactPrint.Types.DP (x, y)) = case kw of - ExactPrint.Types.AnnComment cm - | GHC.RealSrcSpan span <- ExactPrint.Types.commentIdentifier cm - -> ( acc + x + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span - , y + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span + folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of + ExactPrint.AnnComment cm + | GHC.RealSrcSpan span <- ExactPrint.commentIdentifier cm + -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span + , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span ) - _ -> (acc + x, y) - (cmX, cmY) = foldl' folder (0, 0) finalComments + _ -> (acc + y, x) + (cmY, cmX) = foldl' folder (0, 0) finalComments in - ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY) + ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () @@ -323,23 +323,23 @@ ppDecl d@(L loc decl) = case decl of -- Prints the information associated with the module annotation -- This includes the imports ppPreamble :: GenLocated SrcSpan (HsModule RdrName) - -> PPM [(ExactPrint.Types.KeywordId, ExactPrint.Types.DeltaPos)] + -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey lmod) annMap + Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) -- modules to both HsModule and the elements in the module -- this can cause duplication of comments. So strip -- attached annotations that come after the module's where -- from the module node let (filteredAnns', post) = - case (ExactPrint.Types.mkAnnKey lmod) `Map.lookup` filteredAnns of + case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of Nothing -> (filteredAnns, []) Just mAnn -> - let modAnnsDp = ExactPrint.Types.annsDP mAnn - isWhere (ExactPrint.Types.G AnnWhere) = True + let modAnnsDp = ExactPrint.annsDP mAnn + isWhere (ExactPrint.G AnnWhere) = True isWhere _ = False - isEof (ExactPrint.Types.G AnnEofPos) = True + isEof (ExactPrint.G AnnEofPos) = True isEof _ = False whereInd = List.findIndex (isWhere . fst) modAnnsDp eofInd = List.findIndex (isEof . fst) modAnnsDp @@ -348,8 +348,22 @@ ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp (Nothing, Just _i) -> ([], modAnnsDp) (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - mAnn' = mAnn { ExactPrint.Types.annsDP = pre } - filteredAnns'' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' filteredAnns + findInitialCommentSize = \case + ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)):rest) -> + let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm + in y + + GHC.srcSpanEndLine span + - GHC.srcSpanStartLine span + + findInitialCommentSize rest + _ -> 0 + initialCommentSize = findInitialCommentSize pre + fixAbsoluteModuleDP = \case + (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) -> + (g, ExactPrint.DP (y - initialCommentSize, x)) + x -> x + pre' = map fixAbsoluteModuleDP pre + mAnn' = mAnn { ExactPrint.annsDP = pre' } + filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns in (filteredAnns'', post') in do traceIfDumpConf "bridoc annotations filtered/transformed" @@ -415,7 +429,7 @@ layoutBriDoc briDoc = do -- simpl <- mGet <&> transformToSimple -- return simpl - anns :: ExactPrint.Types.Anns <- mAsk + anns :: ExactPrint.Anns <- mAsk let state = LayoutState { _lstate_baseYs = [0] diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index c121eaf..c9da940 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -250,6 +250,23 @@ layoutBriDocM = \case -- layoutMoveToIndentCol y layoutWriteAppendMultiline $ Text.pack $ comment -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } + BDMoveToKWDP annKey keyword bd -> do + mDP <- do + state <- mGet + let m = _lstate_comments state + let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m + let relevant = [ dp + | Just ann <- [mAnn] + , (ExactPrint.Types.G kw1, dp) <- ann + , keyword == kw1 + ] + pure $ case relevant of + [] -> Nothing + (dp:_) -> Just dp + case mDP of + Nothing -> pure () + Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y x + layoutBriDocM bd BDNonBottomSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd @@ -282,6 +299,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ bd -> rec bd BDLines ls@(_:_) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x @@ -317,6 +335,7 @@ briDocIsMultiLine briDoc = rec briDoc BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ bd -> rec bd BDLines (_:_:_) -> True BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 151dd65..89c8ae3 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -16,6 +16,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSeq , docPar , docNodeAnnKW + , docNodeMoveToKWDP , docWrapNode , docWrapNodePrior , docWrapNodeRest @@ -29,6 +30,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docAnnotationPrior , docAnnotationKW , docAnnotationRest + , docMoveToKWDP , docNonBottomSpacing , docSetParSpacing , docForceParSpacing @@ -441,6 +443,13 @@ docAnnotationKW -> ToBriDocM BriDocNumbered docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm +docMoveToKWDP + :: AnnKey + -> AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docMoveToKWDP annKey kw bdm = allocateNode . BDFMoveToKWDP annKey kw =<< bdm + docAnnotationRest :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm @@ -481,6 +490,15 @@ docNodeAnnKW docNodeAnnKW ast kw bdm = docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm +docNodeMoveToKWDP + :: Data.Data.Data ast + => Located ast + -> AnnKeywordId + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered +docNodeMoveToKWDP ast kw bdm = + docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw bdm + class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) => Located ast diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs index 126d519..bc277bc 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -117,8 +117,8 @@ layoutAnnAndSepLLIEs llies@(L _ lies) = do -- () -- no comments -- ( -- a comment -- ) -layoutLLIEs :: Located [LIE RdrName] -> ToBriDocM BriDocNumbered -layoutLLIEs llies = do +layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutLLIEs enableSingleline llies = do ieDs <- layoutAnnAndSepLLIEs llies hasComments <- hasAnyCommentsBelow llies case ieDs of @@ -130,7 +130,7 @@ layoutLLIEs llies = do ) ] (ieDsH:ieDsT) -> docAltFilter - [ ( not hasComments + [ ( not hasComments && enableSingleline , docSeq $ [docLit (Text.pack "(")] ++ (docForceSingleline <$> ieDs) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index 613f2d2..e7fb03c 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -84,7 +84,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of Just (_, llies) -> do hasComments <- hasAnyCommentsBelow llies if compact - then docSeq [hidDoc, layoutLLIEs llies] + then docSeq [hidDoc, layoutLLIEs True llies] else do ieDs <- layoutAnnAndSepLLIEs llies docWrapNodeRest llies $ case ieDs of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index db2e2af..4620307 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -24,35 +24,37 @@ import Language.Haskell.Brittany.Internal.Utils layoutModule :: ToBriDoc HsModule -layoutModule lmod@(L _ mod') = - case mod' of +layoutModule lmod@(L _ mod') = case mod' of -- Implicit module Main - HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports - HsModule (Just n) les imports _ _ _ -> do - let tn = Text.pack $ moduleNameString $ unLoc n - exportsDoc = maybe docEmpty layoutLLIEs les - docLines - $ docSeq - [ docWrapNode lmod docEmpty - -- A pseudo node that serves merely to force documentation - -- before the node - , docAlt - ( [ docForceSingleline $ docSeq - [ appSep $ docLit $ Text.pack "module" - , appSep $ docLit tn - , appSep exportsDoc - , docLit $ Text.pack "where" - ] - ] - ++ [ docLines - [ docAddBaseY BrIndentRegular $ docPar - ( docSeq - [appSep $ docLit $ Text.pack "module", docLit tn] - ) - (docForceMultiline exportsDoc) - , docLit $ Text.pack "where" - ] - ] - ) - ] - : map layoutImport imports + HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports + HsModule (Just n) les imports _ _ _ -> do + let tn = Text.pack $ moduleNameString $ unLoc n + docLines + $ docSeq + [ docNodeAnnKW lmod Nothing docEmpty + -- A pseudo node that serves merely to force documentation + -- before the node + , docNodeMoveToKWDP lmod AnnModule $ docAlt + ( [ docForceSingleline $ docSeq + [ appSep $ docLit $ Text.pack "module" + , appSep $ docLit tn + , docWrapNode lmod $ appSep $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs True x + , docLit $ Text.pack "where" + ] + ] + ++ [ docLines + [ docAddBaseY BrIndentRegular $ docPar + (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] + ) + (docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False x + ) + , docLit $ Text.pack "where" + ] + ] + ) + ] + : map layoutImport imports diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 9c0a34e..c83cfae 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -301,6 +301,8 @@ transformAlts briDoc = reWrap . BDFAnnotationRest annKey <$> rec bd BDFAnnotationKW annKey kw bd -> reWrap . BDFAnnotationKW annKey kw <$> rec bd + BDFMoveToKWDP annKey kw bd -> + reWrap . BDFMoveToKWDP annKey kw <$> rec bd BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. BDFLines (l:lr) -> do ind <- _acp_indent <$> mGet @@ -460,6 +462,7 @@ getSpacing !bridoc = rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw bd -> rec bd BDFLines [] -> return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False @@ -705,6 +708,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BDFAnnotationPrior _annKey bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd + BDFMoveToKWDP _annKey _kw bd -> rec bd BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines ls@(_:_) -> do -- we simply assume that lines is only used "properly", i.e. in diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 071028a..41290a7 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -128,6 +128,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDAnnotationPrior{} -> Nothing BDAnnotationKW{} -> Nothing BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing BDEnsureIndent{} -> Nothing BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 2784c1d..d321e21 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -233,6 +233,7 @@ data BriDoc | BDAnnotationPrior AnnKey BriDoc | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc | BDAnnotationRest AnnKey BriDoc + | BDMoveToKWDP AnnKey AnnKeywordId BriDoc | BDLines [BriDoc] | BDEnsureIndent BrIndent BriDoc -- the following constructors are only relevant for the alt transformation @@ -278,6 +279,7 @@ data BriDocF f | BDFAnnotationPrior AnnKey (f (BriDocF f)) | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f)) | BDFAnnotationRest AnnKey (f (BriDocF f)) + | BDFMoveToKWDP AnnKey AnnKeywordId (f (BriDocF f)) | BDFLines [(f (BriDocF f))] | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) @@ -311,6 +313,7 @@ instance Uniplate.Uniplate BriDoc where uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd + uniplate (BDMoveToKWDP annKey kw bd) = plate BDMoveToKWDP |- annKey |- kw |* bd uniplate (BDLines lines) = plate BDLines ||* lines uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd @@ -342,6 +345,7 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd BDFAnnotationRest annKey bd -> BDAnnotationRest annKey $ rec bd + BDFMoveToKWDP annKey kw bd -> BDMoveToKWDP annKey kw $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd @@ -377,6 +381,7 @@ briDocSeqSpine = \case BDAnnotationPrior _annKey bd -> briDocSeqSpine bd BDAnnotationKW _annKey _kw bd -> briDocSeqSpine bd BDAnnotationRest _annKey bd -> briDocSeqSpine bd + BDMoveToKWDP _annKey _kw bd -> briDocSeqSpine bd BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd From 833ac95fd7ce764e93e2a4b20cda6c81341f1b53 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 17:11:25 +0100 Subject: [PATCH 21/23] Add two config options to control preamble layouting --- src-literatetests/Main.hs | 2 + src-unittests/TestUtils.hs | 2 + src/Language/Haskell/Brittany/Internal.hs | 101 ++++++++++-------- .../Haskell/Brittany/Internal/Config.hs | 4 + .../Haskell/Brittany/Internal/Config/Types.hs | 15 +++ .../Brittany/Internal/Layouters/Module.hs | 14 +-- 6 files changed, 87 insertions(+), 51 deletions(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 5567e68..47fd801 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -174,6 +174,8 @@ defaultTestConfig = Config , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 1ee5203..2e9487c 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -56,6 +56,8 @@ defaultTestConfig = Config , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce True } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index a283e89..561390f 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -324,7 +324,7 @@ ppDecl d@(L loc decl) = case decl of -- This includes the imports ppPreamble :: GenLocated SrcSpan (HsModule RdrName) -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)] -ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do +ppPreamble lmod@(L loc m@(HsModule _ _ _ _ _ _)) = do filteredAnns <- mAsk <&> \annMap -> Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap -- Since ghc-exactprint adds annotations following (implicit) @@ -332,52 +332,63 @@ ppPreamble lmod@(L _ (HsModule _ _ _ _ _ _)) = do -- this can cause duplication of comments. So strip -- attached annotations that come after the module's where -- from the module node - let (filteredAnns', post) = - case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of - Nothing -> (filteredAnns, []) - Just mAnn -> - let modAnnsDp = ExactPrint.annsDP mAnn - isWhere (ExactPrint.G AnnWhere) = True - isWhere _ = False - isEof (ExactPrint.G AnnEofPos) = True - isEof _ = False - whereInd = List.findIndex (isWhere . fst) modAnnsDp - eofInd = List.findIndex (isEof . fst) modAnnsDp - (pre, post') = case (whereInd, eofInd) of - (Nothing, Nothing) -> ([], modAnnsDp) - (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp - (Nothing, Just _i) -> ([], modAnnsDp) - (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp - findInitialCommentSize = \case - ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)):rest) -> - let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm - in y - + GHC.srcSpanEndLine span - - GHC.srcSpanStartLine span - + findInitialCommentSize rest - _ -> 0 - initialCommentSize = findInitialCommentSize pre - fixAbsoluteModuleDP = \case - (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) -> - (g, ExactPrint.DP (y - initialCommentSize, x)) - x -> x - pre' = map fixAbsoluteModuleDP pre - mAnn' = mAnn { ExactPrint.annsDP = pre' } - filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns - in (filteredAnns'', post') - in do - traceIfDumpConf "bridoc annotations filtered/transformed" - _dconf_dump_annotations - $ annsDoc filteredAnns' + config <- mAsk + let shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack - config <- mAsk + let + (filteredAnns', post) = + case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of + Nothing -> (filteredAnns, []) + Just mAnn -> + let + modAnnsDp = ExactPrint.annsDP mAnn + isWhere (ExactPrint.G AnnWhere) = True + isWhere _ = False + isEof (ExactPrint.G AnnEofPos) = True + isEof _ = False + whereInd = List.findIndex (isWhere . fst) modAnnsDp + eofInd = List.findIndex (isEof . fst) modAnnsDp + (pre, post') = case (whereInd, eofInd) of + (Nothing, Nothing) -> ([], modAnnsDp) + (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp + (Nothing, Just _i) -> ([], modAnnsDp) + (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp + findInitialCommentSize = \case + ((ExactPrint.AnnComment cm, ExactPrint.DP (y, _)) : rest) -> + let GHC.RealSrcSpan span = ExactPrint.commentIdentifier cm + in y + + GHC.srcSpanEndLine span + - GHC.srcSpanStartLine span + + findInitialCommentSize rest + _ -> 0 + initialCommentSize = findInitialCommentSize pre + fixAbsoluteModuleDP = \case + (g@(ExactPrint.G AnnModule), ExactPrint.DP (y, x)) -> + (g, ExactPrint.DP (y - initialCommentSize, x)) + x -> x + pre' = if shouldReformatPreamble + then map fixAbsoluteModuleDP pre + else pre + mAnn' = mAnn { ExactPrint.annsDP = pre' } + filteredAnns'' = + Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns + in + (filteredAnns'', post') + traceIfDumpConf "bridoc annotations filtered/transformed" + _dconf_dump_annotations + $ annsDoc filteredAnns' - MultiRWSS.withoutMultiReader $ do - MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil - withTransformedAnns lmod $ do - briDoc <- briDocMToPPM $ layoutModule lmod - layoutBriDoc briDoc - return post + if shouldReformatPreamble + then MultiRWSS.withoutMultiReader $ do + MultiRWSS.mPutRawR $ config :+: filteredAnns' :+: HNil + withTransformedAnns lmod $ do + briDoc <- briDocMToPPM $ layoutModule lmod + layoutBriDoc briDoc + else + let emptyModule = L loc m { hsmodDecls = [] } + in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule + return post _sigHead :: Sig RdrName -> String _sigHead = \case diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index ad991b5..d9266a9 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -64,6 +64,8 @@ staticDefaultConfig = Config , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -158,6 +160,8 @@ configParser = do , _lconfig_alignmentLimit = mempty , _lconfig_alignmentBreakOnMultiline = mempty , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index f2530b0..0f6d48b 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -84,6 +84,21 @@ data CLayoutConfig f = LayoutConfig -- -> SomeLongStuff -- As usual for hanging indentation, the result will be -- context-sensitive (in the function name). + , _lconfig_reformatModulePreamble :: f (Last Bool) + -- whether the module preamble/header (module keyword, name, export list, + -- import statements) are reformatted. If false, only the elements of the + -- module (everything past the "where") are reformatted. + , _lconfig_allowSingleLineExportList :: f (Last Bool) + -- if true, and it fits in a single line, and there are no comments in the + -- export list, the following layout will be used: + -- > module MyModule (abc, def) where + -- > [stuff] + -- otherwise, the multi-line version is used: + -- > module MyModule + -- > ( abc + -- > , def + -- > ) + -- > where } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs index 4620307..e9c9aa3 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -29,13 +29,17 @@ layoutModule lmod@(L _ mod') = case mod' of HsModule Nothing _ imports _ _ _ -> docLines $ map layoutImport imports HsModule (Just n) les imports _ _ _ -> do let tn = Text.pack $ moduleNameString $ unLoc n + allowSingleLineExportList <- mAsk + <&> _conf_layout + .> _lconfig_allowSingleLineExportList + .> confUnpack docLines $ docSeq [ docNodeAnnKW lmod Nothing docEmpty -- A pseudo node that serves merely to force documentation -- before the node - , docNodeMoveToKWDP lmod AnnModule $ docAlt - ( [ docForceSingleline $ docSeq + , docNodeMoveToKWDP lmod AnnModule $ docAltFilter + [ (,) allowSingleLineExportList $ docForceSingleline $ docSeq [ appSep $ docLit $ Text.pack "module" , appSep $ docLit tn , docWrapNode lmod $ appSep $ case les of @@ -43,8 +47,7 @@ layoutModule lmod@(L _ mod') = case mod' of Just x -> layoutLLIEs True x , docLit $ Text.pack "where" ] - ] - ++ [ docLines + , (,) otherwise $ docLines [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) @@ -54,7 +57,6 @@ layoutModule lmod@(L _ mod') = case mod' of ) , docLit $ Text.pack "where" ] - ] - ) + ] ] : map layoutImport imports From 15d2250c0bbc6f10a03db8bc225001ccbe871de8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 17:21:28 +0100 Subject: [PATCH 22/23] Change _lconfig_importColumn default: 60 -> 50 --- src/Language/Haskell/Brittany/Internal/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index d9266a9..ea01253 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -58,7 +58,7 @@ staticDefaultConfig = Config , _lconfig_indentAmount = coerce (2 :: Int) , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) From 8de56ba11d4e2442a648f28573254edd5f54e403 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 21 Mar 2018 01:02:44 +0100 Subject: [PATCH 23/23] Support import column vs import-as column --- src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + src/Language/Haskell/Brittany/Internal/Config.hs | 3 +++ src/Language/Haskell/Brittany/Internal/Config/Types.hs | 7 ++++++- src/Language/Haskell/Brittany/Internal/Layouters/Import.hs | 5 +++-- 5 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 47fd801..ebe2a08 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -169,6 +169,7 @@ defaultTestConfig = Config , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importAsColumn = coerce (60 :: Int) , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 2e9487c..d10f85a 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -51,6 +51,7 @@ defaultTestConfig = Config , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True , _lconfig_importColumn = coerce (60 :: Int) + , _lconfig_importAsColumn = coerce (60 :: Int) , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index ea01253..d660e6e 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -59,6 +59,7 @@ staticDefaultConfig = Config , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) @@ -106,6 +107,7 @@ configParser = do ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") + importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") @@ -155,6 +157,7 @@ configParser = do , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ , _lconfig_indentListSpecial = mempty -- falseToNothing _ , _lconfig_importColumn = optionConcat importCol + , _lconfig_importAsColumn = optionConcat importAsCol , _lconfig_altChooser = mempty , _lconfig_columnAlignMode = mempty , _lconfig_alignmentLimit = mempty diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 0f6d48b..03f7d9a 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -53,7 +53,12 @@ data CLayoutConfig f = LayoutConfig , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," -- when creating zero-indentation -- multi-line list literals. - , _lconfig_importColumn :: f (Last Int) + , _lconfig_importColumn :: f (Last Int) + -- ^ for import statement layouting, column at which to align the + -- elements to be imported from a module. + , _lconfig_importAsColumn :: f (Last Int) + -- ^ for import statement layouting, column at which put the module's + -- "as" name (which also affects the positioning of the "as" keyword). , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) , _lconfig_alignmentLimit :: f (Last Int) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs index e7fb03c..a98f642 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -46,6 +46,7 @@ layoutImport :: ToBriDoc ImportDecl layoutImport limportD@(L _ importD) = docWrapNode limportD $ 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 indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let compact = indentPolicy == IndentPolicyLeft @@ -136,9 +137,9 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] | otherwise -> docLines [importHead, asDoc, bindingLine] where - enoughRoom = nameCost < importCol - asCost + enoughRoom = nameCost < importAsCol - asCost asDoc = - docEnsureIndent (BrIndentSpecial (importCol - asCost)) + docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) $ makeAsDoc n Nothing | enoughRoom -> docSeq [importHead, bindingLine] | otherwise -> docLines [importHead, bindingLine]