diff --git a/ChangeLog.md b/ChangeLog.md index 253226b..05a7ea2 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,44 +1,5 @@ # 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) -* 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/README.md b/README.md index a3a106c..3196b27 100644 --- a/README.md +++ b/README.md @@ -8,12 +8,13 @@ haskell source code formatter This project's goals roughly are to: - Always retain the semantics of the source being transformed; -- Be idempotent; +- Be idempotent (this also directly ensures that only valid haskell is + produced); - 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 - the column maximum if it cannot be avoided; + it 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. @@ -26,9 +27,8 @@ 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 the module header (imports/exports), type-signatures and - function/value bindings** are processed; - other module elements (data-decls, classes, instances, etc.) +- **only type-signatures and function/value bindings** are processed; + other module elements (data-decls, classes, instances, imports/exports 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,22 +39,24 @@ 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 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 input/output of requests.) +log the size of the input, but _not_ the full requests.) # Other usage notes - Supports GHC versions `8.0.*` and `8.2.*`. -- included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) +- as of November'17, `brittany` is available on stackage nightly. - 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 (the first) `brittany.yaml` found in current or parent - directories. + also reads `brittany.yaml` in current dir if present. # Installation @@ -82,11 +84,11 @@ log the size of the input, but _not_ the full input/output of requests.) - via `stack` using a sufficiently recent stackage snapshot (dated to >= 2017-11-15) ~~~~.sh - stack install brittany # --resolver lts-10.0 + stack install brittany # --resolver=nightly-2017-11-15 ~~~~ - (earlier ltss did not include `brittany` yet, but the repo should contain a - `stack.yaml` that works with ghc-8.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.) - on ArchLinux via [the britanny AUR package](https://aur.archlinux.org/packages/brittany/) using `aura`: @@ -94,22 +96,6 @@ log the size of the input, but _not_ the full input/output of 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 @MaxGabriel. -#### 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. -#### Neovim / Vim 8 - The [Neoformat](https://github.com/sbdchd/neoformat) plugin comes with support for - brittany built in. - # Usage - Default mode of operation: Transform a single module, from `stdin` to `stdout`. @@ -157,6 +143,8 @@ 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 diff --git a/brittany.cabal b/brittany.cabal index d87cbc8..f3f6eba 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.10.0.0 +version: 0.9.0.0 synopsis: Haskell source code formatter description: { See . @@ -67,9 +67,6 @@ 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 @@ -85,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.6.0 && <0.5.7 + , ghc-exactprint >=0.5.3.0 && <0.5.6 , transformers >=0.5.2.0 && <0.6 , containers >=0.5.7.1 && <0.6 , mtl >=2.2.1 && <2.3 @@ -97,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.3 && <1.4 + , butcher >=1.2 && <1.3 , yaml >=0.8.18 && <0.9 , aeson >=1.0.1.0 && <1.3 , extra >=1.4.10 && <1.7 @@ -111,7 +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 + , text-latin1 >= 0.3 && < 0.4 } default-extensions: { CPP diff --git a/doc/showcases/Module.md b/doc/showcases/Module.md deleted file mode 100644 index 31a062f..0000000 --- a/doc/showcases/Module.md +++ /dev/null @@ -1,118 +0,0 @@ - -Last updated for brittany version `0.10.0.0`. - -# Example layouting of the module header (exports/imports) - -## On default settings - -default settings are: - -~~~~ -conf_layout: - lconfig_indentPolicy: IndentPolicyFree - lconfig_importColumn: 50 - lconfig_importAsColumn: 50 -~~~~ - - -~~~~.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 - ( someFunc - , MyDataType - , globalConstant - ) -import Example.Very.Long.Module.Name.Internal - ( someVeryLongAndDescriptiveFunctionName - ) -~~~~ - -## Alternative setting - long identifiers - -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.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) -~~~~ diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index 73eccd0..bcb8a3f 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -63,8 +63,7 @@ helpDoc = PP.vcat $ List.intersperse (PP.text "") [ parDocW [ "Reformats one or more haskell modules." - , "Currently affects only the module head (imports/exports), type" - , "signatures and function bindings;" + , "Currently affects only type signatures and function bindings;" , "everything else is left unmodified." , "Based on ghc-exactprint, thus (theoretically) supporting all" , "that ghc does." @@ -72,7 +71,7 @@ helpDoc = PP.vcat $ List.intersperse , parDoc $ "Example invocations:" , PP.hang (PP.text "") 2 $ PP.vcat [ PP.text "brittany" - , PP.nest 2 $ PP.text "read from stdin, output to stdout" + , PP.hang (PP.text " ") 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" @@ -83,10 +82,9 @@ helpDoc = PP.vcat $ List.intersperse ] , parDocW [ "This program is written carefully and contains safeguards to ensure" - , "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." + , "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." , "Please do check the output and do not let brittany override your large" , "codebase without having backups." ] @@ -150,7 +148,7 @@ mainCmdParser helpDesc = do ) <> flagDefault Display ) - inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files") + inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files") reorderStop addCmdImpl $ void $ do when printLicense $ do @@ -159,11 +157,11 @@ mainCmdParser helpDesc = do when printVersion $ do do putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2018 Lennart Spitzner" + putStrLn $ "Copyright (C) 2016-2017 Lennart Spitzner" putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do - liftIO $ putStrLn $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } $ ppHelpShallow helpDesc + liftIO $ print $ ppHelpShallow helpDesc System.Exit.exitSuccess let inputPaths = if null inputParams then [Nothing] else map Just inputParams @@ -171,14 +169,10 @@ mainCmdParser helpDesc = do Display -> repeat Nothing Inplace -> inputPaths - configsToLoad <- liftIO $ if null configPaths - then maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) - else pure configPaths - - config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case + config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x - when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ + when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do trace (showConfigYaml config) $ return () results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths @@ -322,3 +316,42 @@ 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 False 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 index 4919f3f..a3d8591 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -235,17 +235,6 @@ 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 @@ -298,10 +287,6 @@ 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 @@ -364,14 +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 - -#test normal infix constructor -func (x `Foo` xr) = x +func (x:+:xr) = x ############################################################################### @@ -576,314 +558,3 @@ 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 - -- 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 index d84ec79..0fbc830 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 @@ -367,22 +367,13 @@ 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 -#test issue 37 - -foo = - ( a - , -- comment1 - b - -- comment2 - , c - ) - #test issue 38 {-# LANGUAGE TypeApplications #-} @@ -511,21 +502,6 @@ 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.!)) @@ -537,53 +513,3 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ] #test issue 70 {-# 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 - 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) - -#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 index ebe2a08..5567e68 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -169,14 +169,11 @@ 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) , _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 index 2d1c421..e8303cd 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 ############################################################################### @@ -598,270 +598,6 @@ 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 - -- 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) ############################################################################### ############################################################################### @@ -1012,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 ] @@ -1397,3 +1133,4 @@ foo = ## ] ## where ## role = stringProperty "WM_WINDOW_ROLE" + diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index d10f85a..1ee5203 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -51,14 +51,11 @@ 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) , _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 index 9d45dde..5f9a128 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -4,10 +4,6 @@ module Language.Haskell.Brittany ( 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 index 561390f..b6987b5 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 +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data @@ -33,7 +33,6 @@ 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 @@ -133,7 +132,7 @@ parsePrintModule configRaw inputText = runExceptT $ do -- can occur. pPrintModule :: Config - -> ExactPrint.Anns + -> ExactPrint.Types.Anns -> GHC.ParsedSource -> ([BrittanyError], TextL.Text) pPrintModule conf anns parsedModule = @@ -161,7 +160,7 @@ pPrintModule conf anns parsedModule = in tracer $ (errs, Text.Builder.toLazyText out) -- unless () $ do - -- + -- -- debugStrings `forM_` \s -> -- trace s $ return () @@ -169,7 +168,7 @@ pPrintModule conf anns parsedModule = -- if it does not. pPrintModuleAndCheck :: Config - -> ExactPrint.Anns + -> ExactPrint.Types.Anns -> GHC.ParsedSource -> IO ([BrittanyError], TextL.Text) pPrintModuleAndCheck conf anns parsedModule = do @@ -249,11 +248,33 @@ 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 _ decls _ _)) = do - post <- ppPreamble lmod +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 decls `forM_` \decl -> do filteredAnns <- mAsk <&> \annMap -> - Map.findWithDefault Map.empty (ExactPrint.mkAnnKey decl) annMap + Map.findWithDefault Map.empty (ExactPrint.Types.mkAnnKey decl) annMap traceIfDumpConf "bridoc annotations filtered/transformed" _dconf_dump_annotations @@ -266,26 +287,26 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do ppDecl decl let finalComments = filter ( fst .> \case - ExactPrint.AnnComment{} -> True + ExactPrint.Types.AnnComment{} -> True _ -> False ) post post `forM_` \case - (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do + (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do ppmMoveToExactLoc l mTell $ Text.Builder.fromString cmStr - (ExactPrint.G AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> + (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX, eofY))) -> let - 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 + 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 ) - _ -> (acc + y, x) - (cmY, cmX) = foldl' folder (0, 0) finalComments + _ -> (acc + x, y) + (cmX, cmY) = foldl' folder (0, 0) finalComments in - ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) + ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY - cmY) _ -> return () withTransformedAnns :: Data ast => ast -> PPMLocal () -> PPMLocal () @@ -320,76 +341,6 @@ 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.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 _ -> @@ -440,7 +391,7 @@ layoutBriDoc briDoc = do -- simpl <- mGet <&> transformToSimple -- return simpl - anns :: ExactPrint.Anns <- mAsk + anns :: ExactPrint.Types.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 a22d756..dbc611e 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -250,23 +250,6 @@ 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 @@ -281,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 @@ -299,7 +282,6 @@ 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 @@ -335,7 +317,6 @@ 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 []" @@ -455,7 +436,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/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index a7d8594..63e6090 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 @@ -97,11 +99,21 @@ 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 } +-- | +-- >>> 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 @@ -158,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 -- } @@ -588,7 +600,7 @@ layoutIndentRestorePostComment = do -- layoutWritePriorCommentsRestore x = do -- layoutWritePriorComments x -- layoutIndentRestorePostComment --- +-- -- layoutWritePostCommentsRestore :: (Data.Data.Data ast, -- MonadMultiWriter Text.Builder.Builder m, -- MonadMultiState LayoutState m diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 76e9c95..f225545 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -9,10 +9,6 @@ module Language.Haskell.Brittany.Internal.Config , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled , readConfig - , userConfigPath - , findLocalConfigPath - , readConfigs - , readConfigsWithUserConfig , writeDefaultConfig , showConfigYaml ) @@ -26,10 +22,8 @@ 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 @@ -39,8 +33,7 @@ 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 @@ -65,15 +58,12 @@ staticDefaultConfig = Config , _lconfig_indentAmount = coerce (2 :: Int) , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) + , _lconfig_importColumn = 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 False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -114,9 +104,8 @@ 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)") + dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (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") @@ -130,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 (debugging)") + omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid; for dev on brittany") roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") @@ -164,14 +153,11 @@ 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 , _lconfig_alignmentBreakOnMultiline = mempty , _lconfig_hangingTypeSignature = mempty - , _lconfig_reformatModulePreamble = mempty - , _lconfig_allowSingleLineExportList = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors @@ -203,10 +189,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" @@ -241,50 +227,6 @@ readConfig path = do 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 = liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index dc0300f..f2530b0 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -53,14 +53,7 @@ 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) - -- ^ 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_importColumn :: f (Last Int) , _lconfig_altChooser :: f (Last AltChooser) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode) , _lconfig_alignmentLimit :: f (Last Int) @@ -91,21 +84,6 @@ 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/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 749804c..7494d9e 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -113,11 +113,48 @@ parseModuleFromString args fp dynCheck str = $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> \(L _ s) -> s) dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 - let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str + let res = parseModulePure 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 diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 5fb5c8d..52c9e08 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -4,7 +4,6 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , lrdrNameToText , lrdrNameToTextAnn , lrdrNameToTextAnnTypeEqualityIsSpecial - , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick , askIndent , extractAllComments , filterAnns @@ -17,7 +16,6 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSeq , docPar , docNodeAnnKW - , docNodeMoveToKWDP , docWrapNode , docWrapNodePrior , docWrapNodeRest @@ -31,7 +29,6 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docAnnotationPrior , docAnnotationKW , docAnnotationRest - , docMoveToKWDP , docNonBottomSpacing , docSetParSpacing , docForceParSpacing @@ -45,7 +42,6 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , appSep , docCommaSep , docParenLSep - , docParenR , docTick , spacifyDocs , briDocMToPPM @@ -220,27 +216,6 @@ 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 @@ -465,13 +440,6 @@ 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 @@ -497,9 +465,6 @@ 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 "'" @@ -512,15 +477,6 @@ 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/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 400d422..8724291 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -94,8 +94,7 @@ 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 -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default + NeverActive -> "[] " AlwaysActive -> "" ActiveBefore _ i -> "[~" ++ show i ++ "] " ActiveAfter _ i -> "[" ++ show i ++ "] " @@ -193,17 +192,16 @@ layoutPatternBind -> BriDocNumbered -> LMatch RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered -layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (GRHSs grhss whereBinds))) = do +layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p let isInfix = isInfixMatch match - let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr - patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of - (Just idStr, p1 : pr) | isInfix -> docCols + 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) @@ -222,28 +220,6 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ ( 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 @@ -301,13 +277,10 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] let singleLineGuardsDoc guards = appSep $ case guards of [] -> docEmpty - [g] -> docSeq - [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] + [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g] gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] - ++ (List.intersperse docCommaSep - (docForceSingleline . return <$> gs) - ) + ++ List.intersperse docCommaSep (return <$> gs) indentPolicy <- mAsk <&> _conf_layout diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index a5402ea..8d90148 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -117,16 +117,12 @@ 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 - , colsOrSequence + , docCols ColApp $ appSep (docForceSingleline headDoc) : spacifyDocs (docForceSingleline <$> paramDocs) ) @@ -237,27 +233,24 @@ 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 - docAltFilter - [ ( not hasComments + docAlt + [ docSeq + [ appSep $ docForceSingleline leftOperandDoc , docSeq - [ appSep $ docForceSingleline leftOperandDoc - , docSeq - $ (appListDocs <&> \(od, ed) -> docSeq - [ appSep $ docForceSingleline od - , appSep $ docForceSingleline ed - ] - ) - , appSep $ docForceSingleline opLastDoc - , (if allowPar then docForceParSpacing else docForceSingleline) - expLastDoc - ] - ) + $ (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 @@ -267,14 +260,12 @@ layoutExpr lexpr@(L _ expr) = do -- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed]) -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]] -- ) - , (otherwise - , docPar + , 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 @@ -327,7 +318,7 @@ layoutExpr lexpr@(L _ expr) = do , opDoc ] HsPar innerExp -> do - innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp + innerExpDoc <- docSharedWrapper layoutExpr innerExp docAlt [ docSeq [ docLit $ Text.pack "(" @@ -351,12 +342,8 @@ layoutExpr lexpr@(L _ expr) = do rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] ExplicitTuple args boxity -> do - 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 + let argExprs = fmap (\case (L _ (Present e)) -> Just e; (L _ (Missing PlaceHolder)) -> Nothing) args + argDocs <- docSharedWrapper (maybe docEmpty layoutExpr) `mapM` argExprs hasComments <- hasAnyCommentsBelow lexpr let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") @@ -543,26 +530,22 @@ layoutExpr lexpr@(L _ expr) = do (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments) HsLet binds exp1 -> do expDoc1 <- docSharedWrapper layoutExpr exp1 - -- We jump through some ugly hoops here to ensure proper sharing. - mBindDocs <- mapM (fmap (fmap return) . docWrapNodeRest lexpr . return) - =<< layoutLocalBinds binds + mBindDocs <- layoutLocalBinds binds let ifIndentLeftElse :: a -> a -> a ifIndentLeftElse x y = if indentPolicy == IndentPolicyLeft then x else y - -- 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. + -- this `docSetIndentLevel` might seem out of place, 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. - docSetBaseAndIndent $ case mBindDocs of + docSetIndentLevel $ case mBindDocs of Just [bindDoc] -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" - , appSep $ docForceSingleline $ bindDoc + , appSep $ docForceSingleline $ return bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline $ expDoc1 ] @@ -571,12 +554,12 @@ layoutExpr lexpr@(L _ expr) = do [ docSeq [ appSep $ docLit $ Text.pack "let" , ifIndentLeftElse docForceSingleline docSetBaseAndIndent - $ bindDoc + $ return bindDoc ] , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ bindDoc) + (docSetBaseAndIndent $ return bindDoc) ] , docAlt [ docSeq @@ -609,7 +592,7 @@ layoutExpr lexpr@(L _ expr) = do [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) , docSeq [ docLit $ Text.pack "in " , docAddBaseY BrIndentRegular $ expDoc1 @@ -620,7 +603,7 @@ layoutExpr lexpr@(L _ expr) = do , docLines [ docSeq [ appSep $ docLit $ Text.pack "let" - , docSetBaseAndIndent $ docLines $ bindDocs + , docSetBaseAndIndent $ docLines $ return <$> bindDocs ] , docSeq [ appSep $ docLit $ Text.pack "in " @@ -633,7 +616,7 @@ layoutExpr lexpr@(L _ expr) = do [ docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "let") - (docSetBaseAndIndent $ docLines $ bindDocs) + (docSetBaseAndIndent $ docLines $ return <$> bindDocs) , docAddBaseY BrIndentRegular $ docPar (docLit $ Text.pack "in") @@ -750,8 +733,6 @@ 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 @@ -871,7 +852,7 @@ layoutExpr lexpr@(L _ expr) = do Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) docAltFilter - -- container { fieldA = blub, fieldB = blub } + -- singleline [ ( True , docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc @@ -889,10 +870,7 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "}" ] ) - -- hanging single-line fields - -- container { fieldA = blub - -- , fieldB = blub - -- } + -- wild-indentation block , ( indentPolicy /= IndentPolicyLeft , docSeq [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc @@ -903,7 +881,7 @@ layoutExpr lexpr@(L _ expr) = do , case rF1e of Just x -> docWrapNodeRest rF1f $ docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x + , docForceSingleline $ x ] Nothing -> docEmpty ] @@ -923,54 +901,36 @@ layoutExpr lexpr@(L _ expr) = do in [line1] ++ lineR ++ [lineN] ] ) - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } + -- strict indentation block , ( 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 -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular $ 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 -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular 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 deleted file mode 100644 index bc277bc..0000000 --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ /dev/null @@ -1,145 +0,0 @@ -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 deleted file mode 100644 index 04925bd..0000000 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Import.hs +++ /dev/null @@ -1,156 +0,0 @@ -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 deleted file mode 100644 index e9c9aa3..0000000 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ /dev/null @@ -1,62 +0,0 @@ -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/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 51bb03a..ebdd91d 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 - nameDoc <- lrdrNameToTextAnn lname - leftDoc <- appSep . colsWrapPat =<< layoutPat left + let nameDoc = lrdrNameToText lname + leftDoc <- colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right - middle <- appSep $ docLit nameDoc + middle <- docLit nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do -- Abc{} -> expr diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 11e0eed..bd4d728 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) - lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lname name + lrdrNameToTextAnnTypeEqualityIsSpecial name docLit typeDoc1 HsAppsTy (L _ (HsAppPrefix typHead):typRestA) | Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t @@ -350,8 +350,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] where layoutAppType (L _ (HsAppPrefix t)) = layoutType t - layoutAppType lt@(L _ (HsAppInfix t)) = - docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lt t + layoutAppType (L _ (HsAppInfix t)) = docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecial 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 index f7ed523..93c31c6 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -72,11 +72,12 @@ transformAlts ) => BriDocNumbered -> MultiRWSS.MultiRWS r w s BriDoc -transformAlts = +transformAlts briDoc = MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone) - . Memo.startEvalMemoT - . fmap unwrapBriDocNumbered - . rec + $ Memo.startEvalMemoT + $ fmap unwrapBriDocNumbered + $ rec + $ briDoc where -- this function is exponential by nature and cannot be improved in any -- way i can think of, and i've tried. (stupid StableNames.) @@ -300,8 +301,6 @@ transformAlts = 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 @@ -320,16 +319,11 @@ transformAlts = 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 = 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. - } + 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 + } r <- rec bd acp' <- mGet mSet $ acp' { _acp_indent = _acp_indent acp } @@ -461,7 +455,6 @@ 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 @@ -707,7 +700,6 @@ 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 @@ -720,12 +712,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc $ sequence $ reverse $ lSpss - 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 + summed = worbled <&> \lSps@(lSp1:_) -> + VerticalSpacing (_vs_sameLine lSp1) + (spMakePar $ maxVs lSps) + False + return $ summed -- lSpss@(mVs:_) <- rec `mapM` ls -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only -- -- consider the first alternative for the @@ -758,34 +749,6 @@ 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 } diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 471ac67..071028a 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -23,12 +23,11 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDLit{} -> Nothing BDSeq list | any (\case BDSeq{} -> True BDEmpty{} -> True - _ -> False) list -> Just $ BDSeq $ list >>= \case - BDEmpty -> [] - BDSeq l -> l - x -> [x] - BDSeq (BDCols sig1 cols1@(_:_):rest) - | all (\case BDSeparator -> True; _ -> False) rest -> + _ -> False) list -> Just $ BDSeq $ + filter isNotEmpty list >>= \case + BDSeq l -> l + x -> [x] + BDSeq (BDCols sig1 cols1@(_:_):rest) -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) BDLines lines | any (\case BDLines{} -> True BDEmpty{} -> True @@ -129,7 +128,6 @@ 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/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs index 08a919f..e36a545 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 diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 1d26b73..557f9b3 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -174,11 +174,10 @@ data ColSig | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? | ColListComp | ColList - | ColApp Text + | ColApp | ColTuple | ColTuples | ColOpPrefix -- merge with ColList ? other stuff? - | ColImport -- TODO deriving (Eq, Ord, Data.Data.Data, Show) @@ -233,7 +232,6 @@ 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 @@ -279,7 +277,6 @@ 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)) @@ -313,7 +310,6 @@ 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 @@ -345,7 +341,6 @@ 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 @@ -381,7 +376,6 @@ 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 diff --git a/stack-8.0.2.yaml b/stack-8.0.2.yaml index ca6ad6a..539cd6d 100644 --- a/stack-8.0.2.yaml +++ b/stack-8.0.2.yaml @@ -3,10 +3,9 @@ resolver: lts-9.0 extra-deps: - monad-memo-0.4.1 - czipwith-1.0.0.0 - - butcher-1.3.0.0 + - butcher-1.2.0.0 - data-tree-print-0.1.0.0 - deque-0.2 - - ghc-exactprint-0.5.6.0 packages: - . diff --git a/stack.yaml b/stack.yaml index 1939eac..74e27d2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-11.0 +resolver: lts-10.0 packages: - .