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

Format Brittany with Brittany #359

Merged
tfausak merged 1 commits from gh-238-format-self into master 2021-11-29 13:14:35 +01:00
Conversation 0 Commits 1 Files Changed 26
26 changed files with 3870 additions and 3677 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

442
source/library/Language/Haskell/Brittany/Internal.hs
View File

@ -75,35 +75,36 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
[ ( k [ ( k
, [ x , [ x
| (ExactPrint.Comment x _ _, _) <- | (ExactPrint.Comment x _ _, _) <-
( ExactPrint.annPriorComments ann (ExactPrint.annPriorComments ann
++ ExactPrint.annFollowingComments ann ++ ExactPrint.annFollowingComments ann
) )
] ]
++ [ x ++ [ x
| (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <- | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-
ExactPrint.annsDP ann ExactPrint.annsDP ann
] ]
) )
| (k, ann) <- Map.toList anns | (k, ann) <- Map.toList anns
] ]
let configLiness = commentLiness <&> second let
(Data.Maybe.mapMaybe $ \line -> do configLiness = commentLiness <&> second
l1 <- (Data.Maybe.mapMaybe $ \line -> do
List.stripPrefix "-- BRITTANY" line l1 <-
<|> List.stripPrefix "--BRITTANY" line List.stripPrefix "-- BRITTANY" line
<|> List.stripPrefix "-- brittany" line <|> List.stripPrefix "--BRITTANY" line
<|> List.stripPrefix "--brittany" line <|> List.stripPrefix "-- brittany" line
<|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") <|> List.stripPrefix "--brittany" line
let l2 = dropWhile isSpace l1 <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
guard let l2 = dropWhile isSpace l1
( ("@" `isPrefixOf` l2) guard
|| ("-disable" `isPrefixOf` l2) (("@" `isPrefixOf` l2)
|| ("-next" `isPrefixOf` l2) || ("-disable" `isPrefixOf` l2)
|| ("{" `isPrefixOf` l2) || ("-next" `isPrefixOf` l2)
|| ("--" `isPrefixOf` l2) || ("{" `isPrefixOf` l2)
) || ("--" `isPrefixOf` l2)
pure l2 )
) pure l2
)
let let
configParser = Butcher.addAlternatives configParser = Butcher.addAlternatives
[ ( "commandline-config" [ ( "commandline-config"
@ -122,39 +123,44 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
] ]
parser = do -- we will (mis?)use butcher here to parse the inline config parser = do -- we will (mis?)use butcher here to parse the inline config
-- line. -- line.
let nextDecl = do let
conf <- configParser nextDecl = do
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)
Butcher.addCmd "-next-declaration" nextDecl Butcher.addCmd "-next-declaration" nextDecl
Butcher.addCmd "-Next-Declaration" nextDecl Butcher.addCmd "-Next-Declaration" nextDecl
Butcher.addCmd "-NEXT-DECLARATION" nextDecl Butcher.addCmd "-NEXT-DECLARATION" nextDecl
let nextBinding = do let
conf <- configParser nextBinding = do
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)
Butcher.addCmd "-next-binding" nextBinding Butcher.addCmd "-next-binding" nextBinding
Butcher.addCmd "-Next-Binding" nextBinding Butcher.addCmd "-Next-Binding" nextBinding
Butcher.addCmd "-NEXT-BINDING" nextBinding Butcher.addCmd "-NEXT-BINDING" nextBinding
let disableNextBinding = do let
Butcher.addCmdImpl disableNextBinding = do
( InlineConfigTargetNextBinding Butcher.addCmdImpl
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True } ( InlineConfigTargetNextBinding
) , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
)
Butcher.addCmd "-disable-next-binding" disableNextBinding Butcher.addCmd "-disable-next-binding" disableNextBinding
Butcher.addCmd "-Disable-Next-Binding" disableNextBinding Butcher.addCmd "-Disable-Next-Binding" disableNextBinding
Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding
let disableNextDecl = do let
Butcher.addCmdImpl disableNextDecl = do
( InlineConfigTargetNextDecl Butcher.addCmdImpl
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True } ( InlineConfigTargetNextDecl
) , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
)
Butcher.addCmd "-disable-next-declaration" disableNextDecl Butcher.addCmd "-disable-next-declaration" disableNextDecl
Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl
Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl
let disableFormatting = do let
Butcher.addCmdImpl disableFormatting = do
( InlineConfigTargetModule Butcher.addCmdImpl
, mempty { _conf_disable_formatting = pure $ pure True } ( InlineConfigTargetModule
) , mempty { _conf_disable_formatting = pure $ pure True }
)
Butcher.addCmd "-disable" disableFormatting Butcher.addCmd "-disable" disableFormatting
Butcher.addCmd "@" $ do Butcher.addCmd "@" $ do
-- Butcher.addCmd "module" $ do -- Butcher.addCmd "module" $ do
@ -162,30 +168,31 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
-- Butcher.addCmdImpl (InlineConfigTargetModule, conf) -- Butcher.addCmdImpl (InlineConfigTargetModule, conf)
Butcher.addNullCmd $ do Butcher.addNullCmd $ do
bindingName <- Butcher.addParamString "BINDING" mempty bindingName <- Butcher.addParamString "BINDING" mempty
conf <- configParser conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf) Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf)
conf <- configParser conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetModule, conf) Butcher.addCmdImpl (InlineConfigTargetModule, conf)
lineConfigss <- configLiness `forM` \(k, ss) -> do lineConfigss <- configLiness `forM` \(k, ss) -> do
r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of
Left err -> Left $ (err, s) Left err -> Left $ (err, s)
Right c -> Right $ c Right c -> Right $ c
pure (k, r) pure (k, r)
let perModule = foldl' let
(<>) perModule = foldl'
mempty (<>)
[ conf mempty
| (_ , lineConfigs) <- lineConfigss [ conf
, (InlineConfigTargetModule, conf ) <- lineConfigs | (_, lineConfigs) <- lineConfigss
] , (InlineConfigTargetModule, conf) <- lineConfigs
]
let let
perBinding = Map.fromListWith perBinding = Map.fromListWith
(<>) (<>)
[ (n, conf) [ (n, conf)
| (k , lineConfigs) <- lineConfigss | (k, lineConfigs) <- lineConfigss
, (target, conf ) <- lineConfigs , (target, conf) <- lineConfigs
, n <- case target of , n <- case target of
InlineConfigTargetBinding s -> [s] InlineConfigTargetBinding s -> [s]
InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap -> InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->
[name] [name]
@ -195,8 +202,8 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
perKey = Map.fromListWith perKey = Map.fromListWith
(<>) (<>)
[ (k, conf) [ (k, conf)
| (k , lineConfigs) <- lineConfigss | (k, lineConfigs) <- lineConfigss
, (target, conf ) <- lineConfigs , (target, conf) <- lineConfigs
, case target of , case target of
InlineConfigTargetNextDecl -> True InlineConfigTargetNextDecl -> True
InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap -> InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap ->
@ -214,7 +221,7 @@ getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap
getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) = getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
TopLevelDeclNameMap $ Map.fromList TopLevelDeclNameMap $ Map.fromList
[ (ExactPrint.mkAnnKey decl, name) [ (ExactPrint.mkAnnKey decl, name)
| decl <- decls | decl <- decls
, (name : _) <- [getDeclBindingNames decl] , (name : _) <- [getDeclBindingNames decl]
] ]
@ -232,70 +239,76 @@ getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =
-- won't do. -- won't do.
parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
parsePrintModule configWithDebugs inputText = runExceptT $ do parsePrintModule configWithDebugs inputText = runExceptT $ do
let config = let
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
let config_pp = config & _conf_preprocessor let config_pp = config & _conf_preprocessor
let cppMode = config_pp & _ppconf_CPPMode & confUnpack let cppMode = config_pp & _ppconf_CPPMode & confUnpack
let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack
(anns, parsedSource, hasCPP) <- do (anns, parsedSource, hasCPP) <- do
let hackF s = if "#include" `isPrefixOf` s let
then "-- BRITANY_INCLUDE_HACK " ++ s hackF s =
else s if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s
let hackTransform = if hackAroundIncludes let
then List.intercalate "\n" . fmap hackF . lines' hackTransform = if hackAroundIncludes
else id then List.intercalate "\n" . fmap hackF . lines'
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags else id
then case cppMode of let
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
CPPModeWarn -> return $ Right True then case cppMode of
CPPModeNowarn -> return $ Right True CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
else return $ Right False CPPModeWarn -> return $ Right True
CPPModeNowarn -> return $ Right True
else return $ Right False
parseResult <- lift $ parseModuleFromString parseResult <- lift $ parseModuleFromString
ghcOptions ghcOptions
"stdin" "stdin"
cppCheckFunc cppCheckFunc
(hackTransform $ Text.unpack inputText) (hackTransform $ Text.unpack inputText)
case parseResult of case parseResult of
Left err -> throwE [ErrorInput err] Left err -> throwE [ErrorInput err]
Right x -> pure x Right x -> pure x
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
either (throwE . (: []) . uncurry ErrorMacroConfig) pure either (throwE . (: []) . uncurry ErrorMacroConfig) pure
$ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource) $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)
let moduleConfig = cZipWith fromOptionIdentity config inlineConf let moduleConfig = cZipWith fromOptionIdentity config inlineConf
let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack
if disableFormatting if disableFormatting
then do then do
return inputText return inputText
else do else do
(errsWarns, outputTextL) <- do (errsWarns, outputTextL) <- do
let omitCheck = let
moduleConfig omitCheck =
& _conf_errorHandling moduleConfig
& _econf_omit_output_valid_check & _conf_errorHandling
& confUnpack & _econf_omit_output_valid_check
& confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then return $ pPrintModule moduleConfig perItemConf anns parsedSource then return $ pPrintModule moduleConfig perItemConf anns parsedSource
else lift else lift
$ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource
let hackF s = fromMaybe s let
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes pure $ if hackAroundIncludes
then then
( ews ( ews
, TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn , TextL.intercalate (TextL.pack "\n")
(TextL.pack "\n") $ hackF
outRaw <$> TextL.splitOn (TextL.pack "\n") outRaw
) )
else (ews, outRaw) else (ews, outRaw)
let customErrOrder ErrorInput{} = 4 let
customErrOrder LayoutWarning{} = 0 :: Int customErrOrder ErrorInput{} = 4
customErrOrder ErrorOutputCheck{} = 1 customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorUnknownNode{} = 3
let hasErrors = customErrOrder ErrorMacroConfig{} = 5
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack let
hasErrors =
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack
then not $ null errsWarns then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns) else 0 < maximum (-1 : fmap customErrOrder errsWarns)
if hasErrors if hasErrors
@ -315,26 +328,27 @@ pPrintModule
-> GHC.ParsedSource -> GHC.ParsedSource
-> ([BrittanyError], TextL.Text) -> ([BrittanyError], TextL.Text)
pPrintModule conf inlineConf anns parsedModule = pPrintModule conf inlineConf anns parsedModule =
let ((out, errs), debugStrings) = let
runIdentity ((out, errs), debugStrings) =
$ MultiRWSS.runMultiRWSTNil runIdentity
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiWriterW $ MultiRWSS.withMultiWriterAW
$ MultiRWSS.withMultiReader anns $ MultiRWSS.withMultiWriterW
$ MultiRWSS.withMultiReader conf $ MultiRWSS.withMultiReader anns
$ MultiRWSS.withMultiReader inlineConf $ MultiRWSS.withMultiReader conf
$ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns) $ MultiRWSS.withMultiReader inlineConf
$ do $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)
traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations $ do
$ annsDoc anns traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations
ppModule parsedModule $ annsDoc anns
tracer = if Seq.null debugStrings ppModule parsedModule
then id tracer = if Seq.null debugStrings
else then id
trace ("---- DEBUGMESSAGES ---- ") else
. foldr (seq . join trace) id debugStrings trace ("---- DEBUGMESSAGES ---- ")
in tracer $ (errs, Text.Builder.toLazyText out) . foldr (seq . join trace) id debugStrings
in tracer $ (errs, Text.Builder.toLazyText out)
-- unless () $ do -- unless () $ do
-- --
-- debugStrings `forM_` \s -> -- debugStrings `forM_` \s ->
@ -349,15 +363,17 @@ pPrintModuleAndCheck
-> GHC.ParsedSource -> GHC.ParsedSource
-> IO ([BrittanyError], TextL.Text) -> IO ([BrittanyError], TextL.Text)
pPrintModuleAndCheck conf inlineConf anns parsedModule = do pPrintModuleAndCheck conf inlineConf anns parsedModule = do
let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
let (errs, output) = pPrintModule conf inlineConf anns parsedModule let (errs, output) = pPrintModule conf inlineConf anns parsedModule
parseResult <- parseModuleFromString ghcOptions parseResult <- parseModuleFromString
"output" ghcOptions
(\_ -> return $ Right ()) "output"
(TextL.unpack output) (\_ -> return $ Right ())
let errs' = errs ++ case parseResult of (TextL.unpack output)
Left{} -> [ErrorOutputCheck] let
Right{} -> [] errs' = errs ++ case parseResult of
Left{} -> [ErrorOutputCheck]
Right{} -> []
return (errs', output) return (errs', output)
@ -372,18 +388,19 @@ parsePrintModuleTests conf filename input = do
(const . pure $ Right ()) (const . pure $ Right ())
inputStr inputStr
case parseResult of case parseResult of
Left err -> return $ Left err Left err -> return $ Left err
Right (anns, parsedModule, _) -> runExceptT $ do Right (anns, parsedModule, _) -> runExceptT $ do
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
Left err -> throwE $ "error in inline config: " ++ show err Left err -> throwE $ "error in inline config: " ++ show err
Right x -> pure x Right x -> pure x
let moduleConf = cZipWith fromOptionIdentity conf inlineConf let moduleConf = cZipWith fromOptionIdentity conf inlineConf
let omitCheck = let
conf omitCheck =
& _conf_errorHandling conf
.> _econf_omit_output_valid_check & _conf_errorHandling
.> confUnpack .> _econf_omit_output_valid_check
.> confUnpack
(errs, ltext) <- if omitCheck (errs, ltext) <- if omitCheck
then return $ pPrintModule moduleConf perItemConf anns parsedModule then return $ pPrintModule moduleConf perItemConf anns parsedModule
else lift else lift
@ -393,13 +410,13 @@ parsePrintModuleTests conf filename input = do
else else
let let
errStrs = errs <&> \case errStrs = errs <&> \case
ErrorInput str -> str ErrorInput str -> str
ErrorUnusedComment str -> str ErrorUnusedComment str -> str
LayoutWarning str -> str LayoutWarning str -> str
ErrorUnknownNode str _ -> str ErrorUnknownNode str _ -> str
ErrorMacroConfig str _ -> "when parsing inline config: " ++ str ErrorMacroConfig str _ -> "when parsing inline config: " ++ str
ErrorOutputCheck -> "Output is not syntactically valid." ErrorOutputCheck -> "Output is not syntactically valid."
in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs
-- this approach would for if there was a pure GHC.parseDynamicFilePragma. -- this approach would for if there was a pure GHC.parseDynamicFilePragma.
-- Unfortunately that does not exist yet, so we cannot provide a nominally -- Unfortunately that does not exist yet, so we cannot provide a nominally
@ -454,25 +471,26 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
post <- ppPreamble lmod post <- ppPreamble lmod
decls `forM_` \decl -> do decls `forM_` \decl -> do
let declAnnKey = ExactPrint.mkAnnKey decl let declAnnKey = ExactPrint.mkAnnKey decl
let declBindingNames = getDeclBindingNames decl let declBindingNames = getDeclBindingNames decl
inlineConf <- mAsk inlineConf <- mAsk
let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf
let mBindingConfs = let
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf mBindingConfs =
filteredAnns <- mAsk declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
<&> \annMap -> filteredAnns <- mAsk <&> \annMap ->
Map.union defaultAnns $ Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap
Map.findWithDefault Map.empty declAnnKey annMap
traceIfDumpConf "bridoc annotations filtered/transformed" traceIfDumpConf
_dconf_dump_annotations "bridoc annotations filtered/transformed"
_dconf_dump_annotations
$ annsDoc filteredAnns $ annsDoc filteredAnns
config <- mAsk config <- mAsk
let config' = cZipWith fromOptionIdentity config let
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) config' = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
toLocal config' filteredAnns $ do toLocal config' filteredAnns $ do
@ -487,33 +505,34 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
else briDocMToPPM $ briDocByExactNoComment decl else briDocMToPPM $ briDocByExactNoComment decl
layoutBriDoc bd layoutBriDoc bd
let finalComments = filter let
(fst .> \case finalComments = filter
ExactPrint.AnnComment{} -> True (fst .> \case
_ -> False ExactPrint.AnnComment{} -> True
) _ -> False
post )
post
post `forM_` \case post `forM_` \case
(ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do
ppmMoveToExactLoc l ppmMoveToExactLoc l
mTell $ Text.Builder.fromString cmStr mTell $ Text.Builder.fromString cmStr
(ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) -> (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->
let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of let
ExactPrint.AnnComment cm folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
| span <- ExactPrint.commentIdentifier cm ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->
-> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span
, x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span
) )
_ -> (acc + y, x) _ -> (acc + y, x)
(cmY, cmX) = foldl' folder (0, 0) finalComments (cmY, cmX) = foldl' folder (0, 0) finalComments
in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
_ -> return () _ -> return ()
getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames :: LHsDecl GhcPs -> [String]
getDeclBindingNames (L _ decl) = case decl of getDeclBindingNames (L _ decl) = case decl of
SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n) SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)
ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n] ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]
_ -> [] _ -> []
-- Prints the information associated with the module annotation -- Prints the information associated with the module annotation
@ -530,8 +549,9 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
-- attached annotations that come after the module's where -- attached annotations that come after the module's where
-- from the module node -- from the module node
config <- mAsk config <- mAsk
let shouldReformatPreamble = let
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack shouldReformatPreamble =
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
let let
(filteredAnns', post) = (filteredAnns', post) =
@ -541,23 +561,23 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
let let
modAnnsDp = ExactPrint.annsDP mAnn modAnnsDp = ExactPrint.annsDP mAnn
isWhere (ExactPrint.G AnnWhere) = True isWhere (ExactPrint.G AnnWhere) = True
isWhere _ = False isWhere _ = False
isEof (ExactPrint.AnnEofPos) = True isEof (ExactPrint.AnnEofPos) = True
isEof _ = False isEof _ = False
whereInd = List.findIndex (isWhere . fst) modAnnsDp whereInd = List.findIndex (isWhere . fst) modAnnsDp
eofInd = List.findIndex (isEof . fst) modAnnsDp eofInd = List.findIndex (isEof . fst) modAnnsDp
(pre, post') = case (whereInd, eofInd) of (pre, post') = case (whereInd, eofInd) of
(Nothing, Nothing) -> ([], modAnnsDp) (Nothing, Nothing) -> ([], modAnnsDp)
(Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp
(Nothing, Just _i) -> ([], modAnnsDp) (Nothing, Just _i) -> ([], modAnnsDp)
(Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp
mAnn' = mAnn { ExactPrint.annsDP = pre } mAnn' = mAnn { ExactPrint.annsDP = pre }
filteredAnns'' = filteredAnns'' =
Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns
in in (filteredAnns'', post')
(filteredAnns'', post') traceIfDumpConf
traceIfDumpConf "bridoc annotations filtered/transformed" "bridoc annotations filtered/transformed"
_dconf_dump_annotations _dconf_dump_annotations
$ annsDoc filteredAnns' $ annsDoc filteredAnns'
if shouldReformatPreamble if shouldReformatPreamble
@ -566,7 +586,7 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
layoutBriDoc briDoc layoutBriDoc briDoc
else else
let emptyModule = L loc m { hsmodDecls = [] } let emptyModule = L loc m { hsmodDecls = [] }
in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule
return post return post
_sigHead :: Sig GhcPs -> String _sigHead :: Sig GhcPs -> String
@ -579,7 +599,7 @@ _bindHead :: HsBind GhcPs -> String
_bindHead = \case _bindHead = \case
FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId) FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
PatBind _ _pat _ ([], []) -> "PatBind smth" PatBind _ _pat _ ([], []) -> "PatBind smth"
_ -> "unknown bind" _ -> "unknown bind"
@ -597,63 +617,67 @@ layoutBriDoc briDoc = do
transformAlts briDoc >>= mSet transformAlts briDoc >>= mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt
-- bridoc transformation: float stuff in -- bridoc transformation: float stuff in
mGet >>= transformSimplifyFloating .> mSet mGet >>= transformSimplifyFloating .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-floating" .> traceIfDumpConf
_dconf_dump_bridoc_simpl_floating "bridoc post-floating"
_dconf_dump_bridoc_simpl_floating
-- bridoc transformation: par removal -- bridoc transformation: par removal
mGet >>= transformSimplifyPar .> mSet mGet >>= transformSimplifyPar .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par
-- bridoc transformation: float stuff in -- bridoc transformation: float stuff in
mGet >>= transformSimplifyColumns .> mSet mGet >>= transformSimplifyColumns .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns
-- bridoc transformation: indent -- bridoc transformation: indent
mGet >>= transformSimplifyIndent .> mSet mGet >>= transformSimplifyIndent .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final
-- -- convert to Simple type -- -- convert to Simple type
-- simpl <- mGet <&> transformToSimple -- simpl <- mGet <&> transformToSimple
-- return simpl -- return simpl
anns :: ExactPrint.Anns <- mAsk anns :: ExactPrint.Anns <- mAsk
let state = LayoutState { _lstate_baseYs = [0] let
, _lstate_curYOrAddNewline = Right 0 -- important that we dont use left state = LayoutState
-- here because moveToAnn stuff { _lstate_baseYs = [0]
-- of the first node needs to do , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
-- its thing properly. -- here because moveToAnn stuff
, _lstate_indLevels = [0] -- of the first node needs to do
, _lstate_indLevelLinger = 0 -- its thing properly.
, _lstate_comments = anns , _lstate_indLevels = [0]
, _lstate_commentCol = Nothing , _lstate_indLevelLinger = 0
, _lstate_addSepSpace = Nothing , _lstate_comments = anns
, _lstate_commentNewlines = 0 , _lstate_commentCol = Nothing
} , _lstate_addSepSpace = Nothing
, _lstate_commentNewlines = 0
}
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let remainingComments = let
[ c remainingComments =
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList [ c
(_lstate_comments state') | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
-- With the new import layouter, we manually process comments (_lstate_comments state')
-- without relying on the backend to consume the comments out of -- With the new import layouter, we manually process comments
-- the state/map. So they will end up here, and we need to ignore -- without relying on the backend to consume the comments out of
-- them. -- the state/map. So they will end up here, and we need to ignore
, ExactPrint.unConName con /= "ImportDecl" -- them.
, c <- extractAllComments elemAnns , ExactPrint.unConName con /= "ImportDecl"
] , c <- extractAllComments elemAnns
]
remainingComments remainingComments
`forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell) `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)

509
source/library/Language/Haskell/Brittany/Internal/Backend.hs
View File

@ -31,16 +31,20 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
type ColIndex = Int type ColIndex = Int
data ColumnSpacing data ColumnSpacing
= ColumnSpacingLeaf Int = ColumnSpacingLeaf Int
| ColumnSpacingRef Int Int | ColumnSpacingRef Int Int
type ColumnBlock a = [a] type ColumnBlock a = [a]
type ColumnBlocks a = Seq [a] type ColumnBlocks a = Seq [a]
type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing) type ColMap1
type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int) = IntMapL.IntMap {- ColIndex -}
(Bool, ColumnBlocks ColumnSpacing)
type ColMap2
= IntMapL.IntMap {- ColIndex -}
(Float, ColumnBlock Int, ColumnBlocks Int)
-- (ratio of hasSpace, maximum, raw) -- (ratio of hasSpace, maximum, raw)
data ColInfo data ColInfo
@ -50,20 +54,23 @@ data ColInfo
instance Show ColInfo where instance Show ColInfo where
show ColInfoStart = "ColInfoStart" show ColInfoStart = "ColInfoStart"
show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") show (ColInfoNo bd) =
show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")
show (ColInfo ind sig list) =
"ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
data ColBuildState = ColBuildState data ColBuildState = ColBuildState
{ _cbs_map :: ColMap1 { _cbs_map :: ColMap1
, _cbs_index :: ColIndex , _cbs_index :: ColIndex
} }
type LayoutConstraints m = ( MonadMultiReader Config m type LayoutConstraints m
, MonadMultiReader ExactPrint.Types.Anns m = ( MonadMultiReader Config m
, MonadMultiWriter Text.Builder.Builder m , MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter (Seq String) m , MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m , MonadMultiWriter (Seq String) m
) , MonadMultiState LayoutState m
)
layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m () layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()
layoutBriDocM = \case layoutBriDocM = \case
@ -84,10 +91,11 @@ layoutBriDocM = \case
BDSeparator -> do BDSeparator -> do
layoutAddSepSpace layoutAddSepSpace
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
let indentF = case indent of let
BrIndentNone -> id indentF = case indent of
BrIndentRegular -> layoutWithAddBaseCol BrIndentNone -> id
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ layoutBriDocM bd indentF $ layoutBriDocM bd
BDBaseYPushCur bd -> do BDBaseYPushCur bd -> do
layoutBaseYPushCur layoutBaseYPushCur
@ -102,36 +110,39 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
layoutIndentLevelPop layoutIndentLevelPop
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
let indentF = case indent of let
BrIndentNone -> id indentF = case indent of
BrIndentRegular -> layoutWithAddBaseCol BrIndentNone -> id
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do indentF $ do
layoutWriteEnsureBlock layoutWriteEnsureBlock
layoutBriDocM bd layoutBriDocM bd
BDPar indent sameLine indented -> do BDPar indent sameLine indented -> do
layoutBriDocM sameLine layoutBriDocM sameLine
let indentF = case indent of let
BrIndentNone -> id indentF = case indent of
BrIndentRegular -> layoutWithAddBaseCol BrIndentNone -> id
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i
indentF $ do indentF $ do
layoutWriteNewlineBlock layoutWriteNewlineBlock
layoutBriDocM indented layoutBriDocM indented
BDLines lines -> alignColsLines lines BDLines lines -> alignColsLines lines
BDAlt [] -> error "empty BDAlt" BDAlt [] -> error "empty BDAlt"
BDAlt (alt:_) -> layoutBriDocM alt BDAlt (alt : _) -> layoutBriDocM alt
BDForceMultiline bd -> layoutBriDocM bd BDForceMultiline bd -> layoutBriDocM bd
BDForceSingleline bd -> layoutBriDocM bd BDForceSingleline bd -> layoutBriDocM bd
BDForwardLineMode bd -> layoutBriDocM bd BDForwardLineMode bd -> layoutBriDocM bd
BDExternal annKey subKeys shouldAddComment t -> do BDExternal annKey subKeys shouldAddComment t -> do
let tlines = Text.lines $ t <> Text.pack "\n" let
tlineCount = length tlines tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do when shouldAddComment $ do
layoutWriteAppend layoutWriteAppend
$ Text.pack $ Text.pack
$ "{-" $ "{-"
++ show (annKey, Map.lookup annKey anns) ++ show (annKey, Map.lookup annKey anns)
++ "-}" ++ "-}"
zip [1 ..] tlines `forM_` \(i, l) -> do zip [1 ..] tlines `forM_` \(i, l) -> do
@ -148,9 +159,10 @@ layoutBriDocM = \case
BDAnnotationPrior annKey bd -> do BDAnnotationPrior annKey bd -> do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let moveToExactLocationAction = case _lstate_curYOrAddNewline state of let
Left{} -> pure () moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Right{} -> moveToExactAnn annKey Left{} -> pure ()
Right{} -> moveToExactAnn annKey
mAnn <- do mAnn <- do
let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m
mSet $ state mSet $ state
@ -161,8 +173,8 @@ layoutBriDocM = \case
} }
return mAnn return mAnn
case mAnn of case mAnn of
Nothing -> moveToExactLocationAction Nothing -> moveToExactLocationAction
Just [] -> moveToExactLocationAction Just [] -> moveToExactLocationAction
Just priors -> do Just priors -> do
-- layoutResetSepSpace -- layoutResetSepSpace
priors priors
@ -170,9 +182,10 @@ layoutBriDocM = \case
when (comment /= "(" && comment /= ")") $ do when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment let commentLines = Text.lines $ Text.pack $ comment
case comment of case comment of
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) ('#' : _) ->
layoutMoveToCommentPos y (-999) (length commentLines)
-- ^ evil hack for CPP -- ^ evil hack for CPP
_ -> layoutMoveToCommentPos y x (length commentLines) _ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x -- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline -- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y -- layoutMoveToIndentCol y
@ -184,18 +197,20 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
mComments <- do mComments <- do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let mToSpan = case mAnn of let
Just anns | Maybe.isNothing keyword -> Just anns mToSpan = case mAnn of
Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just Just anns | Maybe.isNothing keyword -> Just anns
annR Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->
_ -> Nothing Just annR
_ -> Nothing
case mToSpan of case mToSpan of
Just anns -> do Just anns -> do
let (comments, rest) = flip spanMaybe anns $ \case let
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) (comments, rest) = flip spanMaybe anns $ \case
_ -> Nothing (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing
mSet $ state mSet $ state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
(\ann -> ann { ExactPrint.annsDP = rest }) (\ann -> ann { ExactPrint.annsDP = rest })
@ -207,17 +222,19 @@ layoutBriDocM = \case
case mComments of case mComments of
Nothing -> pure () Nothing -> pure ()
Just comments -> do Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> comments
when (comment /= "(" && comment /= ")") $ do `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
let commentLines = Text.lines $ Text.pack $ comment when (comment /= "(" && comment /= ")") $ do
-- evil hack for CPP: let commentLines = Text.lines $ Text.pack $ comment
case comment of -- evil hack for CPP:
('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines) case comment of
_ -> layoutMoveToCommentPos y x (length commentLines) ('#' : _) ->
-- fixedX <- fixMoveToLineByIsNewline x layoutMoveToCommentPos y (-999) (length commentLines)
-- replicateM_ fixedX layoutWriteNewline _ -> layoutMoveToCommentPos y x (length commentLines)
-- layoutMoveToIndentCol y -- fixedX <- fixMoveToLineByIsNewline x
layoutWriteAppendMultiline commentLines -- replicateM_ fixedX layoutWriteNewline
-- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDAnnotationRest annKey bd -> do BDAnnotationRest annKey bd -> do
layoutBriDocM bd layoutBriDocM bd
@ -226,21 +243,26 @@ layoutBriDocM = \case
let m = _lstate_comments state let m = _lstate_comments state
pure $ Map.lookup annKey m pure $ Map.lookup annKey m
let mComments = nonEmpty . extractAllComments =<< annMay let mComments = nonEmpty . extractAllComments =<< annMay
let semiCount = length [ () let
| Just ann <- [ annMay ] semiCount = length
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann [ ()
] | Just ann <- [annMay]
shouldAddSemicolonNewlines <- mAsk <&> , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
_conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack ]
shouldAddSemicolonNewlines <-
mAsk
<&> _conf_layout
.> _lconfig_experimentalSemicolonNewlines
.> confUnpack
mModify $ \state -> state mModify $ \state -> state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
( \ann -> ann { ExactPrint.annFollowingComments = [] (\ann -> ann
, ExactPrint.annPriorComments = [] { ExactPrint.annFollowingComments = []
, ExactPrint.annsDP = , ExactPrint.annPriorComments = []
flip filter (ExactPrint.annsDP ann) $ \case , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False (ExactPrint.Types.AnnComment{}, _) -> False
_ -> True _ -> True
} }
) )
annKey annKey
(_lstate_comments state) (_lstate_comments state)
@ -248,37 +270,40 @@ layoutBriDocM = \case
case mComments of case mComments of
Nothing -> do Nothing -> do
when shouldAddSemicolonNewlines $ do when shouldAddSemicolonNewlines $ do
[1..semiCount] `forM_` const layoutWriteNewline [1 .. semiCount] `forM_` const layoutWriteNewline
Just comments -> do Just comments -> do
comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> comments
when (comment /= "(" && comment /= ")") $ do `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
let commentLines = Text.lines $ Text.pack comment when (comment /= "(" && comment /= ")") $ do
case comment of let commentLines = Text.lines $ Text.pack comment
('#':_) -> layoutMoveToCommentPos y (-999) 1 case comment of
-- ^ evil hack for CPP ('#' : _) -> layoutMoveToCommentPos y (-999) 1
")" -> pure () -- ^ evil hack for CPP
-- ^ fixes the formatting of parens ")" -> pure ()
-- on the lhs of type alias defs -- ^ fixes the formatting of parens
_ -> layoutMoveToCommentPos y x (length commentLines) -- on the lhs of type alias defs
-- fixedX <- fixMoveToLineByIsNewline x _ -> layoutMoveToCommentPos y x (length commentLines)
-- replicateM_ fixedX layoutWriteNewline -- fixedX <- fixMoveToLineByIsNewline x
-- layoutMoveToIndentCol y -- replicateM_ fixedX layoutWriteNewline
layoutWriteAppendMultiline commentLines -- layoutMoveToIndentCol y
layoutWriteAppendMultiline commentLines
-- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 } -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }
BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do
mDP <- do mDP <- do
state <- mGet state <- mGet
let m = _lstate_comments state let m = _lstate_comments state
let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m
let relevant = [ dp let
| Just ann <- [mAnn] relevant =
, (ExactPrint.Types.G kw1, dp) <- ann [ dp
, keyword == kw1 | Just ann <- [mAnn]
] , (ExactPrint.Types.G kw1, dp) <- ann
, keyword == kw1
]
-- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant] -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]
case relevant of case relevant of
[] -> pure Nothing [] -> pure Nothing
(ExactPrint.Types.DP (y, x):_) -> do (ExactPrint.Types.DP (y, x) : _) -> do
mSet state { _lstate_commentNewlines = 0 } mSet state { _lstate_commentNewlines = 0 }
pure $ Just (y - _lstate_commentNewlines state, x) pure $ Just (y - _lstate_commentNewlines state, x)
case mDP of case mDP of
@ -289,8 +314,8 @@ layoutBriDocM = \case
layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1 layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1
layoutBriDocM bd layoutBriDocM bd
BDNonBottomSpacing _ bd -> layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd
BDDebug s bd -> do BDDebug s bd -> do
mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}" mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"
layoutBriDocM bd layoutBriDocM bd
@ -301,73 +326,73 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
-- appended at the current position. -- appended at the current position.
where where
rec = \case rec = \case
BDEmpty -> return $ 0 BDEmpty -> return $ 0
BDLit t -> StateS.put False $> Text.length t BDLit t -> StateS.put False $> Text.length t
BDSeq bds -> sum <$> rec `mapM` bds BDSeq bds -> sum <$> rec `mapM` bds
BDCols _ bds -> sum <$> rec `mapM` bds BDCols _ bds -> sum <$> rec `mapM` bds
BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1 BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1
BDAddBaseY _ bd -> rec bd BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> rec bd
BDPar _ line _ -> rec line BDPar _ line _ -> rec line
BDAlt{} -> error "briDocLineLength BDAlt" BDAlt{} -> error "briDocLineLength BDAlt"
BDForceMultiline bd -> rec bd BDForceMultiline bd -> rec bd
BDForceSingleline bd -> rec bd BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t -> return $ Text.length t BDExternal _ _ _ t -> return $ Text.length t
BDPlain t -> return $ Text.length t BDPlain t -> return $ Text.length t
BDAnnotationPrior _ bd -> rec bd BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd
BDLines ls@(_ : _) -> do BDLines ls@(_ : _) -> do
x <- StateS.get x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []" BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd BDDebug _ bd -> rec bd
briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine :: BriDoc -> Bool
briDocIsMultiLine briDoc = rec briDoc briDocIsMultiLine briDoc = rec briDoc
where where
rec :: BriDoc -> Bool rec :: BriDoc -> Bool
rec = \case rec = \case
BDEmpty -> False BDEmpty -> False
BDLit _ -> False BDLit _ -> False
BDSeq bds -> any rec bds BDSeq bds -> any rec bds
BDCols _ bds -> any rec bds BDCols _ bds -> any rec bds
BDSeparator -> False BDSeparator -> False
BDAddBaseY _ bd -> rec bd BDAddBaseY _ bd -> rec bd
BDBaseYPushCur bd -> rec bd BDBaseYPushCur bd -> rec bd
BDBaseYPop bd -> rec bd BDBaseYPop bd -> rec bd
BDIndentLevelPushCur bd -> rec bd BDIndentLevelPushCur bd -> rec bd
BDIndentLevelPop bd -> rec bd BDIndentLevelPop bd -> rec bd
BDPar{} -> True BDPar{} -> True
BDAlt{} -> error "briDocIsMultiLine BDAlt" BDAlt{} -> error "briDocIsMultiLine BDAlt"
BDForceMultiline _ -> True BDForceMultiline _ -> True
BDForceSingleline bd -> rec bd BDForceSingleline bd -> rec bd
BDForwardLineMode bd -> rec bd BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t | [_] <- Text.lines t -> False BDExternal _ _ _ t | [_] <- Text.lines t -> False
BDExternal{} -> True BDExternal{} -> True
BDPlain t | [_] <- Text.lines t -> False BDPlain t | [_] <- Text.lines t -> False
BDPlain _ -> True BDPlain _ -> True
BDAnnotationPrior _ bd -> rec bd BDAnnotationPrior _ bd -> rec bd
BDAnnotationKW _ _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd
BDLines (_ : _ : _) -> True BDLines (_ : _ : _) -> True
BDLines [_ ] -> False BDLines [_] -> False
BDLines [] -> error "briDocIsMultiLine BDLines []" BDLines [] -> error "briDocIsMultiLine BDLines []"
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd
BDNonBottomSpacing _ bd -> rec bd BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd BDDebug _ bd -> rec bd
-- In theory -- In theory
-- ========= -- =========
@ -452,16 +477,16 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe
0 0
(_lstate_addSepSpace state) (_lstate_addSepSpace state)
colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack
alignBreak <- alignBreak <-
mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack
case () of case () of
_ -> do _ -> do
-- tellDebugMess ("processedMap: " ++ show processedMap) -- tellDebugMess ("processedMap: " ++ show processedMap)
sequence_ sequence_
$ List.intersperse layoutWriteEnsureNewlineBlock $ List.intersperse layoutWriteEnsureNewlineBlock
$ colInfos $ colInfos
<&> processInfo colMax processedMap <&> processInfo colMax processedMap
where where
(colInfos, finalState) = (colInfos, finalState) =
@ -478,40 +503,39 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
where alignMax' = max 0 alignMax where alignMax' = max 0 alignMax
processedMap :: ColMap2 processedMap :: ColMap2
processedMap = processedMap = fix $ \result ->
fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) -> _cbs_map finalState <&> \(lastFlag, colSpacingss) ->
let let
colss = colSpacingss <&> \spss -> case reverse spss of colss = colSpacingss <&> \spss -> case reverse spss of
[] -> [] [] -> []
(xN:xR) -> (xN : xR) ->
reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
where where
fLast (ColumnSpacingLeaf len ) = len fLast (ColumnSpacingLeaf len) = len
fLast (ColumnSpacingRef len _) = len fLast (ColumnSpacingRef len _) = len
fInit (ColumnSpacingLeaf len) = len fInit (ColumnSpacingLeaf len) = len
fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of
Nothing -> 0 Nothing -> 0
Just (_, maxs, _) -> sum maxs Just (_, maxs, _) -> sum maxs
maxCols = {-Foldable.foldl1 maxZipper-} maxCols = {-Foldable.foldl1 maxZipper-}
fmap colAggregation $ transpose $ Foldable.toList colss fmap colAggregation $ transpose $ Foldable.toList colss
(_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $ (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $
mapAccumL (\acc x -> (acc + x, acc)) curX maxCols mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
counter count l = if List.last posXs + List.last l <= colMax counter count l = if List.last posXs + List.last l <= colMax
then count + 1 then count + 1
else count else count
ratio = fromIntegral (foldl counter (0 :: Int) colss) ratio = fromIntegral (foldl counter (0 :: Int) colss)
/ fromIntegral (length colss) / fromIntegral (length colss)
in in (ratio, maxCols, colss)
(ratio, maxCols, colss)
mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo] mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocs bds = mergeBriDocsW ColInfoStart bds mergeBriDocs bds = mergeBriDocsW ColInfoStart bds
mergeBriDocsW mergeBriDocsW
:: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo] :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]
mergeBriDocsW _ [] = return [] mergeBriDocsW _ [] = return []
mergeBriDocsW lastInfo (bd:bdr) = do mergeBriDocsW lastInfo (bd : bdr) = do
info <- mergeInfoBriDoc True lastInfo bd info <- mergeInfoBriDoc True lastInfo bd
infor <- mergeBriDocsW infor <- mergeBriDocsW
-- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info) -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)
(if shouldBreakAfter bd then ColInfoStart else info) (if shouldBreakAfter bd then ColInfoStart else info)
@ -539,28 +563,27 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-- personal preference to not break alignment for those, even if -- personal preference to not break alignment for those, even if
-- multiline. Really, this should be configurable.. (TODO) -- multiline. Really, this should be configurable.. (TODO)
shouldBreakAfter :: BriDoc -> Bool shouldBreakAfter :: BriDoc -> Bool
shouldBreakAfter bd = alignBreak && shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of
briDocIsMultiLine bd && case bd of (BDCols ColTyOpPrefix _) -> False
(BDCols ColTyOpPrefix _) -> False (BDCols ColPatternsFuncPrefix _) -> True
(BDCols ColPatternsFuncPrefix _) -> True (BDCols ColPatternsFuncInfix _) -> True
(BDCols ColPatternsFuncInfix _) -> True (BDCols ColPatterns _) -> True
(BDCols ColPatterns _) -> True (BDCols ColCasePattern _) -> True
(BDCols ColCasePattern _) -> True (BDCols ColBindingLine{} _) -> True
(BDCols ColBindingLine{} _) -> True (BDCols ColGuard _) -> True
(BDCols ColGuard _) -> True (BDCols ColGuardedBody _) -> True
(BDCols ColGuardedBody _) -> True (BDCols ColBindStmt _) -> True
(BDCols ColBindStmt _) -> True (BDCols ColDoLet _) -> True
(BDCols ColDoLet _) -> True (BDCols ColRec _) -> False
(BDCols ColRec _) -> False (BDCols ColRecUpdate _) -> False
(BDCols ColRecUpdate _) -> False (BDCols ColRecDecl _) -> False
(BDCols ColRecDecl _) -> False (BDCols ColListComp _) -> False
(BDCols ColListComp _) -> False (BDCols ColList _) -> False
(BDCols ColList _) -> False (BDCols ColApp{} _) -> True
(BDCols ColApp{} _) -> True (BDCols ColTuple _) -> False
(BDCols ColTuple _) -> False (BDCols ColTuples _) -> False
(BDCols ColTuples _) -> False (BDCols ColOpPrefix _) -> False
(BDCols ColOpPrefix _) -> False _ -> True
_ -> True
mergeInfoBriDoc mergeInfoBriDoc
:: Bool :: Bool
@ -568,23 +591,22 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
-> BriDoc -> BriDoc
-> StateS.StateT ColBuildState Identity ColInfo -> StateS.StateT ColBuildState Identity ColInfo
mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag
mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) = mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =
\case \case
brdc@(BDCols colSig subDocs) brdc@(BDCols colSig subDocs)
| infoSig == colSig && length subLengthsInfos == length subDocs | infoSig == colSig && length subLengthsInfos == length subDocs -> do
-> do
let let
isLastList = if lastFlag isLastList = if lastFlag
then (==length subDocs) <$> [1 ..] then (== length subDocs) <$> [1 ..]
else repeat False else repeat False
infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs
`forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd
let curLengths = briDocLineLength <$> subDocs let curLengths = briDocLineLength <$> subDocs
let trueSpacings = getTrueSpacings (zip curLengths infos) let trueSpacings = getTrueSpacings (zip curLengths infos)
do -- update map do -- update map
s <- StateS.get s <- StateS.get
let m = _cbs_map s let m = _cbs_map s
let (Just (_, spaces)) = IntMapS.lookup infoInd m let (Just (_, spaces)) = IntMapS.lookup infoInd m
StateS.put s StateS.put s
{ _cbs_map = IntMapS.insert { _cbs_map = IntMapS.insert
@ -593,17 +615,17 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
m m
} }
return $ ColInfo infoInd colSig (zip curLengths infos) return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise | otherwise -> briDocToColInfo lastFlag brdc
-> briDocToColInfo lastFlag brdc
brdc -> return $ ColInfoNo brdc brdc -> return $ ColInfoNo brdc
briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo
briDocToColInfo lastFlag = \case briDocToColInfo lastFlag = \case
BDCols sig list -> withAlloc lastFlag $ \ind -> do BDCols sig list -> withAlloc lastFlag $ \ind -> do
let isLastList = let
if lastFlag then (==length list) <$> [1 ..] else repeat False isLastList =
if lastFlag then (== length list) <$> [1 ..] else repeat False
subInfos <- zip isLastList list `forM` uncurry briDocToColInfo subInfos <- zip isLastList list `forM` uncurry briDocToColInfo
let lengthInfos = zip (briDocLineLength <$> list) subInfos let lengthInfos = zip (briDocLineLength <$> list) subInfos
let trueSpacings = getTrueSpacings lengthInfos let trueSpacings = getTrueSpacings lengthInfos
return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos) return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)
bd -> return $ ColInfoNo bd bd -> return $ ColInfoNo bd
@ -611,11 +633,11 @@ briDocToColInfo lastFlag = \case
getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing] getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]
getTrueSpacings lengthInfos = lengthInfos <&> \case getTrueSpacings lengthInfos = lengthInfos <&> \case
(len, ColInfo i _ _) -> ColumnSpacingRef len i (len, ColInfo i _ _) -> ColumnSpacingRef len i
(len, _ ) -> ColumnSpacingLeaf len (len, _) -> ColumnSpacingLeaf len
withAlloc withAlloc
:: Bool :: Bool
-> ( ColIndex -> ( ColIndex
-> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo) -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)
) )
-> StateS.State ColBuildState ColInfo -> StateS.State ColBuildState ColInfo
@ -630,13 +652,13 @@ withAlloc lastFlag f = do
processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m () processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m ()
processInfo maxSpace m = \case processInfo maxSpace m = \case
ColInfoStart -> error "should not happen (TM)" ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc ColInfoNo doc -> layoutBriDocM doc
ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $ ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $
do do
colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack
alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
curX <- do curX <- do
state <- mGet state <- mGet
-- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state))) -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))
let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state
@ -648,10 +670,11 @@ processInfo maxSpace m = \case
let colMax = min colMaxConf (curX + maxSpace) let colMax = min colMaxConf (curX + maxSpace)
-- tellDebugMess $ show curX -- tellDebugMess $ show curX
let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m
let maxCols2 = list <&> \case let
(_, ColInfo i _ _) -> maxCols2 = list <&> \case
let Just (_, ms, _) = IntMapS.lookup i m in sum ms (_, ColInfo i _ _) ->
(l, _) -> l let Just (_, ms, _) = IntMapS.lookup i m in sum ms
(l, _) -> l
let maxCols = zipWith max maxCols1 maxCols2 let maxCols = zipWith max maxCols1 maxCols2
let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols
-- handle the cases that the vertical alignment leads to more than max -- handle the cases that the vertical alignment leads to more than max
@ -662,46 +685,48 @@ processInfo maxSpace m = \case
-- sizes in such a way that it works _if_ we have sizes (*factor) -- sizes in such a way that it works _if_ we have sizes (*factor)
-- in each column. but in that line, in the last column, we will be -- in each column. but in that line, in the last column, we will be
-- forced to occupy the full vertical space, not reduced by any factor. -- forced to occupy the full vertical space, not reduced by any factor.
let fixedPosXs = case alignMode of let
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX) fixedPosXs = case alignMode of
where ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX)
factor :: Float = where
-- 0.0001 as an offering to the floating point gods. factor :: Float =
min -- 0.0001 as an offering to the floating point gods.
1.0001 min
(fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) 1.0001
offsets = (subtract curX) <$> posXs (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))
fixed = offsets <&> fromIntegral .> (*factor) .> truncate offsets = (subtract curX) <$> posXs
_ -> posXs fixed = offsets <&> fromIntegral .> (* factor) .> truncate
let spacings = zipWith (-) _ -> posXs
(List.tail fixedPosXs ++ [min maxX colMax]) let
fixedPosXs spacings =
zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs
-- tellDebugMess $ "ind = " ++ show ind -- tellDebugMess $ "ind = " ++ show ind
-- tellDebugMess $ "maxCols = " ++ show maxCols -- tellDebugMess $ "maxCols = " ++ show maxCols
-- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs
-- tellDebugMess $ "list = " ++ show list -- tellDebugMess $ "list = " ++ show list
-- tellDebugMess $ "maxSpace = " ++ show maxSpace -- tellDebugMess $ "maxSpace = " ++ show maxSpace
let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do let
layoutWriteEnsureAbsoluteN destX alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
processInfo s m (snd x) layoutWriteEnsureAbsoluteN destX
noAlignAct = list `forM_` (snd .> processInfoIgnore) processInfo s m (snd x)
animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $ noAlignAct = list `forM_` (snd .> processInfoIgnore)
if List.last fixedPosXs + fst (List.last list) > colMax animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $
-- per-item check if there is overflowing. if List.last fixedPosXs + fst (List.last list) > colMax
then noAlignAct -- per-item check if there is overflowing.
else alignAct then noAlignAct
else alignAct
case alignMode of case alignMode of
ColumnAlignModeDisabled -> noAlignAct ColumnAlignModeDisabled -> noAlignAct
ColumnAlignModeUnanimously | maxX <= colMax -> alignAct ColumnAlignModeUnanimously | maxX <= colMax -> alignAct
ColumnAlignModeUnanimously -> noAlignAct ColumnAlignModeUnanimously -> noAlignAct
ColumnAlignModeMajority limit | ratio >= limit -> animousAct ColumnAlignModeMajority limit | ratio >= limit -> animousAct
ColumnAlignModeMajority{} -> noAlignAct ColumnAlignModeMajority{} -> noAlignAct
ColumnAlignModeAnimouslyScale{} -> animousAct ColumnAlignModeAnimouslyScale{} -> animousAct
ColumnAlignModeAnimously -> animousAct ColumnAlignModeAnimously -> animousAct
ColumnAlignModeAlways -> alignAct ColumnAlignModeAlways -> alignAct
processInfoIgnore :: LayoutConstraints m => ColInfo -> m () processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()
processInfoIgnore = \case processInfoIgnore = \case
ColInfoStart -> error "should not happen (TM)" ColInfoStart -> error "should not happen (TM)"
ColInfoNo doc -> layoutBriDocM doc ColInfoNo doc -> layoutBriDocM doc
ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore) ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)

293
source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs
View File

@ -22,17 +22,12 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
traceLocal traceLocal :: (MonadMultiState LayoutState m) => a -> m ()
:: (MonadMultiState LayoutState m)
=> a
-> m ()
traceLocal _ = return () traceLocal _ = return ()
layoutWriteAppend layoutWriteAppend
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Text => Text
-> m () -> m ()
layoutWriteAppend t = do layoutWriteAppend t = do
@ -48,15 +43,13 @@ layoutWriteAppend t = do
mTell $ Text.Builder.fromText $ t mTell $ Text.Builder.fromText $ t
mModify $ \s -> s mModify $ \s -> s
{ _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of
Left c -> c + Text.length t + spaces Left c -> c + Text.length t + spaces
Right{} -> Text.length t + spaces Right{} -> Text.length t + spaces
, _lstate_addSepSpace = Nothing , _lstate_addSepSpace = Nothing
} }
layoutWriteAppendSpaces layoutWriteAppendSpaces
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteAppendSpaces i = do layoutWriteAppendSpaces i = do
@ -64,20 +57,18 @@ layoutWriteAppendSpaces i = do
unless (i == 0) $ do unless (i == 0) $ do
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state
} }
layoutWriteAppendMultiline layoutWriteAppendMultiline
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> [Text] => [Text]
-> m () -> m ()
layoutWriteAppendMultiline ts = do layoutWriteAppendMultiline ts = do
traceLocal ("layoutWriteAppendMultiline", ts) traceLocal ("layoutWriteAppendMultiline", ts)
case ts of case ts of
[] -> layoutWriteAppend (Text.pack "") -- need to write empty, too. [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too.
(l:lr) -> do (l : lr) -> do
layoutWriteAppend l layoutWriteAppend l
lr `forM_` \x -> do lr `forM_` \x -> do
layoutWriteNewline layoutWriteNewline
@ -85,16 +76,15 @@ layoutWriteAppendMultiline ts = do
-- adds a newline and adds spaces to reach the base column. -- adds a newline and adds spaces to reach the base column.
layoutWriteNewlineBlock layoutWriteNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteNewlineBlock = do layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock") traceLocal ("layoutWriteNewlineBlock")
state <- mGet state <- mGet
mSet $ state { _lstate_curYOrAddNewline = Right 1 mSet $ state
, _lstate_addSepSpace = Just $ lstate_baseY state { _lstate_curYOrAddNewline = Right 1
} , _lstate_addSepSpace = Just $ lstate_baseY state
}
-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m -- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m
-- , MonadMultiWriter (Seq String) m) => Int -> m () -- , MonadMultiWriter (Seq String) m) => Int -> m ()
@ -110,13 +100,13 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state -- else _lstate_indLevelLinger state + i - _lstate_curY state
-- } -- }
layoutSetCommentCol layoutSetCommentCol :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutSetCommentCol = do layoutSetCommentCol = do
state <- mGet state <- mGet
let col = case _lstate_curYOrAddNewline state of let
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) col = case _lstate_curYOrAddNewline state of
Right{} -> lstate_baseY state Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Right{} -> lstate_baseY state
traceLocal ("layoutSetCommentCol", col) traceLocal ("layoutSetCommentCol", col)
unless (Data.Maybe.isJust $ _lstate_commentCol state) unless (Data.Maybe.isJust $ _lstate_commentCol state)
$ mSet state { _lstate_commentCol = Just col } $ mSet state { _lstate_commentCol = Just col }
@ -124,9 +114,7 @@ layoutSetCommentCol = do
-- This is also used to move to non-comments in a couple of places. Seems -- This is also used to move to non-comments in a couple of places. Seems
-- to be harmless so far.. -- to be harmless so far..
layoutMoveToCommentPos layoutMoveToCommentPos
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> Int -> Int
-> Int -> Int
@ -136,38 +124,35 @@ layoutMoveToCommentPos y x commentLines = do
state <- mGet state <- mGet
mSet state mSet state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left i -> if y == 0 then Left i else Right y Left i -> if y == 0 then Left i else Right y
Right{} -> Right y Right{} -> Right y
, _lstate_addSepSpace = , _lstate_addSepSpace =
Just $ if Data.Maybe.isJust (_lstate_commentCol state) Just $ if Data.Maybe.isJust (_lstate_commentCol state)
then case _lstate_curYOrAddNewline state of then case _lstate_curYOrAddNewline state of
Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x
Right{} -> _lstate_indLevelLinger state + x Right{} -> _lstate_indLevelLinger state + x
else if y == 0 then x else _lstate_indLevelLinger state + x else if y == 0 then x else _lstate_indLevelLinger state + x
, _lstate_commentCol = , _lstate_commentCol = Just $ case _lstate_commentCol state of
Just $ case _lstate_commentCol state of Just existing -> existing
Just existing -> existing Nothing -> case _lstate_curYOrAddNewline state of
Nothing -> case _lstate_curYOrAddNewline state of Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)
Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) Right{} -> lstate_baseY state
Right{} -> lstate_baseY state
, _lstate_commentNewlines = , _lstate_commentNewlines =
_lstate_commentNewlines state + y + commentLines - 1 _lstate_commentNewlines state + y + commentLines - 1
} }
-- | does _not_ add spaces to again reach the current base column. -- | does _not_ add spaces to again reach the current base column.
layoutWriteNewline layoutWriteNewline
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteNewline = do layoutWriteNewline = do
traceLocal ("layoutWriteNewline") traceLocal ("layoutWriteNewline")
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1 Left{} -> Right 1
Right i -> Right (i + 1) Right i -> Right (i + 1)
, _lstate_addSepSpace = Nothing , _lstate_addSepSpace = Nothing
} }
_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m () _layoutResetCommentNewlines :: MonadMultiState LayoutState m => m ()
@ -175,77 +160,66 @@ _layoutResetCommentNewlines = do
mModify $ \state -> state { _lstate_commentNewlines = 0 } mModify $ \state -> state { _lstate_commentNewlines = 0 }
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteEnsureNewlineBlock = do layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock") traceLocal ("layoutWriteEnsureNewlineBlock")
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of
Left{} -> Right 1 Left{} -> Right 1
Right i -> Right $ max 1 i Right i -> Right $ max 1 i
, _lstate_addSepSpace = Just $ lstate_baseY state , _lstate_addSepSpace = Just $ lstate_baseY state
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
layoutWriteEnsureAbsoluteN layoutWriteEnsureAbsoluteN
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteEnsureAbsoluteN n = do layoutWriteEnsureAbsoluteN n = do
state <- mGet state <- mGet
let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of let
(Just c , _ ) -> n - c diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
(Nothing, Left i ) -> n - i (Just c, _) -> n - c
(Nothing, Right{}) -> n (Nothing, Left i) -> n - i
(Nothing, Right{}) -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
when (diff > 0) $ do when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to
-- at least (Just 1), so we won't -- at least (Just 1), so we won't
-- overwrite any old value in any -- overwrite any old value in any
-- bad way. -- bad way.
}
layoutBaseYPushInternal layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m ()
:: (MonadMultiState LayoutState m)
=> Int
-> m ()
layoutBaseYPushInternal i = do layoutBaseYPushInternal i = do
traceLocal ("layoutBaseYPushInternal", i) traceLocal ("layoutBaseYPushInternal", i)
mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s } mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }
layoutBaseYPopInternal layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPopInternal = do layoutBaseYPopInternal = do
traceLocal ("layoutBaseYPopInternal") traceLocal ("layoutBaseYPopInternal")
mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s } mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }
layoutIndentLevelPushInternal layoutIndentLevelPushInternal :: (MonadMultiState LayoutState m) => Int -> m ()
:: (MonadMultiState LayoutState m)
=> Int
-> m ()
layoutIndentLevelPushInternal i = do layoutIndentLevelPushInternal i = do
traceLocal ("layoutIndentLevelPushInternal", i) traceLocal ("layoutIndentLevelPushInternal", i)
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s
, _lstate_indLevels = i : _lstate_indLevels s { _lstate_indLevelLinger = lstate_indLevel s
} , _lstate_indLevels = i : _lstate_indLevels s
}
layoutIndentLevelPopInternal layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPopInternal = do layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal") traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s
, _lstate_indLevels = List.tail $ _lstate_indLevels s { _lstate_indLevelLinger = lstate_indLevel s
} , _lstate_indLevels = List.tail $ _lstate_indLevels s
}
layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m () layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m ()
layoutRemoveIndentLevelLinger = do layoutRemoveIndentLevelLinger = do
mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s }
}
layoutWithAddBaseCol layoutWithAddBaseCol
:: ( MonadMultiWriter Text.Builder.Builder m :: ( MonadMultiWriter Text.Builder.Builder m
@ -277,9 +251,7 @@ layoutWithAddBaseColBlock m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWithAddBaseColNBlock layoutWithAddBaseColNBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -292,27 +264,23 @@ layoutWithAddBaseColNBlock amount m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWriteEnsureBlock layoutWriteEnsureBlock
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteEnsureBlock = do layoutWriteEnsureBlock = do
traceLocal ("layoutWriteEnsureBlock") traceLocal ("layoutWriteEnsureBlock")
state <- mGet state <- mGet
let let
diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of
(Nothing, Left i ) -> lstate_baseY state - i (Nothing, Left i) -> lstate_baseY state - i
(Nothing, Right{}) -> lstate_baseY state (Nothing, Right{}) -> lstate_baseY state
(Just sp, Left i ) -> max sp (lstate_baseY state - i) (Just sp, Left i) -> max sp (lstate_baseY state - i)
(Just sp, Right{}) -> max sp (lstate_baseY state) (Just sp, Right{}) -> max sp (lstate_baseY state)
-- when (diff>0) $ layoutWriteNewlineBlock -- when (diff>0) $ layoutWriteNewlineBlock
when (diff > 0) $ do when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just $ diff } mSet $ state { _lstate_addSepSpace = Just $ diff }
layoutWithAddBaseColN layoutWithAddBaseColN
:: ( MonadMultiWriter Text.Builder.Builder m :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -322,39 +290,36 @@ layoutWithAddBaseColN amount m = do
m m
layoutBaseYPopInternal layoutBaseYPopInternal
layoutBaseYPushCur layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPushCur = do layoutBaseYPushCur = do
traceLocal ("layoutBaseYPushCur") traceLocal ("layoutBaseYPushCur")
state <- mGet state <- mGet
case _lstate_commentCol state of case _lstate_commentCol state of
Nothing -> Nothing ->
case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Just j ) -> layoutBaseYPushInternal (i + j) (Left i, Just j) -> layoutBaseYPushInternal (i + j)
(Left i , Nothing) -> layoutBaseYPushInternal i (Left i, Nothing) -> layoutBaseYPushInternal i
(Right{}, _ ) -> layoutBaseYPushInternal $ lstate_baseY state (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state
Just cCol -> layoutBaseYPushInternal cCol Just cCol -> layoutBaseYPushInternal cCol
layoutBaseYPop layoutBaseYPop :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop = do layoutBaseYPop = do
traceLocal ("layoutBaseYPop") traceLocal ("layoutBaseYPop")
layoutBaseYPopInternal layoutBaseYPopInternal
layoutIndentLevelPushCur layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPushCur = do layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur") traceLocal ("layoutIndentLevelPushCur")
state <- mGet state <- mGet
let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of let
(Left i , Just j ) -> i + j y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
(Left i , Nothing) -> i (Left i, Just j) -> i + j
(Right{}, Just j ) -> j (Left i, Nothing) -> i
(Right{}, Nothing) -> 0 (Right{}, Just j) -> j
(Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y layoutIndentLevelPushInternal y
layoutIndentLevelPop layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m ()
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPop = do layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop") traceLocal ("layoutIndentLevelPop")
layoutIndentLevelPopInternal layoutIndentLevelPopInternal
@ -364,12 +329,12 @@ layoutIndentLevelPop = do
-- make sense. -- make sense.
layoutRemoveIndentLevelLinger layoutRemoveIndentLevelLinger
layoutAddSepSpace :: (MonadMultiState LayoutState m) layoutAddSepSpace :: (MonadMultiState LayoutState m) => m ()
=> m ()
layoutAddSepSpace = do layoutAddSepSpace = do
state <- mGet state <- mGet
mSet $ state mSet $ state
{ _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state } { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state
}
-- TODO: when refactoring is complete, the other version of this method -- TODO: when refactoring is complete, the other version of this method
-- can probably be removed. -- can probably be removed.
@ -384,7 +349,7 @@ moveToExactAnn annKey = do
traceLocal ("moveToExactAnn", annKey) traceLocal ("moveToExactAnn", annKey)
anns <- mAsk anns <- mAsk
case Map.lookup annKey anns of case Map.lookup annKey anns of
Nothing -> return () Nothing -> return ()
Just ann -> do Just ann -> do
-- curY <- mGet <&> _lstate_curY -- curY <- mGet <&> _lstate_curY
let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann
@ -393,19 +358,19 @@ moveToExactAnn annKey = do
moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY :: MonadMultiState LayoutState m => Int -> m ()
moveToY y = mModify $ \state -> moveToY y = mModify $ \state ->
let upd = case _lstate_curYOrAddNewline state of let
Left i -> if y == 0 then Left i else Right y upd = case _lstate_curYOrAddNewline state of
Right i -> Right $ max y i Left i -> if y == 0 then Left i else Right y
in state Right i -> Right $ max y i
{ _lstate_curYOrAddNewline = upd in
, _lstate_addSepSpace = if Data.Either.isRight upd state
then { _lstate_curYOrAddNewline = upd
_lstate_commentCol state , _lstate_addSepSpace = if Data.Either.isRight upd
<|> _lstate_addSepSpace state then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just
<|> Just (lstate_baseY state) (lstate_baseY state)
else Nothing else Nothing
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
-- fixMoveToLineByIsNewline :: MonadMultiState -- fixMoveToLineByIsNewline :: MonadMultiState
-- LayoutState m => Int -> m Int -- LayoutState m => Int -> m Int
-- fixMoveToLineByIsNewline x = do -- fixMoveToLineByIsNewline x = do
@ -415,9 +380,7 @@ moveToY y = mModify $ \state ->
-- else x -- else x
ppmMoveToExactLoc ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()
=> ExactPrint.DeltaPos
-> m ()
ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do
replicateM_ x $ mTell $ Text.Builder.fromString "\n" replicateM_ x $ mTell $ Text.Builder.fromString "\n"
replicateM_ y $ mTell $ Text.Builder.fromString " " replicateM_ y $ mTell $ Text.Builder.fromString " "
@ -433,75 +396,77 @@ layoutWritePriorComments
layoutWritePriorComments ast = do layoutWritePriorComments ast = do
mAnn <- do mAnn <- do
state <- mGet state <- mGet
let key = ExactPrint.mkAnnKey ast let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state let anns = _lstate_comments state
let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns
mSet $ state mSet $ state
{ _lstate_comments = { _lstate_comments = Map.adjust
Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns (\ann -> ann { ExactPrint.annPriorComments = [] })
key
anns
} }
return mAnn return mAnn
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just priors -> do Just priors -> do
unless (null priors) $ layoutSetCommentCol unless (null priors) $ layoutSetCommentCol
priors `forM_` \( ExactPrint.Comment comment _ _ priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
, ExactPrint.DP (x, y) do
) -> do replicateM_ x layoutWriteNewline
replicateM_ x layoutWriteNewline layoutWriteAppendSpaces y
layoutWriteAppendSpaces y layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
-- TODO: update and use, or clean up. Currently dead code. -- TODO: update and use, or clean up. Currently dead code.
-- this currently only extracs from the `annsDP` field of Annotations. -- this currently only extracs from the `annsDP` field of Annotations.
-- per documentation, this seems sufficient, as the -- per documentation, this seems sufficient, as the
-- "..`annFollowingComments` are only added by AST transformations ..". -- "..`annFollowingComments` are only added by AST transformations ..".
layoutWritePostComments :: (Data.Data.Data ast, layoutWritePostComments
MonadMultiWriter Text.Builder.Builder m, :: ( Data.Data.Data ast
MonadMultiState LayoutState m) , MonadMultiWriter Text.Builder.Builder m
=> Located ast -> m () , MonadMultiState LayoutState m
)
=> Located ast
-> m ()
layoutWritePostComments ast = do layoutWritePostComments ast = do
mAnn <- do mAnn <- do
state <- mGet state <- mGet
let key = ExactPrint.mkAnnKey ast let key = ExactPrint.mkAnnKey ast
let anns = _lstate_comments state let anns = _lstate_comments state
let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns
mSet $ state mSet $ state
{ _lstate_comments = { _lstate_comments = Map.adjust
Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] }) (\ann -> ann { ExactPrint.annFollowingComments = [] })
key key
anns anns
} }
return mAnn return mAnn
case mAnn of case mAnn of
Nothing -> return () Nothing -> return ()
Just posts -> do Just posts -> do
unless (null posts) $ layoutSetCommentCol unless (null posts) $ layoutSetCommentCol
posts `forM_` \( ExactPrint.Comment comment _ _ posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->
, ExactPrint.DP (x, y) do
) -> do replicateM_ x layoutWriteNewline
replicateM_ x layoutWriteNewline layoutWriteAppend $ Text.pack $ replicate y ' '
layoutWriteAppend $ Text.pack $ replicate y ' ' mModify $ \s -> s { _lstate_addSepSpace = Nothing }
mModify $ \s -> s { _lstate_addSepSpace = Nothing } layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment
layoutIndentRestorePostComment layoutIndentRestorePostComment
:: ( MonadMultiState LayoutState m :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)
, MonadMultiWriter Text.Builder.Builder m
)
=> m () => m ()
layoutIndentRestorePostComment = do layoutIndentRestorePostComment = do
state <- mGet state <- mGet
let mCommentCol = _lstate_commentCol state let mCommentCol = _lstate_commentCol state
let eCurYAddNL = _lstate_curYOrAddNewline state let eCurYAddNL = _lstate_curYOrAddNewline state
mModify $ \s -> s { _lstate_commentCol = Nothing mModify
, _lstate_commentNewlines = 0 $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 }
}
case (mCommentCol, eCurYAddNL) of case (mCommentCol, eCurYAddNL) of
(Just commentCol, Left{}) -> do (Just commentCol, Left{}) -> do
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state) layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe
_ -> return () 0
(_lstate_addSepSpace state)
_ -> return ()
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,
-- MonadMultiWriter Text.Builder.Builder m, -- MonadMultiWriter Text.Builder.Builder m,

232
source/library/Language/Haskell/Brittany/Internal/Config.hs
View File

@ -27,151 +27,151 @@ import UI.Butcher.Monadic
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
staticDefaultConfig :: Config staticDefaultConfig :: Config
staticDefaultConfig = Config staticDefaultConfig = Config
{ _conf_version = coerce (1 :: Int) { _conf_version = coerce (1 :: Int)
, _conf_debug = DebugConfig , _conf_debug = DebugConfig
{ _dconf_dump_config = coerce False { _dconf_dump_config = coerce False
, _dconf_dump_annotations = coerce False , _dconf_dump_annotations = coerce False
, _dconf_dump_ast_unknown = coerce False , _dconf_dump_ast_unknown = coerce False
, _dconf_dump_ast_full = coerce False , _dconf_dump_ast_full = coerce False
, _dconf_dump_bridoc_raw = coerce False , _dconf_dump_bridoc_raw = coerce False
, _dconf_dump_bridoc_simpl_alt = coerce False , _dconf_dump_bridoc_simpl_alt = coerce False
, _dconf_dump_bridoc_simpl_floating = coerce False , _dconf_dump_bridoc_simpl_floating = coerce False
, _dconf_dump_bridoc_simpl_par = coerce False , _dconf_dump_bridoc_simpl_par = coerce False
, _dconf_dump_bridoc_simpl_columns = coerce False , _dconf_dump_bridoc_simpl_columns = coerce False
, _dconf_dump_bridoc_simpl_indent = coerce False , _dconf_dump_bridoc_simpl_indent = coerce False
, _dconf_dump_bridoc_final = coerce False , _dconf_dump_bridoc_final = coerce False
, _dconf_roundtrip_exactprint_only = coerce False , _dconf_roundtrip_exactprint_only = coerce False
} }
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = coerce (80 :: Int) { _lconfig_cols = coerce (80 :: Int)
, _lconfig_indentPolicy = coerce IndentPolicyFree , _lconfig_indentPolicy = coerce IndentPolicyFree
, _lconfig_indentAmount = coerce (2 :: Int) , _lconfig_indentAmount = coerce (2 :: Int)
, _lconfig_indentWhereSpecial = coerce True , _lconfig_indentWhereSpecial = coerce True
, _lconfig_indentListSpecial = coerce True , _lconfig_indentListSpecial = coerce True
, _lconfig_importColumn = coerce (50 :: Int) , _lconfig_importColumn = coerce (50 :: Int)
, _lconfig_importAsColumn = coerce (50 :: Int) , _lconfig_importAsColumn = coerce (50 :: Int)
, _lconfig_altChooser = coerce (AltChooserBoundedSearch 3) , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7) , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
, _lconfig_alignmentLimit = coerce (30 :: Int) , _lconfig_alignmentLimit = coerce (30 :: Int)
, _lconfig_alignmentBreakOnMultiline = coerce True , _lconfig_alignmentBreakOnMultiline = coerce True
, _lconfig_hangingTypeSignature = coerce False , _lconfig_hangingTypeSignature = coerce False
, _lconfig_reformatModulePreamble = coerce True , _lconfig_reformatModulePreamble = coerce True
, _lconfig_allowSingleLineExportList = coerce False , _lconfig_allowSingleLineExportList = coerce False
, _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False , _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = coerce False -- , _lconfig_allowSinglelineRecord = coerce False
} }
, _conf_errorHandling = ErrorHandlingConfig , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False { _econf_produceOutputOnErrors = coerce False
, _econf_Werror = coerce False , _econf_Werror = coerce False
, _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline
, _econf_omit_output_valid_check = coerce False , _econf_omit_output_valid_check = coerce False
} }
, _conf_preprocessor = PreProcessorConfig , _conf_preprocessor = PreProcessorConfig
{ _ppconf_CPPMode = coerce CPPModeAbort { _ppconf_CPPMode = coerce CPPModeAbort
, _ppconf_hackAroundIncludes = coerce False , _ppconf_hackAroundIncludes = coerce False
} }
, _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_forward = ForwardOptions { _options_ghc = Identity [] }
, _conf_roundtrip_exactprint_only = coerce False , _conf_roundtrip_exactprint_only = coerce False
, _conf_disable_formatting = coerce False , _conf_disable_formatting = coerce False
, _conf_obfuscate = coerce False , _conf_obfuscate = coerce False
} }
forwardOptionsSyntaxExtsEnabled :: ForwardOptions forwardOptionsSyntaxExtsEnabled :: ForwardOptions
forwardOptionsSyntaxExtsEnabled = ForwardOptions forwardOptionsSyntaxExtsEnabled = ForwardOptions
{ _options_ghc = Identity { _options_ghc = Identity
[ "-XLambdaCase" [ "-XLambdaCase"
, "-XMultiWayIf" , "-XMultiWayIf"
, "-XGADTs" , "-XGADTs"
, "-XPatternGuards" , "-XPatternGuards"
, "-XViewPatterns" , "-XViewPatterns"
, "-XTupleSections" , "-XTupleSections"
, "-XExplicitForAll" , "-XExplicitForAll"
, "-XImplicitParams" , "-XImplicitParams"
, "-XQuasiQuotes" , "-XQuasiQuotes"
, "-XTemplateHaskell" , "-XTemplateHaskell"
, "-XBangPatterns" , "-XBangPatterns"
, "-XTypeApplications" , "-XTypeApplications"
] ]
} }
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 } -- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 }
cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe) cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe)
cmdlineConfigParser = do cmdlineConfigParser = do
-- TODO: why does the default not trigger; ind never should be []!! -- TODO: why does the default not trigger; ind never should be []!!
ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level") ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")
cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)") 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") 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") 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)") 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") 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") 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") dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc") 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") 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") 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") 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") 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") 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") 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)") 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")
omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)") 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)") 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.") 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.") 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.") obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.")
return $ Config return $ Config
{ _conf_version = mempty { _conf_version = mempty
, _conf_debug = DebugConfig , _conf_debug = DebugConfig
{ _dconf_dump_config = wrapLast $ falseToNothing dumpConfig { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig
, _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations
, _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST
, _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST
, _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw
, _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt
, _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar
, _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating
, _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns
, _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent
, _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal
, _dconf_roundtrip_exactprint_only = mempty , _dconf_roundtrip_exactprint_only = mempty
} }
, _conf_layout = LayoutConfig , _conf_layout = LayoutConfig
{ _lconfig_cols = optionConcat cols { _lconfig_cols = optionConcat cols
, _lconfig_indentPolicy = mempty , _lconfig_indentPolicy = mempty
, _lconfig_indentAmount = optionConcat ind , _lconfig_indentAmount = optionConcat ind
, _lconfig_indentWhereSpecial = mempty -- falseToNothing _ , _lconfig_indentWhereSpecial = mempty -- falseToNothing _
, _lconfig_indentListSpecial = mempty -- falseToNothing _ , _lconfig_indentListSpecial = mempty -- falseToNothing _
, _lconfig_importColumn = optionConcat importCol , _lconfig_importColumn = optionConcat importCol
, _lconfig_importAsColumn = optionConcat importAsCol , _lconfig_importAsColumn = optionConcat importAsCol
, _lconfig_altChooser = mempty , _lconfig_altChooser = mempty
, _lconfig_columnAlignMode = mempty , _lconfig_columnAlignMode = mempty
, _lconfig_alignmentLimit = mempty , _lconfig_alignmentLimit = mempty
, _lconfig_alignmentBreakOnMultiline = mempty , _lconfig_alignmentBreakOnMultiline = mempty
, _lconfig_hangingTypeSignature = mempty , _lconfig_hangingTypeSignature = mempty
, _lconfig_reformatModulePreamble = mempty , _lconfig_reformatModulePreamble = mempty
, _lconfig_allowSingleLineExportList = mempty , _lconfig_allowSingleLineExportList = mempty
, _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_allowHangingQuasiQuotes = mempty
, _lconfig_experimentalSemicolonNewlines = mempty , _lconfig_experimentalSemicolonNewlines = mempty
-- , _lconfig_allowSinglelineRecord = mempty -- , _lconfig_allowSinglelineRecord = mempty
} }
, _conf_errorHandling = ErrorHandlingConfig , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors
, _econf_Werror = wrapLast $ falseToNothing wError , _econf_Werror = wrapLast $ falseToNothing wError
, _econf_ExactPrintFallback = mempty , _econf_ExactPrintFallback = mempty
, _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck
} }
, _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty } , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty }
, _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] } , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] }
, _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly
, _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting
, _conf_obfuscate = wrapLast $ falseToNothing obfuscate , _conf_obfuscate = wrapLast $ falseToNothing obfuscate
} }
where where
falseToNothing = Bool.bool Nothing (Just True) falseToNothing = Bool.bool Nothing (Just True)
@ -218,8 +218,8 @@ readConfig path = do
fileConf <- case Data.Yaml.decodeEither' contents of fileConf <- case Data.Yaml.decodeEither' contents of
Left e -> do Left e -> do
liftIO liftIO
$ putStrErrLn $ putStrErrLn
$ "error reading in brittany config from " $ "error reading in brittany config from "
++ path ++ path
++ ":" ++ ":"
liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e) liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e)
@ -233,11 +233,12 @@ readConfig path = do
userConfigPath :: IO System.IO.FilePath userConfigPath :: IO System.IO.FilePath
userConfigPath = do userConfigPath = do
userBritPathSimple <- Directory.getAppUserDataDirectory "brittany" userBritPathSimple <- Directory.getAppUserDataDirectory "brittany"
userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany" userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany"
let searchDirs = [userBritPathSimple, userBritPathXdg] let searchDirs = [userBritPathSimple, userBritPathXdg]
globalConfig <- Directory.findFileWith Directory.doesFileExist globalConfig <- Directory.findFileWith
searchDirs Directory.doesFileExist
"config.yaml" searchDirs
"config.yaml"
maybe (writeUserConfig userBritPathXdg) pure globalConfig maybe (writeUserConfig userBritPathXdg) pure globalConfig
where where
writeUserConfig dir = do writeUserConfig dir = do
@ -249,7 +250,7 @@ userConfigPath = do
-- | Searches for a local (per-project) brittany config starting from a given directory -- | Searches for a local (per-project) brittany config starting from a given directory
findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath) findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath)
findLocalConfigPath dir = do findLocalConfigPath dir = do
let dirParts = FilePath.splitDirectories dir let dirParts = FilePath.splitDirectories dir
-- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"] -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"]
let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts) let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts)
Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml" Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml"
@ -261,8 +262,9 @@ readConfigs
-> MaybeT IO Config -> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do readConfigs cmdlineConfig configPaths = do
configs <- readConfig `mapM` configPaths configs <- readConfig `mapM` configPaths
let merged = Semigroup.sconcat let
$ NonEmpty.reverse (cmdlineConfig :| catMaybes configs) merged =
Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
return $ cZipWith fromOptionIdentity staticDefaultConfig merged return $ cZipWith fromOptionIdentity staticDefaultConfig merged
-- | Reads provided configs -- | Reads provided configs

65
source/library/Language/Haskell/Brittany/Internal/Config/Types.hs
View File

@ -23,40 +23,40 @@ confUnpack :: Coercible a b => Identity a -> b
confUnpack (Identity x) = coerce x confUnpack (Identity x) = coerce x
data CDebugConfig f = DebugConfig data CDebugConfig f = DebugConfig
{ _dconf_dump_config :: f (Semigroup.Last Bool) { _dconf_dump_config :: f (Semigroup.Last Bool)
, _dconf_dump_annotations :: f (Semigroup.Last Bool) , _dconf_dump_annotations :: f (Semigroup.Last Bool)
, _dconf_dump_ast_unknown :: f (Semigroup.Last Bool) , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool)
, _dconf_dump_ast_full :: f (Semigroup.Last Bool) , _dconf_dump_ast_full :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_raw :: 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_alt :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_floating :: 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_par :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_simpl_columns :: 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_simpl_indent :: f (Semigroup.Last Bool)
, _dconf_dump_bridoc_final :: f (Semigroup.Last Bool) , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool)
, _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
data CLayoutConfig f = LayoutConfig data CLayoutConfig f = LayoutConfig
{ _lconfig_cols :: f (Last Int) -- the thing that has default 80. { _lconfig_cols :: f (Last Int) -- the thing that has default 80.
, _lconfig_indentPolicy :: f (Last IndentPolicy) , _lconfig_indentPolicy :: f (Last IndentPolicy)
, _lconfig_indentAmount :: f (Last Int) , _lconfig_indentAmount :: f (Last Int)
, _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO). , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO).
, _lconfig_indentListSpecial :: f (Last 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 (Last Int) , _lconfig_importColumn :: f (Last Int)
-- ^ for import statement layouting, column at which to align the -- ^ for import statement layouting, column at which to align the
-- elements to be imported from a module. -- elements to be imported from a module.
-- It is expected that importAsColumn >= importCol. -- It is expected that importAsColumn >= importCol.
, _lconfig_importAsColumn :: f (Last Int) , _lconfig_importAsColumn :: f (Last Int)
-- ^ for import statement layouting, column at which put the module's -- ^ for import statement layouting, column at which put the module's
-- "as" name (which also affects the positioning of the "as" keyword). -- "as" name (which also affects the positioning of the "as" keyword).
-- It is expected that importAsColumn >= importCol. -- It is expected that importAsColumn >= importCol.
, _lconfig_altChooser :: f (Last AltChooser) , _lconfig_altChooser :: f (Last AltChooser)
, _lconfig_columnAlignMode :: f (Last ColumnAlignMode) , _lconfig_columnAlignMode :: f (Last ColumnAlignMode)
, _lconfig_alignmentLimit :: f (Last Int) , _lconfig_alignmentLimit :: f (Last Int)
-- roughly speaking, this sets an upper bound to the number of spaces -- roughly speaking, this sets an upper bound to the number of spaces
-- inserted to create horizontal alignment. -- inserted to create horizontal alignment.
-- More specifically, if 'xs' are the widths of the columns in some -- More specifically, if 'xs' are the widths of the columns in some
@ -141,17 +141,17 @@ data CLayoutConfig f = LayoutConfig
-- -- > , y :: Double -- -- > , y :: Double
-- -- > } -- -- > }
} }
deriving (Generic) deriving Generic
data CForwardOptions f = ForwardOptions data CForwardOptions f = ForwardOptions
{ _options_ghc :: f [String] { _options_ghc :: f [String]
} }
deriving (Generic) deriving Generic
data CErrorHandlingConfig f = ErrorHandlingConfig data CErrorHandlingConfig f = ErrorHandlingConfig
{ _econf_produceOutputOnErrors :: f (Semigroup.Last Bool) { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)
, _econf_Werror :: f (Semigroup.Last Bool) , _econf_Werror :: f (Semigroup.Last Bool)
, _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode) , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode)
-- ^ Determines when to fall back on the exactprint'ed output when -- ^ Determines when to fall back on the exactprint'ed output when
-- syntactical constructs are encountered which are not yet handled by -- syntactical constructs are encountered which are not yet handled by
-- brittany. -- brittany.
@ -161,21 +161,21 @@ data CErrorHandlingConfig f = ErrorHandlingConfig
-- has different semantics than the code pre-transformation. -- has different semantics than the code pre-transformation.
, _econf_omit_output_valid_check :: f (Semigroup.Last Bool) , _econf_omit_output_valid_check :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
data CPreProcessorConfig f = PreProcessorConfig data CPreProcessorConfig f = PreProcessorConfig
{ _ppconf_CPPMode :: f (Semigroup.Last CPPMode) { _ppconf_CPPMode :: f (Semigroup.Last CPPMode)
, _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool) , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
data CConfig f = Config data CConfig f = Config
{ _conf_version :: f (Semigroup.Last Int) { _conf_version :: f (Semigroup.Last Int)
, _conf_debug :: CDebugConfig f , _conf_debug :: CDebugConfig f
, _conf_layout :: CLayoutConfig f , _conf_layout :: CLayoutConfig f
, _conf_errorHandling :: CErrorHandlingConfig f , _conf_errorHandling :: CErrorHandlingConfig f
, _conf_forward :: CForwardOptions f , _conf_forward :: CForwardOptions f
, _conf_preprocessor :: CPreProcessorConfig f , _conf_preprocessor :: CPreProcessorConfig f
, _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool) , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)
-- ^ this field is somewhat of a duplicate of the one in DebugConfig. -- ^ this field is somewhat of a duplicate of the one in DebugConfig.
-- It is used for per-declaration disabling by the inline config -- It is used for per-declaration disabling by the inline config
@ -186,10 +186,9 @@ data CConfig f = Config
-- module. Useful for wildcard application -- module. Useful for wildcard application
-- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something
-- in that direction). -- in that direction).
, _conf_obfuscate :: f (Semigroup.Last Bool) , _conf_obfuscate :: f (Semigroup.Last Bool)
} }
deriving (Generic) deriving Generic
type DebugConfig = CDebugConfig Identity type DebugConfig = CDebugConfig Identity
type LayoutConfig = CLayoutConfig Identity type LayoutConfig = CLayoutConfig Identity

34
source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs
View File

@ -29,7 +29,7 @@ import Language.Haskell.Brittany.Internal.Prelude
aesonDecodeOptionsBrittany :: Aeson.Options aesonDecodeOptionsBrittany :: Aeson.Options
aesonDecodeOptionsBrittany = Aeson.defaultOptions aesonDecodeOptionsBrittany = Aeson.defaultOptions
{ Aeson.omitNothingFields = True { Aeson.omitNothingFields = True
, Aeson.fieldLabelModifier = dropWhile (=='_') , Aeson.fieldLabelModifier = dropWhile (== '_')
} }
instance FromJSON (CDebugConfig Maybe) where instance FromJSON (CDebugConfig Maybe) where
@ -104,17 +104,27 @@ instance ToJSON (CConfig Maybe) where
-- leafs, but for nodes of the config as well. This way e.g. "{}" is valid -- leafs, but for nodes of the config as well. This way e.g. "{}" is valid
-- config file content. -- config file content.
instance FromJSON (CConfig Maybe) where instance FromJSON (CConfig Maybe) where
parseJSON (Object v) = Config parseJSON (Object v) =
<$> v .:? Key.fromString "conf_version" Config
<*> v .:?= Key.fromString "conf_debug" <$> v
<*> v .:?= Key.fromString "conf_layout" .:? Key.fromString "conf_version"
<*> v .:?= Key.fromString "conf_errorHandling" <*> v
<*> v .:?= Key.fromString "conf_forward" .:?= Key.fromString "conf_debug"
<*> v .:?= Key.fromString "conf_preprocessor" <*> v
<*> v .:? Key.fromString "conf_roundtrip_exactprint_only" .:?= Key.fromString "conf_layout"
<*> v .:? Key.fromString "conf_disable_formatting" <*> v
<*> v .:? Key.fromString "conf_obfuscate" .:?= Key.fromString "conf_errorHandling"
parseJSON invalid = Aeson.typeMismatch "Config" invalid <*> v
.:?= Key.fromString "conf_forward"
<*> v
.:?= Key.fromString "conf_preprocessor"
<*> v
.:? Key.fromString "conf_roundtrip_exactprint_only"
<*> v
.:? Key.fromString "conf_disable_formatting"
<*> v
.:? Key.fromString "conf_obfuscate"
parseJSON invalid = Aeson.typeMismatch "Config" invalid
-- Pretends that the value is {} when the key is not present. -- Pretends that the value is {} when the key is not present.
(.:?=) :: FromJSON a => Object -> Key.Key -> Parser a (.:?=) :: FromJSON a => Object -> Key.Key -> Parser a

87
source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs
View File

@ -53,26 +53,30 @@ parseModuleFromString = ParseModule.parseModule
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do commentAnnFixTransformGlob ast = do
let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey) let
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
const Seq.empty extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
`SYB.ext1Q` const Seq.empty
(\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l)) `SYB.ext1Q` (\l@(L span _) ->
Seq.singleton (span, ExactPrint.mkAnnKey l)
)
let nodes = SYB.everything (<>) extract ast let nodes = SYB.everything (<>) extract ast
let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey let
annsMap = Map.fromListWith annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
(const id) annsMap = Map.fromListWith
[ (GHC.realSrcSpanEnd span, annKey) (const id)
| (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes [ (GHC.realSrcSpanEnd span, annKey)
] | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes
]
nodes `forM_` (snd .> processComs annsMap) nodes `forM_` (snd .> processComs annsMap)
where where
processComs annsMap annKey1 = do processComs annsMap annKey1 = do
mAnn <- State.Class.gets fst <&> Map.lookup annKey1 mAnn <- State.Class.gets fst <&> Map.lookup annKey1
mAnn `forM_` \ann1 -> do mAnn `forM_` \ann1 -> do
let priors = ExactPrint.annPriorComments ann1 let
follows = ExactPrint.annFollowingComments ann1 priors = ExactPrint.annPriorComments ann1
assocs = ExactPrint.annsDP ann1 follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1
let let
processCom processCom
:: (ExactPrint.Comment, ExactPrint.DeltaPos) :: (ExactPrint.Comment, ExactPrint.DeltaPos)
@ -84,31 +88,32 @@ commentAnnFixTransformGlob ast = do
(ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") -> (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->
move $> False move $> False
(x, y) | x == y -> move $> False (x, y) | x == y -> move $> False
_ -> return True _ -> return True
where where
ExactPrint.AnnKey annKeyLoc1 con1 = annKey1 ExactPrint.AnnKey annKeyLoc1 con1 = annKey1
ExactPrint.AnnKey annKeyLoc2 con2 = annKey2 ExactPrint.AnnKey annKeyLoc2 con2 = annKey2
loc1 = GHC.realSrcSpanStart annKeyLoc1 loc1 = GHC.realSrcSpanStart annKeyLoc1
loc2 = GHC.realSrcSpanStart annKeyLoc2 loc2 = GHC.realSrcSpanStart annKeyLoc2
move = ExactPrint.modifyAnnsT $ \anns -> move = ExactPrint.modifyAnnsT $ \anns ->
let let
ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns
ann2' = ann2 ann2' = ann2
{ ExactPrint.annFollowingComments = { ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair] ExactPrint.annFollowingComments ann2 ++ [comPair]
} }
in in Map.insert annKey2 ann2' anns
Map.insert annKey2 ann2' anns
_ -> return True -- retain comment at current node. _ -> return True -- retain comment at current node.
priors' <- filterM processCom priors priors' <- filterM processCom priors
follows' <- filterM processCom follows follows' <- filterM processCom follows
assocs' <- flip filterM assocs $ \case assocs' <- flip filterM assocs $ \case
(ExactPrint.AnnComment com, dp) -> processCom (com, dp) (ExactPrint.AnnComment com, dp) -> processCom (com, dp)
_ -> return True _ -> return True
let ann1' = ann1 { ExactPrint.annPriorComments = priors' let
, ExactPrint.annFollowingComments = follows' ann1' = ann1
, ExactPrint.annsDP = assocs' { ExactPrint.annPriorComments = priors'
} , ExactPrint.annFollowingComments = follows'
, ExactPrint.annsDP = assocs'
}
ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns
@ -196,29 +201,30 @@ extractToplevelAnns lmod anns = output
| (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns
] ]
declMap = declMap1 `Map.union` declMap2 declMap = declMap1 `Map.union` declMap2
modKey = ExactPrint.mkAnnKey lmod modKey = ExactPrint.mkAnnKey lmod
output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns output = groupMap (\k _ -> Map.findWithDefault modKey k declMap) anns
groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a) groupMap :: (Ord k, Ord l) => (k -> a -> l) -> Map k a -> Map l (Map k a)
groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m) groupMap f = Map.foldlWithKey'
Map.empty (\m k a -> Map.alter (insert k a) (f k a) m)
Map.empty
where where
insert k a Nothing = Just (Map.singleton k a) insert k a Nothing = Just (Map.singleton k a)
insert k a (Just m) = Just (Map.insert k a m) insert k a (Just m) = Just (Map.insert k a m)
foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey
foldedAnnKeys ast = SYB.everything foldedAnnKeys ast = SYB.everything
Set.union Set.union
( \x -> maybe (\x -> maybe
Set.empty Set.empty
Set.singleton Set.singleton
[ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x
| locTyCon == SYB.typeRepTyCon (SYB.typeOf x) | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)
, l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x
]
-- for some reason, ghc-8.8 has forgotten how to infer the type of l, -- for some reason, ghc-8.8 has forgotten how to infer the type of l,
-- even though it is passed to mkAnnKey above, which only accepts -- even though it is passed to mkAnnKey above, which only accepts
-- SrcSpan. -- SrcSpan.
]
) )
ast ast
where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ())) where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))
@ -227,8 +233,8 @@ foldedAnnKeys ast = SYB.everything
withTransformedAnns withTransformedAnns
:: Data ast :: Data ast
=> ast => ast
-> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
-> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a
withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
readers@(conf :+: anns :+: HNil) -> do readers@(conf :+: anns :+: HNil) -> do
-- TODO: implement `local` for MultiReader/MultiRWS -- TODO: implement `local` for MultiReader/MultiRWS
@ -238,9 +244,10 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
pure x pure x
where where
f anns = f anns =
let ((), (annsBalanced, _), _) = let
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) ((), (annsBalanced, _), _) =
in annsBalanced ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced
warnExtractorCompat :: GHC.Warn -> String warnExtractorCompat :: GHC.Warn -> String

168
source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs
View File

@ -56,7 +56,7 @@ processDefault x = do
-- the module (header). This would remove the need for this hack! -- the module (header). This would remove the need for this hack!
case str of case str of
"\n" -> return () "\n" -> return ()
_ -> mTell $ Text.Builder.fromString str _ -> mTell $ Text.Builder.fromString str
-- | Use ExactPrint's output for this node; add a newly generated inline comment -- | Use ExactPrint's output for this node; add a newly generated inline comment
-- at insertion position (meant to point out to the user that this node is -- at insertion position (meant to point out to the user that this node is
@ -68,9 +68,10 @@ briDocByExact
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExact ast = do briDocByExact ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" traceIfDumpConf
_dconf_dump_ast_unknown "ast"
(printTreeWithCustom 100 (customLayouterF anns) ast) _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns True docExt ast anns True
-- | Use ExactPrint's output for this node. -- | Use ExactPrint's output for this node.
@ -84,9 +85,10 @@ briDocByExactNoComment
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do briDocByExactNoComment ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" traceIfDumpConf
_dconf_dump_ast_unknown "ast"
(printTreeWithCustom 100 (customLayouterF anns) ast) _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False docExt ast anns False
-- | Use ExactPrint's output for this node, presuming that this output does -- | Use ExactPrint's output for this node, presuming that this output does
@ -99,24 +101,26 @@ briDocByExactInlineOnly
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do briDocByExactInlineOnly infoStr ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf "ast" traceIfDumpConf
_dconf_dump_ast_unknown "ast"
(printTreeWithCustom 100 (customLayouterF anns) ast) _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast)
let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns
fallbackMode <- fallbackMode <-
mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack
let exactPrintNode t = allocateNode $ BDFExternal let
(ExactPrint.Types.mkAnnKey ast) exactPrintNode t = allocateNode $ BDFExternal
(foldedAnnKeys ast) (ExactPrint.Types.mkAnnKey ast)
False (foldedAnnKeys ast)
t False
let errorAction = do t
mTell [ErrorUnknownNode infoStr ast] let
docLit errorAction = do
$ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" mTell [ErrorUnknownNode infoStr ast]
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"
case (fallbackMode, Text.lines exactPrinted) of case (fallbackMode, Text.lines exactPrinted) of
(ExactPrintFallbackModeNever, _ ) -> errorAction (ExactPrintFallbackModeNever, _) -> errorAction
(_ , [t]) -> exactPrintNode (_, [t]) -> exactPrintNode
(Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t) (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)
(ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted
_ -> errorAction _ -> errorAction
@ -141,20 +145,21 @@ lrdrNameToTextAnnGen
lrdrNameToTextAnnGen f ast@(L _ n) = do lrdrNameToTextAnnGen f ast@(L _ n) = do
anns <- mAsk anns <- mAsk
let t = f $ rdrNameToText n let t = f $ rdrNameToText n
let hasUni x (ExactPrint.Types.G y, _) = x == y let
hasUni _ _ = False hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False
-- TODO: in general: we should _always_ process all annotaiton stuff here. -- TODO: in general: we should _always_ process all annotaiton stuff here.
-- whatever we don't probably should have had some effect on the -- whatever we don't probably should have had some effect on the
-- output. in such cases, resorting to byExact is probably the safe -- output. in such cases, resorting to byExact is probably the safe
-- choice. -- choice.
return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
Nothing -> t Nothing -> t
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of
Exact{} | t == Text.pack "()" -> t Exact{} | t == Text.pack "()" -> t
_ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`" _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
_ | any (hasUni AnnCommaTuple) aks -> t _ | any (hasUni AnnCommaTuple) aks -> t
_ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")" _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"
_ | otherwise -> t _ | otherwise -> t
lrdrNameToTextAnn lrdrNameToTextAnn
:: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m) :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)
@ -167,9 +172,10 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
=> Located RdrName => Located RdrName
-> m Text -> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let f x = if x == Text.pack "Data.Type.Equality~" let
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh f x = if x == Text.pack "Data.Type.Equality~"
else x then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
lrdrNameToTextAnnGen f ast lrdrNameToTextAnnGen f ast
-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects -- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects
@ -187,10 +193,11 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
-> m Text -> m Text
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
x <- lrdrNameToTextAnn ast2 x <- lrdrNameToTextAnn ast2
let lit = if x == Text.pack "Data.Type.Equality~" let
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh lit = if x == Text.pack "Data.Type.Equality~"
else x then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x
return $ if hasQuote then Text.cons '\'' lit else lit return $ if hasQuote then Text.cons '\'' lit else lit
askIndent :: (MonadMultiReader Config m) => m Int askIndent :: (MonadMultiReader Config m) => m Int
@ -208,12 +215,11 @@ extractRestComments ann =
ExactPrint.annFollowingComments ann ExactPrint.annFollowingComments ann
++ (ExactPrint.annsDP ann >>= \case ++ (ExactPrint.annsDP ann >>= \case
(ExactPrint.AnnComment com, dp) -> [(com, dp)] (ExactPrint.AnnComment com, dp) -> [(com, dp)]
_ -> [] _ -> []
) )
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast = filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)
-- | True if there are any comments that are -- | True if there are any comments that are
-- a) connected to any node below (in AST sense) the given node AND -- a) connected to any node below (in AST sense) the given node AND
@ -231,15 +237,16 @@ hasCommentsBetween
-> ToBriDocM Bool -> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do hasCommentsBetween ast leftKey rightKey = do
mAnn <- astAnn ast mAnn <- astAnn ast
let go1 [] = False let
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest go1 [] = False
go1 (_ : rest) = go1 rest go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go2 [] = False go1 (_ : rest) = go1 rest
go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True go2 [] = False
go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True
go2 (_ : rest) = go2 rest go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False
go2 (_ : rest) = go2 rest
case mAnn of case mAnn of
Nothing -> pure False Nothing -> pure False
Just ann -> pure $ go1 $ ExactPrint.annsDP ann Just ann -> pure $ go1 $ ExactPrint.annsDP ann
-- | True if there are any comments that are connected to any node below (in AST -- | True if there are any comments that are connected to any node below (in AST
@ -286,7 +293,7 @@ hasAnyRegularCommentsRest ast = astAnn ast <&> \case
hasAnnKeywordComment hasAnnKeywordComment
:: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool
hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case
Nothing -> False Nothing -> False
Just ann -> any hasK (extractAllComments ann) Just ann -> any hasK (extractAllComments ann)
where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst
@ -300,7 +307,7 @@ hasAnnKeyword ast annKeyword = astAnn ast <&> \case
Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks
where where
hasK (ExactPrint.Types.G x, _) = x == annKeyword hasK (ExactPrint.Types.G x, _) = x == annKeyword
hasK _ = False hasK _ = False
astAnn astAnn
:: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)
@ -449,16 +456,13 @@ newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)
deriving (Functor, Applicative, Monad) deriving (Functor, Applicative, Monad)
addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM () addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternativeCond cond doc = addAlternativeCond cond doc = when cond (addAlternative doc)
when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative = addAlternative = CollectAltM . Writer.tell . (: [])
CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) = runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action
docAlt $ Writer.execWriter action
docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
@ -506,7 +510,8 @@ docAnnotationKW
-> Maybe AnnKeywordId -> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm docAnnotationKW annKey kw bdm =
allocateNode . BDFAnnotationKW annKey kw =<< bdm
docMoveToKWDP docMoveToKWDP
:: AnnKey :: AnnKey
@ -558,7 +563,7 @@ docParenR :: ToBriDocM BriDocNumbered
docParenR = docLit $ Text.pack ")" docParenR = docLit $ Text.pack ")"
docParenHashLSep :: ToBriDocM BriDocNumbered docParenHashLSep :: ToBriDocM BriDocNumbered
docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator] docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]
docParenHashRSep :: ToBriDocM BriDocNumbered docParenHashRSep :: ToBriDocM BriDocNumbered
docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"] docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]
@ -620,32 +625,26 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
docWrapNodePrior ast bdm = do docWrapNodePrior ast bdm = do
bd <- bdm bd <- bdm
i1 <- allocNodeIndex i1 <- allocNodeIndex
return return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd
$ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ bd
docWrapNodeRest ast bdm = do docWrapNodeRest ast bdm = do
bd <- bdm bd <- bdm
i2 <- allocNodeIndex i2 <- allocNodeIndex
return return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd
$ (,) i2
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
$ bd
instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where
docWrapNode ast bdms = case bdms of docWrapNode ast bdms = case bdms of
[] -> [] [] -> []
[bd] -> [docWrapNode ast bd] [bd] -> [docWrapNode ast bd]
(bd1:bdR) | (bdN:bdM) <- reverse bdR -> (bd1 : bdR) | (bdN : bdM) <- reverse bdR ->
[docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
docWrapNodePrior ast bdms = case bdms of docWrapNodePrior ast bdms = case bdms of
[] -> [] [] -> []
[bd] -> [docWrapNodePrior ast bd] [bd] -> [docWrapNodePrior ast bd]
(bd1:bdR) -> docWrapNodePrior ast bd1 : bdR (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR
docWrapNodeRest ast bdms = case reverse bdms of docWrapNodeRest ast bdms = case reverse bdms of
[] -> [] [] -> []
(bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
docWrapNode ast bdsm = do docWrapNode ast bdsm = do
@ -655,25 +654,25 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
[bd] -> do [bd] -> do
bd' <- docWrapNode ast (return bd) bd' <- docWrapNode ast (return bd)
return [bd'] return [bd']
(bd1:bdR) | (bdN:bdM) <- reverse bdR -> do (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ [bd1'] ++ reverse bdM ++ [bdN'] return $ [bd1'] ++ reverse bdM ++ [bdN']
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
docWrapNodePrior ast bdsm = do docWrapNodePrior ast bdsm = do
bds <- bdsm bds <- bdsm
case bds of case bds of
[] -> return [] [] -> return []
(bd1:bdR) -> do (bd1 : bdR) -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
return (bd1':bdR) return (bd1' : bdR)
docWrapNodeRest ast bdsm = do docWrapNodeRest ast bdsm = do
bds <- bdsm bds <- bdsm
case reverse bds of case reverse bds of
[] -> return [] [] -> return []
(bdN:bdR) -> do (bdN : bdR) -> do
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ reverse (bdN':bdR) return $ reverse (bdN' : bdR)
instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
docWrapNode ast bdsm = do docWrapNode ast bdsm = do
@ -686,7 +685,7 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
return $ Seq.singleton bd1' return $ Seq.singleton bd1'
bdM Seq.:> bdN -> do bdM Seq.:> bdN -> do
bd1' <- docWrapNodePrior ast (return bd1) bd1' <- docWrapNodePrior ast (return bd1)
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ (bd1' Seq.<| bdM) Seq.|> bdN' return $ (bd1' Seq.<| bdM) Seq.|> bdN'
docWrapNodePrior ast bdsm = do docWrapNodePrior ast bdsm = do
bds <- bdsm bds <- bdsm
@ -730,7 +729,7 @@ docPar
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docPar lineM indentedM = do docPar lineM indentedM = do
line <- lineM line <- lineM
indented <- indentedM indented <- indentedM
allocateNode $ BDFPar BrIndentNone line indented allocateNode $ BDFPar BrIndentNone line indented
@ -767,14 +766,15 @@ briDocMToPPM m = do
briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String) briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)
briDocMToPPMInner m = do briDocMToPPMInner m = do
readers <- MultiRWSS.mGetRawR readers <- MultiRWSS.mGetRawR
let ((x, errs), debugs) = let
runIdentity ((x, errs), debugs) =
$ MultiRWSS.runMultiRWSTNil runIdentity
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1) $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiReaders readers $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiReaders readers
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
$ m $ MultiRWSS.withMultiWriterAW
$ m
pure (x, errs, debugs) pure (x, errs, debugs)
docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y) docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)

367
source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
View File

@ -27,28 +27,29 @@ layoutDataDecl
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- newtype MyType a b = MyType .. -- newtype MyType a b = MyType ..
HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs ->
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> case cons of
docWrapNode ltycl $ do (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc))
nameStr <- lrdrNameToTextAnn name -> docWrapNode ltycl $ do
consNameStr <- lrdrNameToTextAnn consName nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs consNameStr <- lrdrNameToTextAnn consName
-- headDoc <- fmap return $ docSeq tyVarLine <- return <$> createBndrDoc bndrs
-- [ appSep $ docLitS "newtype") -- headDoc <- fmap return $ docSeq
-- , appSep $ docLit nameStr -- [ appSep $ docLitS "newtype")
-- , appSep tyVarLine -- , appSep $ docLit nameStr
-- ] -- , appSep tyVarLine
rhsDoc <- return <$> createDetailsDoc consNameStr details -- ]
createDerivingPar mDerivs $ docSeq rhsDoc <- return <$> createDetailsDoc consNameStr details
[ appSep $ docLitS "newtype" createDerivingPar mDerivs $ docSeq
, appSep $ docLit nameStr [ appSep $ docLitS "newtype"
, appSep tyVarLine , appSep $ docLit nameStr
, docSeparator , appSep tyVarLine
, docLitS "=" , docSeparator
, docSeparator , docLitS "="
, rhsDoc , docSeparator
] , rhsDoc
_ -> briDocByExactNoComment ltycl ]
_ -> briDocByExactNoComment ltycl
-- data MyData a b -- data MyData a b
@ -56,8 +57,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
docWrapNode ltycl $ do docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
tyVarLine <- return <$> createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
createDerivingPar mDerivs $ docSeq createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, lhsContextDoc , lhsContextDoc
@ -69,24 +70,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- data MyData = MyData { .. } -- data MyData = MyData { .. }
HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
case cons of case cons of
(L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc))
docWrapNode ltycl $ do -> docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
forallDocMay <- case createForallDoc qvars of forallDocMay <- case createForallDoc qvars of
Nothing -> pure Nothing Nothing -> pure Nothing
Just x -> Just . pure <$> x Just x -> Just . pure <$> x
rhsContextDocMay <- case mRhsContext of rhsContextDocMay <- case mRhsContext of
Nothing -> pure Nothing Nothing -> pure Nothing
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
rhsDoc <- return <$> createDetailsDoc consNameStr details rhsDoc <- return <$> createDetailsDoc consNameStr details
consDoc <- fmap pure consDoc <-
fmap pure
$ docNonBottomSpacing $ docNonBottomSpacing
$ case (forallDocMay, rhsContextDocMay) of $ case (forallDocMay, rhsContextDocMay) of
(Just forallDoc, Just rhsContextDoc) -> docLines (Just forallDoc, Just rhsContextDoc) -> docLines
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] [ docSeq
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq , docSeq
[ docLitS "." [ docLitS "."
, docSeparator , docSeparator
@ -94,7 +97,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
] ]
] ]
(Just forallDoc, Nothing) -> docLines (Just forallDoc, Nothing) -> docLines
[ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] [ docSeq
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq [docLitS ".", docSeparator, rhsDoc] , docSeq [docLitS ".", docSeparator, rhsDoc]
] ]
(Nothing, Just rhsContextDoc) -> docSeq (Nothing, Just rhsContextDoc) -> docSeq
@ -102,12 +106,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSeparator , docSeparator
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
] ]
(Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] (Nothing, Nothing) ->
docSeq [docLitS "=", docSeparator, rhsDoc]
createDerivingPar mDerivs $ docAlt createDerivingPar mDerivs $ docAlt
[ -- data D = forall a . Show a => D a [ -- data D = forall a . Show a => D a
docSeq docSeq
[ docNodeAnnKW ltycl (Just GHC.AnnData) [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline $ lhsContextDoc , docForceSingleline $ lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -119,12 +123,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSetIndentLevel $ docSeq , docSetIndentLevel $ docSeq
[ case forallDocMay of [ case forallDocMay of
Nothing -> docEmpty Nothing -> docEmpty
Just forallDoc -> docSeq Just forallDoc ->
[ docForceSingleline forallDoc docSeq
, docSeparator [ docForceSingleline forallDoc
, docLitS "." , docSeparator
, docSeparator , docLitS "."
] , docSeparator
]
, maybe docEmpty docForceSingleline rhsContextDocMay , maybe docEmpty docForceSingleline rhsContextDocMay
, rhsDoc , rhsDoc
] ]
@ -132,26 +137,26 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, -- data D , -- data D
-- = forall a . Show a => D a -- = forall a . Show a => D a
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular $ docPar
( docNodeAnnKW ltycl (Just GHC.AnnData) (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc , docForceSingleline lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
, tyVarLine , tyVarLine
] ]
) )
( docSeq (docSeq
[ docLitS "=" [ docLitS "="
, docSeparator , docSeparator
, docSetIndentLevel $ docSeq , docSetIndentLevel $ docSeq
[ case forallDocMay of [ case forallDocMay of
Nothing -> docEmpty Nothing -> docEmpty
Just forallDoc -> docSeq Just forallDoc ->
[ docForceSingleline forallDoc docSeq
, docSeparator [ docForceSingleline forallDoc
, docLitS "." , docSeparator
, docSeparator , docLitS "."
] , docSeparator
]
, maybe docEmpty docForceSingleline rhsContextDocMay , maybe docEmpty docForceSingleline rhsContextDocMay
, rhsDoc , rhsDoc
] ]
@ -162,8 +167,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- . Show a => -- . Show a =>
-- D a -- D a
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular $ docPar
( docNodeAnnKW ltycl (Just GHC.AnnData) (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc , docForceSingleline lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -184,13 +188,10 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
-- hurt. -- hurt.
docAddBaseY BrIndentRegular $ docPar docAddBaseY BrIndentRegular $ docPar
(docLitS "data") (docLitS "data")
( docLines (docLines
[ lhsContextDoc [ lhsContextDoc
, docNodeAnnKW ltycl (Just GHC.AnnData) , docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq $ docSeq [appSep $ docLit nameStr, tyVarLine]
[ appSep $ docLit nameStr
, tyVarLine
]
, consDoc , consDoc
] ]
) )
@ -204,20 +205,20 @@ createContextDoc [] = docEmpty
createContextDoc [t] = createContextDoc [t] =
docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]
createContextDoc (t1 : tR) = do createContextDoc (t1 : tR) = do
t1Doc <- docSharedWrapper layoutType t1 t1Doc <- docSharedWrapper layoutType t1
tRDocs <- tR `forM` docSharedWrapper layoutType tRDocs <- tR `forM` docSharedWrapper layoutType
docAlt docAlt
[ docSeq [ docSeq
[ docLitS "(" [ docLitS "("
, docForceSingleline $ docSeq $ List.intersperse docCommaSep , docForceSingleline $ docSeq $ List.intersperse
(t1Doc : tRDocs) docCommaSep
(t1Doc : tRDocs)
, docLitS ") =>" , docLitS ") =>"
, docSeparator , docSeparator
] ]
, docLines $ join , docLines $ join
[ [docSeq [docLitS "(", docSeparator, t1Doc]] [ [docSeq [docLitS "(", docSeparator, t1Doc]]
, tRDocs , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
<&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
, [docLitS ") =>", docSeparator] , [docLitS ") =>", docSeparator]
] ]
] ]
@ -229,20 +230,18 @@ createBndrDoc bs = do
(L _ (KindedTyVar _ _ext lrdrName kind)) -> do (L _ (KindedTyVar _ _ext lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d) return $ (lrdrNameToText lrdrName, Just $ d)
docSeq docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) ->
$ List.intersperse docSeparator case mKind of
$ tyVarDocs Nothing -> docLit vname
<&> \(vname, mKind) -> case mKind of Just kind -> docSeq
Nothing -> docLit vname [ docLitS "("
Just kind -> docSeq , docLit vname
[ docLitS "(" , docSeparator
, docLit vname , docLitS "::"
, docSeparator , docSeparator
, docLitS "::" , kind
, docSeparator , docLitS ")"
, kind ]
, docLitS ")"
]
createDerivingPar createDerivingPar
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -251,10 +250,10 @@ createDerivingPar derivs mainDoc = do
(L _ []) -> mainDoc (L _ []) -> mainDoc
(L _ types) -> (L _ types) ->
docPar mainDoc docPar mainDoc
$ docEnsureIndent BrIndentRegular $ docEnsureIndent BrIndentRegular
$ docLines $ docLines
$ docWrapNode derivs $ docWrapNode derivs
$ derivingClauseDoc $ derivingClauseDoc
<$> types <$> types
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
@ -263,36 +262,33 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
(L _ ts) -> (L _ ts) ->
let let
tsLength = length ts tsLength = length ts
whenMoreThan1Type val = whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""
if tsLength > 1 then docLitS val else docLitS "" (lhsStrategy, rhsStrategy) =
(lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy maybe (docEmpty, docEmpty) strategyLeftRight mStrategy
in in docSeq
docSeq [ docDeriving
[ docDeriving , docWrapNodePrior types $ lhsStrategy
, docWrapNodePrior types $ lhsStrategy , docSeparator
, docSeparator , whenMoreThan1Type "("
, whenMoreThan1Type "(" , docWrapNodeRest types
, docWrapNodeRest types $ docSeq
$ docSeq $ List.intersperse docCommaSep
$ List.intersperse docCommaSep $ ts
$ ts <&> \case <&> \case
HsIB _ t -> layoutType t HsIB _ t -> layoutType t
, whenMoreThan1Type ")" , whenMoreThan1Type ")"
, rhsStrategy , rhsStrategy
] ]
where where
strategyLeftRight = \case strategyLeftRight = \case
(L _ StockStrategy ) -> (docLitS " stock", docEmpty) (L _ StockStrategy) -> (docLitS " stock", docEmpty)
(L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty)
(L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty)
lVia@(L _ (ViaStrategy viaTypes) ) -> lVia@(L _ (ViaStrategy viaTypes)) ->
( docEmpty ( docEmpty
, case viaTypes of , case viaTypes of
HsIB _ext t -> docSeq HsIB _ext t ->
[ docWrapNode lVia $ docLitS " via" docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]
, docSeparator
, layoutType t
]
) )
docDeriving :: ToBriDocM BriDocNumbered docDeriving :: ToBriDocM BriDocNumbered
@ -302,21 +298,24 @@ createDetailsDoc
:: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)
createDetailsDoc consNameStr details = case details of createDetailsDoc consNameStr details = case details of
PrefixCon args -> do PrefixCon args -> do
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let let
singleLine = docSeq singleLine = docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
, docForceSingleline , docForceSingleline
$ docSeq $ docSeq
$ List.intersperse docSeparator $ List.intersperse docSeparator
$ fmap hsScaledThing args <&> layoutType $ fmap hsScaledThing args
<&> layoutType
] ]
leftIndented = docSetParSpacing leftIndented =
. docAddBaseY BrIndentRegular docSetParSpacing
. docPar (docLit consNameStr) . docAddBaseY BrIndentRegular
. docLines . docPar (docLit consNameStr)
$ layoutType <$> fmap hsScaledThing args . docLines
$ layoutType
<$> fmap hsScaledThing args
multiAppended = docSeq multiAppended = docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
@ -326,79 +325,80 @@ createDetailsDoc consNameStr details = case details of
(docLit consNameStr) (docLit consNameStr)
(docLines $ layoutType <$> fmap hsScaledThing args) (docLines $ layoutType <$> fmap hsScaledThing args)
case indentPolicy of case indentPolicy of
IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyLeft -> docAlt [singleLine, leftIndented]
IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]
IndentPolicyFree -> IndentPolicyFree ->
docAlt [singleLine, multiAppended, multiIndented, leftIndented] docAlt [singleLine, multiAppended, multiIndented, leftIndented]
RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] RecCon (L _ []) ->
RecCon lRec@(L _ fields@(_:_)) -> do docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]
RecCon lRec@(L _ fields@(_ : _)) -> do
let ((fName1, fType1) : fDocR) = mkFieldDocs fields let ((fName1, fType1) : fDocR) = mkFieldDocs fields
-- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
let allowSingleline = False let allowSingleline = False
docAddBaseY BrIndentRegular docAddBaseY BrIndentRegular $ runFilteredAlternative $ do
$ runFilteredAlternative
$ do
-- single-line: { i :: Int, b :: Bool } -- single-line: { i :: Int, b :: Bool }
addAlternativeCond allowSingleline $ docSeq addAlternativeCond allowSingleline $ docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
, docWrapNodePrior lRec $ docLitS "{" , docWrapNodePrior lRec $ docLitS "{"
, docSeparator , docSeparator
, docWrapNodeRest lRec , docWrapNodeRest lRec
$ docForceSingleline $ docForceSingleline
$ docSeq $ docSeq
$ join $ join
$ [fName1, docSeparator, docLitS "::", docSeparator, fType1] $ [fName1, docSeparator, docLitS "::", docSeparator, fType1]
: [ [ docLitS "," : [ [ docLitS ","
, docSeparator , docSeparator
, fName , fName
, docSeparator , docSeparator
, docLitS "::" , docLitS "::"
, docSeparator , docSeparator
, fType , fType
] ]
| (fName, fType) <- fDocR | (fName, fType) <- fDocR
]
, docSeparator
, docLitS "}"
] ]
addAlternative $ docPar , docSeparator
(docLit consNameStr) , docLitS "}"
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines ]
[ docAlt addAlternative $ docPar
[ docCols ColRecDecl (docLit consNameStr)
[ appSep (docLitS "{") (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
, appSep $ docForceSingleline fName1 [ docAlt
[ docCols
ColRecDecl
[ appSep (docLitS "{")
, appSep $ docForceSingleline fName1
, docSeq [docLitS "::", docSeparator]
, docForceSingleline $ fType1
]
, docSeq
[ docLitS "{"
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName1
(docSeq [docLitS "::", docSeparator, fType1])
]
]
, docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->
docAlt
[ docCols
ColRecDecl
[ docCommaSep
, appSep $ docForceSingleline fName
, docSeq [docLitS "::", docSeparator] , docSeq [docLitS "::", docSeparator]
, docForceSingleline $ fType1 , docForceSingleline fType
] ]
, docSeq , docSeq
[ docLitS "{" [ docLitS ","
, docSeparator , docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName1 fName
(docSeq [docLitS "::", docSeparator, fType1]) (docSeq [docLitS "::", docSeparator, fType])
] ]
] ]
, docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> , docLitS "}"
docAlt ]
[ docCols ColRecDecl )
[ docCommaSep
, appSep $ docForceSingleline fName
, docSeq [docLitS "::", docSeparator]
, docForceSingleline fType
]
, docSeq
[ docLitS ","
, docSeparator
, docSetBaseY $ docAddBaseY BrIndentRegular $ docPar
fName
(docSeq [docLitS "::", docSeparator, fType])
]
]
, docLitS "}"
]
)
InfixCon arg1 arg2 -> docSeq InfixCon arg1 arg2 -> docSeq
[ layoutType $ hsScaledThing arg1 [ layoutType $ hsScaledThing arg1
, docSeparator , docSeparator
@ -413,10 +413,11 @@ createDetailsDoc consNameStr details = case details of
mkFieldDocs = fmap $ \lField -> case lField of mkFieldDocs = fmap $ \lField -> case lField of
L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t
createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered) createForallDoc
createForallDoc [] = Nothing :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
createForallDoc lhsTyVarBndrs = Just $ docSeq createForallDoc [] = Nothing
[docLitS "forall ", createBndrDoc lhsTyVarBndrs] createForallDoc lhsTyVarBndrs =
Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
createNamesAndTypeDoc createNamesAndTypeDoc
:: Data.Data.Data ast :: Data.Data.Data ast
@ -426,12 +427,8 @@ createNamesAndTypeDoc
-> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)
createNamesAndTypeDoc lField names t = createNamesAndTypeDoc lField names t =
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
[ docSeq [ docSeq $ List.intersperse docCommaSep $ names <&> \case
$ List.intersperse docCommaSep L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName
$ names
<&> \case
L _ (FieldOcc _ fieldName) ->
docLit =<< lrdrNameToTextAnn fieldName
] ]
, docWrapNodeRest lField $ layoutType t , docWrapNodeRest lField $ layoutType t
) )

