diff --git a/brittany.cabal b/brittany.cabal index e2a954d..889f2b6 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -79,6 +79,9 @@ 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 } default-extensions: { CPP @@ -135,6 +138,7 @@ executable brittany , monad-memo , safe , filepath >=1.4.1.0 && <1.5 + , either } hs-source-dirs: src-brittany default-language: Haskell2010 @@ -200,6 +204,7 @@ test-suite unittests , strict , monad-memo , safe + , either } ghc-options: -Wall main-is: TestMain.hs diff --git a/src-brittany/Main.hs b/src-brittany/Main.hs index f843166..669c154 100644 --- a/src-brittany/Main.hs +++ b/src-brittany/Main.hs @@ -16,11 +16,11 @@ import qualified Data.Text.Lazy.Builder as Text.Builder import qualified Debug.Trace as Trace -import Language.Haskell.Brittany.Types -import Language.Haskell.Brittany -import Language.Haskell.Brittany.Config -import Language.Haskell.Brittany.Config.Types -import Language.Haskell.Brittany.Utils +import Language.Haskell.Brittany.Types +import Language.Haskell.Brittany +import Language.Haskell.Brittany.Config +import Language.Haskell.Brittany.Config.Types +import Language.Haskell.Brittany.Utils import qualified Text.PrettyPrint as PP @@ -98,20 +98,24 @@ mainCmdParser = do config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 50) Just x -> return x - when (runIdentity $ _dconf_dump_config $ _conf_debug $ config) $ do + when (confUnpack $ _dconf_dump_config $ _conf_debug $ config) $ do trace (showTree config) $ return () + let ghcOptions = config + & _conf_forward + & _options_ghc + & runIdentity liftIO $ do parseResult <- case inputPathM of - Nothing -> ExactPrint.Parsers.parseModuleFromString "stdin" + Nothing -> parseModuleFromString ghcOptions "stdin" =<< System.IO.hGetContents System.IO.stdin - Just p -> ExactPrint.parseModule p + Just p -> parseModule ghcOptions p case parseResult of Left left -> do putStrErrLn "parse error:" printErr left System.Exit.exitWith (System.Exit.ExitFailure 60) Right (anns, parsedSource) -> do - when (config & _conf_debug .> _dconf_dump_ast_full .> runIdentity) $ do + when (config & _conf_debug .> _dconf_dump_ast_full .> confUnpack) $ do let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource trace ("---- ast ----\n" ++ show val) $ return () -- mapM_ printErr (Map.toList anns) @@ -135,7 +139,7 @@ mainCmdParser = do uns `forM_` \case LayoutErrorUnknownNode str ast -> do putStrErrLn str - when (config & _conf_debug & _dconf_dump_ast_unknown & runIdentity) $ do + when (config & _conf_debug & _dconf_dump_ast_unknown & confUnpack) $ do putStrErrLn $ " " ++ show (astToDoc ast) _ -> error "cannot happen (TM)" warns@(LayoutWarning{}:_) -> do @@ -157,13 +161,13 @@ mainCmdParser = do let hasErrors = case config & _conf_errorHandling & _econf_Werror - & runIdentity of + & confUnpack of False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) True -> not $ null errsWarns outputOnErrs = config & _conf_errorHandling & _econf_produceOutputOnErrors - & runIdentity + & confUnpack let shouldOutput = not suppressOutput && (not hasErrors || outputOnErrs) @@ -175,15 +179,15 @@ mainCmdParser = do System.Exit.exitWith (System.Exit.ExitFailure 70) where addTraceSep conf = if foldr1 (||) - [ runIdentity $ _dconf_dump_annotations conf - , runIdentity $ _dconf_dump_ast_unknown conf - , runIdentity $ _dconf_dump_ast_full conf - , runIdentity $ _dconf_dump_bridoc_raw conf - , runIdentity $ _dconf_dump_bridoc_simpl_alt conf - , runIdentity $ _dconf_dump_bridoc_simpl_floating conf - , runIdentity $ _dconf_dump_bridoc_simpl_columns conf - , runIdentity $ _dconf_dump_bridoc_simpl_indent conf - , runIdentity $ _dconf_dump_bridoc_final conf + [ confUnpack $ _dconf_dump_annotations conf + , confUnpack $ _dconf_dump_ast_unknown conf + , confUnpack $ _dconf_dump_ast_full conf + , confUnpack $ _dconf_dump_bridoc_raw conf + , confUnpack $ _dconf_dump_bridoc_simpl_alt conf + , confUnpack $ _dconf_dump_bridoc_simpl_floating conf + , confUnpack $ _dconf_dump_bridoc_simpl_columns conf + , confUnpack $ _dconf_dump_bridoc_simpl_indent conf + , confUnpack $ _dconf_dump_bridoc_final conf ] then trace "----" else id diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index 1228c43..31a5383 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -16,6 +16,8 @@ import Language.Haskell.Brittany.Config.Types import System.Timeout ( timeout ) +import Data.Coerce ( coerce ) + roundTripEqual :: Text -> Expectation @@ -39,13 +41,16 @@ defaultTestConfig :: Config defaultTestConfig = Config { _conf_debug = _conf_debug staticDefaultConfig , _conf_layout = LayoutConfig - { _lconfig_cols = Identity 80 - , _lconfig_indentPolicy = Identity IndentPolicyFree - , _lconfig_indentAmount = Identity 2 - , _lconfig_indentWhereSpecial = Identity True - , _lconfig_indentListSpecial = Identity True - , _lconfig_importColumn = Identity 60 - , _lconfig_altChooser = Identity $ AltChooserBoundedSearch 3 + { _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 (60 :: Int) + , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3 } , _conf_errorHandling = _conf_errorHandling staticDefaultConfig + , _conf_forward = ForwardOptions + { _options_ghc = Identity [] + } } diff --git a/src/Language/Haskell/Brittany/BriLayouter.hs b/src/Language/Haskell/Brittany/BriLayouter.hs index af7e57d..7508ceb 100644 --- a/src/Language/Haskell/Brittany/BriLayouter.hs +++ b/src/Language/Haskell/Brittany/BriLayouter.hs @@ -237,7 +237,7 @@ transformAlts briDoc BDFSeparator -> processSpacingSimple bdX $> bdX BDFAddBaseY indent bd -> do acp <- mGet - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack let indAdd = case indent of BrIndentNone -> 0 BrIndentRegular -> indAmount @@ -266,7 +266,7 @@ transformAlts briDoc BDFIndentLevelPop bd -> do reWrap . BDFIndentLevelPop <$> rec bd BDFPar indent sameLine indented -> do - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack let indAdd = case indent of BrIndentNone -> 0 BrIndentRegular -> indAmount @@ -289,7 +289,7 @@ transformAlts briDoc -- fail-early approach; BDEmpty does not -- make sense semantically for Alt[]. BDFAlt alts -> do - altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> runIdentity + altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack case altChooser of AltChooserSimpleQuick -> do rec $ head alts @@ -407,7 +407,7 @@ transformAlts briDoc return $ reWrap $ BDFLines (l':lr') BDFEnsureIndent indent bd -> do acp <- mGet - indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack let indAdd = case indent of BrIndentNone -> 0 BrIndentRegular -> indAmount @@ -449,12 +449,12 @@ transformAlts briDoc hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) - = line + sameLine <= runIdentity (_lconfig_cols lconf) + = line + sameLine <= confUnpack (_lconfig_cols lconf) hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) - = line + sameLine <= runIdentity (_lconfig_cols lconf) - && indent + indentPrep + par <= runIdentity (_lconfig_cols lconf) + = line + sameLine <= confUnpack (_lconfig_cols lconf) + && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf) hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNonBottom _) - = line + sameLine <= runIdentity (_lconfig_cols lconf) + = line + sameLine <= confUnpack (_lconfig_cols lconf) getSpacing :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m (LineModeValidity VerticalSpacing) getSpacing !bridoc = rec bridoc @@ -481,7 +481,7 @@ getSpacing !bridoc = rec bridoc VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of BrIndentNone -> i - BrIndentRegular -> i + ( runIdentity + BrIndentRegular -> i + ( confUnpack $ _lconfig_indentAmount $ _conf_layout $ config @@ -550,7 +550,7 @@ getSpacing !bridoc = rec bridoc mVs <- rec bd let addInd = case indent of BrIndentNone -> 0 - BrIndentRegular -> runIdentity + BrIndentRegular -> confUnpack $ _lconfig_indentAmount $ _conf_layout $ config @@ -626,7 +626,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] rec (brDcId, brdc) = memoWithKey brDcId $ do config <- mAsk - let colMax = config & _conf_layout & _lconfig_cols & runIdentity + let colMax = config & _conf_layout & _lconfig_cols & confUnpack let hasOkColCount (VerticalSpacing lsp psp _) = lsp <= colMax && case psp of VerticalSpacingParNone -> True @@ -661,7 +661,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of BrIndentNone -> i - BrIndentRegular -> i + ( runIdentity + BrIndentRegular -> i + ( confUnpack $ _lconfig_indentAmount $ _conf_layout $ config @@ -758,7 +758,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc mVs <- rec bd let addInd = case indent of BrIndentNone -> 0 - BrIndentRegular -> runIdentity + BrIndentRegular -> confUnpack $ _lconfig_indentAmount $ _conf_layout $ config @@ -1396,7 +1396,7 @@ layoutBriDocM = \case alignColsLines :: [BriDoc] -> m () alignColsLines l = do -- colInfos `forM_` \colInfo -> do - colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> runIdentity + colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock $ colInfos <&> processInfo colMax (_cbs_map finalState) where (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0) diff --git a/src/Language/Haskell/Brittany/Config.hs b/src/Language/Haskell/Brittany/Config.hs index 2f16373..819482b 100644 --- a/src/Language/Haskell/Brittany/Config.hs +++ b/src/Language/Haskell/Brittany/Config.hs @@ -60,9 +60,13 @@ import qualified Data.Yaml import UI.Butcher.Monadic +import qualified System.Console.CmdArgs.Explicit as CmdArgs + import Language.Haskell.Brittany.Config.Types import Language.Haskell.Brittany.Utils +import Data.Coerce ( Coercible, coerce ) + configParser :: CmdParser Identity out (ConfigF Maybe) @@ -89,20 +93,22 @@ configParser = do 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") + + optionsGhc <- addFlagStringParam "" ["ghc-options"] "STRING" mempty return $ Config { _conf_debug = DebugConfig - { _dconf_dump_config = falseToNothing dumpConfig - , _dconf_dump_annotations = falseToNothing dumpAnnotations - , _dconf_dump_ast_unknown = falseToNothing dumpUnknownAST - , _dconf_dump_ast_full = falseToNothing dumpCompleteAST - , _dconf_dump_bridoc_raw = falseToNothing dumpBriDocRaw - , _dconf_dump_bridoc_simpl_alt = falseToNothing dumpBriDocAlt - , _dconf_dump_bridoc_simpl_par = falseToNothing dumpBriDocPar - , _dconf_dump_bridoc_simpl_floating = falseToNothing dumpBriDocFloating - , _dconf_dump_bridoc_simpl_columns = falseToNothing dumpBriDocColumns - , _dconf_dump_bridoc_simpl_indent = falseToNothing dumpBriDocIndent - , _dconf_dump_bridoc_final = falseToNothing dumpBriDocFinal + { _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 } , _conf_layout = LayoutConfig { _lconfig_cols = listLastMaybe cols @@ -114,11 +120,17 @@ configParser = do , _lconfig_altChooser = Nothing } , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = falseToNothing outputOnErrors - , _econf_Werror = falseToNothing wError + { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors + , _econf_Werror = wrapLast $ falseToNothing wError + } + , _conf_forward = ForwardOptions + { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs + | not $ null optionsGhc + ] } } where falseToNothing = Bool.bool Nothing (Just True) + wrapLast = fmap Semigroup.Last listLastMaybe = listToMaybe . reverse -- configParser :: Parser Config @@ -157,7 +169,7 @@ readMergePersConfig path shouldCreate conf = do liftIO $ putStrLn e mzero Right x -> return x - return $ (cZip (<|>) conf fileConf) + return $ fileConf Semigroup.<> conf | shouldCreate -> do liftIO $ ByteString.writeFile path $ Data.Yaml.encode diff --git a/src/Language/Haskell/Brittany/Config/Types.hs b/src/Language/Haskell/Brittany/Config/Types.hs index 2323a3b..62dcd75 100644 --- a/src/Language/Haskell/Brittany/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Config/Types.hs @@ -17,39 +17,53 @@ import Control.Lens import Data.Data ( Data ) +import Data.Coerce ( Coercible, coerce ) +import Data.Semigroup.Generic + +import Data.Semigroup ( Last ) + + + +confUnpack :: Coercible a b => Identity a -> b +confUnpack (Identity x) = coerce x data DebugConfigF f = DebugConfig - { _dconf_dump_config :: f Bool - , _dconf_dump_annotations :: f Bool - , _dconf_dump_ast_unknown :: f Bool - , _dconf_dump_ast_full :: f Bool - , _dconf_dump_bridoc_raw :: f Bool - , _dconf_dump_bridoc_simpl_alt :: f Bool - , _dconf_dump_bridoc_simpl_floating :: f Bool - , _dconf_dump_bridoc_simpl_par :: f Bool - , _dconf_dump_bridoc_simpl_columns :: f Bool - , _dconf_dump_bridoc_simpl_indent :: f Bool - , _dconf_dump_bridoc_final :: f Bool + { _dconf_dump_config :: f (Semigroup.Last Bool) + , _dconf_dump_annotations :: f (Semigroup.Last Bool) + , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) + , _dconf_dump_ast_full :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool) + , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) } deriving (Generic) data LayoutConfigF f = LayoutConfig - { _lconfig_cols :: f Int -- the thing that has default 80. - , _lconfig_indentPolicy :: f IndentPolicy - , _lconfig_indentAmount :: f Int - , _lconfig_indentWhereSpecial :: f Bool -- indent where only 1 sometimes (TODO). - , _lconfig_indentListSpecial :: f Bool -- use some special indentation for "," - -- when creating zero-indentation - -- multi-line list literals. - , _lconfig_importColumn :: f Int - , _lconfig_altChooser :: f AltChooser + { _lconfig_cols :: f (Last Int) -- the thing that has default 80. + , _lconfig_indentPolicy :: f (Last IndentPolicy) + , _lconfig_indentAmount :: f (Last Int) + , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). + , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for "," + -- when creating zero-indentation + -- multi-line list literals. + , _lconfig_importColumn :: f (Last Int) + , _lconfig_altChooser :: f (Last AltChooser) + } + deriving (Generic) + +data ForwardOptionsF f = ForwardOptions + { _options_ghc :: f [String] } deriving (Generic) data ErrorHandlingConfigF f = ErrorHandlingConfig - { _econf_produceOutputOnErrors :: f Bool - , _econf_Werror :: f Bool + { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) + , _econf_Werror :: f (Semigroup.Last Bool) } deriving (Generic) @@ -57,6 +71,7 @@ data ConfigF f = Config { _conf_debug :: DebugConfigF f , _conf_layout :: LayoutConfigF f , _conf_errorHandling :: ErrorHandlingConfigF f + , _conf_forward :: ForwardOptionsF f } deriving (Generic) @@ -64,23 +79,40 @@ data ConfigF f = Config deriving instance Show (DebugConfigF Identity) deriving instance Show (LayoutConfigF Identity) deriving instance Show (ErrorHandlingConfigF Identity) +deriving instance Show (ForwardOptionsF Identity) deriving instance Show (ConfigF Identity) deriving instance Show (DebugConfigF Maybe) deriving instance Show (LayoutConfigF Maybe) deriving instance Show (ErrorHandlingConfigF Maybe) +deriving instance Show (ForwardOptionsF Maybe) deriving instance Show (ConfigF Maybe) deriving instance Data (DebugConfigF Identity) deriving instance Data (LayoutConfigF Identity) deriving instance Data (ErrorHandlingConfigF Identity) +deriving instance Data (ForwardOptionsF Identity) deriving instance Data (ConfigF Identity) +instance Semigroup.Semigroup (DebugConfigF Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (LayoutConfigF Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (ErrorHandlingConfigF Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (ForwardOptionsF Maybe) where + (<>) = gmappend +instance Semigroup.Semigroup (ConfigF Maybe) where + (<>) = gmappend + type Config = ConfigF Identity type DebugConfig = DebugConfigF Identity type LayoutConfig = LayoutConfigF Identity type ErrorHandlingConfig = ErrorHandlingConfigF Identity +instance FromJSON a => FromJSON (Semigroup.Last a) where +instance ToJSON a => ToJSON (Semigroup.Last a) where + instance FromJSON (DebugConfigF Maybe) instance ToJSON (DebugConfigF Maybe) @@ -95,6 +127,9 @@ instance ToJSON (LayoutConfigF Maybe) instance FromJSON (ErrorHandlingConfigF Maybe) instance ToJSON (ErrorHandlingConfigF Maybe) +instance FromJSON (ForwardOptionsF Maybe) +instance ToJSON (ForwardOptionsF Maybe) + instance FromJSON (ConfigF Maybe) instance ToJSON (ConfigF Maybe) @@ -146,30 +181,33 @@ data AltChooser = AltChooserSimpleQuick -- always choose last alternative. staticDefaultConfig :: Config staticDefaultConfig = Config { _conf_debug = DebugConfig - { _dconf_dump_config = Identity False - , _dconf_dump_annotations = Identity False - , _dconf_dump_ast_unknown = Identity False - , _dconf_dump_ast_full = Identity False - , _dconf_dump_bridoc_raw = Identity False - , _dconf_dump_bridoc_simpl_alt = Identity False - , _dconf_dump_bridoc_simpl_floating = Identity False - , _dconf_dump_bridoc_simpl_par = Identity False - , _dconf_dump_bridoc_simpl_columns = Identity False - , _dconf_dump_bridoc_simpl_indent = Identity False - , _dconf_dump_bridoc_final = Identity False + { _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 } , _conf_layout = LayoutConfig - { _lconfig_cols = Identity 80 - , _lconfig_indentPolicy = Identity IndentPolicyFree - , _lconfig_indentAmount = Identity 2 - , _lconfig_indentWhereSpecial = Identity True - , _lconfig_indentListSpecial = Identity True - , _lconfig_importColumn = Identity 60 - , _lconfig_altChooser = Identity $ AltChooserBoundedSearch 3 + { _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 (60 :: Int) + , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) } , _conf_errorHandling = ErrorHandlingConfig - { _econf_produceOutputOnErrors = Identity False - , _econf_Werror = Identity False + { _econf_produceOutputOnErrors = coerce False + , _econf_Werror = coerce False + } + , _conf_forward = ForwardOptions + { _options_ghc = Identity [] } } @@ -211,11 +249,17 @@ instance CZip ErrorHandlingConfigF where (f x1 y1) (f x2 y2) +instance CZip ForwardOptionsF where + cZip f (ForwardOptions x1) + (ForwardOptions y1) = ForwardOptions + (f x1 y1) + instance CZip ConfigF where - cZip f (Config x1 x2 x3) (Config y1 y2 y3) = Config + cZip f (Config x1 x2 x3 x4) (Config y1 y2 y3 y4) = Config (cZip f x1 y1) (cZip f x2 y2) (cZip f x3 y3) + (cZip f x4 y4) cMap :: CZip k => (forall a . f a -> g a) -> k f -> k g cMap f c = cZip (\_ -> f) c c diff --git a/src/Language/Haskell/Brittany/LayoutBasics.hs b/src/Language/Haskell/Brittany/LayoutBasics.hs index d7d2cca..d170580 100644 --- a/src/Language/Haskell/Brittany/LayoutBasics.hs +++ b/src/Language/Haskell/Brittany/LayoutBasics.hs @@ -208,7 +208,7 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do else x askIndent :: (MonadMultiReader Config m) => m Int -askIndent = runIdentity . _lconfig_indentAmount . _conf_layout <$> mAsk +askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk layoutWriteAppend :: (MonadMultiWriter Text.Builder.Builder m, @@ -475,7 +475,7 @@ layoutWithAddBaseCol m = do #if INSERTTRACES tellDebugMessShow ("layoutWithAddBaseCol") #endif - amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack state <- mGet layoutBaseYPushInternal $ lstate_baseY state + amount m @@ -493,7 +493,7 @@ layoutWithAddBaseColBlock m = do #if INSERTTRACES tellDebugMessShow ("layoutWithAddBaseColBlock") #endif - amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity + amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack state <- mGet layoutBaseYPushInternal $ lstate_baseY state + amount layoutWriteEnsureBlock diff --git a/src/Language/Haskell/Brittany/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Layouters/Decl.hs index 4b13219..da87b9a 100644 --- a/src/Language/Haskell/Brittany/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Layouters/Decl.hs @@ -154,7 +154,7 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do whereIndent <- mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial - .> runIdentity + .> confUnpack .> Bool.bool BrIndentRegular (BrIndentSpecial 1) -- TODO: apart from this, there probably are more nodes below which could -- be shared between alternatives. diff --git a/src/Language/Haskell/Brittany/Utils.hs b/src/Language/Haskell/Brittany/Utils.hs index 2981444..574518c 100644 --- a/src/Language/Haskell/Brittany/Utils.hs +++ b/src/Language/Haskell/Brittany/Utils.hs @@ -201,11 +201,11 @@ traceIfDumpConf :: (MonadMultiReader Config m, Show a) => String - -> (DebugConfig -> Identity Bool) + -> (DebugConfig -> Identity (Semigroup.Last Bool)) -> a -> m () traceIfDumpConf s accessor val = do - whenM (mAsk <&> _conf_debug .> accessor .> runIdentity) $ do + whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () tellDebugMess :: MonadMultiWriter diff --git a/srcinc/prelude.inc b/srcinc/prelude.inc index 125aa4b..61910b1 100644 --- a/srcinc/prelude.inc +++ b/srcinc/prelude.inc @@ -388,6 +388,8 @@ import qualified Data.Bool as Bool import qualified GHC.OldList as List -- import qualified Text.Printf as Printf +import qualified Data.Semigroup as Semigroup + import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as ByteStringL @@ -425,6 +427,7 @@ import qualified Control.Monad.Trans.State.Strict as StateS -- import qualified Control.Monad.Trans.Writer as Writer -- import qualified Control.Monad.Trans.Writer.Lazy as WriterL -- import qualified Control.Monad.Trans.Writer.Strict as Writer +import qualified Control.Monad.Trans.Either as EitherT import qualified Data.Strict.Maybe as Strict @@ -442,7 +445,7 @@ import Data.Char ( Char ) import Data.Either ( Either(..) ) import Data.IORef ( IORef ) import Data.Maybe ( Maybe(..) ) -import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), ) +import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), Alt(..), ) import Data.Ord ( Ordering(..), Down(..) ) import Data.Ratio ( Ratio, Rational ) import Data.String ( String )