diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/brittany.cabal b/brittany.cabal --- a/brittany.cabal +++ b/brittany.cabal @@ -1,5 +1,5 @@ name: brittany -version: 0.8.0.3 +version: 0.9.0.0 synopsis: Haskell source code formatter description: { See . @@ -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" diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -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 diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt new file mode 100644 --- /dev/null +++ b/src-literatetests/10-tests.blt @@ -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] + diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt new file mode 100644 --- /dev/null +++ b/src-literatetests/14-extensions.blt @@ -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) + diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt new file mode 100644 --- /dev/null +++ b/src-literatetests/15-regressions.blt @@ -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 diff --git a/src-literatetests/16-pending.blt b/src-literatetests/16-pending.blt new file mode 100644 --- /dev/null +++ b/src-literatetests/16-pending.blt @@ -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" + diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -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 + } + } diff --git a/src-literatetests/tests-context-free.blt b/src-literatetests/tests-context-free.blt new file mode 100644 --- /dev/null +++ b/src-literatetests/tests-context-free.blt @@ -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" + diff --git a/src-literatetests/tests.blt b/src-literatetests/tests.blt deleted file mode 100644 --- a/src-literatetests/tests.blt +++ /dev/null @@ -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" - diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -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) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -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 + ) ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -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 "(" ")" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs @@ -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 diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -14,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 diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc --- a/srcinc/prelude.inc +++ b/srcinc/prelude.inc @@ -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