919
source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

File diff suppressed because it is too large Load Diff

1216
source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

File diff suppressed because it is too large Load Diff

118
source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs
View File

@ -35,36 +35,40 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"] docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]
IEThingWith _ x _ ns _ -> do IEThingWith _ x _ ns _ -> do
hasComments <- orM hasComments <- orM
( hasCommentsBetween lie AnnOpenP AnnCloseP (hasCommentsBetween lie AnnOpenP AnnCloseP
: hasAnyCommentsBelow x : hasAnyCommentsBelow x
: map hasAnyCommentsBelow ns : map hasAnyCommentsBelow ns
) )
let sortedNs = List.sortOn wrappedNameToText ns let sortedNs = List.sortOn wrappedNameToText ns
runFilteredAlternative $ do runFilteredAlternative $ do
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
$ [layoutWrapped lie x, docLit $ Text.pack "("] $ [layoutWrapped lie x, docLit $ Text.pack "("]
++ intersperse docCommaSep (map nameDoc sortedNs) ++ intersperse docCommaSep (map nameDoc sortedNs)
++ [docParenR] ++ [docParenR]
addAlternative addAlternative
$ docWrapNodeRest lie $ docWrapNodeRest lie
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))
(layoutWrapped lie x)
(layoutItems (splitFirstLast sortedNs))
where where
nameDoc = docLit <=< lrdrNameToTextAnn . prepareName nameDoc = docLit <=< lrdrNameToTextAnn . prepareName
layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n] layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]
layoutItems FirstLastEmpty = docSetBaseY $ docLines layoutItems FirstLastEmpty = docSetBaseY $ docLines
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR] [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty]
, docParenR
]
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
[docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR] [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n]
, docParenR
]
layoutItems (FirstLast n1 nMs nN) = layoutItems (FirstLast n1 nMs nN) =
docSetBaseY docSetBaseY
$ docLines $ docLines
$ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]] $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]
++ map layoutItem nMs ++ map layoutItem nMs
++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR] ++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
, docParenR
]
IEModuleContents _ n -> docSeq IEModuleContents _ n -> docSeq
[ docLit $ Text.pack "module" [ docLit $ Text.pack "module"
, docSeparator , docSeparator
@ -73,7 +77,7 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
_ -> docEmpty _ -> docEmpty
where where
layoutWrapped _ = \case layoutWrapped _ = \case
L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n
L _ (IEPattern n) -> do L _ (IEPattern n) -> do
name <- lrdrNameToTextAnn n name <- lrdrNameToTextAnn n
docLit $ Text.pack "pattern " <> name docLit $ Text.pack "pattern " <> name
@ -90,33 +94,36 @@ data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted
-- handling of the resulting list. Adding parens is -- handling of the resulting list. Adding parens is
-- left to the caller since that is context sensitive -- left to the caller since that is context sensitive
layoutAnnAndSepLLIEs layoutAnnAndSepLLIEs
:: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered] :: SortItemsFlag
-> Located [LIE GhcPs]
-> ToBriDocM [ToBriDocM BriDocNumbered]
layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
let makeIENode ie = docSeq [docCommaSep, ie] let makeIENode ie = docSeq [docCommaSep, ie]
let sortedLies = let
[ items sortedLies =
| group <- Data.List.Extra.groupOn lieToText [ items
$ List.sortOn lieToText lies | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies
, items <- mergeGroup group , items <- mergeGroup group
] ]
let ieDocs = fmap layoutIE $ case shouldSort of let
ShouldSortItems -> sortedLies ieDocs = fmap layoutIE $ case shouldSort of
KeepItemsUnsorted -> lies ShouldSortItems -> sortedLies
KeepItemsUnsorted -> lies
ieCommaDocs <- ieCommaDocs <-
docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of
FirstLastEmpty -> [] FirstLastEmpty -> []
FirstLastSingleton ie -> [ie] FirstLastSingleton ie -> [ie]
FirstLast ie1 ieMs ieN -> FirstLast ie1 ieMs ieN ->
[ie1] ++ map makeIENode ieMs ++ [makeIENode ieN] [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]
pure $ fmap pure ieCommaDocs -- returned shared nodes pure $ fmap pure ieCommaDocs -- returned shared nodes
where where
mergeGroup :: [LIE GhcPs] -> [LIE GhcPs] mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]
mergeGroup [] = [] mergeGroup [] = []
mergeGroup items@[_] = items mergeGroup items@[_] = items
mergeGroup items = if mergeGroup items = if
| all isProperIEThing items -> [List.foldl1' thingFolder items] | all isProperIEThing items -> [List.foldl1' thingFolder items]
| all isIEVar items -> [List.foldl1' thingFolder items] | all isIEVar items -> [List.foldl1' thingFolder items]
| otherwise -> items | otherwise -> items
-- proper means that if it is a ThingWith, it does not contain a wildcard -- proper means that if it is a ThingWith, it does not contain a wildcard
-- (because I don't know what a wildcard means if it is not already a -- (because I don't know what a wildcard means if it is not already a
-- IEThingAll). -- IEThingAll).
@ -129,21 +136,22 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
isIEVar :: LIE GhcPs -> Bool isIEVar :: LIE GhcPs -> Bool
isIEVar = \case isIEVar = \case
L _ IEVar{} -> True L _ IEVar{} -> True
_ -> False _ -> False
thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs
thingFolder l1@(L _ IEVar{} ) _ = l1 thingFolder l1@(L _ IEVar{}) _ = l1
thingFolder l1@(L _ IEThingAll{}) _ = l1 thingFolder l1@(L _ IEThingAll{}) _ = l1
thingFolder _ l2@(L _ IEThingAll{}) = l2 thingFolder _ l2@(L _ IEThingAll{}) = l2
thingFolder l1 ( L _ IEThingAbs{}) = l1 thingFolder l1 (L _ IEThingAbs{}) = l1
thingFolder (L _ IEThingAbs{}) l2 = l2 thingFolder (L _ IEThingAbs{}) l2 = l2
thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2)) thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))
= L = L
l l
(IEThingWith x (IEThingWith
wn x
NoIEWildcard wn
(consItems1 ++ consItems2) NoIEWildcard
(fieldLbls1 ++ fieldLbls2) (consItems1 ++ consItems2)
(fieldLbls1 ++ fieldLbls2)
) )
thingFolder _ _ = thingFolder _ _ =
error "thingFolder should be exhaustive because we have a guard above" error "thingFolder should be exhaustive because we have a guard above"
@ -162,9 +170,10 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-- () -- no comments -- () -- no comments
-- ( -- a comment -- ( -- a comment
-- ) -- )
layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered layoutLLIEs
:: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
layoutLLIEs enableSingleline shouldSort llies = do layoutLLIEs enableSingleline shouldSort llies = do
ieDs <- layoutAnnAndSepLLIEs shouldSort llies ieDs <- layoutAnnAndSepLLIEs shouldSort llies
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies
runFilteredAlternative $ case ieDs of runFilteredAlternative $ case ieDs of
[] -> do [] -> do
@ -174,14 +183,14 @@ layoutLLIEs enableSingleline shouldSort llies = do
docParenR docParenR
(ieDsH : ieDsT) -> do (ieDsH : ieDsT) -> do
addAlternativeCond (not hasComments && enableSingleline) addAlternativeCond (not hasComments && enableSingleline)
$ docSeq $ docSeq
$ [docLit (Text.pack "(")] $ [docLit (Text.pack "(")]
++ (docForceSingleline <$> ieDs) ++ (docForceSingleline <$> ieDs)
++ [docParenR] ++ [docParenR]
addAlternative addAlternative
$ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH]) $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])
$ docLines $ docLines
$ ieDsT $ ieDsT
++ [docParenR] ++ [docParenR]
-- | Returns a "fingerprint string", not a full text representation, nor even -- | Returns a "fingerprint string", not a full text representation, nor even
@ -189,26 +198,27 @@ layoutLLIEs enableSingleline shouldSort llies = do
-- Used for sorting, not for printing the formatter's output source code. -- Used for sorting, not for printing the formatter's output source code.
wrappedNameToText :: LIEWrappedName RdrName -> Text wrappedNameToText :: LIEWrappedName RdrName -> Text
wrappedNameToText = \case wrappedNameToText = \case
L _ (IEName n) -> lrdrNameToText n L _ (IEName n) -> lrdrNameToText n
L _ (IEPattern n) -> lrdrNameToText n L _ (IEPattern n) -> lrdrNameToText n
L _ (IEType n) -> lrdrNameToText n L _ (IEType n) -> lrdrNameToText n
-- | Returns a "fingerprint string", not a full text representation, nor even -- | Returns a "fingerprint string", not a full text representation, nor even
-- a source code representation of this syntax node. -- a source code representation of this syntax node.
-- Used for sorting, not for printing the formatter's output source code. -- Used for sorting, not for printing the formatter's output source code.
lieToText :: LIE GhcPs -> Text lieToText :: LIE GhcPs -> Text
lieToText = \case lieToText = \case
L _ (IEVar _ wn ) -> wrappedNameToText wn L _ (IEVar _ wn) -> wrappedNameToText wn
L _ (IEThingAbs _ wn ) -> wrappedNameToText wn L _ (IEThingAbs _ wn) -> wrappedNameToText wn
L _ (IEThingAll _ wn ) -> wrappedNameToText wn L _ (IEThingAll _ wn) -> wrappedNameToText wn
L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn
-- TODO: These _may_ appear in exports! -- TODO: These _may_ appear in exports!
-- Need to check, and either put them at the top (for module) or do some -- Need to check, and either put them at the top (for module) or do some
-- other clever thing. -- other clever thing.
L _ (IEModuleContents _ n) -> moduleNameToText n L _ (IEModuleContents _ n) -> moduleNameToText n
L _ IEGroup{} -> Text.pack "@IEGroup" L _ IEGroup{} -> Text.pack "@IEGroup"
L _ IEDoc{} -> Text.pack "@IEDoc" L _ IEDoc{} -> Text.pack "@IEDoc"
L _ IEDocNamed{} -> Text.pack "@IEDocNamed" L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where where
moduleNameToText :: Located ModuleName -> Text moduleNameToText :: Located ModuleName -> Text
moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name) moduleNameToText (L _ name) =
Text.pack ("@IEModuleContents" ++ moduleNameString name)

