From ee9abff9e8e56e96ba0bb78a84c1f6a7491b60ea Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Sat, 16 Dec 2017 14:00:49 +0100 Subject: [PATCH 01/66] 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 + ) -- 2.30.2 From a72465ebef408468a06dfe9fa89f9d33edb8f92c Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Sun, 17 Dec 2017 13:13:19 +0100 Subject: [PATCH 02/66] 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" - -- 2.30.2 From e140cd01e07838699e8a74777de707ebda179bfd Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Sun, 17 Dec 2017 14:00:16 +0100 Subject: [PATCH 03/66] 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" -- 2.30.2 From 204f0aff0857968a24d0f0e2f968c3bd91a51e26 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 17 Dec 2017 20:47:52 +0100 Subject: [PATCH 04/66] 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) -- 2.30.2 From c3b6e172614eb53468fb8cec50000b99b3681c2b Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Mon, 18 Dec 2017 12:01:22 +0100 Subject: [PATCH 05/66] 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 -- 2.30.2 From 8c3a9bec251eb80df64e5e6b5b539ebbff9d3f78 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 18 Dec 2017 18:56:50 +0100 Subject: [PATCH 06/66] 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 -- 2.30.2 From eac17b1bf28637f608da973df7b137115b18bdc1 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 01:11:25 +0100 Subject: [PATCH 07/66] 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 -- 2.30.2 From 7c51a181c8af97bd1b9ac8f50eca2e98cb351d9d Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 01:17:19 +0100 Subject: [PATCH 08/66] 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 ")"] -- 2.30.2 From a59df1f3913344768e4d5d2b7835652e787eecef Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 14:28:22 +0100 Subject: [PATCH 09/66] 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 -- 2.30.2 From bcdd05848569c5381eeebf43558b31b1d8007758 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 19 Dec 2017 15:28:52 +0100 Subject: [PATCH 10/66] Update README.md for stackage lts release --- README.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 3196b27..c7bd461 100644 --- a/README.md +++ b/README.md @@ -52,7 +52,7 @@ log the size of the input, but _not_ the full requests.) # Other usage notes - Supports GHC versions `8.0.*` and `8.2.*`. -- as of November'17, `brittany` is available on stackage nightly. +- included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. - uses/creates user config file in `~/.config/brittany/config.yaml`; @@ -84,11 +84,11 @@ log the size of the input, but _not_ the full requests.) - via `stack` using a sufficiently recent stackage snapshot (dated to >= 2017-11-15) ~~~~.sh - stack install brittany # --resolver=nightly-2017-11-15 + stack install brittany # --resolver lts-10.0 ~~~~ - (alternatively, should nightlies be unreliable, or you want to use ghc-8.0 or something, then - cloning the repo and doing `stack install` will use an lts resolver.) + (earlier ltss did not include `brittany` yet, but the repo should contain a + `stack.yaml` that works with ghc-8.0.) - on ArchLinux via [the britanny AUR package](https://aur.archlinux.org/packages/brittany/) using `aura`: -- 2.30.2 From 162b6e6bfda6fc64b6f5fc28345bca41fab383d7 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Tue, 19 Dec 2017 16:33:13 +0100 Subject: [PATCH 11/66] 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 -- 2.30.2 From ce7ec0b4679d5fd3cb8a2e51a67752d34dd2390b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 19 Dec 2017 17:52:33 +0100 Subject: [PATCH 12/66] 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 $ -- 2.30.2 From 33f23a65ec44d70aecde50dcdaf16b09a4f8c470 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 21 Dec 2017 15:44:58 +0100 Subject: [PATCH 13/66] 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" ] ] -- 2.30.2 From 82a5ffb3b3ce02f4370784e416c999518bd07d5a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 21 Dec 2017 17:56:54 +0100 Subject: [PATCH 14/66] 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 "()" -- 2.30.2 From 21c080572b39fb4307edfe19107998a2a2b4f2d9 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Thu, 21 Dec 2017 23:51:27 +0100 Subject: [PATCH 15/66] 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 -- 2.30.2 From 3708838b6a4a7618afbadb5182d81ff2fa9ad5e8 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Fri, 22 Dec 2017 06:58:39 +0100 Subject: [PATCH 16/66] 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 -- 2.30.2 From ad34a8b9b99a277c4ba11413a08fdc21ea85ce41 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Fri, 22 Dec 2017 10:08:30 +0100 Subject: [PATCH 17/66] 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 -- 2.30.2 From 98c93f0d63ed24d67ab28ec6518769494c1b97f2 Mon Sep 17 00:00:00 2001 From: sniperrifle2004 Date: Fri, 22 Dec 2017 16:35:39 +0100 Subject: [PATCH 18/66] 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] -- 2.30.2 From 8fe9ba1f43b753c2522a37aece27e4bd9c523502 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 13 Jan 2018 18:02:00 +0100 Subject: [PATCH 19/66] Update readme: Add editor integration paragraph --- README.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/README.md b/README.md index c7bd461..ba6fe36 100644 --- a/README.md +++ b/README.md @@ -96,6 +96,19 @@ log the size of the input, but _not_ the full requests.) aura -A brittany ~~~~ +# Editor Integration + +#### Sublime text + [In this gist](https://gist.github.com/lspitzner/097c33177248a65e7657f0c6d0d12075) + I have described a haskell setup that includes a shortcut to run brittany formatting. +#### VSCode + [This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany) + connects commandline `brittany` to VSCode formatting API. Thanks to Max Garbriel. +#### Via HIE + [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) + includes a `brittany` plugin that directly uses the brittany library. + Relevant for any editors that properly support the language-server-protocol. + # Usage - Default mode of operation: Transform a single module, from `stdin` to `stdout`. -- 2.30.2 From 37bc36f10a8924552bb666104bc92f07fc58732a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sat, 13 Jan 2018 18:05:21 +0100 Subject: [PATCH 20/66] Update README.md --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index ba6fe36..3850fbd 100644 --- a/README.md +++ b/README.md @@ -103,7 +103,7 @@ log the size of the input, but _not_ the full requests.) I have described a haskell setup that includes a shortcut to run brittany formatting. #### VSCode [This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany) - connects commandline `brittany` to VSCode formatting API. Thanks to Max Garbriel. + connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGarbriel. #### Via HIE [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) includes a `brittany` plugin that directly uses the brittany library. -- 2.30.2 From d086140120dc1398d8149723979c1e347bdc7130 Mon Sep 17 00:00:00 2001 From: Jake Zimmerman Date: Wed, 24 Jan 2018 15:19:04 -0800 Subject: [PATCH 21/66] Add Vim / Neovim plugin I saw that you started an editor integration section, and thought that it might benefit from a Vim / Neovim section \o/ Thanks for this program by the way! --- README.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/README.md b/README.md index 3850fbd..cc264e4 100644 --- a/README.md +++ b/README.md @@ -108,6 +108,9 @@ log the size of the input, but _not_ the full requests.) [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) includes a `brittany` plugin that directly uses the brittany library. Relevant for any editors that properly support the language-server-protocol. +#### Neovim / Vim 8 + The [Neoformat](https://github.com/sbdchd/neoformat) plugin comes with support for + brittany built in. # Usage -- 2.30.2 From 18b3cfaf88d44ba6d2e1bfc27a3d43eb8381314b Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Mon, 15 Jan 2018 16:02:14 -0500 Subject: [PATCH 22/66] Fix infix constructor pattern matching for normal constructors Brittany was previously only support symbol based infix constructors. It is common in some libraries (for example Esqueleto) to pattern match on normal constructors as infix. Brittany was failing in this case by not wrapping the constructor name in back ticks/spaces. Backticks and spaces have been added in the case where the constructor contains any alpha characters. --- src-literatetests/10-tests.blt | 3 +++ src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 5 ++++- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index a3d8591..6659847 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -355,6 +355,9 @@ func (x:xr) = x #pending func (x:+:xr) = x +#test normal infix constructor +func (x `Foo` xr) = x + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index ebdd91d..2f881a0 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -13,6 +13,7 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics +import Data.Char (isAlpha) import RdrName ( RdrName(..) ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import HsSyn @@ -80,7 +81,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of let nameDoc = lrdrNameToText lname leftDoc <- colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right - middle <- docLit nameDoc + middle <- docLit $ if Text.any isAlpha nameDoc + then Text.pack " `" <> nameDoc <> Text.pack "` " + else nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do -- Abc{} -> expr -- 2.30.2 From 019d47bf7e7a4c4d7cca18b41f9319c6f518ff6e Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Mon, 15 Jan 2018 19:11:25 -0500 Subject: [PATCH 23/66] Change infix patterns to include spaces This commit changes infix patterns to utilize `lrdrNameToTextAnn`. This function allows the logic to avoid introspecting on the constructor name. Additionally this adds spaces to all infix operator pattern matches. Previously infix symbols did not include spaces: ``` foo (x:xs) = _ ``` Now they include a space ``` foo (x : xs) = _ ``` --- src-literatetests/10-tests.blt | 4 ++-- src-literatetests/15-regressions.blt | 4 ++-- src-literatetests/tests-context-free.blt | 6 +++--- .../Haskell/Brittany/Internal/Layouters/Pattern.hs | 8 +++----- 4 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 6659847..af873df 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -349,11 +349,11 @@ func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable func (A a) = a #test list constructor -func (x:xr) = x +func (x : xr) = x #test some other constructor symbol #pending -func (x:+:xr) = x +func (x :+: xr) = x #test normal infix constructor func (x `Foo` xr) = x diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 0fbc830..5c31ab6 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -123,8 +123,8 @@ func = do #test list comprehension comment placement func = [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_:_)) <- nosuchFooThing - , gast <- award + | (thing, _got, alts@(_ : _)) <- nosuchFooThing + , gast <- award ] #test if-then-else comment placement diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt index e8303cd..0d3d8cf 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -366,11 +366,11 @@ func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable func (A a) = a #test list constructor -func (x:xr) = x +func (x : xr) = x #test some other constructor symbol #pending -func (x:+:xr) = x +func (x :+: xr) = x ############################################################################### @@ -748,7 +748,7 @@ func = do #test list comprehension comment placement func = [ (thing, take 10 alts) --TODO: select best ones - | (thing, _got, alts@(_:_)) <- nosuchFooThing + | (thing, _got, alts@(_ : _)) <- nosuchFooThing , gast <- award ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 2f881a0..317fbe2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -78,12 +78,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of return $ x1 Seq.<| xR ConPatIn lname (InfixCon left right) -> do -- a :< b -> expr - let nameDoc = lrdrNameToText lname - leftDoc <- colsWrapPat =<< layoutPat left + let nameDoc = lrdrNameToTextAnn lname + leftDoc <- appSep . colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right - middle <- docLit $ if Text.any isAlpha nameDoc - then Text.pack " `" <> nameDoc <> Text.pack "` " - else nameDoc + middle <- appSep . docLit =<< nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do -- Abc{} -> expr -- 2.30.2 From eb8f0de6c3b04505f2350137ce41308c25149c54 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Mon, 15 Jan 2018 19:15:51 -0500 Subject: [PATCH 24/66] Remove redundant import. --- src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 317fbe2..c04790d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -13,7 +13,6 @@ where import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics -import Data.Char (isAlpha) import RdrName ( RdrName(..) ) import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import HsSyn -- 2.30.2 From 077b93db016123ba58aed9568fef05bfeb0dd7f8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 9 Feb 2018 16:50:57 +0100 Subject: [PATCH 25/66] Minor refactor --- src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index c04790d..51bb03a 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -77,10 +77,10 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of return $ x1 Seq.<| xR ConPatIn lname (InfixCon left right) -> do -- a :< b -> expr - let nameDoc = lrdrNameToTextAnn lname - leftDoc <- appSep . colsWrapPat =<< layoutPat left + nameDoc <- lrdrNameToTextAnn lname + leftDoc <- appSep . colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right - middle <- appSep . docLit =<< nameDoc + middle <- appSep $ docLit nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do -- Abc{} -> expr -- 2.30.2 From 8430b74b1ad77835f755a821bd32635879bc13f5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Feb 2018 20:05:48 +0100 Subject: [PATCH 26/66] Switch to butcher-1.3, Improve help layout, fixes #103 --- brittany.cabal | 2 +- src-brittany/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index 42277ad..ae71fde 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -94,7 +94,7 @@ library { , pretty >=1.1.3.3 && <1.2 , bytestring >=0.10.8.1 && <0.11 , directory >=1.2.6.2 && <1.4 - , butcher >=1.2 && <1.3 + , butcher >=1.3 && <1.4 , yaml >=0.8.18 && <0.9 , aeson >=1.0.1.0 && <1.3 , extra >=1.4.10 && <1.7 diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index bcb8a3f..cc721d2 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -161,7 +161,7 @@ mainCmdParser helpDesc = do putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do - liftIO $ print $ ppHelpShallow helpDesc + liftIO $ putStrLn $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } $ ppHelpShallow helpDesc System.Exit.exitSuccess let inputPaths = if null inputParams then [Nothing] else map Just inputParams -- 2.30.2 From d749c0da2715f0d0678644ab95429a8715827a50 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Feb 2018 20:06:31 +0100 Subject: [PATCH 27/66] Prevent crash if ~/.config does not exist (fixes #115) --- src-brittany/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index cc721d2..324a7a3 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -346,7 +346,7 @@ readConfigs cmdlineConfig configPaths = do userConfigXdg <- readConfig userConfigPathXdg let userConfig = userConfigSimple <|> userConfigXdg when (Data.Maybe.isNothing userConfig) $ do - liftIO $ Directory.createDirectoryIfMissing False userBritPathXdg + liftIO $ Directory.createDirectoryIfMissing True userBritPathXdg writeDefaultConfig userConfigPathXdg -- rightmost has highest priority pure $ [userConfig, localConfig] -- 2.30.2 From 779a23c380d1ff3bc68642d91a367903d05aa6bd Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Feb 2018 20:32:19 +0100 Subject: [PATCH 28/66] Update README.md: Conf file discovery description --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index cc264e4..8366d6b 100644 --- a/README.md +++ b/README.md @@ -56,7 +56,8 @@ log the size of the input, but _not_ the full requests.) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. - uses/creates user config file in `~/.config/brittany/config.yaml`; - also reads `brittany.yaml` in current dir if present. + also reads (the first) `brittany.yaml` found in current or parent + directories. # Installation -- 2.30.2 From 91de1ca08cc7e95c072a85fd98d11926ba4c0689 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Feb 2018 23:48:00 +0100 Subject: [PATCH 29/66] Fix bang deletion on ghc-8.2, Add testcase (fixes #116) --- src-literatetests/15-regressions.blt | 6 ++++ .../Brittany/Internal/Layouters/Decl.hs | 31 ++++++++++++++++--- 2 files changed, 33 insertions(+), 4 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 5c31ab6..dda42a0 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -513,3 +513,9 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] #test issue 70 {-# LANGUAGE TemplateHaskell #-} deriveFromJSON (unPrefix "assignPost") ''AssignmentPost + +#test issue 116 +{-# LANGUAGE BangPatterns #-} +func = do + let !forced = some + pure () diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 8724291..c6ff4e0 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -192,16 +192,17 @@ layoutPatternBind -> BriDocNumbered -> LMatch RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered -layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do +layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (GRHSs grhss whereBinds))) = do patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match - patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of - (Just idStr, p1:pr) | isInfix -> docCols + let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr + patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of + (Just idStr, p1 : pr) | isInfix -> docCols ColPatternsFuncInfix ( [appSep $ docForceSingleline p1, appSep $ docLit idStr] ++ (spacifyDocs $ docForceSingleline <$> pr) ) - (Just idStr, [] ) -> docLit idStr + (Just idStr, []) -> docLit idStr (Just idStr, ps) -> docCols ColPatternsFuncPrefix $ appSep (docLit $ idStr) @@ -220,6 +221,28 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhs mWhereDocs hasComments +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +fixPatternBindIdentifier + :: HsMatchContext (NameOrRdrName RdrName) -> Text -> Text +fixPatternBindIdentifier ctx idStr = case ctx of + (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr + (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr + (FunRhs _ _ NoSrcStrict) -> idStr + (StmtCtxt ctx1 ) -> fixPatternBindIdentifier' ctx1 + _ -> idStr + where + -- I have really no idea if this path ever occurs, but better safe than + -- risking another "drop bangpatterns" bugs. + fixPatternBindIdentifier' = \case + (PatGuard ctx1) -> fixPatternBindIdentifier ctx1 idStr + (ParStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1 + (TransStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1 + _ -> idStr +#else /* ghc-8.0 */ +fixPatternBindIdentifier :: MatchFixity RdrName -> Text -> Text +fixPatternBindIdentifier _ x = x +#endif + layoutPatternBindFinal :: Maybe Text -> BriDocNumbered -- 2.30.2 From 55b1c71bf3da03eab9a722d7143871fe079c4f9d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 01:00:01 +0100 Subject: [PATCH 30/66] Fix a layouting mistake that went unnoticed so far --- src-literatetests/15-regressions.blt | 6 ++++++ src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 7 +++++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index dda42a0..7654285 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -519,3 +519,9 @@ deriveFromJSON (unPrefix "assignPost") ''AssignmentPost func = do let !forced = some pure () + +#test let-in-hanging +spanKey p q = case minViewWithKey q of + Just ((k, _), q') | p k -> + let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') + _ -> ([], q) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index c6ff4e0..9681453 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -300,10 +300,13 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] let singleLineGuardsDoc guards = appSep $ case guards of [] -> docEmpty - [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] + [g] -> docSeq + [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] - ++ List.intersperse docCommaSep (return <$> gs) + ++ (List.intersperse docCommaSep + (docForceSingleline . return <$> gs) + ) indentPolicy <- mAsk <&> _conf_layout -- 2.30.2 From 81928ea59715508d6d2b931bbed82f205fa9ac7d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 01:14:24 +0100 Subject: [PATCH 31/66] Switch to ghc-exactprint-0.5.6.0, Remove code duplication --- brittany.cabal | 2 +- .../Brittany/Internal/ExactPrintUtils.hs | 39 +------------------ 2 files changed, 2 insertions(+), 39 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index ae71fde..d0059f1 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -82,7 +82,7 @@ library { { base >=4.9 && <4.11 , ghc >=8.0.1 && <8.3 , ghc-paths >=0.1.0.9 && <0.2 - , ghc-exactprint >=0.5.3.0 && <0.5.6 + , ghc-exactprint >=0.5.6.0 && <0.5.7 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.6 , mtl >=2.2.1 && <2.3 diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 7494d9e..749804c 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -113,48 +113,11 @@ parseModuleFromString args fp dynCheck str = $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> \(L _ s) -> s) dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 - let res = parseModulePure dflags1 fp str + let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of Left (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err Right (a , m ) -> pure (a, m, dynCheckRes) ------------ - --- this function should move to ghc-exactprint. btw, we can deprecate/remove --- the `parseModuleFromString` function that I added initially to --- ghc-exactprint. -parseModulePure - :: GHC.DynFlags - -> System.IO.FilePath - -> String - -> Either (SrcSpan, String) (ExactPrint.Anns, GHC.ParsedSource) -parseModulePure dflags fileName str = - let (str1, lp) = ExactPrint.stripLinePragmas str - res = case runParser GHC.parseModule dflags fileName str1 of - GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m) - GHC.POk x pmod -> Right $ (mkApiAnns x, lp, dflags, pmod) - in ExactPrint.postParseTransform res ExactPrint.normalLayout - --- copied from exactprint until exactprint exposes a proper interface. -runParser - :: GHC.P a - -> GHC.DynFlags - -> System.IO.FilePath - -> String - -> GHC.ParseResult a -runParser parser flags filename str = GHC.unP parser parseState - where - location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1 - buffer = GHC.stringToStringBuffer str - parseState = GHC.mkPState flags buffer location -mkApiAnns :: GHC.PState -> GHC.ApiAnns -mkApiAnns pstate = - ( Map.fromListWith (++) . GHC.annotations $ pstate - , Map.fromList - ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate) - ) - ------------ commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob ast = do -- 2.30.2 From c28ec4cfdfe33e222a76053bb49dbee87c476382 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 14:42:26 +0100 Subject: [PATCH 32/66] Bump butcher version in stack-8.0.2.yaml --- stack-8.0.2.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index 539cd6d..51c6004 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -3,7 +3,7 @@ resolver: lts-9.0 extra-deps: - monad-memo-0.4.1 - czipwith-1.0.0.0 - - butcher-1.2.0.0 + - butcher-1.3.0.0 - data-tree-print-0.1.0.0 - deque-0.2 -- 2.30.2 From c28636adca522713ceebf51854162dd11f548828 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 15:20:22 +0100 Subject: [PATCH 33/66] Add ghc-exactprint-0.5.6.0 to extra-deps in stack.yaml --- stack-8.0.2.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index 51c6004..ca6ad6a 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -6,6 +6,7 @@ extra-deps: - butcher-1.3.0.0 - data-tree-print-0.1.0.0 - deque-0.2 + - ghc-exactprint-0.5.6.0 packages: - . -- 2.30.2 From f17d9f8bf6f71358d3b9aa287150a923de38b1c5 Mon Sep 17 00:00:00 2001 From: Maximilian Tagher Date: Wed, 14 Feb 2018 06:54:39 -0800 Subject: [PATCH 34/66] Fix spelling of my name --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 8366d6b..2f55f03 100644 --- a/README.md +++ b/README.md @@ -104,7 +104,7 @@ log the size of the input, but _not_ the full requests.) I have described a haskell setup that includes a shortcut to run brittany formatting. #### VSCode [This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany) - connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGarbriel. + connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGabriel. #### Via HIE [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) includes a `brittany` plugin that directly uses the brittany library. -- 2.30.2 From 4b53072ccdfa348d107044c624afaf4a1e973544 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 17:18:15 +0100 Subject: [PATCH 35/66] Correct some commandline help output --- src-brittany/Main.hs | 9 +++++---- src/Language/Haskell/Brittany/Internal/Config.hs | 6 +++--- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 324a7a3..f986ad9 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -82,9 +82,10 @@ helpDoc = PP.vcat $ List.intersperse ] , parDocW [ "This program is written carefully and contains safeguards to ensure" - , "the transformation does not change semantics (or the syntax tree at all)" - , "and that no comments are removed." - , "Nonetheless, this is a young project, and there will always be bugs." + , "the output is syntactically valid and that no comments are removed." + , "Nonetheless, this is a young project, and there will always be bugs," + , "and ensuring that the transformation never changes semantics of the" + , "transformed source is currently not possible." , "Please do check the output and do not let brittany override your large" , "codebase without having backups." ] @@ -148,7 +149,7 @@ mainCmdParser helpDesc = do ) <> flagDefault Display ) - inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files") + inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files") reorderStop addCmdImpl $ void $ do when printLicense $ do diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index f225545..ad991b5 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -105,7 +105,7 @@ configParser = do 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") - dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)") + 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") dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") @@ -119,9 +119,9 @@ configParser = do dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") - outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible") + outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") - omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid; for dev on brittany") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") -- 2.30.2 From bac69ba54f3988f4f2999366a038c973bedb8a11 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 14 Feb 2018 17:18:22 +0100 Subject: [PATCH 36/66] Bump to 0.9.0.1, Add changelog --- ChangeLog.md | 16 ++++++++++++++++ brittany.cabal | 2 +- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 05a7ea2..1b23e1e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,21 @@ # Revision history for brittany +## 0.9.0.1 -- February 2018 + +* Support `TupleSections` (thanks to Matthew Piziak) +* Bugfixes: + - Fix Shebang handling with stdin input (#92) + - Fix bug that effectively deleted strict/lazy matches (BangPatterns) (#116) + - Fix infix operator whitespace bug (#101, #114) + - Fix help command output and its layouting (#103) + - Fix crash when config dir does not exist yet (#115) +* Layouting changes: + - no space after opening non-tuple parenthesis even for multi-line case + - use spaces around infix operators (applies to sections and in pattern + matches) + - Let-in is layouted more flexibly in fewer lines, if possible + (thanks to Evan Borden) + ## 0.9.0.0 -- December 2017 * Change default global config path (use XDG spec) diff --git a/brittany.cabal b/brittany.cabal index d0059f1..b6ecf52 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.9.0.0 +version: 0.9.0.1 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From c124336738b922b0269d4e44e1c1095ada9ec8e9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 19 Feb 2018 17:17:39 +0100 Subject: [PATCH 37/66] Fix NOINLINE pragma layouting --- src-literatetests/10-tests.blt | 4 ++++ src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index af873df..3f7ec68 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -287,6 +287,10 @@ func = f {-# INLINE CONLIKE [1] f #-} f = id +#test noinline pragma 1 +{-# NOINLINE func #-} +func :: Int + #test inline pragma 4 #pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2. func = f diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 9681453..400d422 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -94,7 +94,8 @@ layoutSig lsig@(L _loc sig) = case sig of NoInline -> "NOINLINE " EmptyInlineSpec -> "" -- i have no idea if this is correct. let phaseStr = case phaseAct of - NeverActive -> "[] " + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default AlwaysActive -> "" ActiveBefore _ i -> "[~" ++ show i ++ "] " ActiveAfter _ i -> "[" ++ show i ++ "] " -- 2.30.2 From 19e31fdaf2bed40e25f9c9b29907441279f53fbe Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 19 Feb 2018 21:33:43 +0100 Subject: [PATCH 38/66] Improve layouting of RecordUpd, Fix minor issue for HsLet --- src-literatetests/15-regressions.blt | 5 +- .../Brittany/Internal/Layouters/Expr.hs | 55 ++++++++++++++----- 2 files changed, 42 insertions(+), 18 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 7654285..5e4f52c 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -367,9 +367,8 @@ runBrittany tabSize text = do let config' = staticDefaultConfig config = config' - { _conf_layout = (_conf_layout config') { _lconfig_indentAmount = coerce - tabSize - } + { _conf_layout = + (_conf_layout config') { _lconfig_indentAmount = coerce tabSize } , _conf_forward = forwardOptionsSyntaxExtsEnabled } parsePrintModule config text diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 8d90148..807aad8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -535,13 +535,15 @@ layoutExpr lexpr@(L _ expr) = do ifIndentLeftElse :: a -> a -> a ifIndentLeftElse x y = if indentPolicy == IndentPolicyLeft then x else y - -- this `docSetIndentLevel` might seem out of place, but is here due to - -- ghc-exactprint's DP handling of "let" in particular. + -- this `docSetBaseAndIndent` might seem out of place (especially the + -- Indent part; setBase is necessary due to the use of docLines below), + -- but is here due to ghc-exactprint's DP handling of "let" in + -- particular. -- Just pushing another indentation level is a straightforward approach -- to making brittany idempotent, even though the result is non-optimal -- if "let" is moved horizontally as part of the transformation, as the -- comments before the first let item are moved horizontally with it. - docSetIndentLevel $ case mBindDocs of + docSetBaseAndIndent $ case mBindDocs of Just [bindDoc] -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" @@ -733,6 +735,8 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "}" ] RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do + -- TODO: the layouter for RecordUpd is slightly more clever. Should + -- probably copy the approach from there. let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do fExpDoc <- if pun @@ -852,7 +856,7 @@ layoutExpr lexpr@(L _ expr) = do Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) docAltFilter - -- singleline + -- container { fieldA = blub, fieldB = blub } [ ( True , docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc @@ -870,7 +874,10 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "}" ] ) - -- wild-indentation block + -- hanging single-line fields + -- container { fieldA = blub + -- , fieldB = blub + -- } , ( indentPolicy /= IndentPolicyLeft , docSeq [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc @@ -881,7 +888,7 @@ layoutExpr lexpr@(L _ expr) = do , case rF1e of Just x -> docWrapNodeRest rF1f $ docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline $ x + , docForceSingleline x ] Nothing -> docEmpty ] @@ -901,36 +908,54 @@ layoutExpr lexpr@(L _ expr) = do in [line1] ++ lineR ++ [lineN] ] ) - -- strict indentation block + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } , ( True , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docNodeAnnKW lexpr Nothing $ rExprDoc) (docNonBottomSpacing $ docLines $ let + expressionWrapper = if indentPolicy == IndentPolicyLeft + then docForceParSpacing + else docSetBaseY line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n , docWrapNodeRest rF1f $ case rF1e of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular $ x - ] + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] Nothing -> docEmpty ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield + $ docCols ColRecUpdate [ docCommaSep , appSep $ docLit $ fText , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular x - ] + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] Nothing -> docEmpty ] lineN = docSeq [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty , docLit $ Text.pack "}" ] - in [line1] ++ lineR ++ [lineN]) + in [line1] ++ lineR ++ [lineN] + ) ) ] #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ -- 2.30.2 From b3dc1dff04673de6ca3a36974f18450621544a08 Mon Sep 17 00:00:00 2001 From: waddlaw Date: Mon, 26 Feb 2018 17:26:50 +0900 Subject: [PATCH 39/66] Add text-latin1 package --- brittany.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/brittany.cabal b/brittany.cabal index 42277ad..f3f6eba 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -108,6 +108,7 @@ library { , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.0.0 && <1.1 , ghc-boot-th >=8.0.1 && <8.3 + , text-latin1 >= 0.3 && < 0.4 } default-extensions: { CPP -- 2.30.2 From 1e8d62232c374d686e83826ea8e57d75470db702 Mon Sep 17 00:00:00 2001 From: waddlaw Date: Mon, 26 Feb 2018 17:45:09 +0900 Subject: [PATCH 40/66] Add elasticLength function --- .../Haskell/Brittany/Internal/BackendUtils.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index a7d8594..d5f9d52 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -32,6 +32,7 @@ module Language.Haskell.Brittany.Internal.BackendUtils , layoutWritePriorComments , layoutWritePostComments , layoutRemoveIndentLevelLinger + , elasticLength ) where @@ -51,6 +52,7 @@ import Language.Haskell.Brittany.Internal.Utils import GHC ( Located, GenLocated(L), moduleNameString ) +import Text.Ascii (isAscii) traceLocal @@ -102,6 +104,16 @@ layoutWriteAppend t = do , _lstate_addSepSpace = Nothing } +-- | +-- >>> elasticLength "あ" +-- 2 +-- >>> elasticLength "abc" +-- 3 +-- >>> elasticLength "aあa" +-- 4 +elasticLength :: Text -> Int +elasticLength = Text.foldl' (\len c -> if isAscii c then len + 1 else len + 2) 0 + layoutWriteAppendSpaces :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m -- 2.30.2 From 62f2f4977d51494250d5dbfa90a54f7e8c27d159 Mon Sep 17 00:00:00 2001 From: waddlaw Date: Mon, 26 Feb 2018 17:46:18 +0900 Subject: [PATCH 41/66] Fix ColumnAlign problem for multibyte strings #122 --- src/Language/Haskell/Brittany/Internal/Backend.hs | 2 +- src/Language/Haskell/Brittany/Internal/BackendUtils.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index c121eaf..dbc611e 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -264,7 +264,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc where rec = \case BDEmpty -> return $ 0 - BDLit t -> StateS.put False $> Text.length t + BDLit t -> StateS.put False $> elasticLength t BDSeq bds -> sum <$> rec `mapM` bds BDCols _ bds -> sum <$> rec `mapM` bds BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index d5f9d52..63e6090 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -99,7 +99,7 @@ layoutWriteAppend t = do mTell $ Text.Builder.fromText $ t mModify $ \s -> s { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of - Left c -> c + Text.length t + spaces + Left c -> c + elasticLength t + spaces Right{} -> Text.length t + spaces , _lstate_addSepSpace = Nothing } @@ -170,7 +170,7 @@ layoutWriteNewlineBlock = do -- mSet $ state -- { _lstate_addSepSpace = Just -- $ if isJust $ _lstate_addNewline state --- then i +-- then i -- else _lstate_indLevelLinger state + i - _lstate_curY state -- } @@ -600,7 +600,7 @@ layoutIndentRestorePostComment = do -- layoutWritePriorCommentsRestore x = do -- layoutWritePriorComments x -- layoutIndentRestorePostComment --- +-- -- layoutWritePostCommentsRestore :: (Data.Data.Data ast, -- MonadMultiWriter Text.Builder.Builder m, -- MonadMultiState LayoutState m -- 2.30.2 From e4dea8783901d44fe5236ef080814fa76250b2e4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 4 Mar 2018 19:11:10 +0100 Subject: [PATCH 42/66] Switch to using branches master/release instead of dev/master --- README.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/README.md b/README.md index 2f55f03..42e7fa5 100644 --- a/README.md +++ b/README.md @@ -160,8 +160,6 @@ a good amount of high-level documentation at [the documentation index](doc/implementation/index.md) -Note that most development happens on the `dev` branch of this repository! - # License Copyright (C) 2016-2017 Lennart Spitzner -- 2.30.2 From 83b39de3d424dc1062b52657109862160fa08c6b Mon Sep 17 00:00:00 2001 From: alexeyraga Date: Fri, 23 Feb 2018 21:57:50 +1100 Subject: [PATCH 43/66] Expose readConfigs --- brittany.cabal | 1 + src-brittany/Main.hs | 49 +++------------- src/Language/Haskell/Brittany.hs | 4 ++ .../Haskell/Brittany/Internal/Config.hs | 57 ++++++++++++++++++- stack.yaml | 5 +- 5 files changed, 70 insertions(+), 46 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index b6ecf52..a090280 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -108,6 +108,7 @@ library { , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.0.0 && <1.1 , ghc-boot-th >=8.0.1 && <8.3 + , filepath >=1.4.1.0 && <1.5 } default-extensions: { CPP diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index f986ad9..057ad24 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -158,7 +158,7 @@ mainCmdParser helpDesc = do when printVersion $ do do putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2017 Lennart Spitzner" + putStrLn $ "Copyright (C) 2016-2018 Lennart Spitzner" putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do @@ -170,10 +170,14 @@ mainCmdParser helpDesc = do Display -> repeat Nothing Inplace -> inputPaths - config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case + configsToLoad <- liftIO $ if null configPaths + then maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths + + config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x - when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do + when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ trace (showConfigYaml config) $ return () results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths @@ -317,42 +321,3 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx ] then trace "----" else id - - -readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config -readConfigs cmdlineConfig configPaths = do - userBritPathSimple <- liftIO $ Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- liftIO - $ Directory.getXdgDirectory Directory.XdgConfig "brittany" - let userConfigPathSimple = userBritPathSimple FilePath. "config.yaml" - let userConfigPathXdg = userBritPathXdg FilePath. "config.yaml" - let - findLocalConfig :: MaybeT IO (Maybe (CConfig Option)) - findLocalConfig = do - cwd <- liftIO $ Directory.getCurrentDirectory - let dirParts = FilePath.splitDirectories cwd - let searchDirs = - [ FilePath.joinPath x | x <- reverse $ List.inits dirParts ] - -- when cwd is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] - mFilePath <- liftIO $ Directory.findFileWith Directory.doesFileExist - searchDirs - "brittany.yaml" - case mFilePath of - Nothing -> pure Nothing - Just fp -> readConfig fp - configsRead <- case configPaths of - [] -> do - localConfig <- findLocalConfig - userConfigSimple <- readConfig userConfigPathSimple - userConfigXdg <- readConfig userConfigPathXdg - let userConfig = userConfigSimple <|> userConfigXdg - when (Data.Maybe.isNothing userConfig) $ do - liftIO $ Directory.createDirectoryIfMissing True userBritPathXdg - writeDefaultConfig userConfigPathXdg - -- rightmost has highest priority - pure $ [userConfig, localConfig] - paths -> readConfig `mapM` reverse paths - -- reverse to give highest priority to the first - merged <- - pure $ Semigroup.mconcat $ catMaybes $ configsRead ++ [Just cmdlineConfig] - return $ cZipWith fromOptionIdentity staticDefaultConfig merged diff --git a/src/Language/Haskell/Brittany.hs b/src/Language/Haskell/Brittany.hs index 5f9a128..9d45dde 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -4,6 +4,10 @@ module Language.Haskell.Brittany ( parsePrintModule , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig , Config , CConfig(..) , CDebugConfig(..) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index ad991b5..fe1b317 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -9,6 +9,10 @@ module Language.Haskell.Brittany.Internal.Config , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled , readConfig + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig , writeDefaultConfig , showConfigYaml ) @@ -22,8 +26,10 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import qualified Data.Yaml +import Data.CZipWith import UI.Butcher.Monadic +import Data.Monoid ((<>)) import qualified System.Console.CmdArgs.Explicit as CmdArgs @@ -33,7 +39,8 @@ import Language.Haskell.Brittany.Internal.Utils import Data.Coerce ( Coercible, coerce ) - +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath staticDefaultConfig :: Config staticDefaultConfig = Config @@ -189,10 +196,10 @@ configParser = do -- <*> switch (long "barb") -- <*> flag 3 5 (long "barc") -- ) --- +-- -- configParserInfo :: ParserInfo Config -- configParserInfo = ParserInfo --- { infoParser = configParser +-- { infoParser = configParser -- , infoFullDesc = True -- , infoProgDesc = return $ PP.text "a haskell code formatting utility based on ghc-exactprint" -- , infoHeader = return $ PP.text "brittany" @@ -227,6 +234,50 @@ readConfig path = do return $ Just fileConf else return $ Nothing +-- | Returns a global brittany config file +-- If there is no global config in a system, one will be created +userConfigPath :: IO System.IO.FilePath +userConfigPath = do + userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + let searchDirs = [userBritPathSimple, userBritPathXdg] + globalConfig <- Directory.findFileWith Directory.doesFileExist searchDirs "config.yaml" + maybe (writeUserConfig userBritPathXdg) pure globalConfig + where + writeUserConfig dir = do + let createConfPath = dir FilePath. "config.yaml" + liftIO $ Directory.createDirectoryIfMissing True dir + writeDefaultConfig $ createConfPath + pure createConfPath + +-- | Searhes for a local brittany config path starting from a given directory +findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) +findLocalConfigPath dir = do + let dirParts = FilePath.splitDirectories dir + -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] + let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) + Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" + +-- | Reads specified configs. +readConfigs + :: CConfig Option -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigs cmdlineConfig configPaths = do + configs <- readConfig `mapM` configPaths + let merged = Semigroup.mconcat $ reverse (cmdlineConfig:catMaybes configs) + return $ cZipWith fromOptionIdentity staticDefaultConfig merged + +-- | Reads provided configs +-- but also applies the user default configuration (with a lowest priority) +readConfigsWithUserConfig + :: CConfig Option -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigsWithUserConfig cmdlineConfig configPaths = do + defaultPath <- liftIO $ userConfigPath + readConfigs cmdlineConfig (configPaths ++ [defaultPath]) + writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () writeDefaultConfig path = liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap diff --git a/stack.yaml b/stack.yaml index 74e27d2..3362823 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,7 @@ -resolver: lts-10.0 +resolver: lts-10.5 packages: - . + +extra-deps: + - butcher-1.3.0.0 -- 2.30.2 From af7f9017b82d9fa9d8886716a7e82cd2e9854dd9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 11 Mar 2018 22:07:12 +0100 Subject: [PATCH 44/66] 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 } -- 2.30.2 From 20f9c009ee18e18ca5c4d4db440f4e565757cbc4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 11 Mar 2018 22:42:47 +0100 Subject: [PATCH 45/66] 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 ] -- 2.30.2 From 9531edb2a79d7e53e8fad06726b72f6c675ce6fc Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 16:29:47 +0100 Subject: [PATCH 46/66] 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 -- 2.30.2 From 833ac95fd7ce764e93e2a4b20cda6c81341f1b53 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 17:11:25 +0100 Subject: [PATCH 47/66] 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 -- 2.30.2 From 15d2250c0bbc6f10a03db8bc225001ccbe871de8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 17:21:28 +0100 Subject: [PATCH 48/66] 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) -- 2.30.2 From 2128f7b3fbc95450da08be32963a90b2c7b3d10f Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 12 Mar 2018 18:28:10 +0100 Subject: [PATCH 49/66] Fixup stack.yaml --- stack.yaml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/stack.yaml b/stack.yaml index 74e27d2..585eb87 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,3 +2,7 @@ resolver: lts-10.0 packages: - . + +extra-deps: + - butcher-1.3.0.0 + - ghc-exactprint-0.5.6.0 -- 2.30.2 From c0ea20455cb0fa67721759a66e61b863954b49e3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Mar 2018 22:38:27 +0100 Subject: [PATCH 50/66] Fixup haddock typos --- src/Language/Haskell/Brittany/Internal/Config.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index fe1b317..666d1f4 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -234,8 +234,8 @@ readConfig path = do return $ Just fileConf else return $ Nothing --- | Returns a global brittany config file --- If there is no global config in a system, one will be created +-- | Looks for a user-global config file and return its path. +-- If there is no global config in a system, one will be created. userConfigPath :: IO System.IO.FilePath userConfigPath = do userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" @@ -250,7 +250,7 @@ userConfigPath = do writeDefaultConfig $ createConfPath pure createConfPath --- | Searhes for a local brittany config path starting from a given directory +-- | Searches for a local (per-project) brittany config starting from a given directory findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath dir = do let dirParts = FilePath.splitDirectories dir @@ -269,7 +269,7 @@ readConfigs cmdlineConfig configPaths = do return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs --- but also applies the user default configuration (with a lowest priority) +-- but also applies the user default configuration (with lowest priority) readConfigsWithUserConfig :: CConfig Option -- ^ Explicit options, take highest priority -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first -- 2.30.2 From 60775bbc6292b7860385b10af002280e283e8828 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Mar 2018 23:24:05 +0100 Subject: [PATCH 51/66] Switch stack.yaml resolver to lts-11.0 --- stack.yaml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/stack.yaml b/stack.yaml index 3362823..1939eac 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,4 @@ -resolver: lts-10.5 +resolver: lts-11.0 packages: - . - -extra-deps: - - butcher-1.3.0.0 -- 2.30.2 From 1330aeb6b4d3a3138bca89e1f3ee966677ee93db Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 13 Mar 2018 23:51:22 +0100 Subject: [PATCH 52/66] Fix ticked type operator losing tick (fixes #125) --- src-literatetests/15-regressions.blt | 3 +++ .../Brittany/Internal/LayouterBasics.hs | 22 +++++++++++++++++++ .../Brittany/Internal/Layouters/Type.hs | 7 +++--- 3 files changed, 29 insertions(+), 3 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 5e4f52c..0eec0be 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -524,3 +524,6 @@ spanKey p q = case minViewWithKey q of Just ((k, _), q') | p k -> let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') _ -> ([], q) + +#test issue 125 +a :: () ':- () diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 52c9e08..a013270 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -4,6 +4,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , lrdrNameToText , lrdrNameToTextAnn , lrdrNameToTextAnnTypeEqualityIsSpecial + , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick , askIndent , extractAllComments , filterAnns @@ -216,6 +217,27 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh else x +-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects +-- the annotations for a (parent) node for a tick to be added to the +-- literal. +-- Excessively long name to reflect on us having to work around such +-- excessively obscure special cases in the exactprint API. +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick + :: ( Data ast + , MonadMultiReader Config m + , MonadMultiReader (Map AnnKey Annotation) m + ) + => Located ast + -> Located RdrName + -> m Text +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do + hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote + x <- lrdrNameToTextAnn ast2 + let lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + return $ if hasQuote then Text.cons '\'' lit else lit + askIndent :: (MonadMultiReader Config m) => m Int askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index bd4d728..11e0eed 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -317,7 +317,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsAppsTy [L _ (HsAppPrefix typ1)] -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 - HsAppsTy [_lname@(L _ (HsAppInfix name))] -> do + HsAppsTy [lname@(L _ (HsAppInfix name))] -> do -- this redirection is somewhat hacky, but whatever. -- TODO: a general problem when doing deep inspections on -- the type (and this is not the only instance) @@ -326,7 +326,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- circumstances exactly important annotations (comments) -- would be assigned to such constructors. typeDoc1 <- -- docSharedWrapper layoutType $ (L l $ HsTyVar name) - lrdrNameToTextAnnTypeEqualityIsSpecial name + lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lname name docLit typeDoc1 HsAppsTy (L _ (HsAppPrefix typHead):typRestA) | Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t @@ -350,7 +350,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] where layoutAppType (L _ (HsAppPrefix t)) = layoutType t - layoutAppType (L _ (HsAppInfix t)) = docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecial t + layoutAppType lt@(L _ (HsAppInfix t)) = + docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lt t HsListTy typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt -- 2.30.2 From 8de56ba11d4e2442a648f28573254edd5f54e403 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 21 Mar 2018 01:02:44 +0100 Subject: [PATCH 53/66] 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] -- 2.30.2 From 487c32175ad72c5ebaef0ef6442cefa2e789e26b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 4 Mar 2018 23:55:11 +0100 Subject: [PATCH 54/66] Refactor Alt.hs and Add out-commented alternative --- .../Brittany/Internal/Transformations/Alt.hs | 48 +++++++++++++++---- 1 file changed, 38 insertions(+), 10 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index c83cfae..f7ed523 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -72,12 +72,11 @@ transformAlts ) => BriDocNumbered -> MultiRWSS.MultiRWS r w s BriDoc -transformAlts briDoc = +transformAlts = MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) - $ Memo.startEvalMemoT - $ fmap unwrapBriDocNumbered - $ rec - $ briDoc + . Memo.startEvalMemoT + . fmap unwrapBriDocNumbered + . rec where -- this function is exponential by nature and cannot be improved in any -- way i can think of, and i've tried. (stupid StableNames.) @@ -721,11 +720,12 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc $ sequence $ reverse $ lSpss - summed = worbled <&> \lSps@(lSp1:_) -> - VerticalSpacing (_vs_sameLine lSp1) - (spMakePar $ maxVs lSps) - False - return $ summed + sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1) + (spMakePar $ maxVs lSps) + False + sumF [] = error $ "should not happen. if my logic does not fail" + ++ "me, this follows from not (null ls)." + return $ sumF <$> worbled -- lSpss@(mVs:_) <- rec `mapM` ls -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only -- -- consider the first alternative for the @@ -758,6 +758,34 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacingParAlways i -> VerticalSpacingParAlways i VerticalSpacingParSome i -> VerticalSpacingParAlways i } + -- the version below is an alternative idea: fold the input + -- spacings into a single spacing. This was hoped to improve in + -- certain cases where non-bottom alternatives took up "too much + -- explored search space"; the downside is that it also cuts + -- the search-space short in other cases where it is not necessary, + -- leading to unnecessary new-lines. Disabled for now. A better + -- solution would require conditionally folding the search-space + -- only in appropriate locations (i.e. a new BriDoc node type + -- for this purpose, perhaps "BDFNonBottomSpacing1"). + -- else + -- [ Foldable.foldl1 + -- (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> + -- VerticalSpacing + -- (min x1 y1) + -- (case (x2, y2) of + -- (x, VerticalSpacingParNone) -> x + -- (VerticalSpacingParNone, x) -> x + -- (VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParAlways i, VerticalSpacingParSome j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome i, VerticalSpacingParAlways j) -> + -- VerticalSpacingParAlways $ min i j + -- (VerticalSpacingParSome x, VerticalSpacingParSome y) -> + -- VerticalSpacingParSome $ min x y) + -- False) + -- mVs + -- ] BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } -- 2.30.2 From 46de13256bde47c8fe48d5af2ed6f54ed85afee3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 4 Mar 2018 23:55:23 +0100 Subject: [PATCH 55/66] Add one more testcase --- src-literatetests/10-tests.blt | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index c57e33a..3410785 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -235,6 +235,17 @@ func -> ColInfo -> m () +#test forall context multiline with comments +{-# LANGUAGE RankNTypes #-} +addFlagStringParam + :: forall f out + . (Applicative f) + => String -- ^ short flag chars, i.e. "v" for -v + -> [String] -- ^ list of long names, i.e. ["verbose"] + -> String -- ^ param name + -> Flag String -- ^ properties + -> CmdParser f out String + #test language pragma issue {-# LANGUAGE ScopedTypeVariables #-} func :: forall (a :: *) b . a -> b -- 2.30.2 From 90a2f65ba7f4da736567035525f565f993dc5dce Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 22 Mar 2018 01:19:56 +0100 Subject: [PATCH 56/66] Align applications on for same function, plus minor fixup Arguments of two function applications will only be aligned if the same function is called in both cases. The column transform was altered slightly to fix #65 properly as well. fixes #65, #128 --- src-literatetests/15-regressions.blt | 20 +++++++++++++++++++ .../Haskell/Brittany/Internal/Backend.hs | 2 +- .../Brittany/Internal/Layouters/Expr.hs | 6 +++++- .../Internal/Transformations/Columns.hs | 11 +++++----- .../Haskell/Brittany/Internal/Types.hs | 2 +- 5 files changed, 33 insertions(+), 8 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 0eec0be..3a0b19d 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -501,6 +501,21 @@ func -> Proxy (str :: [*]) -> m (Tagged str String) +#test issue 65 +widgetsDyn = + [ [ vBox + [ padTop Max outputLinesWidget + , padRight Max wid1 <+> flowWidget -- alignment here is strange/buggy + , padBottom (Pad 5) help + ] + ] + | wid1 <- promptDyn + , (flowWidget, _) <- flowResultD + , outputLinesWidget <- outputLinesWidgetD + , help <- suggestionHelpBox + , parser <- cmdParserD + ] + #test issue 67 fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b fmapuv f xs = G.generate (G.length xs) (f . (xs G.!)) @@ -527,3 +542,8 @@ spanKey p q = case minViewWithKey q of #test issue 125 a :: () ':- () + +#test issue 128 +func = do + createDirectoryIfMissing True path + openFile fileName AppendMode diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index c9da940..a22d756 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -455,7 +455,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do (BDCols ColRecUpdate _) -> False (BDCols ColListComp _) -> False (BDCols ColList _) -> False - (BDCols ColApp _) -> True + (BDCols ColApp{} _) -> True (BDCols ColTuple _) -> False (BDCols ColTuples _) -> False (BDCols ColOpPrefix _) -> False diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 807aad8..4aca92f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -117,12 +117,16 @@ layoutExpr lexpr@(L _ expr) = do (L _ (HsApp l r)) -> gather (r:list) l x -> (x, list) let (headE, paramEs) = gather [exp2] exp1 + let colsOrSequence = case headE of + L _ (HsVar (L _ (Unqual occname))) -> + docCols (ColApp $ Text.pack $ occNameString occname) + _ -> docSeq headDoc <- docSharedWrapper layoutExpr headE paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs docAltFilter [ -- foo x y ( True - , docCols ColApp + , colsOrSequence $ appSep (docForceSingleline headDoc) : spacifyDocs (docForceSingleline <$> paramDocs) ) diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 41290a7..471ac67 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -23,11 +23,12 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDLit{} -> Nothing BDSeq list | any (\case BDSeq{} -> True BDEmpty{} -> True - _ -> False) list -> Just $ BDSeq $ - filter isNotEmpty list >>= \case - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_:_):rest) -> + _ -> False) list -> Just $ BDSeq $ list >>= \case + BDEmpty -> [] + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_:_):rest) + | all (\case BDSeparator -> True; _ -> False) rest -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) BDLines lines | any (\case BDLines{} -> True BDEmpty{} -> True diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index d321e21..1d26b73 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -174,7 +174,7 @@ data ColSig | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? | ColListComp | ColList - | ColApp + | ColApp Text | ColTuple | ColTuples | ColOpPrefix -- merge with ColList ? other stuff? -- 2.30.2 From d634d34ff1ee83c7925e21639c8c0e60f6faf4a3 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 15:41:41 +0100 Subject: [PATCH 57/66] Fix module-import-hiding-items layout --- src-literatetests/10-tests.blt | 19 +++- src-literatetests/tests-context-free.blt | 21 ++++- .../Haskell/Brittany/Internal/Config/Types.hs | 2 + .../Brittany/Internal/Layouters/Import.hs | 93 ++++++++++--------- .../Internal/Transformations/Floating.hs | 4 +- 5 files changed, 89 insertions(+), 50 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 3410785..4919f3f 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -734,19 +734,22 @@ import Test hiding ( ) import Test as T hiding ( ) -#test long-module-name +#test long-module-name-simple import TestJustShortEnoughModuleNameLikeThisOne ( ) import TestJustAbitToLongModuleNameLikeThisOneIs ( ) +#test long-module-name-as import TestJustShortEnoughModuleNameLikeThisOn as T import TestJustAbitToLongModuleNameLikeThisOneI as T +#test long-module-name-hiding import TestJustShortEnoughModuleNameLike hiding ( ) import TestJustAbitToLongModuleNameLikeTh hiding ( ) +#test long-module-name-simple-items import MoreThanSufficientlyLongModuleNameWithSome ( items , that @@ -758,6 +761,20 @@ import MoreThanSufficientlyLongModuleNameWithSome , layout ) +#test long-module-name-hiding-items +import TestJustShortEnoughModuleNameLike hiding ( abc + , def + , ghci + , jklm + ) +import TestJustAbitToLongModuleNameLikeTh + hiding ( abc + , def + , ghci + , jklm + ) + +#test long-module-name-other 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 8ab4d7e..2d1c421 100644 --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -736,16 +736,27 @@ import Test (T, T2(), T3(..), T4(T4), T5(T5, t5), T6((<|>)), (+)) import Test hiding () import Test as T hiding () -#test long-module-name +#test long-module-name-simple 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 long-module-name-as +import TestJustShortEnoughModuleNameLikeThisOn as T +import TestJustAbitToLongModuleNameLikeThisOneI as T + +#test long-module-name-hiding +import TestJustShortEnoughModuleNameLike hiding () +import TestJustAbitToLongModuleNameLikeTh hiding () + +#test long-module-name-simple-items +import MoreThanSufficientlyLongModuleNameWithSome + (items, that, will, not, fit, inA, compact, layout) + +#test long-module-name-hiding-items +import TestJustShortEnoughModuleNameLike hiding (abc, def, ghci, jklm) + #test import-with-comments -- Test import Data.List (nub) -- Test diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 03f7d9a..dc0300f 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -56,9 +56,11 @@ data CLayoutConfig f = LayoutConfig , _lconfig_importColumn :: f (Last Int) -- ^ for import statement layouting, column at which to align the -- elements to be imported from a module. + -- It is expected that importAsColumn >= importCol. , _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). + -- It is expected that importAsColumn >= importCol. , _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 a98f642..04925bd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -64,7 +64,7 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of qLength = max minQLength qLengthReal -- Cost in columns of importColumn asCost = length "as " - bindingCost = if hiding then length "hiding ( " else length "( " + hidingParenCost = if hiding then length "hiding ( " else length "( " nameCost = Text.length modNameT + qLength importQualifiers = docSeq [ appSep $ docLit $ Text.pack "import" @@ -77,8 +77,11 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of if compact then id else docEnsureIndent (BrIndentSpecial qLength) modNameD = indentName $ appSep $ docLit modNameT - hidDoc = - if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty + hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 + hidDocColDiff = importCol - 2 - hidDocCol + hidDoc = if hiding + then appSep $ docLit $ Text.pack "hiding" + else docEmpty importHead = docSeq [importQualifiers, modNameD] bindingsD = case mllies of Nothing -> docEmpty @@ -88,40 +91,43 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of then docSeq [hidDoc, layoutLLIEs True 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] -> docAltFilter - [ ( not hasComments - , docSeq - [ hidDoc - , docParenLSep - , docForceSingleline $ ieD - , docSeparator - , docParenR - ] - ) - , ( otherwise - , docPar - (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) - docParenR - ) - ] - -- ..[hiding].( b - -- , b' - -- ) - (ieD:ieDs') -> - docPar (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) - $ docLines - $ ieDs' - ++ [docParenR] - bindingLine = - docEnsureIndent (BrIndentSpecial (importCol - bindingCost)) bindingsD + docWrapNodeRest llies + $ docEnsureIndent (BrIndentSpecial hidDocCol) + $ case ieDs of + -- ..[hiding].( ) + [] -> if hasComments + then docPar + (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) $ docParenR) + else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] + -- ..[hiding].( b ) + [ieD] -> docAltFilter + [ ( not hasComments + , docSeq + [ hidDoc + , docParenLSep + , docForceSingleline $ ieD + , docSeparator + , docParenR + ] + ) + , ( otherwise + , docPar + (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) + (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) + ) + ] + -- ..[hiding].( b + -- , b' + -- ) + (ieD:ieDs') -> + docPar + (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) + ( docEnsureIndent (BrIndentSpecial hidDocColDiff) + $ docLines + $ ieDs' + ++ [docParenR] + ) makeAsDoc asT = docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] if compact @@ -134,14 +140,17 @@ layoutImport limportD@(L _ importD) = docWrapNode limportD $ case importD of ] else case masT of - Just n | enoughRoom -> docLines [docSeq [importHead, asDoc], bindingLine] - | otherwise -> docLines [importHead, asDoc, bindingLine] + Just n -> if enoughRoom + then docLines + [ docSeq [importHead, asDoc], bindingsD] + else docLines [importHead, asDoc, bindingsD] where enoughRoom = nameCost < importAsCol - asCost asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) $ makeAsDoc n - Nothing | enoughRoom -> docSeq [importHead, bindingLine] - | otherwise -> docLines [importHead, bindingLine] - where enoughRoom = nameCost < importCol - bindingCost + Nothing -> if enoughRoom + then docSeq [importHead, bindingsD] + else docLines [importHead, bindingsD] + where enoughRoom = nameCost < importCol - hidingParenCost _ -> docEmpty diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index e36a545..08a919f 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -101,9 +101,9 @@ transformSimplifyFloating = stepBO .> stepFull Just $ BDDebug s (BDIndentLevelPop x) _ -> Nothing descendAddB = transformDownMay $ \case - -- AddIndent floats into Lines. BDAddBaseY BrIndentNone x -> Just x + -- AddIndent floats into Lines. BDAddBaseY indent (BDLines lines) -> Just $ BDLines $ BDAddBaseY indent <$> lines -- AddIndent floats into last column @@ -145,9 +145,9 @@ transformSimplifyFloating = stepBO .> stepFull x -> x stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ Uniplate.rewrite $ \case - -- AddIndent floats into Lines. BDAddBaseY BrIndentNone x -> Just $ x + -- AddIndent floats into Lines. BDAddBaseY indent (BDLines lines) -> Just $ BDLines $ BDAddBaseY indent <$> lines -- AddIndent floats into last column -- 2.30.2 From a003b932a97b52d6e013786cc3e3e07884b7d1af Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 16:55:09 +0100 Subject: [PATCH 58/66] Fix comments in tuples being dropped (fixes #37) --- src-literatetests/15-regressions.blt | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Expr.hs | 8 ++++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 3a0b19d..91038fc 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -373,6 +373,16 @@ runBrittany tabSize text = do } parsePrintModule config text +#test issue 37 + +foo = + ( a + , -- comment1 + b + -- comment2 + , c + ) + #test issue 38 {-# LANGUAGE TypeApplications #-} diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 4aca92f..d144b80 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -346,8 +346,12 @@ layoutExpr lexpr@(L _ expr) = do rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple args boxity -> do - let argExprs = fmap (\case (L _ (Present e)) -> Just e; (L _ (Missing PlaceHolder)) -> Nothing) args - argDocs <- docSharedWrapper (maybe docEmpty layoutExpr) `mapM` argExprs + let argExprs = args <&> \arg -> case arg of + (L _ (Present e)) -> (arg, Just e); + (L _ (Missing PlaceHolder)) -> (arg, Nothing) + argDocs <- forM argExprs + $ docSharedWrapper + $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM hasComments <- hasAnyCommentsBelow lexpr let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") -- 2.30.2 From 3847325fd5a9413037c73f919a92772cbfe2f57c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 17:02:58 +0100 Subject: [PATCH 59/66] Omit single-line layout for OpApp with comments (fixes #111) --- src-literatetests/15-regressions.blt | 12 +++++++ .../Brittany/Internal/Layouters/Expr.hs | 31 +++++++++++-------- 2 files changed, 30 insertions(+), 13 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 91038fc..2127eaf 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -538,6 +538,18 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] {-# LANGUAGE TemplateHaskell #-} deriveFromJSON (unPrefix "assignPost") ''AssignmentPost +#test issue 111 + +alternatives :: Parser (Maybe Text) +alternatives = + alternativeOne -- first try this one + <|> alterantiveTwo -- then this one + <|> alternativeThree -- then this one + where + alternativeOne = purer "one" + alternativeTwo = purer "two" + alterantiveThree = purer "three" + #test issue 116 {-# LANGUAGE BangPatterns #-} func = do diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index d144b80..98d3d10 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -237,24 +237,27 @@ layoutExpr lexpr@(L _ expr) = do ] opLastDoc <- docSharedWrapper layoutExpr expOp expLastDoc <- docSharedWrapper layoutExpr expRight + hasComments <- hasAnyCommentsBelow lexpr let allowPar = case (expOp, expRight) of (L _ (HsVar (L _ (Unqual occname))), _) | occNameString occname == "$" -> True (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True - docAlt - [ docSeq - [ appSep $ docForceSingleline leftOperandDoc + docAltFilter + [ ( not hasComments , docSeq - $ (appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] - ) - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] + [ appSep $ docForceSingleline leftOperandDoc + , docSeq + $ (appListDocs <&> \(od, ed) -> docSeq + [ appSep $ docForceSingleline od + , appSep $ docForceSingleline ed + ] + ) + , appSep $ docForceSingleline opLastDoc + , (if allowPar then docForceParSpacing else docForceSingleline) + expLastDoc + ] + ) -- this case rather leads to some unfortunate layouting than to anything -- useful; disabling for now. (it interfers with cols stuff.) -- , docSetBaseY @@ -264,12 +267,14 @@ layoutExpr lexpr@(L _ expr) = do -- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] -- ) - , docPar + , (otherwise + , docPar leftOperandDoc ( docLines $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] ) + ) ] OpApp expLeft expOp _ expRight -> do expDocLeft <- docSharedWrapper layoutExpr expLeft -- 2.30.2 From bdd3b155f3e5be2e85a2edad381712ed37a4de4e Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 17:11:39 +0100 Subject: [PATCH 60/66] Fix HsPar comment placement bug (see #111) --- src-literatetests/15-regressions.blt | 10 ++++++++++ .../Haskell/Brittany/Internal/Layouters/Expr.hs | 2 +- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 2127eaf..0498b5d 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -569,3 +569,13 @@ a :: () ':- () func = do createDirectoryIfMissing True path openFile fileName AppendMode + +#test hspar-comments + +alternatives :: Parser (Maybe Text) +alternatives = -- a + ( -- b + alternativeOne -- c + <|> alterantiveTwo -- d + <|> alternativeThree -- e + ) -- f diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 98d3d10..f8535e7 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -327,7 +327,7 @@ layoutExpr lexpr@(L _ expr) = do , opDoc ] HsPar innerExp -> do - innerExpDoc <- docSharedWrapper layoutExpr innerExp + innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt [ docSeq [ docLit $ Text.pack "(" -- 2.30.2 From 08451427279f15751bd762135117591d7e6cd6dc Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 17:34:36 +0100 Subject: [PATCH 61/66] Fix let-in comment placement bug (fixes #110) --- src-literatetests/15-regressions.blt | 10 +++++++++- .../Haskell/Brittany/Internal/Layouters/Expr.hs | 16 +++++++++------- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 0498b5d..d84ec79 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -538,8 +538,16 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] {-# LANGUAGE TemplateHaskell #-} deriveFromJSON (unPrefix "assignPost") ''AssignmentPost -#test issue 111 +#test issue 110 +main = -- a + let --b + x = 1 -- x + y = 2 -- y + in do + print x + print y +#test issue 111 alternatives :: Parser (Maybe Text) alternatives = alternativeOne -- first try this one diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index f8535e7..a5402ea 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -543,7 +543,9 @@ layoutExpr lexpr@(L _ expr) = do (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) HsLet binds exp1 -> do expDoc1 <- docSharedWrapper layoutExpr exp1 - mBindDocs <- layoutLocalBinds binds + -- We jump through some ugly hoops here to ensure proper sharing. + mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) + =<< layoutLocalBinds binds let ifIndentLeftElse :: a -> a -> a ifIndentLeftElse x y = @@ -560,7 +562,7 @@ layoutExpr lexpr@(L _ expr) = do Just [bindDoc] -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" - , appSep $ docForceSingleline $ return bindDoc + , appSep $ docForceSingleline $ bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline $ expDoc1 ] @@ -569,12 +571,12 @@ layoutExpr lexpr@(L _ expr) = do [ docSeq [ appSep $ docLit $ Text.pack "let" , ifIndentLeftElse docForceSingleline docSetBaseAndIndent - $ return bindDoc + $ bindDoc ] , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ return bindDoc) + (docSetBaseAndIndent $ bindDoc) ] , docAlt [ docSeq @@ -607,7 +609,7 @@ layoutExpr lexpr@(L _ expr) = do [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + (docSetBaseAndIndent $ docLines $ bindDocs) , docSeq [ docLit $ Text.pack "in " , docAddBaseY BrIndentRegular $ expDoc1 @@ -618,7 +620,7 @@ layoutExpr lexpr@(L _ expr) = do , docLines [ docSeq [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs + , docSetBaseAndIndent $ docLines $ bindDocs ] , docSeq [ appSep $ docLit $ Text.pack "in " @@ -631,7 +633,7 @@ layoutExpr lexpr@(L _ expr) = do [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + (docSetBaseAndIndent $ docLines $ bindDocs) , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "in") -- 2.30.2 From 3b20d0275e99f311c50b11b97918c0c8cf867d09 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 23 Mar 2018 19:32:30 +0100 Subject: [PATCH 62/66] Bump to 0.10.0.0, Add Changelog --- ChangeLog.md | 23 +++++++++++++++++++++++ brittany.cabal | 2 +- 2 files changed, 24 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 1b23e1e..253226b 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,28 @@ # Revision history for brittany +## 0.10.0.0 -- March 2018 + +* Implement module/exports/imports layouting (thanks to sniperrifle2004) +* Expose config paths/parsing functions (thanks to Alexey Raga) +* Bugfixes: + - Fix layouting of `NOINLINE` pragma + - Fix ticked type operator (e.g. `':-`) losing tick (#125) + - Fix alignment issue with cases involving operators (#65) + - Fix comments in tuples being dropped (#37) + - Fix comment placements with let-in (#110) +* Layouting changes: + - Align arguments only if it is the same function being called (#128) + - Do not use single-line layout when infix operator expression contains + comments (#111) +* New layouting config items: + - `lconfig_importColumn`/`--import-col`: column for import items + - `lconfig_importAsColumn`/`--import-as-col`: column for the "as" name of + a module + - `lconfig_reformatModulePreamble`: controls module/export/import layouting + (default True) + - `lconfig_allowSingleLineExportList`: permit one-line module header, e.g. + `module Main (main)` (default False) + ## 0.9.0.1 -- February 2018 * Support `TupleSections` (thanks to Matthew Piziak) diff --git a/brittany.cabal b/brittany.cabal index f081f77..d87cbc8 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.9.0.1 +version: 0.10.0.0 synopsis: Haskell source code formatter description: { See . -- 2.30.2 From 8cabd0847737d122a77b7fd30b28498be806cf48 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 25 Mar 2018 16:06:36 +0200 Subject: [PATCH 63/66] Update README.md and commandline description --- README.md | 12 ++++++------ src-brittany/Main.hs | 5 +++-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/README.md b/README.md index 42e7fa5..4987ffc 100644 --- a/README.md +++ b/README.md @@ -8,13 +8,12 @@ haskell source code formatter This project's goals roughly are to: - Always retain the semantics of the source being transformed; -- Be idempotent (this also directly ensures that only valid haskell is - produced); +- Be idempotent; - Support the full GHC-haskell syntax including syntactic extensions (but excluding `-XCPP` which is too hard); - Retain newlines and comments unmodified; - Be clever about using the available horizontal space while not overflowing - it if it cannot be avoided; + the column maximum if it cannot be avoided; - Be clever about aligning things horizontally (this can be turned off completely however); - Have linear complexity in the size of the input. @@ -27,8 +26,9 @@ size of the input (although the constant factor is not small). See But brittany is not finished yet, and there are some open issues that yet require fixing: -- **only type-signatures and function/value bindings** are processed; - other module elements (data-decls, classes, instances, imports/exports etc.) +- **only the module header (imports/exports), type-signatures and + function/value bindings** are processed; + other module elements (data-decls, classes, instances, etc.) are not transformed in any way; this extends to e.g. **bindings inside class instance definitions** - they **won't be touched** (yet). - By using `ghc-exactprint` as the parser, brittany supports full GHC @@ -47,7 +47,7 @@ require fixing: You can [paste haskell code over here](https://hexagoxel.de/brittany/) to test how it gets formatted by brittany. (Rg. privacy: the server does -log the size of the input, but _not_ the full requests.) +log the size of the input, but _not_ the full input/output of requests.) # Other usage notes diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 057ad24..73eccd0 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -63,7 +63,8 @@ helpDoc = PP.vcat $ List.intersperse (PP.text "") [ parDocW [ "Reformats one or more haskell modules." - , "Currently affects only type signatures and function bindings;" + , "Currently affects only the module head (imports/exports), type" + , "signatures and function bindings;" , "everything else is left unmodified." , "Based on ghc-exactprint, thus (theoretically) supporting all" , "that ghc does." @@ -71,7 +72,7 @@ helpDoc = PP.vcat $ List.intersperse , parDoc $ "Example invocations:" , PP.hang (PP.text "") 2 $ PP.vcat [ PP.text "brittany" - , PP.hang (PP.text " ") 2 $ PP.text "read from stdin, output to stdout" + , PP.nest 2 $ PP.text "read from stdin, output to stdout" ] , PP.hang (PP.text "") 2 $ PP.vcat [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" -- 2.30.2 From b142837f1a6c97303d14f3c0600536a594c2945b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 25 Mar 2018 16:58:17 +0200 Subject: [PATCH 64/66] Remove old bug notice from README.md [ci skip] --- README.md | 3 --- 1 file changed, 3 deletions(-) diff --git a/README.md b/README.md index 4987ffc..a3a106c 100644 --- a/README.md +++ b/README.md @@ -39,9 +39,6 @@ require fixing: be detected and the user will get an error); there are other cases where comments are moved slightly; there are also cases where comments result in wonky newline insertion (although this should be a purely aesthetic issue.) -- ~~There is an **open performance issue on large inputs** (due to an - accidentally quadratic sub-algorithm); noticable for inputs with >1k loc.~~ - (fixed in `0.8.0.3`) ## Try without Installing -- 2.30.2 From f8c93e06f4ba44b9b15ef5c89021c182aceb4879 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 25 Mar 2018 17:47:40 +0200 Subject: [PATCH 65/66] Add showcase for module layouting [ci skip] --- doc/showcases/Module.md | 89 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) create mode 100644 doc/showcases/Module.md diff --git a/doc/showcases/Module.md b/doc/showcases/Module.md new file mode 100644 index 0000000..ebde6a9 --- /dev/null +++ b/doc/showcases/Module.md @@ -0,0 +1,89 @@ + +Last updated for brittany version `0.10.0.0`. + +# Example layouting of the module header (exports/imports) + +## On default settings + +~~~~.hs +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +module Main + ( main + ) +where + +import qualified Paths_brittany +import Language.Haskell.Brittany + +import Network.Wai +import Network.HTTP.Types +import qualified Network.Wai.Handler.Warp as Warp + +import Data.String + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +import Control.Monad.Loops + +import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text + +import Data.Version ( showVersion ) + +import qualified System.Mem +import qualified Control.Concurrent +import Control.Concurrent.Async ( async + , waitEitherCatch + , waitEitherCatchCancel + ) +import qualified Data.Aeson as Aeson +import Data.Time.Clock +import Data.Time.Format +import Text.Parsec hiding ( (<|>) ) +~~~~ + +For long module names, things will be moved one line below and aligned as +before. Long identifiers may overflow our 80 column limit: + +~~~~.hs +import qualified Example.Very.Long.Module.Name.Internal + as T +import Example.Very.Long.Module.Name.Internal + ( a + , b + , c + ) +import Example.Very.Long.Module.Name.Internal + ( someVeryLongAndDescriptiveFunctionName + ) +~~~~ + +## Alternative setting + +If you have many long module names or use large identifiers, you might +be interested in these alternative settings: + +~~~~ +conf_layout: + lconfig_importColumn: 21 + lconfig_importAsColumn: 70 +~~~~ + +Now, our previous examples becomes: + +~~~~.hs +import qualified Example.Very.Long.Module.Name.Strict.Internal as T +import Example.Very.Long.Module.Name.Strict.Internal + ( a + , b + , c + ) +import Example.Very.Long.Module.Name.Strict.Internal + ( someVeryLongAndDescriptiveFunctionName + ) +~~~~ -- 2.30.2 From e9f764e0e7e8e76a93f2c3a4623daee7b0533c0c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 25 Mar 2018 18:06:37 +0200 Subject: [PATCH 66/66] Add showcase for IndentPolicyLeft --- doc/showcases/Module.md | 53 +++++++++++++++++++++++++++++++---------- 1 file changed, 41 insertions(+), 12 deletions(-) diff --git a/doc/showcases/Module.md b/doc/showcases/Module.md index ebde6a9..31a062f 100644 --- a/doc/showcases/Module.md +++ b/doc/showcases/Module.md @@ -5,6 +5,16 @@ Last updated for brittany version `0.10.0.0`. ## On default settings +default settings are: + +~~~~ +conf_layout: + lconfig_indentPolicy: IndentPolicyFree + lconfig_importColumn: 50 + lconfig_importAsColumn: 50 +~~~~ + + ~~~~.hs {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -54,16 +64,16 @@ before. Long identifiers may overflow our 80 column limit: import qualified Example.Very.Long.Module.Name.Internal as T import Example.Very.Long.Module.Name.Internal - ( a - , b - , c + ( someFunc + , MyDataType + , globalConstant ) import Example.Very.Long.Module.Name.Internal ( someVeryLongAndDescriptiveFunctionName ) ~~~~ -## Alternative setting +## Alternative setting - long identifiers If you have many long module names or use large identifiers, you might be interested in these alternative settings: @@ -77,13 +87,32 @@ conf_layout: Now, our previous examples becomes: ~~~~.hs -import qualified Example.Very.Long.Module.Name.Strict.Internal as T -import Example.Very.Long.Module.Name.Strict.Internal - ( a - , b - , c - ) -import Example.Very.Long.Module.Name.Strict.Internal - ( someVeryLongAndDescriptiveFunctionName +import qualified Example.Very.Long.Module.Name.Internal as T +import Example.Very.Long.Module.Name.Internal + ( someFunc + , MyDataType + , globalConstant ) +import Example.Very.Long.Module.Name.Internal + ( someVeryLongAndDescriptiveFunctionName ) +~~~~ + +## Alternative setting - "IndentPolicyLeft" + +The global switch "indent policy" that has the rough intention of removing any +cases of "hanging indentation" also affects module layouting: + +~~~~ +conf_layout: + lconfig_indentPolicy: IndentPolicyLeft +~~~~ + +Now, our previous examples becomes: + +~~~~.hs +import qualified Example.Very.Long.Module.Name.Internal as T +import Example.Very.Long.Module.Name.Internal + (someFunc, MyDataType, globalConstant) +import Example.Very.Long.Module.Name.Internal + (someVeryLongAndDescriptiveFunctionName) ~~~~ -- 2.30.2