From 8ef7daece8dab2658001e2d7229938473f4d3836 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 26 Sep 2017 23:24:00 +0200
Subject: [PATCH 01/26] Add changelog entry for 0.8.0.3
---
ChangeLog.md | 13 +++++++++++++
1 file changed, 13 insertions(+)
diff --git a/ChangeLog.md b/ChangeLog.md
index 4d16652..236a7ad 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,18 @@
# Revision history for brittany
+## 0.8.0.3 -- September 2017
+
+* Support for ghc-8.2.1
+* Bugfixes:
+ - Fix quadratic performance issue
+ - Fix special "where" indentation with indentAmount /= 2
+ - Fix negative literals in patterns
+ - Support type applications
+* Accept `-h` for `--help` and improve help layouting (via butcher-1.1.0.2)
+* Add continuous integration via travis (cabal, cabal-new, stack)
+ (brittle due compilation time limit)
+* Reduce compilation memory usage a bit
+
## 0.8.0.2 -- August 2017
* Add library interface, to be used by `haskell-ide-engine`.
--
2.30.2
From 8438d4a03d1d41fc105c99b04b7d951c19e87326 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 26 Sep 2017 23:41:54 +0200
Subject: [PATCH 02/26] Update README.md (ghc versions)
---
README.md | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/README.md b/README.md
index c048afa..d32a189 100644
--- a/README.md
+++ b/README.md
@@ -39,13 +39,13 @@ require fixing:
be detected and the user will get an error); there are other cases where
comments are moved slightly; there are also cases where comments result in
wonky newline insertion (although this should be a purely aesthetic issue.)
-- There is an **open performance issue on large inputs** (due to an
- accidentally quadratic sub-algorithm); noticable for inputs with >1k loc.
+- ~~There is an **open performance issue on large inputs** (due to an
+ accidentally quadratic sub-algorithm); noticable for inputs with >1k loc.~~
+ (fixed in `0.8.0.3`)
# Other usage notes
-- Requires `GHC-8.0.*`; support for 8.2 is on the list, but I haven't even
- looked at how much the `GHC` API changes.
+- Supports GHC versions `8.0.*` and `8.2.*`.
- config (file) documentation is lacking.
- some config values can not be configured via commandline yet.
- uses/creates user config file in `~/.brittany/config.yaml`;
--
2.30.2
From 8c6eb4d1e2b61ea51004aadc7280da503e883839 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 26 Sep 2017 23:42:11 +0200
Subject: [PATCH 03/26] Update stack.yaml (butcher-1.1.0.2)
---
stack.yaml | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/stack.yaml b/stack.yaml
index 39c0882..4bbcc0c 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -3,7 +3,7 @@ resolver: lts-9.0
extra-deps:
- monad-memo-0.4.1
- czipwith-1.0.0.0
- - butcher-1.1.0.0
+ - butcher-1.1.0.2
- data-tree-print-0.1.0.0
- deque-0.2
--
2.30.2
From a348ae7fbcc4bfbfb301f6dacd4cc0e096b9c7b2 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Fri, 29 Sep 2017 14:59:41 +0200
Subject: [PATCH 04/26] Switch to XDG path for config; Search conf in parents
- switch to XDG path should be backwards-compatible:
- new config will be written to XDG path
- but existing config in ~/.brittany will be respected
- looks for "brittany.yaml" not only in cwd, but in parents too.
uses the first file found.
fixes #45, fixes #55
---
src-brittany/Main.hs | 43 +++++++++++----
.../Haskell/Brittany/Internal/Config.hs | 55 +++++++++++--------
2 files changed, 65 insertions(+), 33 deletions(-)
diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs
index 129ee50..71b278a 100644
--- a/src-brittany/Main.hs
+++ b/src-brittany/Main.hs
@@ -292,15 +292,38 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEi
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/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs
index 49651d7..baaca1f 100644
--- a/src/Language/Haskell/Brittany/Internal/Config.hs
+++ b/src/Language/Haskell/Brittany/Internal/Config.hs
@@ -8,7 +8,8 @@ module Language.Haskell.Brittany.Internal.Config
, configParser
, staticDefaultConfig
, forwardOptionsSyntaxExtsEnabled
- , readMergePersConfig
+ , readConfig
+ , writeDefaultConfig
, showConfigYaml
)
where
@@ -198,29 +199,37 @@ configParser = do
-- , 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
--
2.30.2
From 5a12b630351695004d24daea58ded23cf7b44bbd Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Fri, 29 Sep 2017 17:39:39 +0200
Subject: [PATCH 05/26] Adapt travis script to improve build times
---
.travis.yml | 12 ++++++------
brittany.cabal | 5 -----
2 files changed, 6 insertions(+), 11 deletions(-)
diff --git a/.travis.yml b/.travis.yml
index a6b4a16..8b62149 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -180,7 +180,7 @@ before_install:
- |
function better_wait() {
date
- time $* & # send the long living command to background!
+ time "$*" & # send the long living command to background!
set +x
MINUTES=0
@@ -231,7 +231,7 @@ install:
echo "cabal build-cache MISS";
rm -rf $HOME/.cabsnap;
mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
- cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks;
+ cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M500M";
fi
# snapshot package-db on cache miss
@@ -259,12 +259,12 @@ script:
set -ex
case "$BUILD" in
stack)
- better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps
+ better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M"
;;
cabal)
if [ -f configure.ac ]; then autoreconf -i; fi
cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging
- better_wait cabal build -j$JOBS # this builds all libraries and executables (including tests/benchmarks)
+ better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M" # this builds all libraries and executables (including tests/benchmarks)
cabal test
;;
cabaldist)
@@ -275,12 +275,12 @@ script:
# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
# `cabal install --force-reinstalls dist/*-*.tar.gz`
SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
- (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ")
+ (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M500M")
;;
canew)
better_wait cabal new-build -j$JOBS --disable-tests --disable-benchmarks
better_wait cabal new-build -j$JOBS --enable-tests --enable-benchmarks
- cabal new-test
+ cabal new-test --ghc-options="-j1 +RTS -M500M"
;;
esac
set +ex
diff --git a/brittany.cabal b/brittany.cabal
index 07504a0..957fb06 100644
--- a/brittany.cabal
+++ b/brittany.cabal
@@ -80,7 +80,6 @@ library {
}
ghc-options: {
-Wall
- -j
-fno-warn-unused-imports
-fno-warn-redundant-constraints
}
@@ -203,7 +202,6 @@ executable brittany
}
ghc-options: {
-Wall
- -j
-fno-spec-constr
-fno-warn-unused-imports
-fno-warn-redundant-constraints
@@ -283,7 +281,6 @@ test-suite unittests
}
ghc-options: {
-Wall
- -j
-fno-warn-unused-imports
-rtsopts
-with-rtsopts "-M2G"
@@ -356,7 +353,6 @@ test-suite littests
}
ghc-options: {
-Wall
- -j
-fno-warn-unused-imports
-rtsopts
-with-rtsopts "-M2G"
@@ -395,7 +391,6 @@ test-suite libinterfacetests
}
ghc-options: {
-Wall
- -j
-fno-warn-unused-imports
-rtsopts
-with-rtsopts "-M2G"
--
2.30.2
From 308da71afbbc579aa26b97d62b0a1eb8f6829fec Mon Sep 17 00:00:00 2001
From: d-dorazio <daniele.dorazio@adroll.com>
Date: Sun, 1 Oct 2017 13:03:49 +0200
Subject: [PATCH 06/26] support multiple inputs and outputs
---
src-brittany/Main.hs | 44 ++++++++++++++++++++++++--------------------
1 file changed, 24 insertions(+), 20 deletions(-)
diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs
index 129ee50..a88e1e3 100644
--- a/src-brittany/Main.hs
+++ b/src-brittany/Main.hs
@@ -14,6 +14,7 @@ import qualified Data.Map as Map
import qualified Data.Text.Lazy.Builder as Text.Builder
+import Control.Monad (foldM)
import Data.CZipWith
import qualified Debug.Trace as Trace
@@ -103,8 +104,8 @@ mainCmdParser helpDesc = do
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")
+ inputPaths <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "paths to input haskell source files")
+ outputPaths <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file paths")
configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
cmdlineConfig <- configParser
suppressOutput <- addSimpleBoolFlag
@@ -128,29 +129,32 @@ mainCmdParser helpDesc = do
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' = nonEmptyList Nothing . map Just $ maybeToList inputParam ++ inputPaths
+ let outputPaths' = nonEmptyList Nothing . map Just $ outputPaths
+ when (length inputPaths' /= length outputPaths') $ do
+ putStrErrLn "the number of inputs must match ther number of outputs"
+ System.Exit.exitWith (System.Exit.ExitFailure 51)
+
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 ()
+
+ let ios = zipWith (coreIO putStrErrLn config suppressOutput) inputPaths' outputPaths'
+ errNoM <- foldM run Nothing ios
+ case errNoM of
+ Just errNo -> System.Exit.exitWith (System.Exit.ExitFailure errNo)
+ Nothing -> pure ()
+ where
+ run acc io = do
+ res <- io
+ case res of
+ Left _ -> return (Just 1)
+ Right () -> return acc
+
+ nonEmptyList def [] = [def]
+ nonEmptyList _ x = x
-- | The main IO parts for the default mode of operation, and after commandline
--
2.30.2
From 36af16f881f489f7b59268146c401dd42fae1945 Mon Sep 17 00:00:00 2001
From: d-dorazio <daniele.dorazio@adroll.com>
Date: Sun, 1 Oct 2017 15:04:27 +0200
Subject: [PATCH 07/26] add inplace flag
---
src-brittany/Main.hs | 7 ++++++-
1 file changed, 6 insertions(+), 1 deletion(-)
diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs
index a88e1e3..ed21e50 100644
--- a/src-brittany/Main.hs
+++ b/src-brittany/Main.hs
@@ -113,6 +113,7 @@ mainCmdParser helpDesc = do
["suppress-output"]
(flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source")
_verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]")
+ inplace <- addSimpleBoolFlag "" ["inplace"] (flagHelp $ parDoc "overwrite the input files")
reorderStop
inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file")
desc <- peekCmdDesc
@@ -129,8 +130,12 @@ mainCmdParser helpDesc = do
when printHelp $ do
liftIO $ print $ ppHelpShallow desc
System.Exit.exitSuccess
+ when (length outputPaths > 0 && inplace) $ do
+ putStrErrLn "cannot specify output files and inplace at the same time"
+ System.Exit.exitWith (System.Exit.ExitFailure 52)
+
let inputPaths' = nonEmptyList Nothing . map Just $ maybeToList inputParam ++ inputPaths
- let outputPaths' = nonEmptyList Nothing . map Just $ outputPaths
+ let outputPaths' = if inplace then inputPaths' else nonEmptyList Nothing . map Just $ outputPaths
when (length inputPaths' /= length outputPaths') $ do
putStrErrLn "the number of inputs must match ther number of outputs"
System.Exit.exitWith (System.Exit.ExitFailure 51)
--
2.30.2
From ccf2eb092f0f9755d64b180807fd69852504f8af Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Sun, 1 Oct 2017 17:16:27 +0200
Subject: [PATCH 08/26] Support RecordWildCards, Add one-liner layouting for
records
fixes #52
---
src-literatetests/tests.blt | 15 +++
.../Brittany/Internal/Layouters/Expr.hs | 125 +++++++++++++-----
.../Brittany/Internal/Layouters/Pattern.hs | 20 +++
3 files changed, 128 insertions(+), 32 deletions(-)
diff --git a/src-literatetests/tests.blt b/src-literatetests/tests.blt
index e54841b..f4db082 100644
--- a/src-literatetests/tests.blt
+++ b/src-literatetests/tests.blt
@@ -1042,6 +1042,21 @@ foo =
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}
+
###############################################################################
###############################################################################
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
index a6ba345..2808df2 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
@@ -672,42 +672,103 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
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
- [ docSetParSpacing
+ [ docSeq
+ $ [docNodeAnnKW lexpr Nothing $ nameDoc, docSeparator]
+ ++ line1 id docForceSingleline
+ ++ join (lineR docForceSingleline)
+ ++ lineN
+ , 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 (?)
+ ( 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
@@ -755,7 +816,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
Nothing -> docEmpty
]
lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate
- [ appSep $ docLit $ Text.pack ","
+ [ docCommaSep
, appSep $ docLit $ fText
, case fDoc of
Just x -> docSeq [ appSep $ docLit $ Text.pack "="
@@ -785,7 +846,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
Nothing -> docEmpty
]
lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate
- [ appSep $ docLit $ Text.pack ","
+ [ docCommaSep
, appSep $ docLit $ fText
, case fDoc of
Just x -> docSeq [ appSep $ docLit $ Text.pack "="
@@ -829,7 +890,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
docSeq
[ docLit $ Text.pack "["
, docForceSingleline e1Doc
- , appSep $ docLit $ Text.pack ","
+ , docCommaSep
, appSep $ docForceSingleline e2Doc
, docLit $ Text.pack "..]"
]
@@ -850,7 +911,7 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
docSeq
[ docLit $ Text.pack "["
, docForceSingleline e1Doc
- , appSep $ docLit $ Text.pack ","
+ , docCommaSep
, appSep $ docForceSingleline e2Doc
, appSep $ docLit $ Text.pack ".."
, docForceSingleline eNDoc
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
index b36fcaa..3f66932 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
@@ -96,6 +96,26 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
[ 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 "(" ")"
--
2.30.2
From 95c40f2b1e2418945761b9a590db005e39c5b33b Mon Sep 17 00:00:00 2001
From: d-dorazio <daniele.dorazio@adroll.com>
Date: Mon, 2 Oct 2017 13:51:31 +0200
Subject: [PATCH 09/26] address review comments
---
src-brittany/Main.hs | 35 ++++++++++++++++-------------------
1 file changed, 16 insertions(+), 19 deletions(-)
diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs
index ed21e50..6f2d4d8 100644
--- a/src-brittany/Main.hs
+++ b/src-brittany/Main.hs
@@ -14,7 +14,6 @@ import qualified Data.Map as Map
import qualified Data.Text.Lazy.Builder as Text.Builder
-import Control.Monad (foldM)
import Data.CZipWith
import qualified Debug.Trace as Trace
@@ -130,15 +129,22 @@ mainCmdParser helpDesc = do
when printHelp $ do
liftIO $ print $ ppHelpShallow desc
System.Exit.exitSuccess
- when (length outputPaths > 0 && inplace) $ do
- putStrErrLn "cannot specify output files and inplace at the same time"
- System.Exit.exitWith (System.Exit.ExitFailure 52)
- let inputPaths' = nonEmptyList Nothing . map Just $ maybeToList inputParam ++ inputPaths
- let outputPaths' = if inplace then inputPaths' else nonEmptyList Nothing . map Just $ outputPaths
+ let inputPaths' = case maybeToList inputParam ++ inputPaths of
+ [] -> [Nothing]
+ ps -> map Just ps
+
+ outputPaths' <- case outputPaths of
+ [] | not inplace -> return [Nothing]
+ [] -> return inputPaths'
+ ps | not inplace -> return . map Just $ ps
+ _ -> do
+ putStrErrLn "cannot specify output files and inplace at the same time"
+ System.Exit.exitWith (System.Exit.ExitFailure 51)
+
when (length inputPaths' /= length outputPaths') $ do
putStrErrLn "the number of inputs must match ther number of outputs"
- System.Exit.exitWith (System.Exit.ExitFailure 51)
+ System.Exit.exitWith (System.Exit.ExitFailure 52)
config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
@@ -147,19 +153,10 @@ mainCmdParser helpDesc = do
trace (showConfigYaml config) $ return ()
let ios = zipWith (coreIO putStrErrLn config suppressOutput) inputPaths' outputPaths'
- errNoM <- foldM run Nothing ios
- case errNoM of
- Just errNo -> System.Exit.exitWith (System.Exit.ExitFailure errNo)
- Nothing -> pure ()
- where
- run acc io = do
- res <- io
+ res <- fmap sequence_ $ sequence ios
case res of
- Left _ -> return (Just 1)
- Right () -> return acc
-
- nonEmptyList def [] = [def]
- nonEmptyList _ x = x
+ Left _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)
+ Right _ -> pure ()
-- | The main IO parts for the default mode of operation, and after commandline
--
2.30.2
From a0112524aa4752f089758bbfdbe55fbde6566e8d Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Mon, 2 Oct 2017 20:50:51 +0200
Subject: [PATCH 10/26] Split up littests input into multiple files
*.blt instead of just tests.blt
yay for unix-style for ordering the inputs "15-regression.blt"
---
brittany.cabal | 3 +-
src-literatetests/{tests.blt => 10-tests.blt} | 504 ------------------
src-literatetests/15-regressions.blt | 467 ++++++++++++++++
src-literatetests/16-pending.blt | 35 ++
src-literatetests/Main.hs | 7 +-
5 files changed, 509 insertions(+), 507 deletions(-)
rename src-literatetests/{tests.blt => 10-tests.blt} (50%)
create mode 100644 src-literatetests/15-regressions.blt
create mode 100644 src-literatetests/16-pending.blt
diff --git a/brittany.cabal b/brittany.cabal
index 957fb06..2294238 100644
--- a/brittany.cabal
+++ b/brittany.cabal
@@ -24,7 +24,7 @@ extra-doc-files: {
doc/implementation/*.md
}
extra-source-files: {
- src-literatetests/tests.blt
+ src-literatetests/*.blt
}
source-repository head {
@@ -330,6 +330,7 @@ test-suite littests
, czipwith
, ghc-boot-th
, hspec >=2.4.1 && <2.5
+ , filepath
, parsec >=3.1.11 && <3.2
}
ghc-options: -Wall
diff --git a/src-literatetests/tests.blt b/src-literatetests/10-tests.blt
similarity index 50%
rename from src-literatetests/tests.blt
rename to src-literatetests/10-tests.blt
index f4db082..696cbb6 100644
--- a/src-literatetests/tests.blt
+++ b/src-literatetests/10-tests.blt
@@ -589,507 +589,3 @@ func =
]
++ [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
-
-#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}
-
-
-###############################################################################
-###############################################################################
-###############################################################################
-#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/15-regressions.blt b/src-literatetests/15-regressions.blt
new file mode 100644
index 0000000..0a63b7a
--- /dev/null
+++ b/src-literatetests/15-regressions.blt
@@ -0,0 +1,467 @@
+###############################################################################
+###############################################################################
+###############################################################################
+#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
+
+#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}
+
diff --git a/src-literatetests/16-pending.blt b/src-literatetests/16-pending.blt
new file mode 100644
index 0000000..c8147d8
--- /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
index fe966e6..34b4e4e 100644
--- a/src-literatetests/Main.hs
+++ b/src-literatetests/Main.hs
@@ -24,6 +24,7 @@ import Language.Haskell.Brittany.Internal.Config
import Data.Coerce ( coerce )
import qualified Data.Text.IO as Text.IO
+import System.FilePath ( (</>) )
@@ -38,8 +39,10 @@ data InputLine
main :: IO ()
main = do
- input <- Text.IO.readFile "src-literatetests/tests.blt"
- let groups = createChunks input
+ files <- System.Directory.listDirectory "src-literatetests/"
+ let blts = List.sort $ filter (".blt" `isSuffixOf`) files
+ inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" </> blt)
+ let groups = createChunks =<< inputs
hspec $ groups `forM_` \(groupname, tests) -> do
describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do
(if pend then before_ pending else id)
--
2.30.2
From f21c6b6eacad4542a2c02606d43ba70814d7a919 Mon Sep 17 00:00:00 2001
From: d-dorazio <daniele.dorazio@adroll.com>
Date: Tue, 3 Oct 2017 23:32:36 +0200
Subject: [PATCH 11/26] rework the cli interface
---
brittany.cabal | 8 +++----
src-brittany/Main.hs | 54 +++++++++++++++++++++++++-------------------
stack.yaml | 2 +-
3 files changed, 36 insertions(+), 28 deletions(-)
diff --git a/brittany.cabal b/brittany.cabal
index 2294238..ca639b8 100644
--- a/brittany.cabal
+++ b/brittany.cabal
@@ -102,7 +102,7 @@ library {
, pretty >=1.1.3.3 && <1.2
, bytestring >=0.10.8.1 && <0.11
, directory >=1.2.6.2 && <1.4
- , butcher >=1.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
@@ -147,7 +147,7 @@ executable brittany
other-modules: {
Paths_brittany
}
- -- other-extensions:
+ -- other-extensions:
build-depends:
{ brittany
, base
@@ -335,7 +335,7 @@ test-suite littests
}
ghc-options: -Wall
main-is: Main.hs
- other-modules:
+ other-modules:
hs-source-dirs: src-literatetests
default-extensions: {
CPP
@@ -379,7 +379,7 @@ test-suite libinterfacetests
}
ghc-options: -Wall
main-is: Main.hs
- other-modules:
+ other-modules:
hs-source-dirs: src-libinterfacetests
default-extensions: {
FlexibleContexts
diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs
index 8edc6b6..4f6992e 100644
--- a/src-brittany/Main.hs
+++ b/src-brittany/Main.hs
@@ -12,8 +12,12 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import qualified Data.Map as Map
+import 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,6 +43,17 @@ import qualified GHC.LanguageExtensions.Type as GHC
import Paths_brittany
+data WriteMode = Display | Inplace
+
+instance Read WriteMode where
+ readPrec = val "display" Display <|> val "inplace" Inplace
+ where
+ val iden v = ReadPrec.lift $ ReadP.string iden >> return v
+
+instance Show WriteMode where
+ show Display = "display"
+ show Inplace = "inplace"
+
main :: IO ()
main = mainFromCmdParserWithHelpDesc mainCmdParser
@@ -103,8 +118,6 @@ mainCmdParser helpDesc = do
printHelp <- addSimpleBoolFlag "h" ["help"] mempty
printVersion <- addSimpleBoolFlag "" ["version"] mempty
printLicense <- addSimpleBoolFlag "" ["license"] mempty
- inputPaths <- addFlagStringParams "i" ["input"] "PATH" (flagHelpStr "paths to input haskell source files")
- outputPaths <- addFlagStringParams "o" ["output"] "PATH" (flagHelpStr "output file paths")
configPaths <- addFlagStringParams "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
cmdlineConfig <- configParser
suppressOutput <- addSimpleBoolFlag
@@ -112,10 +125,17 @@ mainCmdParser helpDesc = do
["suppress-output"]
(flagHelp $ parDoc "suppress the regular output, i.e. the transformed haskell source")
_verbosity <- addSimpleCountFlag "v" ["verbose"] (flagHelp $ parDoc "[currently without effect; TODO]")
- inplace <- addSimpleBoolFlag "" ["inplace"] (flagHelp $ parDoc "overwrite the input files")
+ writeMode <- addFlagReadParam
+ ""
+ ["write-mode"]
+ ""
+ Flag
+ { _flag_help = Just (PP.text "output mode: [display|inplace]")
+ , _flag_default = Just Display
+ }
reorderStop
- inputParam <- addStringParamOpt "PATH" (paramHelpStr "path to input haskell source file")
- desc <- peekCmdDesc
+ inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files")
+ desc <- peekCmdDesc
addCmdImpl $ void $ do
when printLicense $ do
print licenseDoc
@@ -130,21 +150,10 @@ mainCmdParser helpDesc = do
liftIO $ print $ ppHelpShallow desc
System.Exit.exitSuccess
- let inputPaths' = case maybeToList inputParam ++ inputPaths of
- [] -> [Nothing]
- ps -> map Just ps
-
- outputPaths' <- case outputPaths of
- [] | not inplace -> return [Nothing]
- [] -> return inputPaths'
- ps | not inplace -> return . map Just $ ps
- _ -> do
- putStrErrLn "cannot specify output files and inplace at the same time"
- System.Exit.exitWith (System.Exit.ExitFailure 51)
-
- when (length inputPaths' /= length outputPaths') $ do
- putStrErrLn "the number of inputs must match ther number of outputs"
- 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)
@@ -152,9 +161,8 @@ mainCmdParser helpDesc = do
when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do
trace (showConfigYaml config) $ return ()
- let ios = zipWith (coreIO putStrErrLn config suppressOutput) inputPaths' outputPaths'
- res <- fmap sequence_ $ sequence ios
- case res of
+ results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths
+ case sequence_ results of
Left _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)
Right _ -> pure ()
diff --git a/stack.yaml b/stack.yaml
index 4bbcc0c..539cd6d 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -3,7 +3,7 @@ resolver: lts-9.0
extra-deps:
- monad-memo-0.4.1
- czipwith-1.0.0.0
- - butcher-1.1.0.2
+ - butcher-1.2.0.0
- data-tree-print-0.1.0.0
- deque-0.2
--
2.30.2
From 752048882e6049f02413bbd2882ea2066e43a50b Mon Sep 17 00:00:00 2001
From: d-dorazio <daniele.dorazio@adroll.com>
Date: Wed, 4 Oct 2017 20:56:37 +0200
Subject: [PATCH 12/26] move inputParams into the reordered block
---
src-brittany/Main.hs | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs
index 4f6992e..76ed94e 100644
--- a/src-brittany/Main.hs
+++ b/src-brittany/Main.hs
@@ -133,8 +133,8 @@ mainCmdParser helpDesc = do
{ _flag_help = Just (PP.text "output mode: [display|inplace]")
, _flag_default = Just Display
}
- reorderStop
inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files")
+ reorderStop
desc <- peekCmdDesc
addCmdImpl $ void $ do
when printLicense $ do
--
2.30.2
From 7d7ec3e8b4793a163f38f257cbb9b87b7760928e Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Wed, 4 Oct 2017 23:43:30 +0200
Subject: [PATCH 13/26] Update commandline help output
---
src-brittany/Main.hs | 26 ++++++++++++++++++++------
1 file changed, 20 insertions(+), 6 deletions(-)
diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs
index 76ed94e..4928acf 100644
--- a/src-brittany/Main.hs
+++ b/src-brittany/Main.hs
@@ -62,13 +62,24 @@ helpDoc :: PP.Doc
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)"
@@ -128,9 +139,12 @@ mainCmdParser helpDesc = do
writeMode <- addFlagReadParam
""
["write-mode"]
- ""
+ "(display|inplace)"
Flag
- { _flag_help = Just (PP.text "output mode: [display|inplace]")
+ { _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")
--
2.30.2
From f86665a251463daa03b8f6f39118b11beaca5d54 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Sat, 14 Oct 2017 23:21:13 +0200
Subject: [PATCH 14/26] Fix promoted HsTyVars on ghc-8.2.1
This fix does not work on ghc-8.0, because I do not understand
the 8.0 API in this instance. Could be resolved by looking
at annotations, but that really should not be necessary.
---
src-literatetests/15-regressions.blt | 12 ++++++++++++
.../Brittany/Internal/LayouterBasics.hs | 4 ++++
.../Brittany/Internal/Layouters/Type.hs | 18 +++++++++++++-----
3 files changed, 29 insertions(+), 5 deletions(-)
diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt
index 0a63b7a..2a7185b 100644
--- a/src-literatetests/15-regressions.blt
+++ b/src-literatetests/15-regressions.blt
@@ -465,3 +465,15 @@ v = A {..} where b = 2
{-# 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]
+
diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index cffcad7..14a0510 100644
--- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -42,6 +42,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
, appSep
, docCommaSep
, docParenLSep
+ , docTick
, spacifyDocs
, briDocMToPPM
, allocateNode
@@ -447,6 +448,9 @@ docCommaSep = appSep $ docLit $ Text.pack ","
docParenLSep :: ToBriDocM BriDocNumbered
docParenLSep = appSep $ docLit $ Text.pack "("
+docTick :: ToBriDocM BriDocNumbered
+docTick = docLit $ Text.pack "'"
+
docNodeAnnKW
:: Data.Data.Data ast
=> Located ast
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
index 36d1633..9fa7262 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
@@ -29,12 +29,20 @@ layoutType :: ToBriDoc HsType
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
@@ -294,7 +302,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
docAlt
[ docSeq
[ docForceSingleline typeDoc1
- , docLit $ Text.pack " "
+ , docSeparator
, docForceSingleline typeDoc2
]
, docPar
@@ -324,7 +332,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
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 +341,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
docAlt
[ docSeq
$ docForceSingleline docHead : (docRest >>= \d ->
- [ docLit $ Text.pack " ", docForceSingleline d ])
+ [ docSeparator, docForceSingleline d ])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
]
where
--
2.30.2
From b1c6be7acd3a65bd55667388288ea15c1ea31cba Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Sun, 15 Oct 2017 00:23:14 +0200
Subject: [PATCH 15/26] Fix parentheses around kind signatures, fixes #64
---
src-literatetests/15-regressions.blt | 9 +++
.../Brittany/Internal/LayouterBasics.hs | 14 +++++
.../Brittany/Internal/Layouters/Type.hs | 56 +++++++++++++++----
3 files changed, 67 insertions(+), 12 deletions(-)
diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt
index 2a7185b..bea97cc 100644
--- a/src-literatetests/15-regressions.blt
+++ b/src-literatetests/15-regressions.blt
@@ -477,3 +477,12 @@ test :: Proxy '[ 'True]
#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)
+
diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index 14a0510..a0a3c7b 100644
--- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -48,6 +48,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
, allocateNode
, docSharedWrapper
, hasAnyCommentsBelow
+ , hasAnnKeyword
)
where
@@ -239,6 +240,19 @@ hasAnyCommentsBelow ast@(L l _) = do
$ 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
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
index 9fa7262..a5148f5 100644
--- 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.Types
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
@@ -521,19 +525,47 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
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
--
2.30.2
From 585c345c356f8e8dd2db564503a8c1f8d8c31fbb Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Sun, 15 Oct 2017 00:32:10 +0200
Subject: [PATCH 16/26] Fix silently broken travis setup (rahhh)
---
.travis.yml | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/.travis.yml b/.travis.yml
index 8b62149..da510f3 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -180,7 +180,7 @@ before_install:
- |
function better_wait() {
date
- time "$*" & # send the long living command to background!
+ time "$@" & # send the long living command to background!
set +x
MINUTES=0
@@ -231,7 +231,7 @@ install:
echo "cabal build-cache MISS";
rm -rf $HOME/.cabsnap;
mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
- cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M500M";
+ cabal install -j$JOBS --only-dependencies --enable-tests --enable-benchmarks --ghc-options="-j1 +RTS -M500M -RTS";
fi
# snapshot package-db on cache miss
@@ -259,12 +259,12 @@ script:
set -ex
case "$BUILD" in
stack)
- better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M"
+ better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS"
;;
cabal)
if [ -f configure.ac ]; then autoreconf -i; fi
cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging
- better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M" # this builds all libraries and executables (including tests/benchmarks)
+ better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" # this builds all libraries and executables (including tests/benchmarks)
cabal test
;;
cabaldist)
@@ -275,12 +275,12 @@ script:
# If there are no other `.tar.gz` files in `dist`, this can be even simpler:
# `cabal install --force-reinstalls dist/*-*.tar.gz`
SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
- (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M500M")
+ (cd dist && better_wait cabal install -j$JOBS --force-reinstalls "$SRC_TGZ" --ghc-options="-j1 +RTS -M500M -RTS")
;;
canew)
better_wait cabal new-build -j$JOBS --disable-tests --disable-benchmarks
better_wait cabal new-build -j$JOBS --enable-tests --enable-benchmarks
- cabal new-test --ghc-options="-j1 +RTS -M500M"
+ cabal new-test --ghc-options="-j1 +RTS -M500M -RTS"
;;
esac
set +ex
--
2.30.2
From ddd7c6b439588547d488574b5c019df029dc9d77 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 24 Oct 2017 00:00:34 +0200
Subject: [PATCH 17/26] Fix some rare issue and add some comments
(it is so rare i cannot reproduce anymore right now,
because the code that caused it has changed since..)
---
.../Brittany/Internal/Layouters/Expr.hs | 23 +++++++++++++++----
1 file changed, 18 insertions(+), 5 deletions(-)
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
index 2808df2..90fd435 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
@@ -154,19 +154,32 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
expDoc1 <- docSharedWrapper layoutExpr exp1
expDoc2 <- docSharedWrapper layoutExpr exp2
docAlt
- [ docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2]
- , docSetParSpacing
+ [ -- 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
]
- , docSetParSpacing
+ , -- func
+ -- arg
+ docSetParSpacing
$ docAddBaseY BrIndentRegular
$ docPar
(docForceSingleline expDoc1)
- expDoc2
- , docAddBaseY BrIndentRegular
+ (docNonBottomSpacing expDoc2)
+ , -- fu
+ -- nc
+ -- ar
+ -- gument
+ docAddBaseY BrIndentRegular
$ docPar
expDoc1
expDoc2
--
2.30.2
From 338beb8eea96809c0030541f96ff8fd1c8c0f68c Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 24 Oct 2017 00:15:53 +0200
Subject: [PATCH 18/26] Move testcases for extensions in separate testfile
---
src-literatetests/10-tests.blt | 44 -------------------------
src-literatetests/14-extensions.blt | 50 +++++++++++++++++++++++++++++
2 files changed, 50 insertions(+), 44 deletions(-)
create mode 100644 src-literatetests/14-extensions.blt
diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt
index 696cbb6..03b1c6b 100644
--- a/src-literatetests/10-tests.blt
+++ b/src-literatetests/10-tests.blt
@@ -260,21 +260,6 @@ func -- b
) -- j
-- k
-###############################################################################
-
-#test ImplicitParams 1
-{-# LANGUAGE ImplicitParams #-}
-func :: (?asd::Int) -> ()
-
-#test ImplicitParams 2
-{-# LANGUAGE ImplicitParams #-}
-func
- :: ( ?asd
- :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
- -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
- )
- -> ()
-
###############################################################################
###############################################################################
@@ -454,12 +439,6 @@ func = 1.1e5
func = 'x'
func = 981409823458910394810928414192837123987123987123
-#test lambdacase
-{-# LANGUAGE LambdaCase #-}
-func = \case
- FooBar -> x
- Baz -> y
-
#test lambda
func = \x -> abc
@@ -550,29 +529,6 @@ func =
]
-###############################################################################
-###############################################################################
-###############################################################################
-#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
-
-
###############################################################################
###############################################################################
###############################################################################
diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt
new file mode 100644
index 0000000..d038b64
--- /dev/null
+++ b/src-literatetests/14-extensions.blt
@@ -0,0 +1,50 @@
+###############################################################################
+###############################################################################
+###############################################################################
+#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
+ )
+ -> ()
+
--
2.30.2
From 26f8cdfb659876f6233dac70dd76c64578c9048d Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 24 Oct 2017 00:16:49 +0200
Subject: [PATCH 19/26] Support RecursiveDo/`rec` keyword
---
src-literatetests/14-extensions.blt | 18 ++++++++++++++++++
.../Brittany/Internal/Layouters/Stmt.hs | 6 ++++++
2 files changed, 24 insertions(+)
diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt
index d038b64..896d105 100644
--- a/src-literatetests/14-extensions.blt
+++ b/src-literatetests/14-extensions.blt
@@ -48,3 +48,21 @@ func
)
-> ()
+
+###############################################################################
+## 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/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
index 692b467..a8d95aa 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
@@ -70,6 +70,12 @@ layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
]
+ RecStmt stmts _ _ _ _ _ _ _ _ _ -> do
+ docSeq
+ [ docLit (Text.pack "rec")
+ , docSeparator
+ , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts
+ ]
BodyStmt expr _ _ _ -> do
expDoc <- docSharedWrapper layoutExpr expr
docAddBaseY BrIndentRegular $ expDoc
--
2.30.2
From f46fcc135d7985c8c95025e21f0aa5a1d09fe16f Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Wed, 8 Nov 2017 21:54:32 +0100
Subject: [PATCH 20/26] Update doc/HCAR entry
---
doc/hcar/Brittany.tex | 55 ++++++++++++++++++-------------------------
1 file changed, 23 insertions(+), 32 deletions(-)
diff --git a/doc/hcar/Brittany.tex b/doc/hcar/Brittany.tex
index 5c6760d..f181b2f 100644
--- a/doc/hcar/Brittany.tex
+++ b/doc/hcar/Brittany.tex
@@ -1,6 +1,6 @@
-% Brittany-LE.tex
-\begin{hcarentry}[new]{Brittany}
-\report{Lennart Spitzner}%11/16
+% Brittany-LB.tex
+\begin{hcarentry}[updated]{Brittany}
+\report{Lennart Spitzner}%11/17
\status{work in progress}
\makeheader
@@ -11,44 +11,35 @@ haskell-src-exts such as hindent or haskell-formatter.
The goals of the project are to:
\begin{compactitem}
-\item
- support the full ghc-haskell syntax including syntactic extensions;
-\item
- retain newlines and comments unmodified (to the degree possible when code
- around them gets reformatted);
-\item
- be clever about using horizontal space while not overflowing it if it cannot
- be avoided;
-\item
- have linear complexity in the size of the input text / the number of
+\item support the full ghc-haskell syntax including syntactic extensions;
+\item retain newlines and comments unmodified (to the degree possible when
+ code around them gets reformatted);
+\item be clever about using horizontal space while not overflowing it if it
+ cannot be avoided;
+\item have linear complexity in the size of the input text / the number of
syntactic nodes in the input.
-\item
- support horizontal alignments (e.g. different equations/pattern matches in
- the some function's definition).
+\item support horizontal alignments (e.g. different equations/pattern matches
+ in the some function's definition).
\end{compactitem}
-In contrast to other formatters brittany internally works in two steps: Firstly
-transforming the syntax tree into a document tree representation, similar to
-the document representation in general-purpose pretty-printers such as the
-\emph{pretty} package, but much more specialized for the specific purpose of
-handling a Haskell source code document. Secondly this document representation
-is transformed into the output text document. This approach allows to handle
-many different syntactic constructs in a uniform way, making it possible
-to attain the above goals with a manageable amount of work.
+In contrast to other formatters brittany internally works in two steps:
+Firstly transforming the syntax tree into a document tree representation,
+similar to the document representation in general-purpose pretty-printers such
+as the \emph{pretty} package, but much more specialized for the specific
+purpose of handling a Haskell source code document. Secondly this document
+representation is transformed into the output text document. This approach
+allows to handle many different syntactic constructs in a uniform way, making
+it possible to attain the above goals with a manageable amount of work.
Brittany is work in progress; currently only type signatures and function
bindings are transformed, and not all syntactic constructs are supported.
-Nonetheless Brittany is safe to try/use as there are checks in place to
-ensure that the output is syntactically valid.
+Nonetheless Brittany is safe to try/use as there are checks in place to ensure
+that the output is syntactically valid.
-Brittany requires ghc-8, and is not released on hackage yet; for a description
-of how to build it see the repository README.
+Brittany requires ghc-8.*, and is available on Hackage and on Stackage.
\FurtherReading
-{\small
\begin{compactitem}
- \item
- \url{https://github.com/lspitzner/brittany}
+ \item \url{https://github.com/lspitzner/brittany}
\end{compactitem}
-}
\end{hcarentry}
--
2.30.2
From 37436e675aff945d756d49cecbd3487f428da507 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Sat, 25 Nov 2017 00:58:33 +0100
Subject: [PATCH 21/26] Update README.md: Mention stackage nightly,
contribution, dev branch
---
README.md | 17 +++++++++++++++--
1 file changed, 15 insertions(+), 2 deletions(-)
diff --git a/README.md b/README.md
index d32a189..5d232a2 100644
--- a/README.md
+++ b/README.md
@@ -46,6 +46,7 @@ require fixing:
# 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 @@ require fixing:
- -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
--
2.30.2
From c7095132094d1adcc8622cd4ded738131432f9dc Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Sat, 25 Nov 2017 19:23:56 +0100
Subject: [PATCH 22/26] Remove dependency on either package
Following the deprecation and removal of the EitherT transformer
---
brittany.cabal | 4 --
src-brittany/Main.hs | 8 ++--
src/Language/Haskell/Brittany/Internal.hs | 8 ++--
.../Brittany/Internal/ExactPrintUtils.hs | 37 +++++++++----------
srcinc/prelude.inc | 2 +-
5 files changed, 26 insertions(+), 33 deletions(-)
diff --git a/brittany.cabal b/brittany.cabal
index ca639b8..bf2ba63 100644
--- a/brittany.cabal
+++ b/brittany.cabal
@@ -112,7 +112,6 @@ library {
, 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
@@ -175,7 +174,6 @@ executable brittany
, unsafe
, safe
, deepseq
- , either
, semigroups
, cmdargs
, czipwith
@@ -252,7 +250,6 @@ test-suite unittests
, unsafe
, safe
, deepseq
- , either
, semigroups
, cmdargs
, czipwith
@@ -324,7 +321,6 @@ test-suite littests
, unsafe
, safe
, deepseq
- , either
, semigroups
, cmdargs
, czipwith
diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs
index 4928acf..046c830 100644
--- a/src-brittany/Main.hs
+++ b/src-brittany/Main.hs
@@ -193,8 +193,8 @@ coreIO
-> 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
@@ -234,7 +234,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEi
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
@@ -300,7 +300,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = EitherT.runEi
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
diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs
index 4c4bbf0..64c139a 100644
--- a/src/Language/Haskell/Brittany/Internal.hs
+++ b/src/Language/Haskell/Brittany/Internal.hs
@@ -20,7 +20,7 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
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 @@ import qualified GHC.LanguageExtensions.Type as GHC
-- 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 @@ parsePrintModule configRaw inputText = runEitherT $ do
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 @@ parsePrintModule configRaw inputText = runEitherT $ do
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
diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
index faa9526..74ed50d 100644
--- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
+++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
@@ -58,26 +58,24 @@ parseModuleWithCpp
-> (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 @@ parseModuleFromString
-> 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
-----------
diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc
index 805b941..81ca53a 100644
--- a/srcinc/prelude.inc
+++ b/srcinc/prelude.inc
@@ -136,7 +136,7 @@ import qualified Data.Text.Lazy.IO as TextL.IO
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
--
2.30.2
From fdd2f5f6dc2ac4e5e307e50f16d373db0d5210b5 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Sun, 26 Nov 2017 21:28:06 +0100
Subject: [PATCH 23/26] Try fix shitty travis CI script again
---
.travis.yml | 1 +
1 file changed, 1 insertion(+)
diff --git a/.travis.yml b/.travis.yml
index da510f3..5922f50 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -196,6 +196,7 @@ before_install:
sleep 60
done
+ wait $!
set -x
}
--
2.30.2
From 6a97379b330078463cfd89353cf76787ce66a678 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 28 Nov 2017 17:56:28 +0100
Subject: [PATCH 24/26] Add whitespace around operator in section, Fixes #67
---
src-literatetests/10-tests.blt | 9 ++++-----
src-literatetests/15-regressions.blt | 12 ++++++++----
.../Haskell/Brittany/Internal/Layouters/Expr.hs | 4 ++--
3 files changed, 14 insertions(+), 11 deletions(-)
diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt
index 03b1c6b..e04887c 100644
--- a/src-literatetests/10-tests.blt
+++ b/src-literatetests/10-tests.blt
@@ -461,17 +461,16 @@ func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas
###
#test left
-func = (1+)
+func = (1 +)
#test right
-func = (+1)
+func = (+ 1)
#test left inf
-## TODO: this could be improved..
-func = (1`abc`)
+func = (1 `abc`)
#test right inf
-func = (`abc`1)
+func = (`abc` 1)
###
#group tuples
diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt
index bea97cc..319713b 100644
--- a/src-literatetests/15-regressions.blt
+++ b/src-literatetests/15-regressions.blt
@@ -324,17 +324,17 @@ func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo
parserPrim =
[ r
| r <-
- [ SGPPrimFloat $ bool id (0-) minus $ readGnok "parserPrim"
- (d1 ++ d2 ++ d3 ++ d4)
+ [ 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
+ <|> [ SGPPrimFloat $ bool id (0 -) minus $ fromIntegral
(readGnok "parserPrim" d1 :: Integer)
| _ <- string "f"
]
- <|> [ SGPPrimInt $ bool id (0-) minus $ fromIntegral
+ <|> [ SGPPrimInt $ bool id (0 -) minus $ fromIntegral
(readGnok "parserPrim" d1 :: Integer)
| _ <- string "i"
]
@@ -486,3 +486,7 @@ func
-> 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.!))
+
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
index 90fd435..0e36a21 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
+++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
@@ -321,11 +321,11 @@ layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
SectionL left op -> do -- TODO: add to testsuite
leftDoc <- docSharedWrapper layoutExpr left
opDoc <- docSharedWrapper layoutExpr op
- docSeq [leftDoc, opDoc]
+ docSeq [leftDoc, docSeparator, opDoc]
SectionR op right -> do -- TODO: add to testsuite
opDoc <- docSharedWrapper layoutExpr op
rightDoc <- docSharedWrapper layoutExpr right
- docSeq [opDoc, rightDoc]
+ docSeq [opDoc, docSeparator, rightDoc]
ExplicitTuple args boxity
| Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do
argDocs <- docSharedWrapper layoutExpr `mapM` argExprs
--
2.30.2
From 8a401d291efb44550e4b0a641aa311dab04d3891 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
Date: Tue, 28 Nov 2017 18:23:05 +0100
Subject: [PATCH 25/26] Workaround for #68: trim exactprinted text for unknown
nodes
---
src-literatetests/15-regressions.blt | 3 +++
.../Brittany/Internal/LayouterBasics.hs | 21 +++++++++++--------
2 files changed, 15 insertions(+), 9 deletions(-)
diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt
index 319713b..0876dc3 100644
--- a/src-literatetests/15-regressions.blt
+++ b/src-literatetests/15-regressions.blt
@@ -490,3 +490,6 @@ func
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..] ]
diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
index a0a3c7b..52c9e08 100644
--- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
+++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
@@ -82,6 +82,8 @@ import ApiAnnotation ( AnnKeywordId(..) )
import Data.Data
import Data.Generics.Schemes
+import qualified Data.Char as Char
+
import DataTreePrint
import Data.HList.HList
@@ -154,20 +156,21 @@ briDocByExactInlineOnly infoStr ast = do
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
--
2.30.2
From 910937985a4237a170d4c704c22f6ba222130c9e Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
Date: Tue, 28 Nov 2017 18:46:57 -0500
Subject: [PATCH 26/26] Add failing test for template haskell splices
For some reason `brittany` is failing to print exact for top level
splices. This may be an issue in `brittany` or `ghc-exact-print`, I'm
not sure. I've added failing tests to highlight this issue. This bug
causes `brittany` to produce syntactically invalid Haskell.
```
1) template haskell top level splice
expected: Right
{-# LANGUAGE TemplateHaskell #-}
deriveFromJSON (unPrefix "assignPost") ''AssignmentPost
but got: Right
{-# LANGUAGE TemplateHaskell #-}
deriveFromJSON (unPrefix "assignPost") ''
```
---
src-literatetests/tests.blt | 19 ++++++++++++++++++-
1 file changed, 18 insertions(+), 1 deletion(-)
diff --git a/src-literatetests/tests.blt b/src-literatetests/tests.blt
index e54841b..b87a418 100644
--- a/src-literatetests/tests.blt
+++ b/src-literatetests/tests.blt
@@ -590,6 +590,23 @@ func =
++ [ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc]
+###############################################################################
+###############################################################################
+###############################################################################
+#group template haskell
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test top level splice
+{-# LANGUAGE TemplateHaskell #-}
+deriveFromJSON (unPrefix "assignPost") ''AssignmentPost
+
+#test top level splice wrapped
+{-# LANGUAGE TemplateHaskell #-}
+$(deriveFromJSON (unPrefix "assignPost") ''AssignmentPost)
+
+
###############################################################################
###############################################################################
###############################################################################
@@ -1057,7 +1074,7 @@ foo =
## from the input; i cannot really express this yet with the current
## test-suite.
## #test ayaz
-##
+##
## myManageHook =
## composeOne [isFullscreen -?> doFullFloat, isDialog -?> doFloat, transience]
## <+> composeAll
--
2.30.2