169
source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs
View File

@ -30,111 +30,128 @@ layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered
layoutImport importD = case importD of layoutImport importD = case importD of
ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do
importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack
importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack importAsCol <-
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack
indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let let
compact = indentPolicy /= IndentPolicyFree compact = indentPolicy /= IndentPolicyFree
modNameT = Text.pack $ moduleNameString modName modNameT = Text.pack $ moduleNameString modName
pkgNameT = Text.pack . prepPkg . sl_st <$> pkg pkgNameT = Text.pack . prepPkg . sl_st <$> pkg
masT = Text.pack . moduleNameString . prepModName <$> mas masT = Text.pack . moduleNameString . prepModName <$> mas
hiding = maybe False fst mllies hiding = maybe False fst mllies
minQLength = length "import qualified " minQLength = length "import qualified "
qLengthReal = qLengthReal =
let qualifiedPart = if q /= NotQualified then length "qualified " else 0 let
safePart = if safe then length "safe " else 0 qualifiedPart = if q /= NotQualified then length "qualified " else 0
pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT safePart = if safe then length "safe " else 0
srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 } pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT
in length "import " + srcPart + safePart + qualifiedPart + pkgPart srcPart = case src of
qLength = max minQLength qLengthReal IsBoot -> length "{-# SOURCE #-} "
NotBoot -> 0
in length "import " + srcPart + safePart + qualifiedPart + pkgPart
qLength = max minQLength qLengthReal
-- Cost in columns of importColumn -- Cost in columns of importColumn
asCost = length "as " asCost = length "as "
hidingParenCost = if hiding then length "hiding ( " else length "( " hidingParenCost = if hiding then length "hiding ( " else length "( "
nameCost = Text.length modNameT + qLength nameCost = Text.length modNameT + qLength
importQualifiers = docSeq importQualifiers = docSeq
[ appSep $ docLit $ Text.pack "import" [ appSep $ docLit $ Text.pack "import"
, case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty } , case src of
IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"
NotBoot -> docEmpty
, if safe then appSep $ docLit $ Text.pack "safe" else docEmpty , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty
, if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty , if q /= NotQualified
then appSep $ docLit $ Text.pack "qualified"
else docEmpty
, maybe docEmpty (appSep . docLit) pkgNameT , maybe docEmpty (appSep . docLit) pkgNameT
] ]
indentName = indentName =
if compact then id else docEnsureIndent (BrIndentSpecial qLength) if compact then id else docEnsureIndent (BrIndentSpecial qLength)
modNameD = modNameD = indentName $ appSep $ docLit modNameT
indentName $ appSep $ docLit modNameT
hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2 hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2
hidDocColDiff = importCol - 2 - hidDocCol hidDocColDiff = importCol - 2 - hidDocCol
hidDoc = if hiding hidDoc =
then appSep $ docLit $ Text.pack "hiding" if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty
else docEmpty
importHead = docSeq [importQualifiers, modNameD] importHead = docSeq [importQualifiers, modNameD]
bindingsD = case mllies of bindingsD = case mllies of
Nothing -> docEmpty Nothing -> docEmpty
Just (_, llies) -> do Just (_, llies) -> do
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies
if compact if compact
then docAlt then docAlt
[ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies] [ docSeq
, let makeParIfHiding = if hiding [ hidDoc
, docForceSingleline $ layoutLLIEs True ShouldSortItems llies
]
, let
makeParIfHiding = if hiding
then docAddBaseY BrIndentRegular . docPar hidDoc then docAddBaseY BrIndentRegular . docPar hidDoc
else id else id
in makeParIfHiding (layoutLLIEs True ShouldSortItems llies) in makeParIfHiding (layoutLLIEs True ShouldSortItems llies)
] ]
else do else do
ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies
docWrapNodeRest llies docWrapNodeRest llies
$ docEnsureIndent (BrIndentSpecial hidDocCol) $ docEnsureIndent (BrIndentSpecial hidDocCol)
$ case ieDs of $ case ieDs of
-- ..[hiding].( ) -- ..[hiding].( )
[] -> if hasComments [] -> if hasComments
then docPar then docPar
(docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty]) (docSeq
(docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) [hidDoc, docParenLSep, docWrapNode llies docEmpty]
else docSeq [hidDoc, docParenLSep, docSeparator, docParenR] )
-- ..[hiding].( b ) (docEnsureIndent
[ieD] -> runFilteredAlternative $ do (BrIndentSpecial hidDocColDiff)
addAlternativeCond (not hasComments) docParenR
$ docSeq )
[ hidDoc else docSeq
, docParenLSep [hidDoc, docParenLSep, docSeparator, docParenR]
, docForceSingleline ieD -- ..[hiding].( b )
, docSeparator [ieD] -> runFilteredAlternative $ do
, docParenR addAlternativeCond (not hasComments)
] $ docSeq
addAlternative $ docPar [ hidDoc
(docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD]) , docParenLSep
(docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR) , docForceSingleline ieD
-- ..[hiding].( b , docSeparator
-- , b' , docParenR
-- ) ]
(ieD:ieDs') -> addAlternative $ docPar
docPar (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])
(docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]) (docEnsureIndent
( docEnsureIndent (BrIndentSpecial hidDocColDiff) (BrIndentSpecial hidDocColDiff)
$ docLines docParenR
$ ieDs' )
++ [docParenR] -- ..[hiding].( b
) -- , b'
-- )
(ieD : ieDs') -> docPar
(docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]
)
(docEnsureIndent (BrIndentSpecial hidDocColDiff)
$ docLines
$ ieDs'
++ [docParenR]
)
makeAsDoc asT = makeAsDoc asT =
docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT] docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT]
if compact if compact
then then
let asDoc = maybe docEmpty makeAsDoc masT let asDoc = maybe docEmpty makeAsDoc masT
in docAlt in
[ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] docAlt
, docAddBaseY BrIndentRegular $ [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD]
docPar (docSeq [importHead, asDoc]) bindingsD , docAddBaseY BrIndentRegular
] $ docPar (docSeq [importHead, asDoc]) bindingsD
else ]
case masT of else case masT of
Just n -> if enoughRoom Just n -> if enoughRoom
then docLines then docLines [docSeq [importHead, asDoc], bindingsD]
[ docSeq [importHead, asDoc], bindingsD]
else docLines [importHead, asDoc, bindingsD] else docLines [importHead, asDoc, bindingsD]
where where
enoughRoom = nameCost < importAsCol - asCost enoughRoom = nameCost < importAsCol - asCost
asDoc = asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost))
docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) $ makeAsDoc n
$ makeAsDoc n
Nothing -> if enoughRoom Nothing -> if enoughRoom
then docSeq [importHead, bindingsD] then docSeq [importHead, bindingsD]
else docLines [importHead, bindingsD] else docLines [importHead, bindingsD]

