module Language.Haskell.Brittany.Internal.Config ( CConfig(..) , CDebugConfig(..) , CLayoutConfig(..) , DebugConfig , LayoutConfig , Config , cmdlineConfigParser , staticDefaultConfig , forwardOptionsSyntaxExtsEnabled , readConfig , userConfigPath , findLocalConfigPath , readConfigs , readConfigsWithUserConfig , writeDefaultConfig , showConfigYaml ) where #include "prelude.inc" 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 import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types.Instances import Language.Haskell.Brittany.Internal.Utils import Data.Coerce ( Coercible , coerce ) import qualified Data.List.NonEmpty as NonEmpty import qualified System.Directory as Directory import qualified System.FilePath.Posix as FilePath -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } staticDefaultConfig :: Config staticDefaultConfig = Config { _conf_version = coerce (1 :: Int) , _conf_debug = DebugConfig { _dconf_dump_config = coerce False , _dconf_dump_annotations = coerce False , _dconf_dump_ast_unknown = coerce False , _dconf_dump_ast_full = coerce False , _dconf_dump_bridoc_raw = coerce False , _dconf_dump_bridoc_simpl_alt = coerce False , _dconf_dump_bridoc_simpl_floating = coerce False , _dconf_dump_bridoc_simpl_par = coerce False , _dconf_dump_bridoc_simpl_columns = coerce False , _dconf_dump_bridoc_simpl_indent = coerce False , _dconf_dump_bridoc_final = coerce False , _dconf_roundtrip_exactprint_only = coerce False } , _conf_layout = LayoutConfig { _lconfig_cols = coerce (80 :: Int) , _lconfig_indentPolicy = coerce IndentPolicyFree , _lconfig_indentAmount = coerce (2 :: Int) , _lconfig_indentWhereSpecial = coerce True , _lconfig_indentListSpecial = coerce True , _lconfig_importColumn = coerce (50 :: Int) , _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_hangingTypeSignature = coerce False , _lconfig_reformatModulePreamble = coerce True , _lconfig_allowSingleLineExportList = coerce False , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False -- , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False , _econf_Werror = coerce False , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_omit_output_valid_check = coerce False } , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = coerce CPPModeAbort , _ppconf_hackAroundIncludes = coerce False } , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False , _conf_disable_formatting = coerce False , _conf_obfuscate = coerce False } forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions { _options_ghc = Identity [ "-XLambdaCase" , "-XMultiWayIf" , "-XGADTs" , "-XPatternGuards" , "-XViewPatterns" , "-XTupleSections" , "-XExplicitForAll" , "-XImplicitParams" , "-XQuasiQuotes" , "-XTemplateHaskell" , "-XBangPatterns" , "-XTypeApplications" ] } -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } cmdlineConfigParser :: CmdParser Identity out (CConfig Option) cmdlineConfigParser = do -- TODO: why does the default not trigger; ind never should be []!! ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at") importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at") dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)") dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint") dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany") dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast") dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt") dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par") dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating") dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns") dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent") dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc") outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)") wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors") omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)") optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.") disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.") obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.") return $ Config { _conf_version = mempty , _conf_debug = DebugConfig { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal , _dconf_roundtrip_exactprint_only = mempty } , _conf_layout = LayoutConfig { _lconfig_cols = optionConcat cols , _lconfig_indentPolicy = mempty , _lconfig_indentAmount = optionConcat ind , _lconfig_indentWhereSpecial = mempty -- falseToNothing _ , _lconfig_indentListSpecial = mempty -- falseToNothing _ , _lconfig_importColumn = optionConcat importCol , _lconfig_importAsColumn = optionConcat importAsCol , _lconfig_altChooser = mempty , _lconfig_columnAlignMode = mempty , _lconfig_alignmentLimit = mempty , _lconfig_alignmentBreakOnMultiline = mempty , _lconfig_hangingTypeSignature = mempty , _lconfig_reformatModulePreamble = mempty , _lconfig_allowSingleLineExportList = mempty , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty -- , _lconfig_allowSinglelineRecord = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors , _econf_Werror = wrapLast $ falseToNothing wError , _econf_ExactPrintFallback = mempty , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck } , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting , _conf_obfuscate = wrapLast $ falseToNothing obfuscate } where falseToNothing = Option . Bool.bool Nothing (Just True) wrapLast :: Option a -> Option (Semigroup.Last a) wrapLast = fmap Semigroup.Last optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Option (f a) optionConcat = mconcat . fmap (pure . pure) -- configParser :: Parser Config -- configParser = Config -- <$> option (eitherReader $ maybe (Left "required !") Right . readMaybe) -- (long "indent" <> value 2 <> metavar "AMOUNT" <> help "spaces per indentation level") -- <*> (Bar -- <$> switch (long "bara" <> help "bara help") -- <*> switch (long "barb") -- <*> flag 3 5 (long "barc") -- ) -- -- configParserInfo :: ParserInfo Config -- configParserInfo = ParserInfo -- { infoParser = configParser -- , infoFullDesc = True -- , infoProgDesc = return $ PP.text "a haskell code formatting utility based on ghc-exactprint" -- , infoHeader = return $ PP.text "brittany" -- , infoFooter = empty -- , infoFailureCode = (-55) -- , infoIntersperse = True -- } -- | 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 -- TODO: probably should catch IOErrors and then omit the existence check. exists <- liftIO $ System.Directory.doesFileExist path 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 (Data.Yaml.prettyPrintParseException e) mzero Right x -> return x return $ Just fileConf else return $ Nothing -- | Looks for a user-global config file and return its path. -- 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 -- | Searches for a local (per-project) brittany config 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.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) return $ cZipWith fromOptionIdentity staticDefaultConfig merged -- | Reads provided configs -- but also applies the user default configuration (with 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 (Option . Just . runIdentity) staticDefaultConfig showConfigYaml :: Config -> String showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap (\(Identity x) -> Just x)