hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Support --ghc-options; Rework config internals

pull/3/head
Lennart Spitzner 2016-08-08 17:35:07 +02:00
parent d625c90461
commit 1a70e4d949
10 changed files with 179 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
brittany.cabal
View File

@ -79,6 +79,9 @@ library {
, unsafe >=0.0 && <0.1 , unsafe >=0.0 && <0.1
, safe >=0.3.9 && <0.4 , safe >=0.3.9 && <0.4
, deepseq >=1.4.2.0 && <1.5 , 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: { default-extensions: {
CPP CPP
@ -135,6 +138,7 @@ executable brittany
, monad-memo , monad-memo
, safe , safe
, filepath >=1.4.1.0 && <1.5 , filepath >=1.4.1.0 && <1.5
, either
} }
hs-source-dirs: src-brittany hs-source-dirs: src-brittany
default-language: Haskell2010 default-language: Haskell2010
@ -200,6 +204,7 @@ test-suite unittests
, strict , strict
, monad-memo , monad-memo
, safe , safe
, either
} }
ghc-options: -Wall ghc-options: -Wall
main-is: TestMain.hs main-is: TestMain.hs

36
src-brittany/Main.hs
View File

@ -98,20 +98,24 @@ mainCmdParser = do
config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case config <- runMaybeT (readConfigs cmdlineConfig configPaths) >>= \case
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 50) Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 50)
Just x -> return x 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 () trace (showTree config) $ return ()
let ghcOptions = config
& _conf_forward
& _options_ghc
& runIdentity
liftIO $ do liftIO $ do
parseResult <- case inputPathM of parseResult <- case inputPathM of
Nothing -> ExactPrint.Parsers.parseModuleFromString "stdin" Nothing -> parseModuleFromString ghcOptions "stdin"
=<< System.IO.hGetContents System.IO.stdin =<< System.IO.hGetContents System.IO.stdin
Just p -> ExactPrint.parseModule p Just p -> parseModule ghcOptions p
case parseResult of case parseResult of
Left left -> do Left left -> do
putStrErrLn "parse error:" putStrErrLn "parse error:"
printErr left printErr left
System.Exit.exitWith (System.Exit.ExitFailure 60) System.Exit.exitWith (System.Exit.ExitFailure 60)
Right (anns, parsedSource) -> do 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 let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return () trace ("---- ast ----\n" ++ show val) $ return ()
-- mapM_ printErr (Map.toList anns) -- mapM_ printErr (Map.toList anns)
@ -135,7 +139,7 @@ mainCmdParser = do
uns `forM_` \case uns `forM_` \case
LayoutErrorUnknownNode str ast -> do LayoutErrorUnknownNode str ast -> do
putStrErrLn str 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) putStrErrLn $ " " ++ show (astToDoc ast)
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
warns@(LayoutWarning{}:_) -> do warns@(LayoutWarning{}:_) -> do
@ -157,13 +161,13 @@ mainCmdParser = do
let hasErrors = case config let hasErrors = case config
& _conf_errorHandling & _conf_errorHandling
& _econf_Werror & _econf_Werror
& runIdentity of & confUnpack of
False -> 0 < maximum (-1 : fmap customErrOrder errsWarns) False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
True -> not $ null errsWarns True -> not $ null errsWarns
outputOnErrs = config outputOnErrs = config
& _conf_errorHandling & _conf_errorHandling
& _econf_produceOutputOnErrors & _econf_produceOutputOnErrors
& runIdentity & confUnpack
let shouldOutput = not suppressOutput let shouldOutput = not suppressOutput
&& (not hasErrors || outputOnErrs) && (not hasErrors || outputOnErrs)
@ -175,15 +179,15 @@ mainCmdParser = do
System.Exit.exitWith (System.Exit.ExitFailure 70) System.Exit.exitWith (System.Exit.ExitFailure 70)
where where
addTraceSep conf = if foldr1 (||) addTraceSep conf = if foldr1 (||)
[ runIdentity $ _dconf_dump_annotations conf [ confUnpack $ _dconf_dump_annotations conf
, runIdentity $ _dconf_dump_ast_unknown conf , confUnpack $ _dconf_dump_ast_unknown conf
, runIdentity $ _dconf_dump_ast_full conf , confUnpack $ _dconf_dump_ast_full conf
, runIdentity $ _dconf_dump_bridoc_raw conf , confUnpack $ _dconf_dump_bridoc_raw conf
, runIdentity $ _dconf_dump_bridoc_simpl_alt conf , confUnpack $ _dconf_dump_bridoc_simpl_alt conf
, runIdentity $ _dconf_dump_bridoc_simpl_floating conf , confUnpack $ _dconf_dump_bridoc_simpl_floating conf
, runIdentity $ _dconf_dump_bridoc_simpl_columns conf , confUnpack $ _dconf_dump_bridoc_simpl_columns conf
, runIdentity $ _dconf_dump_bridoc_simpl_indent conf , confUnpack $ _dconf_dump_bridoc_simpl_indent conf
, runIdentity $ _dconf_dump_bridoc_final conf , confUnpack $ _dconf_dump_bridoc_final conf
] ]
then trace "----" then trace "----"
else id else id