91
source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs
View File

@ -25,7 +25,7 @@ import Language.Haskell.GHC.ExactPrint.Types
layoutModule :: ToBriDoc' HsModule layoutModule :: ToBriDoc' HsModule
layoutModule lmod@(L _ mod') = case mod' of layoutModule lmod@(L _ mod') = case mod' of
-- Implicit module Main -- Implicit module Main
HsModule _ Nothing _ imports _ _ _ -> do HsModule _ Nothing _ imports _ _ _ -> do
commentedImports <- transformToCommentedImport imports commentedImports <- transformToCommentedImport imports
-- groupify commentedImports `forM_` tellDebugMessShow -- groupify commentedImports `forM_` tellDebugMessShow
docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports) docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)
@ -36,10 +36,8 @@ layoutModule lmod@(L _ mod') = case mod' of
-- groupify commentedImports `forM_` tellDebugMessShow -- groupify commentedImports `forM_` tellDebugMessShow
-- sortedImports <- sortImports imports -- sortedImports <- sortImports imports
let tn = Text.pack $ moduleNameString $ unLoc n let tn = Text.pack $ moduleNameString $ unLoc n
allowSingleLineExportList <- mAsk allowSingleLineExportList <-
<&> _conf_layout mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack
.> _lconfig_allowSingleLineExportList
.> confUnpack
-- the config should not prevent single-line layout when there is no -- the config should not prevent single-line layout when there is no
-- export list -- export list
let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
@ -49,30 +47,26 @@ layoutModule lmod@(L _ mod') = case mod' of
-- A pseudo node that serves merely to force documentation -- A pseudo node that serves merely to force documentation
-- before the node -- before the node
, docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do
addAlternativeCond allowSingleLine $ addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq
docForceSingleline [ appSep $ docLit $ Text.pack "module"
$ docSeq , appSep $ docLit tn
[ appSep $ docLit $ Text.pack "module" , docWrapNode lmod $ appSep $ case les of
, appSep $ docLit tn Nothing -> docEmpty
, docWrapNode lmod $ appSep $ case les of Just x -> layoutLLIEs True KeepItemsUnsorted x
Nothing -> docEmpty , docSeparator
Just x -> layoutLLIEs True KeepItemsUnsorted x , docLit $ Text.pack "where"
, docSeparator ]
, docLit $ Text.pack "where" addAlternative $ docLines
]
addAlternative
$ docLines
[ docAddBaseY BrIndentRegular $ docPar [ docAddBaseY BrIndentRegular $ docPar
(docSeq [appSep $ docLit $ Text.pack "module", docLit tn] (docSeq [appSep $ docLit $ Text.pack "module", docLit tn])
) (docSeq
(docSeq [ [ docWrapNode lmod $ case les of
docWrapNode lmod $ case les of Nothing -> docEmpty
Nothing -> docEmpty Just x -> layoutLLIEs False KeepItemsUnsorted x
Just x -> layoutLLIEs False KeepItemsUnsorted x , docSeparator
, docSeparator , docLit $ Text.pack "where"
, docLit $ Text.pack "where" ]
] )
)
] ]
] ]
: (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports] : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports]
@ -84,7 +78,7 @@ data CommentedImport
instance Show CommentedImport where instance Show CommentedImport where
show = \case show = \case
EmptyLine -> "EmptyLine" EmptyLine -> "EmptyLine"
IndependentComment _ -> "IndependentComment" IndependentComment _ -> "IndependentComment"
ImportStatement r -> ImportStatement r ->
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
@ -97,8 +91,9 @@ data ImportStatementRecord = ImportStatementRecord
} }
instance Show ImportStatementRecord where instance Show ImportStatementRecord where
show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show show r =
(length $ commentsAfter r) "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r)
transformToCommentedImport transformToCommentedImport
:: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport] :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]
@ -116,10 +111,11 @@ transformToCommentedImport is = do
accumF accConnectedComm (annMay, decl) = case annMay of accumF accConnectedComm (annMay, decl) = case annMay of
Nothing -> Nothing ->
( [] ( []
, [ ImportStatement ImportStatementRecord { commentsBefore = [] , [ ImportStatement ImportStatementRecord
, commentsAfter = [] { commentsBefore = []
, importStatement = decl , commentsAfter = []
} , importStatement = decl
}
] ]
) )
Just ann -> Just ann ->
@ -131,7 +127,7 @@ transformToCommentedImport is = do
:: [(Comment, DeltaPos)] :: [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
-> ([CommentedImport], [(Comment, DeltaPos)], Int) -> ([CommentedImport], [(Comment, DeltaPos)], Int)
go acc [] = ([], acc, 0) go acc [] = ([], acc, 0)
go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1) go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)
go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs
go acc ((c1, DP (y, x)) : xs) = go acc ((c1, DP (y, x)) : xs) =
@ -148,8 +144,8 @@ transformToCommentedImport is = do
, convertedIndependentComments , convertedIndependentComments
++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine
++ [ ImportStatement ImportStatementRecord ++ [ ImportStatement ImportStatementRecord
{ commentsBefore = beforeComments { commentsBefore = beforeComments
, commentsAfter = accConnectedComm , commentsAfter = accConnectedComm
, importStatement = decl , importStatement = decl
} }
] ]
@ -163,14 +159,14 @@ sortCommentedImports =
where where
unpackImports :: [CommentedImport] -> [CommentedImport] unpackImports :: [CommentedImport] -> [CommentedImport]
unpackImports xs = xs >>= \case unpackImports xs = xs >>= \case
l@EmptyLine -> [l] l@EmptyLine -> [l]
l@IndependentComment{} -> [l] l@IndependentComment{} -> [l]
ImportStatement r -> ImportStatement r ->
map IndependentComment (commentsBefore r) ++ [ImportStatement r] map IndependentComment (commentsBefore r) ++ [ImportStatement r]
mergeGroups mergeGroups
:: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport] :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport]
mergeGroups xs = xs >>= \case mergeGroups xs = xs >>= \case
Left x -> [x] Left x -> [x]
Right y -> ImportStatement <$> y Right y -> ImportStatement <$> y
sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord] sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
sortGroups = sortGroups =
@ -180,25 +176,22 @@ sortCommentedImports =
groupify cs = go [] cs groupify cs = go [] cs
where where
go [] = \case go [] = \case
(l@EmptyLine : rest) -> Left l : go [] rest (l@EmptyLine : rest) -> Left l : go [] rest
(l@IndependentComment{} : rest) -> Left l : go [] rest (l@IndependentComment{} : rest) -> Left l : go [] rest
(ImportStatement r : rest) -> go [r] rest (ImportStatement r : rest) -> go [r] rest
[] -> [] [] -> []
go acc = \case go acc = \case
(l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest
(l@IndependentComment{} : rest) -> (l@IndependentComment{} : rest) ->
Left l : Right (reverse acc) : go [] rest Left l : Right (reverse acc) : go [] rest
(ImportStatement r : rest) -> go (r : acc) rest (ImportStatement r : rest) -> go (r : acc) rest
[] -> [Right (reverse acc)] [] -> [Right (reverse acc)]
commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered
commentedImportsToDoc = \case commentedImportsToDoc = \case
EmptyLine -> docLitS "" EmptyLine -> docLitS ""
IndependentComment c -> commentToDoc c IndependentComment c -> commentToDoc c
ImportStatement r -> ImportStatement r -> docSeq
docSeq (layoutImport (importStatement r) : map commentToDoc (commentsAfter r))
( layoutImport (importStatement r)
: map commentToDoc (commentsAfter r)
)
where where
commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c) commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)

