diff --git a/README.md b/README.md index 42e7fa5..2f55f03 100644 --- a/README.md +++ b/README.md @@ -160,6 +160,8 @@ 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 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-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 3f7ec68..af873df 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -287,10 +287,6 @@ 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-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 5e4f52c..7654285 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -367,8 +367,9 @@ 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.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/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 400d422..9681453 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -94,8 +94,7 @@ 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 -> "" -- not [] - for NOINLINE NeverActive is - -- in fact the default + NeverActive -> "[] " AlwaysActive -> "" ActiveBefore _ i -> "[~" ++ show i ++ "] " ActiveAfter _ i -> "[" ++ show i ++ "] " diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 807aad8..8d90148 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -535,15 +535,13 @@ layoutExpr lexpr@(L _ expr) = do ifIndentLeftElse :: a -> a -> a ifIndentLeftElse x y = if indentPolicy == IndentPolicyLeft then x else y - -- 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. + -- this `docSetIndentLevel` might seem out of place, but is here due to + -- ghc-exactprint's DP handling of "let" in particular. -- Just pushing another indentation level is a straightforward approach -- to making brittany idempotent, even though the result is non-optimal -- if "let" is moved horizontally as part of the transformation, as the -- comments before the first let item are moved horizontally with it. - docSetBaseAndIndent $ case mBindDocs of + docSetIndentLevel $ case mBindDocs of Just [bindDoc] -> docAlt [ docSeq [ appSep $ docLit $ Text.pack "let" @@ -735,8 +733,6 @@ 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 @@ -856,7 +852,7 @@ layoutExpr lexpr@(L _ expr) = do Unambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) Ambiguous n _ -> (lfield, lrdrNameToText n, rFExpDoc) docAltFilter - -- container { fieldA = blub, fieldB = blub } + -- singleline [ ( True , docSeq [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline rExprDoc @@ -874,10 +870,7 @@ layoutExpr lexpr@(L _ expr) = do , docLit $ Text.pack "}" ] ) - -- hanging single-line fields - -- container { fieldA = blub - -- , fieldB = blub - -- } + -- wild-indentation block , ( indentPolicy /= IndentPolicyLeft , docSeq [ docNodeAnnKW lexpr Nothing $ appSep rExprDoc @@ -888,7 +881,7 @@ layoutExpr lexpr@(L _ expr) = do , case rF1e of Just x -> docWrapNodeRest rF1f $ docSeq [ appSep $ docLit $ Text.pack "=" - , docForceSingleline x + , docForceSingleline $ x ] Nothing -> docEmpty ] @@ -908,54 +901,36 @@ layoutExpr lexpr@(L _ expr) = do in [line1] ++ lineR ++ [lineN] ] ) - -- non-hanging with expressions placed to the right of the names - -- container - -- { fieldA = blub - -- , fieldB = potentially - -- multiline - -- } + -- strict indentation block , ( 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 -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular $ 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 -> docAlt - [ docSeq [ appSep $ docLit $ Text.pack "=" - , expressionWrapper x - ] - , docAddBaseY BrIndentRegular - $ docPar (docLit $ Text.pack "=") x - ] + Just x -> docSeq [ appSep $ docLit $ Text.pack "=" + , docAddBaseY BrIndentRegular x + ] Nothing -> docEmpty ] lineN = docSeq [ docNodeAnnKW lexpr (Just AnnOpenC) docEmpty , docLit $ Text.pack "}" ] - in [line1] ++ lineR ++ [lineN] - ) + in [line1] ++ lineR ++ [lineN]) ) ] #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ 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