diff --git a/ChangeLog.md b/ChangeLog.md --- 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/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,13 +8,12 @@ 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 @@ 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 @@ -39,15 +39,12 @@ 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 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 @@ -104,7 +101,7 @@ 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. @@ -159,8 +156,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 diff --git a/brittany.cabal b/brittany.cabal --- 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 . @@ -67,6 +67,9 @@ 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 @@ -108,6 +111,7 @@ , 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 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -63,7 +63,8 @@ (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 @@ , 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" @@ -158,7 +159,7 @@ 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 +171,14 @@ 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 +322,3 @@ ] 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-literatetests/10-tests.blt b/src-literatetests/10-tests.blt --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -235,6 +235,17 @@ -> 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 @@ -287,6 +298,10 @@ {-# 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 @@ -561,3 +576,314 @@ ] ++ [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 + -- main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + -- Test 6 + ) +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-things-comment +-- comment1 + +module Main + ( Test(Test, a, b) + , foo -- comment2 + ) -- comment3 +where + +#test export-with-empty-thing +module Main (Test()) where + +#test empty-with-comment +-- Intentionally left empty + +############################################################################### +############################################################################### +############################################################################### +#group module.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 as L + +#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 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 ( ) + +#test one-element +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((<|>)) + , (+) + ) + +#test hiding +import Test hiding ( ) +import Test as T + hiding ( ) + +#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 + , will + , not + , fit + , inA + , compact + , 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 + ( ) + +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 +{- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} + +-- 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 import-with-comments-5 +import Test ( -- comment + ) + +#test long-bindings +import Test ( longbindingNameThatoverflowsColum + ) +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 prefer-dense-empty-list +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + ( ) + +#test preamble full-preamble +{-# LANGUAGE BangPatterns #-} + +{- + - Test module + -} +module Test + ( test1 + -- ^ test + , test2 + -- | test + , test3 + , test4 + , test5 + , test6 + , test7 + , test8 + , test9 + , test10 + -- Test 10 + ) +where + +-- Test +import Data.List ( nub ) -- Test +{- Test -} +import qualified Data.List as L + ( foldl' ) {- Test -} + +-- Test +import Test ( test ) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -367,13 +367,22 @@ 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 +#test issue 37 + +foo = + ( a + , -- comment1 + b + -- comment2 + , c + ) + #test issue 38 {-# LANGUAGE TypeApplications #-} @@ -502,6 +511,21 @@ -> 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.!)) @@ -514,6 +538,26 @@ {-# LANGUAGE TemplateHaskell #-} deriveFromJSON (unPrefix "assignPost") ''AssignmentPost +#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 + <|> 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 @@ -525,3 +569,21 @@ Just ((k, _), q') | p k -> let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') _ -> ([], q) + +#test issue 125 +a :: () ':- () + +#test issue 128 +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-literatetests/Main.hs b/src-literatetests/Main.hs --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -169,11 +169,14 @@ , _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) , _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-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt --- a/src-literatetests/tests-context-free.blt +++ b/src-literatetests/tests-context-free.blt @@ -598,10 +598,274 @@ ] ++ [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 + -- main + , test1 + , test2 + -- Test 3 + , test3 + , test4 + -- Test 5 + , test5 + -- Test 6 + ) +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 as L + +#test simple-source +import {-# SOURCE #-} Data.List () + +#test simple-safe-qualified +import safe qualified Data.List hiding (nub) + +#test simple-safe-qualified-source +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 () + +#test one-element +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((<|>)), (+)) + +#test hiding +import Test hiding () +import Test as T hiding () + +#test long-module-name-simple +import TestJustShortEnoughModuleNameLikeThisOne () +import TestJustAbitToLongModuleNameLikeThisOneIs () +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 +{- 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) + +#test import-with-comments-5 +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 + -- ! + ) + ) + +#test prefer-dense-empty-list +import VeryLongModuleNameThatCouldEvenCauseAnEmptyBindingListToExpandIntoMultipleLine + () + +#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) + +############################################################################### +############################################################################### +############################################################################### #group regression ############################################################################### ############################################################################### @@ -1133,4 +1397,3 @@ ## ] ## where ## role = stringProperty "WM_WINDOW_ROLE" - diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -51,11 +51,14 @@ , _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) , _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.hs b/src/Language/Haskell/Brittany.hs --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -4,6 +4,10 @@ ( parsePrintModule , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig , Config , CConfig(..) , CDebugConfig(..) diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -16,7 +16,7 @@ #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 @@ -33,6 +33,7 @@ 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 @@ -132,7 +133,7 @@ -- can occur. pPrintModule :: Config - -> ExactPrint.Types.Anns + -> ExactPrint.Anns -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf anns parsedModule = @@ -160,7 +161,7 @@ in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do - -- + -- -- debugStrings `forM_` \s -> -- trace s $ return () @@ -168,7 +169,7 @@ -- if it does not. pPrintModuleAndCheck :: Config - -> ExactPrint.Types.Anns + -> ExactPrint.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf anns parsedModule = do @@ -248,33 +249,11 @@ -- 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 + Map.findWithDefault Map.empty (ExactPrint.mkAnnKey decl) annMap traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations @@ -287,26 +266,26 @@ 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 () @@ -341,6 +320,76 @@ 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.KeywordId, ExactPrint.DeltaPos)] +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) + -- 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 + config <- mAsk + let shouldReformatPreamble = + config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack + + 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' + + 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 TypeSig names _ -> @@ -391,7 +440,7 @@ -- 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 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -250,6 +250,23 @@ -- 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 @@ 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 @@ BDAnnotationPrior _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd + BDMoveToKWDP _ _ bd -> rec bd BDLines (_:_:_) -> True BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" @@ -436,7 +455,7 @@ (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/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -9,6 +9,10 @@ , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled , readConfig + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig , writeDefaultConfig , showConfigYaml ) @@ -22,8 +26,10 @@ 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 Data.Coerce ( Coercible, coerce ) - +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath staticDefaultConfig :: Config staticDefaultConfig = Config @@ -58,12 +65,15 @@ , _lconfig_indentAmount = coerce (2 :: Int) , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (60 :: Int) + , _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) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -104,6 +114,7 @@ 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") @@ -153,11 +164,14 @@ , _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 , _lconfig_alignmentBreakOnMultiline = mempty , _lconfig_hangingTypeSignature = mempty + , _lconfig_reformatModulePreamble = mempty + , _lconfig_allowSingleLineExportList = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors @@ -189,10 +203,10 @@ -- <*> 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" @@ -226,6 +240,50 @@ Right x -> return x return $ Just fileConf else return $ Nothing + +-- | 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" + 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 + +-- | 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 + -- 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 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 = diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -53,7 +53,14 @@ , _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. + -- 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) @@ -84,6 +91,21 @@ -- -> 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/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -4,6 +4,7 @@ , lrdrNameToText , lrdrNameToTextAnn , lrdrNameToTextAnnTypeEqualityIsSpecial + , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick , askIndent , extractAllComments , filterAnns @@ -16,6 +17,7 @@ , docSeq , docPar , docNodeAnnKW + , docNodeMoveToKWDP , docWrapNode , docWrapNodePrior , docWrapNodeRest @@ -29,6 +31,7 @@ , docAnnotationPrior , docAnnotationKW , docAnnotationRest + , docMoveToKWDP , docNonBottomSpacing , docSetParSpacing , docForceParSpacing @@ -42,6 +45,7 @@ , appSep , docCommaSep , docParenLSep + , docParenR , docTick , spacifyDocs , briDocMToPPM @@ -216,6 +220,27 @@ 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 @@ -440,6 +465,13 @@ -> 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 @@ -465,6 +497,9 @@ docParenLSep :: ToBriDocM BriDocNumbered docParenLSep = appSep $ docLit $ Text.pack "(" +docParenR :: ToBriDocM BriDocNumbered +docParenR = docLit $ Text.pack ")" + docTick :: ToBriDocM BriDocNumbered docTick = docLit $ Text.pack "'" @@ -476,6 +511,15 @@ -> ToBriDocM BriDocNumbered 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) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -94,7 +94,8 @@ 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 ++ "] " diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -117,12 +117,16 @@ (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) ) @@ -233,24 +237,27 @@ ] 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 @@ -260,12 +267,14 @@ -- - $ (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 @@ -318,7 +327,7 @@ , opDoc ] HsPar innerExp -> do - innerExpDoc <- docSharedWrapper layoutExpr innerExp + innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp docAlt [ docSeq [ docLit $ Text.pack "(" @@ -342,8 +351,12 @@ 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 ")") @@ -530,22 +543,26 @@ (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 = 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" - , appSep $ docForceSingleline $ return bindDoc + , appSep $ docForceSingleline $ bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline $ expDoc1 ] @@ -554,12 +571,12 @@ [ 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 @@ -592,7 +609,7 @@ [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + (docSetBaseAndIndent $ docLines $ bindDocs) , docSeq [ docLit $ Text.pack "in " , docAddBaseY BrIndentRegular $ expDoc1 @@ -603,7 +620,7 @@ , docLines [ docSeq [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ return <$> bindDocs + , docSetBaseAndIndent $ docLines $ bindDocs ] , docSeq [ appSep $ docLit $ Text.pack "in " @@ -616,7 +633,7 @@ [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ return <$> bindDocs) + (docSetBaseAndIndent $ docLines $ bindDocs) , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "in") @@ -733,6 +750,8 @@ , 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 +871,7 @@ 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 +889,10 @@ , 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 +903,7 @@ , case rF1e of Just x -> docWrapNodeRest rF1f $ docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline $ x + , docForceSingleline x ] Nothing -> docEmpty ] @@ -901,36 +923,54 @@ 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 */ diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -0,0 +1,145 @@ +module Language.Haskell.Brittany.Internal.Layouters.IE + ( layoutIE + , layoutLLIEs + , layoutAnnAndSepLLIEs + ) +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(..) + , Located + ) +import HsSyn +import Name +import HsImpExp +import FieldLabel +import qualified FastString +import BasicTypes + +import Language.Haskell.Brittany.Internal.Utils + + + +#if MIN_VERSION_ghc(8,2,0) +prepareName :: LIEWrappedName name -> Located name +prepareName = ieLWrappedName +#else +prepareName :: Located name -> Located name +prepareName = id +#endif + +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 _ -> do + hasComments <- hasAnyCommentsBelow lie + docAltFilter + [ ( not hasComments + , docSeq + $ [ien, docLit $ Text.pack "("] + ++ intersperse docCommaSep (map nameDoc ns) + ++ [docParenR] + ) + , (otherwise + , docAddBaseY BrIndentRegular + $ docPar ien (layoutItems (splitFirstLast ns)) + ) + ] + where + nameDoc = (docLit =<<) . lrdrNameToTextAnn . prepareName + 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 + , docLit . Text.pack . moduleNameString $ unLoc n + ] + _ -> docEmpty + where ien = docLit =<< lrdrNameToTextAnn (ieName <$> lie) + +-- Helper function to deal with Located lists of LIEs. +-- In particular this will also associate documentation +-- from the located list that actually belongs to the last IE. +-- 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 +layoutAnnAndSepLLIEs + :: Located [LIE RdrName] -> ToBriDocM [ToBriDocM BriDocNumbered] +layoutAnnAndSepLLIEs llies@(L _ lies) = do + let makeIENode ie = docSeq [docCommaSep, ie] + let ieDocs = layoutIE <$> lies + ieCommaDocs <- + docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of + FirstLastEmpty -> [] + FirstLastSingleton ie -> [ie] + FirstLast ie1 ieMs ieN -> + [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: +-- (item, item, ..., item) +-- ( item +-- , item +-- ... +-- , item +-- ) +-- If the llies contains comments the list will +-- always expand over multiple lines, even when empty: +-- () -- no comments +-- ( -- a comment +-- ) +layoutLLIEs :: Bool -> Located [LIE RdrName] -> ToBriDocM BriDocNumbered +layoutLLIEs enableSingleline llies = do + 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 && enableSingleline + , 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 new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs @@ -0,0 +1,156 @@ +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 + , GenLocated(L) + , moduleNameString + , Located + ) +import HsSyn +import Name +import FieldLabel +import qualified FastString +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 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 + modNameT = Text.pack $ moduleNameString modName + pkgNameT = Text.pack . prepPkg . sl_st <$> pkg + 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 = 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 + -- Cost in columns of importColumn + asCost = length "as " + hidingParenCost = 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 + , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty + , if q then appSep $ docLit $ Text.pack "qualified" else docEmpty + , maybe docEmpty (appSep . docLit) pkgNameT + ] + indentName = + if compact then id else docEnsureIndent (BrIndentSpecial qLength) + modNameD = + indentName $ appSep $ docLit modNameT + 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 + Just (_, llies) -> do + hasComments <- hasAnyCommentsBelow llies + if compact + then docSeq [hidDoc, layoutLLIEs True llies] + else do + ieDs <- layoutAnnAndSepLLIEs llies + 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 + then + let asDoc = maybe docEmpty makeAsDoc masT + in docAlt + [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] + , docAddBaseY BrIndentRegular $ + docPar (docSeq [importHead, asDoc]) bindingsD + ] + else + case masT of + 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 -> if enoughRoom + then docSeq [importHead, bindingsD] + else docLines [importHead, bindingsD] + where enoughRoom = nameCost < importCol - hidingParenCost + _ -> 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 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -0,0 +1,62 @@ +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') = 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 + 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 $ docAltFilter + [ (,) allowSingleLineExportList $ 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" + ] + , (,) otherwise $ 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/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -317,7 +317,7 @@ 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 @@ -- 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 @@ ] 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 diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -72,12 +72,11 @@ ) => 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.) @@ -301,6 +300,8 @@ 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 @@ -319,11 +320,16 @@ 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 } @@ -455,6 +461,7 @@ 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 @@ -700,6 +707,7 @@ 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 @@ -712,11 +720,12 @@ $ 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 @@ -749,6 +758,34 @@ 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 } diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -23,11 +23,12 @@ 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 @@ -128,6 +129,7 @@ BDAnnotationPrior{} -> Nothing BDAnnotationKW{} -> Nothing BDAnnotationRest{} -> Nothing + BDMoveToKWDP{} -> Nothing BDEnsureIndent{} -> Nothing BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -101,9 +101,9 @@ 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 @@ 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 diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -174,10 +174,11 @@ | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? | ColListComp | ColList - | ColApp + | ColApp Text | ColTuple | ColTuples | ColOpPrefix -- merge with ColList ? other stuff? + | ColImport -- TODO deriving (Eq, Ord, Data.Data.Data, Show) @@ -232,6 +233,7 @@ | 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 @@ -277,6 +279,7 @@ | 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)) @@ -310,6 +313,7 @@ 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 @@ -341,6 +345,7 @@ 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 @@ -376,6 +381,7 @@ 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