81
source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs
View File

@ -31,17 +31,15 @@ import Language.Haskell.Brittany.Internal.Types
-- the different cases below. -- the different cases below.
layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered) layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"
-- _ -> expr -- _ -> expr
VarPat _ n -> VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n
fmap Seq.singleton $ docLit $ lrdrNameToText n
-- abc -> expr -- abc -> expr
LitPat _ lit -> LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr -- 0 -> expr
ParPat _ inner -> do ParPat _ inner -> do
-- (nestedpat) -> expr -- (nestedpat) -> expr
left <- docLit $ Text.pack "(" left <- docLit $ Text.pack "("
right <- docLit $ Text.pack ")" right <- docLit $ Text.pack ")"
innerDocs <- colsWrapPat =<< layoutPat inner innerDocs <- colsWrapPat =<< layoutPat inner
return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right
@ -67,10 +65,9 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
then return <$> docLit nameDoc then return <$> docLit nameDoc
else do else do
x1 <- appSep (docLit nameDoc) x1 <- appSep (docLit nameDoc)
xR <- fmap Seq.fromList xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap
$ sequence colsWrapPat
$ spacifyDocs argDocs
$ fmap colsWrapPat argDocs
return $ x1 Seq.<| xR return $ x1 Seq.<| xR
ConPat _ lname (InfixCon left right) -> do ConPat _ lname (InfixCon left right) -> do
-- a :< b -> expr -- a :< b -> expr
@ -83,7 +80,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
-- Abc{} -> expr -- Abc{} -> expr
let t = lrdrNameToText lname let t = lrdrNameToText lname
fmap Seq.singleton $ docLit $ t <> Text.pack "{}" fmap Seq.singleton $ docLit $ t <> Text.pack "{}"
ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do
-- Abc { a = locA, b = locB, c = locC } -> expr1 -- Abc { a = locA, b = locB, c = locC } -> expr1
-- Abc { a, b, c } -> expr2 -- Abc { a, b, c } -> expr2
let t = lrdrNameToText lname let t = lrdrNameToText lname
@ -96,37 +93,34 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
Seq.singleton <$> docSeq Seq.singleton <$> docSeq
[ appSep $ docLit t [ appSep $ docLit t
, appSep $ docLit $ Text.pack "{" , appSep $ docLit $ Text.pack "{"
, docSeq $ List.intersperse docCommaSep , docSeq $ List.intersperse docCommaSep $ fds <&> \case
$ fds <&> \case (fieldName, Just fieldDoc) -> docSeq
(fieldName, Just fieldDoc) -> docSeq [ appSep $ docLit fieldName
[ appSep $ docLit fieldName , appSep $ docLit $ Text.pack "="
, appSep $ docLit $ Text.pack "=" , fieldDoc >>= colsWrapPat
, fieldDoc >>= colsWrapPat ]
] (fieldName, Nothing) -> docLit fieldName
(fieldName, Nothing) -> docLit fieldName
, docSeparator , docSeparator
, docLit $ Text.pack "}" , docLit $ Text.pack "}"
] ]
ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do
-- Abc { .. } -> expr -- Abc { .. } -> expr
let t = lrdrNameToText lname let t = lrdrNameToText lname
Seq.singleton <$> docSeq Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"]
[ appSep $ docLit t ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti))))
, docLit $ Text.pack "{..}" | dotdoti == length fs -> do
]
ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do
-- Abc { a = locA, .. } -- Abc { a = locA, .. }
let t = lrdrNameToText lname let t = lrdrNameToText lname
fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do
let FieldOcc _ lnameF = fieldOcc let FieldOcc _ lnameF = fieldOcc
fExpDoc <- if pun fExpDoc <- if pun
then return Nothing then return Nothing
else Just <$> docSharedWrapper layoutPat fPat else Just <$> docSharedWrapper layoutPat fPat
return (lrdrNameToText lnameF, fExpDoc) return (lrdrNameToText lnameF, fExpDoc)
Seq.singleton <$> docSeq Seq.singleton <$> docSeq
[ appSep $ docLit t [ appSep $ docLit t
, appSep $ docLit $ Text.pack "{" , appSep $ docLit $ Text.pack "{"
, docSeq $ fds >>= \case , docSeq $ fds >>= \case
(fieldName, Just fieldDoc) -> (fieldName, Just fieldDoc) ->
[ appSep $ docLit fieldName [ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "=" , appSep $ docLit $ Text.pack "="
@ -134,13 +128,13 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
, docCommaSep , docCommaSep
] ]
(fieldName, Nothing) -> [docLit fieldName, docCommaSep] (fieldName, Nothing) -> [docLit fieldName, docCommaSep]
, docLit $ Text.pack "..}" , docLit $ Text.pack "..}"
] ]
TuplePat _ args boxity -> do TuplePat _ args boxity -> do
-- (nestedpat1, nestedpat2, nestedpat3) -> expr -- (nestedpat1, nestedpat2, nestedpat3) -> expr
-- (#nestedpat1, nestedpat2, nestedpat3#) -> expr -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr
case boxity of case boxity of
Boxed -> wrapPatListy args "()" docParenL docParenR Boxed -> wrapPatListy args "()" docParenL docParenR
Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep
AsPat _ asName asPat -> do AsPat _ asName asPat -> do
-- bind@nestedpat -> expr -- bind@nestedpat -> expr
@ -180,7 +174,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
negDoc <- docLit $ Text.pack "-" negDoc <- docLit $ Text.pack "-"
pure $ case mNegative of pure $ case mNegative of
Just{} -> Seq.fromList [negDoc, litDoc] Just{} -> Seq.fromList [negDoc, litDoc]
Nothing -> Seq.singleton litDoc Nothing -> Seq.singleton litDoc
_ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat
@ -189,9 +183,7 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend wrapPatPrepend
:: LPat GhcPs :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered)
-> ToBriDocM BriDocNumbered
-> ToBriDocM (Seq BriDocNumbered)
wrapPatPrepend pat prepElem = do wrapPatPrepend pat prepElem = do
patDocs <- layoutPat pat patDocs <- layoutPat pat
case Seq.viewl patDocs of case Seq.viewl patDocs of
@ -213,8 +205,5 @@ wrapPatListy elems both start end = do
x1 Seq.:< rest -> do x1 Seq.:< rest -> do
sDoc <- start sDoc <- start
eDoc <- end eDoc <- end
rest' <- rest `forM` \bd -> docSeq rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd]
[ docCommaSep
, return bd
]
return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc

