diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,20 @@ # Revision history for brittany +## 0.12.2.0 -- November 2020 + +* #207: Fix newtype indent in associated type family. +* #231: Improve comments-affecting-layout behaviour for tuples. +* #259: Data declaration for newtype and records. Thanks @eborden! +* #263: Fix non-idempotent newlines with comment + where. +* #273: Error handling. +* #281: Fix moving comment in export list (haddock header). +* #286: Fix comments in instance/type instances. +* #287: Add support for pattern synonyms. Thanks @RaoulHC! +* #293: Expose main function as a module. Thanks @soareschen! +* #303: Readme: Supports 8.8. Thanks @andys8! +* #311: Allows aeson-1.5.*. Thanks @jkachmar! +* #313: Nondecreasing export list formatting. Thanks @expipiplus1! + ## 0.12.1.1 -- December 2019 * Bugfixes: @@ -90,11 +105,11 @@ multiline-comments are supported too, although the specification must still be a single line. E.g. - + > "{- brittany --columns 50 -}" - + CONFIG is either: - + 1) one or more flags in the form of what brittany accepts on the commandline, e.g. "--columns 50", or 2) one or more specifications in the form of what brittany diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -48,7 +48,7 @@ # Other usage notes -- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`. +- Supports GHC versions `8.0`, `8.2`, `8.4`, `8.6`, `8.8`. - included in stackage with lts>=10.0 (or nightlies dating to >=2017-11-15) - config (file) documentation is lacking. - some config values can not be configured via commandline yet. diff --git a/brittany.cabal b/brittany.cabal --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.12.1.1 +version: 0.12.2.0 synopsis: Haskell source code formatter description: { See . @@ -53,6 +53,7 @@ srcinc exposed-modules: { Language.Haskell.Brittany + Language.Haskell.Brittany.Main Language.Haskell.Brittany.Internal Language.Haskell.Brittany.Internal.Prelude Language.Haskell.Brittany.Internal.PreludeUtils @@ -77,6 +78,7 @@ Language.Haskell.Brittany.Internal.Layouters.IE Language.Haskell.Brittany.Internal.Layouters.Import Language.Haskell.Brittany.Internal.Layouters.Module + Language.Haskell.Brittany.Internal.Layouters.DataDecl Language.Haskell.Brittany.Internal.Transformations.Alt Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Par @@ -99,15 +101,14 @@ , text >=1.2 && <1.3 , multistate >=0.7.1.1 && <0.9 , syb >=0.6 && <0.8 - , neat-interpolation >=0.3.2 && <0.4 , data-tree-print , 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 && <1.4 , yaml >=0.8.18 && <0.12 - , aeson >=1.0.1.0 && <1.5 - , extra >=1.4.10 && <1.7 + , aeson >=1.0.1.0 && <1.6 + , extra >=1.4.10 && <1.8 , uniplate >=1.6.12 && <1.7 , strict >=0.3.2 && <0.4 , monad-memo >=0.4.1 && <0.6 @@ -145,61 +146,12 @@ buildable: True } main-is: Main.hs - other-modules: { - Paths_brittany - } - -- other-extensions: + hs-source-dirs: src-brittany build-depends: - { brittany - , base - , ghc - , ghc-paths - , ghc-exactprint - , transformers - , containers - , mtl - , text - , multistate - , syb - , neat-interpolation - , data-tree-print - , pretty - , bytestring - , directory - , butcher - , yaml - , aeson - , extra - , uniplate - , strict - , monad-memo - , unsafe - , safe - , deepseq - , semigroups - , cmdargs - , czipwith - , ghc-boot-th - , filepath >=1.4.1.0 && <1.5 + { base + , brittany } - hs-source-dirs: src-brittany - include-dirs: srcinc default-language: Haskell2010 - default-extensions: { - CPP - - NoImplicitPrelude - - GADTs - - FlexibleContexts - FlexibleInstances - ScopedTypeVariables - MonadComprehensions - LambdaCase - MultiWayIf - KindSignatures - } ghc-options: { -Wall -fno-spec-constr @@ -229,7 +181,6 @@ , text , multistate , syb - , neat-interpolation , data-tree-print , pretty , bytestring @@ -301,7 +252,6 @@ , text , multistate , syb - , neat-interpolation , data-tree-print , pretty , bytestring diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -1,469 +1,6 @@ -{-# LANGUAGE DataKinds #-} - module Main where - - -#include "prelude.inc" - --- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } -import qualified Language.Haskell.GHC.ExactPrint as ExactPrint -import qualified Language.Haskell.GHC.ExactPrint.Annotate - as ExactPrint.Annotate -import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types -import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers -import qualified Data.Map as Map -import qualified Data.Monoid - -import GHC ( GenLocated(L) ) -import Outputable ( Outputable(..) - , showSDocUnsafe - ) - -import Text.Read ( Read(..) ) -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Data.Text.Lazy.Builder as Text.Builder - -import Control.Monad ( zipWithM ) -import Data.CZipWith - -import qualified Debug.Trace as Trace - -import Language.Haskell.Brittany.Internal.Types -import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Utils -import Language.Haskell.Brittany.Internal.Obfuscation - -import qualified Text.PrettyPrint as PP - -import DataTreePrint -import UI.Butcher.Monadic - -import qualified System.Exit -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath - -import qualified DynFlags as GHC -import qualified GHC.LanguageExtensions.Type as GHC - -import Paths_brittany - - - -data WriteMode = Display | Inplace - -instance Read WriteMode where - readPrec = val "display" Display <|> val "inplace" Inplace - where val iden v = ReadPrec.lift $ ReadP.string iden >> return v - -instance Show WriteMode where - show Display = "display" - show Inplace = "inplace" - +import qualified Language.Haskell.Brittany.Main as BrittanyMain main :: IO () -main = mainFromCmdParserWithHelpDesc mainCmdParser - -helpDoc :: PP.Doc -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;" - , "everything else is left unmodified." - , "Based on ghc-exactprint, thus (theoretically) supporting all" - , "that ghc does." - ] - , 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.vcat - [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" - , PP.nest 2 $ PP.vcat - [ PP.text "run on all modules in current directory (no backup!)" - , PP.text "4 spaces indentation" - ] - ] - , 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." - , "Please do check the output and do not let brittany override your large" - , "codebase without having backups." - ] - , parDoc $ "There is NO WARRANTY, to the extent permitted by law." - , parDocW - [ "This program is free software released under the AGPLv3." - , "For details use the --license flag." - ] - , parDoc $ "See https://github.com/lspitzner/brittany" - , parDoc - $ "Please report bugs at" - ++ " https://github.com/lspitzner/brittany/issues" - ] - -licenseDoc :: PP.Doc -licenseDoc = PP.vcat $ List.intersperse - (PP.text "") - [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" - , parDoc $ "Copyright (C) 2019 PRODA LTD" - , parDocW - [ "This program is free software: you can redistribute it and/or modify" - , "it under the terms of the GNU Affero General Public License," - , "version 3, as published by the Free Software Foundation." - ] - , parDocW - [ "This program is distributed in the hope that it will be useful," - , "but WITHOUT ANY WARRANTY; without even the implied warranty of" - , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , "GNU Affero General Public License for more details." - ] - , parDocW - [ "You should have received a copy of the GNU Affero General Public" - , "License along with this program. If not, see" - , "." - ] - ] - - -mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () -mainCmdParser helpDesc = do - addCmdSynopsis "haskell source pretty printer" - addCmdHelp $ helpDoc - -- addCmd "debugArgs" $ do - addHelpCommand helpDesc - addCmd "license" $ addCmdImpl $ print $ licenseDoc - -- addButcherDebugCommand - reorderStart - printHelp <- addSimpleBoolFlag "h" ["help"] mempty - printVersion <- addSimpleBoolFlag "" ["version"] mempty - printLicense <- addSimpleBoolFlag "" ["license"] mempty - noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty - configPaths <- addFlagStringParams "" - ["config-file"] - "PATH" - (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? - cmdlineConfig <- cmdlineConfigParser - suppressOutput <- addSimpleBoolFlag - "" - ["suppress-output"] - (flagHelp $ parDoc - "suppress the regular output, i.e. the transformed haskell source" - ) - _verbosity <- addSimpleCountFlag - "v" - ["verbose"] - (flagHelp $ parDoc "[currently without effect; TODO]") - checkMode <- addSimpleBoolFlag - "c" - ["check-mode"] - (flagHelp - (PP.vcat - [ PP.text "check for changes but do not write them out" - , PP.text "exits with code 0 if no changes necessary, 1 otherwise" - ] - ) - ) - writeMode <- addFlagReadParam - "" - ["write-mode"] - "(display|inplace)" - ( flagHelp - (PP.vcat - [ PP.text "display: output for any input(s) goes to stdout" - , PP.text "inplace: override respective input file (without backup!)" - ] - ) - Data.Monoid.<> flagDefault Display - ) - inputParams <- addParamNoFlagStrings - "PATH" - (paramHelpStr "paths to input/inout haskell source files") - reorderStop - addCmdImpl $ void $ do - when printLicense $ do - print licenseDoc - System.Exit.exitSuccess - when printVersion $ do - do - putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" - putStrLn $ "Copyright (C) 2019 PRODA LTD" - 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 - System.Exit.exitSuccess - - let inputPaths = - if null inputParams then [Nothing] else map Just inputParams - let outputPaths = case writeMode of - Display -> repeat Nothing - Inplace -> inputPaths - - configsToLoad <- liftIO $ if null configPaths - then - maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) - else pure configPaths - - config <- - runMaybeT - (if noUserConfig - then readConfigs cmdlineConfig configsToLoad - else readConfigsWithUserConfig cmdlineConfig configsToLoad - ) - >>= \case - Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) - Just x -> return x - when (config & _conf_debug & _dconf_dump_config & confUnpack) - $ trace (showConfigYaml config) - $ return () - - results <- zipWithM - (coreIO putStrErrLn config (suppressOutput || checkMode)) - inputPaths - outputPaths - - if checkMode - then when (any (== Changes) (Data.Either.rights results)) - $ System.Exit.exitWith (System.Exit.ExitFailure 1) - else case results of - xs | all Data.Either.isRight xs -> pure () - [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) - _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) - - -data ChangeStatus = Changes | NoChanges - deriving (Eq) - --- | The main IO parts for the default mode of operation, and after commandline --- and config stuff is processed. -coreIO - :: (String -> IO ()) -- ^ error output function. In parallel operation, you - -- may want serialize the different outputs and - -- consequently not directly print to stderr. - -> Config -- ^ global program config. - -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so - -- currently not part of program config. - -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. - -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. - -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = - ExceptT.runExceptT $ do - let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () - let ghcOptions = config & _conf_forward & _options_ghc & runIdentity - -- there is a good of code duplication between the following code and the - -- `pureModuleTransform` function. Unfortunately, there are also a good - -- amount of slight differences: This module is a bit more verbose, and - -- it tries to use the full-blown `parseModule` function which supports - -- CPP (but requires the input to be a file..). - let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack - -- the flag will do the following: insert a marker string - -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with - -- "#include" before processing (parsing) input; and remove that marker - -- string from the transformation output. - -- The flag is intentionally misspelled to prevent clashing with - -- inline-config stuff. - let hackAroundIncludes = - config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack - let exactprintOnly = viaGlobal || viaDebug - where - viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack - viaDebug = - config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack - - let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags - then case cppMode of - CPPModeAbort -> do - return $ Left "Encountered -XCPP. Aborting." - CPPModeWarn -> do - putErrorLnIO - $ "Warning: Encountered -XCPP." - ++ " Be warned that -XCPP is not supported and that" - ++ " brittany cannot check that its output is syntactically" - ++ " valid in its presence." - return $ Right True - CPPModeNowarn -> return $ Right True - else return $ Right False - (parseResult, originalContents) <- case inputPathM of - Nothing -> do - -- TODO: refactor this hack to not be mixed into parsing logic - let hackF s = if "#include" `isPrefixOf` s - then "-- BRITANY_INCLUDE_HACK " ++ s - else s - let hackTransform = if hackAroundIncludes && not exactprintOnly - then List.intercalate "\n" . fmap hackF . lines' - else id - inputString <- liftIO $ System.IO.hGetContents System.IO.stdin - parseRes <- liftIO $ parseModuleFromString ghcOptions - "stdin" - cppCheckFunc - (hackTransform inputString) - return (parseRes, Text.pack inputString) - Just p -> liftIO $ do - parseRes <- parseModule ghcOptions p cppCheckFunc - inputText <- Text.IO.readFile p - -- The above means we read the file twice, but the - -- GHC API does not really expose the source it - -- read. Should be in cache still anyways. - -- - -- We do not use TextL.IO.readFile because lazy IO is evil. - -- (not identical -> read is not finished -> - -- handle still open -> write below crashes - evil.) - return (parseRes, inputText) - case parseResult of - Left left -> do - putErrorLn "parse error:" - putErrorLn $ show left - ExceptT.throwE 60 - Right (anns, parsedSource, hasCPP) -> do - (inlineConf, perItemConf) <- - case - extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - of - Left (err, input) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - ExceptT.throwE 61 - Right c -> -- trace (showTree c) $ - pure c - let moduleConf = cZipWith fromOptionIdentity config inlineConf - when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do - let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource - trace ("---- ast ----\n" ++ show val) $ return () - (errsWarns, outSText) <- do - if exactprintOnly - then do - pure ([], Text.pack $ ExactPrint.exactPrint parsedSource anns) - else do - let omitCheck = - moduleConf - & _conf_errorHandling - .> _econf_omit_output_valid_check - .> confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return - $ pPrintModule moduleConf perItemConf anns parsedSource - else liftIO $ pPrintModuleAndCheck moduleConf - perItemConf - anns - parsedSource - let hackF s = fromMaybe s $ TextL.stripPrefix - (TextL.pack "-- BRITANY_INCLUDE_HACK ") - s - let out = TextL.toStrict $ if hackAroundIncludes - then - TextL.intercalate (TextL.pack "\n") - $ fmap hackF - $ TextL.splitOn (TextL.pack "\n") outRaw - else outRaw - out' <- if moduleConf & _conf_obfuscate & confUnpack - then lift $ obfuscate out - else pure out - pure $ (ews, out') - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - when (not $ null errsWarns) $ do - let groupedErrsWarns = - Data.List.Extra.groupOn customErrOrder - $ List.sortOn customErrOrder - $ errsWarns - groupedErrsWarns `forM_` \case - (ErrorOutputCheck{} : _) -> do - putErrorLn - $ "ERROR: brittany pretty printer" - ++ " returned syntactically invalid result." - (ErrorInput str : _) -> do - putErrorLn $ "ERROR: parse error: " ++ str - uns@(ErrorUnknownNode{} : _) -> do - putErrorLn $ "ERROR: encountered unknown syntactical constructs:" - uns `forM_` \case - ErrorUnknownNode str ast@(L loc _) -> do - putErrorLn $ str <> " at " <> showSDocUnsafe (ppr loc) - when - ( config - & _conf_debug - & _dconf_dump_ast_unknown - & confUnpack - ) - $ do - putErrorLn $ " " ++ show (astToDoc ast) - _ -> error "cannot happen (TM)" - warns@(LayoutWarning{} : _) -> do - putErrorLn $ "WARNINGS:" - warns `forM_` \case - LayoutWarning str -> putErrorLn str - _ -> error "cannot happen (TM)" - unused@(ErrorUnusedComment{} : _) -> do - putErrorLn - $ "Error: detected unprocessed comments." - ++ " The transformation output will most likely" - ++ " not contain some of the comments" - ++ " present in the input haskell source file." - putErrorLn $ "Affected are the following comments:" - unused `forM_` \case - ErrorUnusedComment str -> putErrorLn str - _ -> error "cannot happen (TM)" - (ErrorMacroConfig err input : _) -> do - putErrorLn $ "Error: parse error in inline configuration:" - putErrorLn err - putErrorLn $ " in the string \"" ++ input ++ "\"." - [] -> error "cannot happen" - -- TODO: don't output anything when there are errors unless user - -- adds some override? - let - hasErrors = - case config & _conf_errorHandling & _econf_Werror & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - outputOnErrs = - config - & _conf_errorHandling - & _econf_produceOutputOnErrors - & confUnpack - shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) - - let noChanges = outSText == originalContents - when shouldOutput - $ addTraceSep (_conf_debug config) - $ case outputPathM of - Nothing -> liftIO $ Text.IO.putStr $ outSText - Just p -> liftIO $ do - let isIdentical = case inputPathM of - Nothing -> False - Just _ -> noChanges - unless isIdentical $ Text.IO.writeFile p $ outSText - - when hasErrors $ ExceptT.throwE 70 - return (if noChanges then NoChanges else Changes) - where - addTraceSep conf = - if or - [ confUnpack $ _dconf_dump_annotations conf - , confUnpack $ _dconf_dump_ast_unknown conf - , confUnpack $ _dconf_dump_ast_full conf - , confUnpack $ _dconf_dump_bridoc_raw conf - , confUnpack $ _dconf_dump_bridoc_simpl_alt conf - , confUnpack $ _dconf_dump_bridoc_simpl_floating conf - , confUnpack $ _dconf_dump_bridoc_simpl_columns conf - , confUnpack $ _dconf_dump_bridoc_simpl_indent conf - , confUnpack $ _dconf_dump_bridoc_final conf - ] - then trace "----" - else id +main = BrittanyMain.main diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -313,6 +313,303 @@ ############################################################################### ############################################################################### ############################################################################### +#group data type declarations +############################################################################### +############################################################################### +############################################################################### + +#test nullary data type +data Foo = Bar {} + +data Biz = Baz + +#test single record +data Foo = Bar + { foo :: Baz + } + +#test record multiple names +data Foo = Bar + { foo, bar :: Baz + } + +#test record multiple types +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + +#test record multiple types and names +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } + +#test record multiple types deriving +data Foo = Bar + { fooz :: Baz + , bar :: Bizzz + } + deriving Show + +#test record long field names +data MyRecord = MyConstructor + { bar1, bar2 + :: Loooooooooooooooooooooooooooooooong + -> Loooooooooooooooooooooooooooooooong + , foo1, foo2 + :: Loooooooooooooooooooooooooooooooonger + -> Loooooooooooooooooooooooooooooooonger + } + +#test record with DataTypeContexts +{-# LANGUAGE DatatypeContexts #-} +data + ( LooooooooooooooooooooongConstraint a + , LooooooooooooooooooooongConstraint b + ) => + MyRecord a b + = MyConstructor + { foo1, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } + +#test record single line layout +#pending config flag is disabled for now +{-# LANGUAGE ScopedTypeVariables #-} +-- brittany { lconfig_allowSinglelineRecord: true } +data MyRecord = forall a . Show a => MyCons { foo :: a -> a, i :: Int } + +#test record no matching single line layout +{-# LANGUAGE ScopedTypeVariables #-} +-- brittany { lconfig_allowSinglelineRecord: true } +data MyRecord = forall a . Show a => Bar + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } + +#test record forall constraint multiline +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a + . LooooooooooooooooooooongConstraint a => + LoooooooooooongConstructor + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } + +#test record forall constraint multiline more +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { a :: a + , b :: b + } + +#test plain with forall and constraint +{-# LANGUAGE ScopedTypeVariables #-} +data MyStruct + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) + +#test record with many features +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { foo, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } + deriving Show + +#test record multiple types deriving +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) + +#test record multiple deriving strategies +#min-ghc 8.2 +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving Show + deriving (Eq, Ord) + deriving stock Show + deriving stock (Eq, Ord) + deriving anyclass Show + deriving anyclass (Show, Eq, Monad, Functor) + deriving newtype Show + deriving newtype (Traversable, Foldable) + +#test record deriving via +#min-ghc 8.6 +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving ToJSON via (SomeType) + deriving (ToJSON, FromJSON) via (SomeType) + +#test single record existential +{-# LANGUAGE ExistentialQuantification #-} + +data Foo = forall a . Show a => Bar + { foo :: a + } + +#test record multiple types existential +{-# LANGUAGE ExistentialQuantification #-} + +data Foo = forall a b . (Show a, Eq b) => Bar + { foo :: a + , bars :: b + } + +#test plain comment simple +-- before +data MyData = MyData Int +-- after + +#test record newline comment +data MyRecord = MyRecord + { a :: Int + -- comment + , b :: Int + } + +#test record comments simple +data Foo = Bar -- a + { foo :: Baz -- b + , bars :: Bizzz -- c + } -- d + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) -- e + +#test record comments strange inline +data Foo = Bar + { -- a + foo -- b + :: -- c + Baz -- d + , -- e + bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) + +#test record comments in deriving +## maybe we want to switch to a differnt layout when there are such comments. +## Don't hesitate to modify this testcase, it clearly is not the ideal layout +## for this. + +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --b + ( -- c + ToJSON -- d + , -- e + FromJSON --f + ) -- g + +#test record comments in deriving via +## maybe we want to switch to a differnt layout when there are such comments. +## Don't hesitate to modify this testcase, it clearly is not the ideal layout +## for this. +#min-ghc 8.6 + +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --a + ToJSON --b + via -- c + ( -- d + SomeType --e + , -- f + ABC --g + ) + +#test comment before equal sign +{-# LANGUAGE ExistentialQuantification #-} +data MyRecord + -- test comment + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor a b + +#test normal records on multi line indent policy left +-- brittany {lconfig_indentPolicy: IndentPolicyLeft } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] + +#test normal records on multi line indent policy free +-- brittany {lconfig_indentPolicy: IndentPolicyFree } +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] + +#test normal records on multi line indent policy free 2 +-- brittany {lconfig_indentPolicy: IndentPolicyFree } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] + +#test normal records on multi line indent policy multiple +-- brittany {lconfig_indentPolicy: IndentPolicyMultiple } +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] + +#test large record with a comment +data XIILqcacwiuNiu = XIILqcacwiuNiu + { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo + , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg] + , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo + , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo + , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int + , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq + , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq + , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo + , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn + , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo + , opjUxtkxzkiKse_luqjuZazt + :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)] + -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh () + , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo + , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn + , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn + , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn + , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn + , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep + , jeyOcuesexaYoy_vpqn :: Jgtoyuh () + } + +############################################################################### +############################################################################### +############################################################################### #group equation.basic ############################################################################### ############################################################################### @@ -704,8 +1001,7 @@ , test7 , test8 , test9 - ) -where + ) where #test exports-with-comments module Main @@ -719,8 +1015,7 @@ -- Test 5 , test5 -- Test 6 - ) -where + ) where #test simple-export-with-things module Main (Test(..)) where @@ -738,7 +1033,7 @@ ( Test(Test, a, b) , foo -- comment2 ) -- comment3 -where + where #test export-with-empty-thing module Main (Test()) where @@ -989,8 +1284,7 @@ , test9 , test10 -- Test 10 - ) -where + ) where -- Test import Data.List ( nub ) -- Test @@ -1093,7 +1387,15 @@ type ((a :+: b) c) = (a, c) +#test synonym-tuple-type-many-comments +type Foo + = ( -- t1 + A -- t2 + , -- t3 + B -- t4 + ) -- t5 + ############################################################################### ############################################################################### ############################################################################### @@ -1207,6 +1509,24 @@ { intData :: String -- ^ Interesting field , intData2 :: Int + } + +#test instance-with-newtype-family-and-deriving + +{-# LANGUAGE TypeFamilies #-} + +module Lib where + +instance Foo () where + newtype Bar () = Baz () + deriving (Eq, Ord, Show) + bar = Baz + +#test instance-with-newtype-family-and-record + +instance Foo Int where + newtype Bar Int = BarInt + { unBarInt :: Int } diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt --- a/src-literatetests/14-extensions.blt +++ b/src-literatetests/14-extensions.blt @@ -83,6 +83,90 @@ ) ############################################################################### +## PatternSynonyms +#test bidirectional pattern +{-# LANGUAGE PatternSynonyms #-} +pattern J x = Just x + +#test unidirection pattern +{-# LANGUAGE PatternSynonyms #-} +pattern F x <- (x, _) + +#test explicitly bidirectional pattern +{-# LANGUAGE PatternSynonyms #-} +pattern HeadC x <- x : xs where + HeadC x = [x] + +#test Multiple arguments +{-# LANGUAGE PatternSynonyms #-} +pattern Head2 x y <- x : y : xs where + Head2 x y = [x, y] + +#test Infix argument +{-# LANGUAGE PatternSynonyms #-} +pattern x :> y = [x, y] + +#test Record argument +{-# LANGUAGE PatternSynonyms #-} +pattern MyData { a, b, c } = [a, b, c] + +#test long pattern match +{-# LANGUAGE PatternSynonyms #-} +pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName = + [myLongLeftVariableName, myLongRightVariableName] + +#test long explicitly bidirectional match +{-# LANGUAGE PatternSynonyms #-} +pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <- + [myLongLeftVariableName, myLongRightVariableName] where + MyInfixPatternMatcher x y = [x, x, y] + +#test Pattern synonym types +{-# LANGUAGE PatternSynonyms #-} +pattern J :: a -> Maybe a +pattern J x = Just x + +#test pattern synonym bidirectional multiple cases +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x + +#test pattern synonym bidirectional multiple cases long +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed xxxxxxxxxxxxxxxxxxxxxxxx <- + (asSigned -> xxxxxxxxxxxxxxxxxxxxxxxx) where + Signed (Neg x) = -x + Signed Zero = 0 + Signed (Pos x) = x + +#test pattern synonym bidirectional multiple cases with comments +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +pattern Signed x <- (asSigned -> x) where + Signed (Neg x) = -x -- negative comment + Signed Zero = 0 -- zero comment + Signed (Pos x) = x -- positive comment + +#test Pattern synonym types multiple names +#min-ghc 8.2 +{-# LANGUAGE PatternSynonyms #-} +pattern J, K :: a -> Maybe a + +#test Pattern synonym type sig wrapped +{-# LANGUAGE PatternSynonyms #-} +pattern LongMatcher + :: longlongtypevar + -> longlongtypevar + -> longlongtypevar + -> Maybe [longlongtypevar] +pattern LongMatcher x y z = Just [x, y, z] + + +############################################################################### ## UnboxedTuples + MagicHash #test unboxed-tuple and vanilla names {-# LANGUAGE UnboxedTuples #-} diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -363,14 +363,13 @@ #test recordupd-singleline-bug runBrittany tabSize text = do - let - config' = staticDefaultConfig - config = config' - { _conf_layout = (_conf_layout config') { _lconfig_indentAmount = coerce - tabSize - } - , _conf_forward = forwardOptionsSyntaxExtsEnabled - } + let config' = staticDefaultConfig + config = config' + { _conf_layout = (_conf_layout config') + { _lconfig_indentAmount = coerce tabSize + } + , _conf_forward = forwardOptionsSyntaxExtsEnabled + } parsePrintModule config text #test recordupd-singleline-bug-left @@ -770,3 +769,117 @@ , -- N.B. .. -- x } + +#test issue 263 + +func = abc + def + -- a + -- b + + -- comment + + where + abc = 13 + def = 1 + +#test AddBaseY/EnsureIndent float in effect + +zItazySunefp twgq nlyo lwojjoBiecao = + let mhIarjyai = + ukwAausnfcn + $ XojlsTOSR.vuwOvuvdAZUOJaa + $ XojlsTOSR.vkesForanLiufjeDI + $ XojlsTOSR.vkesForanLiufjeDI + $ XojlsTOSR.popjAyijoWarueeP + $ XojlsTOSR.jpwuPmafuDqlbkt nlyo + $ XojlsTOSR.jpwuPmafuDqlbkt xxneswWhxwng + $ XojlsTOSR.jpwuPmafuDqlbkt oloCuxeDdow + $ XojlsTOSR.jpwuPmafuDqlbkt (uwurrvoNnukzefuDjeh lwojjoBiecao nlyo) + $ etOslnoz lwojjoBiecao + in kucotg $ (bbbr, Yoxe.Dwzbuzi.zrLokoTnuy piv) + +#test module initial comment +-- test +module MyModule where + +#test issue 231 + +foo = + [ ("xxx", "xx") + , -- + ("xx" , "xx") + -- + , ("xx" , "xxxxx") + , ("xx" , "xx") + ] + +#test issue 231 not + +foo = + [ ("xx", "xx") + , ( "xx" -- + , "xx" + ) + , ("xx", "xxxxx") + , ("xx", "xx") + ] + +#test issue 281 + +module Main + ( DataTypeI + , DataTypeII(DataConstructor) + -- * Haddock heading + , name + ) where + +#test type level list + +xeoeqibIaib + :: ( KqujhIsaus m + , XivuvIpoboi Droqifim m + , IgorvOtowtf m + , RyagaYaqac m + , QouruDU m + ) + => MaptAdfuxgu + -> Zcnxg NsxayqmvIjsezea -- ^ if Lvqucoo, opsip jl reyoyhk lfil qaculxgd + -> QNOZqwuzg + -> Eoattuq + '[ XkatytdWdquraosu -- test comment + , KyezKijim -- another test comment + , DjmioeePuoeg + , NinrxoiOwezc + , QATAlrijacpk + , TrutvotwIwifiqOjdtu + , CoMmuatjwr + , BoZckzqyodseZole + , VagfwoXaeChfqe + ] + m + () + +#test recordupd-overflow-bad-multiline-spacing + +createRedirectedProcess processConfig = do + let redirectedProc = (_processConfig_inner processConfig) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + foo + +#test issue 282 + +instance HasDependencies SomeDataModel where + -- N.B. Here is a bunch of explanatory context about the relationship + -- between these data models or whatever. + type Dependencies SomeDataModel + = (SomeOtherDataModelId, SomeOtherOtherDataModelId) + +#test stupid-do-operator-combination + +func = + do + y + >>= x diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -315,6 +315,51 @@ ############################################################################### ############################################################################### ############################################################################### +#group data type declarations +############################################################################### +############################################################################### +############################################################################### + +#test single record +data Foo = Bar + { foo :: Baz + } + +#test record multiple names +data Foo = Bar + { foo, bar :: Baz + } + +#test record multiple types +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + +#test record multiple types and names +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } + +#test record multiple types deriving +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving Show + +#test record multiple types deriving +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) + + +############################################################################### +############################################################################### +############################################################################### #group equation.basic ############################################################################### ############################################################################### @@ -630,8 +675,7 @@ , test7 , test8 , test9 - ) -where + ) where #test exports-with-comments module Main @@ -645,8 +689,7 @@ -- Test 5 , test5 -- Test 6 - ) -where + ) where #test simple-export-with-things module Main (Test(..)) where @@ -868,8 +911,7 @@ , test8 , test9 , test10 - ) -where + ) where -- Test import Data.List (nub) -- Test @@ -1162,6 +1204,12 @@ ReflexHost.newExternalEvent liftIO . forkIO . forever $ getLine >>= inputFire ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent + +#test issue 15 +-- Test.hs +module Test where + +data X = X #test issue 16 foldrDesc f z = unSwitchQueue $ \q -> diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -1,42 +1,54 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} -module Main (main) where +module Main + ( main + ) +where #include "prelude.inc" -import Test.Hspec -import Test.Hspec.Runner ( hspecWith, defaultConfig, configConcurrentJobs ) - -import NeatInterpolation +import Test.Hspec +import Test.Hspec.Runner ( hspecWith + , defaultConfig + , configConcurrentJobs + ) -import qualified Text.Parsec as Parsec -import Text.Parsec.Text ( Parser ) +import qualified Text.Parsec as Parsec +import Text.Parsec.Text ( Parser ) -import Data.Char ( isSpace ) -import Data.List ( groupBy ) +import Data.Char ( isSpace ) +import Data.List ( groupBy ) -import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config -import Data.Coerce ( coerce ) +import Data.Coerce ( coerce ) -import qualified Data.Text.IO as Text.IO -import System.FilePath ( () ) +import qualified Data.Text.IO as Text.IO +import System.FilePath ( () ) data InputLine = GroupLine Text | HeaderLine Text + | GhcVersionGuardLine Text | PendingLine | NormalLine Text | CommentLine deriving Show +data TestCase = TestCase + { testName :: Text + , isPending :: Bool + , minGHCVersion :: Maybe Text + , content :: Text + } main :: IO () main = do @@ -44,28 +56,39 @@ let blts = List.sort $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) - $ filter (".blt"`isSuffixOf`) files + $ filter (".blt" `isSuffixOf`) files inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" blt) let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree + let parseVersion :: Text -> Maybe [Int] + parseVersion = + mapM (readMaybe . Text.unpack) . Text.splitOn (Text.pack ".") + let ghcVersion = Data.Maybe.fromJust $ parseVersion $ Text.pack VERSION_ghc + let checkVersion = \case + Nothing -> True -- no version constraint + Just s -> case parseVersion s of + Nothing -> error $ "could not parse version " ++ Text.unpack s + Just v -> v <= ghcVersion hspec $ do groups `forM_` \(groupname, tests) -> do - describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do - (if pend then before_ pending else id) - $ it (Text.unpack name) - $ roundTripEqual defaultTestConfig inp + describe (Text.unpack groupname) $ do + tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do + (if isPending test then before_ pending else id) + $ it (Text.unpack $ testName test) + $ roundTripEqual defaultTestConfig + $ content test groupsCtxFree `forM_` \(groupname, tests) -> do - describe ("context free: " ++ Text.unpack groupname) - $ tests - `forM_` \(name, pend, inp) -> do - (if pend then before_ pending else id) - $ it (Text.unpack name) - $ roundTripEqual contextFreeTestConfig inp + describe ("context free: " ++ Text.unpack groupname) $ do + tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do + (if isPending test then before_ pending else id) + $ it (Text.unpack $ testName test) + $ roundTripEqual contextFreeTestConfig + $ content test where -- this function might be implemented in a weirdly complex fashion; the -- reason being that it was copied from a somewhat more complex variant. - createChunks :: Text -> [(Text, [(Text, Bool, Text)])] + createChunks :: Text -> [(Text, [TestCase])] createChunks input = -- fmap (\case -- HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines) @@ -73,35 +96,39 @@ -- l -> error $ "first non-empty line must start with #test footest\n" ++ show l -- ) -- $ fmap (groupBy grouperT) - fmap - ( \case - GroupLine g:grouprest -> - (,) g - $ fmap - ( \case - HeaderLine n:PendingLine:rest | Just rlines <- mapM - extractNormal - rest -> - (n, True, Text.unlines rlines) - HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> - (n, False, Text.unlines rlines) - l -> - error - $ "first non-empty line must start with #test footest\n" - ++ show l - ) - $ groupBy grouperT - $ filter (not . lineIsSpace) - $ grouprest - l -> error $ "first non-empty line must be a #group\n" ++ show l - ) - $ groupBy grouperG - $ filter (not . lineIsSpace) - $ lineMapper - <$> Text.lines input + fmap groupProcessor + $ groupBy grouperG + $ filter (not . lineIsSpace) + $ fmap lineMapper + $ Text.lines input where + groupProcessor :: [InputLine] -> (Text, [TestCase]) + groupProcessor = \case + GroupLine g : grouprest -> + (,) g + $ fmap testProcessor + $ groupBy grouperT + $ filter (not . lineIsSpace) + $ grouprest + l -> error $ "first non-empty line must be a #group\n" ++ show l + testProcessor :: [InputLine] -> TestCase + testProcessor = \case + HeaderLine n : rest -> + let normalLines = Data.Maybe.mapMaybe extractNormal rest + in TestCase + { testName = n + , isPending = any isPendingLine rest + , minGHCVersion = Data.List.Extra.firstJust extractMinGhc rest + , content = Text.unlines normalLines + } + l -> + error $ "first non-empty line must start with #test footest\n" ++ show l extractNormal (NormalLine l) = Just l extractNormal _ = Nothing + extractMinGhc (GhcVersionGuardLine v) = Just v + extractMinGhc _ = Nothing + isPendingLine PendingLine{} = True + isPendingLine _ = False specialLineParser :: Parser InputLine specialLineParser = Parsec.choice [ [ GroupLine $ Text.pack name @@ -116,6 +143,11 @@ , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , _ <- Parsec.eof ] + , [ GhcVersionGuardLine $ Text.pack version + | _ <- Parsec.try $ Parsec.string "#min-ghc" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" + , version <- Parsec.many1 $ Parsec.noneOf "\r\n:" + ] , [ PendingLine | _ <- Parsec.try $ Parsec.string "#pending" , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") @@ -123,8 +155,8 @@ ] , [ CommentLine | _ <- Parsec.many $ Parsec.oneOf " \t" - , _ <- - Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n") + , _ <- Parsec.optional $ Parsec.string "##" <* many + (Parsec.noneOf "\r\n") , _ <- Parsec.eof ] ] @@ -148,8 +180,7 @@ -------------------- roundTripEqual :: Config -> Text -> Expectation roundTripEqual c t = - fmap (fmap PPTextWrapper) - (parsePrintModuleTests c "TestFakeFileName.hs" t) + fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t) `shouldReturn` Right (PPTextWrapper t) newtype PPTextWrapper = PPTextWrapper Text @@ -158,7 +189,8 @@ instance Show PPTextWrapper where show (PPTextWrapper t) = "\n" ++ Text.unpack t - +-- brittany-next-binding --columns 160 +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } defaultTestConfig :: Config defaultTestConfig = Config { _conf_version = _conf_version staticDefaultConfig @@ -180,22 +212,21 @@ , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False - } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) - { _econf_omit_output_valid_check = coerce True + -- , _lconfig_allowSinglelineRecord = coerce False } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions {_options_ghc = Identity []} + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_obfuscate = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } contextFreeTestConfig :: Config -contextFreeTestConfig = - defaultTestConfig +contextFreeTestConfig = defaultTestConfig { _conf_layout = (_conf_layout defaultTestConfig) - {_lconfig_indentPolicy = coerce IndentPolicyLeft - ,_lconfig_alignmentLimit = coerce (1 :: Int) - ,_lconfig_columnAlignMode = coerce ColumnAlignModeDisabled - } + { _lconfig_indentPolicy = coerce IndentPolicyLeft + , _lconfig_alignmentLimit = coerce (1 :: Int) + , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled + } } diff --git a/src-unittests/AsymptoticPerfTests.hs b/src-unittests/AsymptoticPerfTests.hs --- a/src-unittests/AsymptoticPerfTests.hs +++ b/src-unittests/AsymptoticPerfTests.hs @@ -11,8 +11,6 @@ import Test.Hspec -import NeatInterpolation - import Language.Haskell.Brittany.Internal import TestUtils diff --git a/src-unittests/TestMain.hs b/src-unittests/TestMain.hs --- a/src-unittests/TestMain.hs +++ b/src-unittests/TestMain.hs @@ -8,8 +8,6 @@ import Test.Hspec -import NeatInterpolation - import Language.Haskell.Brittany.Internal import AsymptoticPerfTests diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -8,7 +8,7 @@ import Test.Hspec -import NeatInterpolation +-- import NeatInterpolation import Language.Haskell.Brittany.Internal @@ -61,6 +61,7 @@ , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever @@ -68,5 +69,6 @@ , _conf_preprocessor = (_conf_preprocessor staticDefaultConfig) , _conf_forward = ForwardOptions {_options_ghc = Identity []} , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False , _conf_obfuscate = coerce False } diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -51,13 +51,15 @@ import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Indent -import qualified GHC as GHC +import qualified GHC as GHC hiding ( parseModule ) import ApiAnnotation ( AnnKeywordId(..) ) -import GHC ( runGhc +import GHC ( Located + , runGhc , GenLocated(L) , moduleNameString ) +import RdrName ( RdrName(..) ) import SrcLoc ( SrcSpan ) import HsSyn import qualified DynFlags as GHC @@ -158,6 +160,12 @@ Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl + let disableFormatting = do + Butcher.addCmdImpl + ( InlineConfigTargetModule + , mempty { _conf_disable_formatting = pure $ pure True } + ) + Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "@" $ do -- Butcher.addCmd "module" $ do -- conf <- configParser @@ -264,38 +272,47 @@ (inlineConf, perItemConf) <- either (throwE . (: []) . uncurry ErrorMacroConfig) pure $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) - let moduleConfig = cZipWith fromOptionIdentity config inlineConf - (errsWarns, outputTextL) <- do - let omitCheck = - moduleConfig - & _conf_errorHandling - & _econf_omit_output_valid_check - & confUnpack - (ews, outRaw) <- if hasCPP || omitCheck - then return $ pPrintModule moduleConfig perItemConf anns parsedSource - else lift - $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource - let hackF s = fromMaybe s - $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s - pure $ if hackAroundIncludes - then - ( ews - , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn - (TextL.pack "\n") - outRaw - ) - else (ews, outRaw) - let customErrOrder ErrorInput{} = 4 - customErrOrder LayoutWarning{} = 0 :: Int - customErrOrder ErrorOutputCheck{} = 1 - customErrOrder ErrorUnusedComment{} = 2 - customErrOrder ErrorUnknownNode{} = 3 - customErrOrder ErrorMacroConfig{} = 5 - let hasErrors = - case moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack of - False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) - True -> not $ null errsWarns - if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL + let moduleConfig = cZipWith fromOptionIdentity config inlineConf + let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack + if disableFormatting + then do + return inputText + else do + (errsWarns, outputTextL) <- do + let omitCheck = + moduleConfig + & _conf_errorHandling + & _econf_omit_output_valid_check + & confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return $ pPrintModule moduleConfig perItemConf anns parsedSource + else lift + $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource + let hackF s = fromMaybe s + $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s + pure $ if hackAroundIncludes + then + ( ews + , TextL.intercalate (TextL.pack "\n") $ fmap hackF $ TextL.splitOn + (TextL.pack "\n") + outRaw + ) + else (ews, outRaw) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = 0 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = 3 + customErrOrder ErrorMacroConfig{} = 5 + let hasErrors = + case + moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack + of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + if hasErrors + then throwE $ errsWarns + else pure $ TextL.toStrict outputTextL @@ -458,9 +475,15 @@ let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack toLocal config' filteredAnns $ do - bd <- briDocMToPPM $ if exactprintOnly - then briDocByExactNoComment decl - else layoutDecl decl + bd <- if exactprintOnly + then briDocMToPPM $ briDocByExactNoComment decl + else do + (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl + mTell debugs + mTell errs + if null errs + then pure r + else briDocMToPPM $ briDocByExactNoComment decl layoutBriDoc bd let finalComments = filter @@ -485,7 +508,6 @@ in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () - getDeclBindingNames :: LHsDecl GhcPs -> [String] #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ getDeclBindingNames (L _ decl) = case decl of @@ -519,7 +541,7 @@ let (filteredAnns', post) = - case (ExactPrint.mkAnnKey lmod) `Map.lookup` filteredAnns of + case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of Nothing -> (filteredAnns, []) Just mAnn -> let @@ -535,23 +557,7 @@ (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' } + mAnn' = mAnn { ExactPrint.annsDP = pre } filteredAnns'' = Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns in @@ -650,6 +656,7 @@ , _lstate_comments = anns , _lstate_commentCol = Nothing , _lstate_addSepSpace = Nothing + , _lstate_commentNewlines = 0 } state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -174,14 +174,15 @@ priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do + let commentLines = Text.lines $ Text.pack $ comment case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) -- ^ evil hack for CPP - _ -> layoutMoveToCommentPos y x + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y - layoutWriteAppendMultiline $ Text.pack $ comment + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } when allowMTEL $ moveToExactAnn annKey layoutBriDocM bd @@ -214,14 +215,15 @@ Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do + let commentLines = Text.lines $ Text.pack $ comment -- evil hack for CPP: case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) - _ -> layoutMoveToCommentPos y x + ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y - layoutWriteAppendMultiline $ Text.pack $ comment + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDAnnotationRest annKey bd -> do layoutBriDocM bd @@ -256,17 +258,18 @@ Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> when (not $ comment == "(" || comment == ")") $ do + let commentLines = Text.lines $ Text.pack comment case comment of - ('#':_) -> layoutMoveToCommentPos y (-999) + ('#':_) -> layoutMoveToCommentPos y (-999) 1 -- ^ evil hack for CPP ")" -> pure () -- ^ fixes the formatting of parens -- on the lhs of type alias defs - _ -> layoutMoveToCommentPos y x + _ -> layoutMoveToCommentPos y x (length commentLines) -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline -- layoutMoveToIndentCol y - layoutWriteAppendMultiline $ Text.pack $ comment + layoutWriteAppendMultiline commentLines -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do mDP <- do @@ -278,16 +281,20 @@ , (ExactPrint.Types.G kw1, dp) <- ann , keyword == kw1 ] - -- mTell $ Seq.fromList ["KWDP: " ++ show annKey ++ " " ++ show mAnn] - pure $ case relevant of - [] -> Nothing - (dp:_) -> Just dp + -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] + case relevant of + [] -> pure Nothing + (ExactPrint.Types.DP (y, x):_) -> do + mSet state { _lstate_commentNewlines = 0 } + pure $ Just (y - _lstate_commentNewlines state, x) case mDP of Nothing -> pure () - Just (ExactPrint.Types.DP (y, x)) -> - layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) + Just (y, x) -> + -- we abuse this, as we probably will print the KW next, which is + -- _not_ a comment.. + layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutBriDocM bd - BDNonBottomSpacing bd -> layoutBriDocM bd + BDNonBottomSpacing _ bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do @@ -321,15 +328,15 @@ BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_:_) -> do + BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd - BDDebug _ bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc @@ -363,9 +370,9 @@ BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd BDDebug _ bd -> rec bd -- In theory @@ -551,6 +558,8 @@ (BDCols ColBindStmt _) -> True (BDCols ColDoLet _) -> True (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False (BDCols ColListComp _) -> False (BDCols ColList _) -> False (BDCols ColApp{} _) -> True diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -122,12 +122,12 @@ , MonadMultiState LayoutState m , MonadMultiWriter (Seq String) m ) - => Text + => [Text] -> m () -layoutWriteAppendMultiline t = do - traceLocal ("layoutWriteAppendMultiline", t) - case Text.lines t of - [] -> layoutWriteAppend t -- need to write empty, too. +layoutWriteAppendMultiline ts = do + traceLocal ("layoutWriteAppendMultiline", ts) + case ts of + [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. (l:lr) -> do layoutWriteAppend l lr `forM_` \x -> do @@ -173,6 +173,8 @@ unless (Data.Maybe.isJust $ _lstate_commentCol state) $ mSet state { _lstate_commentCol = Just col } +-- This is also used to move to non-comments in a couple of places. Seems +-- to be harmless so far.. layoutMoveToCommentPos :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m @@ -180,9 +182,10 @@ ) => Int -> Int + -> Int -> m () -layoutMoveToCommentPos y x = do - traceLocal ("layoutMoveToCommentPos", y, x) +layoutMoveToCommentPos y x commentLines = do + traceLocal ("layoutMoveToCommentPos", y, x, commentLines) state <- mGet mSet state { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of @@ -200,6 +203,8 @@ Nothing -> case _lstate_curYOrAddNewline state of Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Right{} -> lstate_baseY state + , _lstate_commentNewlines = + _lstate_commentNewlines state + y + commentLines - 1 } -- | does _not_ add spaces to again reach the current base column. @@ -219,6 +224,10 @@ , _lstate_addSepSpace = Nothing } +_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () +_layoutResetCommentNewlines = do + mModify $ \state -> state { _lstate_commentNewlines = 0 } + layoutWriteEnsureNewlineBlock :: ( MonadMultiWriter Text.Builder.Builder m , MonadMultiState LayoutState m @@ -245,9 +254,10 @@ -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet - let diff = case _lstate_curYOrAddNewline state of - Left i -> n - i - Right{} -> n + let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c , _ ) -> n - c + (Nothing, Left i ) -> n - i + (Nothing, Right{}) -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to @@ -521,7 +531,7 @@ ) -> do replicateM_ x layoutWriteNewline layoutWriteAppendSpaces y - layoutWriteAppendMultiline $ Text.pack $ comment + layoutWriteAppendMultiline $ Text.lines $ Text.pack comment -- TODO: update and use, or clean up. Currently dead code. -- this currently only extracs from the `annsDP` field of Annotations. @@ -557,7 +567,8 @@ ) -> do replicateM_ x layoutWriteNewline layoutWriteAppend $ Text.pack $ replicate y ' ' - layoutWriteAppendMultiline $ Text.pack $ comment + mModify $ \s -> s { _lstate_addSepSpace = Nothing } + layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment layoutIndentRestorePostComment :: ( MonadMultiState LayoutState m @@ -572,7 +583,9 @@ #if INSERTTRACES tellDebugMessShow ("layoutIndentRestorePostComment", mCommentCol) #endif - mModify $ \s -> s { _lstate_commentCol = Nothing } + mModify $ \s -> s { _lstate_commentCol = Nothing + , _lstate_commentNewlines = 0 + } case (mCommentCol, eCurYAddNL) of (Just commentCol, Left{}) -> do layoutWriteEnsureNewlineBlock diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -29,24 +29,28 @@ import Data.CZipWith import UI.Butcher.Monadic -import Data.Monoid ((<>)) +import Data.Monoid ( (<>) ) -import qualified System.Console.CmdArgs.Explicit as CmdArgs +import qualified System.Console.CmdArgs.Explicit + as CmdArgs import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types.Instances import Language.Haskell.Brittany.Internal.Utils -import Data.Coerce ( Coercible, coerce ) -import qualified Data.List.NonEmpty as NonEmpty +import Data.Coerce ( Coercible + , coerce + ) +import qualified Data.List.NonEmpty as NonEmpty -import qualified System.Directory as Directory -import qualified System.FilePath.Posix as FilePath +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config staticDefaultConfig = Config - { _conf_version = coerce (1 :: Int) - , _conf_debug = DebugConfig + { _conf_version = coerce (1 :: Int) + , _conf_debug = DebugConfig { _dconf_dump_config = coerce False , _dconf_dump_annotations = coerce False , _dconf_dump_ast_unknown = coerce False @@ -60,60 +64,60 @@ , _dconf_dump_bridoc_final = coerce False , _dconf_roundtrip_exactprint_only = coerce False } - , _conf_layout = LayoutConfig - { _lconfig_cols = coerce (80 :: Int) - , _lconfig_indentPolicy = coerce IndentPolicyFree - , _lconfig_indentAmount = coerce (2 :: Int) - , _lconfig_indentWhereSpecial = coerce True - , _lconfig_indentListSpecial = coerce True - , _lconfig_importColumn = coerce (50 :: Int) - , _lconfig_importAsColumn = coerce (50 :: Int) - , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) - , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) - , _lconfig_alignmentLimit = coerce (30 :: Int) - , _lconfig_alignmentBreakOnMultiline = coerce True - , _lconfig_hangingTypeSignature = coerce False - , _lconfig_reformatModulePreamble = coerce True - , _lconfig_allowSingleLineExportList = coerce False - , _lconfig_allowHangingQuasiQuotes = coerce True + , _conf_layout = LayoutConfig + { _lconfig_cols = coerce (80 :: Int) + , _lconfig_indentPolicy = coerce IndentPolicyFree + , _lconfig_indentAmount = coerce (2 :: Int) + , _lconfig_indentWhereSpecial = coerce True + , _lconfig_indentListSpecial = coerce True + , _lconfig_importColumn = coerce (50 :: Int) + , _lconfig_importAsColumn = coerce (50 :: Int) + , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) + , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) + , _lconfig_alignmentLimit = coerce (30 :: Int) + , _lconfig_alignmentBreakOnMultiline = coerce True + , _lconfig_hangingTypeSignature = coerce False + , _lconfig_reformatModulePreamble = coerce True + , _lconfig_allowSingleLineExportList = coerce False + , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False } - , _conf_errorHandling = ErrorHandlingConfig + , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False , _econf_Werror = coerce False , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_omit_output_valid_check = coerce False } - , _conf_preprocessor = PreProcessorConfig + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = coerce CPPModeAbort , _ppconf_hackAroundIncludes = coerce False } - , _conf_forward = ForwardOptions - { _options_ghc = Identity [] - } - , _conf_roundtrip_exactprint_only = coerce False - , _conf_obfuscate = coerce False + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } + , _conf_roundtrip_exactprint_only = coerce False + , _conf_disable_formatting = coerce False + , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions { _options_ghc = Identity - [ "-XLambdaCase" - , "-XMultiWayIf" - , "-XGADTs" - , "-XPatternGuards" - , "-XViewPatterns" - , "-XTupleSections" - , "-XExplicitForAll" - , "-XImplicitParams" - , "-XQuasiQuotes" - , "-XTemplateHaskell" - , "-XBangPatterns" - , "-XTypeApplications" - ] + [ "-XLambdaCase" + , "-XMultiWayIf" + , "-XGADTs" + , "-XPatternGuards" + , "-XViewPatterns" + , "-XTupleSections" + , "-XExplicitForAll" + , "-XImplicitParams" + , "-XQuasiQuotes" + , "-XTemplateHaskell" + , "-XBangPatterns" + , "-XTypeApplications" + ] } --- brittany-next-binding --columns=200 +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } cmdlineConfigParser :: CmdParser Identity out (CConfig Option) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! @@ -129,28 +133,24 @@ dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") - dumpBriDocFloating <- addSimpleBoolFlag "" - ["dump-bridoc-floating"] - (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") - dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") - 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") + dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") + dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") + 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)") - 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)") + 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)") - roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") + roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") - optionsGhc <- addFlagStringParams "" - ["ghc-options"] - "STRING" - (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") - obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") + optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") + disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") + obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config - { _conf_version = mempty - , _conf_debug = DebugConfig + { _conf_version = mempty + , _conf_debug = DebugConfig { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST @@ -164,39 +164,36 @@ , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal , _dconf_roundtrip_exactprint_only = mempty } - , _conf_layout = LayoutConfig - { _lconfig_cols = optionConcat cols - , _lconfig_indentPolicy = mempty - , _lconfig_indentAmount = optionConcat ind - , _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 - , _lconfig_allowHangingQuasiQuotes = mempty + , _conf_layout = LayoutConfig + { _lconfig_cols = optionConcat cols + , _lconfig_indentPolicy = mempty + , _lconfig_indentAmount = optionConcat ind + , _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 + , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty + -- , _lconfig_allowSinglelineRecord = mempty } - , _conf_errorHandling = ErrorHandlingConfig + , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors , _econf_Werror = wrapLast $ falseToNothing wError , _econf_ExactPrintFallback = mempty , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck } - , _conf_preprocessor = PreProcessorConfig - { _ppconf_CPPMode = mempty - , _ppconf_hackAroundIncludes = mempty - } - , _conf_forward = ForwardOptions - { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] - } - , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly - , _conf_obfuscate = wrapLast $ falseToNothing obfuscate + , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } + , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } + , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly + , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting + , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Option . Bool.bool Nothing (Just True) @@ -260,19 +257,21 @@ userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" let searchDirs = [userBritPathSimple, userBritPathXdg] - globalConfig <- Directory.findFileWith Directory.doesFileExist searchDirs "config.yaml" + 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 + 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 + 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" @@ -284,7 +283,8 @@ -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do configs <- readConfig `mapM` configPaths - let merged = Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) + let merged = Semigroup.sconcat + $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs @@ -304,7 +304,6 @@ staticDefaultConfig showConfigYaml :: Config -> String -showConfigYaml = Data.ByteString.Char8.unpack - . Data.Yaml.encode - . cMap (\(Identity x) -> Just x) +showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap + (\(Identity x) -> Just x) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -142,6 +142,14 @@ -- The implementation for this is a bit hacky and not tested; it might -- break output syntax or not work properly for every kind of brace. So -- far I have considered `do` and `case-of`. + -- , _lconfig_allowSinglelineRecord :: f (Last Bool) + -- -- if true, layouts record data decls as a single line when possible, e.g. + -- -- > MyPoint { x :: Double, y :: Double } + -- -- if false, always use the multi-line layout + -- -- > MyPoint + -- -- > { x :: Double + -- -- > , y :: Double + -- -- > } } deriving (Generic) @@ -179,11 +187,17 @@ , _conf_forward :: CForwardOptions f , _conf_preprocessor :: CPreProcessorConfig f , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) - , _conf_obfuscate :: f (Semigroup.Last Bool) -- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- It is used for per-declaration disabling by the inline config -- implementation. Could have re-used the existing field, but felt risky -- to use a "debug" labeled field for non-debug functionality. + , _conf_disable_formatting :: f (Semigroup.Last Bool) + -- ^ Used for inline config that disables brittany entirely for this + -- module. Useful for wildcard application + -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something + -- in that direction). + , _conf_obfuscate :: f (Semigroup.Last Bool) + } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs --- a/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs @@ -120,6 +120,7 @@ <*> v .:?= Text.pack "conf_forward" <*> v .:?= Text.pack "conf_preprocessor" <*> v .:? Text.pack "conf_roundtrip_exactprint_only" + <*> v .:? Text.pack "conf_disable_formatting" <*> v .:? Text.pack "conf_obfuscate" parseJSON invalid = Aeson.typeMismatch "Config" invalid diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -123,7 +123,7 @@ dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str case res of - Left (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err + Left (span, err) -> ExceptT.throwE $ showOutputable span ++ ": " ++ err Right (a , m ) -> pure (a, m, dynCheckRes) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -13,6 +13,7 @@ , filterAnns , docEmpty , docLit + , docLitS , docAlt , CollectAltM , addAlternativeCond @@ -39,6 +40,7 @@ , docAnnotationRest , docMoveToKWDP , docNonBottomSpacing + , docNonBottomSpacingS , docSetParSpacing , docForceParSpacing , docDebug @@ -60,9 +62,11 @@ , docTick , spacifyDocs , briDocMToPPM + , briDocMToPPMInner , allocateNode , docSharedWrapper , hasAnyCommentsBelow + , hasCommentsBetween , hasAnyCommentsConnected , hasAnyCommentsPrior , hasAnyRegularCommentsConnected @@ -296,6 +300,25 @@ List.any (\(c, _) -> ExactPrint.commentIdentifier c > l) <$> astConnectedComments ast +hasCommentsBetween + :: Data ast + => GHC.Located ast + -> AnnKeywordId + -> AnnKeywordId + -> ToBriDocM Bool +hasCommentsBetween ast leftKey rightKey = do + mAnn <- astAnn ast + let go1 [] = False + go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest + go1 (_ : rest) = go1 rest + go2 [] = False + go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True + go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False + go2 (_ : rest) = go2 rest + case mAnn of + Nothing -> pure False + Just ann -> pure $ go1 $ ExactPrint.annsDP ann + -- | True if there are any comments that are connected to any node below (in AST -- sense) the given node hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool @@ -481,6 +504,9 @@ docLit :: Text -> ToBriDocM BriDocNumbered docLit t = allocateNode $ BDFLit t +docLitS :: String -> ToBriDocM BriDocNumbered +docLitS s = allocateNode $ BDFLit $ Text.pack s + docExt :: (ExactPrint.Annotate.Annotate ast) => Located ast @@ -572,8 +598,11 @@ docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm +docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm +docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm + docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm @@ -642,18 +671,18 @@ class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) => Located ast - -> ToBriDocM a - -> ToBriDocM a + -> a + -> a docWrapNodePrior :: ( Data.Data.Data ast) => Located ast - -> ToBriDocM a - -> ToBriDocM a + -> a + -> a docWrapNodeRest :: ( Data.Data.Data ast) => Located ast - -> ToBriDocM a - -> ToBriDocM a + -> a + -> a -instance DocWrapable BriDocNumbered where +instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNode ast bdm = do bd <- bdm i1 <- allocNodeIndex @@ -679,7 +708,22 @@ $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd -instance DocWrapable a => DocWrapable [a] where +instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where + docWrapNode ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNode ast bd] + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> + [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] + _ -> error "cannot happen (TM)" + docWrapNodePrior ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNodePrior ast bd] + (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR + docWrapNodeRest ast bdms = case reverse bdms of + [] -> [] + (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where docWrapNode ast bdsm = do bds <- bdsm case bds of @@ -707,7 +751,7 @@ bdN' <- docWrapNodeRest ast (return bdN) return $ reverse (bdN':bdR) -instance DocWrapable a => DocWrapable (Seq a) where +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where docWrapNode ast bdsm = do bds <- bdsm case Seq.viewl bds of @@ -735,7 +779,7 @@ bdN' <- docWrapNodeRest ast (return bdN) return $ bdR Seq.|> bdN' -instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where +instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where docWrapNode ast stuffM = do (bds, bd, x) <- stuffM if null bds @@ -791,6 +835,13 @@ briDocMToPPM :: ToBriDocM a -> PPMLocal a briDocMToPPM m = do + (x, errs, debugs) <- briDocMToPPMInner m + mTell debugs + mTell errs + return x + +briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) +briDocMToPPMInner m = do readers <- MultiRWSS.mGetRawR let ((x, errs), debugs) = runIdentity @@ -800,9 +851,7 @@ $ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW $ m - mTell debugs - mTell errs - return x + pure (x, errs, debugs) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) docSharedWrapper f x = return <$> f x diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -0,0 +1,527 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE KindSignatures #-} + +module Language.Haskell.Brittany.Internal.Layouters.DataDecl + ( layoutDataDecl + ) +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 ( Located, runGhc, GenLocated(L), moduleNameString ) +import qualified GHC +import HsSyn +import Name +import BasicTypes +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) + +import Language.Haskell.Brittany.Internal.Layouters.Type +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Utils + +import Bag ( mapBagM ) + + + +layoutDataDecl + :: Located (TyClDecl GhcPs) + -> Located RdrName + -> LHsQTyVars GhcPs + -> HsDataDefn GhcPs + -> ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext +layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of +#else +layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of +#endif + -- newtype MyType a b = MyType .. +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> +#else + HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _conDoc)) -> +#endif + docWrapNode ltycl $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- fmap return $ createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLitS "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- fmap return $ createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "newtype" + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , rhsDoc + ] + _ -> briDocByExactNoComment ltycl + + + -- data MyData a b + -- (zero constructors) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> +#else + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> +#endif + docWrapNode ltycl $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + tyVarLine <- fmap return $ createBndrDoc bndrs + createDerivingPar mDerivs $ docSeq + [ appSep $ docLitS "data" + , lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + ] + + -- data MyData = MyData .. + -- data MyData = MyData { .. } +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> +#else + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> +#endif + case cons of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> +#else + (L _ (ConDeclH98 consName (Just (HsQTvs _ qvars _)) mRhsContext details _conDoc)) -> +#endif + docWrapNode ltycl $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- fmap return $ createBndrDoc bndrs + forallDocMay <- case createForallDoc qvars of + Nothing -> pure Nothing + Just x -> Just . pure <$> x + rhsContextDocMay <- case mRhsContext of + Nothing -> pure Nothing + Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt + rhsDoc <- fmap return $ createDetailsDoc consNameStr details + consDoc <- fmap pure + $ docNonBottomSpacing + $ case (forallDocMay, rhsContextDocMay) of + (Just forallDoc, Just rhsContextDoc) -> docLines + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq + [ docLitS "." + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + ] + (Just forallDoc, Nothing) -> docLines + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq [docLitS ".", docSeparator, rhsDoc] + ] + (Nothing, Just rhsContextDoc) -> docSeq + [ docLitS "=" + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] + createDerivingPar mDerivs $ docAlt + [ -- data D = forall a . Show a => D a + docSeq + [ docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline $ lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + ] + , docLitS "=" + , docSeparator + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + ] + , -- data D + -- = forall a . Show a => D a + docAddBaseY BrIndentRegular $ docPar + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + ( docSeq + [ docLitS "=" + , docSeparator + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + ] + ) + , -- data D + -- = forall a + -- . Show a => + -- D a + docAddBaseY BrIndentRegular $ docPar + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + consDoc + , -- data + -- Show a => + -- D + -- = forall a + -- . Show a => + -- D a + -- This alternative is only for -XDatatypeContexts. + -- But I think it is rather unlikely this will trigger without + -- -XDataTypeContexts, especially with the `docNonBottomSpacing` + -- above, so while not strictly necessary, this should not + -- hurt. + docAddBaseY BrIndentRegular $ docPar + (docLitS "data") + ( docLines + [ lhsContextDoc + , docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLit nameStr + , tyVarLine + ] + , consDoc + ] + ) + ] + _ -> briDocByExactNoComment ltycl + + _ -> briDocByExactNoComment ltycl + +createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered +createContextDoc [] = docEmpty +createContextDoc [t] = + docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] +createContextDoc (t1 : tR) = do + t1Doc <- docSharedWrapper layoutType t1 + tRDocs <- tR `forM` docSharedWrapper layoutType + docAlt + [ docSeq + [ docLitS "(" + , docForceSingleline $ docSeq $ List.intersperse docCommaSep + (t1Doc : tRDocs) + , docLitS ") =>" + , docSeparator + ] + , docLines $ join + [ [docSeq [docLitS "(", docSeparator, t1Doc]] + , tRDocs + <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , [docLitS ") =>", docSeparator] + ] + ] + +createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered +createBndrDoc bs = do + tyVarDocs <- bs `forM` \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar _ext lrdrName kind)) -> do +#else + (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do +#endif + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + (L _ (XTyVarBndr ext)) -> absurdExt ext +#endif + docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLitS "(" + , docLit vname + , docSeparator + , docLitS "::" + , docSeparator + , kind + , docLitS ")" + ] + +createDerivingPar + :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +createDerivingPar derivs mainDoc = do + case derivs of +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + (L _ []) -> mainDoc + (L _ types) -> + docPar mainDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ docWrapNode derivs + $ derivingClauseDoc + <$> types +#else + Nothing -> mainDoc + Just types -> + docPar mainDoc + $ docEnsureIndent BrIndentRegular + $ derivingClauseDoc types +#endif + +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered +#else +derivingClauseDoc :: Located [LHsSigType GhcPs] -> ToBriDocM BriDocNumbered +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext +derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ +derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of +#else +derivingClauseDoc types = case types of +#endif + (L _ []) -> docSeq [] + (L _ ts) -> + let + tsLength = length ts + whenMoreThan1Type val = + if tsLength > 1 then docLitS val else docLitS "" +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy +#else + (lhsStrategy, rhsStrategy) = (docEmpty, docEmpty) +#endif + in + docSeq + [ docDeriving + , docWrapNodePrior types $ lhsStrategy + , docSeparator + , whenMoreThan1Type "(" + , docWrapNodeRest types + $ docSeq + $ List.intersperse docCommaSep + $ ts <&> \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsIB _ t -> layoutType t + XHsImplicitBndrs x -> absurdExt x +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ + HsIB _ t _ -> layoutType t +#else + HsIB _ t -> layoutType t +#endif + , whenMoreThan1Type ")" + , rhsStrategy + ] +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.6 */ + where + strategyLeftRight = \case + (L _ StockStrategy ) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + lVia@(L _ (ViaStrategy viaTypes) ) -> + ( docEmpty + , case viaTypes of + HsIB _ext t -> docSeq + [ docWrapNode lVia $ docLitS " via" + , docSeparator + , layoutType t + ] + XHsImplicitBndrs ext -> absurdExt ext + ) +#endif +#endif + +docDeriving :: ToBriDocM BriDocNumbered +docDeriving = docLitS "deriving" + +createDetailsDoc + :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) +createDetailsDoc consNameStr details = case details of + PrefixCon args -> do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let + singleLine = docSeq + [ docLit consNameStr + , docSeparator + , docForceSingleline + $ docSeq + $ List.intersperse docSeparator + $ args <&> layoutType + ] + leftIndented = docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType <$> args + multiAppended = docSeq + [ docLit consNameStr + , docSeparator + , docSetBaseY $ docLines $ layoutType <$> args + ] + multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + (docLit consNameStr) + (docLines $ layoutType <$> args) + case indentPolicy of + IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] + IndentPolicyFree -> + docAlt [singleLine, multiAppended, multiIndented, leftIndented] + RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] + RecCon lRec@(L _ fields@(_:_)) -> do + let ((fName1, fType1) : fDocR) = mkFieldDocs fields + -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack + let allowSingleline = False + docAddBaseY BrIndentRegular + $ runFilteredAlternative + $ do + -- single-line: { i :: Int, b :: Bool } + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR + ] + , docSeparator + , docLitS "}" + ] + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines + [ docAlt + [ docCols ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName + , docSeq [docLitS "::", docSeparator] + , docForceSingleline fType + ] + , docSeq + [ docLitS "," + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName + (docSeq [docLitS "::", docSeparator, fType]) + ] + ] + , docLitS "}" + ] + ) + InfixCon arg1 arg2 -> docSeq + [ layoutType arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType arg2 + ] + where + mkFieldDocs + :: [LConDeclField GhcPs] + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] + mkFieldDocs = fmap $ \lField -> case lField of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t + L _ (XConDeclField x) -> absurdExt x +#else + L _ (ConDeclField names t _) -> createNamesAndTypeDoc lField names t +#endif + +createForallDoc :: [LHsTyVarBndr GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = Just $ docSeq + [docLitS "forall ", createBndrDoc lhsTyVarBndrs] + +createNamesAndTypeDoc + :: Data.Data.Data ast + => Located ast + -> [GenLocated t (FieldOcc GhcPs)] + -> Located (HsType GhcPs) + -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) +createNamesAndTypeDoc lField names t = + ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (XFieldOcc x) -> absurdExt x + L _ (FieldOcc _ fieldName) -> +#else + L _ (FieldOcc fieldName _) -> +#endif + docLit =<< lrdrNameToTextAnn fieldName + ] + , docWrapNodeRest lField $ layoutType t + ) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} module Language.Haskell.Brittany.Internal.Layouters.Decl ( layoutDecl @@ -53,6 +56,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Bag ( mapBagM, bagToList, emptyBag ) import Data.Char (isUpper) @@ -68,7 +72,7 @@ Right n -> return n TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD _ (TyFamInstD _ tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) + withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD _ (ClsInstD _ inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d @@ -80,12 +84,11 @@ Right n -> return n TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD (TyFamInstD tfid) -> - withTransformedAnns d $ layoutTyFamInstDecl False (L loc tfid) + withTransformedAnns d $ layoutTyFamInstDecl False d tfid InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst) _ -> briDocByExactNoComment d #endif - -------------------------------------------------------------------------------- -- Sig -------------------------------------------------------------------------------- @@ -93,11 +96,11 @@ layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType names typ + TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ - TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ + TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType Nothing names typ #else /* ghc-8.0 */ - TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ + TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType Nothing names typ #endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> @@ -121,15 +124,25 @@ <> nameStr <> Text.pack " #-}" #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType names typ + ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ #elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */ - ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ + ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType Nothing names typ #else /* ghc-8.0 */ - ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ + ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ #endif +#if MIN_VERSION_ghc(8,6,0) + PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ +#elif MIN_VERSION_ghc(8,2,0) + PatSynSig names (HsIB _ typ _) -> layoutNamesAndType (Just "pattern") names typ +#else + PatSynSig name (HsIB _ typ) -> layoutNamesAndType (Just "pattern") [name] typ +#endif _ -> briDocByExactNoComment lsig -- TODO where - layoutNamesAndType names typ = docWrapNode lsig $ do + layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do + let keyDoc = case mKeyword of + Just key -> [appSep . docLit $ Text.pack key] + Nothing -> [] nameStrs <- names `forM` lrdrNameToTextAnn let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs typeDoc <- docSharedWrapper layoutType typ @@ -139,8 +152,8 @@ .> _lconfig_hangingTypeSignature .> confUnpack if shouldBeHanging - then docSeq - [ appSep $ docWrapNodeRest lsig $ docLit nameStr + then docSeq $ + [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr] , docSetBaseY $ docLines [ docCols ColTyOpPrefix @@ -151,7 +164,7 @@ ] else layoutLhsAndType hasComments - (appSep . docWrapNodeRest lsig $ docLit nameStr) + (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr]) "::" typeDoc @@ -231,8 +244,18 @@ clauseDocs mWhereArg hasComments +#if MIN_VERSION_ghc(8,8,0) + PatSynBind _ (PSB _ patID lpat rpat dir) -> do +#elif MIN_VERSION_ghc(8,6,0) + PatSynBind _ (PSB _ patID lpat rpat dir) -> do +#else + PatSynBind (PSB patID _ lpat rpat dir) -> do +#endif + fmap Right $ docWrapNode lbind $ layoutPatSynBind patID + lpat + dir + rpat _ -> Right <$> unknownNodeError "" lbind - layoutIPBind :: ToBriDoc IPBind layoutIPBind lipbind@(L _ bind) = case bind of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ @@ -511,7 +534,9 @@ (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq - [appSep $ return binderDoc, docForceParSpacing $ return body] + [ appSep $ return binderDoc + , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body + ] ] ] ++ wherePartMultiLine @@ -709,7 +734,100 @@ ] ++ wherePartMultiLine +-- | Layout a pattern synonym binding +layoutPatSynBind + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> HsPatSynDir GhcPs + -> LPat GhcPs + -> ToBriDocM BriDocNumbered +layoutPatSynBind name patSynDetails patDir rpat = do + let patDoc = docLit $ Text.pack "pattern" + binderDoc = case patDir of + ImplicitBidirectional -> docLit $ Text.pack "=" + _ -> docLit $ Text.pack "<-" + body = colsWrapPat =<< layoutPat rpat + whereDoc = docLit $ Text.pack "where" + mWhereDocs <- layoutPatSynWhere patDir + headDoc <- fmap pure $ docSeq $ + [ patDoc + , docSeparator + , layoutLPatSyn name patSynDetails + , docSeparator + , binderDoc + ] + runFilteredAlternative $ do + addAlternative $ + -- pattern .. where + -- .. + -- .. + docAddBaseY BrIndentRegular $ docSeq + ( [headDoc, docSeparator, body] + ++ case mWhereDocs of + Just ds -> [docSeparator, docPar whereDoc (docLines ds)] + Nothing -> [] + ) + addAlternative $ + -- pattern .. = + -- .. + -- pattern .. <- + -- .. where + -- .. + -- .. + docAddBaseY BrIndentRegular $ docPar + headDoc + (case mWhereDocs of + Nothing -> body + Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds) + ) +-- | Helper method for the left hand side of a pattern synonym +layoutLPatSyn + :: Located (IdP GhcPs) + -> HsPatSynDetails (Located (IdP GhcPs)) + -> ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,4,0) +layoutLPatSyn name (PrefixCon vars) = do +#else +layoutLPatSyn name (PrefixPatSyn vars) = do +#endif + docName <- lrdrNameToTextAnn name + names <- mapM lrdrNameToTextAnn vars + docSeq . fmap appSep $ docLit docName : (docLit <$> names) +#if MIN_VERSION_ghc(8,4,0) +layoutLPatSyn name (InfixCon left right) = do +#else +layoutLPatSyn name (InfixPatSyn left right) = do +#endif + leftDoc <- lrdrNameToTextAnn left + docName <- lrdrNameToTextAnn name + rightDoc <- lrdrNameToTextAnn right + docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc] +#if MIN_VERSION_ghc(8,4,0) +layoutLPatSyn name (RecCon recArgs) = do +#else +layoutLPatSyn name (RecordPatSyn recArgs) = do +#endif + docName <- lrdrNameToTextAnn name + args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs + docSeq . fmap docLit + $ [docName, Text.pack " { " ] + <> intersperse (Text.pack ", ") args + <> [Text.pack " }"] + +-- | Helper method to get the where clause from of explicitly bidirectional +-- pattern synonyms +layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered]) +layoutPatSynWhere hs = case hs of +#if MIN_VERSION_ghc(8,6,0) + ExplicitBidirectional (MG _ (L _ lbinds) _) -> do +#else + ExplicitBidirectional (MG (L _ lbinds) _ _ _) -> do +#endif + binderDoc <- docLit $ Text.pack "=" + Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds + _ -> pure Nothing + -------------------------------------------------------------------------------- -- TyClDecl -------------------------------------------------------------------------------- @@ -741,6 +859,14 @@ let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ +#if MIN_VERSION_ghc(8,6,0) + DataDecl _ext name tyVars _ dataDefn -> +#elif MIN_VERSION_ghc(8,2,0) + DataDecl name tyVars _ dataDefn _ _ -> +#else + DataDecl name tyVars dataDefn _ _ -> +#endif + layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl layoutSynDecl @@ -817,39 +943,39 @@ -layoutTyFamInstDecl :: Bool -> ToBriDoc TyFamInstDecl -layoutTyFamInstDecl inClass (L loc tfid) = do +layoutTyFamInstDecl + :: Data.Data.Data a + => Bool + -> Located a + -> TyFamInstDecl GhcPs + -> ToBriDocM BriDocNumbered +layoutTyFamInstDecl inClass outerNode tfid = do let #if MIN_VERSION_ghc(8,8,0) - linst = L loc (TyFamInstD NoExt tfid) - feqn@(FamEqn _ name bndrsMay pats _fixity typ) = hsib_body $ tfid_eqn tfid + FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid -- bndrsMay isJust e.g. with -- type instance forall a . MyType (Maybe a) = Either () a - lfeqn = L loc feqn + innerNode = outerNode #elif MIN_VERSION_ghc(8,6,0) - linst = L loc (TyFamInstD NoExt tfid) - feqn@(FamEqn _ name pats _fixity typ) = hsib_body $ tfid_eqn tfid + FamEqn _ name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing - lfeqn = L loc feqn + innerNode = outerNode #elif MIN_VERSION_ghc(8,4,0) - linst = L loc (TyFamInstD tfid) - feqn@(FamEqn name pats _fixity typ) = hsib_body $ tfid_eqn tfid + FamEqn name pats _fixity typ = hsib_body $ tfid_eqn tfid bndrsMay = Nothing - lfeqn = L loc feqn + innerNode = outerNode #elif MIN_VERSION_ghc(8,2,0) - linst = L loc (TyFamInstD tfid) - lfeqn@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid + innerNode@(L _ (TyFamEqn name boundPats _fixity typ)) = tfid_eqn tfid bndrsMay = Nothing pats = hsib_body boundPats #else - linst = L loc (TyFamInstD tfid) - lfeqn@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid + innerNode@(L _ (TyFamEqn name boundPats typ)) = tfid_eqn tfid bndrsMay = Nothing pats = hsib_body boundPats #endif - docWrapNodePrior linst $ do + docWrapNodePrior outerNode $ do nameStr <- lrdrNameToTextAnn name - needsParens <- hasAnnKeyword lfeqn AnnOpenP + needsParens <- hasAnnKeyword outerNode AnnOpenP let instanceDoc = if inClass then docLit $ Text.pack "type" @@ -863,9 +989,7 @@ ++ processTyVarBndrsSingleline bndrDocs ) lhs = - docWrapNode lfeqn - . appSep - . docWrapNodeRest linst + docWrapNode innerNode . docSeq $ [appSep instanceDoc] ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ] @@ -874,8 +998,8 @@ ++ intersperse docSeparator (layoutHsTyPats pats) ++ [ docParenR | needsParens ] hasComments <- (||) - <$> hasAnyRegularCommentsConnected lfeqn - <*> hasAnyRegularCommentsRest linst + <$> hasAnyRegularCommentsConnected outerNode + <*> hasAnyRegularCommentsRest innerNode typeDoc <- docSharedWrapper layoutType typ layoutLhsAndType hasComments lhs "=" typeDoc @@ -961,8 +1085,8 @@ layoutAndLocateTyFamInsts :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered) - layoutAndLocateTyFamInsts ltfid@(L loc _) = - L loc <$> layoutTyFamInstDecl True ltfid + layoutAndLocateTyFamInsts ltfid@(L loc tfid) = + L loc <$> layoutTyFamInstDecl True ltfid tfid layoutAndLocateDataFamInsts :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered) @@ -1029,6 +1153,7 @@ | otherwise -> st : go lineR isTypeOrData t' = (Text.pack "type" `Text.isPrefixOf` t') + || (Text.pack "newtype" `Text.isPrefixOf` t') || (Text.pack "data" `Text.isPrefixOf` t') @@ -1043,13 +1168,12 @@ -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered layoutLhsAndType hasComments lhs sep typeDoc = do - let sepDoc = appSep . docLit $ Text.pack sep runFilteredAlternative $ do -- (separators probably are "=" or "::") -- lhs = type -- lhs :: type - addAlternativeCond (not hasComments) - $ docSeq [lhs, sepDoc, docForceSingleline typeDoc] + addAlternativeCond (not hasComments) $ docSeq + [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc] -- lhs -- :: typeA -- -> typeB @@ -1058,4 +1182,6 @@ -- -> typeB addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols ColTyOpPrefix - [sepDoc, docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc] + [ appSep $ docLitS sep + , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -426,6 +426,9 @@ (_, L _ (HsApp _ (L _ HsVar{}))) -> False _ -> True #endif + let leftIsDoBlock = case expLeft of + L _ HsDo{} -> True + _ -> False runFilteredAlternative $ do -- one-line addAlternative @@ -442,16 +445,17 @@ -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight -- ] -- two-line - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft -- TODO: this is not forced to single-line, which has - -- certain.. interesting consequences. - -- At least, the "two-line" label is not entirely - -- accurate. - ( docForceSingleline + addAlternative $ do + let + expDocOpAndRight = docForceSingleline $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight] - ) + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight + -- TODO: in both cases, we don't force expDocLeft to be + -- single-line, which has certain.. interesting consequences. + -- At least, the "two-line" label is not entirely + -- accurate. -- one-line + par addAlternativeCond allowPar $ docSeq @@ -460,11 +464,13 @@ , docForceParSpacing expDocRight ] -- more lines - addAlternative - $ docAddBaseY BrIndentRegular - $ docPar - expDocLeft - (docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]) + addAlternative $ do + let expDocOpAndRight = + docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight] + if leftIsDoBlock + then docLines [expDocLeft, expDocOpAndRight] + else docAddBaseY BrIndentRegular + $ docPar expDocLeft expDocOpAndRight #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ NegApp _ op _ -> do #else @@ -528,7 +534,10 @@ argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM - hasComments <- hasAnyCommentsBelow lexpr + hasComments <- orM + ( hasCommentsBetween lexpr AnnOpenP AnnCloseP + : map hasAnyCommentsBelow args + ) let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") Unboxed -> (docParenHashLSep, docParenHashRSep) @@ -770,7 +779,7 @@ addAlternativeCond (not hasComments) $ docSeq [ appSep $ docLit $ Text.pack "let" , docNodeAnnKW lexpr (Just AnnLet) - $ appSep $ docForceSingleline bindDoc + $ appSep $ docForceSingleline bindDoc , appSep $ docLit $ Text.pack "in" , docForceSingleline expDoc1 ] @@ -1223,7 +1232,7 @@ -- } addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq - [ docNodeAnnKW lexpr Nothing $ appSep nameDoc + [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc , docSetBaseY $ docLines $ let line1 = docCols ColRec [ appSep $ docLit $ Text.pack "{" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/IE.hs @@ -65,29 +65,36 @@ #else IEThingWith x _ ns _ -> do #endif - hasComments <- hasAnyCommentsBelow lie + hasComments <- orM + ( hasCommentsBetween lie AnnOpenP AnnCloseP + : hasAnyCommentsBelow x + : map hasAnyCommentsBelow ns + ) runFilteredAlternative $ do addAlternativeCond (not hasComments) $ docSeq $ [layoutWrapped lie x, docLit $ Text.pack "("] ++ intersperse docCommaSep (map nameDoc ns) ++ [docParenR] - addAlternative $ docAddBaseY BrIndentRegular $ docPar - (layoutWrapped lie x) - (layoutItems (splitFirstLast ns)) + addAlternative + $ docWrapNodeRest lie + $ docAddBaseY BrIndentRegular + $ docPar + (layoutWrapped lie x) + (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] + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines - [docSeq [docParenLSep, docWrapNodeRest lie $ nameDoc n], docParenR] + [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ 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] + ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] #if MIN_VERSION_ghc(8,6,0) IEModuleContents _ n -> docSeq #else diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Module.hs @@ -49,6 +49,7 @@ , docWrapNode lmod $ appSep $ case les of Nothing -> docEmpty Just x -> layoutLLIEs True x + , docSeparator , docLit $ Text.pack "where" ] addAlternative @@ -56,11 +57,13 @@ [ docAddBaseY BrIndentRegular $ docPar (docSeq [appSep $ docLit $ Text.pack "module", docLit tn] ) - (docWrapNode lmod $ case les of - Nothing -> docEmpty - Just x -> layoutLLIEs False x + (docSeq [ docWrapNode lmod $ case les of + Nothing -> docEmpty + Just x -> layoutLLIEs False x + , docSeparator + , docLit $ Text.pack "where" + ] ) - , docLit $ Text.pack "where" ] ] : map layoutImport imports diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -51,7 +51,10 @@ [ docCols ColBindStmt [ appSep patDoc - , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc] + , docSeq + [ appSep $ docLit $ Text.pack "<-" + , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc + ] ] , docCols ColBindStmt diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -14,6 +14,10 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Utils + ( splitFirstLast + , FirstLastView(..) + ) import GHC ( runGhc , GenLocated(L) @@ -444,15 +448,17 @@ docs <- docSharedWrapper layoutType `mapM` typs let end = docLit $ Text.pack ")" lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) docAlt [ docSeq $ [docLit $ Text.pack "("] - ++ List.intersperse docCommaSep (docForceSingleline <$> docs) + ++ docWrapNodeRest ltype commaDocs ++ [end] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] in docPar (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + (docLines $ docWrapNodeRest ltype lines ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs @@ -460,15 +466,16 @@ end = docParenHashRSep docAlt [ docSeq $ [start] - ++ List.intersperse docCommaSep docs + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) ++ [end] , let line1 = docCols ColTyOpPrefix [start, head docs] lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] in docPar (docAddBaseY (BrIndentSpecial 2) line1) - (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + (docLines $ lines ++ [end]) ] HsOpTy{} -> -- TODO briDocByExactInlineOnly "HsOpTy{}" ltype @@ -690,12 +697,48 @@ HsExplicitListTy _ typs -> do #endif typDocs <- docSharedWrapper layoutType `mapM` typs + hasComments <- hasAnyCommentsBelow ltype + let specialCommaSep = appSep $ docLit $ Text.pack " ," docAlt [ docSeq $ [docLit $ Text.pack "'["] - ++ List.intersperse docCommaSep typDocs + ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ [docLit $ Text.pack "]"] - -- TODO + , case splitFirstLast typDocs of + FirstLastEmpty -> docSeq + [ docLit $ Text.pack "'[" + , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]" + ] + FirstLastSingleton e -> docAlt + [ docSeq + [ docLit $ Text.pack "'[" + , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e + , docLit $ Text.pack "]" + ] + , docSetBaseY $ docLines + [ docSeq + [ docLit $ Text.pack "'[" + , docSeparator + , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e + ] + , docLit $ Text.pack " ]" + ] + ] + FirstLast e1 ems eN -> runFilteredAlternative $ do + addAlternativeCond (not hasComments) + $ docSeq + $ [docLit $ Text.pack "'["] + ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) + ++ [docLit $ Text.pack " ]"] + addAlternative $ + let + start = docCols ColList + [appSep $ docLit $ Text.pack "'[", e1] + linesM = ems <&> \d -> + docCols ColList [specialCommaSep, d] + lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] + end = docLit $ Text.pack " ]" + in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] HsExplicitTupleTy{} -> -- TODO briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -331,7 +331,7 @@ BrIndentNone -> r BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing bd -> rec bd + BDFNonBottomSpacing _ bd -> rec bd BDFSetParSpacing bd -> rec bd BDFForceParSpacing bd -> rec bd BDFDebug s bd -> do @@ -488,13 +488,18 @@ BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf - BDFNonBottomSpacing bd -> do + BDFNonBottomSpacing b bd -> do mVs <- rec bd return $ mVs - <|> LineModeValid (VerticalSpacing 0 - (VerticalSpacingParAlways colMax) - False) + <|> LineModeValid + (VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } @@ -799,16 +804,30 @@ BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing bd -> do + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. mVs <- rec bd return $ if null mVs - then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False] + then [VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] else mVs <&> \vs -> vs { _vs_sameLine = min colMax (_vs_sameLine vs) , _vs_paragraph = case _vs_paragraph vs of VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - VerticalSpacingParSome i -> VerticalSpacingParAlways i + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i } -- the version below is an alternative idea: fold the input -- spacings into a single spacing. This was hoped to improve in diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -135,4 +135,4 @@ BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing BDDebug{} -> Nothing - BDNonBottomSpacing x -> Just x + BDNonBottomSpacing _ x -> Just x diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs --- a/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Floating.hs @@ -132,6 +132,8 @@ Just $ BDIndentLevelPop (BDAddBaseY ind x) BDAddBaseY ind (BDIndentLevelPushCur x) -> Just $ BDIndentLevelPushCur (BDAddBaseY ind x) + BDAddBaseY ind (BDEnsureIndent ind2 x) -> + Just $ BDEnsureIndent (mergeIndents ind ind2) x _ -> Nothing stepBO :: BriDoc -> BriDoc stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -84,6 +84,17 @@ -- -- captures if the layouter currently is in a new line, i.e. if the -- -- current line only contains (indentation) spaces. -- this is mostly superseeded by curYOrAddNewline, iirc. + , _lstate_commentNewlines :: Int -- number of newlines inserted due to + -- move-to-DP at a start of a comment. + -- Necessary because some keyword DPs + -- are relative to the last non-comment + -- entity (for some reason). + -- This is not very strictly reset to 0, + -- so we might in some cases get "artifacts" + -- from previous document elements. + -- But the worst effect at the moment would + -- be that we introduce less newlines on + -- moveToKWDP, which seems harmless enough. } lstate_baseY :: LayoutState -> Int @@ -102,6 +113,7 @@ ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state) ++ ",commentCol=" ++ show (_lstate_commentCol state) ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state) + ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state) ++ "}" -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a @@ -185,6 +197,8 @@ | ColBindStmt | ColDoLet -- the non-indented variant | ColRec + | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? + | ColRecDecl | ColListComp | ColList | ColApp Text @@ -201,7 +215,10 @@ | BrIndentSpecial Int deriving (Eq, Ord, Typeable, Data.Data.Data, Show) -type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[BrittanyError], Seq String] '[NodeAllocIndex] +type ToBriDocM = MultiRWSS.MultiRWS + '[Config, Anns] -- reader + '[[BrittanyError], Seq String] -- writer + '[NodeAllocIndex] -- state type ToBriDoc (sym :: * -> *) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered @@ -256,7 +273,7 @@ -- after the alt transformation. | BDForceMultiline BriDoc | BDForceSingleline BriDoc - | BDNonBottomSpacing BriDoc + | BDNonBottomSpacing Bool BriDoc | BDSetParSpacing BriDoc | BDForceParSpacing BriDoc -- pseudo-deprecated @@ -301,7 +318,7 @@ | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) | BDFForceSingleline (f (BriDocF f)) - | BDFNonBottomSpacing (f (BriDocF f)) + | BDFNonBottomSpacing Bool (f (BriDocF f)) | BDFSetParSpacing (f (BriDocF f)) | BDFForceParSpacing (f (BriDocF f)) | BDFDebug String (f (BriDocF f)) @@ -313,33 +330,37 @@ type BriDocNumbered = (Int, BriDocFInt) instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd - uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd - uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x - 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 b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd - uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd - uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd) = plate BDDebug |- s |* bd + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list ) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented + uniplate (BDAlt alts ) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x + 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 b bd) = + plate BDMoveToKWDP |- annKey |- kw |- b |* bd + uniplate (BDLines lines ) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd + uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd + uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int @@ -367,14 +388,13 @@ BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd - where - rec = unwrapBriDocNumbered + where rec = unwrapBriDocNumbered isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False @@ -404,11 +424,11 @@ BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -25,6 +26,7 @@ , splitFirstLast , lines' , showOutputable + , absurdExt ) where @@ -57,6 +59,9 @@ import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate +#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ +import qualified HsExtension +#endif @@ -293,3 +298,12 @@ (s1, []) -> [s1] (s1, [_]) -> [s1, ""] (s1, (_:r)) -> s1 : lines' r + +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ +-- | A method to dismiss NoExt patterns for total matches +absurdExt :: HsExtension.NoExt -> a +absurdExt = error "cannot construct NoExt" +#else +absurdExt :: () +absurdExt = () +#endif diff --git a/src/Language/Haskell/Brittany/Main.hs b/src/Language/Haskell/Brittany/Main.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Brittany/Main.hs @@ -0,0 +1,484 @@ +{-# LANGUAGE DataKinds #-} + +module Language.Haskell.Brittany.Main (main) where + + + +#include "prelude.inc" + +-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 } +import qualified Language.Haskell.GHC.ExactPrint as ExactPrint +import qualified Language.Haskell.GHC.ExactPrint.Annotate + as ExactPrint.Annotate +import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types +import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers +import qualified Data.Map as Map +import qualified Data.Monoid + +import GHC ( GenLocated(L) ) +import Outputable ( Outputable(..) + , showSDocUnsafe + ) + +import Text.Read ( Read(..) ) +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Data.Text.Lazy.Builder as Text.Builder + +import Control.Monad ( zipWithM ) +import Data.CZipWith + +import qualified Debug.Trace as Trace + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Utils +import Language.Haskell.Brittany.Internal.Obfuscation + +import qualified Text.PrettyPrint as PP + +import DataTreePrint +import UI.Butcher.Monadic + +import qualified System.Exit +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath + +import qualified DynFlags as GHC +import qualified GHC.LanguageExtensions.Type as GHC + +import Paths_brittany + + + +data WriteMode = Display | Inplace + +instance Read WriteMode where + readPrec = val "display" Display <|> val "inplace" Inplace + where val iden v = ReadPrec.lift $ ReadP.string iden >> return v + +instance Show WriteMode where + show Display = "display" + show Inplace = "inplace" + + +main :: IO () +main = mainFromCmdParserWithHelpDesc mainCmdParser + +helpDoc :: PP.Doc +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;" + , "everything else is left unmodified." + , "Based on ghc-exactprint, thus (theoretically) supporting all" + , "that ghc does." + ] + , 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.vcat + [ PP.text "brittany --indent=4 --write-mode=inplace *.hs" + , PP.nest 2 $ PP.vcat + [ PP.text "run on all modules in current directory (no backup!)" + , PP.text "4 spaces indentation" + ] + ] + , 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." + , "Please do check the output and do not let brittany override your large" + , "codebase without having backups." + ] + , parDoc $ "There is NO WARRANTY, to the extent permitted by law." + , parDocW + [ "This program is free software released under the AGPLv3." + , "For details use the --license flag." + ] + , parDoc $ "See https://github.com/lspitzner/brittany" + , parDoc + $ "Please report bugs at" + ++ " https://github.com/lspitzner/brittany/issues" + ] + +licenseDoc :: PP.Doc +licenseDoc = PP.vcat $ List.intersperse + (PP.text "") + [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner" + , parDoc $ "Copyright (C) 2019 PRODA LTD" + , parDocW + [ "This program is free software: you can redistribute it and/or modify" + , "it under the terms of the GNU Affero General Public License," + , "version 3, as published by the Free Software Foundation." + ] + , parDocW + [ "This program is distributed in the hope that it will be useful," + , "but WITHOUT ANY WARRANTY; without even the implied warranty of" + , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , "GNU Affero General Public License for more details." + ] + , parDocW + [ "You should have received a copy of the GNU Affero General Public" + , "License along with this program. If not, see" + , "." + ] + ] + + +mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) () +mainCmdParser helpDesc = do + addCmdSynopsis "haskell source pretty printer" + addCmdHelp $ helpDoc + -- addCmd "debugArgs" $ do + addHelpCommand helpDesc + addCmd "license" $ addCmdImpl $ print $ licenseDoc + -- addButcherDebugCommand + reorderStart + printHelp <- addSimpleBoolFlag "h" ["help"] mempty + printVersion <- addSimpleBoolFlag "" ["version"] mempty + printLicense <- addSimpleBoolFlag "" ["license"] mempty + noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty + configPaths <- addFlagStringParams "" + ["config-file"] + "PATH" + (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? + cmdlineConfig <- cmdlineConfigParser + suppressOutput <- addSimpleBoolFlag + "" + ["suppress-output"] + (flagHelp $ parDoc + "suppress the regular output, i.e. the transformed haskell source" + ) + _verbosity <- addSimpleCountFlag + "v" + ["verbose"] + (flagHelp $ parDoc "[currently without effect; TODO]") + checkMode <- addSimpleBoolFlag + "c" + ["check-mode"] + (flagHelp + (PP.vcat + [ PP.text "check for changes but do not write them out" + , PP.text "exits with code 0 if no changes necessary, 1 otherwise" + , PP.text "and print file path(s) of files that have changes to stdout" + ] + ) + ) + writeMode <- addFlagReadParam + "" + ["write-mode"] + "(display|inplace)" + ( flagHelp + (PP.vcat + [ PP.text "display: output for any input(s) goes to stdout" + , PP.text "inplace: override respective input file (without backup!)" + ] + ) + Data.Monoid.<> flagDefault Display + ) + inputParams <- addParamNoFlagStrings + "PATH" + (paramHelpStr "paths to input/inout haskell source files") + reorderStop + addCmdImpl $ void $ do + when printLicense $ do + print licenseDoc + System.Exit.exitSuccess + when printVersion $ do + do + putStrLn $ "brittany version " ++ showVersion version + putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner" + putStrLn $ "Copyright (C) 2019 PRODA LTD" + 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 + System.Exit.exitSuccess + + let inputPaths = + if null inputParams then [Nothing] else map Just inputParams + let outputPaths = case writeMode of + Display -> repeat Nothing + Inplace -> inputPaths + + configsToLoad <- liftIO $ if null configPaths + then + maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths + + config <- + runMaybeT + (if noUserConfig + then readConfigs cmdlineConfig configsToLoad + else readConfigsWithUserConfig cmdlineConfig configsToLoad + ) + >>= \case + Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) + Just x -> return x + when (config & _conf_debug & _dconf_dump_config & confUnpack) + $ trace (showConfigYaml config) + $ return () + + results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) + inputPaths + outputPaths + + if checkMode + then when (any (== Changes) (Data.Either.rights results)) + $ System.Exit.exitWith (System.Exit.ExitFailure 1) + else case results of + xs | all Data.Either.isRight xs -> pure () + [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x) + _ -> System.Exit.exitWith (System.Exit.ExitFailure 1) + + +data ChangeStatus = Changes | NoChanges + deriving (Eq) + +-- | The main IO parts for the default mode of operation, and after commandline +-- and config stuff is processed. +coreIO + :: (String -> IO ()) -- ^ error output function. In parallel operation, you + -- may want serialize the different outputs and + -- consequently not directly print to stderr. + -> Config -- ^ global program config. + -> Bool -- ^ whether to supress output (to stdout). Purely IO flag, so + -- currently not part of program config. + -> Bool -- ^ whether we are (just) in check mode. + -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. + -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. + -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. +coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = + ExceptT.runExceptT $ do + let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO () + let ghcOptions = config & _conf_forward & _options_ghc & runIdentity + -- there is a good of code duplication between the following code and the + -- `pureModuleTransform` function. Unfortunately, there are also a good + -- amount of slight differences: This module is a bit more verbose, and + -- it tries to use the full-blown `parseModule` function which supports + -- CPP (but requires the input to be a file..). + let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack + -- the flag will do the following: insert a marker string + -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with + -- "#include" before processing (parsing) input; and remove that marker + -- string from the transformation output. + -- The flag is intentionally misspelled to prevent clashing with + -- inline-config stuff. + let hackAroundIncludes = + config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack + let exactprintOnly = viaGlobal || viaDebug + where + viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack + viaDebug = + config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack + + let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags + then case cppMode of + CPPModeAbort -> do + return $ Left "Encountered -XCPP. Aborting." + CPPModeWarn -> do + putErrorLnIO + $ "Warning: Encountered -XCPP." + ++ " Be warned that -XCPP is not supported and that" + ++ " brittany cannot check that its output is syntactically" + ++ " valid in its presence." + return $ Right True + CPPModeNowarn -> return $ Right True + else return $ Right False + (parseResult, originalContents) <- case inputPathM of + Nothing -> do + -- TODO: refactor this hack to not be mixed into parsing logic + let hackF s = if "#include" `isPrefixOf` s + then "-- BRITANY_INCLUDE_HACK " ++ s + else s + let hackTransform = if hackAroundIncludes && not exactprintOnly + then List.intercalate "\n" . fmap hackF . lines' + else id + inputString <- liftIO $ System.IO.hGetContents System.IO.stdin + parseRes <- liftIO $ parseModuleFromString ghcOptions + "stdin" + cppCheckFunc + (hackTransform inputString) + return (parseRes, Text.pack inputString) + Just p -> liftIO $ do + parseRes <- parseModule ghcOptions p cppCheckFunc + inputText <- Text.IO.readFile p + -- The above means we read the file twice, but the + -- GHC API does not really expose the source it + -- read. Should be in cache still anyways. + -- + -- We do not use TextL.IO.readFile because lazy IO is evil. + -- (not identical -> read is not finished -> + -- handle still open -> write below crashes - evil.) + return (parseRes, inputText) + case parseResult of + Left left -> do + putErrorLn "parse error:" + putErrorLn left + ExceptT.throwE 60 + Right (anns, parsedSource, hasCPP) -> do + (inlineConf, perItemConf) <- + case + extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) + of + Left (err, input) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + ExceptT.throwE 61 + Right c -> -- trace (showTree c) $ + pure c + let moduleConf = cZipWith fromOptionIdentity config inlineConf + when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do + let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource + trace ("---- ast ----\n" ++ show val) $ return () + let disableFormatting = + moduleConf & _conf_disable_formatting & confUnpack + (errsWarns, outSText, hasChanges) <- do + if + | disableFormatting -> do + pure ([], originalContents, False) + | exactprintOnly -> do + let r = Text.pack $ ExactPrint.exactPrint parsedSource anns + pure ([], r, r /= originalContents) + | otherwise -> do + let omitCheck = + moduleConf + & _conf_errorHandling + .> _econf_omit_output_valid_check + .> confUnpack + (ews, outRaw) <- if hasCPP || omitCheck + then return + $ pPrintModule moduleConf perItemConf anns parsedSource + else liftIO $ pPrintModuleAndCheck moduleConf + perItemConf + anns + parsedSource + let hackF s = fromMaybe s $ TextL.stripPrefix + (TextL.pack "-- BRITANY_INCLUDE_HACK ") + s + let out = TextL.toStrict $ if hackAroundIncludes + then + TextL.intercalate (TextL.pack "\n") + $ fmap hackF + $ TextL.splitOn (TextL.pack "\n") outRaw + else outRaw + out' <- if moduleConf & _conf_obfuscate & confUnpack + then lift $ obfuscate out + else pure out + pure $ (ews, out', out' /= originalContents) + let customErrOrder ErrorInput{} = 4 + customErrOrder LayoutWarning{} = -1 :: Int + customErrOrder ErrorOutputCheck{} = 1 + customErrOrder ErrorUnusedComment{} = 2 + customErrOrder ErrorUnknownNode{} = -2 :: Int + customErrOrder ErrorMacroConfig{} = 5 + when (not $ null errsWarns) $ do + let groupedErrsWarns = + Data.List.Extra.groupOn customErrOrder + $ List.sortOn customErrOrder + $ errsWarns + groupedErrsWarns `forM_` \case + (ErrorOutputCheck{} : _) -> do + putErrorLn + $ "ERROR: brittany pretty printer" + ++ " returned syntactically invalid result." + (ErrorInput str : _) -> do + putErrorLn $ "ERROR: parse error: " ++ str + uns@(ErrorUnknownNode{} : _) -> do + putErrorLn + $ "WARNING: encountered unknown syntactical constructs:" + uns `forM_` \case + ErrorUnknownNode str ast@(L loc _) -> do + putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) + when + ( config + & _conf_debug + & _dconf_dump_ast_unknown + & confUnpack + ) + $ do + putErrorLn $ " " ++ show (astToDoc ast) + _ -> error "cannot happen (TM)" + putErrorLn + " -> falling back on exactprint for this element of the module" + warns@(LayoutWarning{} : _) -> do + putErrorLn $ "WARNINGS:" + warns `forM_` \case + LayoutWarning str -> putErrorLn str + _ -> error "cannot happen (TM)" + unused@(ErrorUnusedComment{} : _) -> do + putErrorLn + $ "Error: detected unprocessed comments." + ++ " The transformation output will most likely" + ++ " not contain some of the comments" + ++ " present in the input haskell source file." + putErrorLn $ "Affected are the following comments:" + unused `forM_` \case + ErrorUnusedComment str -> putErrorLn str + _ -> error "cannot happen (TM)" + (ErrorMacroConfig err input : _) -> do + putErrorLn $ "Error: parse error in inline configuration:" + putErrorLn err + putErrorLn $ " in the string \"" ++ input ++ "\"." + [] -> error "cannot happen" + -- TODO: don't output anything when there are errors unless user + -- adds some override? + let + hasErrors = + case config & _conf_errorHandling & _econf_Werror & confUnpack of + False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) + True -> not $ null errsWarns + outputOnErrs = + config + & _conf_errorHandling + & _econf_produceOutputOnErrors + & confUnpack + shouldOutput = + not suppressOutput + && not checkMode + && (not hasErrors || outputOnErrs) + + when shouldOutput + $ addTraceSep (_conf_debug config) + $ case outputPathM of + Nothing -> liftIO $ Text.IO.putStr $ outSText + Just p -> liftIO $ do + let isIdentical = case inputPathM of + Nothing -> False + Just _ -> not hasChanges + unless isIdentical $ Text.IO.writeFile p $ outSText + + when (checkMode && hasChanges) $ case inputPathM of + Nothing -> pure () + Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p + + when hasErrors $ ExceptT.throwE 70 + return (if hasChanges then Changes else NoChanges) + where + addTraceSep conf = + if or + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf + ] + then trace "----" + else id