brittany 0.8.0.3 → 0.9.0.0
raw patch · 22 files changed
+3817/−2222 lines, 22 filesdep −eitherdep ~butcherdep ~filepathPVP ok
version bump matches the API change (PVP)
Dependencies removed: either
Dependency ranges changed: butcher, filepath
API changes (from Hackage documentation)
- Language.Haskell.Brittany.Internal.Config: readMergePersConfig :: FilePath -> Bool -> CConfig Option -> MaybeT IO (CConfig Option)
+ Language.Haskell.Brittany.Internal.Config: readConfig :: MonadIO m => FilePath -> MaybeT m (Maybe (CConfig Option))
+ Language.Haskell.Brittany.Internal.Config: writeDefaultConfig :: MonadIO m => FilePath -> m ()
+ Language.Haskell.Brittany.Internal.Config.Types: instance GHC.Classes.Eq Language.Haskell.Brittany.Internal.Config.Types.IndentPolicy
Files
- ChangeLog.md +26/−0
- README.md +15/−2
- brittany.cabal +7/−37
- src-brittany/Main.hs +91/−40
- src-literatetests/10-tests.blt +546/−0
- src-literatetests/14-extensions.blt +68/−0
- src-literatetests/15-regressions.blt +515/−0
- src-literatetests/16-pending.blt +35/−0
- src-literatetests/Main.hs +35/−10
- src-literatetests/tests-context-free.blt +1131/−0
- src-literatetests/tests.blt +0/−1080
- src/Language/Haskell/Brittany/Internal.hs +8/−8
- src/Language/Haskell/Brittany/Internal/Config.hs +32/−23
- src/Language/Haskell/Brittany/Internal/Config/Types.hs +1/−1
- src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +28/−24
- src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +30/−9
- src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +36/−11
- src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +1045/−910
- src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +20/−0
- src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +85/−44
- src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +62/−22
- srcinc/prelude.inc +1/−1
ChangeLog.md view
@@ -1,5 +1,31 @@ # Revision history for brittany +## 0.9.0.0 -- December 2017++* Change default global config path (use XDG spec)+ Existing config should still be respected, so this should not break+ compatibility+* ! Slight rework of the commandline interface:+ - Support multiple inputs and outputs+ - Support inplace-transformation for multiple files via+ `--write-mode=inplace`+* Implement `IndentPolicyLeft` - the indentation mode that never adds more+ than the base indentation for nested parts (no hanging indentation)++ (thanks to Evan Borden)+* Fix bug that manifested in bad output for (top-level) template haskell splices+* Extension support:+ - RecordWildCards+ - RecursiveDo (was only partially supported previously)+* Layouting Bugfixes:+ - Properly reproduce parentheses around kind signatures+ - Fix issue around promoted lists+ (example good: `'[ 'True]` bad: `'['True]`)+ - Trim text from exactprint used as workaround for unknown nodes+ (unsupported extension workaround)+* Layouting changes+ - Insert spaces around operator in sections+ ## 0.8.0.3 -- September 2017 * Support for ghc-8.2.1
README.md view
@@ -46,6 +46,7 @@ # Other usage notes - Supports GHC versions `8.0.*` and `8.2.*`.+- as of November'17, `brittany` is available on stackage nightly. - config (file) documentation is lacking. - some config values can not be configured via commandline yet. - uses/creates user config file in `~/.brittany/config.yaml`;@@ -109,9 +110,21 @@ - -XBangPatterns ~~~~ -# Implementation/High-level Documentation+# Feature Requests, Contribution, Documentation -[See the documentation index](doc/implementation/index.md)+This currently is a one-person project in the sense that 90% of the code is+written by one person. And (unfortunately) it is not my job to keep improving+this project. Please forgive that as a consequence my time to invest on new+features is rather limited.++Nonetheless I consider it "in active development" :)++One way of speeding things up is to make your own contributions. There is+a good amount of high-level documentation at++[the documentation index](doc/implementation/index.md)++Note that most development happens on the `dev` branch of this repository! # License
brittany.cabal view
@@ -1,5 +1,5 @@ name: brittany-version: 0.8.0.3+version: 0.9.0.0 synopsis: Haskell source code formatter description: { See <https://github.com/lspitzner/brittany/blob/master/README.md the README>.@@ -24,7 +24,7 @@ doc/implementation/*.md } extra-source-files: {- src-literatetests/tests.blt+ src-literatetests/*.blt } source-repository head {@@ -32,11 +32,6 @@ location: https://github.com/lspitzner/brittany.git } -flag brittany-dev- description: dev options- default: False- manual: True- flag brittany-dev-lib description: set buildable false for anything but lib default: False@@ -80,13 +75,9 @@ } ghc-options: { -Wall- -j -fno-warn-unused-imports -fno-warn-redundant-constraints }- if flag(brittany-dev) {- ghc-options: -O0 -Werror -fobject-code- } build-depends: { base >=4.9 && <4.11 , ghc >=8.0.1 && <8.3@@ -103,7 +94,7 @@ , pretty >=1.1.3.3 && <1.2 , bytestring >=0.10.8.1 && <0.11 , directory >=1.2.6.2 && <1.4- , butcher >=1.1.0.0 && <1.2+ , butcher >=1.2 && <1.3 , yaml >=0.8.18 && <0.9 , aeson >=1.0.1.0 && <1.3 , extra >=1.4.10 && <1.7@@ -113,7 +104,6 @@ , unsafe >=0.0 && <0.1 , safe >=0.3.9 && <0.4 , deepseq >=1.4.2.0 && <1.5- , either >=4.4.1.1 && <4.5 , semigroups >=0.18.2 && <0.19 , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.0.0 && <1.1@@ -148,7 +138,7 @@ other-modules: { Paths_brittany }- -- other-extensions: + -- other-extensions: build-depends: { brittany , base@@ -176,7 +166,6 @@ , unsafe , safe , deepseq- , either , semigroups , cmdargs , czipwith@@ -203,21 +192,12 @@ } ghc-options: { -Wall- -j -fno-spec-constr -fno-warn-unused-imports -fno-warn-redundant-constraints -rtsopts -with-rtsopts "-M2G" }- if flag(brittany-dev) {- ghc-options:- -O0- -Werror- -fobject-code- -fprof-auto- -fprof-cafs- } test-suite unittests if flag(brittany-dev-lib) {@@ -254,7 +234,6 @@ , unsafe , safe , deepseq- , either , semigroups , cmdargs , czipwith@@ -283,14 +262,10 @@ } ghc-options: { -Wall- -j -fno-warn-unused-imports -rtsopts -with-rtsopts "-M2G" }- if flag(brittany-dev) {- ghc-options: -O0 -Werror -fobject-code- } test-suite littests if flag(brittany-dev-lib) {@@ -327,17 +302,17 @@ , unsafe , safe , deepseq- , either , semigroups , cmdargs , czipwith , ghc-boot-th , hspec >=2.4.1 && <2.5+ , filepath , parsec >=3.1.11 && <3.2 } ghc-options: -Wall main-is: Main.hs- other-modules: + other-modules: hs-source-dirs: src-literatetests default-extensions: { CPP@@ -356,14 +331,10 @@ } ghc-options: { -Wall- -j -fno-warn-unused-imports -rtsopts -with-rtsopts "-M2G" }- if flag(brittany-dev) {- ghc-options: -O0 -Werror -fobject-code- } test-suite libinterfacetests if flag(brittany-dev-lib) {@@ -382,7 +353,7 @@ } ghc-options: -Wall main-is: Main.hs- other-modules: + other-modules: hs-source-dirs: src-libinterfacetests default-extensions: { FlexibleContexts@@ -395,7 +366,6 @@ } ghc-options: { -Wall- -j -fno-warn-unused-imports -rtsopts -with-rtsopts "-M2G"
src-brittany/Main.hs view
@@ -12,8 +12,12 @@ import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import qualified Data.Map as Map +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@@ -39,7 +43,18 @@ 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 @@ -47,13 +62,24 @@ helpDoc = PP.vcat $ List.intersperse (PP.text "") [ parDocW- [ "Transforms one haskell module by reformatting"- , "(parts of) the source code (while preserving the"- , "parts not transformed)."+ [ "Reformats one or more haskell modules."+ , "Currently affects only type signatures and function bindings;"+ , "everything else is left unmodified." , "Based on ghc-exactprint, thus (theoretically) supporting all" , "that ghc does."- , "Currently, only type-signatures and function-bindings are transformed." ]+ , parDoc $ "Example invocations:"+ , PP.hang (PP.text "") 2 $ PP.vcat+ [ PP.text "brittany"+ , PP.hang (PP.text " ") 2 $ PP.text "read from stdin, output to stdout"+ ]+ , PP.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 transformation does not change semantics (or the syntax tree at all)"@@ -103,8 +129,6 @@ printHelp <- addSimpleBoolFlag "h" ["help"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty- inputPaths <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "path to input haskell source file")- outputPaths <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file path") configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? cmdlineConfig <- configParser suppressOutput <- addSimpleBoolFlag@@ -112,9 +136,20 @@ ["suppress-output"] (flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source") _verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]")+ writeMode <- addFlagReadParam+ ""+ ["write-mode"]+ "(display|inplace)"+ Flag+ { _flag_help = Just $ PP.vcat+ [ PP.text "display: output for any input(s) goes to stdout"+ , PP.text "inplace: override respective input file (without backup!)"+ ]+ , _flag_default = Just Display+ }+ inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files") reorderStop- inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file")- desc <- peekCmdDesc+ desc <- peekCmdDesc addCmdImpl $ void $ do when printLicense $ do print licenseDoc@@ -128,31 +163,24 @@ when printHelp $ do liftIO $ print $ ppHelpShallow desc System.Exit.exitSuccess- inputPathM <- case maybeToList inputParam ++ inputPaths of- [] -> do- return Nothing- [x] -> return $ Just x- _ -> do- putStrErrLn $ "more than one input, aborting"- System.Exit.exitWith (System.Exit.ExitFailure 51)- outputPathM <- case outputPaths of- [] -> do- return Nothing- [x] -> return $ Just x- _ -> do- putStrErrLn $ "more than one output, aborting"- System.Exit.exitWith (System.Exit.ExitFailure 52)++ let inputPaths = if null inputParams then [Nothing] else map Just inputParams+ let outputPaths = case writeMode of+ Display -> repeat Nothing+ Inplace -> inputPaths+ config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do trace (showConfigYaml config) $ return ()- eitherErrSucc <- coreIO putStrErrLn config suppressOutput inputPathM outputPathM- case eitherErrSucc of- Left errNo -> System.Exit.exitWith (System.Exit.ExitFailure errNo)- Right () -> pure () + results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths+ case sequence_ results of+ Left _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)+ Right _ -> pure () + -- | The main IO parts for the default mode of operation, and after commandline -- and config stuff is processed. coreIO@@ -165,8 +193,8 @@ -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing. -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing. -> IO (Either Int ()) -- ^ Either an errorNo, or success.-coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEitherT $ do- let putErrorLn = liftIO . putErrorLnIO :: String -> EitherT.EitherT e IO ()+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@@ -206,7 +234,7 @@ Left left -> do putErrorLn "parse error:" putErrorLn $ show left- EitherT.left 60+ ExceptT.throwE 60 Right (anns, parsedSource, hasCPP) -> do when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource@@ -272,7 +300,7 @@ Nothing -> liftIO $ TextL.IO.putStr $ outLText Just p -> liftIO $ TextL.IO.writeFile p $ outLText - when hasErrors $ EitherT.left 70+ when hasErrors $ ExceptT.throwE 70 where addTraceSep conf = if or@@ -292,15 +320,38 @@ readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config readConfigs cmdlineConfig configPaths = do- let defLocalConfigPath = "brittany.yaml"- userBritPath <- liftIO $ Directory.getAppUserDataDirectory "brittany"- let defUserConfigPath = userBritPath FilePath.</> "config.yaml"- merged <- case configPaths of+ userBritPathSimple <- liftIO $ Directory.getAppUserDataDirectory "brittany"+ userBritPathXdg <- liftIO+ $ Directory.getXdgDirectory Directory.XdgConfig "brittany"+ let userConfigPathSimple = userBritPathSimple FilePath.</> "config.yaml"+ let userConfigPathXdg = userBritPathXdg FilePath.</> "config.yaml"+ let+ findLocalConfig :: MaybeT IO (Maybe (CConfig Option))+ findLocalConfig = do+ cwd <- liftIO $ Directory.getCurrentDirectory+ let dirParts = FilePath.splitDirectories cwd+ let searchDirs =+ [ FilePath.joinPath x | x <- reverse $ List.inits dirParts ]+ -- when cwd is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"]+ mFilePath <- liftIO $ Directory.findFileWith Directory.doesFileExist+ searchDirs+ "brittany.yaml"+ case mFilePath of+ Nothing -> pure Nothing+ Just fp -> readConfig fp+ configsRead <- case configPaths of [] -> do- liftIO $ Directory.createDirectoryIfMissing False userBritPath- return cmdlineConfig- >>= readMergePersConfig defLocalConfigPath False- >>= readMergePersConfig defUserConfigPath True- -- TODO: ensure that paths exist ?- paths -> foldl (\prev p -> prev >>= readMergePersConfig p False) (return cmdlineConfig) paths+ localConfig <- findLocalConfig+ userConfigSimple <- readConfig userConfigPathSimple+ userConfigXdg <- readConfig userConfigPathXdg+ let userConfig = userConfigSimple <|> userConfigXdg+ when (Data.Maybe.isNothing userConfig) $ do+ liftIO $ Directory.createDirectoryIfMissing False userBritPathXdg+ writeDefaultConfig userConfigPathXdg+ -- rightmost has highest priority+ pure $ [userConfig, localConfig]+ paths -> readConfig `mapM` reverse paths+ -- reverse to give highest priority to the first+ merged <-+ pure $ Semigroup.mconcat $ catMaybes $ configsRead ++ [Just cmdlineConfig] return $ cZipWith fromOptionIdentity staticDefaultConfig merged
+ src-literatetests/10-tests.blt view
@@ -0,0 +1,546 @@++###############################################################################+###############################################################################+###############################################################################+#group type signatures+###############################################################################+###############################################################################+###############################################################################++#test simple001+func :: a -> a++#test long typeVar+func+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++#test keep linebreak mode+func+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lakjsdlkjasldkj+ -> lakjsdlkjasldkj++#test simple parens 1+func :: ((a))++#test simple parens 2+func :: (a -> a) -> a++#test simple parens 3+func :: a -> (a -> a)++#test did anyone say parentheses?+func :: (((((((((())))))))))++-- current output is.. funny. wonder if that can/needs to be improved..+#test give me more!+#pending+func :: ((((((((((((((((((((((((((((((((((((((((((()))))))))))))))))))))))))))))))))))))))))))++#test unit+func :: ()+++###############################################################################++#test paren'd func 1+func+ :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lakjsdlkjasldkj+ -> lakjsdlkjasldkj+ )++#test paren'd func 2+func+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> (lakjsdlkjasldkj -> lakjsdlkjasldkj)++#test paren'd func 3+func+ :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj)+ -> lakjsdlkjasldkj++#test paren'd func 4+func+ :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ -> lakjsdlkjasldkj++#test paren'd func 5+func+ :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ )++###############################################################################++#test type application 1+func :: asd -> Either a b++#test type application 2+func+ :: asd+ -> Either+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++#test type application 3+func+ :: asd+ -> Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++#test type application 4+func+ :: Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> asd++#test type application 5+func+ :: Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd)++#test type application 6+func+ :: Trither+ asd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )++#test type application paren 1+func+ :: asd+ -> ( Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )++#test type application paren 2+func+ :: asd+ -> ( Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++#test type application paren 3+func+ :: ( Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> asd++###############################################################################++#test list simple+func :: [a -> b]++#test list func+func+ :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ ]++#test list paren+func+ :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ ]++################################################################## -- #############++#test tuple type 1+func :: (a, b, c)++#test tuple type 2+func :: ((a, b, c), (a, b, c), (a, b, c))++#test tuple type long+func+ :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )++#test tuple type nested+func+ :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd)+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ )++#test tuple type function+func+ :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ ]+###############################################################################+#test type operator stuff+#pending+test050 :: a :+: b+test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++###############################################################################++#test forall oneliner+{-# LANGUAGE ScopedTypeVariables #-}+func :: forall (a :: *) b . a -> b++#test forall context multiline+{-# LANGUAGE ScopedTypeVariables #-}+func+ :: forall m+ . Foo+ => ColMap2+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> m ()++#test forall no-context multiline+{-# LANGUAGE ScopedTypeVariables #-}+func+ :: forall m+ . ColMap2+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> m ()++#test language pragma issue+{-# LANGUAGE ScopedTypeVariables #-}+func :: forall (a :: *) b . a -> b++#test comments 1+func :: a -> b -- comment++#test comments 2+funcA :: a -> b -- comment A+funcB :: a -> b -- comment B++#test comments all+#pending+-- a+func -- b+ :: -- c+ a -- d+ -> -- e+ ( -- f+ c -- g+ , -- h+ d -- i+ ) -- j+-- k+++###############################################################################+###############################################################################+###############################################################################+#group type signatures pragmas+###############################################################################+###############################################################################+###############################################################################++#test inline pragma 1+func = f+ where+ {-# INLINE f #-}+ f = id++#test inline pragma 2+func = ($)+ where+ {-# INLINE ($) #-}+ ($) = id++#test inline pragma 3+func = f+ where+ {-# INLINE CONLIKE [1] f #-}+ f = id++#test inline pragma 4+#pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2.+func = f+ where+ {-# INLINE [~] f #-}+ f = id+++###############################################################################+###############################################################################+###############################################################################+#group equation.basic+###############################################################################+###############################################################################+###############################################################################+## some basic testing of different kinds of equations.+## some focus on column layouting for multiple-equation definitions.+## (that part probably is not implemented in any way yet.)++#test basic 1+func x = x++#test infix 1+x *** y = x++#test symbol prefix+(***) x y = x+++###############################################################################+###############################################################################+###############################################################################+#group equation.patterns+###############################################################################+###############################################################################+###############################################################################++#test wildcard+func _ = x++#test simple long pattern+#pending+func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable+ = x++#test simple multiline pattern+#pending+func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable+ reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable+ = x++#test another multiline pattern+#pending+func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable+ a+ b+ = x++#test simple constructor+func (A a) = a++#test list constructor+func (x:xr) = x++#test some other constructor symbol+#pending+func (x:+:xr) = x+++###############################################################################+###############################################################################+###############################################################################+#group equation.guards+###############################################################################+###############################################################################+###############################################################################+#test simple guard+func | True = x++#test multiple-clauses-1+func x | x = simple expression+ | otherwise = 0++#test multiple-clauses-2+func x+ | a somewhat longer guard x = "and a somewhat longer expession that does not"+ | otherwise = "fit without putting the guards in new lines"++#test multiple-clauses-3+func x+ | very long guard, another rather long guard that refers to x = nontrivial+ expression+ foo+ bar+ alsdkjlasdjlasj+ | otherwise = 0++#test multiple-clauses-4+func x+ | very long guard, another rather long guard that refers to x+ = nontrivialexpression foo bar alsdkjlasdjlasj+ | otherwise+ = 0++#test multiple-clauses-5+func x+ | very loooooooooooooooooooooooooooooong guard+ , another rather long guard that refers to x+ = nontrivial expression foo bar alsdkjlasdjlasj+ | otherwise+ = 0+++###############################################################################+###############################################################################+###############################################################################+#group expression.basic+###############################################################################+###############################################################################+###############################################################################++#test var+func = x++describe "infix op" $ do+#test 1+func = x + x++#test long+#pending+func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj+ + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj++#test long keep linemode 1+#pending+func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj+ + mweroiuxlskdfjlksj+ + mweroiuxlskdfjlksj++#test long keep linemode 2+#pending+func = mweroiuxlskdfjlksj+ + mweroiuxlskdfjlksj+ + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj++#test literals+func = 1+func = "abc"+func = 1.1e5+func = 'x'+func = 981409823458910394810928414192837123987123987123++#test lambda+func = \x -> abc++describe "app" $ do+#test 1+func = klajsdas klajsdas klajsdas++#test 2+func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd+ lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd+ lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd++#test 3+func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas+ lakjsdlajsdljas+ lakjsdlajsdljas++###+#group expression.basic.sections+###++#test left+func = (1 +)++#test right+func = (+ 1)++#test left inf+func = (1 `abc`)++#test right inf+func = (`abc` 1)++###+#group tuples+###++#test 1+func = (abc, def)++#test 2+#pending+func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd+ , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd)++++###############################################################################+###############################################################################+###############################################################################+#group expression.do statements+###############################################################################+###############################################################################+###############################################################################++#test simple+func = do+ stmt+ stmt++#test bind+func = do+ x <- stmt+ stmt x++#test let+func = do+ let x = 13+ stmt x+++###############################################################################+###############################################################################+###############################################################################+#group expression.lists+###############################################################################+###############################################################################+###############################################################################++#test monad-comprehension-case-of+func =+ foooooo+ $ [ case+ foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo+ of+ _ -> True+ ]+++###############################################################################+###############################################################################+###############################################################################+#group stylisticspecialcases+###############################################################################+###############################################################################+###############################################################################++#test operatorprefixalignment-even-with-multiline-alignbreak+func =+ foo+ $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa+ , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb+ ]+ ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc]+
+ src-literatetests/14-extensions.blt view
@@ -0,0 +1,68 @@+###############################################################################+###############################################################################+###############################################################################+#group extensions+###############################################################################+###############################################################################+###############################################################################++###############################################################################+## MultiWayIf+#test multiwayif 1+{-# LANGUAGE MultiWayIf #-}+func = if+ | cond1 -> loooooooooooooooooooooooooooooong expr1+ | cond2 -> loooooooooooooooooooooooooooooong expr2++#test multiwayif 2+{-# LANGUAGE MultiWayIf #-}+func = do+ foo+ bar $ if+ | cond1 -> loooooooooooooooooooooooooooooong expr1+ | cond2 -> loooooooooooooooooooooooooooooong expr2+++###############################################################################+## LambdaCase+#test lambdacase 1+{-# LANGUAGE LambdaCase #-}+func = \case+ FooBar -> x+ Baz -> y++++###############################################################################+## ImplicitParams+#test ImplicitParams 1+{-# LANGUAGE ImplicitParams #-}+func :: (?asd::Int) -> ()++#test ImplicitParams 2+{-# LANGUAGE ImplicitParams #-}+func+ :: ( ?asd+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ -> ()+++###############################################################################+## RecursiveDo+#test recursivedo 1+{-# LANGUAGE RecursiveDo #-}+foo = do+ rec a <- f b+ b <- g a+ return (a, b)++#test recursivedo 2+{-# LANGUAGE RecursiveDo #-}+foo = do+ rec -- comment+ a <- f b+ b <- g a+ return (a, b)+
+ src-literatetests/15-regressions.blt view
@@ -0,0 +1,515 @@+###############################################################################+###############################################################################+###############################################################################+#group regression+###############################################################################+###############################################################################+###############################################################################++#test newlines-comment+func = do+ abc <- foo++--abc+return ()++#test parenthesis-around-unit+func = (())++#test let-defs indentation+func = do+ let foo True = True+ foo _ = False+ return ()++#test record update indentation 1+func = do+ s <- mGet+ mSet $ s { _lstate_indent = _lstate_indent state }++#test record update indentation 2+func = do+ s <- mGet+ mSet $ s { _lstate_indent = _lstate_indent state+ , _lstate_foo = _lstate_foo state+ }++#test record update indentation 3+func = do+ s <- mGet+ mSet $ s+ { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ }++#test record construction 1+func = Foo {_lstate_indent = _lstate_indent state}++#test record construction 2+func = Foo+ { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , _lstate_fooo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ }++#test record construction 3+func = do+ Foo+ { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ }++#test post-indent comment+func = do+-- abc+ -- def+ return ()++#test post-unindent comment+func = do+ do+ return ()+ -- abc+ -- def+ return ()++#test CPP empty comment case+#pending CPP parsing needs fixing for roundTripEqual+{-# LANGUAGE CPP #-}+module Test where+func = do+#if FOO+ let x = 13+#endif+ stmt x++## really, the following should be handled by forcing the Alt to multiline+## because there are comments. as long as this is not implemented though,+## we should ensure the trivial solution works.+#test comment inline placement (temporary)+func+ :: Int -- basic indentation amount+ -> Int -- currently used width in current line (after indent)+ -- used to accurately calc placing of the current-line+ -> LayoutDesc+ -> Int++#test some indentation thingy+func =+ ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj+ $ abc+ $ def+ $ ghi+ $ jkl+ )++#test parenthesized operator+buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)+ where reassoc (v, e, w) = (v, (e, w))++#test record pattern matching stuff+downloadRepoPackage = case repo of+ RepoLocal {..} -> return ()+ RepoLocal { abc } -> return ()+ RepoLocal{} -> return ()++#test do let comment indentation level problem+func = do+ let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'+ (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''+ -- default local dir target if there's no given target+ utargets'' = "foo"+ return ()++#test list comprehension comment placement+func =+ [ (thing, take 10 alts) --TODO: select best ones+ | (thing, _got, alts@(_:_)) <- nosuchFooThing+ , gast <- award+ ]++#test if-then-else comment placement+func = if x+ then if y -- y is important+ then foo+ else bar+ else Nothing++#test qualified infix pattern+#pending "TODO"+wrapPatPrepend pat prepElem = do+ patDocs <- layoutPat pat+ case Seq.viewl patDocs of+ Seq.EmptyL -> return $ Seq.empty+ x1 Seq.:< xR -> do+ x1' <- docSeq [prepElem, return x1]+ return $ x1' Seq.<| xR++#test type signature multiline forcing issue+layoutWriteNewlineBlock+ :: ( MonadMultiWriter Text.Builder.Builder m+ , MonadMultiState LayoutState m+ , MonadMultiWriter (Seq String) m+ )+ => m ()++#test multiwayif proper indentation+{-# LANGUAGE MultiWayIf #-}+readMergePersConfig path shouldCreate conf = do+ exists <- liftIO $ System.Directory.doesFileExist path+ if+ | exists -> do+ contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.+ fileConf <- case Data.Yaml.decodeEither contents of+ Left e -> do+ liftIO+ $ putStrErrLn+ $ "error reading in brittany config from "+ ++ path+ ++ ":"+ liftIO $ putStrErrLn e+ mzero+ Right x -> return x+ return $ fileConf Semigroup.<> conf+ | shouldCreate -> do+ liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap+ (Option . Just . runIdentity)+ staticDefaultConfig+ return $ conf+ | otherwise -> do+ return conf++#test nested pattern alignment issue"+func = BuildReport+ where+ convertInstallOutcome = case result of+ Left BR.PlanningFailed -> PlanningFailed+ Left (BR.DependentFailed p) -> DependencyFailed p+ Left (BR.DownloadFailed _) -> DownloadFailed+ Left (BR.UnpackFailed _) -> UnpackFailed+ Left (BR.ConfigureFailed _) -> ConfigureFailed+ Left (BR.BuildFailed _) -> BuildFailed+ Left (BR.TestsFailed _) -> TestsFailed+ Left (BR.InstallFailed _) -> InstallFailed+ Right (BR.BuildOk _ _ _ ) -> InstallOk++#test nested pattern alignment issue"+func = BuildReport+ where+ convertInstallOutcome = case result of+ Left BR.PlanningFailed -> PlanningFailed+ Left (BR.DependentFailed p) -> DependencyFailed p+ Left (BR.DownloadFailed _) -> DownloadFailed+ Left (BR.UnpackFailed _) -> UnpackFailed+ Left (BR.ConfigureFailed _) -> ConfigureFailed+ Left (BR.BuildFailed _) -> BuildFailed+ Left (BR.TestsFailed _) -> TestsFailed+ Left (BR.InstallFailed _) -> InstallFailed+ Right (BR.BuildOk _ _ _ ) -> InstallOk++#test partially overflowing alignment issue"+showPackageDetailedInfo pkginfo =+ renderStyle (style { lineLength = 80, ribbonsPerLine = 1 })+ $ char '*'+ $+$ something+ [ entry "Synopsis" synopsis hideIfNull reflowParagraphs+ , entry "Versions available"+ sourceVersions+ (altText null "[ Not available from server ]")+ (dispTopVersions 9 (preferredVersions pkginfo))+ , entry+ "Versions installed"+ installedVersions+ ( altText+ null+ (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")+ )+ (dispTopVersions 4 (preferredVersions pkginfo))+ , entry "Homepage" homepage orNotSpecified text+ , entry "Bug reports" bugReports orNotSpecified text+ , entry "Description" description hideIfNull reflowParagraphs+ , entry "Category" category hideIfNull text+ , entry "License" license alwaysShow disp+ , entry "Author" author hideIfNull reflowLines+ , entry "Maintainer" maintainer hideIfNull reflowLines+ , entry "Source repo" sourceRepo orNotSpecified text+ , entry "Executables" executables hideIfNull (commaSep text)+ , entry "Flags" flags hideIfNull (commaSep dispFlag)+ , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)+ , entry "Documentation" haddockHtml showIfInstalled text+ , entry "Cached" haveTarball alwaysShow dispYesNo+ , if not (hasLib pkginfo)+ then empty+ else text "Modules:"+ $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))+ ]++#test issue 7a+isValidPosition position | validX && validY = Just position+ | otherwise = Nothing++#test issue-6-pattern-linebreak-validity+## this is ugly, but at least syntactically valid.+foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do+ (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String+ -> IO Bool ) <-+ ReflexHost.newExternalEvent+ liftIO . forkIO . forever $ getLine >>= inputFire+ ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent++#test issue 16+foldrDesc f z = unSwitchQueue $ \q ->+ switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q)++#test issue 18+autocheckCases =+ [ ("Never Deadlocks" , representative deadlocksNever)+ , ("No Exceptions" , representative exceptionsNever)+ , ("Consistent Result", alwaysSame) -- already representative+ ]++#test issue 18b+autocheckCases =+ [ ("Never Deadlocks", representative deadlocksNever)+ , ("No Exceptions" , representative exceptionsNever)+ , ( "Consistent Result"+ , alwaysSame -- already representative+ )+ ]++#test issue 18c+func =+ [ (abc, (1111, 1111))+ , (def, (2, 2))+ , foo -- comment+ ]++#test issue 26+foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo+ where g a b = b + b * a++#test issue 26b+foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo++#test aggressive alignment 1+func = do+ abc <- expr+ abcccccccccccccccccc <- expr+ abcccccccccccccccccccccccccccccccccccccccccc <- expr+ abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr++#test example alignment 1+func (MyLongFoo abc def) = 1+func (Bar a d ) = 2+func _ = 3++#test listcomprehension-case-of+parserCompactLocation =+ [ try+ $ [ ParseRelAbs (Text.Read.read digits) _ _+ | digits <- many1 digit+ , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe+ [ case divPart of+ Nothing -> Left $ Text.Read.read digits+ Just ddigits ->+ Right $ Text.Read.read digits % Text.Read.read ddigits+ | digits <- many1 digit+ , divPart <- optionMaybe (string "/" *> many1 digit)+ ]+ ]+ ]++#test opapp-specialcasing-1+func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo+ foooooooooooooooooooooooooooooooo+ foooooooooooooooooooooooooooooooo++#test opapp-specialcasing-2+func =+ fooooooooooooooooooooooooooooooooo+ + foooooooooooooooooooooooooooooooo foooooooooooooooooooooooooooooooo+ foooooooooooooooooooooooooooooooo++#test opapp-specialcasing-3+func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo+ [ foooooooooooooooooooooooooooooooo+ , foooooooooooooooooooooooooooooooo+ , foooooooooooooooooooooooooooooooo+ ]++#test opapp-indenting+parserPrim =+ [ r+ | r <-+ [ SGPPrimFloat $ bool id (0 -) minus $ readGnok "parserPrim"+ (d1 ++ d2 ++ d3 ++ d4)+ | d2 <- string "."+ , d3 <- many1 (oneOf "0123456789")+ , _ <- string "f"+ ]+ <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral+ (readGnok "parserPrim" d1 :: Integer)+ | _ <- string "f"+ ]+ <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral+ (readGnok "parserPrim" d1 :: Integer)+ | _ <- string "i"+ ]+ ]++#test another-parspacing-testcase++samples = (SV.unpackaaaaadat) <&> \f ->+ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa++#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+ }+ parsePrintModule config text++#test issue 38++{-# LANGUAGE TypeApplications #-}+foo = bar @Baz++#test comment-before-BDCols+{-# LANGUAGE TypeApplications #-}+layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do+ docAlt+ $ -- one-line solution+ [ docCols+ (ColBindingLine alignmentToken)+ [ docSeq (patPartInline ++ [guardPart])+ , docSeq+ [ appSep $ return binderDoc+ , docForceSingleline $ return body+ , wherePart+ ]+ ]+ | not hasComments+ , [(guards, body, _bodyRaw)] <- [clauseDocs]+ , let guardPart = singleLineGuardsDoc guards+ , wherePart <- case mWhereDocs of+ Nothing -> return @[] $ docEmpty+ Just [w] -> return @[] $ docSeq+ [ docSeparator+ , appSep $ docLit $ Text.pack "where"+ , docSetIndentLevel $ docForceSingleline $ return w+ ]+ _ -> []+ ]+ ++ -- one-line solution + where in next line(s)+ [ docLines+ $ [ docCols+ (ColBindingLine alignmentToken)+ [ docSeq (patPartInline ++ [guardPart])+ , docSeq+ [appSep $ return binderDoc, docForceParSpacing $ return body]+ ]+ ]+ ++ wherePartMultiLine+ | [(guards, body, _bodyRaw)] <- [clauseDocs]+ , let guardPart = singleLineGuardsDoc guards+ , Data.Maybe.isJust mWhereDocs+ ]+ ++ -- two-line solution + where in next line(s)+ [ docLines+ $ [ docForceSingleline+ $ docSeq (patPartInline ++ [guardPart, return binderDoc])+ , docEnsureIndent BrIndentRegular $ docForceSingleline $ return+ body+ ]+ ++ wherePartMultiLine+ | [(guards, body, _bodyRaw)] <- [clauseDocs]+ , let guardPart = singleLineGuardsDoc guards+ ]++#test comment-testcase-17+{-# LANGUAGE MultiWayIf #-}+func = do+ let foo = if+ | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO+ -> max+ (defLen - 0.2) -- TODO+ (defLen * 0.8)+ | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO+ return True++#test issue 49++foo n = case n of+ 1 -> True+ -1 -> False++bar n = case n of+ (-2, -2) -> (-2, -2)++#test issue 48 a++foo =+ let a = b@1+ cccc = ()+ in foo++#test issue 48 b++{-# LANGUAGE TypeApplications #-}+foo =+ let a = b @1+ cccc = ()+ in foo++#test issue 52 a++{-# LANGUAGE RecordWildCards #-}+v = A {a = 1, ..} where b = 2++#test issue 52 b++{-# LANGUAGE RecordWildCards #-}+v = A {..} where b = 2++#test issue 52 c++{-# LANGUAGE RecordWildCards #-}+v = A {a = 1, b = 2, c = 3}++#test issue 63 a+#pending fix does not work on 8.0.2+test :: Proxy 'Int++#test issue 63 b+#pending fix does not work on 8.0.2+test :: Proxy '[ 'True]++#test issue 63 c+#pending fix does not work on 8.0.2+test :: Proxy '[Bool]++#test issue 64+{-# LANGUAGE RankNTypes, KindSignatures #-}+func+ :: forall m str+ . (Str str, Monad m)+ => Int+ -> Proxy (str :: [*])+ -> m (Tagged str String)++#test issue 67+fmapuv :: U.Unbox a => (a -> b) -> U.Vector a -> V.Vector b+fmapuv f xs = G.generate (G.length xs) (f . (xs G.!))+++#test parallellistcomp-workaround+cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ]++#test issue 70+{-# LANGUAGE TemplateHaskell #-}+deriveFromJSON (unPrefix "assignPost") ''AssignmentPost
+ src-literatetests/16-pending.blt view
@@ -0,0 +1,35 @@+###############################################################################+###############################################################################+###############################################################################+#group pending+###############################################################################+###############################################################################+###############################################################################++++## this testcase is not about idempotency, but about _how_ the output differs+## from the input; i cannot really express this yet with the current+## test-suite.+## #test ayaz+## +## myManageHook =+## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience]+## <+> composeAll+## [ className =? "Pidgin" --> doFloat+## , className =? "XCalc" --> doFloat+## -- plan9port's acme+## , className =? "acme" --> doFloat+## -- Acme with Vi bindings editor+## , title =? "ED" --> doFloat+## , title =? "wlc-x11" --> doFloat+## , className =? "Skype" --> doFloat+## , className =? "ffplay" --> doFloat+## , className =? "mpv" --> doFloat+## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc.+## -- Firefox works well tiled, but it has dialog windows we want to float.+## , appName =? "Browser" --> doFloat+## ]+## where+## role = stringProperty "WM_WINDOW_ROLE"+
src-literatetests/Main.hs view
@@ -24,6 +24,7 @@ import Data.Coerce ( coerce ) import qualified Data.Text.IO as Text.IO+import System.FilePath ( (</>) ) @@ -38,13 +39,28 @@ main :: IO () main = do- input <- Text.IO.readFile "src-literatetests/tests.blt"- let groups = createChunks input- hspec $ 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 inp+ files <- System.Directory.listDirectory "src-literatetests/"+ let blts =+ List.sort+ $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))+ $ filter (".blt"`isSuffixOf`) files+ inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" </> blt)+ let groups = createChunks =<< inputs+ inputCtxFree <- Text.IO.readFile "src-literatetests/tests-context-free.blt"+ let groupsCtxFree = createChunks inputCtxFree+ 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+ 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 where -- this function might be implemented in a weirdly complex fashion; the -- reason being that it was copied from a somewhat more complex variant.@@ -129,10 +145,10 @@ -------------------- -- past this line: copy-pasta from other test (meh..) ---------------------roundTripEqual :: Text -> Expectation-roundTripEqual t =+roundTripEqual :: Config -> Text -> Expectation+roundTripEqual c t = fmap (fmap PPTextWrapper)- (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)+ (parsePrintModuleTests c "TestFakeFileName.hs" t) `shouldReturn` Right (PPTextWrapper t) newtype PPTextWrapper = PPTextWrapper Text@@ -167,3 +183,12 @@ } } +contextFreeTestConfig :: Config+contextFreeTestConfig =+ defaultTestConfig+ { _conf_layout = (_conf_layout defaultTestConfig)+ {_lconfig_indentPolicy = coerce IndentPolicyLeft+ ,_lconfig_alignmentLimit = coerce (1 :: Int)+ ,_lconfig_columnAlignMode = coerce ColumnAlignModeDisabled+ }+ }
+ src-literatetests/tests-context-free.blt view
@@ -0,0 +1,1131 @@++###############################################################################+###############################################################################+###############################################################################+#group type signatures+###############################################################################+###############################################################################+###############################################################################++#test simple001+func :: a -> a++#test long typeVar+func+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++#test keep linebreak mode+func+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lakjsdlkjasldkj+ -> lakjsdlkjasldkj++#test simple parens 1+func :: ((a))++#test simple parens 2+func :: (a -> a) -> a++#test simple parens 3+func :: a -> (a -> a)++#test did anyone say parentheses?+func :: (((((((((())))))))))++-- current output is.. funny. wonder if that can/needs to be improved..+#test give me more!+#pending+func :: ((((((((((((((((((((((((((((((((((((((((((()))))))))))))))))))))))))))))))))))))))))))++#test unit+func :: ()+++###############################################################################++#test paren'd func 1+func+ :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lakjsdlkjasldkj+ -> lakjsdlkjasldkj+ )++#test paren'd func 2+func+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> (lakjsdlkjasldkj -> lakjsdlkjasldkj)++#test paren'd func 3+func+ :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj)+ -> lakjsdlkjasldkj++#test paren'd func 4+func+ :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ -> lakjsdlkjasldkj++#test paren'd func 5+func+ :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ )++###############################################################################++#test type application 1+func :: asd -> Either a b++#test type application 2+func+ :: asd+ -> Either+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++#test type application 3+func+ :: asd+ -> Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++#test type application 4+func+ :: Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> asd++#test type application 5+func+ :: Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd)++#test type application 6+func+ :: Trither+ asd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )++#test type application paren 1+func+ :: asd+ -> ( Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )++#test type application paren 2+func+ :: asd+ -> ( Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++#test type application paren 3+func+ :: ( Trither+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> asd++###############################################################################++#test list simple+func :: [a -> b]++#test list func+func+ :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ ]++#test list paren+func+ :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ ]++################################################################## -- #############++#test tuple type 1+func :: (a, b, c)++#test tuple type 2+func :: ((a, b, c), (a, b, c), (a, b, c))++#test tuple type long+func+ :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )++#test tuple type nested+func+ :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd)+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ )++#test tuple type function+func+ :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ ]+###############################################################################+#test type operator stuff+#pending+test050 :: a :+: b+test051+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+test052+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd++###############################################################################++#test forall oneliner+{-# LANGUAGE ScopedTypeVariables #-}+func :: forall (a :: *) b . a -> b++#test forall context multiline+{-# LANGUAGE ScopedTypeVariables #-}+func+ :: forall m+ . Foo+ => ColMap2+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> m ()++#test forall no-context multiline+{-# LANGUAGE ScopedTypeVariables #-}+func+ :: forall m+ . ColMap2+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> ColInfo+ -> m ()++#test language pragma issue+{-# LANGUAGE ScopedTypeVariables #-}+func :: forall (a :: *) b . a -> b++#test comments 1+func :: a -> b -- comment++#test comments 2+funcA :: a -> b -- comment A+funcB :: a -> b -- comment B++#test comments all+#pending+-- a+func -- b+ :: -- c+ a -- d+ -> -- e+ ( -- f+ c -- g+ , -- h+ d -- i+ ) -- j+-- k++###############################################################################++#test ImplicitParams 1+{-# LANGUAGE ImplicitParams #-}+func :: (?asd::Int) -> ()++#test ImplicitParams 2+{-# LANGUAGE ImplicitParams #-}+func+ :: ( ?asd+ :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ )+ -> ()+++###############################################################################+###############################################################################+###############################################################################+#group type signatures pragmas+###############################################################################+###############################################################################+###############################################################################++#test inline pragma 1+func = f+ where+ {-# INLINE f #-}+ f = id++#test inline pragma 2+func = ($)+ where+ {-# INLINE ($) #-}+ ($) = id++#test inline pragma 3+func = f+ where+ {-# INLINE CONLIKE [1] f #-}+ f = id++#test inline pragma 4+#pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2.+func = f+ where+ {-# INLINE [~] f #-}+ f = id+++###############################################################################+###############################################################################+###############################################################################+#group equation.basic+###############################################################################+###############################################################################+###############################################################################+## some basic testing of different kinds of equations.+## some focus on column layouting for multiple-equation definitions.+## (that part probably is not implemented in any way yet.)++#test basic 1+func x = x++#test infix 1+x *** y = x++#test symbol prefix+(***) x y = x+++###############################################################################+###############################################################################+###############################################################################+#group equation.patterns+###############################################################################+###############################################################################+###############################################################################++#test wildcard+func _ = x++#test simple long pattern+#pending+func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable+ = x++#test simple multiline pattern+#pending+func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable+ reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable+ = x++#test another multiline pattern+#pending+func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable+ a+ b+ = x++#test simple constructor+func (A a) = a++#test list constructor+func (x:xr) = x++#test some other constructor symbol+#pending+func (x:+:xr) = x+++###############################################################################+###############################################################################+###############################################################################+#group equation.guards+###############################################################################+###############################################################################+###############################################################################+#test simple guard+func | True = x++#test multiple-clauses-1+func x+ | x = simple expression+ | otherwise = 0++#test multiple-clauses-2+func x+ | a somewhat longer guard x = "and a somewhat longer expession that does not"+ | otherwise = "fit without putting the guards in new lines"++#test multiple-clauses-3+func x+ | very long guard, another rather long guard that refers to x = nontrivial+ expression+ foo+ bar+ alsdkjlasdjlasj+ | otherwise = 0++#test multiple-clauses-4+func x+ | very long guard, another rather long guard that refers to x+ = nontrivialexpression foo bar alsdkjlasdjlasj+ | otherwise+ = 0++#test multiple-clauses-5+func x+ | very loooooooooooooooooooooooooooooong guard+ , another rather long guard that refers to x+ = nontrivial expression foo bar alsdkjlasdjlasj+ | otherwise+ = 0+++###############################################################################+###############################################################################+###############################################################################+#group expression.basic+###############################################################################+###############################################################################+###############################################################################++#test var+func = x++describe "infix op" $ do+#test 1+func = x + x++#test long+#pending+func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj+ + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj++#test long keep linemode 1+#pending+func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj+ + mweroiuxlskdfjlksj+ + mweroiuxlskdfjlksj++#test long keep linemode 2+#pending+func = mweroiuxlskdfjlksj+ + mweroiuxlskdfjlksj+ + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj++#test literals+func = 1+func = "abc"+func = 1.1e5+func = 'x'+func = 981409823458910394810928414192837123987123987123++#test lambdacase+{-# LANGUAGE LambdaCase #-}+func = \case+ FooBar -> x+ Baz -> y++#test lambda+func = \x -> abc++describe "app" $ do+#test 1+func = klajsdas klajsdas klajsdas++#test 2+func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd+ lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd+ lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd++#test 3+func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd+ lakjsdlajsdljas+ lakjsdlajsdljas+ lakjsdlajsdljas++###+#group expression.basic.sections+###++#test left+func = (1 +)++#test right+func = (+ 1)++#test left inf+## TODO: this could be improved..+func = (1 `abc`)++#test right inf+func = (`abc` 1)++###+#group tuples+###++#test 1+func = (abc, def)++#test 2+#pending+func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd+ , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd)++++###############################################################################+###############################################################################+###############################################################################+#group expression.do statements+###############################################################################+###############################################################################+###############################################################################++#test simple+func = do+ stmt+ stmt++#test bind+func = do+ x <- stmt+ stmt x++#test let+func = do+ let x = 13+ stmt x+++###############################################################################+###############################################################################+###############################################################################+#group expression.lists+###############################################################################+###############################################################################+###############################################################################++#test monad-comprehension-case-of+func =+ foooooo+ $ [ case+ foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo+ of+ _ -> True+ ]+++###############################################################################+###############################################################################+###############################################################################+#group expression.multiwayif+###############################################################################+###############################################################################+###############################################################################++#test simple+{-# LANGUAGE MultiWayIf #-}+func = if+ | cond1 -> loooooooooooooooooooooooooooooong expr1+ | cond2 -> loooooooooooooooooooooooooooooong expr2++#test simplenested+{-# LANGUAGE MultiWayIf #-}+func = do+ foo+ bar $ if+ | cond1 -> loooooooooooooooooooooooooooooong expr1+ | cond2 -> loooooooooooooooooooooooooooooong expr2+++###############################################################################+###############################################################################+###############################################################################+#group stylisticspecialcases+###############################################################################+###############################################################################+###############################################################################++#test operatorprefixalignment-even-with-multiline-alignbreak+func =+ foo+ $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa+ , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb+ ]+ ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc]+++###############################################################################+###############################################################################+###############################################################################+#group regression+###############################################################################+###############################################################################+###############################################################################++#test newlines-comment+func = do+ abc <- foo++--abc+return ()++#test parenthesis-around-unit+func = (())++#test let-defs indentation+func = do+ let+ foo True = True+ foo _ = False+ return ()++#test let-defs no indent+func = do+ let+ foo True = True+ foo _ = False+ return ()++#test let-defs no indent+func = do+ let+ foo = True+ b = False+ return ()++#test let-defs no indent+func =+ let+ foo = True+ b = False+ in return ()++#test record update indentation 1+func = do+ s <- mGet+ mSet $ s { _lstate_indent = _lstate_indent state }++#test record update indentation 2+func = do+ s <- mGet+ mSet $ s+ { _lstate_indent = _lstate_indent state+ , _lstate_foo = _lstate_foo state+ }++#test record update indentation 3+func = do+ s <- mGet+ mSet $ s+ { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , _lstate_foo = _lstate_foo kasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ }++#test record construction 1+func = Foo {_lstate_indent = _lstate_indent state}++#test record construction 2+func = Foo+ { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ }++#test record construction 3+func = do+ Foo+ { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ , _lstate_foo = _lstate_foo lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd+ }++#test post-indent comment+func = do+-- abc+ -- def+ return ()++#test post-unindent comment+func = do+ do+ return ()+ -- abc+ -- def+ return ()++#test CPP empty comment case+#pending CPP parsing needs fixing for roundTripEqual+{-# LANGUAGE CPP #-}+module Test where+func = do+#if FOO+ let x = 13+#endif+ stmt x++## really, the following should be handled by forcing the Alt to multiline+## because there are comments. as long as this is not implemented though,+## we should ensure the trivial solution works.+#test comment inline placement (temporary)+func+ :: Int -- basic indentation amount+ -> Int -- currently used width in current line (after indent)+ -- used to accurately calc placing of the current-line+ -> LayoutDesc+ -> Int++#test some indentation thingy+func =+ ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj+ $ abc+ $ def+ $ ghi+ $ jkl+ )++#test parenthesized operator+buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)+ where reassoc (v, e, w) = (v, (e, w))++#test record pattern matching stuff+downloadRepoPackage = case repo of+ RepoLocal {..} -> return ()+ RepoLocal { abc } -> return ()+ RepoLocal{} -> return ()++#test do let comment indentation level problem+func = do+ let+ (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'+ (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''+ -- default local dir target if there's no given target+ utargets'' = "foo"+ return ()++#test list comprehension comment placement+func =+ [ (thing, take 10 alts) --TODO: select best ones+ | (thing, _got, alts@(_:_)) <- nosuchFooThing+ , gast <- award+ ]++#test if-then-else comment placement+func = if x+ then if y -- y is important+ then foo+ else bar+ else Nothing++#test qualified infix pattern+#pending "TODO"+wrapPatPrepend pat prepElem = do+ patDocs <- layoutPat pat+ case Seq.viewl patDocs of+ Seq.EmptyL -> return $ Seq.empty+ x1 Seq.:< xR -> do+ x1' <- docSeq [prepElem, return x1]+ return $ x1' Seq.<| xR++#test type signature multiline forcing issue+layoutWriteNewlineBlock+ :: ( MonadMultiWriter Text.Builder.Builder m+ , MonadMultiState LayoutState m+ , MonadMultiWriter (Seq String) m+ )+ => m ()++#test multiwayif proper indentation+{-# LANGUAGE MultiWayIf #-}+readMergePersConfig path shouldCreate conf = do+ exists <- liftIO $ System.Directory.doesFileExist path+ if+ | exists -> do+ contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.+ fileConf <- case Data.Yaml.decodeEither contents of+ Left e -> do+ liftIO+ $ putStrErrLn+ $ "error reading in brittany config from "+ ++ path+ ++ ":"+ liftIO $ putStrErrLn e+ mzero+ Right x -> return x+ return $ fileConf Semigroup.<> conf+ | shouldCreate -> do+ liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap+ (Option . Just . runIdentity)+ staticDefaultConfig+ return $ conf+ | otherwise -> do+ return conf++#test nested pattern alignment issue"+func = BuildReport+ where+ convertInstallOutcome = case result of+ Left BR.PlanningFailed -> PlanningFailed+ Left (BR.DependentFailed p) -> DependencyFailed p+ Left (BR.DownloadFailed _) -> DownloadFailed+ Left (BR.UnpackFailed _) -> UnpackFailed+ Left (BR.ConfigureFailed _) -> ConfigureFailed+ Left (BR.BuildFailed _) -> BuildFailed+ Left (BR.TestsFailed _) -> TestsFailed+ Left (BR.InstallFailed _) -> InstallFailed+ Right (BR.BuildOk _ _ _) -> InstallOk++#test nested pattern alignment issue"+func = BuildReport+ where+ convertInstallOutcome = case result of+ Left BR.PlanningFailed -> PlanningFailed+ Left (BR.DependentFailed p) -> DependencyFailed p+ Left (BR.DownloadFailed _) -> DownloadFailed+ Left (BR.UnpackFailed _) -> UnpackFailed+ Left (BR.ConfigureFailed _) -> ConfigureFailed+ Left (BR.BuildFailed _) -> BuildFailed+ Left (BR.TestsFailed _) -> TestsFailed+ Left (BR.InstallFailed _) -> InstallFailed+ Right (BR.BuildOk _ _ _) -> InstallOk++#test partially overflowing alignment issue"+showPackageDetailedInfo pkginfo =+ renderStyle (style { lineLength = 80, ribbonsPerLine = 1 })+ $ char '*'+ $+$ something+ [ entry "Synopsis" synopsis hideIfNull reflowParagraphs+ , entry+ "Versions available"+ sourceVersions+ (altText null "[ Not available from server ]")+ (dispTopVersions 9 (preferredVersions pkginfo))+ , entry+ "Versions installed"+ installedVersions+ ( altText+ null+ (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")+ )+ (dispTopVersions 4 (preferredVersions pkginfo))+ , entry "Homepage" homepage orNotSpecified text+ , entry "Bug reports" bugReports orNotSpecified text+ , entry "Description" description hideIfNull reflowParagraphs+ , entry "Category" category hideIfNull text+ , entry "License" license alwaysShow disp+ , entry "Author" author hideIfNull reflowLines+ , entry "Maintainer" maintainer hideIfNull reflowLines+ , entry "Source repo" sourceRepo orNotSpecified text+ , entry "Executables" executables hideIfNull (commaSep text)+ , entry "Flags" flags hideIfNull (commaSep dispFlag)+ , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)+ , entry "Documentation" haddockHtml showIfInstalled text+ , entry "Cached" haveTarball alwaysShow dispYesNo+ , if not (hasLib pkginfo)+ then empty+ else text "Modules:"+ $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))+ ]++#test issue 7a+isValidPosition position+ | validX && validY = Just position+ | otherwise = Nothing++#test issue-6-pattern-linebreak-validity+## this is ugly, but at least syntactically valid.+foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do+ (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String+ -> IO Bool) <-+ ReflexHost.newExternalEvent+ liftIO . forkIO . forever $ getLine >>= inputFire+ ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent++#test issue 16+foldrDesc f z = unSwitchQueue $ \q ->+ switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q)++#test issue 18+autocheckCases =+ [ ("Never Deadlocks", representative deadlocksNever)+ , ("No Exceptions", representative exceptionsNever)+ , ("Consistent Result", alwaysSame) -- already representative+ ]++#test issue 18b+autocheckCases =+ [ ("Never Deadlocks", representative deadlocksNever)+ , ("No Exceptions", representative exceptionsNever)+ , ( "Consistent Result"+ , alwaysSame -- already representative+ )+ ]++#test issue 18c+func =+ [ (abc, (1111, 1111))+ , (def, (2, 2))+ , foo -- comment+ ]++#test issue 26+foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo+ where g a b = b + b * a++#test issue 26b+foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo++#test aggressive alignment 1+func = do+ abc <- expr+ abcccccccccccccccccc <- expr+ abcccccccccccccccccccccccccccccccccccccccccc <- expr+ abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr++#test example alignment 1+func (MyLongFoo abc def) = 1+func (Bar a d) = 2+func _ = 3++#test listcomprehension-case-of+parserCompactLocation =+ [ try+ $ [ ParseRelAbs (Text.Read.read digits) _ _+ | digits <- many1 digit+ , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe+ [ case divPart of+ Nothing -> Left $ Text.Read.read digits+ Just ddigits ->+ Right $ Text.Read.read digits % Text.Read.read ddigits+ | digits <- many1 digit+ , divPart <- optionMaybe (string "/" *> many1 digit)+ ]+ ]+ ]++#test opapp-specialcasing-1+func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo+ foooooooooooooooooooooooooooooooo+ foooooooooooooooooooooooooooooooo++#test opapp-specialcasing-2+func =+ fooooooooooooooooooooooooooooooooo+ + foooooooooooooooooooooooooooooooo+ foooooooooooooooooooooooooooooooo+ foooooooooooooooooooooooooooooooo++#test opapp-specialcasing-3+func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo+ [ foooooooooooooooooooooooooooooooo+ , foooooooooooooooooooooooooooooooo+ , foooooooooooooooooooooooooooooooo+ ]++#test opapp-indenting+parserPrim =+ [ r+ | r <-+ [ SGPPrimFloat $ bool id (0 -) minus $ readGnok+ "parserPrim"+ (d1 ++ d2 ++ d3 ++ d4)+ | d2 <- string "."+ , d3 <- many1 (oneOf "0123456789")+ , _ <- string "f"+ ]+ <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral+ (readGnok "parserPrim" d1 :: Integer)+ | _ <- string "f"+ ]+ <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral+ (readGnok "parserPrim" d1 :: Integer)+ | _ <- string "i"+ ]+ ]++#test another-parspacing-testcase++samples = (SV.unpackaaaaadat) <&> \f ->+ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa++#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+ }+ parsePrintModule config text++#test issue 38++{-# LANGUAGE TypeApplications #-}+foo = bar @Baz++#test comment-before-BDCols+{-# LANGUAGE TypeApplications #-}+layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do+ docAlt+ $ -- one-line solution+ [ docCols+ (ColBindingLine alignmentToken)+ [ docSeq (patPartInline ++ [guardPart])+ , docSeq+ [ appSep $ return binderDoc+ , docForceSingleline $ return body+ , wherePart+ ]+ ]+ | not hasComments+ , [(guards, body, _bodyRaw)] <- [clauseDocs]+ , let guardPart = singleLineGuardsDoc guards+ , wherePart <- case mWhereDocs of+ Nothing -> return @[] $ docEmpty+ Just [w] -> return @[] $ docSeq+ [ docSeparator+ , appSep $ docLit $ Text.pack "where"+ , docSetIndentLevel $ docForceSingleline $ return w+ ]+ _ -> []+ ]+ ++ -- one-line solution + where in next line(s)+ [ docLines+ $ [ docCols+ (ColBindingLine alignmentToken)+ [ docSeq (patPartInline ++ [guardPart])+ , docSeq+ [appSep $ return binderDoc, docForceParSpacing $ return body]+ ]+ ]+ ++ wherePartMultiLine+ | [(guards, body, _bodyRaw)] <- [clauseDocs]+ , let guardPart = singleLineGuardsDoc guards+ , Data.Maybe.isJust mWhereDocs+ ]+ ++ -- two-line solution + where in next line(s)+ [ docLines+ $ [ docForceSingleline+ $ docSeq (patPartInline ++ [guardPart, return binderDoc])+ , docEnsureIndent BrIndentRegular $ docForceSingleline $ return+ body+ ]+ ++ wherePartMultiLine+ | [(guards, body, _bodyRaw)] <- [clauseDocs]+ , let guardPart = singleLineGuardsDoc guards+ ]++#test comment-testcase-17+{-# LANGUAGE MultiWayIf #-}+func = do+ let+ foo = if+ | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO+ -> max+ (defLen - 0.2) -- TODO+ (defLen * 0.8)+ | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO+ return True++#test issue 49++foo n = case n of+ 1 -> True+ -1 -> False++bar n = case n of+ (-2, -2) -> (-2, -2)++#test issue 48 a++foo =+ let+ a = b@1+ cccc = ()+ in foo++#test issue 48 b++{-# LANGUAGE TypeApplications #-}+foo =+ let+ a = b @1+ cccc = ()+ in foo+++###############################################################################+###############################################################################+###############################################################################+#group pending+###############################################################################+###############################################################################+###############################################################################++++## this testcase is not about idempotency, but about _how_ the output differs+## from the input; i cannot really express this yet with the current+## test-suite.+## #test ayaz+##+## myManageHook =+## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience]+## <+> composeAll+## [ className =? "Pidgin" --> doFloat+## , className =? "XCalc" --> doFloat+## -- plan9port's acme+## , className =? "acme" --> doFloat+## -- Acme with Vi bindings editor+## , title =? "ED" --> doFloat+## , title =? "wlc-x11" --> doFloat+## , className =? "Skype" --> doFloat+## , className =? "ffplay" --> doFloat+## , className =? "mpv" --> doFloat+## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc.+## -- Firefox works well tiled, but it has dialog windows we want to float.+## , appName =? "Browser" --> doFloat+## ]+## where+## role = stringProperty "WM_WINDOW_ROLE"+
− src-literatetests/tests.blt
@@ -1,1080 +0,0 @@--###############################################################################-###############################################################################-###############################################################################-#group type signatures-###############################################################################-###############################################################################-###############################################################################--#test simple001-func :: a -> a--#test long typeVar-func- :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd--#test keep linebreak mode-func- :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lakjsdlkjasldkj- -> lakjsdlkjasldkj--#test simple parens 1-func :: ((a))--#test simple parens 2-func :: (a -> a) -> a--#test simple parens 3-func :: a -> (a -> a)--#test did anyone say parentheses?-func :: (((((((((())))))))))---- current output is.. funny. wonder if that can/needs to be improved..-#test give me more!-#pending-func :: ((((((((((((((((((((((((((((((((((((((((((()))))))))))))))))))))))))))))))))))))))))))--#test unit-func :: ()---###############################################################################--#test paren'd func 1-func- :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lakjsdlkjasldkj- -> lakjsdlkjasldkj- )--#test paren'd func 2-func- :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> (lakjsdlkjasldkj -> lakjsdlkjasldkj)--#test paren'd func 3-func- :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj)- -> lakjsdlkjasldkj--#test paren'd func 4-func- :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )- -> lakjsdlkjasldkj--#test paren'd func 5-func- :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )- )--###############################################################################--#test type application 1-func :: asd -> Either a b--#test type application 2-func- :: asd- -> Either- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd--#test type application 3-func- :: asd- -> Trither- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd--#test type application 4-func- :: Trither- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> asd--#test type application 5-func- :: Trither- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd)--#test type application 6-func- :: Trither- asd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )--#test type application paren 1-func- :: asd- -> ( Trither- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )--#test type application paren 2-func- :: asd- -> ( Trither- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd--#test type application paren 3-func- :: ( Trither- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )- lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> asd--###############################################################################--#test list simple-func :: [a -> b]--#test list func-func- :: [ lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- ]--#test list paren-func- :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )- ]--################################################################## -- #############--#test tuple type 1-func :: (a, b, c)--#test tuple type 2-func :: ((a, b, c), (a, b, c), (a, b, c))--#test tuple type long-func- :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )--#test tuple type nested-func- :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd)- , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )- )--#test tuple type function-func- :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )- ]-###############################################################################-#test type operator stuff-#pending-test050 :: a :+: b-test051 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd-test052 :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd--###############################################################################--#test forall oneliner-{-# LANGUAGE ScopedTypeVariables #-}-func :: forall (a :: *) b . a -> b--#test forall context multiline-{-# LANGUAGE ScopedTypeVariables #-}-func- :: forall m- . Foo- => ColMap2- -> ColInfo- -> ColInfo- -> ColInfo- -> ColInfo- -> m ()--#test forall no-context multiline-{-# LANGUAGE ScopedTypeVariables #-}-func- :: forall m- . ColMap2- -> ColInfo- -> ColInfo- -> ColInfo- -> ColInfo- -> ColInfo- -> m ()--#test language pragma issue-{-# LANGUAGE ScopedTypeVariables #-}-func :: forall (a :: *) b . a -> b--#test comments 1-func :: a -> b -- comment--#test comments 2-funcA :: a -> b -- comment A-funcB :: a -> b -- comment B--#test comments all-#pending--- a-func -- b- :: -- c- a -- d- -> -- e- ( -- f- c -- g- , -- h- d -- i- ) -- j--- k--###############################################################################--#test ImplicitParams 1-{-# LANGUAGE ImplicitParams #-}-func :: (?asd::Int) -> ()--#test ImplicitParams 2-{-# LANGUAGE ImplicitParams #-}-func- :: ( ?asd- :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- )- -> ()---###############################################################################-###############################################################################-###############################################################################-#group type signatures pragmas-###############################################################################-###############################################################################-###############################################################################--#test inline pragma 1-func = f- where- {-# INLINE f #-}- f = id--#test inline pragma 2-func = ($)- where- {-# INLINE ($) #-}- ($) = id--#test inline pragma 3-func = f- where- {-# INLINE CONLIKE [1] f #-}- f = id--#test inline pragma 4-#pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2.-func = f- where- {-# INLINE [~] f #-}- f = id---###############################################################################-###############################################################################-###############################################################################-#group equation.basic-###############################################################################-###############################################################################-###############################################################################-## some basic testing of different kinds of equations.-## some focus on column layouting for multiple-equation definitions.-## (that part probably is not implemented in any way yet.)--#test basic 1-func x = x--#test infix 1-x *** y = x--#test symbol prefix-(***) x y = x---###############################################################################-###############################################################################-###############################################################################-#group equation.patterns-###############################################################################-###############################################################################-###############################################################################--#test wildcard-func _ = x--#test simple long pattern-#pending-func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable- = x--#test simple multiline pattern-#pending-func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable- reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable- = x--#test another multiline pattern-#pending-func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable- a- b- = x--#test simple constructor-func (A a) = a--#test list constructor-func (x:xr) = x--#test some other constructor symbol-#pending-func (x:+:xr) = x---###############################################################################-###############################################################################-###############################################################################-#group equation.guards-###############################################################################-###############################################################################-###############################################################################-#test simple guard-func | True = x--#test multiple-clauses-1-func x | x = simple expression- | otherwise = 0--#test multiple-clauses-2-func x- | a somewhat longer guard x = "and a somewhat longer expession that does not"- | otherwise = "fit without putting the guards in new lines"--#test multiple-clauses-3-func x- | very long guard, another rather long guard that refers to x = nontrivial- expression- foo- bar- alsdkjlasdjlasj- | otherwise = 0--#test multiple-clauses-4-func x- | very long guard, another rather long guard that refers to x- = nontrivialexpression foo bar alsdkjlasdjlasj- | otherwise- = 0--#test multiple-clauses-5-func x- | very loooooooooooooooooooooooooooooong guard- , another rather long guard that refers to x- = nontrivial expression foo bar alsdkjlasdjlasj- | otherwise- = 0---###############################################################################-###############################################################################-###############################################################################-#group expression.basic-###############################################################################-###############################################################################-###############################################################################--#test var-func = x--describe "infix op" $ do-#test 1-func = x + x--#test long-#pending-func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj- + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj--#test long keep linemode 1-#pending-func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj- + mweroiuxlskdfjlksj- + mweroiuxlskdfjlksj--#test long keep linemode 2-#pending-func = mweroiuxlskdfjlksj- + mweroiuxlskdfjlksj- + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj--#test literals-func = 1-func = "abc"-func = 1.1e5-func = 'x'-func = 981409823458910394810928414192837123987123987123--#test lambdacase-{-# LANGUAGE LambdaCase #-}-func = \case- FooBar -> x- Baz -> y--#test lambda-func = \x -> abc--describe "app" $ do-#test 1-func = klajsdas klajsdas klajsdas--#test 2-func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd- lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd- lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd--#test 3-func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas- lakjsdlajsdljas- lakjsdlajsdljas--###-#group expression.basic.sections-###--#test left-func = (1+)--#test right-func = (+1)--#test left inf-## TODO: this could be improved..-func = (1`abc`)--#test right inf-func = (`abc`1)--###-#group tuples-###--#test 1-func = (abc, def)--#test 2-#pending-func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd- , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd)----###############################################################################-###############################################################################-###############################################################################-#group expression.do statements-###############################################################################-###############################################################################-###############################################################################--#test simple-func = do- stmt- stmt--#test bind-func = do- x <- stmt- stmt x--#test let-func = do- let x = 13- stmt x---###############################################################################-###############################################################################-###############################################################################-#group expression.lists-###############################################################################-###############################################################################-###############################################################################--#test monad-comprehension-case-of-func =- foooooo- $ [ case- foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo- of- _ -> True- ]---###############################################################################-###############################################################################-###############################################################################-#group expression.multiwayif-###############################################################################-###############################################################################-###############################################################################--#test simple-{-# LANGUAGE MultiWayIf #-}-func = if- | cond1 -> loooooooooooooooooooooooooooooong expr1- | cond2 -> loooooooooooooooooooooooooooooong expr2--#test simplenested-{-# LANGUAGE MultiWayIf #-}-func = do- foo- bar $ if- | cond1 -> loooooooooooooooooooooooooooooong expr1- | cond2 -> loooooooooooooooooooooooooooooong expr2---###############################################################################-###############################################################################-###############################################################################-#group stylisticspecialcases-###############################################################################-###############################################################################-###############################################################################--#test operatorprefixalignment-even-with-multiline-alignbreak-func =- foo- $ [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa- , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb- ]- ++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc]---###############################################################################-###############################################################################-###############################################################################-#group regression-###############################################################################-###############################################################################-###############################################################################--#test newlines-comment-func = do- abc <- foo----abc-return ()--#test parenthesis-around-unit-func = (())--#test let-defs indentation-func = do- let foo True = True- foo _ = False- return ()--#test record update indentation 1-func = do- s <- mGet- mSet $ s { _lstate_indent = _lstate_indent state }--#test record update indentation 2-func = do- s <- mGet- mSet $ s { _lstate_indent = _lstate_indent state- , _lstate_indent = _lstate_indent state- }--#test record update indentation 3-func = do- s <- mGet- mSet $ s- { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- , _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd- }--#test post-indent comment-func = do--- abc- -- def- return ()--#test post-unindent comment-func = do- do- return ()- -- abc- -- def- return ()--#test CPP empty comment case-#pending CPP parsing needs fixing for roundTripEqual-{-# LANGUAGE CPP #-}-module Test where-func = do-#if FOO- let x = 13-#endif- stmt x--## really, the following should be handled by forcing the Alt to multiline-## because there are comments. as long as this is not implemented though,-## we should ensure the trivial solution works.-#test comment inline placement (temporary)-func- :: Int -- basic indentation amount- -> Int -- currently used width in current line (after indent)- -- used to accurately calc placing of the current-line- -> LayoutDesc- -> Int--#test some indentation thingy-func =- ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj- $ abc- $ def- $ ghi- $ jkl- )--#test parenthesized operator-buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)- where reassoc (v, e, w) = (v, (e, w))--#test record pattern matching stuff-downloadRepoPackage = case repo of- RepoLocal {..} -> return ()- RepoLocal { abc } -> return ()- RepoLocal{} -> return ()--#test do let comment indentation level problem-func = do- let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'- (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''- -- default local dir target if there's no given target- utargets'' = "foo"- return ()--#test list comprehension comment placement-func =- [ (thing, take 10 alts) --TODO: select best ones- | (thing, _got, alts@(_:_)) <- nosuchFooThing- , gast <- award- ]--#test if-then-else comment placement-func = if x- then if y -- y is important- then foo- else bar- else Nothing--#test qualified infix pattern-#pending "TODO"-wrapPatPrepend pat prepElem = do- patDocs <- layoutPat pat- case Seq.viewl patDocs of- Seq.EmptyL -> return $ Seq.empty- x1 Seq.:< xR -> do- x1' <- docSeq [prepElem, return x1]- return $ x1' Seq.<| xR--#test type signature multiline forcing issue-layoutWriteNewlineBlock- :: ( MonadMultiWriter Text.Builder.Builder m- , MonadMultiState LayoutState m- , MonadMultiWriter (Seq String) m- )- => m ()--#test multiwayif proper indentation-{-# LANGUAGE MultiWayIf #-}-readMergePersConfig path shouldCreate conf = do- exists <- liftIO $ System.Directory.doesFileExist path- if- | exists -> do- contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.- fileConf <- case Data.Yaml.decodeEither contents of- Left e -> do- liftIO- $ putStrErrLn- $ "error reading in brittany config from "- ++ path- ++ ":"- liftIO $ putStrErrLn e- mzero- Right x -> return x- return $ fileConf Semigroup.<> conf- | shouldCreate -> do- liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap- (Option . Just . runIdentity)- staticDefaultConfig- return $ conf- | otherwise -> do- return conf--#test nested pattern alignment issue"-func = BuildReport- where- convertInstallOutcome = case result of- Left BR.PlanningFailed -> PlanningFailed- Left (BR.DependentFailed p) -> DependencyFailed p- Left (BR.DownloadFailed _) -> DownloadFailed- Left (BR.UnpackFailed _) -> UnpackFailed- Left (BR.ConfigureFailed _) -> ConfigureFailed- Left (BR.BuildFailed _) -> BuildFailed- Left (BR.TestsFailed _) -> TestsFailed- Left (BR.InstallFailed _) -> InstallFailed- Right (BR.BuildOk _ _ _ ) -> InstallOk--#test nested pattern alignment issue"-func = BuildReport- where- convertInstallOutcome = case result of- Left BR.PlanningFailed -> PlanningFailed- Left (BR.DependentFailed p) -> DependencyFailed p- Left (BR.DownloadFailed _) -> DownloadFailed- Left (BR.UnpackFailed _) -> UnpackFailed- Left (BR.ConfigureFailed _) -> ConfigureFailed- Left (BR.BuildFailed _) -> BuildFailed- Left (BR.TestsFailed _) -> TestsFailed- Left (BR.InstallFailed _) -> InstallFailed- Right (BR.BuildOk _ _ _ ) -> InstallOk--#test partially overflowing alignment issue"-showPackageDetailedInfo pkginfo =- renderStyle (style { lineLength = 80, ribbonsPerLine = 1 })- $ char '*'- $+$ something- [ entry "Synopsis" synopsis hideIfNull reflowParagraphs- , entry "Versions available"- sourceVersions- (altText null "[ Not available from server ]")- (dispTopVersions 9 (preferredVersions pkginfo))- , entry- "Versions installed"- installedVersions- ( altText- null- (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")- )- (dispTopVersions 4 (preferredVersions pkginfo))- , entry "Homepage" homepage orNotSpecified text- , entry "Bug reports" bugReports orNotSpecified text- , entry "Description" description hideIfNull reflowParagraphs- , entry "Category" category hideIfNull text- , entry "License" license alwaysShow disp- , entry "Author" author hideIfNull reflowLines- , entry "Maintainer" maintainer hideIfNull reflowLines- , entry "Source repo" sourceRepo orNotSpecified text- , entry "Executables" executables hideIfNull (commaSep text)- , entry "Flags" flags hideIfNull (commaSep dispFlag)- , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)- , entry "Documentation" haddockHtml showIfInstalled text- , entry "Cached" haveTarball alwaysShow dispYesNo- , if not (hasLib pkginfo)- then empty- else text "Modules:"- $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))- ]--#test issue 7a-isValidPosition position | validX && validY = Just position- | otherwise = Nothing--#test issue-6-pattern-linebreak-validity-## this is ugly, but at least syntactically valid.-foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do- (inputEvent :: Reflex.Event Reflex.Spider String, inputFire :: String- -> IO Bool ) <-- ReflexHost.newExternalEvent- liftIO . forkIO . forever $ getLine >>= inputFire- ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent--#test issue 16-foldrDesc f z = unSwitchQueue $ \q ->- switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q)--#test issue 18-autocheckCases =- [ ("Never Deadlocks" , representative deadlocksNever)- , ("No Exceptions" , representative exceptionsNever)- , ("Consistent Result", alwaysSame) -- already representative- ]--#test issue 18b-autocheckCases =- [ ("Never Deadlocks", representative deadlocksNever)- , ("No Exceptions" , representative exceptionsNever)- , ( "Consistent Result"- , alwaysSame -- already representative- )- ]--#test issue 18c-func =- [ (abc, (1111, 1111))- , (def, (2, 2))- , foo -- comment- ]--#test issue 26-foo a b = g a b -- fooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo- where g a b = b + b * a--#test issue 26b-foo a b = g a b where g a b = b + b * a -- fooooooooooooooooooooooooooooooooooo--#test aggressive alignment 1-func = do- abc <- expr- abcccccccccccccccccc <- expr- abcccccccccccccccccccccccccccccccccccccccccc <- expr- abccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc <- expr--#test example alignment 1-func (MyLongFoo abc def) = 1-func (Bar a d ) = 2-func _ = 3--#test listcomprehension-case-of-parserCompactLocation =- [ try- $ [ ParseRelAbs (Text.Read.read digits) _ _- | digits <- many1 digit- , rel1 :: Maybe (Either Int (Ratio Int)) <- optionMaybe- [ case divPart of- Nothing -> Left $ Text.Read.read digits- Just ddigits ->- Right $ Text.Read.read digits % Text.Read.read ddigits- | digits <- many1 digit- , divPart <- optionMaybe (string "/" *> many1 digit)- ]- ]- ]--#test opapp-specialcasing-1-func = fooooooooooooooooooooooooooooooooo $ foooooooooooooooooooooooooooooooo- foooooooooooooooooooooooooooooooo- foooooooooooooooooooooooooooooooo--#test opapp-specialcasing-2-func =- fooooooooooooooooooooooooooooooooo- + foooooooooooooooooooooooooooooooo foooooooooooooooooooooooooooooooo- foooooooooooooooooooooooooooooooo--#test opapp-specialcasing-3-func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo- [ foooooooooooooooooooooooooooooooo- , foooooooooooooooooooooooooooooooo- , foooooooooooooooooooooooooooooooo- ]--#test opapp-indenting-parserPrim =- [ r- | r <-- [ SGPPrimFloat $ bool id (0-) minus $ readGnok "parserPrim"- (d1 ++ d2 ++ d3 ++ d4)- | d2 <- string "."- , d3 <- many1 (oneOf "0123456789")- , _ <- string "f"- ]- <|> [ SGPPrimFloat $ bool id (0-) minus $ fromIntegral- (readGnok "parserPrim" d1 :: Integer)- | _ <- string "f"- ]- <|> [ SGPPrimInt $ bool id (0-) minus $ fromIntegral- (readGnok "parserPrim" d1 :: Integer)- | _ <- string "i"- ]- ]--#test another-parspacing-testcase--samples = (SV.unpackaaaaadat) <&> \f ->- aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa--#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- }- parsePrintModule config text--#test issue 38--{-# LANGUAGE TypeApplications #-}-foo = bar @Baz--#test comment-before-BDCols-{-# LANGUAGE TypeApplications #-}-layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs = do- docAlt- $ -- one-line solution- [ docCols- (ColBindingLine alignmentToken)- [ docSeq (patPartInline ++ [guardPart])- , docSeq- [ appSep $ return binderDoc- , docForceSingleline $ return body- , wherePart- ]- ]- | not hasComments- , [(guards, body, _bodyRaw)] <- [clauseDocs]- , let guardPart = singleLineGuardsDoc guards- , wherePart <- case mWhereDocs of- Nothing -> return @[] $ docEmpty- Just [w] -> return @[] $ docSeq- [ docSeparator- , appSep $ docLit $ Text.pack "where"- , docSetIndentLevel $ docForceSingleline $ return w- ]- _ -> []- ]- ++ -- one-line solution + where in next line(s)- [ docLines- $ [ docCols- (ColBindingLine alignmentToken)- [ docSeq (patPartInline ++ [guardPart])- , docSeq- [appSep $ return binderDoc, docForceParSpacing $ return body]- ]- ]- ++ wherePartMultiLine- | [(guards, body, _bodyRaw)] <- [clauseDocs]- , let guardPart = singleLineGuardsDoc guards- , Data.Maybe.isJust mWhereDocs- ]- ++ -- two-line solution + where in next line(s)- [ docLines- $ [ docForceSingleline- $ docSeq (patPartInline ++ [guardPart, return binderDoc])- , docEnsureIndent BrIndentRegular $ docForceSingleline $ return- body- ]- ++ wherePartMultiLine- | [(guards, body, _bodyRaw)] <- [clauseDocs]- , let guardPart = singleLineGuardsDoc guards- ]--#test comment-testcase-17-{-# LANGUAGE MultiWayIf #-}-func = do- let foo = if- | Constuctoooooooooooooooooooooooooooooooooooor `elem` artics -- TODO- -> max- (defLen - 0.2) -- TODO- (defLen * 0.8)- | otherwise -> max (defLen - 0.05) (defLen * 0.95) -- TODO- return True--#test issue 49--foo n = case n of- 1 -> True- -1 -> False--bar n = case n of- (-2, -2) -> (-2, -2)--#test issue 48 a--foo =- let a = b@1- cccc = ()- in foo--#test issue 48 b--{-# LANGUAGE TypeApplications #-}-foo =- let a = b @1- cccc = ()- in foo---###############################################################################-###############################################################################-###############################################################################-#group pending-###############################################################################-###############################################################################-###############################################################################----## this testcase is not about idempotency, but about _how_ the output differs-## from the input; i cannot really express this yet with the current-## test-suite.-## #test ayaz-## -## myManageHook =-## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience]-## <+> composeAll-## [ className =? "Pidgin" --> doFloat-## , className =? "XCalc" --> doFloat-## -- plan9port's acme-## , className =? "acme" --> doFloat-## -- Acme with Vi bindings editor-## , title =? "ED" --> doFloat-## , title =? "wlc-x11" --> doFloat-## , className =? "Skype" --> doFloat-## , className =? "ffplay" --> doFloat-## , className =? "mpv" --> doFloat-## , className =? "Plugin-container" --> doFloat -- Firefox flash, etc.-## -- Firefox works well tiled, but it has dialog windows we want to float.-## , appName =? "Browser" --> doFloat-## ]-## where-## role = stringProperty "WM_WINDOW_ROLE"-
src/Language/Haskell/Brittany/Internal.hs view
@@ -20,7 +20,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Data.Data-import Control.Monad.Trans.Either+import Control.Monad.Trans.Except import Data.HList.HList import Data.CZipWith @@ -62,7 +62,7 @@ -- Note that this function ignores/resets all config values regarding -- debugging, i.e. it will never use `trace`/write to stderr. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)-parsePrintModule configRaw inputText = runEitherT $ do+parsePrintModule configRaw inputText = runExceptT $ do let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let config_pp = config & _conf_preprocessor@@ -87,7 +87,7 @@ cppCheckFunc (hackTransform $ Text.unpack inputText) case parseResult of- Left err -> left $ [ErrorInput err]+ Left err -> throwE $ [ErrorInput err] Right x -> pure $ x (errsWarns, outputTextL) <- do let omitCheck =@@ -117,7 +117,7 @@ case config & _conf_errorHandling & _econf_Werror & confUnpack of False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) True -> not $ null errsWarns- if hasErrors then left $ errsWarns else pure $ TextL.toStrict outputTextL+ if hasErrors then throwE $ errsWarns else pure $ TextL.toStrict outputTextL @@ -320,8 +320,8 @@ ppDecl :: LHsDecl RdrName -> PPMLocal () ppDecl d@(L loc decl) = case decl of- SigD sig -> -- trace (_sigHead sig) $- withTransformedAnns d $ do+ SigD sig -> -- trace (_sigHead sig) $+ withTransformedAnns d $ do -- runLayouter $ Old.layoutSig (L loc sig) briDoc <- briDocMToPPM $ layoutSig (L loc sig) layoutBriDoc briDoc@@ -332,9 +332,9 @@ eitherNode <- layoutBind (L loc bind) case eitherNode of Left ns -> docLines $ return <$> ns- Right n -> return n+ Right n -> return n layoutBriDoc briDoc- _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc+ _ -> briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc _sigHead :: Sig RdrName -> String _sigHead = \case
src/Language/Haskell/Brittany/Internal/Config.hs view
@@ -8,7 +8,8 @@ , configParser , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled- , readMergePersConfig+ , readConfig+ , writeDefaultConfig , showConfigYaml ) where@@ -198,29 +199,37 @@ -- , infoIntersperse = True -- } -readMergePersConfig- :: System.IO.FilePath -> Bool -> CConfig Option -> MaybeT IO (CConfig Option)-readMergePersConfig path shouldCreate conf = do++-- | Reads a config from a file. If the file does not exist, returns+-- Nothing. If the file exists and parsing fails, prints to stderr and+-- aborts the MaybeT. Otherwise succeed via Just.+-- If the second parameter is True and the file does not exist, writes the+-- staticDefaultConfig to the file.+readConfig+ :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Option))+readConfig path = do exists <- liftIO $ System.Directory.doesFileExist path- if- | exists -> do- contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.- fileConf <- case Data.Yaml.decodeEither contents of- Left e -> do- liftIO- $ putStrErrLn- $ "error reading in brittany config from " ++ path ++ ":"- liftIO $ putStrErrLn e- mzero- Right x -> return x- return $ fileConf Semigroup.<> conf- | shouldCreate -> do- liftIO $ ByteString.writeFile path- $ Data.Yaml.encode- $ cMap (Option . Just . runIdentity) staticDefaultConfig- return $ conf- | otherwise -> do- return conf+ if exists+ then do+ contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.+ fileConf <- case Data.Yaml.decodeEither contents of+ Left e -> do+ liftIO+ $ putStrErrLn+ $ "error reading in brittany config from "+ ++ path+ ++ ":"+ liftIO $ putStrErrLn e+ mzero+ Right x -> return x+ return $ Just fileConf+ else return $ Nothing++writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m ()+writeDefaultConfig path =+ liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap+ (Option . Just . runIdentity)+ staticDefaultConfig showConfigYaml :: Config -> String showConfigYaml = Data.ByteString.Char8.unpack
src/Language/Haskell/Brittany/Internal/Config/Types.hs view
@@ -191,7 +191,7 @@ | IndentPolicyFree -- can create new indentations whereever | IndentPolicyMultiple -- can create indentations only -- at any n * amount.- deriving (Show, Generic, Data)+ deriving (Eq, Show, Generic, Data) data AltChooser = AltChooserSimpleQuick -- always choose last alternative. -- leads to tons of sparsely filled
src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs view
@@ -58,26 +58,24 @@ -> (GHC.DynFlags -> IO (Either String a)) -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleWithCpp cpp opts args fp dynCheck =- ExactPrint.ghcWrapper $ EitherT.runEitherT $ do+ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do dflags0 <- lift $ GHC.getSessionDynFlags- (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine- dflags0- (GHC.noLoc <$> args)+ (dflags1, leftover, warnings) <- lift+ $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) void $ lift $ GHC.setSessionDynFlags dflags1- dflags2 <- lift $ ExactPrint.initDynFlags fp+ dflags2 <- lift $ ExactPrint.initDynFlags fp when (not $ null leftover)- $ EitherT.left+ $ ExceptT.throwE $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) when (not $ null warnings)- $ EitherT.left+ $ ExceptT.throwE $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> \(L _ s) -> s)- x <- EitherT.EitherT $ liftIO $ dynCheck dflags2+ x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp- EitherT.hoistEither- $ either (\(span, err) -> Left $ show span ++ ": " ++ err)- (\(a, m) -> Right (a, m, x))+ either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)+ (\(a, m) -> pure (a, m, x)) $ ExactPrint.postParseTransform res opts parseModuleFromString@@ -87,22 +85,21 @@ -> String -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleFromString args fp dynCheck str =- ExactPrint.ghcWrapper $ EitherT.runEitherT $ do+ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str- (dflags1, leftover, warnings) <-- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)+ (dflags1, leftover, warnings) <- lift+ $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) when (not $ null leftover)- $ EitherT.left+ $ ExceptT.throwE $ "when parsing ghc flags: leftover flags: " ++ show (leftover <&> \(L _ s) -> s) when (not $ null warnings)- $ EitherT.left+ $ ExceptT.throwE $ "when parsing ghc flags: encountered warnings: " ++ show (warnings <&> \(L _ s) -> s)- x <- EitherT.EitherT $ liftIO $ dynCheck dflags1- EitherT.hoistEither- $ either (\(span, err) -> Left $ show span ++ ": " ++ err)- (\(a, m) -> Right (a, m, x))+ x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1+ either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)+ (\(a, m) -> pure (a, m, x)) $ ExactPrint.parseWith dflags1 fp GHC.parseModule str -----------@@ -220,11 +217,18 @@ extractToplevelAnns lmod anns = output where (L _ (HsModule _ _ _ ldecls _ _)) = lmod- declMap :: Map ExactPrint.AnnKey ExactPrint.AnnKey- declMap = Map.unions $ ldecls <&> \ldecl ->+ declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey+ declMap1 = Map.unions $ ldecls <&> \ldecl -> Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl)- modKey = ExactPrint.mkAnnKey lmod- output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns+ declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey+ declMap2 =+ Map.fromList+ $ [ (captured, declMap1 Map.! k)+ | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns+ ]+ declMap = declMap1 `Map.union` declMap2+ modKey = ExactPrint.mkAnnKey lmod+ output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m)
src/Language/Haskell/Brittany/Internal/LayouterBasics.hs view
@@ -42,11 +42,13 @@ , appSep , docCommaSep , docParenLSep+ , docTick , spacifyDocs , briDocMToPPM , allocateNode , docSharedWrapper , hasAnyCommentsBelow+ , hasAnnKeyword ) where @@ -80,6 +82,8 @@ import Data.Data import Data.Generics.Schemes +import qualified Data.Char as Char+ import DataTreePrint import Data.HList.HList@@ -152,20 +156,21 @@ let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns fallbackMode <- mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack- let exactPrintNode = allocateNode $ BDFExternal+ let exactPrintNode t = allocateNode $ BDFExternal (ExactPrint.Types.mkAnnKey ast) (foldedAnnKeys ast) False- exactPrinted- let- errorAction = do- mTell $ [ErrorUnknownNode infoStr ast]- docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"+ t+ let errorAction = do+ mTell $ [ErrorUnknownNode infoStr ast]+ docLit+ $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" case (fallbackMode, Text.lines exactPrinted) of (ExactPrintFallbackModeNever, _ ) -> errorAction- (_ , [_]) -> exactPrintNode- (ExactPrintFallbackModeRisky, _ ) -> exactPrintNode- _ -> errorAction+ (_ , [t]) -> exactPrintNode+ (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)+ (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted+ _ -> errorAction rdrNameToText :: RdrName -> Text -- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr@@ -238,6 +243,19 @@ $ Map.elems $ anns +hasAnnKeyword+ :: (Data a, MonadMultiReader (Map AnnKey Annotation) m)+ => Located a+ -> AnnKeywordId+ -> m Bool+hasAnnKeyword ast annKeyword = do+ anns <- mAsk+ let hasK (ExactPrint.Types.G x, _) = x == annKeyword+ hasK _ = False+ pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of+ Nothing -> False+ Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks+ -- new BriDoc stuff allocateNode@@ -446,6 +464,9 @@ docParenLSep :: ToBriDocM BriDocNumbered docParenLSep = appSep $ docLit $ Text.pack "("++docTick :: ToBriDocM BriDocNumbered+docTick = docLit $ Text.pack "'" docNodeAnnKW :: Data.Data.Data ast
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs view
@@ -265,9 +265,15 @@ gs -> docSeq $ [appSep $ docLit $ Text.pack "|"] ++ List.intersperse docCommaSep (return <$> gs)- docAlt++ indentPolicy <- mAsk+ <&> _conf_layout+ .> _lconfig_indentPolicy+ .> confUnpack+ docAltFilter $ -- one-line solution- [ docCols+ [ ( True+ , docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart]) , docSeq@@ -276,6 +282,7 @@ , wherePart ] ]+ ) | not hasComments , [(guards, body, _bodyRaw)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards@@ -289,7 +296,8 @@ _ -> [] ] ++ -- one-line solution + where in next line(s)- [ docLines+ [ ( True+ , docLines $ [ docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart])@@ -298,23 +306,27 @@ ] ] ++ wherePartMultiLine+ ) | [(guards, body, _bodyRaw)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards , Data.Maybe.isJust mWhereDocs ] ++ -- two-line solution + where in next line(s)- [ docLines+ [ ( True + , docLines $ [ docForceSingleline $ docSeq (patPartInline ++ [guardPart, return binderDoc]) , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body ] ++ wherePartMultiLine+ ) | [(guards, body, _bodyRaw)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards ] ++ -- pattern and exactly one clause in single line, body as par; -- where in following lines- [ docLines+ [ ( True+ , docLines $ [ docCols (ColBindingLine alignmentToken) [ docSeq (patPartInline ++ [guardPart])@@ -329,24 +341,28 @@ -- , docAddBaseY BrIndentRegular $ return body -- ] ++ wherePartMultiLine+ ) | [(guards, body, _bodyRaw)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards ] ++ -- pattern and exactly one clause in single line, body in new line.- [ docLines+ [ ( True+ , docLines $ [ docSeq (patPartInline ++ [guardPart, return binderDoc]) , docEnsureIndent BrIndentRegular $ docNonBottomSpacing $ (docAddBaseY BrIndentRegular $ return body) ] ++ wherePartMultiLine+ ) | [(guards, body, _)] <- [clauseDocs] , let guardPart = singleLineGuardsDoc guards ] ++ -- multiple clauses added in-paragraph, each in a single line -- example: foo | bar = baz -- | lll = asd- [ docLines+ [ ( indentPolicy /= IndentPolicyLeft+ , docLines $ [ docSeq [ appSep $ docForceSingleline $ return patDoc , docSetBaseY@@ -370,10 +386,12 @@ ] ] ++ wherePartMultiLine+ ) | Just patDoc <- [mPatDoc] ] ++ -- multiple clauses, each in a separate, single line- [ docLines+ [ ( True+ , docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines@@ -396,10 +414,12 @@ ] ] ++ wherePartMultiLine+ ) ] ++ -- multiple clauses, each with the guard(s) in a single line, body -- as a paragraph- [ docLines+ [ ( True+ , docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines@@ -431,10 +451,12 @@ ] ] ++ wherePartMultiLine+ ) ] ++ -- multiple clauses, each with the guard(s) in a single line, body -- in a new line as a paragraph- [ docLines+ [ ( True+ , docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines@@ -464,9 +486,11 @@ ] ] ++ wherePartMultiLine+ ) ] ++ -- conservative approach: everything starts on the left.- [ docLines+ [ ( True+ , docLines $ [ docAddBaseY BrIndentRegular $ patPartParWrap $ docLines@@ -494,4 +518,5 @@ ] ] ++ wherePartMultiLine+ ) ]
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs view
@@ -13,916 +13,1051 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics--import RdrName ( RdrName(..) )-import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) )-import HsSyn-import Name-import qualified FastString-import BasicTypes--import Language.Haskell.Brittany.Internal.Utils-import Language.Haskell.Brittany.Internal.Layouters.Pattern-import Language.Haskell.Brittany.Internal.Layouters.Decl-import Language.Haskell.Brittany.Internal.Layouters.Stmt-import Language.Haskell.Brittany.Internal.Layouters.Type----layoutExpr :: ToBriDoc HsExpr-layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of- HsVar vname -> do- docLit =<< lrdrNameToTextAnn vname- HsUnboundVar var -> case var of- OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname- TrueExprHole oname -> docLit $ Text.pack $ occNameString oname- HsRecFld{} -> do- -- TODO- briDocByExactInlineOnly "HsRecFld" lexpr- HsOverLabel{} -> do- -- TODO- briDocByExactInlineOnly "HsOverLabel{}" lexpr- HsIPVar{} -> do- -- TODO- briDocByExactInlineOnly "HsOverLabel{}" lexpr- HsOverLit (OverLit olit _ _ _) -> do- allocateNode $ overLitValBriDoc olit- HsLit lit -> do- allocateNode $ litBriDoc lit- HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do- patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p- bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body- let funcPatternPartLine =- docCols ColCasePattern- $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))- docAlt- [ -- single line- docSeq- [ docLit $ Text.pack "\\"- , docWrapNode lmatch $ docForceSingleline funcPatternPartLine- , appSep $ docLit $ Text.pack "->"- , docWrapNode lgrhs $ docForceSingleline bodyDoc- ]- -- double line- , docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- (docSeq- [ docLit $ Text.pack "\\"- , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine- , docLit $ Text.pack "->"- ])- (docWrapNode lgrhs $ docForceSingleline bodyDoc)- -- wrapped par spacing- , docSetParSpacing- $ docSeq- [ docLit $ Text.pack "\\"- , docWrapNode lmatch $ docForceSingleline funcPatternPartLine- , appSep $ docLit $ Text.pack "->"- , docWrapNode lgrhs $ docForceParSpacing bodyDoc- ]- -- conservative- , docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- (docSeq- [ docLit $ Text.pack "\\"- , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine- , docLit $ Text.pack "->"- ])- (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc)- ]- HsLam{} ->- unknownNodeError "HsLam too complex" lexpr-#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */- HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do-#else /* ghc-8.0 */- HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do-#endif- binderDoc <- docLit $ Text.pack "->"- funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches- docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar- (docLit $ Text.pack "\\case")- (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)- HsApp exp1@(L _ HsApp{}) exp2 -> do- let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName])- gather list = \case- (L _ (HsApp l r)) -> gather (r:list) l- x -> (x, list)- let (headE, paramEs) = gather [exp2] exp1- headDoc <- docSharedWrapper layoutExpr headE- paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs- docAlt- [ -- foo x y- docCols ColApp- $ appSep (docForceSingleline headDoc)- : spacifyDocs (docForceSingleline <$> paramDocs)- , -- foo x- -- y- docSeq- [ appSep (docForceSingleline headDoc)- , docSetBaseY- $ docAddBaseY BrIndentRegular- $ docLines- $ (docForceSingleline <$> paramDocs)- ]- , -- foo- -- x- -- y- docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- (docForceSingleline headDoc)- ( docNonBottomSpacing- $ docLines paramDocs- )- , -- ( multi- -- line- -- function- -- )- -- x- -- y- docAddBaseY BrIndentRegular- $ docPar- headDoc- ( docNonBottomSpacing- $ docLines paramDocs- )- ]- HsApp exp1 exp2 -> do- -- TODO: if expDoc1 is some literal, we may want to create a docCols here.- expDoc1 <- docSharedWrapper layoutExpr exp1- expDoc2 <- docSharedWrapper layoutExpr exp2- docAlt- [ docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2]- , docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docSeq- [ appSep $ docForceSingleline expDoc1- , docForceParSpacing expDoc2- ]- , docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- (docForceSingleline expDoc1)- expDoc2- , docAddBaseY BrIndentRegular- $ docPar- expDoc1- expDoc2- ]-#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */- HsAppType exp1 (HsWC _ ty1) -> do-#else /* ghc-8.0 */- HsAppType exp1 (HsWC _ _ ty1) -> do-#endif- t <- docSharedWrapper layoutType ty1- e <- docSharedWrapper layoutExpr exp1- docAlt- [ docSeq- [ docForceSingleline e- , docSeparator- , docLit $ Text.pack "@"- , docForceSingleline t- ]- , docPar- e- (docSeq [docLit $ Text.pack "@", t ])- ]- HsAppTypeOut{} -> do- -- TODO- briDocByExactInlineOnly "HsAppTypeOut{}" lexpr- OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do- let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)])- gather opExprList = \case- (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1- final -> (final, opExprList)- (leftOperand, appList) = gather [] expLeft- leftOperandDoc <- docSharedWrapper layoutExpr leftOperand- appListDocs <- appList `forM` \(x,y) -> [ (xD, yD)- | xD <- docSharedWrapper layoutExpr x- , yD <- docSharedWrapper layoutExpr y- ]- opLastDoc <- docSharedWrapper layoutExpr expOp- expLastDoc <- docSharedWrapper layoutExpr expRight- let allowPar = case (expOp, expRight) of- (L _ (HsVar (L _ (Unqual occname))), _)- | occNameString occname == "$" -> True- (_, L _ (HsApp _ (L _ HsVar{}))) -> False- _ -> True- docAlt- [ docSeq- [ appSep $ docForceSingleline leftOperandDoc- , docSeq- $ (appListDocs <&> \(od, ed) -> docSeq- [ appSep $ docForceSingleline od- , appSep $ docForceSingleline ed- ]- )- , appSep $ docForceSingleline opLastDoc- , (if allowPar then docForceParSpacing else docForceSingleline)- expLastDoc- ]- -- this case rather leads to some unfortunate layouting than to anything- -- useful; disabling for now. (it interfers with cols stuff.)- -- , docSetBaseY- -- - $ docPar- -- leftOperandDoc- -- ( docLines- -- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])- -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]- -- )- , docPar- leftOperandDoc- ( docLines- $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]- )- ]- OpApp expLeft expOp _ expRight -> do- expDocLeft <- docSharedWrapper layoutExpr expLeft- expDocOp <- docSharedWrapper layoutExpr expOp- expDocRight <- docSharedWrapper layoutExpr expRight- let allowPar = case (expOp, expRight) of- (L _ (HsVar (L _ (Unqual occname))), _)- | occNameString occname == "$" -> True- (_, L _ (HsApp _ (L _ HsVar{}))) -> False- _ -> True- docAltFilter- $ [ -- one-line- (,) True- $ docSeq- [ appSep $ docForceSingleline expDocLeft- , appSep $ docForceSingleline expDocOp- , docForceSingleline expDocRight- ]- -- , -- line + freely indented block for right expression- -- docSeq- -- [ appSep $ docForceSingleline expDocLeft- -- , appSep $ docForceSingleline expDocOp- -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight- -- ]- , -- two-line- (,) True- $ docAddBaseY BrIndentRegular- $ docPar- expDocLeft- ( docForceSingleline- $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]- )- , -- one-line + par- (,) allowPar- $ docSeq- [ appSep $ docForceSingleline expDocLeft- , appSep $ docForceSingleline expDocOp- , docForceParSpacing expDocRight- ]- , -- more lines- (,) True- $ docAddBaseY BrIndentRegular- $ docPar- expDocLeft- (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight])- ]- NegApp op _ -> do- opDoc <- docSharedWrapper layoutExpr op- docSeq $ [ docLit $ Text.pack "-"- , opDoc- ]- HsPar innerExp -> do- innerExpDoc <- docSharedWrapper layoutExpr innerExp- docAlt- [ docSeq- [ docLit $ Text.pack "("- , docForceSingleline innerExpDoc- , docLit $ Text.pack ")"- ]- , docSetBaseY $ docLines- [ docCols ColOpPrefix- [ docParenLSep- , docAddBaseY (BrIndentSpecial 2) innerExpDoc- ]- , docLit $ Text.pack ")"- ]- ]- SectionL left op -> do -- TODO: add to testsuite- leftDoc <- docSharedWrapper layoutExpr left- opDoc <- docSharedWrapper layoutExpr op- docSeq [leftDoc, opDoc]- SectionR op right -> do -- TODO: add to testsuite- opDoc <- docSharedWrapper layoutExpr op- rightDoc <- docSharedWrapper layoutExpr right- docSeq [opDoc, rightDoc]- ExplicitTuple args boxity- | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do- argDocs <- docSharedWrapper layoutExpr `mapM` argExprs- hasComments <- hasAnyCommentsBelow lexpr- let (openLit, closeLit) = case boxity of- Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")")- Unboxed -> (docLit $ Text.pack "(#", docLit $ Text.pack "#)")- case splitFirstLast argDocs of- FirstLastEmpty -> docSeq- [ openLit- , docNodeAnnKW lexpr (Just AnnOpenP) $ closeLit- ]- FirstLastSingleton e -> docAlt- [ docCols ColTuple- [ openLit- , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e- , closeLit- ]- , docSetBaseY $ docLines- [ docSeq- [ openLit- , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e- ]- , closeLit- ]- ]- FirstLast e1 ems eN ->- docAltFilter- [ (,) (not hasComments)- $ docCols ColTuple- ( [docSeq [openLit, docForceSingleline e1]]- ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e])- ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]]- )- , (,) True- $ let- start = docCols ColTuples- [appSep $ openLit, e1]- linesM = ems <&> \d ->- docCols ColTuples [docCommaSep, d]- lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN]- end = closeLit- in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]- ]- ExplicitTuple{} ->- unknownNodeError "ExplicitTuple|.." lexpr - HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do- cExpDoc <- docSharedWrapper layoutExpr cExp- binderDoc <- docLit $ Text.pack "->"- funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches- docAlt- [ docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- ( docSeq- [ appSep $ docLit $ Text.pack "case"- , appSep $ docForceSingleline cExpDoc- , docLit $ Text.pack "of"- ])- (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)- , docPar- ( docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "case") cExpDoc- )- ( docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "of")- (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)- )- ]- HsIf _ ifExpr thenExpr elseExpr -> do- ifExprDoc <- docSharedWrapper layoutExpr ifExpr- thenExprDoc <- docSharedWrapper layoutExpr thenExpr- elseExprDoc <- docSharedWrapper layoutExpr elseExpr- hasComments <- hasAnyCommentsBelow lexpr- docAltFilter- [ -- if _ then _ else _- (,) (not hasComments)- $ docSeq- [ appSep $ docLit $ Text.pack "if"- , appSep $ docForceSingleline ifExprDoc- , appSep $ docLit $ Text.pack "then"- , appSep $ docForceSingleline thenExprDoc- , appSep $ docLit $ Text.pack "else"- , docForceSingleline elseExprDoc- ]- , -- either- -- if expr- -- then foo- -- bar- -- else foo- -- bar- -- or- -- if expr- -- then- -- stuff- -- else- -- stuff- -- note that this has par-spacing- (,) True- $ docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- ( docAddBaseY (BrIndentSpecial 3)- $ docSeq- [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"- , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc- ])- (docLines- [ docAddBaseY BrIndentRegular- $ docNodeAnnKW lexpr (Just AnnThen)- $ docAlt- [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]- , docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "then") thenExprDoc- ]- , docAddBaseY BrIndentRegular- $ docAlt- [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]- , docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "else") elseExprDoc- ]- ])- , -- either- -- if multi- -- line- -- condition- -- then foo- -- bar- -- else foo- -- bar- -- or- -- if multi- -- line- -- condition- -- then- -- stuff- -- else- -- stuff- -- note that this does _not_ have par-spacing- (,) True- $ docAddBaseY BrIndentRegular- $ docPar- ( docAddBaseY (BrIndentSpecial 3)- $ docSeq- [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"- , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc- ])- (docLines- [ docAddBaseY BrIndentRegular- $ docNodeAnnKW lexpr (Just AnnThen)- $ docAlt- [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]- , docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "then") thenExprDoc- ]- , docAddBaseY BrIndentRegular- $ docAlt- [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]- , docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "else") elseExprDoc- ]- ])- , (,) True- $ docSetBaseY- $ docLines- [ docAddBaseY (BrIndentSpecial 3)- $ docSeq- [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"- , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc- ]- , docNodeAnnKW lexpr (Just AnnThen)- $ docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "then") thenExprDoc- , docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "else") elseExprDoc- ]- ]- HsMultiIf _ cases -> do- clauseDocs <- cases `forM` layoutGrhs- binderDoc <- docLit $ Text.pack "->"- hasComments <- hasAnyCommentsBelow lexpr- docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar- (docLit $ Text.pack "if")- (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments)- HsLet binds exp1 -> do- expDoc1 <- docSharedWrapper layoutExpr exp1- mBindDocs <- layoutLocalBinds binds- -- this `docSetIndentLevel` might seem out of place, but is here due to- -- ghc-exactprint's DP handling of "let" in particular.- -- Just pushing another indentation level is a straightforward approach- -- to making brittany idempotent, even though the result is non-optimal- -- if "let" is moved horizontally as part of the transformation, as the- -- comments before the first let item are moved horizontally with it.- docSetIndentLevel $ case mBindDocs of- Just [bindDoc] -> docAlt- [ docSeq- [ appSep $ docLit $ Text.pack "let"- , appSep $ docForceSingleline $ return bindDoc- , appSep $ docLit $ Text.pack "in"- , docForceSingleline $ expDoc1- ]- , docLines- [ docSeq- [ appSep $ docLit $ Text.pack "let"- , docSetBaseAndIndent $ return bindDoc- ]- , docSeq- [ appSep $ docLit $ Text.pack "in "- , docSetBaseY $ expDoc1- ]- ]- , docLines- [ docAddBaseY BrIndentRegular- $ docPar- (appSep $ docLit $ Text.pack "let")- (docSetBaseAndIndent $ return bindDoc)- , docAddBaseY BrIndentRegular- $ docPar- (appSep $ docLit $ Text.pack "in")- (docSetBaseY $ expDoc1)- ]- ]- Just bindDocs@(_:_) -> docAlt- [ docLines- [ docSeq- [ appSep $ docLit $ Text.pack "let"- , docSetBaseAndIndent $ docLines $ return <$> bindDocs- ]- , docSeq- [ appSep $ docLit $ Text.pack "in "- , docSetBaseY $ expDoc1- ]- ]- , docLines- [ docAddBaseY BrIndentRegular- $ docPar- (docLit $ Text.pack "let")- (docSetBaseAndIndent $ docLines $ return <$> bindDocs)- , docAddBaseY BrIndentRegular- $ docPar- (docLit $ Text.pack "in")- (docSetBaseY $ expDoc1)- ]- ]- _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1]- -- docSeq [appSep $ docLit "let in", expDoc1]- HsDo DoExpr (L _ stmts) _ -> do- stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts- docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- (docLit $ Text.pack "do")- (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)- HsDo MDoExpr (L _ stmts) _ -> do- stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts- docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- (docLit $ Text.pack "mdo")- (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)- HsDo x (L _ stmts) _ | case x of { ListComp -> True- ; MonadComp -> True- ; _ -> False } -> do- stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts- hasComments <- hasAnyCommentsBelow lexpr- docAltFilter- [ (,) (not hasComments)- $ docSeq- [ docNodeAnnKW lexpr Nothing- $ appSep- $ docLit- $ Text.pack "["- , docNodeAnnKW lexpr (Just AnnOpenS)- $ appSep- $ docForceSingleline- $ List.last stmtDocs- , appSep $ docLit $ Text.pack "|"- , docSeq $ List.intersperse docCommaSep- $ fmap docForceSingleline $ List.init stmtDocs- , docLit $ Text.pack " ]"- ]- , (,) True- $ let- start = docCols ColListComp- [ docNodeAnnKW lexpr Nothing- $ appSep $ docLit $ Text.pack "["- , docSetBaseY- $ docNodeAnnKW lexpr (Just AnnOpenS)- $ List.last stmtDocs- ]- (s1:sM) = List.init stmtDocs- line1 = docCols ColListComp- [appSep $ docLit $ Text.pack "|", s1]- lineM = sM <&> \d ->- docCols ColListComp [docCommaSep, d]- end = docLit $ Text.pack "]"- in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]- ]- HsDo{} -> do- -- TODO- unknownNodeError "HsDo{} no comp" lexpr- ExplicitList _ _ elems@(_:_) -> do- elemDocs <- elems `forM` docSharedWrapper layoutExpr- hasComments <- hasAnyCommentsBelow lexpr- case splitFirstLast elemDocs of- FirstLastEmpty -> docSeq- [ docLit $ Text.pack "["- , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]"- ]- FirstLastSingleton e -> docAlt- [ docSeq- [ docLit $ Text.pack "["- , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e- , docLit $ Text.pack "]"- ]- , docSetBaseY $ docLines- [ docSeq- [ docLit $ Text.pack "["- , docSeparator- , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) $ e- ]- , docLit $ Text.pack "]"- ]- ]- FirstLast e1 ems eN ->- docAltFilter- [ (,) (not hasComments)- $ docSeq- $ [docLit $ Text.pack "["]- ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]))- ++ [docLit $ Text.pack "]"]- , (,) True- $ let- start = docCols ColList- [appSep $ docLit $ Text.pack "[", e1]- linesM = ems <&> \d ->- docCols ColList [docCommaSep, d]- lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN]- end = docLit $ Text.pack "]"- in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]- ]- ExplicitList _ _ [] ->- docLit $ Text.pack "[]"- ExplicitPArr{} -> do- -- TODO- briDocByExactInlineOnly "ExplicitPArr{}" lexpr- RecordCon lname _ _ (HsRecFields [] Nothing) -> do- let t = lrdrNameToText lname- docWrapNode lname $ docSeq- [ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{"- , docLit $ Text.pack "}"- ]- RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do- let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname- ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do- fExpDoc <- if pun- then return Nothing- else Just <$> docSharedWrapper layoutExpr fExpr- return $ (fieldl, lrdrNameToText lnameF, fExpDoc)- docAlt- [ docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- (docNodeAnnKW lexpr Nothing $ nameDoc)- (docNonBottomSpacing $ docLines $ let- line1 = docCols ColRecUpdate- [ appSep $ docLit $ Text.pack "{"- , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n- , case fd1e of- Just x -> docSeq- [ appSep $ docLit $ Text.pack "="- , docWrapNodeRest fd1l $ docAddBaseY BrIndentRegular $ x- ]- Nothing -> docEmpty- ]- lineR = fdr <&> \(lfield, fText, fDoc) -> docCols ColRecUpdate- [ appSep $ docLit $ Text.pack ","- , appSep $ docLit $ fText- , case fDoc of- Just x -> docWrapNode lfield $ docSeq- [ appSep $ docLit $ Text.pack "="- , docAddBaseY BrIndentRegular x- ]- Nothing -> docEmpty- ]- lineN = docSeq- [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty- , docLit $ Text.pack "}"- ]- in [line1] ++ lineR ++ [lineN])- -- TODO oneliner (?)- ]- RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do- let t = lrdrNameToText lname- docWrapNode lname $ docLit $ t <> Text.pack " {..}"- RecordCon{} ->- unknownNodeError "RecordCon with puns" lexpr- RecordUpd rExpr [] _ _ _ _ -> do- rExprDoc <- docSharedWrapper layoutExpr rExpr- docSeq [rExprDoc, docLit $ Text.pack "{}"]- RecordUpd rExpr fields@(_:_) _ _ _ _ -> do- rExprDoc <- docSharedWrapper layoutExpr rExpr- rFs@((rF1f, rF1n, rF1e):rFr) <- fields- `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do- rFExpDoc <- if pun- then return Nothing- else Just <$> docSharedWrapper layoutExpr rFExpr- return $ case ambName of- Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)- Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)- docAlt- -- singleline- [ docSeq- [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc- , appSep $ docLit $ Text.pack "{"- , appSep $ docSeq $ List.intersperse docCommaSep- $ rFs <&> \case- (lfield, fieldStr, Just fieldDoc) ->- docWrapNode lfield $ docSeq- [ appSep $ docLit fieldStr- , appSep $ docLit $ Text.pack "="- , docForceSingleline fieldDoc- ]- (lfield, fieldStr, Nothing) ->- docWrapNode lfield $ docLit fieldStr- , docLit $ Text.pack "}"- ]- -- wild-indentation block- , docSeq- [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc- , docSetBaseY $ docLines $ let- line1 = docCols ColRecUpdate- [ appSep $ docLit $ Text.pack "{"- , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n- , case rF1e of- Just x -> docWrapNodeRest rF1f $ docSeq- [ appSep $ docLit $ Text.pack "="- , docForceSingleline $ x- ]- Nothing -> docEmpty- ]- lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate- [ appSep $ docLit $ Text.pack ","- , appSep $ docLit $ fText- , case fDoc of- Just x -> docSeq [ appSep $ docLit $ Text.pack "="- , docForceSingleline x- ]- Nothing -> docEmpty- ]- lineN = docSeq- [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty- , docLit $ Text.pack "}"- ]- in [line1] ++ lineR ++ [lineN]- ]- -- strict indentation block- , docSetParSpacing- $ docAddBaseY BrIndentRegular- $ docPar- (docNodeAnnKW lexpr Nothing $ rExprDoc)- (docNonBottomSpacing $ docLines $ let- line1 = docCols ColRecUpdate- [ appSep $ docLit $ Text.pack "{"- , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n- , docWrapNodeRest rF1f $ case rF1e of- Just x -> docSeq [ appSep $ docLit $ Text.pack "="- , docAddBaseY BrIndentRegular $ x- ]- Nothing -> docEmpty- ]- lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate- [ appSep $ docLit $ Text.pack ","- , appSep $ docLit $ fText- , case fDoc of- Just x -> docSeq [ appSep $ docLit $ Text.pack "="- , docAddBaseY BrIndentRegular x- ]- Nothing -> docEmpty- ]- lineN = docSeq- [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty- , docLit $ Text.pack "}"- ]- in [line1] ++ lineR ++ [lineN])- ]-#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */- ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do-#else /* ghc-8.0 */- ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do-#endif- expDoc <- docSharedWrapper layoutExpr exp1- typDoc <- docSharedWrapper layoutType typ1- docSeq- [ appSep expDoc- , appSep $ docLit $ Text.pack "::"- , typDoc- ]- ExprWithTySigOut{} -> do- -- TODO- briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr- ArithSeq _ Nothing info ->- case info of- From e1 -> do- e1Doc <- docSharedWrapper layoutExpr e1- docSeq- [ docLit $ Text.pack "["- , appSep $ docForceSingleline e1Doc- , docLit $ Text.pack "..]"- ]- FromThen e1 e2 -> do- e1Doc <- docSharedWrapper layoutExpr e1- e2Doc <- docSharedWrapper layoutExpr e2- docSeq- [ docLit $ Text.pack "["- , docForceSingleline e1Doc- , appSep $ docLit $ Text.pack ","- , appSep $ docForceSingleline e2Doc- , docLit $ Text.pack "..]"- ]- FromTo e1 eN -> do- e1Doc <- docSharedWrapper layoutExpr e1- eNDoc <- docSharedWrapper layoutExpr eN- docSeq- [ docLit $ Text.pack "["- , appSep $ docForceSingleline e1Doc- , appSep $ docLit $ Text.pack ".."- , docForceSingleline eNDoc- , docLit $ Text.pack "]"- ]- FromThenTo e1 e2 eN -> do- e1Doc <- docSharedWrapper layoutExpr e1- e2Doc <- docSharedWrapper layoutExpr e2- eNDoc <- docSharedWrapper layoutExpr eN- docSeq- [ docLit $ Text.pack "["- , docForceSingleline e1Doc- , appSep $ docLit $ Text.pack ","- , appSep $ docForceSingleline e2Doc- , appSep $ docLit $ Text.pack ".."- , docForceSingleline eNDoc- , docLit $ Text.pack "]"- ]- ArithSeq{} ->- briDocByExactInlineOnly "ArithSeq" lexpr- PArrSeq{} -> do- -- TODO- briDocByExactInlineOnly "PArrSeq{}" lexpr- HsSCC{} -> do- -- TODO- briDocByExactInlineOnly "HsSCC{}" lexpr- HsCoreAnn{} -> do- -- TODO- briDocByExactInlineOnly "HsCoreAnn{}" lexpr- HsBracket{} -> do- -- TODO- briDocByExactInlineOnly "HsBracket{}" lexpr- HsRnBracketOut{} -> do- -- TODO- briDocByExactInlineOnly "HsRnBracketOut{}" lexpr- HsTcBracketOut{} -> do- -- TODO- briDocByExactInlineOnly "HsTcBracketOut{}" lexpr- HsSpliceE{} -> do- -- TODO- briDocByExactInlineOnly "HsSpliceE{}" lexpr- HsProc{} -> do- -- TODO- briDocByExactInlineOnly "HsProc{}" lexpr- HsStatic{} -> do- -- TODO- briDocByExactInlineOnly "HsStatic{}" lexpr- HsArrApp{} -> do- -- TODO- briDocByExactInlineOnly "HsArrApp{}" lexpr- HsArrForm{} -> do- -- TODO- briDocByExactInlineOnly "HsArrForm{}" lexpr- HsTick{} -> do- -- TODO- briDocByExactInlineOnly "HsTick{}" lexpr- HsBinTick{} -> do- -- TODO- briDocByExactInlineOnly "HsBinTick{}" lexpr- HsTickPragma{} -> do- -- TODO- briDocByExactInlineOnly "HsTickPragma{}" lexpr- EWildPat{} -> do- docLit $ Text.pack "_"- EAsPat asName asExpr -> do- docSeq- [ docLit $ (lrdrNameToText asName) <> Text.pack "@"- , layoutExpr asExpr- ]- EViewPat{} -> do- -- TODO- briDocByExactInlineOnly "EViewPat{}" lexpr- ELazyPat{} -> do- -- TODO- briDocByExactInlineOnly "ELazyPat{}" lexpr- HsWrap{} -> do- -- TODO- briDocByExactInlineOnly "HsWrap{}" lexpr-#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */- HsConLikeOut{} -> do- -- TODO- briDocByExactInlineOnly "HsWrap{}" lexpr- ExplicitSum{} -> do- -- TODO- briDocByExactInlineOnly "ExplicitSum{}" lexpr+import Language.Haskell.Brittany.Internal.Config.Types++import RdrName ( RdrName(..) )+import GHC ( runGhc, GenLocated(L), moduleNameString, AnnKeywordId(..) )+import HsSyn+import Name+import qualified FastString+import BasicTypes++import Language.Haskell.Brittany.Internal.Utils+import Language.Haskell.Brittany.Internal.Layouters.Pattern+import Language.Haskell.Brittany.Internal.Layouters.Decl+import Language.Haskell.Brittany.Internal.Layouters.Stmt+import Language.Haskell.Brittany.Internal.Layouters.Type++++layoutExpr :: ToBriDoc HsExpr+layoutExpr lexpr@(L _ expr) = do+ indentPolicy <- mAsk+ <&> _conf_layout+ .> _lconfig_indentPolicy+ .> confUnpack+ let allowFreeIndent = indentPolicy == IndentPolicyFree+ docWrapNode lexpr $ case expr of+ HsVar vname -> do+ docLit =<< lrdrNameToTextAnn vname+ HsUnboundVar var -> case var of+ OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname+ TrueExprHole oname -> docLit $ Text.pack $ occNameString oname+ HsRecFld{} -> do+ -- TODO+ briDocByExactInlineOnly "HsRecFld" lexpr+ HsOverLabel{} -> do+ -- TODO+ briDocByExactInlineOnly "HsOverLabel{}" lexpr+ HsIPVar{} -> do+ -- TODO+ briDocByExactInlineOnly "HsOverLabel{}" lexpr+ HsOverLit (OverLit olit _ _ _) -> do+ allocateNode $ overLitValBriDoc olit+ HsLit lit -> do+ allocateNode $ litBriDoc lit+ HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do+ patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p+ bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body+ let funcPatternPartLine =+ docCols ColCasePattern+ $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))+ docAlt+ [ -- single line+ docSeq+ [ docLit $ Text.pack "\\"+ , docWrapNode lmatch $ docForceSingleline funcPatternPartLine+ , appSep $ docLit $ Text.pack "->"+ , docWrapNode lgrhs $ docForceSingleline bodyDoc+ ]+ -- double line+ , docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ (docSeq+ [ docLit $ Text.pack "\\"+ , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine+ , docLit $ Text.pack "->"+ ])+ (docWrapNode lgrhs $ docForceSingleline bodyDoc)+ -- wrapped par spacing+ , docSetParSpacing+ $ docSeq+ [ docLit $ Text.pack "\\"+ , docWrapNode lmatch $ docForceSingleline funcPatternPartLine+ , appSep $ docLit $ Text.pack "->"+ , docWrapNode lgrhs $ docForceParSpacing bodyDoc+ ]+ -- conservative+ , docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ (docSeq+ [ docLit $ Text.pack "\\"+ , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine+ , docLit $ Text.pack "->"+ ])+ (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc)+ ]+ HsLam{} ->+ unknownNodeError "HsLam too complex" lexpr+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+ HsLamCase (MG lmatches@(L _ matches) _ _ _) -> do+#else /* ghc-8.0 */+ HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do+#endif+ binderDoc <- docLit $ Text.pack "->"+ funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches+ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+ (docLit $ Text.pack "\\case")+ (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)+ HsApp exp1@(L _ HsApp{}) exp2 -> do+ let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName])+ gather list = \case+ (L _ (HsApp l r)) -> gather (r:list) l+ x -> (x, list)+ let (headE, paramEs) = gather [exp2] exp1+ headDoc <- docSharedWrapper layoutExpr headE+ paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs+ docAltFilter+ [ -- foo x y+ ( True+ , docCols ColApp+ $ appSep (docForceSingleline headDoc)+ : spacifyDocs (docForceSingleline <$> paramDocs)+ )+ , -- foo x+ -- y+ ( allowFreeIndent+ , docSeq+ [ appSep (docForceSingleline headDoc)+ , docSetBaseY+ $ docAddBaseY BrIndentRegular+ $ docLines+ $ (docForceSingleline <$> paramDocs)+ ]+ )+ , -- foo+ -- x+ -- y+ ( True+ , docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ (docForceSingleline headDoc)+ ( docNonBottomSpacing+ $ docLines paramDocs+ )+ )+ , -- ( multi+ -- line+ -- function+ -- )+ -- x+ -- y+ ( True+ , docAddBaseY BrIndentRegular+ $ docPar+ headDoc+ ( docNonBottomSpacing+ $ docLines paramDocs+ )+ )+ ]+ HsApp exp1 exp2 -> do+ -- TODO: if expDoc1 is some literal, we may want to create a docCols here.+ expDoc1 <- docSharedWrapper layoutExpr exp1+ expDoc2 <- docSharedWrapper layoutExpr exp2+ docAlt+ [ -- func arg+ docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2]+ , -- func argline1+ -- arglines+ -- e.g.+ -- func if x+ -- then 1+ -- else 2+ docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docSeq+ [ appSep $ docForceSingleline expDoc1+ , docForceParSpacing expDoc2+ ]+ , -- func+ -- arg+ docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ (docForceSingleline expDoc1)+ (docNonBottomSpacing expDoc2)+ , -- fu+ -- nc+ -- ar+ -- gument+ docAddBaseY BrIndentRegular+ $ docPar+ expDoc1+ expDoc2+ ]+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+ HsAppType exp1 (HsWC _ ty1) -> do+#else /* ghc-8.0 */+ HsAppType exp1 (HsWC _ _ ty1) -> do+#endif+ t <- docSharedWrapper layoutType ty1+ e <- docSharedWrapper layoutExpr exp1+ docAlt+ [ docSeq+ [ docForceSingleline e+ , docSeparator+ , docLit $ Text.pack "@"+ , docForceSingleline t+ ]+ , docPar+ e+ (docSeq [docLit $ Text.pack "@", t ])+ ]+ HsAppTypeOut{} -> do+ -- TODO+ briDocByExactInlineOnly "HsAppTypeOut{}" lexpr+ OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do+ let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)])+ gather opExprList = \case+ (L _ (OpApp l1 op1 _ r1)) -> gather ((op1, r1): opExprList) l1+ final -> (final, opExprList)+ (leftOperand, appList) = gather [] expLeft+ leftOperandDoc <- docSharedWrapper layoutExpr leftOperand+ appListDocs <- appList `forM` \(x,y) -> [ (xD, yD)+ | xD <- docSharedWrapper layoutExpr x+ , yD <- docSharedWrapper layoutExpr y+ ]+ opLastDoc <- docSharedWrapper layoutExpr expOp+ expLastDoc <- docSharedWrapper layoutExpr expRight+ let allowPar = case (expOp, expRight) of+ (L _ (HsVar (L _ (Unqual occname))), _)+ | occNameString occname == "$" -> True+ (_, L _ (HsApp _ (L _ HsVar{}))) -> False+ _ -> True+ docAlt+ [ docSeq+ [ appSep $ docForceSingleline leftOperandDoc+ , docSeq+ $ (appListDocs <&> \(od, ed) -> docSeq+ [ appSep $ docForceSingleline od+ , appSep $ docForceSingleline ed+ ]+ )+ , appSep $ docForceSingleline opLastDoc+ , (if allowPar then docForceParSpacing else docForceSingleline)+ expLastDoc+ ]+ -- this case rather leads to some unfortunate layouting than to anything+ -- useful; disabling for now. (it interfers with cols stuff.)+ -- , docSetBaseY+ -- - $ docPar+ -- leftOperandDoc+ -- ( docLines+ -- - $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])+ -- ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]+ -- )+ , docPar+ leftOperandDoc+ ( docLines+ $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])+ ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]+ )+ ]+ OpApp expLeft expOp _ expRight -> do+ expDocLeft <- docSharedWrapper layoutExpr expLeft+ expDocOp <- docSharedWrapper layoutExpr expOp+ expDocRight <- docSharedWrapper layoutExpr expRight+ let allowPar = case (expOp, expRight) of+ (L _ (HsVar (L _ (Unqual occname))), _)+ | occNameString occname == "$" -> True+ (_, L _ (HsApp _ (L _ HsVar{}))) -> False+ _ -> True+ docAltFilter+ $ [ -- one-line+ (,) True+ $ docSeq+ [ appSep $ docForceSingleline expDocLeft+ , appSep $ docForceSingleline expDocOp+ , docForceSingleline expDocRight+ ]+ -- , -- line + freely indented block for right expression+ -- docSeq+ -- [ appSep $ docForceSingleline expDocLeft+ -- , appSep $ docForceSingleline expDocOp+ -- , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight+ -- ]+ , -- two-line+ (,) True+ $ docAddBaseY BrIndentRegular+ $ docPar+ expDocLeft+ ( docForceSingleline+ $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]+ )+ , -- one-line + par+ (,) allowPar+ $ docSeq+ [ appSep $ docForceSingleline expDocLeft+ , appSep $ docForceSingleline expDocOp+ , docForceParSpacing expDocRight+ ]+ , -- more lines+ (,) True+ $ docAddBaseY BrIndentRegular+ $ docPar+ expDocLeft+ (docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight])+ ]+ NegApp op _ -> do+ opDoc <- docSharedWrapper layoutExpr op+ docSeq $ [ docLit $ Text.pack "-"+ , opDoc+ ]+ HsPar innerExp -> do+ innerExpDoc <- docSharedWrapper layoutExpr innerExp+ docAlt+ [ docSeq+ [ docLit $ Text.pack "("+ , docForceSingleline innerExpDoc+ , docLit $ Text.pack ")"+ ]+ , docSetBaseY $ docLines+ [ docCols ColOpPrefix+ [ docParenLSep+ , docAddBaseY (BrIndentSpecial 2) innerExpDoc+ ]+ , docLit $ Text.pack ")"+ ]+ ]+ SectionL left op -> do -- TODO: add to testsuite+ leftDoc <- docSharedWrapper layoutExpr left+ opDoc <- docSharedWrapper layoutExpr op+ docSeq [leftDoc, docSeparator, opDoc]+ SectionR op right -> do -- TODO: add to testsuite+ opDoc <- docSharedWrapper layoutExpr op+ rightDoc <- docSharedWrapper layoutExpr right+ docSeq [opDoc, docSeparator, rightDoc]+ ExplicitTuple args boxity+ | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do+ argDocs <- docSharedWrapper layoutExpr `mapM` argExprs+ hasComments <- hasAnyCommentsBelow lexpr+ let (openLit, closeLit) = case boxity of+ Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")")+ Unboxed -> (docLit $ Text.pack "(#", docLit $ Text.pack "#)")+ case splitFirstLast argDocs of+ FirstLastEmpty -> docSeq+ [ openLit+ , docNodeAnnKW lexpr (Just AnnOpenP) $ closeLit+ ]+ FirstLastSingleton e -> docAlt+ [ docCols ColTuple+ [ openLit+ , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e+ , closeLit+ ]+ , docSetBaseY $ docLines+ [ docSeq+ [ openLit+ , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e+ ]+ , closeLit+ ]+ ]+ FirstLast e1 ems eN ->+ docAltFilter+ [ (,) (not hasComments)+ $ docCols ColTuple+ ( [docSeq [openLit, docForceSingleline e1]]+ ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e])+ ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]]+ )+ , (,) True+ $ let+ start = docCols ColTuples+ [appSep $ openLit, e1]+ linesM = ems <&> \d ->+ docCols ColTuples [docCommaSep, d]+ lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN]+ end = closeLit+ in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]+ ]+ ExplicitTuple{} ->+ unknownNodeError "ExplicitTuple|.." lexpr + HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do+ cExpDoc <- docSharedWrapper layoutExpr cExp+ binderDoc <- docLit $ Text.pack "->"+ funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches+ docAlt+ [ docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ ( docSeq+ [ appSep $ docLit $ Text.pack "case"+ , appSep $ docForceSingleline cExpDoc+ , docLit $ Text.pack "of"+ ])+ (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)+ , docPar+ ( docAddBaseY BrIndentRegular+ $ docPar (docLit $ Text.pack "case") cExpDoc+ )+ ( docAddBaseY BrIndentRegular+ $ docPar (docLit $ Text.pack "of")+ (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)+ )+ ]+ HsIf _ ifExpr thenExpr elseExpr -> do+ ifExprDoc <- docSharedWrapper layoutExpr ifExpr+ thenExprDoc <- docSharedWrapper layoutExpr thenExpr+ elseExprDoc <- docSharedWrapper layoutExpr elseExpr+ hasComments <- hasAnyCommentsBelow lexpr+ let maySpecialIndent =+ case indentPolicy of+ IndentPolicyLeft -> BrIndentRegular+ _ -> BrIndentSpecial 3+ -- TODO: some of the alternatives (especially last and last-but-one)+ -- overlap.+ docAltFilter+ [ -- if _ then _ else _+ (,) (not hasComments)+ $ docSeq+ [ appSep $ docLit $ Text.pack "if"+ , appSep $ docForceSingleline ifExprDoc+ , appSep $ docLit $ Text.pack "then"+ , appSep $ docForceSingleline thenExprDoc+ , appSep $ docLit $ Text.pack "else"+ , docForceSingleline elseExprDoc+ ]+ , -- either+ -- if expr+ -- then foo+ -- bar+ -- else foo+ -- bar+ -- or+ -- if expr+ -- then+ -- stuff+ -- else+ -- stuff+ -- note that this has par-spacing+ (,) True+ $ docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ ( docSeq+ [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"+ , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc+ ])+ (docLines+ [ docAddBaseY BrIndentRegular+ $ docNodeAnnKW lexpr (Just AnnThen)+ $ docAlt+ [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]+ , docAddBaseY BrIndentRegular+ $ docPar (docLit $ Text.pack "then") thenExprDoc+ ]+ , docAddBaseY BrIndentRegular+ $ docAlt+ [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]+ , docAddBaseY BrIndentRegular+ $ docPar (docLit $ Text.pack "else") elseExprDoc+ ]+ ])+ , -- either+ -- if multi+ -- line+ -- condition+ -- then foo+ -- bar+ -- else foo+ -- bar+ -- or+ -- if multi+ -- line+ -- condition+ -- then+ -- stuff+ -- else+ -- stuff+ -- note that this does _not_ have par-spacing+ (,) True+ $ docAddBaseY BrIndentRegular+ $ docPar+ ( docAddBaseY maySpecialIndent+ $ docSeq+ [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"+ , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc+ ])+ (docLines+ [ docAddBaseY BrIndentRegular+ $ docNodeAnnKW lexpr (Just AnnThen)+ $ docAlt+ [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]+ , docAddBaseY BrIndentRegular+ $ docPar (docLit $ Text.pack "then") thenExprDoc+ ]+ , docAddBaseY BrIndentRegular+ $ docAlt+ [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]+ , docAddBaseY BrIndentRegular+ $ docPar (docLit $ Text.pack "else") elseExprDoc+ ]+ ])+ , (,) True+ $ docSetBaseY+ $ docLines+ [ docAddBaseY maySpecialIndent+ $ docSeq+ [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"+ , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc+ ]+ , docNodeAnnKW lexpr (Just AnnThen)+ $ docAddBaseY BrIndentRegular+ $ docPar (docLit $ Text.pack "then") thenExprDoc+ , docAddBaseY BrIndentRegular+ $ docPar (docLit $ Text.pack "else") elseExprDoc+ ]+ ]+ HsMultiIf _ cases -> do+ clauseDocs <- cases `forM` layoutGrhs+ binderDoc <- docLit $ Text.pack "->"+ hasComments <- hasAnyCommentsBelow lexpr+ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+ (docLit $ Text.pack "if")+ (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments)+ HsLet binds exp1 -> do+ expDoc1 <- docSharedWrapper layoutExpr exp1+ mBindDocs <- layoutLocalBinds binds+ -- this `docSetIndentLevel` might seem out of place, but is here due to+ -- ghc-exactprint's DP handling of "let" in particular.+ -- Just pushing another indentation level is a straightforward approach+ -- to making brittany idempotent, even though the result is non-optimal+ -- if "let" is moved horizontally as part of the transformation, as the+ -- comments before the first let item are moved horizontally with it.+ docSetIndentLevel $ case mBindDocs of+ Just [bindDoc] -> docAltFilter+ [ ( True+ , docSeq+ [ appSep $ docLit $ Text.pack "let"+ , appSep $ docForceSingleline $ return bindDoc+ , appSep $ docLit $ Text.pack "in"+ , docForceSingleline $ expDoc1+ ]+ )+ , ( indentPolicy /= IndentPolicyLeft+ , docLines+ [ docSeq+ [ appSep $ docLit $ Text.pack "let"+ , docSetBaseAndIndent $ return bindDoc+ ]+ , docSeq+ [ appSep $ docLit $ Text.pack "in "+ , docSetBaseY $ expDoc1+ ]+ ]+ )+ , ( True+ , docLines+ [ docAddBaseY BrIndentRegular+ $ docPar+ (appSep $ docLit $ Text.pack "let")+ (docSetBaseAndIndent $ return bindDoc)+ , docAddBaseY BrIndentRegular+ $ docPar+ (appSep $ docLit $ Text.pack "in")+ (docSetBaseY $ expDoc1)+ ]+ )+ ]+ Just bindDocs@(_:_) -> docAltFilter+ --either+ -- let+ -- a = b+ -- c = d+ -- in foo+ -- bar+ -- baz+ --or+ -- let+ -- a = b+ -- c = d+ -- in+ -- fooooooooooooooooooo+ [ ( indentPolicy == IndentPolicyLeft+ , docLines+ [ docAddBaseY BrIndentRegular+ $ docPar+ (docLit $ Text.pack "let")+ (docSetBaseAndIndent $ docLines $ return <$> bindDocs)+ , docSeq+ [ docLit $ Text.pack "in "+ , docAddBaseY BrIndentRegular $ expDoc1+ ]+ ]+ )+ , ( indentPolicy /= IndentPolicyLeft+ , docLines+ [ docSeq+ [ appSep $ docLit $ Text.pack "let"+ , docSetBaseAndIndent $ docLines $ return <$> bindDocs+ ]+ , docSeq+ [ appSep $ docLit $ Text.pack "in "+ , docSetBaseY $ expDoc1+ ]+ ]+ )+ , ( True+ , docLines+ [ docAddBaseY BrIndentRegular+ $ docPar+ (docLit $ Text.pack "let")+ (docSetBaseAndIndent $ docLines $ return <$> bindDocs)+ , docAddBaseY BrIndentRegular+ $ docPar+ (docLit $ Text.pack "in")+ (docSetBaseY $ expDoc1)+ ]+ )+ ]+ _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1]+ -- docSeq [appSep $ docLit "let in", expDoc1]+ HsDo DoExpr (L _ stmts) _ -> do+ stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts+ docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ (docLit $ Text.pack "do")+ (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)+ HsDo MDoExpr (L _ stmts) _ -> do+ stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts+ docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ (docLit $ Text.pack "mdo")+ (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)+ HsDo x (L _ stmts) _ | case x of { ListComp -> True+ ; MonadComp -> True+ ; _ -> False } -> do+ stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts+ hasComments <- hasAnyCommentsBelow lexpr+ docAltFilter+ [ (,) (not hasComments)+ $ docSeq+ [ docNodeAnnKW lexpr Nothing+ $ appSep+ $ docLit+ $ Text.pack "["+ , docNodeAnnKW lexpr (Just AnnOpenS)+ $ appSep+ $ docForceSingleline+ $ List.last stmtDocs+ , appSep $ docLit $ Text.pack "|"+ , docSeq $ List.intersperse docCommaSep+ $ fmap docForceSingleline $ List.init stmtDocs+ , docLit $ Text.pack " ]"+ ]+ , (,) True+ $ let+ start = docCols ColListComp+ [ docNodeAnnKW lexpr Nothing+ $ appSep $ docLit $ Text.pack "["+ , docSetBaseY+ $ docNodeAnnKW lexpr (Just AnnOpenS)+ $ List.last stmtDocs+ ]+ (s1:sM) = List.init stmtDocs+ line1 = docCols ColListComp+ [appSep $ docLit $ Text.pack "|", s1]+ lineM = sM <&> \d ->+ docCols ColListComp [docCommaSep, d]+ end = docLit $ Text.pack "]"+ in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]+ ]+ HsDo{} -> do+ -- TODO+ unknownNodeError "HsDo{} no comp" lexpr+ ExplicitList _ _ elems@(_:_) -> do+ elemDocs <- elems `forM` docSharedWrapper layoutExpr+ hasComments <- hasAnyCommentsBelow lexpr+ case splitFirstLast elemDocs of+ FirstLastEmpty -> docSeq+ [ docLit $ Text.pack "["+ , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]"+ ]+ FirstLastSingleton e -> docAlt+ [ docSeq+ [ docLit $ Text.pack "["+ , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e+ , docLit $ Text.pack "]"+ ]+ , docSetBaseY $ docLines+ [ docSeq+ [ docLit $ Text.pack "["+ , docSeparator+ , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) $ e+ ]+ , docLit $ Text.pack "]"+ ]+ ]+ FirstLast e1 ems eN ->+ docAltFilter+ [ (,) (not hasComments)+ $ docSeq+ $ [docLit $ Text.pack "["]+ ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]))+ ++ [docLit $ Text.pack "]"]+ , (,) True+ $ let+ start = docCols ColList+ [appSep $ docLit $ Text.pack "[", e1]+ linesM = ems <&> \d ->+ docCols ColList [docCommaSep, d]+ lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN]+ end = docLit $ Text.pack "]"+ in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]+ ]+ ExplicitList _ _ [] ->+ docLit $ Text.pack "[]"+ ExplicitPArr{} -> do+ -- TODO+ briDocByExactInlineOnly "ExplicitPArr{}" lexpr+ RecordCon lname _ _ (HsRecFields [] Nothing) -> do+ let t = lrdrNameToText lname+ docWrapNode lname $ docSeq+ [ docNodeAnnKW lexpr (Just AnnOpenC) $ docLit $ t <> Text.pack "{"+ , docLit $ Text.pack "}"+ ]+ RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do+ let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname+ ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do+ fExpDoc <- if pun+ then return Nothing+ else Just <$> docSharedWrapper layoutExpr fExpr+ return $ (fieldl, lrdrNameToText lnameF, fExpDoc)+ let line1 appender wrapper =+ [ appender $ docLit $ Text.pack "{"+ , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n+ , case fd1e of+ Just x -> docSeq+ [ appSep $ docLit $ Text.pack "="+ , docWrapNodeRest fd1l $ wrapper $ x+ ]+ Nothing -> docEmpty+ ]+ let lineR wrapper = fdr <&> \(lfield, fText, fDoc) ->+ [ docCommaSep+ , appSep $ docLit $ fText+ , case fDoc of+ Just x -> docWrapNode lfield $ docSeq+ [ appSep $ docLit $ Text.pack "="+ , wrapper x+ ]+ Nothing -> docEmpty+ ]+ let lineN =+ [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty+ , docLit $ Text.pack "}"+ ]+ docAlt+ [ docSeq+ $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator]+ ++ line1 id docForceSingleline+ ++ join (lineR docForceSingleline)+ ++ lineN+ , docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ (docNodeAnnKW lexpr Nothing $ nameDoc)+ ( docNonBottomSpacing+ $ docLines+ $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)]+ ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular))+ ++ [docSeq lineN]+ )+ ]+ RecordCon lname _ _ (HsRecFields [] (Just 0)) -> do+ let t = lrdrNameToText lname+ docWrapNode lname $ docLit $ t <> Text.pack " {..}"+ RecordCon lname _ _ (HsRecFields fs@(_:_) (Just dotdoti)) | dotdoti == length fs -> do+ let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname+ ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do+ fExpDoc <- if pun+ then return Nothing+ else Just <$> docSharedWrapper layoutExpr fExpr+ return $ (fieldl, lrdrNameToText lnameF, fExpDoc)+ let line1 appender wrapper =+ [ appender $ docLit $ Text.pack "{"+ , docWrapNodePrior fd1l $ appSep $ docLit $ fd1n+ , case fd1e of+ Just x -> docSeq+ [ appSep $ docLit $ Text.pack "="+ , docWrapNodeRest fd1l $ wrapper $ x+ ]+ Nothing -> docEmpty+ ]+ let lineR wrapper = fdr <&> \(lfield, fText, fDoc) ->+ [ docCommaSep+ , appSep $ docLit $ fText+ , case fDoc of+ Just x -> docWrapNode lfield $ docSeq+ [ appSep $ docLit $ Text.pack "="+ , wrapper x+ ]+ Nothing -> docEmpty+ ]+ let lineDot =+ [ docCommaSep+ , docLit $ Text.pack ".."+ ]+ let lineN =+ [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty+ , docLit $ Text.pack "}"+ ]+ docAlt+ [ docSeq+ $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator]+ ++ line1 id docForceSingleline+ ++ join (lineR docForceSingleline)+ ++ lineDot+ ++ lineN+ , docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ (docNodeAnnKW lexpr Nothing $ nameDoc)+ ( docNonBottomSpacing+ $ docLines+ $ [docCols ColRecUpdate $ line1 appSep (docAddBaseY BrIndentRegular)]+ ++ (docCols ColRecUpdate <$> lineR (docAddBaseY BrIndentRegular))+ ++ [docSeq lineDot, docSeq lineN]+ )+ ]+ RecordCon{} ->+ unknownNodeError "RecordCon with puns" lexpr+ RecordUpd rExpr [] _ _ _ _ -> do+ rExprDoc <- docSharedWrapper layoutExpr rExpr+ docSeq [rExprDoc, docLit $ Text.pack "{}"]+ RecordUpd rExpr fields@(_:_) _ _ _ _ -> do+ rExprDoc <- docSharedWrapper layoutExpr rExpr+ rFs@((rF1f, rF1n, rF1e):rFr) <- fields+ `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do+ rFExpDoc <- if pun+ then return Nothing+ else Just <$> docSharedWrapper layoutExpr rFExpr+ return $ case ambName of+ Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)+ Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc)+ docAltFilter+ -- singleline+ [ ( True+ , docSeq+ [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc+ , appSep $ docLit $ Text.pack "{"+ , appSep $ docSeq $ List.intersperse docCommaSep+ $ rFs <&> \case+ (lfield, fieldStr, Just fieldDoc) ->+ docWrapNode lfield $ docSeq+ [ appSep $ docLit fieldStr+ , appSep $ docLit $ Text.pack "="+ , docForceSingleline fieldDoc+ ]+ (lfield, fieldStr, Nothing) ->+ docWrapNode lfield $ docLit fieldStr+ , docLit $ Text.pack "}"+ ]+ )+ -- wild-indentation block+ , ( indentPolicy /= IndentPolicyLeft+ , docSeq+ [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc+ , docSetBaseY $ docLines $ let+ line1 = docCols ColRecUpdate+ [ appSep $ docLit $ Text.pack "{"+ , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n+ , case rF1e of+ Just x -> docWrapNodeRest rF1f $ docSeq+ [ appSep $ docLit $ Text.pack "="+ , docForceSingleline $ x+ ]+ Nothing -> docEmpty+ ]+ lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate+ [ docCommaSep+ , appSep $ docLit $ fText+ , case fDoc of+ Just x -> docSeq [ appSep $ docLit $ Text.pack "="+ , docForceSingleline x+ ]+ Nothing -> docEmpty+ ]+ lineN = docSeq+ [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty+ , docLit $ Text.pack "}"+ ]+ in [line1] ++ lineR ++ [lineN]+ ]+ )+ -- strict indentation block+ , ( True+ , docSetParSpacing+ $ docAddBaseY BrIndentRegular+ $ docPar+ (docNodeAnnKW lexpr Nothing $ rExprDoc)+ (docNonBottomSpacing $ docLines $ let+ line1 = docCols ColRecUpdate+ [ appSep $ docLit $ Text.pack "{"+ , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n+ , docWrapNodeRest rF1f $ case rF1e of+ Just x -> docSeq [ appSep $ docLit $ Text.pack "="+ , docAddBaseY BrIndentRegular $ x+ ]+ Nothing -> docEmpty+ ]+ lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate+ [ docCommaSep+ , appSep $ docLit $ fText+ , case fDoc of+ Just x -> docSeq [ appSep $ docLit $ Text.pack "="+ , docAddBaseY BrIndentRegular x+ ]+ Nothing -> docEmpty+ ]+ lineN = docSeq+ [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty+ , docLit $ Text.pack "}"+ ]+ in [line1] ++ lineR ++ [lineN])+ )+ ]+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+ ExprWithTySig exp1 (HsWC _ (HsIB _ typ1 _)) -> do+#else /* ghc-8.0 */+ ExprWithTySig exp1 (HsIB _ (HsWC _ _ typ1)) -> do+#endif+ expDoc <- docSharedWrapper layoutExpr exp1+ typDoc <- docSharedWrapper layoutType typ1+ docSeq+ [ appSep expDoc+ , appSep $ docLit $ Text.pack "::"+ , typDoc+ ]+ ExprWithTySigOut{} -> do+ -- TODO+ briDocByExactInlineOnly "ExprWithTySigOut{}" lexpr+ ArithSeq _ Nothing info ->+ case info of+ From e1 -> do+ e1Doc <- docSharedWrapper layoutExpr e1+ docSeq+ [ docLit $ Text.pack "["+ , appSep $ docForceSingleline e1Doc+ , docLit $ Text.pack "..]"+ ]+ FromThen e1 e2 -> do+ e1Doc <- docSharedWrapper layoutExpr e1+ e2Doc <- docSharedWrapper layoutExpr e2+ docSeq+ [ docLit $ Text.pack "["+ , docForceSingleline e1Doc+ , appSep $ docLit $ Text.pack ","+ , appSep $ docForceSingleline e2Doc+ , docLit $ Text.pack "..]"+ ]+ FromTo e1 eN -> do+ e1Doc <- docSharedWrapper layoutExpr e1+ eNDoc <- docSharedWrapper layoutExpr eN+ docSeq+ [ docLit $ Text.pack "["+ , appSep $ docForceSingleline e1Doc+ , appSep $ docLit $ Text.pack ".."+ , docForceSingleline eNDoc+ , docLit $ Text.pack "]"+ ]+ FromThenTo e1 e2 eN -> do+ e1Doc <- docSharedWrapper layoutExpr e1+ e2Doc <- docSharedWrapper layoutExpr e2+ eNDoc <- docSharedWrapper layoutExpr eN+ docSeq+ [ docLit $ Text.pack "["+ , docForceSingleline e1Doc+ , appSep $ docLit $ Text.pack ","+ , appSep $ docForceSingleline e2Doc+ , appSep $ docLit $ Text.pack ".."+ , docForceSingleline eNDoc+ , docLit $ Text.pack "]"+ ]+ ArithSeq{} ->+ briDocByExactInlineOnly "ArithSeq" lexpr+ PArrSeq{} -> do+ -- TODO+ briDocByExactInlineOnly "PArrSeq{}" lexpr+ HsSCC{} -> do+ -- TODO+ briDocByExactInlineOnly "HsSCC{}" lexpr+ HsCoreAnn{} -> do+ -- TODO+ briDocByExactInlineOnly "HsCoreAnn{}" lexpr+ HsBracket{} -> do+ -- TODO+ briDocByExactInlineOnly "HsBracket{}" lexpr+ HsRnBracketOut{} -> do+ -- TODO+ briDocByExactInlineOnly "HsRnBracketOut{}" lexpr+ HsTcBracketOut{} -> do+ -- TODO+ briDocByExactInlineOnly "HsTcBracketOut{}" lexpr+ HsSpliceE{} -> do+ -- TODO+ briDocByExactInlineOnly "HsSpliceE{}" lexpr+ HsProc{} -> do+ -- TODO+ briDocByExactInlineOnly "HsProc{}" lexpr+ HsStatic{} -> do+ -- TODO+ briDocByExactInlineOnly "HsStatic{}" lexpr+ HsArrApp{} -> do+ -- TODO+ briDocByExactInlineOnly "HsArrApp{}" lexpr+ HsArrForm{} -> do+ -- TODO+ briDocByExactInlineOnly "HsArrForm{}" lexpr+ HsTick{} -> do+ -- TODO+ briDocByExactInlineOnly "HsTick{}" lexpr+ HsBinTick{} -> do+ -- TODO+ briDocByExactInlineOnly "HsBinTick{}" lexpr+ HsTickPragma{} -> do+ -- TODO+ briDocByExactInlineOnly "HsTickPragma{}" lexpr+ EWildPat{} -> do+ docLit $ Text.pack "_"+ EAsPat asName asExpr -> do+ docSeq+ [ docLit $ (lrdrNameToText asName) <> Text.pack "@"+ , layoutExpr asExpr+ ]+ EViewPat{} -> do+ -- TODO+ briDocByExactInlineOnly "EViewPat{}" lexpr+ ELazyPat{} -> do+ -- TODO+ briDocByExactInlineOnly "ELazyPat{}" lexpr+ HsWrap{} -> do+ -- TODO+ briDocByExactInlineOnly "HsWrap{}" lexpr+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */+ HsConLikeOut{} -> do+ -- TODO+ briDocByExactInlineOnly "HsWrap{}" lexpr+ ExplicitSum{} -> do+ -- TODO+ briDocByExactInlineOnly "ExplicitSum{}" lexpr #endif
src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs view
@@ -96,6 +96,26 @@ [ appSep $ docLit t , docLit $ Text.pack "{..}" ]+ ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do+ let t = lrdrNameToText lname+ fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do+ fExpDoc <- if pun+ then return Nothing+ else Just <$> docSharedWrapper layoutPat fPat+ return $ (lrdrNameToText lnameF, fExpDoc)+ fmap Seq.singleton $ docSeq+ [ appSep $ docLit t+ , appSep $ docLit $ Text.pack "{"+ , docSeq $ fds >>= \case+ (fieldName, Just fieldDoc) ->+ [ appSep $ docLit $ fieldName+ , appSep $ docLit $ Text.pack "="+ , fieldDoc >>= colsWrapPat+ , docCommaSep+ ]+ (fieldName, Nothing) -> [docLit fieldName, docCommaSep]+ , docLit $ Text.pack "..}"+ ] TuplePat args boxity _ -> do case boxity of Boxed -> wrapPatListy args "(" ")"
src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs view
@@ -11,6 +11,7 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics+import Language.Haskell.Brittany.Internal.Config.Types import RdrName ( RdrName(..) ) import GHC ( runGhc, GenLocated(L), moduleNameString )@@ -26,51 +27,91 @@ layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))-layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of- LastStmt body False _ -> do- layoutExpr body- BindStmt lPat expr _ _ _ -> do- patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat- expDoc <- docSharedWrapper layoutExpr expr- docAlt- [ docCols- ColBindStmt- [ appSep patDoc- , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc]- ]- , docCols- ColBindStmt- [ appSep patDoc- , docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "<-") (expDoc)+layoutStmt lstmt@(L _ stmt) = do+ indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack+ docWrapNode lstmt $ case stmt of+ LastStmt body False _ -> do+ layoutExpr body+ BindStmt lPat expr _ _ _ -> do+ patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat+ expDoc <- docSharedWrapper layoutExpr expr+ docAlt+ [ docCols+ ColBindStmt+ [ appSep patDoc+ , docSeq [appSep $ docLit $ Text.pack "<-", docForceParSpacing expDoc]+ ]+ , docCols+ ColBindStmt+ [ appSep patDoc+ , docAddBaseY BrIndentRegular+ $ docPar (docLit $ Text.pack "<-") (expDoc)+ ] ]- ]- LetStmt binds -> layoutLocalBinds binds >>= \case- Nothing -> docLit $ Text.pack "let" -- i just tested- -- it, and it is- -- indeed allowed.- -- heh.- Just [] -> docLit $ Text.pack "let" -- this probably never happens- Just [bindDoc] -> docAlt- [ docCols- ColDoLet- [ appSep $ docLit $ Text.pack "let"- , docSetBaseAndIndent $ return bindDoc+ LetStmt binds -> layoutLocalBinds binds >>= \case+ Nothing -> docLit $ Text.pack "let" -- i just tested+ -- it, and it is+ -- indeed allowed.+ -- heh.+ Just [] -> docLit $ Text.pack "let" -- this probably never happens+ Just [bindDoc] -> docAlt+ [ -- let bind = expr+ docCols+ ColDoLet+ [ appSep $ docLit $ Text.pack "let"+ , ( if indentPolicy == IndentPolicyLeft+ then docForceSingleline+ else docSetBaseAndIndent+ )+ $ return bindDoc+ ]+ , -- let+ -- bind = expr+ docAddBaseY BrIndentRegular $ docPar+ (docLit $ Text.pack "let")+ (docSetBaseAndIndent $ return bindDoc) ]- , docAddBaseY BrIndentRegular- $ docPar (docLit $ Text.pack "let")- (docSetBaseAndIndent $ return bindDoc)- ]- Just bindDocs -> docAlt- [ docSeq- [ appSep $ docLit $ Text.pack "let"- , docSetBaseAndIndent $ docLines $ return <$> bindDocs+ Just bindDocs -> docAltFilter+ [ -- let aaa = expra+ -- bbb = exprb+ -- ccc = exprc+ ( indentPolicy /= IndentPolicyLeft+ , docSeq+ [ appSep $ docLit $ Text.pack "let"+ , docSetBaseAndIndent $ docLines $ return <$> bindDocs+ ]+ )+ , -- let+ -- aaa = expra+ -- bbb = exprb+ -- ccc = exprc+ ( True+ , docAddBaseY BrIndentRegular $ docPar+ (docLit $ Text.pack "let")+ (docSetBaseAndIndent $ docLines $ return <$> bindDocs)+ ) ]- , docAddBaseY BrIndentRegular $ docPar- (docLit $ Text.pack "let")- (docSetBaseAndIndent $ docLines $ return <$> bindDocs)+ RecStmt stmts _ _ _ _ _ _ _ _ _ -> docAltFilter+ [ -- rec stmt1+ -- stmt2+ -- stmt3+ ( indentPolicy /= IndentPolicyLeft+ , docSeq+ [ docLit (Text.pack "rec")+ , docSeparator+ , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts+ ]+ )+ , -- rec+ -- stmt1+ -- stmt2+ -- stmt3+ ( True+ , docAddBaseY BrIndentRegular+ $ docPar (docLit (Text.pack "rec")) (docLines $ layoutStmt <$> stmts)+ ) ]- BodyStmt expr _ _ _ -> do- expDoc <- docSharedWrapper layoutExpr expr- docAddBaseY BrIndentRegular $ expDoc- _ -> briDocByExactInlineOnly "some unknown statement" lstmt+ BodyStmt expr _ _ _ -> do+ expDoc <- docSharedWrapper layoutExpr expr+ docAddBaseY BrIndentRegular $ expDoc+ _ -> briDocByExactInlineOnly "some unknown statement" lstmt
src/Language/Haskell/Brittany/Internal/Layouters/Type.hs view
@@ -14,7 +14,11 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import RdrName ( RdrName(..) )-import GHC ( runGhc, GenLocated(L), moduleNameString )+import GHC ( runGhc+ , GenLocated(L)+ , moduleNameString+ , AnnKeywordId (..)+ ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import HsSyn import Name@@ -29,12 +33,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */- HsTyVar _ name -> do+ HsTyVar promoted name -> do+ t <- lrdrNameToTextAnn name+ case promoted of+ Promoted -> docSeq+ [ docSeparator+ , docTick+ , docWrapNode name $ docLit t+ ]+ NotPromoted -> docWrapNode name $ docLit t #else /* ghc-8.0 */ HsTyVar name -> do-#endif t <- lrdrNameToTextAnn name docWrapNode name $ docLit t+#endif HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts@(_:_)) typ2)) -> do typeDoc <- docSharedWrapper layoutType typ2 tyVarDocs <- bndrs `forM` \case@@ -162,17 +174,17 @@ , docForceSingleline $ return $ typeDoc ] -- :: forall x- -- . x+ -- . x , docPar (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) ( docCols ColTyOpPrefix- [ docWrapNodeRest ltype $ docLit $ Text.pack ". "+ [ docWrapNodeRest ltype $ docLit $ Text.pack " . " , maybeForceML $ return typeDoc ] ) -- :: forall -- (x :: *)- -- . x+ -- . x , docPar (docLit (Text.pack "forall")) (docLines@@ -192,7 +204,7 @@ ] ) ++[ docCols ColTyOpPrefix- [ docWrapNodeRest ltype $ docLit $ Text.pack ". "+ [ docWrapNodeRest ltype $ docLit $ Text.pack " . " , maybeForceML $ return typeDoc ] ]@@ -294,7 +306,7 @@ docAlt [ docSeq [ docForceSingleline typeDoc1- , docLit $ Text.pack " "+ , docSeparator , docForceSingleline typeDoc2 ] , docPar@@ -324,7 +336,7 @@ docAlt [ docSeq $ docForceSingleline docHead : (docRest >>= \d ->- [ docLit $ Text.pack " ", docForceSingleline d ])+ [ docSeparator, docForceSingleline d ]) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) ] HsAppsTy (typHead:typRest) -> do@@ -333,7 +345,7 @@ docAlt [ docSeq $ docForceSingleline docHead : (docRest >>= \d ->- [ docLit $ Text.pack " ", docForceSingleline d ])+ [ docSeparator, docForceSingleline d ]) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) ] where@@ -487,7 +499,7 @@ ) (docCols ColTyOpPrefix [ docWrapNodeRest ltype- $ docLit $ Text.pack "::"+ $ docLit $ Text.pack ":: " , docAddBaseY (BrIndentSpecial 2) typeDoc1 ]) ]@@ -513,19 +525,47 @@ HsKindSig typ1 kind1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 kindDoc1 <- docSharedWrapper layoutType kind1+ hasParens <- hasAnnKeyword ltype AnnOpenP docAlt- [ docSeq- [ docForceSingleline typeDoc1- , docLit $ Text.pack " :: "- , docForceSingleline kindDoc1- ]- , docPar+ [ if hasParens+ then docSeq+ [ docLit $ Text.pack "("+ , docForceSingleline typeDoc1+ , docSeparator+ , docLit $ Text.pack "::"+ , docSeparator+ , docForceSingleline kindDoc1+ , docLit $ Text.pack ")"+ ]+ else docSeq+ [ docForceSingleline typeDoc1+ , docSeparator+ , docLit $ Text.pack "::"+ , docSeparator+ , docForceSingleline kindDoc1+ ]+ , if hasParens+ then docLines+ [ docCols+ ColTyOpPrefix+ [ docWrapNodeRest ltype $ docParenLSep+ , docAddBaseY (BrIndentSpecial 3) $ typeDoc1+ ]+ , docCols+ ColTyOpPrefix+ [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "+ , docAddBaseY (BrIndentSpecial 3) kindDoc1+ ]+ , (docLit $ Text.pack ")")+ ]+ else docPar typeDoc1- ( docCols ColTyOpPrefix- [ docWrapNodeRest ltype- $ docLit $ Text.pack ":: "- , docAddBaseY (BrIndentSpecial 3) kindDoc1- ])+ ( docCols+ ColTyOpPrefix+ [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "+ , docAddBaseY (BrIndentSpecial 3) kindDoc1+ ]+ ) ] HsBangTy{} -> -- TODO briDocByExactInlineOnly "HsBangTy{}" ltype
srcinc/prelude.inc view
@@ -136,7 +136,7 @@ import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.State.Lazy as StateL import qualified Control.Monad.Trans.State.Strict as StateS-import qualified Control.Monad.Trans.Either as EitherT+import qualified Control.Monad.Trans.Except as ExceptT import qualified Data.Strict.Maybe as Strict