27
source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs
View File

@ -47,12 +47,12 @@ layoutStmt lstmt@(L _ stmt) = do
] ]
] ]
LetStmt _ binds -> do LetStmt _ binds -> do
let isFree = indentPolicy == IndentPolicyFree let isFree = indentPolicy == IndentPolicyFree
let indentFourPlus = indentAmount >= 4 let indentFourPlus = indentAmount >= 4
layoutLocalBinds binds >>= \case layoutLocalBinds binds >>= \case
Nothing -> docLit $ Text.pack "let" Nothing -> docLit $ Text.pack "let"
-- i just tested the above, and it is indeed allowed. heh. -- i just tested the above, and it is indeed allowed. heh.
Just [] -> docLit $ Text.pack "let" -- this probably never happens Just [] -> docLit $ Text.pack "let" -- this probably never happens
Just [bindDoc] -> docAlt Just [bindDoc] -> docAlt
[ -- let bind = expr [ -- let bind = expr
docCols docCols
@ -62,9 +62,10 @@ layoutStmt lstmt@(L _ stmt) = do
f = case indentPolicy of f = case indentPolicy of
IndentPolicyFree -> docSetBaseAndIndent IndentPolicyFree -> docSetBaseAndIndent
IndentPolicyLeft -> docForceSingleline IndentPolicyLeft -> docForceSingleline
IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent IndentPolicyMultiple
| otherwise -> docForceSingleline | indentFourPlus -> docSetBaseAndIndent
in f $ return bindDoc | otherwise -> docForceSingleline
in f $ return bindDoc
] ]
, -- let , -- let
-- bind = expr -- bind = expr
@ -78,10 +79,11 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc -- ccc = exprc
addAlternativeCond (isFree || indentFourPlus) $ docSeq addAlternativeCond (isFree || indentFourPlus) $ docSeq
[ appSep $ docLit $ Text.pack "let" [ appSep $ docLit $ Text.pack "let"
, let f = if indentFourPlus , let
then docEnsureIndent BrIndentRegular f = if indentFourPlus
else docSetBaseAndIndent then docEnsureIndent BrIndentRegular
in f $ docLines $ return <$> bindDocs else docSetBaseAndIndent
in f $ docLines $ return <$> bindDocs
] ]
-- let -- let
-- aaa = expra -- aaa = expra
@ -89,8 +91,9 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc -- ccc = exprc
addAlternativeCond (not indentFourPlus) addAlternativeCond (not indentFourPlus)
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar (docLit $ Text.pack "let") $ docPar
(docSetBaseAndIndent $ docLines $ return <$> bindDocs) (docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs)
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1 -- rec stmt1
-- stmt2 -- stmt2

418
source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View File

