Support --ghc-options; Rework config internals
Lennart Spitzner
parent
d625c90461
commit
1a70e4d949
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 []
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
Loading…
Reference in New Issue