From c124336738b922b0269d4e44e1c1095ada9ec8e9 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 19 Feb 2018 17:17:39 +0100 Subject: [PATCH 1/4] Fix NOINLINE pragma layouting --- src-literatetests/10-tests.blt | 4 ++++ src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 3 ++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index af873df..3f7ec68 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -287,6 +287,10 @@ func = f {-# INLINE CONLIKE [1] f #-} f = id +#test noinline pragma 1 +{-# NOINLINE func #-} +func :: Int + #test inline pragma 4 #pending this does not work with the compiler version we currently use yet (i think). should work with ghc-8.0.2. func = f diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 9681453..400d422 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -94,7 +94,8 @@ layoutSig lsig@(L _loc sig) = case sig of NoInline -> "NOINLINE " EmptyInlineSpec -> "" -- i have no idea if this is correct. let phaseStr = case phaseAct of - NeverActive -> "[] " + NeverActive -> "" -- not [] - for NOINLINE NeverActive is + -- in fact the default AlwaysActive -> "" ActiveBefore _ i -> "[~" ++ show i ++ "] " ActiveAfter _ i -> "[" ++ show i ++ "] " -- 2.30.2 From 19e31fdaf2bed40e25f9c9b29907441279f53fbe Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 19 Feb 2018 21:33:43 +0100 Subject: [PATCH 2/4] Improve layouting of RecordUpd, Fix minor issue for HsLet --- src-literatetests/15-regressions.blt | 5 +- .../Brittany/Internal/Layouters/Expr.hs | 55 ++++++++++++++----- 2 files changed, 42 insertions(+), 18 deletions(-) diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 7654285..5e4f52c 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -367,9 +367,8 @@ runBrittany tabSize text = do let config' = staticDefaultConfig config = config' - { _conf_layout = (_conf_layout config') { _lconfig_indentAmount = coerce - tabSize - } + { _conf_layout = + (_conf_layout config') { _lconfig_indentAmount = coerce tabSize } , _conf_forward = forwardOptionsSyntaxExtsEnabled } parsePrintModule config text diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 8d90148..807aad8 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -535,13 +535,15 @@ layoutExpr lexpr@(L _ expr) = do ifIndentLeftElse :: a -> a -> a ifIndentLeftElse x y = if indentPolicy == IndentPolicyLeft then x else y - -- this `docSetIndentLevel` might seem out of place, but is here due to - -- ghc-exactprint's DP handling of "let" in particular. + -- this `docSetBaseAndIndent` might seem out of place (especially the + -- Indent part; setBase is necessary due to the use of docLines below), + -- but is here due to ghc-exactprint's DP handling of "let" in + -- particular. -- Just pushing another indentation level is a straightforward approach -- to making brittany idempotent, even though the result is non-optimal -- if "let" is moved horizontally as part of the transformation, as the -- comments before the first let item are moved horizontally with it. - docSetIndentLevel $ case mBindDocs of + docSetBaseAndIndent $ case mBindDocs of Just [bindDoc] -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" @@ -733,6 +735,8 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "}" ] RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do + -- TODO: the layouter for RecordUpd is slightly more clever. Should + -- probably copy the approach from there. let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname ((fd1l, fd1n, fd1e):fdr) <- fs `forM` \fieldl@(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr pun)) -> do fExpDoc <- if pun @@ -852,7 +856,7 @@ layoutExpr lexpr@(L _ expr) = do Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) docAltFilter - -- singleline + -- container { fieldA = blub, fieldB = blub } [ ( True , docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc @@ -870,7 +874,10 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "}" ] ) - -- wild-indentation block + -- hanging single-line fields + -- container { fieldA = blub + -- , fieldB = blub + -- } , ( indentPolicy /= IndentPolicyLeft , docSeq [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc @@ -881,7 +888,7 @@ layoutExpr lexpr@(L _ expr) = do , case rF1e of Just x -> docWrapNodeRest rF1f $ docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline $ x + , docForceSingleline x ] Nothing -> docEmpty ] @@ -901,36 +908,54 @@ layoutExpr lexpr@(L _ expr) = do in [line1] ++ lineR ++ [lineN] ] ) - -- strict indentation block + -- non-hanging with expressions placed to the right of the names + -- container + -- { fieldA = blub + -- , fieldB = potentially + -- multiline + -- } , ( True , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar (docNodeAnnKW lexpr Nothing $ rExprDoc) (docNonBottomSpacing $ docLines $ let + expressionWrapper = if indentPolicy == IndentPolicyLeft + then docForceParSpacing + else docSetBaseY line1 = docCols ColRecUpdate [ appSep $ docLit $ Text.pack "{" , docWrapNodePrior rF1f $ appSep $ docLit $ rF1n , docWrapNodeRest rF1f $ case rF1e of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular $ x - ] + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] Nothing -> docEmpty ] - lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRecUpdate + lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield + $ docCols ColRecUpdate [ docCommaSep , appSep $ docLit $ fText , case fDoc of - Just x -> docSeq [ appSep $ docLit $ Text.pack "=" - , docAddBaseY BrIndentRegular x - ] + Just x -> docAlt + [ docSeq [ appSep $ docLit $ Text.pack "=" + , expressionWrapper x + ] + , docAddBaseY BrIndentRegular + $ docPar (docLit $ Text.pack "=") x + ] Nothing -> docEmpty ] lineN = docSeq [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty , docLit $ Text.pack "}" ] - in [line1] ++ lineR ++ [lineN]) + in [line1] ++ lineR ++ [lineN] + ) ) ] #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ -- 2.30.2 From e4dea8783901d44fe5236ef080814fa76250b2e4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 4 Mar 2018 19:11:10 +0100 Subject: [PATCH 3/4] Switch to using branches master/release instead of dev/master --- README.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/README.md b/README.md index 2f55f03..42e7fa5 100644 --- a/README.md +++ b/README.md @@ -160,8 +160,6 @@ a good amount of high-level documentation at [the documentation index](doc/implementation/index.md) -Note that most development happens on the `dev` branch of this repository! - # License Copyright (C) 2016-2017 Lennart Spitzner -- 2.30.2 From 83b39de3d424dc1062b52657109862160fa08c6b Mon Sep 17 00:00:00 2001 From: alexeyraga Date: Fri, 23 Feb 2018 21:57:50 +1100 Subject: [PATCH 4/4] Expose readConfigs --- brittany.cabal | 1 + src-brittany/Main.hs | 49 +++------------- src/Language/Haskell/Brittany.hs | 4 ++ .../Haskell/Brittany/Internal/Config.hs | 57 ++++++++++++++++++- stack.yaml | 5 +- 5 files changed, 70 insertions(+), 46 deletions(-) diff --git a/brittany.cabal b/brittany.cabal index b6ecf52..a090280 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -108,6 +108,7 @@ library { , cmdargs >=0.10.14 && <0.11 , czipwith >=1.0.0.0 && <1.1 , ghc-boot-th >=8.0.1 && <8.3 + , filepath >=1.4.1.0 && <1.5 } default-extensions: { CPP diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index f986ad9..057ad24 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -158,7 +158,7 @@ mainCmdParser helpDesc = do when printVersion $ do do putStrLn $ "brittany version " ++ showVersion version - putStrLn $ "Copyright (C) 2016-2017 Lennart Spitzner" + putStrLn $ "Copyright (C) 2016-2018 Lennart Spitzner" putStrLn $ "There is NO WARRANTY, to the extent permitted by law." System.Exit.exitSuccess when printHelp $ do @@ -170,10 +170,14 @@ mainCmdParser helpDesc = do Display -> repeat Nothing Inplace -> inputPaths - config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case + configsToLoad <- liftIO $ if null configPaths + then maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath) + else pure configPaths + + config <- runMaybeT (readConfigsWithUserConfig cmdlineConfig configsToLoad) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Just x -> return x - when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do + when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ trace (showConfigYaml config) $ return () results <- zipWithM (coreIO putStrErrLn config suppressOutput) inputPaths outputPaths @@ -317,42 +321,3 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx ] then trace "----" else id - - -readConfigs :: CConfig Option -> [System.IO.FilePath] -> MaybeT IO Config -readConfigs cmdlineConfig configPaths = do - userBritPathSimple <- liftIO $ Directory.getAppUserDataDirectory "brittany" - userBritPathXdg <- liftIO - $ Directory.getXdgDirectory Directory.XdgConfig "brittany" - let userConfigPathSimple = userBritPathSimple FilePath. "config.yaml" - let userConfigPathXdg = userBritPathXdg FilePath. "config.yaml" - let - findLocalConfig :: MaybeT IO (Maybe (CConfig Option)) - findLocalConfig = do - cwd <- liftIO $ Directory.getCurrentDirectory - let dirParts = FilePath.splitDirectories cwd - let searchDirs = - [ FilePath.joinPath x | x <- reverse $ List.inits dirParts ] - -- when cwd is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] - mFilePath <- liftIO $ Directory.findFileWith Directory.doesFileExist - searchDirs - "brittany.yaml" - case mFilePath of - Nothing -> pure Nothing - Just fp -> readConfig fp - configsRead <- case configPaths of - [] -> do - localConfig <- findLocalConfig - userConfigSimple <- readConfig userConfigPathSimple - userConfigXdg <- readConfig userConfigPathXdg - let userConfig = userConfigSimple <|> userConfigXdg - when (Data.Maybe.isNothing userConfig) $ do - liftIO $ Directory.createDirectoryIfMissing True 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.hs b/src/Language/Haskell/Brittany.hs index 5f9a128..9d45dde 100644 --- a/src/Language/Haskell/Brittany.hs +++ b/src/Language/Haskell/Brittany.hs @@ -4,6 +4,10 @@ module Language.Haskell.Brittany ( parsePrintModule , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig , Config , CConfig(..) , CDebugConfig(..) diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index ad991b5..fe1b317 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -9,6 +9,10 @@ module Language.Haskell.Brittany.Internal.Config , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled , readConfig + , userConfigPath + , findLocalConfigPath + , readConfigs + , readConfigsWithUserConfig , writeDefaultConfig , showConfigYaml ) @@ -22,8 +26,10 @@ import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.LayouterBasics import qualified Data.Yaml +import Data.CZipWith import UI.Butcher.Monadic +import Data.Monoid ((<>)) import qualified System.Console.CmdArgs.Explicit as CmdArgs @@ -33,7 +39,8 @@ import Language.Haskell.Brittany.Internal.Utils import Data.Coerce ( Coercible, coerce ) - +import qualified System.Directory as Directory +import qualified System.FilePath.Posix as FilePath staticDefaultConfig :: Config staticDefaultConfig = Config @@ -189,10 +196,10 @@ configParser = do -- <*> switch (long "barb") -- <*> flag 3 5 (long "barc") -- ) --- +-- -- configParserInfo :: ParserInfo Config -- configParserInfo = ParserInfo --- { infoParser = configParser +-- { infoParser = configParser -- , infoFullDesc = True -- , infoProgDesc = return $ PP.text "a haskell code formatting utility based on ghc-exactprint" -- , infoHeader = return $ PP.text "brittany" @@ -227,6 +234,50 @@ readConfig path = do return $ Just fileConf else return $ Nothing +-- | Returns a global brittany config file +-- If there is no global config in a system, one will be created +userConfigPath :: IO System.IO.FilePath +userConfigPath = do + userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" + userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" + let searchDirs = [userBritPathSimple, userBritPathXdg] + globalConfig <- Directory.findFileWith Directory.doesFileExist searchDirs "config.yaml" + maybe (writeUserConfig userBritPathXdg) pure globalConfig + where + writeUserConfig dir = do + let createConfPath = dir FilePath. "config.yaml" + liftIO $ Directory.createDirectoryIfMissing True dir + writeDefaultConfig $ createConfPath + pure createConfPath + +-- | Searhes for a local brittany config path starting from a given directory +findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) +findLocalConfigPath dir = do + let dirParts = FilePath.splitDirectories dir + -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] + let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) + Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" + +-- | Reads specified configs. +readConfigs + :: CConfig Option -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigs cmdlineConfig configPaths = do + configs <- readConfig `mapM` configPaths + let merged = Semigroup.mconcat $ reverse (cmdlineConfig:catMaybes configs) + return $ cZipWith fromOptionIdentity staticDefaultConfig merged + +-- | Reads provided configs +-- but also applies the user default configuration (with a lowest priority) +readConfigsWithUserConfig + :: CConfig Option -- ^ Explicit options, take highest priority + -> [System.IO.FilePath] -- ^ List of config files to load and merge, highest priority first + -> MaybeT IO Config +readConfigsWithUserConfig cmdlineConfig configPaths = do + defaultPath <- liftIO $ userConfigPath + readConfigs cmdlineConfig (configPaths ++ [defaultPath]) + writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m () writeDefaultConfig path = liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap diff --git a/stack.yaml b/stack.yaml index 74e27d2..3362823 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,7 @@ -resolver: lts-10.0 +resolver: lts-10.5 packages: - . + +extra-deps: + - butcher-1.3.0.0 -- 2.30.2