@ -24,76 +24,63 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsTyVar _ promoted name -> do HsTyVar _ promoted name -> do
t <- lrdrNameToTextAnnTypeEqualityIsSpecial name t <- lrdrNameToTextAnnTypeEqualityIsSpecial name
case promoted of case promoted of
IsPromoted -> docSeq IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
[ docSeparator
, docTick
, docWrapNode name $ docLit t
]
NotPromoted -> docWrapNode name $ docLit t NotPromoted -> docWrapNode name $ docLit t
HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
let bndrs = getBinders hsf let bndrs = getBinders hsf
typeDoc <- docSharedWrapper layoutType typ2 typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let maybeForceML = case typ2 of let
(L _ HsFunTy{}) -> docForceMultiline maybeForceML = case typ2 of
_ -> id (L _ HsFunTy{}) -> docForceMultiline
_ -> id
let let
tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
forallDoc = docAlt forallDoc = docAlt
[ let [ let open = docLit $ Text.pack "forall"
open = docLit $ Text.pack "forall" in docSeq ([open] ++ tyVarDocLineList)
in docSeq ([open]++tyVarDocLineList)
, docPar , docPar
(docLit (Text.pack "forall")) (docLit (Text.pack "forall"))
(docLines (docLines $ tyVarDocs <&> \case
$ tyVarDocs <&> \case (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
(tname, Just doc) -> docEnsureIndent BrIndentRegular [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
$ docLines , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
[ docCols ColTyOpPrefix , docLit $ Text.pack ")"
[ docParenLSep ]
, docLit tname )
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")"
])
] ]
contextDoc = case cntxtDocs of contextDoc = case cntxtDocs of
[] -> docLit $ Text.pack "()" [] -> docLit $ Text.pack "()"
[x] -> x [x] -> x
_ -> docAlt _ -> docAlt
[ let [ let
open = docLit $ Text.pack "(" open = docLit $ Text.pack "("
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep list =
$ docForceSingleline <$> cntxtDocs List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close]) in docSeq ([open] ++ list ++ [close])
, let , let
open = docCols ColTyOpPrefix open = docCols
[ docParenLSep ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs]
]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
docCols ColTyOpPrefix ColTyOpPrefix
[ docCommaSep [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]
, docAddBaseY (BrIndentSpecial 2) cntxtDoc
]
in docPar open $ docLines $ list ++ [close] in docPar open $ docLines $ list ++ [close]
] ]
docAlt docAlt
-- :: forall a b c . (Foo a b c) => a b -> c -- :: forall a b c . (Foo a b c) => a b -> c
[ docSeq [ docSeq
[ if null bndrs [ if null bndrs
then docEmpty then docEmpty
else let else
let
open = docLit $ Text.pack "forall" open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . " close = docLit $ Text.pack " . "
in docSeq ([open, docSeparator]++tyVarDocLineList++[close]) in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close])
, docForceSingleline contextDoc , docForceSingleline contextDoc
, docLit $ Text.pack " => " , docLit $ Text.pack " => "
, docForceSingleline typeDoc , docForceSingleline typeDoc
@ -103,75 +90,74 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- => a b -- => a b
-- -> c -- -> c
, docPar , docPar
forallDoc forallDoc
( docLines (docLines
[ docCols ColTyOpPrefix [ docCols
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 3) [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
$ contextDoc , docAddBaseY (BrIndentSpecial 3) $ contextDoc
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
] ]
) , docCols
ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
]
)
] ]
HsForAllTy _ hsf typ2 -> do HsForAllTy _ hsf typ2 -> do
let bndrs = getBinders hsf let bndrs = getBinders hsf
typeDoc <- layoutType typ2 typeDoc <- layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
let maybeForceML = case typ2 of let
(L _ HsFunTy{}) -> docForceMultiline maybeForceML = case typ2 of
_ -> id (L _ HsFunTy{}) -> docForceMultiline
_ -> id
let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
docAlt docAlt
-- forall x . x -- forall x . x
[ docSeq [ docSeq
[ if null bndrs [ if null bndrs
then docEmpty then docEmpty
else let else
let
open = docLit $ Text.pack "forall" open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . " close = docLit $ Text.pack " . "
in docSeq ([open]++tyVarDocLineList++[close]) in docSeq ([open] ++ tyVarDocLineList ++ [close])
, docForceSingleline $ return $ typeDoc , docForceSingleline $ return $ typeDoc
] ]
-- :: forall x -- :: forall x
-- . x -- . x
, docPar , docPar
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList) (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
( docCols ColTyOpPrefix (docCols
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " ColTyOpPrefix
, maybeForceML $ return typeDoc [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
] , maybeForceML $ return typeDoc
) ]
)
-- :: forall -- :: forall
-- (x :: *) -- (x :: *)
-- . x -- . x
, docPar , docPar
(docLit (Text.pack "forall")) (docLit (Text.pack "forall"))
(docLines (docLines
$ (tyVarDocs <&> \case $ (tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname (tname, Nothing) ->
(tname, Just doc) -> docEnsureIndent BrIndentRegular docEnsureIndent BrIndentRegular $ docLit tname
$ docLines (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines
[ docCols ColTyOpPrefix [ docCols ColTyOpPrefix [docParenLSep, docLit tname]
[ docParenLSep , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]
, docLit tname , docLit $ Text.pack ")"
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")"
]
)
++[ docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
] ]
]
) )
++ [ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
]
)
] ]
HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
typeDoc <- docSharedWrapper layoutType typ1 typeDoc <- docSharedWrapper layoutType typ1
@ -182,29 +168,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[x] -> x [x] -> x
_ -> docAlt _ -> docAlt
[ let [ let
open = docLit $ Text.pack "(" open = docLit $ Text.pack "("
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep list =
$ docForceSingleline <$> cntxtDocs List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close]) in docSeq ([open] ++ list ++ [close])
, let , let
open = docCols ColTyOpPrefix open = docCols
[ docParenLSep ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 2) [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs]
$ head cntxtDocs
]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> list = List.tail cntxtDocs <&> \cntxtDoc -> docCols
docCols ColTyOpPrefix ColTyOpPrefix
[ docCommaSep [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc]
, docAddBaseY (BrIndentSpecial 2)
$ cntxtDoc
]
in docPar open $ docLines $ list ++ [close] in docPar open $ docLines $ list ++ [close]
] ]
let maybeForceML = case typ1 of let
(L _ HsFunTy{}) -> docForceMultiline maybeForceML = case typ1 of
_ -> id (L _ HsFunTy{}) -> docForceMultiline
_ -> id
docAlt docAlt
-- (Foo a b c) => a b -> c -- (Foo a b c) => a b -> c
[ docSeq [ docSeq
@ -216,37 +198,39 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- => a b -- => a b
-- -> c -- -> c
, docPar , docPar
(docForceSingleline contextDoc) (docForceSingleline contextDoc)
( docCols ColTyOpPrefix (docCols
[ docLit $ Text.pack "=> " ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc [ docLit $ Text.pack "=> "
] , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
) ]
)
] ]
HsFunTy _ _ typ1 typ2 -> do HsFunTy _ _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2 typeDoc2 <- docSharedWrapper layoutType typ2
let maybeForceML = case typ2 of let
(L _ HsFunTy{}) -> docForceMultiline maybeForceML = case typ2 of
_ -> id (L _ HsFunTy{}) -> docForceMultiline
_ -> id
hasComments <- hasAnyCommentsBelow ltype hasComments <- hasAnyCommentsBelow ltype
docAlt $ docAlt
[ docSeq $ [ docSeq
[ appSep $ docForceSingleline typeDoc1 [ appSep $ docForceSingleline typeDoc1
, appSep $ docLit $ Text.pack "->" , appSep $ docLit $ Text.pack "->"
, docForceSingleline typeDoc2 , docForceSingleline typeDoc2
]
| not hasComments
] ]
| not hasComments ++ [ docPar
] ++ (docNodeAnnKW ltype Nothing typeDoc1)
[ docPar (docCols
(docNodeAnnKW ltype Nothing typeDoc1) ColTyOpPrefix
( docCols ColTyOpPrefix [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2
, docAddBaseY (BrIndentSpecial 3) ]
$ maybeForceML typeDoc2 )
] ]
)
]
HsParTy _ typ1 -> do HsParTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
@ -256,24 +240,28 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
, docPar , docPar
( docCols ColTyOpPrefix (docCols
[ docWrapNodeRest ltype $ docParenLSep ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 [ docWrapNodeRest ltype $ docParenLSep
]) , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
(docLit $ Text.pack ")") ]
)
(docLit $ Text.pack ")")
] ]
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs]) let
gather list = \case gather
L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1 :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
final -> (final, list) gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1
final -> (final, list)
let (typHead, typRest) = gather [typ2] typ1 let (typHead, typRest) = gather [typ2] typ1
docHead <- docSharedWrapper layoutType typHead docHead <- docSharedWrapper layoutType typHead
docRest <- docSharedWrapper layoutType `mapM` typRest docRest <- docSharedWrapper layoutType `mapM` typRest
docAlt docAlt
[ docSeq [ docSeq
$ docForceSingleline docHead : (docRest >>= \d -> $ docForceSingleline docHead
[ docSeparator, docForceSingleline d ]) : (docRest >>= \d -> [docSeparator, docForceSingleline d])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
] ]
HsAppTy _ typ1 typ2 -> do HsAppTy _ typ1 typ2 -> do
@ -281,13 +269,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc2 <- docSharedWrapper layoutType typ2 typeDoc2 <- docSharedWrapper layoutType typ2
docAlt docAlt
[ docSeq [ docSeq
[ docForceSingleline typeDoc1 [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]
, docSeparator , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)
, docForceSingleline typeDoc2
]
, docPar
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
] ]
HsListTy _ typ1 -> do HsListTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
@ -298,51 +281,61 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "]" , docLit $ Text.pack "]"
] ]
, docPar , docPar
( docCols ColTyOpPrefix (docCols
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ " ColTyOpPrefix
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
]) , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
(docLit $ Text.pack "]") ]
)
(docLit $ Text.pack "]")
] ]
HsTupleTy _ tupleSort typs -> case tupleSort of HsTupleTy _ tupleSort typs -> case tupleSort of
HsUnboxedTuple -> unboxed HsUnboxedTuple -> unboxed
HsBoxedTuple -> simple HsBoxedTuple -> simple
HsConstraintTuple -> simple HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple
where where
unboxed = if null typs then error "brittany internal error: unboxed unit" unboxed = if null typs
else unboxedL then error "brittany internal error: unboxed unit"
else unboxedL
simple = if null typs then unitL else simpleL simple = if null typs then unitL else simpleL
unitL = docLit $ Text.pack "()" unitL = docLit $ Text.pack "()"
simpleL = do simpleL = do
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
let end = docLit $ Text.pack ")" let
lines = List.tail docs <&> \d -> end = docLit $ Text.pack ")"
docAddBaseY (BrIndentSpecial 2) lines =
$ docCols ColTyOpPrefix [docCommaSep, d] List.tail docs
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) <&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
docAlt docAlt
[ docSeq $ [docLit $ Text.pack "("] [ docSeq
++ docWrapNodeRest ltype commaDocs $ [docLit $ Text.pack "("]
++ [end] ++ docWrapNodeRest ltype commaDocs
++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in docPar in
(docAddBaseY (BrIndentSpecial 2) $ line1) docPar
(docLines $ docWrapNodeRest ltype lines ++ [end]) (docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ docWrapNodeRest ltype lines ++ [end])
] ]
unboxedL = do unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
let start = docParenHashLSep let
end = docParenHashRSep start = docParenHashLSep
end = docParenHashRSep
docAlt docAlt
[ docSeq $ [start] [ docSeq
++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) $ [start]
++ [end] ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ [end]
, let , let
line1 = docCols ColTyOpPrefix [start, head docs] line1 = docCols ColTyOpPrefix [start, head docs]
lines = List.tail docs <&> \d -> lines =
docAddBaseY (BrIndentSpecial 2) List.tail docs
$ docCols ColTyOpPrefix [docCommaSep, d] <&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
in docPar in docPar
(docAddBaseY (BrIndentSpecial 2) line1) (docAddBaseY (BrIndentSpecial 2) line1)
(docLines $ lines ++ [end]) (docLines $ lines ++ [end])
@ -411,20 +404,18 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
[ docSeq [ docSeq
[ docWrapNodeRest ltype [ docWrapNodeRest ltype $ docLit $ Text.pack
$ docLit ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1 , docForceSingleline typeDoc1
] ]
, docPar , docPar
( docLit (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)) (docCols
) ColTyOpPrefix
(docCols ColTyOpPrefix [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
[ docWrapNodeRest ltype , docAddBaseY (BrIndentSpecial 2) typeDoc1
$ docLit $ Text.pack ":: " ]
, docAddBaseY (BrIndentSpecial 2) typeDoc1 )
])
] ]
-- TODO: test KindSig -- TODO: test KindSig
HsKindSig _ typ1 kind1 -> do HsKindSig _ typ1 kind1 -> do
@ -465,7 +456,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
] ]
else docPar else docPar
typeDoc1 typeDoc1
( docCols (docCols
ColTyOpPrefix ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: " [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1 , docAddBaseY (BrIndentSpecial 3) kindDoc1
@ -536,7 +527,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
let specialCommaSep = appSep $ docLit $ Text.pack " ," let specialCommaSep = appSep $ docLit $ Text.pack " ,"
docAlt docAlt
[ docSeq [ docSeq
$ [docLit $ Text.pack "'["] $ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs) ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)
++ [docLit $ Text.pack "]"] ++ [docLit $ Text.pack "]"]
, case splitFirstLast typDocs of , case splitFirstLast typDocs of
@ -561,19 +552,23 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
] ]
FirstLast e1 ems eN -> runFilteredAlternative $ do FirstLast e1 ems eN -> runFilteredAlternative $ do
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
$ [docLit $ Text.pack "'["] $ [docLit $ Text.pack "'["]
++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])) ++ List.intersperse
specialCommaSep
(docForceSingleline
<$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])
)
++ [docLit $ Text.pack " ]"] ++ [docLit $ Text.pack " ]"]
addAlternative $ addAlternative
let $ let
start = docCols ColList start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]
[appSep $ docLit $ Text.pack "'[", e1] linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]
linesM = ems <&> \d -> lineN = docCols
docCols ColList [specialCommaSep, d] ColList
lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]
end = docLit $ Text.pack " ]" end = docLit $ Text.pack " ]"
in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
] ]
HsExplicitTupleTy{} -> -- TODO HsExplicitTupleTy{} -> -- TODO
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
@ -584,8 +579,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy NoSourceText _ -> HsStrTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText" error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> HsWildCardTy _ -> docLit $ Text.pack "_"
docLit $ Text.pack "_"
HsSumTy{} -> -- TODO HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype briDocByExactInlineOnly "HsSumTy{}" ltype
HsStarTy _ isUnicode -> do HsStarTy _ isUnicode -> do
@ -598,14 +592,12 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
k <- docSharedWrapper layoutType kind k <- docSharedWrapper layoutType kind
docAlt docAlt
[ docSeq [ docSeq
[ docForceSingleline t [ docForceSingleline t
, docSeparator , docSeparator
, docLit $ Text.pack "@" , docLit $ Text.pack "@"
, docForceSingleline k , docForceSingleline k
] ]
, docPar , docPar t (docSeq [docLit $ Text.pack "@", k])
t
(docSeq [docLit $ Text.pack "@", k ])
] ]
layoutTyVarBndrs layoutTyVarBndrs

17
source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs
View File

@ -18,9 +18,10 @@ obfuscate input = do
let predi x = isAlphaNum x || x `elem` "_'" let predi x = isAlphaNum x || x `elem` "_'"
let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input) let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input)
let idents = Set.toList $ Set.fromList $ filter (all predi) groups let idents = Set.toList $ Set.fromList $ filter (all predi) groups
let exceptionFilter x | x `elem` keywords = False let
exceptionFilter x | x `elem` extraKWs = False exceptionFilter x | x `elem` keywords = False
exceptionFilter x = not $ null $ drop 1 x exceptionFilter x | x `elem` extraKWs = False
exceptionFilter x = not $ null $ drop 1 x
let filtered = filter exceptionFilter idents let filtered = filter exceptionFilter idents
mappings <- fmap Map.fromList $ filtered `forM` \x -> do mappings <- fmap Map.fromList $ filtered `forM` \x -> do
r <- createAlias x r <- createAlias x
@ -72,14 +73,14 @@ extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"]
createAlias :: String -> IO String createAlias :: String -> IO String
createAlias xs = go NoHint xs createAlias xs = go NoHint xs
where where
go _hint "" = pure "" go _hint "" = pure ""
go hint (c : cr) = do go hint (c : cr) = do
c' <- case hint of c' <- case hint of
VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z'] VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z']
_ | isUpper c -> randomFrom ['A' .. 'Z'] _ | isUpper c -> randomFrom ['A' .. 'Z']
VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z'] VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z']
_ | isLower c -> randomFrom ['a' .. 'z'] _ | isLower c -> randomFrom ['a' .. 'z']
_ -> pure c _ -> pure c
cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr
pure (c' : cr') pure (c' : cr')

10
source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs
View File

@ -27,12 +27,12 @@ instance Alternative Strict.Maybe where
x <|> Strict.Nothing = x x <|> Strict.Nothing = x
_ <|> x = x _ <|> x = x
traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b) traceFunctionWith
:: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
traceFunctionWith name s1 s2 f x = trace traceStr y traceFunctionWith name s1 s2 f x = trace traceStr y
where where
y = f x y = f x
traceStr = traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y
(<&!>) :: Monad m => m a -> (a -> b) -> m b (<&!>) :: Monad m => m a -> (a -> b) -> m b
(<&!>) = flip (<$!>) (<&!>) = flip (<$!>)
@ -48,10 +48,10 @@ printErr = putStrErrLn . show
errorIf :: Bool -> a -> a errorIf :: Bool -> a -> a
errorIf False = id errorIf False = id
errorIf True = error "errorIf" errorIf True = error "errorIf"
errorIfNote :: Maybe String -> a -> a errorIfNote :: Maybe String -> a -> a
errorIfNote Nothing = id errorIfNote Nothing = id
errorIfNote (Just x) = error x errorIfNote (Just x) = error x
(<&>) :: Functor f => f a -> (a -> b) -> f b (<&>) :: Functor f => f a -> (a -> b) -> f b

1370
source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
View File

File diff suppressed because it is too large Load Diff

191
source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs
View File

@ -16,118 +16,147 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
-- BDWrapAnnKey annKey $ transformSimplify bd -- BDWrapAnnKey annKey $ transformSimplify bd
BDEmpty -> Nothing BDEmpty -> Nothing
BDLit{} -> Nothing BDLit{} -> Nothing
BDSeq list | any (\case BDSeq{} -> True BDSeq list
BDEmpty{} -> True | any
_ -> False) list -> Just $ BDSeq $ list >>= \case (\case
BDEmpty -> [] BDSeq{} -> True
BDSeq l -> l BDEmpty{} -> True
x -> [x] _ -> False
BDSeq (BDCols sig1 cols1@(_:_):rest) )
| all (\case BDSeparator -> True; _ -> False) rest -> list
Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)]) -> Just $ BDSeq $ list >>= \case
BDLines lines | any (\case BDLines{} -> True BDEmpty -> []
BDEmpty{} -> True BDSeq l -> l
_ -> False) lines -> x -> [x]
Just $ BDLines $ filter isNotEmpty $ lines >>= \case BDSeq (BDCols sig1 cols1@(_ : _) : rest)
| all
(\case
BDSeparator -> True
_ -> False
)
rest
-> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)])
BDLines lines
| any
(\case
BDLines{} -> True
BDEmpty{} -> True
_ -> False
)
lines
-> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l BDLines l -> l
x -> [x] x -> [x]
-- prior floating in -- prior floating in
BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDLines (l:lr)) -> BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l:lr) Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
-- post floating in -- post floating in
BDAnnotationRest annKey1 (BDSeq list) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationKW annKey1 kw (BDSeq list) -> BDAnnotationKW annKey1 kw (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) -> BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationKW annKey1 kw $ List.last cols]
-- ensureIndent float-in -- ensureIndent float-in
-- not sure if the following rule is necessary; tests currently are -- not sure if the following rule is necessary; tests currently are
-- unaffected. -- unaffected.
-- BDEnsureIndent indent (BDLines lines) -> -- BDEnsureIndent indent (BDLines lines) ->
-- Just $ BDLines $ BDEnsureIndent indent <$> lines -- Just $ BDLines $ BDEnsureIndent indent <$> lines
-- matching col special transformation -- matching col special transformation
BDCols sig1 cols1@(_:_) BDCols sig1 cols1@(_ : _)
| BDLines lines@(_:_:_) <- List.last cols1 | BDLines lines@(_ : _ : _) <- List.last cols1
, BDCols sig2 cols2 <- List.last lines , BDCols sig2 cols2 <- List.last lines
, sig1==sig2 -> , sig1 == sig2
Just $ BDLines -> Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDCols sig1 cols1@(_:_) BDCols sig1 cols1@(_ : _)
| BDLines lines@(_:_:_) <- List.last cols1 | BDLines lines@(_ : _ : _) <- List.last cols1
, BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines
, sig1==sig2 -> , sig1 == sig2
Just $ BDLines -> Just $ BDLines
[ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines] [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 -> BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 ->
Just $ BDAddBaseY ind (BDLines [col1, col2]) Just $ BDAddBaseY ind (BDLines [col1, col2])
BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest)) BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest))
| sig1==sig2 -> | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)
BDPar ind (BDLines lines1) col2@(BDCols sig2 _) BDPar ind (BDLines lines1) col2@(BDCols sig2 _)
| BDCols sig1 _ <- List.last lines1 | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just
, sig1==sig2 -> $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])
Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest))
BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest)) | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just
| BDCols sig1 _ <- List.last lines1 $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest)
, sig1==sig2 ->
Just $ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest)
-- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2)) -- BDPar ind1 (BDCols sig1 cols1) (BDPar ind2 line (BDCols sig2 cols2))
-- | sig1==sig2 -> -- | sig1==sig2 ->
-- Just $ BDPar -- Just $ BDPar
-- ind1 -- ind1
-- (BDLines [BDCols sig1 cols1, BDCols sig]) -- (BDLines [BDCols sig1 cols1, BDCols sig])
BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols BDCols sig1 cols
, sig1==sig2 -> | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2
Just $ BDLines -> Just
[ BDCols sig1 (List.init cols ++ [line]) $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2]
BDCols sig1 cols
| BDPar ind line (BDLines lines) <- List.last cols
, BDCols sig2 cols2 <- List.last lines
, sig1 == sig2
-> Just $ BDLines
[ BDCols sig1
$ List.init cols
++ [BDPar ind line (BDLines $ List.init lines)]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols BDLines [x] -> Just $ x
, BDCols sig2 cols2 <- List.last lines BDLines [] -> Just $ BDEmpty
, sig1==sig2 -> BDSeq{} -> Nothing
Just $ BDLines BDCols{} -> Nothing
[ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)] BDSeparator -> Nothing
, BDCols sig2 cols2 BDAddBaseY{} -> Nothing
] BDBaseYPushCur{} -> Nothing
BDLines [x] -> Just $ x BDBaseYPop{} -> Nothing
BDLines [] -> Just $ BDEmpty
BDSeq{} -> Nothing
BDCols{} -> Nothing
BDSeparator -> Nothing
BDAddBaseY{} -> Nothing
BDBaseYPushCur{} -> Nothing
BDBaseYPop{} -> Nothing
BDIndentLevelPushCur{} -> Nothing BDIndentLevelPushCur{} -> Nothing
BDIndentLevelPop{} -> Nothing BDIndentLevelPop{} -> Nothing
BDPar{} -> Nothing BDPar{} -> Nothing
BDAlt{} -> Nothing BDAlt{} -> Nothing
BDForceMultiline{} -> Nothing BDForceMultiline{} -> Nothing
BDForceSingleline{} -> Nothing BDForceSingleline{} -> Nothing
BDForwardLineMode{} -> Nothing BDForwardLineMode{} -> Nothing
BDExternal{} -> Nothing BDExternal{} -> Nothing
BDPlain{} -> Nothing BDPlain{} -> Nothing
BDLines{} -> Nothing BDLines{} -> Nothing
BDAnnotationPrior{} -> Nothing BDAnnotationPrior{} -> Nothing
BDAnnotationKW{} -> Nothing BDAnnotationKW{} -> Nothing
BDAnnotationRest{} -> Nothing BDAnnotationRest{} -> Nothing
BDMoveToKWDP{} -> Nothing BDMoveToKWDP{} -> Nothing
BDEnsureIndent{} -> Nothing BDEnsureIndent{} -> Nothing
BDSetParSpacing{} -> Nothing BDSetParSpacing{} -> Nothing
BDForceParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing
BDDebug{} -> Nothing BDDebug{} -> Nothing
BDNonBottomSpacing _ x -> Just x BDNonBottomSpacing _ x -> Just x

358
source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs
View File

@ -14,10 +14,11 @@ import Language.Haskell.Brittany.Internal.Utils
-- note that this is not total, and cannot be with that exact signature. -- note that this is not total, and cannot be with that exact signature.
mergeIndents :: BrIndent -> BrIndent -> BrIndent mergeIndents :: BrIndent -> BrIndent -> BrIndent
mergeIndents BrIndentNone x = x mergeIndents BrIndentNone x = x
mergeIndents x BrIndentNone = x mergeIndents x BrIndentNone = x
mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j) mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) =
mergeIndents _ _ = error "mergeIndents" BrIndentSpecial (max i j)
mergeIndents _ _ = error "mergeIndents"
transformSimplifyFloating :: BriDoc -> BriDoc transformSimplifyFloating :: BriDoc -> BriDoc
@ -27,169 +28,186 @@ transformSimplifyFloating = stepBO .> stepFull
-- better complexity. -- better complexity.
-- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence
-- the push/pop cases would need to be copied over -- the push/pop cases would need to be copied over
where where
descendPrior = transformDownMay $ \case descendPrior = transformDownMay $ \case
-- prior floating in -- prior floating in
BDAnnotationPrior annKey1 (BDPar ind line indented) -> BDAnnotationPrior annKey1 (BDPar ind line indented) ->
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
Just $ BDSeq (BDAnnotationPrior annKey1 l:lr) Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDLines (l:lr)) -> BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
Just $ BDLines (BDAnnotationPrior annKey1 l:lr) Just $ BDLines (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr) Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)
BDAnnotationPrior annKey1 (BDAddBaseY indent x) -> BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x
BDAnnotationPrior annKey1 (BDDebug s x) -> BDAnnotationPrior annKey1 (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationPrior annKey1 x Just $ BDDebug s $ BDAnnotationPrior annKey1 x
_ -> Nothing _ -> Nothing
descendRest = transformDownMay $ \case descendRest = transformDownMay $ \case
-- post floating in -- post floating in
BDAnnotationRest annKey1 (BDPar ind line indented) -> BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) -> BDAnnotationRest annKey1 (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] Just
BDAnnotationRest annKey1 (BDLines list) -> $ BDSeq
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] $ List.init list
BDAnnotationRest annKey1 (BDCols sig cols) -> ++ [BDAnnotationRest annKey1 $ List.last list]
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] BDAnnotationRest annKey1 (BDLines list) ->
BDAnnotationRest annKey1 (BDAddBaseY indent x) -> Just
Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x $ BDLines
BDAnnotationRest annKey1 (BDDebug s x) -> $ List.init list
Just $ BDDebug s $ BDAnnotationRest annKey1 x ++ [BDAnnotationRest annKey1 $ List.last list]
_ -> Nothing BDAnnotationRest annKey1 (BDCols sig cols) ->
descendKW = transformDownMay $ \case Just
-- post floating in $ BDCols sig
BDAnnotationKW annKey1 kw (BDPar ind line indented) -> $ List.init cols
Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented ++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationKW annKey1 kw (BDSeq list) -> BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
BDAnnotationKW annKey1 kw (BDLines list) -> BDAnnotationRest annKey1 (BDDebug s x) ->
Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list] Just $ BDDebug s $ BDAnnotationRest annKey1 x
BDAnnotationKW annKey1 kw (BDCols sig cols) -> _ -> Nothing
Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols] descendKW = transformDownMay $ \case
BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> -- post floating in
Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
BDAnnotationKW annKey1 kw (BDDebug s x) -> Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
Just $ BDDebug s $ BDAnnotationKW annKey1 kw x BDAnnotationKW annKey1 kw (BDSeq list) ->
_ -> Nothing Just
descendBYPush = transformDownMay $ \case $ BDSeq
BDBaseYPushCur (BDCols sig cols@(_:_)) -> $ List.init list
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) ++ [BDAnnotationKW annKey1 kw $ List.last list]
BDBaseYPushCur (BDDebug s x) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just $ BDDebug s (BDBaseYPushCur x) Just
_ -> Nothing $ BDLines
descendBYPop = transformDownMay $ \case $ List.init list
BDBaseYPop (BDCols sig cols@(_:_)) -> ++ [BDAnnotationKW annKey1 kw $ List.last list]
Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) BDAnnotationKW annKey1 kw (BDCols sig cols) ->
BDBaseYPop (BDDebug s x) -> Just
Just $ BDDebug s (BDBaseYPop x) $ BDCols sig
_ -> Nothing $ List.init cols
descendILPush = transformDownMay $ \case ++ [BDAnnotationKW annKey1 kw $ List.last cols]
BDIndentLevelPushCur (BDCols sig cols@(_:_)) -> BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
BDIndentLevelPushCur (BDDebug s x) -> BDAnnotationKW annKey1 kw (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPushCur x) Just $ BDDebug s $ BDAnnotationKW annKey1 kw x
_ -> Nothing _ -> Nothing
descendILPop = transformDownMay $ \case descendBYPush = transformDownMay $ \case
BDIndentLevelPop (BDCols sig cols@(_:_)) -> BDBaseYPushCur (BDCols sig cols@(_ : _)) ->
Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
BDIndentLevelPop (BDDebug s x) -> BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x)
Just $ BDDebug s (BDIndentLevelPop x) _ -> Nothing
_ -> Nothing descendBYPop = transformDownMay $ \case
descendAddB = transformDownMay $ \case BDBaseYPop (BDCols sig cols@(_ : _)) ->
BDAddBaseY BrIndentNone x -> Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])
Just x BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x)
-- AddIndent floats into Lines. _ -> Nothing
BDAddBaseY indent (BDLines lines) -> descendILPush = transformDownMay $ \case
Just $ BDLines $ BDAddBaseY indent <$> lines BDIndentLevelPushCur (BDCols sig cols@(_ : _)) ->
-- AddIndent floats into last column Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
BDAddBaseY indent (BDCols sig cols) -> BDIndentLevelPushCur (BDDebug s x) ->
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] Just $ BDDebug s (BDIndentLevelPushCur x)
-- merge AddIndent and Par _ -> Nothing
BDAddBaseY ind1 (BDPar ind2 line indented) -> descendILPop = transformDownMay $ \case
Just $ BDPar (mergeIndents ind1 ind2) line indented BDIndentLevelPop (BDCols sig cols@(_ : _)) ->
BDAddBaseY ind (BDAnnotationPrior annKey1 x) -> Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])
Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x) BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x)
BDAddBaseY ind (BDAnnotationRest annKey1 x) -> _ -> Nothing
Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x) descendAddB = transformDownMay $ \case
BDAddBaseY ind (BDAnnotationKW annKey1 kw x) -> BDAddBaseY BrIndentNone x -> Just x
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) -- AddIndent floats into Lines.
BDAddBaseY ind (BDSeq list) -> BDAddBaseY indent (BDLines lines) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDLines $ BDAddBaseY indent <$> lines
BDAddBaseY _ lit@BDLit{} -> -- AddIndent floats into last column
Just $ lit BDAddBaseY indent (BDCols sig cols) ->
BDAddBaseY ind (BDBaseYPushCur x) -> Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
Just $ BDBaseYPushCur (BDAddBaseY ind x) -- merge AddIndent and Par
BDAddBaseY ind (BDBaseYPop x) -> BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDBaseYPop (BDAddBaseY ind x) Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY ind (BDDebug s x) -> BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->
Just $ BDDebug s (BDAddBaseY ind x) Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPop x) -> BDAddBaseY ind (BDAnnotationRest annKey1 x) ->
Just $ BDIndentLevelPop (BDAddBaseY ind x) Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPushCur x) -> BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->
Just $ BDIndentLevelPushCur (BDAddBaseY ind x) Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
BDAddBaseY ind (BDEnsureIndent ind2 x) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDEnsureIndent (mergeIndents ind ind2) x Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
_ -> Nothing BDAddBaseY _ lit@BDLit{} -> Just $ lit
stepBO :: BriDoc -> BriDoc BDAddBaseY ind (BDBaseYPushCur x) ->
stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ Just $ BDBaseYPushCur (BDAddBaseY ind x)
transformUp f BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
where BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x)
f = \case BDAddBaseY ind (BDIndentLevelPop x) ->
x@BDAnnotationPrior{} -> descendPrior x Just $ BDIndentLevelPop (BDAddBaseY ind x)
x@BDAnnotationKW{} -> descendKW x BDAddBaseY ind (BDIndentLevelPushCur x) ->
x@BDAnnotationRest{} -> descendRest x Just $ BDIndentLevelPushCur (BDAddBaseY ind x)
x@BDAddBaseY{} -> descendAddB x BDAddBaseY ind (BDEnsureIndent ind2 x) ->
x@BDBaseYPushCur{} -> descendBYPush x Just $ BDEnsureIndent (mergeIndents ind ind2) x
x@BDBaseYPop{} -> descendBYPop x _ -> Nothing
x@BDIndentLevelPushCur{} -> descendILPush x stepBO :: BriDoc -> BriDoc
x@BDIndentLevelPop{} -> descendILPop x stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
x -> x transformUp f
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ where
Uniplate.rewrite $ \case f = \case
BDAddBaseY BrIndentNone x -> x@BDAnnotationPrior{} -> descendPrior x
Just $ x x@BDAnnotationKW{} -> descendKW x
-- AddIndent floats into Lines. x@BDAnnotationRest{} -> descendRest x
BDAddBaseY indent (BDLines lines) -> x@BDAddBaseY{} -> descendAddB x
Just $ BDLines $ BDAddBaseY indent <$> lines x@BDBaseYPushCur{} -> descendBYPush x
-- AddIndent floats into last column x@BDBaseYPop{} -> descendBYPop x
BDAddBaseY indent (BDCols sig cols) -> x@BDIndentLevelPushCur{} -> descendILPush x
Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols] x@BDIndentLevelPop{} -> descendILPop x
BDAddBaseY ind (BDSeq list) -> x -> x
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
-- merge AddIndent and Par Uniplate.rewrite $ \case
BDAddBaseY ind1 (BDPar ind2 line indented) -> BDAddBaseY BrIndentNone x -> Just $ x
Just $ BDPar (mergeIndents ind1 ind2) line indented -- AddIndent floats into Lines.
BDAddBaseY _ lit@BDLit{} -> BDAddBaseY indent (BDLines lines) ->
Just $ lit Just $ BDLines $ BDAddBaseY indent <$> lines
BDAddBaseY ind (BDBaseYPushCur x) -> -- AddIndent floats into last column
Just $ BDBaseYPushCur (BDAddBaseY ind x) BDAddBaseY indent (BDCols sig cols) ->
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
Just $ BDBaseYPop (BDAddBaseY ind x) BDAddBaseY ind (BDSeq list) ->
-- prior floating in Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAnnotationPrior annKey1 (BDPar ind line indented) -> -- merge AddIndent and Par
Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented BDAddBaseY ind1 (BDPar ind2 line indented) ->
BDAnnotationPrior annKey1 (BDSeq (l:lr)) -> Just $ BDPar (mergeIndents ind1 ind2) line indented
Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr) BDAddBaseY _ lit@BDLit{} -> Just $ lit
BDAnnotationPrior annKey1 (BDLines (l:lr)) -> BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDLines ((BDAnnotationPrior annKey1 l):lr) Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAnnotationPrior annKey1 (BDCols sig (l:lr)) -> BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)
Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr) -- prior floating in
-- EnsureIndent float-in BDAnnotationPrior annKey1 (BDPar ind line indented) ->
-- BDEnsureIndent indent (BDCols sig (col:colr)) -> Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented
-- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->
-- not sure if the following rule is necessary; tests currently are Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr)
-- unaffected. BDAnnotationPrior annKey1 (BDLines (l : lr)) ->
-- BDEnsureIndent indent (BDLines lines) -> Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr)
-- Just $ BDLines $ BDEnsureIndent indent <$> lines BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->
-- post floating in Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr)
BDAnnotationRest annKey1 (BDPar ind line indented) -> -- EnsureIndent float-in
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented -- BDEnsureIndent indent (BDCols sig (col:colr)) ->
BDAnnotationRest annKey1 (BDSeq list) -> -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))
Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] -- not sure if the following rule is necessary; tests currently are
BDAnnotationRest annKey1 (BDLines list) -> -- unaffected.
Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list] -- BDEnsureIndent indent (BDLines lines) ->
BDAnnotationRest annKey1 (BDCols sig cols) -> -- Just $ BDLines $ BDEnsureIndent indent <$> lines
Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols] -- post floating in
_ -> Nothing BDAnnotationRest annKey1 (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationRest annKey1 indented
BDAnnotationRest annKey1 (BDSeq list) ->
Just
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) ->
Just
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) ->
Just
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
_ -> Nothing