19
src-unittests/TestUtils.hs
View File

@ -16,6 +16,8 @@ import Language.Haskell.Brittany.Config.Types
import System.Timeout ( timeout ) import System.Timeout ( timeout )
import Data.Coerce ( coerce )
roundTripEqual :: Text -> Expectation roundTripEqual :: Text -> Expectation
@ -39,13 +41,16 @@ defaultTestConfig :: Config
defaultTestConfig = Config defaultTestConfig = Config
{ _conf_debug = _conf_debug staticDefaultConfig { _conf_debug = _conf_debug staticDefaultConfig
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = Identity 80 { _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = Identity IndentPolicyFree , _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = Identity 2 , _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = Identity True , _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = Identity True , _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = Identity 60 , _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = Identity $ AltChooserBoundedSearch 3 , _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
} }
, _conf_errorHandling = _conf_errorHandling staticDefaultConfig , _conf_errorHandling = _conf_errorHandling staticDefaultConfig
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
}
} }

28
src/Language/Haskell/Brittany/BriLayouter.hs
View File

@ -237,7 +237,7 @@ transformAlts briDoc
BDFSeparator -> processSpacingSimple bdX $> bdX BDFSeparator -> processSpacingSimple bdX $> bdX
BDFAddBaseY indent bd -> do BDFAddBaseY indent bd -> do
acp <- mGet acp <- mGet
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let indAdd = case indent of let indAdd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> indAmount BrIndentRegular -> indAmount
@ -266,7 +266,7 @@ transformAlts briDoc
BDFIndentLevelPop bd -> do BDFIndentLevelPop bd -> do
reWrap . BDFIndentLevelPop <$> rec bd reWrap . BDFIndentLevelPop <$> rec bd
BDFPar indent sameLine indented -> do BDFPar indent sameLine indented -> do
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let indAdd = case indent of let indAdd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> indAmount BrIndentRegular -> indAmount
@ -289,7 +289,7 @@ transformAlts briDoc
-- fail-early approach; BDEmpty does not -- fail-early approach; BDEmpty does not
-- make sense semantically for Alt[]. -- make sense semantically for Alt[].
BDFAlt alts -> do BDFAlt alts -> do
altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> runIdentity altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack
case altChooser of case altChooser of
AltChooserSimpleQuick -> do AltChooserSimpleQuick -> do
rec $ head alts rec $ head alts
@ -407,7 +407,7 @@ transformAlts briDoc
return $ reWrap $ BDFLines (l':lr') return $ reWrap $ BDFLines (l':lr')
BDFEnsureIndent indent bd -> do BDFEnsureIndent indent bd -> do
acp <- mGet acp <- mGet
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let indAdd = case indent of let indAdd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> indAmount BrIndentRegular -> indAmount
@ -449,12 +449,12 @@ transformAlts briDoc
hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient"
hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) 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) _) hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _)
= line + sameLine <= runIdentity (_lconfig_cols lconf) = line + sameLine <= confUnpack (_lconfig_cols lconf)
&& indent + indentPrep + par <= runIdentity (_lconfig_cols lconf) && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf)
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNonBottom _) 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 :: forall m . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m (LineModeValidity VerticalSpacing)
getSpacing !bridoc = rec bridoc getSpacing !bridoc = rec bridoc
@ -481,7 +481,7 @@ getSpacing !bridoc = rec bridoc
VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> i + ( runIdentity BrIndentRegular -> i + ( confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
@ -550,7 +550,7 @@ getSpacing !bridoc = rec bridoc
mVs <- rec bd mVs <- rec bd
let addInd = case indent of let addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> runIdentity BrIndentRegular -> confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
@ -626,7 +626,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing] rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
rec (brDcId, brdc) = memoWithKey brDcId $ do rec (brDcId, brdc) = memoWithKey brDcId $ do
config <- mAsk config <- mAsk
let colMax = config & _conf_layout & _lconfig_cols & runIdentity let colMax = config & _conf_layout & _lconfig_cols & confUnpack
let hasOkColCount (VerticalSpacing lsp psp _) = let hasOkColCount (VerticalSpacing lsp psp _) =
lsp <= colMax && case psp of lsp <= colMax && case psp of
VerticalSpacingParNone -> True VerticalSpacingParNone -> True
@ -661,7 +661,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom VerticalSpacingParNonBottom -> VerticalSpacingParNonBottom
VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> i + ( runIdentity BrIndentRegular -> i + ( confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
@ -758,7 +758,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
mVs <- rec bd mVs <- rec bd
let addInd = case indent of let addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> runIdentity BrIndentRegular -> confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
@ -1396,7 +1396,7 @@ layoutBriDocM = \case
alignColsLines :: [BriDoc] alignColsLines :: [BriDoc]
-> m () -> m ()
alignColsLines l = do -- colInfos `forM_` \colInfo -> do 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) sequence_ $ List.intersperse layoutWriteEnsureNewlineBlock $ colInfos <&> processInfo colMax (_cbs_map finalState)
where where
(colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0) (colInfos, finalState) = StateS.runState (mergeBriDocs l) (ColBuildState IntMapS.empty 0)

40
src/Language/Haskell/Brittany/Config.hs
View File

@ -60,9 +60,13 @@ import qualified Data.Yaml
import UI.Butcher.Monadic import UI.Butcher.Monadic
import qualified System.Console.CmdArgs.Explicit as CmdArgs
import Language.Haskell.Brittany.Config.Types import Language.Haskell.Brittany.Config.Types
import Language.Haskell.Brittany.Utils import Language.Haskell.Brittany.Utils
import Data.Coerce ( Coercible, coerce )
configParser :: CmdParser Identity out (ConfigF Maybe) configParser :: CmdParser Identity out (ConfigF Maybe)
@ -90,19 +94,21 @@ configParser = do
outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible") 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") wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
optionsGhc <- addFlagStringParam "" ["ghc-options"] "STRING" mempty
return $ Config return $ Config
{ _conf_debug = DebugConfig { _conf_debug = DebugConfig
{ _dconf_dump_config = falseToNothing dumpConfig { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
, _dconf_dump_annotations = falseToNothing dumpAnnotations , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
, _dconf_dump_ast_unknown = falseToNothing dumpUnknownAST , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
, _dconf_dump_ast_full = falseToNothing dumpCompleteAST , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
, _dconf_dump_bridoc_raw = falseToNothing dumpBriDocRaw , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw
, _dconf_dump_bridoc_simpl_alt = falseToNothing dumpBriDocAlt , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt
, _dconf_dump_bridoc_simpl_par = falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar
, _dconf_dump_bridoc_simpl_floating = falseToNothing dumpBriDocFloating , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating
, _dconf_dump_bridoc_simpl_columns = falseToNothing dumpBriDocColumns , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns
, _dconf_dump_bridoc_simpl_indent = falseToNothing dumpBriDocIndent , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent
, _dconf_dump_bridoc_final = falseToNothing dumpBriDocFinal , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal
} }
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = listLastMaybe cols { _lconfig_cols = listLastMaybe cols
@ -114,11 +120,17 @@ configParser = do
, _lconfig_altChooser = Nothing , _lconfig_altChooser = Nothing
} }
, _conf_errorHandling = ErrorHandlingConfig , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = falseToNothing outputOnErrors { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
, _econf_Werror = falseToNothing wError , _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) where falseToNothing = Bool.bool Nothing (Just True)
wrapLast = fmap Semigroup.Last
listLastMaybe = listToMaybe . reverse listLastMaybe = listToMaybe . reverse
-- configParser :: Parser Config -- configParser :: Parser Config
@ -157,7 +169,7 @@ readMergePersConfig path shouldCreate conf = do
liftIO $ putStrLn e liftIO $ putStrLn e
mzero mzero
Right x -> return x Right x -> return x
return $ (cZip (<|>) conf fileConf) return $ fileConf Semigroup.<> conf
| shouldCreate -> do | shouldCreate -> do
liftIO $ ByteString.writeFile path liftIO $ ByteString.writeFile path
$ Data.Yaml.encode $ Data.Yaml.encode

126
src/Language/Haskell/Brittany/Config/Types.hs
View File

@ -17,39 +17,53 @@ import Control.Lens
import Data.Data ( Data ) 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 data DebugConfigF f = DebugConfig
{ _dconf_dump_config :: f Bool { _dconf_dump_config :: f (Semigroup.Last Bool)
, _dconf_dump_annotations :: f Bool , _dconf_dump_annotations :: f (Semigroup.Last Bool)
, _dconf_dump_ast_unknown :: f Bool , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool)
, _dconf_dump_ast_full :: f Bool , _dconf_dump_ast_full :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_raw :: f Bool , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_alt :: f Bool , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_floating :: f Bool , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_par :: f Bool , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_columns :: f Bool , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_indent :: f Bool , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_final :: f Bool , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving (Generic)
data LayoutConfigF f = LayoutConfig data LayoutConfigF f = LayoutConfig
{ _lconfig_cols :: f Int -- the thing that has default 80. { _lconfig_cols :: f (Last Int) -- the thing that has default 80.
, _lconfig_indentPolicy :: f IndentPolicy , _lconfig_indentPolicy :: f (Last IndentPolicy)
, _lconfig_indentAmount :: f Int , _lconfig_indentAmount :: f (Last Int)
, _lconfig_indentWhereSpecial :: f Bool -- indent where only 1 sometimes (TODO). , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO).
, _lconfig_indentListSpecial :: f Bool -- use some special indentation for "," , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for ","
-- when creating zero-indentation -- when creating zero-indentation
-- multi-line list literals. -- multi-line list literals.
, _lconfig_importColumn :: f Int , _lconfig_importColumn :: f (Last Int)
, _lconfig_altChooser :: f AltChooser , _lconfig_altChooser :: f (Last AltChooser)
}
deriving (Generic)
data ForwardOptionsF f = ForwardOptions
{ _options_ghc :: f [String]
} }
deriving (Generic) deriving (Generic)
data ErrorHandlingConfigF f = ErrorHandlingConfig data ErrorHandlingConfigF f = ErrorHandlingConfig
{ _econf_produceOutputOnErrors :: f Bool { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
, _econf_Werror :: f Bool , _econf_Werror :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving (Generic)
@ -57,6 +71,7 @@ data ConfigF f = Config
{ _conf_debug :: DebugConfigF f { _conf_debug :: DebugConfigF f
, _conf_layout :: LayoutConfigF f , _conf_layout :: LayoutConfigF f
, _conf_errorHandling :: ErrorHandlingConfigF f , _conf_errorHandling :: ErrorHandlingConfigF f
, _conf_forward :: ForwardOptionsF f
} }
deriving (Generic) deriving (Generic)
@ -64,23 +79,40 @@ data ConfigF f = Config
deriving instance Show (DebugConfigF Identity) deriving instance Show (DebugConfigF Identity)
deriving instance Show (LayoutConfigF Identity) deriving instance Show (LayoutConfigF Identity)
deriving instance Show (ErrorHandlingConfigF Identity) deriving instance Show (ErrorHandlingConfigF Identity)
deriving instance Show (ForwardOptionsF Identity)
deriving instance Show (ConfigF Identity) deriving instance Show (ConfigF Identity)
deriving instance Show (DebugConfigF Maybe) deriving instance Show (DebugConfigF Maybe)
deriving instance Show (LayoutConfigF Maybe) deriving instance Show (LayoutConfigF Maybe)
deriving instance Show (ErrorHandlingConfigF Maybe) deriving instance Show (ErrorHandlingConfigF Maybe)
deriving instance Show (ForwardOptionsF Maybe)
deriving instance Show (ConfigF Maybe) deriving instance Show (ConfigF Maybe)
deriving instance Data (DebugConfigF Identity) deriving instance Data (DebugConfigF Identity)
deriving instance Data (LayoutConfigF Identity) deriving instance Data (LayoutConfigF Identity)
deriving instance Data (ErrorHandlingConfigF Identity) deriving instance Data (ErrorHandlingConfigF Identity)
deriving instance Data (ForwardOptionsF Identity)
deriving instance Data (ConfigF 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 Config = ConfigF Identity
type DebugConfig = DebugConfigF Identity type DebugConfig = DebugConfigF Identity
type LayoutConfig = LayoutConfigF Identity type LayoutConfig = LayoutConfigF Identity
type ErrorHandlingConfig = ErrorHandlingConfigF 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 FromJSON (DebugConfigF Maybe)
instance ToJSON (DebugConfigF Maybe) instance ToJSON (DebugConfigF Maybe)
@ -95,6 +127,9 @@ instance ToJSON (LayoutConfigF Maybe)
instance FromJSON (ErrorHandlingConfigF Maybe) instance FromJSON (ErrorHandlingConfigF Maybe)
instance ToJSON (ErrorHandlingConfigF Maybe) instance ToJSON (ErrorHandlingConfigF Maybe)
instance FromJSON (ForwardOptionsF Maybe)
instance ToJSON (ForwardOptionsF Maybe)
instance FromJSON (ConfigF Maybe) instance FromJSON (ConfigF Maybe)
instance ToJSON (ConfigF Maybe) instance ToJSON (ConfigF Maybe)
@ -146,30 +181,33 @@ data AltChooser = AltChooserSimpleQuick -- always choose last alternative.
staticDefaultConfig :: Config staticDefaultConfig :: Config
staticDefaultConfig = Config staticDefaultConfig = Config
{ _conf_debug = DebugConfig { _conf_debug = DebugConfig
{ _dconf_dump_config = Identity False { _dconf_dump_config = coerce False
, _dconf_dump_annotations = Identity False , _dconf_dump_annotations = coerce False
, _dconf_dump_ast_unknown = Identity False , _dconf_dump_ast_unknown = coerce False
, _dconf_dump_ast_full = Identity False , _dconf_dump_ast_full = coerce False
, _dconf_dump_bridoc_raw = Identity False , _dconf_dump_bridoc_raw = coerce False
, _dconf_dump_bridoc_simpl_alt = Identity False , _dconf_dump_bridoc_simpl_alt = coerce False
, _dconf_dump_bridoc_simpl_floating = Identity False , _dconf_dump_bridoc_simpl_floating = coerce False
, _dconf_dump_bridoc_simpl_par = Identity False , _dconf_dump_bridoc_simpl_par = coerce False
, _dconf_dump_bridoc_simpl_columns = Identity False , _dconf_dump_bridoc_simpl_columns = coerce False
, _dconf_dump_bridoc_simpl_indent = Identity False , _dconf_dump_bridoc_simpl_indent = coerce False
, _dconf_dump_bridoc_final = Identity False , _dconf_dump_bridoc_final = coerce False
} }
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = Identity 80 { _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = Identity IndentPolicyFree , _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = Identity 2 , _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = Identity True , _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = Identity True , _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = Identity 60 , _lconfig_importColumn = coerce (60 :: Int)
, _lconfig_altChooser = Identity $ AltChooserBoundedSearch 3 , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
} }
, _conf_errorHandling = ErrorHandlingConfig , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = Identity False { _econf_produceOutputOnErrors = coerce False
, _econf_Werror = Identity False , _econf_Werror = coerce False
}
, _conf_forward = ForwardOptions
{ _options_ghc = Identity []
} }
} }
@ -211,11 +249,17 @@ instance CZip ErrorHandlingConfigF where
(f x1 y1) (f x1 y1)
(f x2 y2) (f x2 y2)
instance CZip ForwardOptionsF where
cZip f (ForwardOptions x1)
(ForwardOptions y1) = ForwardOptions
(f x1 y1)
instance CZip ConfigF where 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 x1 y1)
(cZip f x2 y2) (cZip f x2 y2)
(cZip f x3 y3) (cZip f x3 y3)
(cZip f x4 y4)
cMap :: CZip k => (forall a . f a -> g a) -> k f -> k g cMap :: CZip k => (forall a . f a -> g a) -> k f -> k g
cMap f c = cZip (\_ -> f) c c cMap f c = cZip (\_ -> f) c c

6
src/Language/Haskell/Brittany/LayoutBasics.hs
View File

@ -208,7 +208,7 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
else x else x
askIndent :: (MonadMultiReader Config m) => m Int askIndent :: (MonadMultiReader Config m) => m Int
askIndent = runIdentity . _lconfig_indentAmount . _conf_layout <$> mAsk askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk
layoutWriteAppend :: (MonadMultiWriter layoutWriteAppend :: (MonadMultiWriter
Text.Builder.Builder m, Text.Builder.Builder m,
@ -475,7 +475,7 @@ layoutWithAddBaseCol m = do
#if INSERTTRACES #if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseCol") tellDebugMessShow ("layoutWithAddBaseCol")
#endif #endif
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
state <- mGet state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount layoutBaseYPushInternal $ lstate_baseY state + amount
m m
@ -493,7 +493,7 @@ layoutWithAddBaseColBlock m = do
#if INSERTTRACES #if INSERTTRACES
tellDebugMessShow ("layoutWithAddBaseColBlock") tellDebugMessShow ("layoutWithAddBaseColBlock")
#endif #endif
amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
state <- mGet state <- mGet
layoutBaseYPushInternal $ lstate_baseY state + amount layoutBaseYPushInternal $ lstate_baseY state + amount
layoutWriteEnsureBlock layoutWriteEnsureBlock

2
src/Language/Haskell/Brittany/Layouters/Decl.hs
View File

@ -154,7 +154,7 @@ layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
whereIndent <- mAsk whereIndent <- mAsk
<&> _conf_layout <&> _conf_layout
.> _lconfig_indentWhereSpecial .> _lconfig_indentWhereSpecial
.> runIdentity .> confUnpack
.> Bool.bool BrIndentRegular (BrIndentSpecial 1) .> Bool.bool BrIndentRegular (BrIndentSpecial 1)
-- TODO: apart from this, there probably are more nodes below which could -- TODO: apart from this, there probably are more nodes below which could
-- be shared between alternatives. -- be shared between alternatives.

4
src/Language/Haskell/Brittany/Utils.hs
View File

@ -201,11 +201,11 @@ traceIfDumpConf :: (MonadMultiReader
Config m, Config m,
Show a) Show a)
=> String => String
-> (DebugConfig -> Identity Bool) -> (DebugConfig -> Identity (Semigroup.Last Bool))
-> a -> a
-> m () -> m ()
traceIfDumpConf s accessor val = do 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 () trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
tellDebugMess :: MonadMultiWriter tellDebugMess :: MonadMultiWriter

5
srcinc/prelude.inc
View File

@ -388,6 +388,8 @@ import qualified Data.Bool as Bool
import qualified GHC.OldList as List import qualified GHC.OldList as List
-- import qualified Text.Printf as Printf -- import qualified Text.Printf as Printf
import qualified Data.Semigroup as Semigroup
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as ByteStringL 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 as Writer
-- import qualified Control.Monad.Trans.Writer.Lazy as WriterL -- import qualified Control.Monad.Trans.Writer.Lazy as WriterL
-- import qualified Control.Monad.Trans.Writer.Strict as Writer -- import qualified Control.Monad.Trans.Writer.Strict as Writer
import qualified Control.Monad.Trans.Either as EitherT
import qualified Data.Strict.Maybe as Strict import qualified Data.Strict.Maybe as Strict
@ -442,7 +445,7 @@ import Data.Char ( Char )
import Data.Either ( Either(..) ) import Data.Either ( Either(..) )
import Data.IORef ( IORef ) import Data.IORef ( IORef )
import Data.Maybe ( Maybe(..) ) 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.Ord ( Ordering(..), Down(..) )
import Data.Ratio ( Ratio, Rational ) import Data.Ratio ( Ratio, Rational )
import Data.String ( String ) import Data.String ( String )