20
source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs
View File

@ -27,15 +27,17 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
-- [ BDAddBaseY ind x -- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented -- , BDEnsureIndent ind indented
-- ] -- ]
BDLines lines | any ( \case BDLines lines
BDLines{} -> True | any
BDEmpty{} -> True (\case
_ -> False BDLines{} -> True
) BDEmpty{} -> True
lines -> _ -> False
Just $ BDLines $ filter isNotEmpty $ lines >>= \case )
lines
-> Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l BDLines l -> l
x -> [x] x -> [x]
BDLines [l] -> Just l BDLines [l] -> Just l
BDAddBaseY i (BDAnnotationPrior k x) -> BDAddBaseY i (BDAnnotationPrior k x) ->
Just $ BDAnnotationPrior k (BDAddBaseY i x) Just $ BDAnnotationPrior k (BDAddBaseY i x)
@ -49,4 +51,4 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l] Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]
BDAddBaseY _ lit@BDLit{} -> Just lit BDAddBaseY _ lit@BDLit{} -> Just lit
_ -> Nothing _ -> Nothing

31
source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs
View File

@ -21,25 +21,28 @@ transformSimplifyPar = transformUp $ \case
BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds)) BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))
BDPar ind1 (BDPar ind2 line p1) p2 -> BDPar ind1 (BDPar ind2 line p1) p2 ->
BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2]) BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])
BDLines lines | any ( \case BDLines lines
BDLines{} -> True | any
BDEmpty{} -> True (\case
_ -> False BDLines{} -> True
) BDEmpty{} -> True
lines -> case go lines of _ -> False
[] -> BDEmpty )
[x] -> x lines
xs -> BDLines xs -> case go lines of
[] -> BDEmpty
[x] -> x
xs -> BDLines xs
where where
go = (=<<) $ \case go = (=<<) $ \case
BDLines l -> go l BDLines l -> go l
BDEmpty -> [] BDEmpty -> []
x -> [x] x -> [x]
BDLines [] -> BDEmpty BDLines [] -> BDEmpty
BDLines [x] -> x BDLines [x] -> x
-- BDCols sig cols | BDPar ind line indented <- List.last cols -> -- BDCols sig cols | BDPar ind line indented <- List.last cols ->
-- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented -- Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented
-- BDPar BrIndentNone line indented -> -- BDPar BrIndentNone line indented ->
-- Just $ BDLines [line, indented] -- Just $ BDLines [line, indented]
BDEnsureIndent BrIndentNone x -> x BDEnsureIndent BrIndentNone x -> x
x -> x x -> x

97
source/library/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -61,24 +61,26 @@ instance (Num a, Ord a) => Semigroup (Max a) where
(<>) = Data.Coerce.coerce (max :: a -> a -> a) (<>) = Data.Coerce.coerce (max :: a -> a -> a)
instance (Num a, Ord a) => Monoid (Max a) where instance (Num a, Ord a) => Monoid (Max a) where
mempty = Max 0 mempty = Max 0
mappend = (<>) mappend = (<>)
newtype ShowIsId = ShowIsId String deriving Data newtype ShowIsId = ShowIsId String deriving Data
instance Show ShowIsId where show (ShowIsId x) = x instance Show ShowIsId where
show (ShowIsId x) = x
data A x = A ShowIsId x deriving Data data A x = A ShowIsId x
deriving Data
customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF :: ExactPrint.Types.Anns -> LayouterF
customLayouterF anns layoutF = customLayouterF anns layoutF =
DataToLayouter DataToLayouter
$ f $ f
`extQ` showIsId `extQ` showIsId
`extQ` fastString `extQ` fastString
`extQ` bytestring `extQ` bytestring
`extQ` occName `extQ` occName
`extQ` srcSpan `extQ` srcSpan
`ext2Q` located `ext2Q` located
where where
DataToLayouter f = defaultLayouterF layoutF DataToLayouter f = defaultLayouterF layoutF
@ -86,18 +88,22 @@ customLayouterF anns layoutF =
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s Left True -> PP.parens $ PP.text s
Left False -> PP.text s Left False -> PP.text s
Right _ -> PP.text s Right _ -> PP.text s
fastString = fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter -> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter srcSpan ss =
simpleLayouter
-- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}" -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
$ "{" ++ showOutputable ss ++ "}" $ "{"
++ showOutputable ss
++ "}"
located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
where where
@ -109,12 +115,12 @@ customLayouterF anns layoutF =
customLayouterNoAnnsF :: LayouterF customLayouterNoAnnsF :: LayouterF
customLayouterNoAnnsF layoutF = customLayouterNoAnnsF layoutF =
DataToLayouter DataToLayouter
$ f $ f
`extQ` showIsId `extQ` showIsId
`extQ` fastString `extQ` fastString
`extQ` bytestring `extQ` bytestring
`extQ` occName `extQ` occName
`extQ` srcSpan `extQ` srcSpan
`ext2Q` located `ext2Q` located
where where
DataToLayouter f = defaultLayouterF layoutF DataToLayouter f = defaultLayouterF layoutF
@ -122,14 +128,15 @@ customLayouterNoAnnsF layoutF =
simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s) simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)
showIsId :: ShowIsId -> NodeLayouter showIsId :: ShowIsId -> NodeLayouter
showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case
Left True -> PP.parens $ PP.text s Left True -> PP.parens $ PP.text s
Left False -> PP.text s Left False -> PP.text s
Right _ -> PP.text s Right _ -> PP.text s
fastString = fastString =
simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString
-> NodeLayouter -> NodeLayouter
bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter
occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString occName =
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}" srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"
located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter
@ -193,12 +200,11 @@ traceIfDumpConf s accessor val = do
whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do
trace ("---- " ++ s ++ " ----\n" ++ show val) $ return () trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
tellDebugMess :: MonadMultiWriter tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m ()
(Seq String) m => String -> m ()
tellDebugMess s = mTell $ Seq.singleton s tellDebugMess s = mTell $ Seq.singleton s
tellDebugMessShow :: forall a m . (MonadMultiWriter tellDebugMessShow
(Seq String) m, Show a) => a -> m () :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()
tellDebugMessShow = tellDebugMess . show tellDebugMessShow = tellDebugMess . show
-- i should really put that into multistate.. -- i should really put that into multistate..
@ -213,29 +219,28 @@ briDocToDoc = astToDoc . removeAnnotations
where where
removeAnnotations = Uniplate.transform $ \case removeAnnotations = Uniplate.transform $ \case
BDAnnotationPrior _ x -> x BDAnnotationPrior _ x -> x
BDAnnotationKW _ _ x -> x BDAnnotationKW _ _ x -> x
BDAnnotationRest _ x -> x BDAnnotationRest _ x -> x
x -> x x -> x
briDocToDocWithAnns :: BriDoc -> PP.Doc briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show) annsDoc =
printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
breakEither :: (a -> Either b c) -> [a] -> ([b], [c]) breakEither :: (a -> Either b c) -> [a] -> ([b], [c])
breakEither _ [] = ([], []) breakEither _ [] = ([], [])
breakEither fn (a1:aR) = case fn a1 of breakEither fn (a1 : aR) = case fn a1 of
Left b -> (b : bs, cs) Left b -> (b : bs, cs)
Right c -> (bs, c : cs) Right c -> (bs, c : cs)
where where (bs, cs) = breakEither fn aR
(bs, cs) = breakEither fn aR
spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a]) spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs) spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs)
where where (ys, xs) = spanMaybe f xR
(ys, xs) = spanMaybe f xR spanMaybe _ xs = ([], xs)
spanMaybe _ xs = ([], xs)
data FirstLastView a data FirstLastView a
= FirstLastEmpty = FirstLastEmpty
@ -245,7 +250,7 @@ data FirstLastView a
splitFirstLast :: [a] -> FirstLastView a splitFirstLast :: [a] -> FirstLastView a
splitFirstLast [] = FirstLastEmpty splitFirstLast [] = FirstLastEmpty
splitFirstLast [x] = FirstLastSingleton x splitFirstLast [x] = FirstLastSingleton x
splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr) splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr)
-- TODO: move to uniplate upstream? -- TODO: move to uniplate upstream?
-- aka `transform` -- aka `transform`
@ -264,7 +269,7 @@ lines' :: String -> [String]
lines' s = case break (== '\n') s of lines' s = case break (== '\n') s of
(s1, []) -> [s1] (s1, []) -> [s1]
(s1, [_]) -> [s1, ""] (s1, [_]) -> [s1, ""]
(s1, (_:r)) -> s1 : lines' r (s1, (_ : r)) -> s1 : lines' r
absurdExt :: HsExtension.NoExtCon -> a absurdExt :: HsExtension.NoExtCon -> a
absurdExt = HsExtension.noExtCon absurdExt = HsExtension.noExtCon

217
source/library/Language/Haskell/Brittany/Main.hs
View File

@ -105,7 +105,7 @@ helpDoc = PP.vcat $ List.intersperse
] ]
, parDoc $ "See https://github.com/lspitzner/brittany" , parDoc $ "See https://github.com/lspitzner/brittany"
, parDoc , parDoc
$ "Please report bugs at" $ "Please report bugs at"
++ " https://github.com/lspitzner/brittany/issues" ++ " https://github.com/lspitzner/brittany/issues"
] ]
@ -142,15 +142,16 @@ mainCmdParser helpDesc = do
addCmd "license" $ addCmdImpl $ print $ licenseDoc addCmd "license" $ addCmdImpl $ print $ licenseDoc
-- addButcherDebugCommand -- addButcherDebugCommand
reorderStart reorderStart
printHelp <- addSimpleBoolFlag "h" ["help"] mempty printHelp <- addSimpleBoolFlag "h" ["help"] mempty
printVersion <- addSimpleBoolFlag "" ["version"] mempty printVersion <- addSimpleBoolFlag "" ["version"] mempty
printLicense <- addSimpleBoolFlag "" ["license"] mempty printLicense <- addSimpleBoolFlag "" ["license"] mempty
noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty
configPaths <- addFlagStringParams "" configPaths <- addFlagStringParams
["config-file"] ""
"PATH" ["config-file"]
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? "PATH"
cmdlineConfig <- cmdlineConfigParser (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
cmdlineConfig <- cmdlineConfigParser
suppressOutput <- addSimpleBoolFlag suppressOutput <- addSimpleBoolFlag
"" ""
["suppress-output"] ["suppress-output"]
@ -176,7 +177,7 @@ mainCmdParser helpDesc = do
"" ""
["write-mode"] ["write-mode"]
"(display|inplace)" "(display|inplace)"
( flagHelp (flagHelp
(PP.vcat (PP.vcat
[ PP.text "display: output for any input(s) goes to stdout" [ PP.text "display: output for any input(s) goes to stdout"
, PP.text "inplace: override respective input file (without backup!)" , PP.text "inplace: override respective input file (without backup!)"
@ -206,11 +207,12 @@ mainCmdParser helpDesc = do
$ ppHelpShallow helpDesc $ ppHelpShallow helpDesc
System.Exit.exitSuccess System.Exit.exitSuccess
let inputPaths = let
if null inputParams then [Nothing] else map Just inputParams inputPaths = if null inputParams then [Nothing] else map Just inputParams
let outputPaths = case writeMode of let
Display -> repeat Nothing outputPaths = case writeMode of
Inplace -> inputPaths Display -> repeat Nothing
Inplace -> inputPaths
configsToLoad <- liftIO $ if null configPaths configsToLoad <- liftIO $ if null configPaths
then then
@ -225,14 +227,15 @@ mainCmdParser helpDesc = do
) )
>>= \case >>= \case
Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53) Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)
Just x -> return x Just x -> return x
when (config & _conf_debug & _dconf_dump_config & confUnpack) when (config & _conf_debug & _dconf_dump_config & confUnpack)
$ trace (showConfigYaml config) $ trace (showConfigYaml config)
$ return () $ return ()
results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode) results <- zipWithM
inputPaths (coreIO putStrErrLn config suppressOutput checkMode)
outputPaths inputPaths
outputPaths
if checkMode if checkMode
then when (Changes `elem` (Data.Either.rights results)) then when (Changes `elem` (Data.Either.rights results))
@ -268,51 +271,57 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
-- amount of slight differences: This module is a bit more verbose, and -- amount of slight differences: This module is a bit more verbose, and
-- it tries to use the full-blown `parseModule` function which supports -- it tries to use the full-blown `parseModule` function which supports
-- CPP (but requires the input to be a file..). -- CPP (but requires the input to be a file..).
let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack
-- the flag will do the following: insert a marker string -- the flag will do the following: insert a marker string
-- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with
-- "#include" before processing (parsing) input; and remove that marker -- "#include" before processing (parsing) input; and remove that marker
-- string from the transformation output. -- string from the transformation output.
-- The flag is intentionally misspelled to prevent clashing with -- The flag is intentionally misspelled to prevent clashing with
-- inline-config stuff. -- inline-config stuff.
let hackAroundIncludes = let
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack hackAroundIncludes =
let exactprintOnly = viaGlobal || viaDebug config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
where let
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack exactprintOnly = viaGlobal || viaDebug
viaDebug = where
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
viaDebug =
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags let
then case cppMode of cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
CPPModeAbort -> do then case cppMode of
return $ Left "Encountered -XCPP. Aborting." CPPModeAbort -> do
CPPModeWarn -> do return $ Left "Encountered -XCPP. Aborting."
putErrorLnIO CPPModeWarn -> do
$ "Warning: Encountered -XCPP." putErrorLnIO
++ " Be warned that -XCPP is not supported and that" $ "Warning: Encountered -XCPP."
++ " brittany cannot check that its output is syntactically" ++ " Be warned that -XCPP is not supported and that"
++ " valid in its presence." ++ " brittany cannot check that its output is syntactically"
return $ Right True ++ " valid in its presence."
CPPModeNowarn -> return $ Right True return $ Right True
else return $ Right False CPPModeNowarn -> return $ Right True
else return $ Right False
(parseResult, originalContents) <- case inputPathM of (parseResult, originalContents) <- case inputPathM of
Nothing -> do Nothing -> do
-- TODO: refactor this hack to not be mixed into parsing logic -- TODO: refactor this hack to not be mixed into parsing logic
let hackF s = if "#include" `isPrefixOf` s let
then "-- BRITANY_INCLUDE_HACK " ++ s hackF s = if "#include" `isPrefixOf` s
else s then "-- BRITANY_INCLUDE_HACK " ++ s
let hackTransform = if hackAroundIncludes && not exactprintOnly else s
then List.intercalate "\n" . fmap hackF . lines' let
else id hackTransform = if hackAroundIncludes && not exactprintOnly
then List.intercalate "\n" . fmap hackF . lines'
else id
inputString <- liftIO System.IO.getContents inputString <- liftIO System.IO.getContents
parseRes <- liftIO $ parseModuleFromString ghcOptions parseRes <- liftIO $ parseModuleFromString
"stdin" ghcOptions
cppCheckFunc "stdin"
(hackTransform inputString) cppCheckFunc
(hackTransform inputString)
return (parseRes, Text.pack inputString) return (parseRes, Text.pack inputString)
Just p -> liftIO $ do Just p -> liftIO $ do
parseRes <- parseModule ghcOptions p cppCheckFunc parseRes <- parseModule ghcOptions p cppCheckFunc
inputText <- Text.IO.readFile p inputText <- Text.IO.readFile p
-- The above means we read the file twice, but the -- The above means we read the file twice, but the
-- GHC API does not really expose the source it -- GHC API does not really expose the source it
@ -343,8 +352,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ 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 ()
let disableFormatting = let
moduleConf & _conf_disable_formatting & confUnpack disableFormatting =
moduleConf & _conf_disable_formatting & confUnpack
(errsWarns, outSText, hasChanges) <- do (errsWarns, outSText, hasChanges) <- do
if if
| disableFormatting -> do | disableFormatting -> do
@ -353,46 +363,52 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let r = Text.pack $ ExactPrint.exactPrint parsedSource anns let r = Text.pack $ ExactPrint.exactPrint parsedSource anns
pure ([], r, r /= originalContents) pure ([], r, r /= originalContents)
| otherwise -> do | otherwise -> do
let omitCheck = let
moduleConf omitCheck =
& _conf_errorHandling moduleConf
.> _econf_omit_output_valid_check & _conf_errorHandling
.> confUnpack .> _econf_omit_output_valid_check
.> confUnpack
(ews, outRaw) <- if hasCPP || omitCheck (ews, outRaw) <- if hasCPP || omitCheck
then return then return
$ pPrintModule moduleConf perItemConf anns parsedSource $ pPrintModule moduleConf perItemConf anns parsedSource
else liftIO $ pPrintModuleAndCheck moduleConf else liftIO $ pPrintModuleAndCheck
perItemConf moduleConf
anns perItemConf
parsedSource anns
let hackF s = fromMaybe s $ TextL.stripPrefix parsedSource
(TextL.pack "-- BRITANY_INCLUDE_HACK ") let
s hackF s = fromMaybe s $ TextL.stripPrefix
let out = TextL.toStrict $ if hackAroundIncludes (TextL.pack "-- BRITANY_INCLUDE_HACK ")
then s
TextL.intercalate (TextL.pack "\n") let
$ hackF out = TextL.toStrict $ if hackAroundIncludes
<$> TextL.splitOn (TextL.pack "\n") outRaw then
else outRaw TextL.intercalate (TextL.pack "\n")
$ hackF
<$> TextL.splitOn (TextL.pack "\n") outRaw
else outRaw
out' <- if moduleConf & _conf_obfuscate & confUnpack out' <- if moduleConf & _conf_obfuscate & confUnpack
then lift $ obfuscate out then lift $ obfuscate out
else pure out else pure out
pure $ (ews, out', out' /= originalContents) pure $ (ews, out', out' /= originalContents)
let customErrOrder ErrorInput{} = 4 let
customErrOrder LayoutWarning{} = -1 :: Int customErrOrder ErrorInput{} = 4
customErrOrder ErrorOutputCheck{} = 1 customErrOrder LayoutWarning{} = -1 :: Int
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorMacroConfig{} = 5
unless (null errsWarns) $ do unless (null errsWarns) $ do
let groupedErrsWarns = let
Data.List.Extra.groupOn customErrOrder groupedErrsWarns =
$ List.sortOn customErrOrder Data.List.Extra.groupOn customErrOrder
$ errsWarns $ List.sortOn customErrOrder
$ errsWarns
groupedErrsWarns `forM_` \case groupedErrsWarns `forM_` \case
(ErrorOutputCheck{} : _) -> do (ErrorOutputCheck{} : _) -> do
putErrorLn putErrorLn
$ "ERROR: brittany pretty printer" $ "ERROR: brittany pretty printer"
++ " returned syntactically invalid result." ++ " returned syntactically invalid result."
(ErrorInput str : _) -> do (ErrorInput str : _) -> do
putErrorLn $ "ERROR: parse error: " ++ str putErrorLn $ "ERROR: parse error: " ++ str
@ -403,7 +419,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
ErrorUnknownNode str ast@(L loc _) -> do ErrorUnknownNode str ast@(L loc _) -> do
putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc) putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc)
when when
( config (config
& _conf_debug & _conf_debug
& _dconf_dump_ast_unknown & _dconf_dump_ast_unknown
& confUnpack & confUnpack
@ -417,17 +433,17 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
putErrorLn $ "WARNINGS:" putErrorLn $ "WARNINGS:"
warns `forM_` \case warns `forM_` \case
LayoutWarning str -> putErrorLn str LayoutWarning str -> putErrorLn str
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
unused@(ErrorUnusedComment{} : _) -> do unused@(ErrorUnusedComment{} : _) -> do
putErrorLn putErrorLn
$ "Error: detected unprocessed comments." $ "Error: detected unprocessed comments."
++ " The transformation output will most likely" ++ " The transformation output will most likely"
++ " not contain some of the comments" ++ " not contain some of the comments"
++ " present in the input haskell source file." ++ " present in the input haskell source file."
putErrorLn $ "Affected are the following comments:" putErrorLn $ "Affected are the following comments:"
unused `forM_` \case unused `forM_` \case
ErrorUnusedComment str -> putErrorLn str ErrorUnusedComment str -> putErrorLn str
_ -> error "cannot happen (TM)" _ -> error "cannot happen (TM)"
(ErrorMacroConfig err input : _) -> do (ErrorMacroConfig err input : _) -> do
putErrorLn $ "Error: parse error in inline configuration:" putErrorLn $ "Error: parse error in inline configuration:"
putErrorLn err putErrorLn err
@ -438,8 +454,8 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
let let
hasErrors = hasErrors =
if config & _conf_errorHandling & _econf_Werror & confUnpack if config & _conf_errorHandling & _econf_Werror & confUnpack
then not $ null errsWarns then not $ null errsWarns
else 0 < maximum (-1 : fmap customErrOrder errsWarns) else 0 < maximum (-1 : fmap customErrOrder errsWarns)
outputOnErrs = outputOnErrs =
config config
& _conf_errorHandling & _conf_errorHandling
@ -454,10 +470,11 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ addTraceSep (_conf_debug config) $ addTraceSep (_conf_debug config)
$ case outputPathM of $ case outputPathM of
Nothing -> liftIO $ Text.IO.putStr $ outSText Nothing -> liftIO $ Text.IO.putStr $ outSText
Just p -> liftIO $ do Just p -> liftIO $ do
let isIdentical = case inputPathM of let
Nothing -> False isIdentical = case inputPathM of
Just _ -> not hasChanges Nothing -> False
Just _ -> not hasChanges
unless isIdentical $ Text.IO.writeFile p $ outSText unless isIdentical $ Text.IO.writeFile p $ outSText
when (checkMode && hasChanges) $ case inputPathM of when (checkMode && hasChanges) $ case inputPathM of
@ -469,15 +486,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
where where
addTraceSep conf = addTraceSep conf =
if or if or
[ confUnpack $ _dconf_dump_annotations conf [ confUnpack $ _dconf_dump_annotations conf
, confUnpack $ _dconf_dump_ast_unknown conf , confUnpack $ _dconf_dump_ast_unknown conf
, confUnpack $ _dconf_dump_ast_full conf , confUnpack $ _dconf_dump_ast_full conf
, confUnpack $ _dconf_dump_bridoc_raw conf , confUnpack $ _dconf_dump_bridoc_raw conf
, confUnpack $ _dconf_dump_bridoc_simpl_alt conf , confUnpack $ _dconf_dump_bridoc_simpl_alt conf
, confUnpack $ _dconf_dump_bridoc_simpl_floating conf , confUnpack $ _dconf_dump_bridoc_simpl_floating conf
, confUnpack $ _dconf_dump_bridoc_simpl_columns conf , confUnpack $ _dconf_dump_bridoc_simpl_columns conf
, confUnpack $ _dconf_dump_bridoc_simpl_indent conf , confUnpack $ _dconf_dump_bridoc_simpl_indent conf
, confUnpack $ _dconf_dump_bridoc_final conf , confUnpack $ _dconf_dump_bridoc_final conf
] ]
then trace "----" then trace "----"
else id else id