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

Revert "Format Brittany with Brittany" 

This reverts commit 4398b5880d.
pull/357/head
Taylor Fausak 2021-11-07 12:37:49 +00:00 committed by GitHub
parent 4398b5880d
commit 4079981b1d
33 changed files with 4804 additions and 4693 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
brittany.yaml
View File

@ -1,5 +0,0 @@
conf_layout:
lconfig_cols: 79
lconfig_columnAlignMode:
tag: ColumnAlignModeDisabled
lconfig_indentPolicy: IndentPolicyLeft

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

@ -16,9 +16,13 @@ module Language.Haskell.Brittany
, CForwardOptions(..) , CForwardOptions(..)
, CPreProcessorConfig(..) , CPreProcessorConfig(..)
, BrittanyError(..) , BrittanyError(..)
) where )
where
import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config

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

@ -12,52 +12,68 @@ module Language.Haskell.Brittany.Internal
, parseModuleFromString , parseModuleFromString
, extractCommentConfigs , extractCommentConfigs
, getTopLevelDeclNameMap , getTopLevelDeclNameMap
) where )
where
import Control.Monad.Trans.Except
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.ByteString.Char8 import qualified Data.ByteString.Char8
import Data.CZipWith
import Data.Char (isSpace)
import Data.HList.HList
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy as TextL
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Yaml
import qualified GHC hiding (parseModule)
import GHC (GenLocated(L))
import GHC.Data.Bag
import qualified GHC.Driver.Session as GHC
import GHC.Hs
import qualified GHC.LanguageExtensions.Type as GHC
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Parser.Annotation (AnnKeywordId(..))
import GHC.Types.SrcLoc (SrcSpan) -- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import Language.Haskell.Brittany.Internal.Backend import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.Brittany.Internal.BackendUtils import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.Brittany.Internal.Config import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers
import Control.Monad.Trans.Except
import Data.HList.HList
import qualified Data.Yaml
import Data.CZipWith
import qualified UI.Butcher.Monadic as Butcher
import qualified Data.Text.Lazy.Builder as Text.Builder
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Decl
import Language.Haskell.Brittany.Internal.Layouters.Module import Language.Haskell.Brittany.Internal.Layouters.Module
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Transformations.Alt
import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Floating
import Language.Haskell.Brittany.Internal.Transformations.Indent
import Language.Haskell.Brittany.Internal.Transformations.Par
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.Brittany.Internal.Backend
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint.Parsers import Language.Haskell.Brittany.Internal.BackendUtils
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils
import qualified UI.Butcher.Monadic as Butcher
import Language.Haskell.Brittany.Internal.Transformations.Alt
import Language.Haskell.Brittany.Internal.Transformations.Floating
import Language.Haskell.Brittany.Internal.Transformations.Par
import Language.Haskell.Brittany.Internal.Transformations.Columns
import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC
hiding ( parseModule )
import GHC.Parser.Annotation ( AnnKeywordId(..) )
import GHC ( GenLocated(L)
)
import GHC.Types.SrcLoc ( SrcSpan )
import GHC.Hs
import GHC.Data.Bag
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import Data.Char ( isSpace )
data InlineConfigTarget data InlineConfigTarget
= InlineConfigTargetModule = InlineConfigTargetModule
@ -75,7 +91,7 @@ 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
) )
] ]
@ -86,8 +102,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
) )
| (k, ann) <- Map.toList anns | (k, ann) <- Map.toList anns
] ]
let let configLiness = commentLiness <&> second
configLiness = commentLiness <&> second
(Data.Maybe.mapMaybe $ \line -> do (Data.Maybe.mapMaybe $ \line -> do
l1 <- l1 <-
List.stripPrefix "-- BRITTANY" line List.stripPrefix "-- BRITTANY" line
@ -97,7 +112,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
<|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}") <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")
let l2 = dropWhile isSpace l1 let l2 = dropWhile isSpace l1
guard guard
(("@" `isPrefixOf` l2) ( ("@" `isPrefixOf` l2)
|| ("-disable" `isPrefixOf` l2) || ("-disable" `isPrefixOf` l2)
|| ("-next" `isPrefixOf` l2) || ("-next" `isPrefixOf` l2)
|| ("{" `isPrefixOf` l2) || ("{" `isPrefixOf` l2)
@ -123,22 +138,19 @@ 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 let nextDecl = do
nextDecl = do
conf <- configParser conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf) 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 let nextBinding = do
nextBinding = do
conf <- configParser conf <- configParser
Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf) 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 let disableNextBinding = do
disableNextBinding = do
Butcher.addCmdImpl Butcher.addCmdImpl
( InlineConfigTargetNextBinding ( InlineConfigTargetNextBinding
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True } , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
@ -146,8 +158,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
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 let disableNextDecl = do
disableNextDecl = do
Butcher.addCmdImpl Butcher.addCmdImpl
( InlineConfigTargetNextDecl ( InlineConfigTargetNextDecl
, mempty { _conf_roundtrip_exactprint_only = pure $ pure True } , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }
@ -155,8 +166,7 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
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 let disableFormatting = do
disableFormatting = do
Butcher.addCmdImpl Butcher.addCmdImpl
( InlineConfigTargetModule ( InlineConfigTargetModule
, mempty { _conf_disable_formatting = pure $ pure True } , mempty { _conf_disable_formatting = pure $ pure True }
@ -178,32 +188,31 @@ extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do
Right c -> Right $ c Right c -> Right $ c
pure (k, r) pure (k, r)
let let perModule = foldl'
perModule = foldl'
(<>) (<>)
mempty mempty
[ conf [ conf
| (_, lineConfigs) <- lineConfigss | (_ , lineConfigs) <- lineConfigss
, (InlineConfigTargetModule, conf) <- lineConfigs , (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 InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->
| Just name <- Map.lookup k declNameMap -> [name] [name]
_ -> [] _ -> []
] ]
let let
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 ->
@ -239,24 +248,20 @@ 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 let config =
config =
configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig } 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 let hackF s = if "#include" `isPrefixOf` s
hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s then "-- BRITANY_INCLUDE_HACK " ++ s
else s else s
let let hackTransform = if hackAroundIncludes
hackTransform = if hackAroundIncludes
then List.intercalate "\n" . fmap hackF . lines' then List.intercalate "\n" . fmap hackF . lines'
else id else id
let let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of then case cppMode of
CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting." CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."
CPPModeWarn -> return $ Right True CPPModeWarn -> return $ Right True
@ -280,8 +285,7 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
return inputText return inputText
else do else do
(errsWarns, outputTextL) <- do (errsWarns, outputTextL) <- do
let let omitCheck =
omitCheck =
moduleConfig moduleConfig
& _conf_errorHandling & _conf_errorHandling
& _econf_omit_output_valid_check & _econf_omit_output_valid_check
@ -290,26 +294,23 @@ parsePrintModule configWithDebugs inputText = runExceptT $ do
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 let hackF s = fromMaybe s
hackF s = fromMaybe s
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
pure $ if hackAroundIncludes pure $ if hackAroundIncludes
then then
( ews ( ews
, TextL.intercalate (TextL.pack "\n") , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn
$ hackF (TextL.pack "\n")
<$> TextL.splitOn (TextL.pack "\n") outRaw outRaw
) )
else (ews, outRaw) else (ews, outRaw)
let let customErrOrder ErrorInput{} = 4
customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = 0 :: Int customErrOrder LayoutWarning{} = 0 :: Int
customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = 3 customErrOrder ErrorUnknownNode{} = 3
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorMacroConfig{} = 5
let let hasErrors =
hasErrors =
if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack 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)
@ -330,8 +331,7 @@ pPrintModule
-> GHC.ParsedSource -> GHC.ParsedSource
-> ([BrittanyError], TextL.Text) -> ([BrittanyError], TextL.Text)
pPrintModule conf inlineConf anns parsedModule = pPrintModule conf inlineConf anns parsedModule =
let let ((out, errs), debugStrings) =
((out, errs), debugStrings) =
runIdentity runIdentity
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiWriterAW $ MultiRWSS.withMultiWriterAW
@ -367,13 +367,11 @@ pPrintModuleAndCheck
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 parseResult <- parseModuleFromString ghcOptions
ghcOptions
"output" "output"
(\_ -> return $ Right ()) (\_ -> return $ Right ())
(TextL.unpack output) (TextL.unpack output)
let let errs' = errs ++ case parseResult of
errs' = errs ++ case parseResult of
Left{} -> [ErrorOutputCheck] Left{} -> [ErrorOutputCheck]
Right{} -> [] Right{} -> []
return (errs', output) return (errs', output)
@ -386,18 +384,14 @@ parsePrintModuleTests conf filename input = do
let inputStr = Text.unpack input let inputStr = Text.unpack input
parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
case parseResult of case parseResult of
Left err -> Left err -> return $ Left $ "parsing error: " ++ show (bagToList (show <$> err))
return $ Left $ "parsing error: " ++ show (bagToList (show <$> err))
Right (anns, parsedModule) -> runExceptT $ do Right (anns, parsedModule) -> runExceptT $ do
(inlineConf, perItemConf) <- (inlineConf, perItemConf) <-
case case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of
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 let omitCheck =
omitCheck =
conf conf
& _conf_errorHandling & _conf_errorHandling
.> _econf_omit_output_valid_check .> _econf_omit_output_valid_check
@ -474,26 +468,23 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
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 let mBindingConfs =
mBindingConfs =
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
filteredAnns <- mAsk <&> \annMap -> filteredAnns <- mAsk
Map.union (Map.findWithDefault Map.empty annKey annMap) <&> \annMap ->
$ Map.findWithDefault Map.empty declAnnKey annMap Map.union (Map.findWithDefault Map.empty annKey annMap) $
Map.findWithDefault Map.empty declAnnKey annMap
traceIfDumpConf traceIfDumpConf "bridoc annotations filtered/transformed"
"bridoc annotations filtered/transformed"
_dconf_dump_annotations _dconf_dump_annotations
$ annsDoc filteredAnns $ annsDoc filteredAnns
config <- mAsk config <- mAsk
let let config' = cZipWith fromOptionIdentity config
config' = cZipWith fromOptionIdentity config
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf])) $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
let let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack
toLocal config' filteredAnns $ do toLocal config' filteredAnns $ do
bd <- if exactprintOnly bd <- if exactprintOnly
then briDocMToPPM $ briDocByExactNoComment decl then briDocMToPPM $ briDocByExactNoComment decl
@ -506,8 +497,7 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do
else briDocMToPPM $ briDocByExactNoComment decl else briDocMToPPM $ briDocByExactNoComment decl
layoutBriDoc bd layoutBriDoc bd
let let finalComments = filter
finalComments = filter
(fst .> \case (fst .> \case
ExactPrint.AnnComment{} -> True ExactPrint.AnnComment{} -> True
_ -> False _ -> False
@ -518,10 +508,10 @@ ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = 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 let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of
folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of ExactPrint.AnnComment cm
ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier 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)
@ -550,8 +540,7 @@ 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 let shouldReformatPreamble =
shouldReformatPreamble =
config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
let let
@ -569,15 +558,15 @@ ppPreamble lmod@(L loc m@HsModule{}) = do
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 (filteredAnns'', post') in
traceIfDumpConf (filteredAnns'', post')
"bridoc annotations filtered/transformed" traceIfDumpConf "bridoc annotations filtered/transformed"
_dconf_dump_annotations _dconf_dump_annotations
$ annsDoc filteredAnns' $ annsDoc filteredAnns'
@ -623,8 +612,7 @@ layoutBriDoc briDoc = do
mGet >>= transformSimplifyFloating .> mSet mGet >>= transformSimplifyFloating .> mSet
mGet mGet
>>= briDocToDoc >>= briDocToDoc
.> traceIfDumpConf .> traceIfDumpConf "bridoc post-floating"
"bridoc post-floating"
_dconf_dump_bridoc_simpl_floating _dconf_dump_bridoc_simpl_floating
-- bridoc transformation: par removal -- bridoc transformation: par removal
mGet >>= transformSimplifyPar .> mSet mGet >>= transformSimplifyPar .> mSet
@ -650,9 +638,7 @@ layoutBriDoc briDoc = do
anns :: ExactPrint.Anns <- mAsk anns :: ExactPrint.Anns <- mAsk
let let state = LayoutState { _lstate_baseYs = [0]
state = LayoutState
{ _lstate_baseYs = [0]
, _lstate_curYOrAddNewline = Right 0 -- important that we dont use left , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left
-- here because moveToAnn stuff -- here because moveToAnn stuff
-- of the first node needs to do -- of the first node needs to do
@ -667,8 +653,7 @@ layoutBriDoc briDoc = do
state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc' state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'
let let remainingComments =
remainingComments =
[ c [ c
| (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList
(_lstate_comments state') (_lstate_comments state')

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

@ -6,6 +6,10 @@
module Language.Haskell.Brittany.Internal.Backend where module Language.Haskell.Brittany.Internal.Backend where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.State.Strict as StateS import qualified Control.Monad.Trans.State.Strict as StateS
import qualified Data.Either as Either import qualified Data.Either as Either
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
@ -17,18 +21,22 @@ import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.BackendUtils
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Text.Lazy.Builder as Text.Builder
type ColIndex = Int type ColIndex = Int
data ColumnSpacing data ColumnSpacing
@ -37,12 +45,8 @@ data ColumnSpacing
type ColumnBlock a = [a] type ColumnBlock a = [a]
type ColumnBlocks a = Seq [a] type ColumnBlocks a = Seq [a]
type ColMap1 type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)
= IntMapL.IntMap {- ColIndex -} type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)
(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
@ -52,18 +56,15 @@ data ColInfo
instance Show ColInfo where instance Show ColInfo where
show ColInfoStart = "ColInfoStart" show ColInfoStart = "ColInfoStart"
show (ColInfoNo bd) = show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")
"ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..") show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list
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 type LayoutConstraints m = ( MonadMultiReader Config m
= ( MonadMultiReader Config m
, MonadMultiReader ExactPrint.Types.Anns m , MonadMultiReader ExactPrint.Types.Anns m
, MonadMultiWriter Text.Builder.Builder m , MonadMultiWriter Text.Builder.Builder m
, MonadMultiWriter (Seq String) m , MonadMultiWriter (Seq String) m
@ -89,8 +90,7 @@ layoutBriDocM = \case
BDSeparator -> do BDSeparator -> do
layoutAddSepSpace layoutAddSepSpace
BDAddBaseY indent bd -> do BDAddBaseY indent bd -> do
let let indentF = case indent of
indentF = case indent of
BrIndentNone -> id BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
@ -108,8 +108,7 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
layoutIndentLevelPop layoutIndentLevelPop
BDEnsureIndent indent bd -> do BDEnsureIndent indent bd -> do
let let indentF = case indent of
indentF = case indent of
BrIndentNone -> id BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
@ -118,8 +117,7 @@ layoutBriDocM = \case
layoutBriDocM bd layoutBriDocM bd
BDPar indent sameLine indented -> do BDPar indent sameLine indented -> do
layoutBriDocM sameLine layoutBriDocM sameLine
let let indentF = case indent of
indentF = case indent of
BrIndentNone -> id BrIndentNone -> id
BrIndentRegular -> layoutWithAddBaseCol BrIndentRegular -> layoutWithAddBaseCol
BrIndentSpecial i -> layoutWithAddBaseColN i BrIndentSpecial i -> layoutWithAddBaseColN i
@ -128,13 +126,12 @@ layoutBriDocM = \case
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 let tlines = Text.lines $ t <> Text.pack "\n"
tlines = Text.lines $ t <> Text.pack "\n"
tlineCount = length tlines tlineCount = length tlines
anns :: ExactPrint.Anns <- mAsk anns :: ExactPrint.Anns <- mAsk
when shouldAddComment $ do when shouldAddComment $ do
@ -157,8 +154,7 @@ 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 let moveToExactLocationAction = case _lstate_curYOrAddNewline state of
moveToExactLocationAction = case _lstate_curYOrAddNewline state of
Left{} -> pure () Left{} -> pure ()
Right{} -> moveToExactAnn annKey Right{} -> moveToExactAnn annKey
mAnn <- do mAnn <- do
@ -180,8 +176,7 @@ 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
@ -197,16 +192,14 @@ layoutBriDocM = \case
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 let mToSpan = case mAnn of
mToSpan = case mAnn of
Just anns | Maybe.isNothing keyword -> Just anns Just anns | Maybe.isNothing keyword -> Just anns
Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 -> Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just
Just annR annR
_ -> Nothing _ -> Nothing
case mToSpan of case mToSpan of
Just anns -> do Just anns -> do
let let (comments, rest) = flip spanMaybe anns $ \case
(comments, rest) = flip spanMaybe anns $ \case
(ExactPrint.Types.AnnComment x, dp) -> Just (x, dp) (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)
_ -> Nothing _ -> Nothing
mSet $ state mSet $ state
@ -220,14 +213,12 @@ layoutBriDocM = \case
case mComments of case mComments of
Nothing -> pure () Nothing -> pure ()
Just comments -> do Just comments -> do
comments comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
when (comment /= "(" && comment /= ")") $ do when (comment /= "(" && comment /= ")") $ do
let commentLines = Text.lines $ Text.pack $ comment let commentLines = Text.lines $ Text.pack $ comment
-- evil hack for CPP: -- evil hack for CPP:
case comment of case comment of
('#' : _) -> ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)
layoutMoveToCommentPos y (-999) (length commentLines)
_ -> layoutMoveToCommentPos y x (length commentLines) _ -> layoutMoveToCommentPos y x (length commentLines)
-- fixedX <- fixMoveToLineByIsNewline x -- fixedX <- fixMoveToLineByIsNewline x
-- replicateM_ fixedX layoutWriteNewline -- replicateM_ fixedX layoutWriteNewline
@ -241,23 +232,18 @@ 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 let semiCount = length [ ()
semiCount = length | Just ann <- [ annMay ]
[ ()
| Just ann <- [annMay]
, (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann
] ]
shouldAddSemicolonNewlines <- shouldAddSemicolonNewlines <- mAsk <&>
mAsk _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack
<&> _conf_layout
.> _lconfig_experimentalSemicolonNewlines
.> confUnpack
mModify $ \state -> state mModify $ \state -> state
{ _lstate_comments = Map.adjust { _lstate_comments = Map.adjust
(\ann -> ann ( \ann -> ann { ExactPrint.annFollowingComments = []
{ ExactPrint.annFollowingComments = []
, ExactPrint.annPriorComments = [] , ExactPrint.annPriorComments = []
, ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case , ExactPrint.annsDP =
flip filter (ExactPrint.annsDP ann) $ \case
(ExactPrint.Types.AnnComment{}, _) -> False (ExactPrint.Types.AnnComment{}, _) -> False
_ -> True _ -> True
} }
@ -268,14 +254,13 @@ 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 comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
`forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->
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) 1 ('#':_) -> layoutMoveToCommentPos y (-999) 1
-- ^ evil hack for CPP -- ^ evil hack for CPP
")" -> pure () ")" -> pure ()
-- ^ fixes the formatting of parens -- ^ fixes the formatting of parens
@ -291,9 +276,7 @@ layoutBriDocM = \case
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 let relevant = [ dp
relevant =
[ dp
| Just ann <- [mAnn] | Just ann <- [mAnn]
, (ExactPrint.Types.G kw1, dp) <- ann , (ExactPrint.Types.G kw1, dp) <- ann
, keyword == kw1 , keyword == kw1
@ -301,7 +284,7 @@ layoutBriDocM = \case
-- 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
@ -384,7 +367,7 @@ briDocIsMultiLine briDoc = rec briDoc
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
@ -501,20 +484,18 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
where alignMax' = max 0 alignMax where alignMax' = max 0 alignMax
processedMap :: ColMap2 processedMap :: ColMap2
processedMap = fix $ \result -> processedMap =
_cbs_map finalState <&> \(lastFlag, colSpacingss) -> fix $ \result -> _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 reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR
$ (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-}
@ -526,7 +507,8 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
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 (ratio, maxCols, colss) in
(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
@ -534,7 +516,7 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
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)
@ -563,7 +545,8 @@ 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 && briDocIsMultiLine bd && case bd of shouldBreakAfter bd = alignBreak &&
briDocIsMultiLine bd && case bd of
(BDCols ColTyOpPrefix _) -> False (BDCols ColTyOpPrefix _) -> False
(BDCols ColPatternsFuncPrefix _) -> True (BDCols ColPatternsFuncPrefix _) -> True
(BDCols ColPatternsFuncInfix _) -> True (BDCols ColPatternsFuncInfix _) -> True
@ -595,10 +578,11 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
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 -> do | infoSig == colSig && length subLengthsInfos == length subDocs
-> 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
@ -615,15 +599,15 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
m m
} }
return $ ColInfo infoInd colSig (zip curLengths infos) return $ ColInfo infoInd colSig (zip curLengths infos)
| otherwise -> briDocToColInfo lastFlag brdc | otherwise
-> 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 let isLastList =
isLastList = if lastFlag then (==length list) <$> [1 ..] else repeat False
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
@ -633,7 +617,7 @@ 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
@ -657,8 +641,7 @@ processInfo maxSpace m = \case
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 <- alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack
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)))
@ -671,8 +654,7 @@ 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 let maxCols2 = list <&> \case
maxCols2 = list <&> \case
(_, ColInfo i _ _) -> (_, ColInfo i _ _) ->
let Just (_, ms, _) = IntMapS.lookup i m in sum ms let Just (_, ms, _) = IntMapS.lookup i m in sum ms
(l, _) -> l (l, _) -> l
@ -686,9 +668,8 @@ 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 let fixedPosXs = case alignMode of
fixedPosXs = case alignMode of ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX)
ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX)
where where
factor :: Float = factor :: Float =
-- 0.0001 as an offering to the floating point gods. -- 0.0001 as an offering to the floating point gods.
@ -696,18 +677,17 @@ processInfo maxSpace m = \case
1.0001 1.0001
(fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX)) (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))
offsets = (subtract curX) <$> posXs offsets = (subtract curX) <$> posXs
fixed = offsets <&> fromIntegral .> (* factor) .> truncate fixed = offsets <&> fromIntegral .> (*factor) .> truncate
_ -> posXs _ -> posXs
let let spacings = zipWith (-)
spacings = (List.tail fixedPosXs ++ [min maxX colMax])
zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs 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 let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do
layoutWriteEnsureAbsoluteN destX layoutWriteEnsureAbsoluteN destX
processInfo s m (snd x) processInfo s m (snd x)
noAlignAct = list `forM_` (snd .> processInfoIgnore) noAlignAct = list `forM_` (snd .> processInfoIgnore)

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

@ -3,29 +3,42 @@
module Language.Haskell.Brittany.Internal.BackendUtils where module Language.Haskell.Brittany.Internal.BackendUtils where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Data import qualified Data.Data
import qualified Data.Either import qualified Data.Either
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC (Located)
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
traceLocal :: (MonadMultiState LayoutState m) => a -> m () import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey
, Annotation
)
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.Brittany.Internal.Utils
import GHC ( Located )
traceLocal
:: (MonadMultiState LayoutState m)
=> a
-> m ()
traceLocal _ = return () traceLocal _ = return ()
layoutWriteAppend layoutWriteAppend
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Text => Text
-> m () -> m ()
layoutWriteAppend t = do layoutWriteAppend t = do
@ -47,7 +60,9 @@ layoutWriteAppend t = do
} }
layoutWriteAppendSpaces layoutWriteAppendSpaces
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteAppendSpaces i = do layoutWriteAppendSpaces i = do
@ -55,18 +70,20 @@ 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder 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
@ -74,13 +91,14 @@ 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteNewlineBlock = do layoutWriteNewlineBlock = do
traceLocal ("layoutWriteNewlineBlock") traceLocal ("layoutWriteNewlineBlock")
state <- mGet state <- mGet
mSet $ state mSet $ state { _lstate_curYOrAddNewline = Right 1
{ _lstate_curYOrAddNewline = Right 1
, _lstate_addSepSpace = Just $ lstate_baseY state , _lstate_addSepSpace = Just $ lstate_baseY state
} }
@ -98,11 +116,11 @@ layoutWriteNewlineBlock = do
-- else _lstate_indLevelLinger state + i - _lstate_curY state -- else _lstate_indLevelLinger state + i - _lstate_curY state
-- } -- }
layoutSetCommentCol :: (MonadMultiState LayoutState m) => m () layoutSetCommentCol
:: (MonadMultiState LayoutState m) => m ()
layoutSetCommentCol = do layoutSetCommentCol = do
state <- mGet state <- mGet
let let col = case _lstate_curYOrAddNewline state of
col = 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
traceLocal ("layoutSetCommentCol", col) traceLocal ("layoutSetCommentCol", col)
@ -112,7 +130,9 @@ 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> Int -> Int
-> Int -> Int
@ -130,7 +150,8 @@ layoutMoveToCommentPos y x commentLines = do
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 = Just $ case _lstate_commentCol state of , _lstate_commentCol =
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)
@ -141,7 +162,9 @@ layoutMoveToCommentPos y x commentLines = do
-- | 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteNewline = do layoutWriteNewline = do
traceLocal ("layoutWriteNewline") traceLocal ("layoutWriteNewline")
@ -158,7 +181,9 @@ _layoutResetCommentNewlines = do
mModify $ \state -> state { _lstate_commentNewlines = 0 } mModify $ \state -> state { _lstate_commentNewlines = 0 }
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> m () => m ()
layoutWriteEnsureNewlineBlock = do layoutWriteEnsureNewlineBlock = do
traceLocal ("layoutWriteEnsureNewlineBlock") traceLocal ("layoutWriteEnsureNewlineBlock")
@ -172,53 +197,61 @@ layoutWriteEnsureNewlineBlock = do
} }
layoutWriteEnsureAbsoluteN layoutWriteEnsureAbsoluteN
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
layoutWriteEnsureAbsoluteN n = do layoutWriteEnsureAbsoluteN n = do
state <- mGet state <- mGet
let let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of (Just c , _ ) -> n - c
(Just c, _) -> n - c (Nothing, Left i ) -> n - i
(Nothing, Left i) -> n - i
(Nothing, Right{}) -> n (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 :: (MonadMultiState LayoutState m) => Int -> m () layoutBaseYPushInternal
:: (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 :: (MonadMultiState LayoutState m) => m () layoutBaseYPopInternal
:: (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 mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
{ _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = i : _lstate_indLevels s , _lstate_indLevels = i : _lstate_indLevels s
} }
layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPopInternal
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPopInternal = do layoutIndentLevelPopInternal = do
traceLocal ("layoutIndentLevelPopInternal") traceLocal ("layoutIndentLevelPopInternal")
mModify $ \s -> s mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s
{ _lstate_indLevelLinger = lstate_indLevel s
, _lstate_indLevels = List.tail $ _lstate_indLevels 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
@ -250,7 +283,9 @@ layoutWithAddBaseColBlock m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWithAddBaseColNBlock layoutWithAddBaseColNBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -263,23 +298,27 @@ layoutWithAddBaseColNBlock amount m = do
layoutBaseYPopInternal layoutBaseYPopInternal
layoutWriteEnsureBlock layoutWriteEnsureBlock
:: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder 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, MonadMultiState LayoutState m) :: ( MonadMultiWriter Text.Builder.Builder m
, MonadMultiState LayoutState m
)
=> Int => Int
-> m () -> m ()
-> m () -> m ()
@ -289,36 +328,39 @@ layoutWithAddBaseColN amount m = do
m m
layoutBaseYPopInternal layoutBaseYPopInternal
layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m () layoutBaseYPushCur
:: (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 :: (MonadMultiState LayoutState m) => m () layoutBaseYPop
:: (MonadMultiState LayoutState m) => m ()
layoutBaseYPop = do layoutBaseYPop = do
traceLocal ("layoutBaseYPop") traceLocal ("layoutBaseYPop")
layoutBaseYPopInternal layoutBaseYPopInternal
layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPushCur
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPushCur = do layoutIndentLevelPushCur = do
traceLocal ("layoutIndentLevelPushCur") traceLocal ("layoutIndentLevelPushCur")
state <- mGet state <- mGet
let let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of
y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of (Left i , Just j ) -> i + j
(Left i, Just j) -> i + j (Left i , Nothing) -> i
(Left i, Nothing) -> i (Right{}, Just j ) -> j
(Right{}, Just j) -> j
(Right{}, Nothing) -> 0 (Right{}, Nothing) -> 0
layoutIndentLevelPushInternal y layoutIndentLevelPushInternal y
layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m () layoutIndentLevelPop
:: (MonadMultiState LayoutState m) => m ()
layoutIndentLevelPop = do layoutIndentLevelPop = do
traceLocal ("layoutIndentLevelPop") traceLocal ("layoutIndentLevelPop")
layoutIndentLevelPopInternal layoutIndentLevelPopInternal
@ -328,12 +370,12 @@ layoutIndentLevelPop = do
-- make sense. -- make sense.
layoutRemoveIndentLevelLinger layoutRemoveIndentLevelLinger
layoutAddSepSpace :: (MonadMultiState LayoutState m) => m () layoutAddSepSpace :: (MonadMultiState LayoutState 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.
@ -357,16 +399,16 @@ moveToExactAnn annKey = do
moveToY :: MonadMultiState LayoutState m => Int -> m () moveToY :: MonadMultiState LayoutState m => Int -> m ()
moveToY y = mModify $ \state -> moveToY y = mModify $ \state ->
let let upd = case _lstate_curYOrAddNewline state of
upd = 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 i -> Right $ max y i Right i -> Right $ max y i
in in state
state
{ _lstate_curYOrAddNewline = upd { _lstate_curYOrAddNewline = upd
, _lstate_addSepSpace = if Data.Either.isRight upd , _lstate_addSepSpace = if Data.Either.isRight upd
then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just then
(lstate_baseY state) _lstate_commentCol state
<|> _lstate_addSepSpace state
<|> Just (lstate_baseY state)
else Nothing else Nothing
, _lstate_commentCol = Nothing , _lstate_commentCol = Nothing
} }
@ -379,7 +421,9 @@ moveToY y = mModify $ \state ->
-- else x -- else x
ppmMoveToExactLoc ppmMoveToExactLoc
:: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m () :: MonadMultiWriter Text.Builder.Builder 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 " "
@ -399,18 +443,17 @@ layoutWritePriorComments ast = do
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 = Map.adjust { _lstate_comments =
(\ann -> ann { ExactPrint.annPriorComments = [] }) Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns
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 priors `forM_` \( ExactPrint.Comment comment _ _
`forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> do , ExactPrint.DP (x, y)
) -> do
replicateM_ x layoutWriteNewline replicateM_ x layoutWriteNewline
layoutWriteAppendSpaces y layoutWriteAppendSpaces y
layoutWriteAppendMultiline $ Text.lines $ Text.pack comment layoutWriteAppendMultiline $ Text.lines $ Text.pack comment
@ -419,13 +462,10 @@ layoutWritePriorComments ast = do
-- 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 layoutWritePostComments :: (Data.Data.Data ast,
:: ( Data.Data.Data ast MonadMultiWriter Text.Builder.Builder m,
, MonadMultiWriter Text.Builder.Builder m MonadMultiState LayoutState m)
, MonadMultiState LayoutState m => Located ast -> m ()
)
=> Located ast
-> m ()
layoutWritePostComments ast = do layoutWritePostComments ast = do
mAnn <- do mAnn <- do
state <- mGet state <- mGet
@ -433,8 +473,8 @@ layoutWritePostComments ast = do
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 = Map.adjust { _lstate_comments =
(\ann -> ann { ExactPrint.annFollowingComments = [] }) Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] })
key key
anns anns
} }
@ -443,28 +483,30 @@ layoutWritePostComments ast = do
Nothing -> return () Nothing -> return ()
Just posts -> do Just posts -> do
unless (null posts) $ layoutSetCommentCol unless (null posts) $ layoutSetCommentCol
posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) -> posts `forM_` \( ExactPrint.Comment comment _ _
do , ExactPrint.DP (x, y)
) -> 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, MonadMultiWriter Text.Builder.Builder m) :: ( MonadMultiState LayoutState 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 mModify $ \s -> s { _lstate_commentCol = Nothing
$ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 } , _lstate_commentNewlines = 0
}
case (mCommentCol, eCurYAddNL) of case (mCommentCol, eCurYAddNL) of
(Just commentCol, Left{}) -> do (Just commentCol, Left{}) -> do
layoutWriteEnsureNewlineBlock layoutWriteEnsureNewlineBlock
layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state)
0
(_lstate_addSepSpace state)
_ -> return () _ -> return ()
-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast, -- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,

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

@ -3,27 +3,38 @@
module Language.Haskell.Brittany.Internal.Config where module Language.Haskell.Brittany.Internal.Config where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Bool as Bool import qualified Data.Bool as Bool
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 import qualified Data.ByteString.Char8
import Data.CZipWith
import Data.Coerce (coerce)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Yaml
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Utils
import qualified System.Console.CmdArgs.Explicit as CmdArgs
import qualified System.Directory import qualified System.Directory
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
import qualified System.IO import qualified System.IO
import qualified Data.Yaml
import Data.CZipWith
import UI.Butcher.Monadic import UI.Butcher.Monadic
import qualified System.Console.CmdArgs.Explicit
as CmdArgs
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config.Types.Instances ()
import Language.Haskell.Brittany.Internal.Utils
import Data.Coerce ( coerce
)
import qualified Data.List.NonEmpty as NonEmpty
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
staticDefaultConfig :: Config staticDefaultConfig :: Config
staticDefaultConfig = Config staticDefaultConfig = Config
{ _conf_version = coerce (1 :: Int) { _conf_version = coerce (1 :: Int)
@ -94,7 +105,7 @@ forwardOptionsSyntaxExtsEnabled = ForwardOptions
] ]
} }
-- brittany-next-binding --columns 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 []!!
@ -234,8 +245,7 @@ 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 globalConfig <- Directory.findFileWith Directory.doesFileExist
Directory.doesFileExist
searchDirs searchDirs
"config.yaml" "config.yaml"
maybe (writeUserConfig userBritPathXdg) pure globalConfig maybe (writeUserConfig userBritPathXdg) pure globalConfig
@ -261,9 +271,8 @@ readConfigs
-> MaybeT IO Config -> MaybeT IO Config
readConfigs cmdlineConfig configPaths = do readConfigs cmdlineConfig configPaths = do
configs <- readConfig `mapM` configPaths configs <- readConfig `mapM` configPaths
let let merged = Semigroup.sconcat
merged = $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)
return $ cZipWith fromOptionIdentity staticDefaultConfig merged return $ cZipWith fromOptionIdentity staticDefaultConfig merged
-- | Reads provided configs -- | Reads provided configs

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

@ -7,15 +7,24 @@
module Language.Haskell.Brittany.Internal.Config.Types where module Language.Haskell.Brittany.Internal.Config.Types where
import Data.CZipWith
import Data.Coerce (Coercible, coerce)
import Data.Data (Data)
import qualified Data.Semigroup as Semigroup
import Data.Semigroup (Last)
import Data.Semigroup.Generic
import GHC.Generics
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils () import Language.Haskell.Brittany.Internal.PreludeUtils ()
import qualified Data.Semigroup as Semigroup
import GHC.Generics
import Data.Data ( Data )
import Data.Coerce ( Coercible, coerce )
import Data.Semigroup.Generic
import Data.Semigroup ( Last )
import Data.CZipWith
confUnpack :: Coercible a b => Identity a -> b confUnpack :: Coercible a b => Identity a -> b
confUnpack (Identity x) = coerce x confUnpack (Identity x) = coerce x
@ -34,7 +43,7 @@ data CDebugConfig f = DebugConfig
, _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.
@ -139,12 +148,12 @@ 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)
@ -159,13 +168,13 @@ 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)
@ -185,8 +194,9 @@ data CConfig f = Config
-- (`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

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

@ -18,16 +18,22 @@
module Language.Haskell.Brittany.Internal.Config.Types.Instances where module Language.Haskell.Brittany.Internal.Config.Types.Instances where
import Language.Haskell.Brittany.Internal.Prelude
import Data.Yaml
import qualified Data.Aeson.Key as Key import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.Types as Aeson import qualified Data.Aeson.Types as Aeson
import Data.Yaml
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
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
@ -102,17 +108,16 @@ 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) = parseJSON (Object v) = Config
Config <$> v .:? Key.fromString "conf_version"
<$> (v .:? Key.fromString "conf_version") <*> v .:?= Key.fromString "conf_debug"
<*> (v .:?= Key.fromString "conf_debug") <*> v .:?= Key.fromString "conf_layout"
<*> (v .:?= Key.fromString "conf_layout") <*> v .:?= Key.fromString "conf_errorHandling"
<*> (v .:?= Key.fromString "conf_errorHandling") <*> v .:?= Key.fromString "conf_forward"
<*> (v .:?= Key.fromString "conf_forward") <*> v .:?= Key.fromString "conf_preprocessor"
<*> (v .:?= Key.fromString "conf_preprocessor") <*> v .:? Key.fromString "conf_roundtrip_exactprint_only"
<*> (v .:? Key.fromString "conf_roundtrip_exactprint_only") <*> v .:? Key.fromString "conf_disable_formatting"
<*> (v .:? Key.fromString "conf_disable_formatting") <*> v .:? Key.fromString "conf_obfuscate"
<*> (v .:? Key.fromString "conf_obfuscate")
parseJSON invalid = Aeson.typeMismatch "Config" invalid 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.

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

@ -7,35 +7,48 @@
module Language.Haskell.Brittany.Internal.ExactPrintUtils where module Language.Haskell.Brittany.Internal.ExactPrintUtils where
import Control.Exception
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.State.Class as State.Class import qualified Control.Monad.State.Class as State.Class
import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.Except as ExceptT
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.Data
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
import qualified Data.Generics as SYB
import Data.HList.HList
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import GHC (GenLocated(L))
import qualified GHC hiding (parseModule)
import GHC.Data.Bag
import qualified GHC.Driver.CmdLine as GHC
import qualified GHC.Driver.Session as GHC
import GHC.Hs
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.SrcLoc (Located, SrcSpan)
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified System.IO import qualified System.IO
import Language.Haskell.Brittany.Internal.Config.Types
import Data.Data
import Data.HList.HList
import GHC ( GenLocated(L) )
import qualified GHC.Driver.Session as GHC
import qualified GHC hiding (parseModule)
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Driver.CmdLine as GHC
import GHC.Hs
import GHC.Data.Bag
import GHC.Types.SrcLoc ( SrcSpan, Located )
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint
import qualified Data.Generics as SYB
import Control.Exception
-- import Data.Generics.Schemes
parseModule parseModule
:: [String] :: [String]
-> System.IO.FilePath -> System.IO.FilePath
@ -75,10 +88,7 @@ parseModuleWithCpp cpp opts args fp dynCheck =
++ show (warnings <&> warnExtractorCompat) ++ show (warnings <&> warnExtractorCompat)
x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2 x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags2
res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp res <- lift $ ExactPrint.parseModuleApiAnnsWithCppInternal cpp dflags2 fp
either either (\err -> ExceptT.throwE $ "transform error: " ++ show (bagToList (show <$> err)))
(\err -> ExceptT.throwE $ "transform error: " ++ show
(bagToList (show <$> err))
)
(\(a, m) -> pure (a, m, x)) (\(a, m) -> pure (a, m, x))
$ ExactPrint.postParseTransform res opts $ ExactPrint.postParseTransform res opts
@ -111,23 +121,19 @@ parseModuleFromString args fp dynCheck str =
dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1 dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
case res of case res of
Left err -> Left err -> ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err))
ExceptT.throwE $ "parse error: " ++ show (bagToList (show <$> err)) Right (a , m ) -> pure (a, m, dynCheckRes)
Right (a, m) -> pure (a, m, dynCheckRes)
commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform () commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
commentAnnFixTransformGlob ast = do commentAnnFixTransformGlob ast = do
let let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)
extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $ extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $
const Seq.empty const Seq.empty
`SYB.ext1Q` (\l@(L span _) -> `SYB.ext1Q`
Seq.singleton (span, ExactPrint.mkAnnKey l) (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l))
)
let nodes = SYB.everything (<>) extract ast let nodes = SYB.everything (<>) extract ast
let let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey
annsMap = Map.fromListWith annsMap = Map.fromListWith
(const id) (const id)
[ (GHC.realSrcSpanEnd span, annKey) [ (GHC.realSrcSpanEnd span, annKey)
@ -138,8 +144,7 @@ commentAnnFixTransformGlob ast = do
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 let priors = ExactPrint.annPriorComments ann1
priors = ExactPrint.annPriorComments ann1
follows = ExactPrint.annFollowingComments ann1 follows = ExactPrint.annFollowingComments ann1
assocs = ExactPrint.annsDP ann1 assocs = ExactPrint.annsDP ann1
let let
@ -166,16 +171,15 @@ commentAnnFixTransformGlob ast = do
{ ExactPrint.annFollowingComments = { ExactPrint.annFollowingComments =
ExactPrint.annFollowingComments ann2 ++ [comPair] ExactPrint.annFollowingComments ann2 ++ [comPair]
} }
in Map.insert annKey2 ann2' anns in
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 let ann1' = ann1 { ExactPrint.annPriorComments = priors'
ann1' = ann1
{ ExactPrint.annPriorComments = priors'
, ExactPrint.annFollowingComments = follows' , ExactPrint.annFollowingComments = follows'
, ExactPrint.annsDP = assocs' , ExactPrint.annsDP = assocs'
} }
@ -270,8 +274,7 @@ extractToplevelAnns lmod anns = output
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' groupMap f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m)
(\m k a -> Map.alter (insert k a) (f k a) m)
Map.empty Map.empty
where where
insert k a Nothing = Just (Map.singleton k a) insert k a Nothing = Just (Map.singleton k a)
@ -280,16 +283,16 @@ groupMap f = Map.foldlWithKey'
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 () ()))
@ -298,8 +301,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
@ -309,8 +312,7 @@ withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case
pure x pure x
where where
f anns = f anns =
let let ((), (annsBalanced, _), _) =
((), (annsBalanced, _), _) =
ExactPrint.runTransform anns (commentAnnFixTransformGlob ast) ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)
in annsBalanced in annsBalanced

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

@ -6,37 +6,50 @@
module Language.Haskell.Brittany.Internal.LayouterBasics where module Language.Haskell.Brittany.Internal.LayouterBasics where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Control.Monad.Writer.Strict as Writer
import qualified Data.Char as Char
import Data.Data
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lazy.Builder as Text.Builder
import DataTreePrint
import GHC (GenLocated(L), Located, moduleName, moduleNameString)
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Parser.Annotation (AnnKeywordId(..))
import GHC.Types.Name (getOccString) import qualified Control.Monad.Writer.Strict as Writer
import GHC.Types.Name.Occurrence (occNameString)
import GHC.Types.Name.Reader (RdrName(..))
import qualified GHC.Types.SrcLoc as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation )
import qualified Data.Text.Lazy.Builder as Text.Builder
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import GHC.Types.Name.Reader ( RdrName(..) )
import GHC ( Located, GenLocated(L), moduleName, moduleNameString )
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.Name.Occurrence ( occNameString )
import GHC.Types.Name ( getOccString )
import GHC.Parser.Annotation ( AnnKeywordId(..) )
import Data.Data
import qualified Data.Char as Char
import DataTreePrint
processDefault processDefault
:: ( ExactPrint.Annotate.Annotate ast :: ( ExactPrint.Annotate.Annotate ast
, MonadMultiWriter Text.Builder.Builder m , MonadMultiWriter Text.Builder.Builder m
@ -66,8 +79,7 @@ briDocByExact
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExact ast = do briDocByExact ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf traceIfDumpConf "ast"
"ast"
_dconf_dump_ast_unknown _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns True docExt ast anns True
@ -83,8 +95,7 @@ briDocByExactNoComment
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactNoComment ast = do briDocByExactNoComment ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf traceIfDumpConf "ast"
"ast"
_dconf_dump_ast_unknown _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (printTreeWithCustom 100 (customLayouterF anns) ast)
docExt ast anns False docExt ast anns False
@ -99,26 +110,24 @@ briDocByExactInlineOnly
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
briDocByExactInlineOnly infoStr ast = do briDocByExactInlineOnly infoStr ast = do
anns <- mAsk anns <- mAsk
traceIfDumpConf traceIfDumpConf "ast"
"ast"
_dconf_dump_ast_unknown _dconf_dump_ast_unknown
(printTreeWithCustom 100 (customLayouterF anns) ast) (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 let exactPrintNode t = allocateNode $ BDFExternal
exactPrintNode t = allocateNode $ BDFExternal
(ExactPrint.Types.mkAnnKey ast) (ExactPrint.Types.mkAnnKey ast)
(foldedAnnKeys ast) (foldedAnnKeys ast)
False False
t t
let let errorAction = do
errorAction = do
mTell [ErrorUnknownNode infoStr ast] mTell [ErrorUnknownNode infoStr ast]
docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}" 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
@ -143,8 +152,7 @@ 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 let hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni x (ExactPrint.Types.G y, _) = x == y
hasUni _ _ = False 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
@ -170,8 +178,7 @@ lrdrNameToTextAnnTypeEqualityIsSpecial
=> Located RdrName => Located RdrName
-> m Text -> m Text
lrdrNameToTextAnnTypeEqualityIsSpecial ast = do lrdrNameToTextAnnTypeEqualityIsSpecial ast = do
let let f x = if x == Text.pack "Data.Type.Equality~"
f x = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x else x
lrdrNameToTextAnnGen f ast lrdrNameToTextAnnGen f ast
@ -192,8 +199,7 @@ lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do
hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote
x <- lrdrNameToTextAnn ast2 x <- lrdrNameToTextAnn ast2
let let lit = if x == Text.pack "Data.Type.Equality~"
lit = if x == Text.pack "Data.Type.Equality~"
then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh
else x else x
return $ if hasQuote then Text.cons '\'' lit else lit return $ if hasQuote then Text.cons '\'' lit else lit
@ -217,7 +223,8 @@ extractRestComments ann =
) )
filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns
filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) filterAnns 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
@ -235,8 +242,7 @@ hasCommentsBetween
-> ToBriDocM Bool -> ToBriDocM Bool
hasCommentsBetween ast leftKey rightKey = do hasCommentsBetween ast leftKey rightKey = do
mAnn <- astAnn ast mAnn <- astAnn ast
let let go1 [] = False
go1 [] = False
go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest
go1 (_ : rest) = go1 rest go1 (_ : rest) = go1 rest
go2 [] = False go2 [] = False
@ -254,8 +260,7 @@ hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast
-- | True if there are any regular comments connected to any node below (in AST -- | True if there are any regular comments connected to any node below (in AST
-- sense) the given node -- sense) the given node
hasAnyRegularCommentsConnected hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool
:: Data ast => GHC.Located ast -> ToBriDocM Bool
hasAnyRegularCommentsConnected ast = hasAnyRegularCommentsConnected ast =
any isRegularComment <$> astConnectedComments ast any isRegularComment <$> astConnectedComments ast
@ -455,10 +460,12 @@ 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 = when cond (addAlternative doc) addAlternativeCond cond doc =
when cond (addAlternative doc)
addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM () addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()
addAlternative = CollectAltM . Writer.tell . (: []) addAlternative =
CollectAltM . Writer.tell . (: [])
runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered
runFilteredAlternative (CollectAltM action) = runFilteredAlternative (CollectAltM action) =
@ -475,8 +482,7 @@ docLines l = allocateNode . BDFLines =<< sequence l
docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
docCols sig l = allocateNode . BDFCols sig =<< sequence l docCols sig l = allocateNode . BDFCols sig =<< sequence l
docAddBaseY docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
:: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm
docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@ -511,8 +517,7 @@ docAnnotationKW
-> Maybe AnnKeywordId -> Maybe AnnKeywordId
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docAnnotationKW annKey kw bdm = docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm
allocateNode . BDFAnnotationKW annKey kw =<< bdm
docMoveToKWDP docMoveToKWDP
:: AnnKey :: AnnKey
@ -626,26 +631,32 @@ instance DocWrapable (ToBriDocM BriDocNumbered) where
docWrapNodePrior ast bdm = do docWrapNodePrior ast bdm = do
bd <- bdm bd <- bdm
i1 <- allocNodeIndex i1 <- allocNodeIndex
return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd return
$ (,) i1
$ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
$ bd
docWrapNodeRest ast bdm = do docWrapNodeRest ast bdm = do
bd <- bdm bd <- bdm
i2 <- allocNodeIndex i2 <- allocNodeIndex
return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd return
$ (,) 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,7 +666,7 @@ 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']
@ -664,16 +675,16 @@ instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where
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
@ -767,8 +778,7 @@ 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 let ((x, errs), debugs) =
((x, errs), debugs) =
runIdentity runIdentity
$ MultiRWSS.runMultiRWSTNil $ MultiRWSS.runMultiRWSTNil
$ MultiRWSS.withMultiStateA (NodeAllocIndex 1) $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)

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

@ -3,19 +3,26 @@
module Language.Haskell.Brittany.Internal.Layouters.DataDecl where module Language.Haskell.Brittany.Internal.Layouters.DataDecl where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Data import qualified Data.Data
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (GenLocated(L), Located) import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import GHC ( Located, GenLocated(L) )
import qualified GHC import qualified GHC
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
layoutDataDecl layoutDataDecl
:: Located (TyClDecl GhcPs) :: Located (TyClDecl GhcPs)
@ -25,10 +32,9 @@ 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 -> HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of
case cons of (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) ->
(L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) docWrapNode ltycl $ do
-> docWrapNode ltycl $ do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
consNameStr <- lrdrNameToTextAnn consName consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- return <$> createBndrDoc bndrs tyVarLine <- return <$> createBndrDoc bndrs
@ -68,8 +74,8 @@ 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
@ -81,23 +87,19 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn 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 <- consDoc <- fmap pure
fmap pure
$ docNonBottomSpacing $ docNonBottomSpacing
$ case (forallDocMay, rhsContextDocMay) of $ case (forallDocMay, rhsContextDocMay) of
(Just forallDoc, Just rhsContextDoc) -> docLines (Just forallDoc, Just rhsContextDoc) -> docLines
[ docSeq [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq , docSeq
[ docLitS "." [ docLitS "."
, docSeparator , docSeparator
, docSetBaseY , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
$ docLines [rhsContextDoc, docSetBaseY rhsDoc]
] ]
] ]
(Just forallDoc, Nothing) -> docLines (Just forallDoc, Nothing) -> docLines
[ docSeq [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc]
[docLitS "=", docSeparator, docForceSingleline forallDoc]
, docSeq [docLitS ".", docSeparator, rhsDoc] , docSeq [docLitS ".", docSeparator, rhsDoc]
] ]
(Nothing, Just rhsContextDoc) -> docSeq (Nothing, Just rhsContextDoc) -> docSeq
@ -105,12 +107,12 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of
, docSeparator , docSeparator
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
] ]
(Nothing, Nothing) -> (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc]
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) $ docSeq [ docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline $ lhsContextDoc , docForceSingleline $ lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -122,8 +124,7 @@ 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 -> Just forallDoc -> docSeq
docSeq
[ docForceSingleline forallDoc [ docForceSingleline forallDoc
, docSeparator , docSeparator
, docLitS "." , docLitS "."
@ -136,21 +137,21 @@ 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) $ docSeq ( docNodeAnnKW ltycl (Just GHC.AnnData)
$ 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 -> Just forallDoc -> docSeq
docSeq
[ docForceSingleline forallDoc [ docForceSingleline forallDoc
, docSeparator , docSeparator
, docLitS "." , docLitS "."
@ -166,7 +167,8 @@ 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) $ docSeq ( docNodeAnnKW ltycl (Just GHC.AnnData)
$ docSeq
[ appSep $ docLitS "data" [ appSep $ docLitS "data"
, docForceSingleline lhsContextDoc , docForceSingleline lhsContextDoc
, appSep $ docLit nameStr , appSep $ docLit nameStr
@ -187,10 +189,13 @@ 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 [appSep $ docLit nameStr, tyVarLine] $ docSeq
[ appSep $ docLit nameStr
, tyVarLine
]
, consDoc , consDoc
] ]
) )
@ -209,15 +214,15 @@ createContextDoc (t1 : tR) = do
docAlt docAlt
[ docSeq [ docSeq
[ docLitS "(" [ docLitS "("
, docForceSingleline $ docSeq $ List.intersperse , docForceSingleline $ docSeq $ List.intersperse docCommaSep
docCommaSep
(t1Doc : tRDocs) (t1Doc : tRDocs)
, docLitS ") =>" , docLitS ") =>"
, docSeparator , docSeparator
] ]
, docLines $ join , docLines $ join
[ [docSeq [docLitS "(", docSeparator, t1Doc]] [ [docSeq [docLitS "(", docSeparator, t1Doc]]
, tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] , tRDocs
<&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]
, [docLitS ") =>", docSeparator] , [docLitS ") =>", docSeparator]
] ]
] ]
@ -229,8 +234,10 @@ 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 $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) -> docSeq
case mKind of $ List.intersperse docSeparator
$ tyVarDocs
<&> \(vname, mKind) -> case mKind of
Nothing -> docLit vname Nothing -> docLit vname
Just kind -> docSeq Just kind -> docSeq
[ docLitS "(" [ docLitS "("
@ -256,17 +263,16 @@ createDerivingPar derivs mainDoc = do
<$> types <$> types
derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered
derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of
case types of
(L _ []) -> docSeq [] (L _ []) -> docSeq []
(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
@ -274,22 +280,24 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) =
, 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 -> docSeq
[docWrapNode lVia $ docLitS " via", docSeparator, layoutType t] [ docWrapNode lVia $ docLitS " via"
, docSeparator
, layoutType t
]
) )
docDeriving :: ToBriDocM BriDocNumbered docDeriving :: ToBriDocM BriDocNumbered
@ -299,8 +307,7 @@ 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 <- indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
let let
singleLine = docSeq singleLine = docSeq
[ docLit consNameStr [ docLit consNameStr
@ -308,16 +315,13 @@ createDetailsDoc consNameStr details = case details of
, docForceSingleline , docForceSingleline
$ docSeq $ docSeq
$ List.intersperse docSeparator $ List.intersperse docSeparator
$ fmap hsScaledThing args $ fmap hsScaledThing args <&> layoutType
<&> layoutType
] ]
leftIndented = leftIndented = docSetParSpacing
docSetParSpacing
. docAddBaseY BrIndentRegular . docAddBaseY BrIndentRegular
. docPar (docLit consNameStr) . docPar (docLit consNameStr)
. docLines . docLines
$ layoutType $ layoutType <$> fmap hsScaledThing args
<$> fmap hsScaledThing args
multiAppended = docSeq multiAppended = docSeq
[ docLit consNameStr [ docLit consNameStr
, docSeparator , docSeparator
@ -331,13 +335,14 @@ createDetailsDoc consNameStr details = case details of
IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]
IndentPolicyFree -> IndentPolicyFree ->
docAlt [singleLine, multiAppended, multiIndented, leftIndented] docAlt [singleLine, multiAppended, multiIndented, leftIndented]
RecCon (L _ []) -> RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]
docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] RecCon lRec@(L _ fields@(_:_)) -> do
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 $ runFilteredAlternative $ do docAddBaseY BrIndentRegular
$ runFilteredAlternative
$ do
-- single-line: { i :: Int, b :: Bool } -- single-line: { i :: Int, b :: Bool }
addAlternativeCond allowSingleline $ docSeq addAlternativeCond allowSingleline $ docSeq
[ docLit consNameStr [ docLit consNameStr
@ -366,8 +371,7 @@ createDetailsDoc consNameStr details = case details of
(docLit consNameStr) (docLit consNameStr)
(docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines
[ docAlt [ docAlt
[ docCols [ docCols ColRecDecl
ColRecDecl
[ appSep (docLitS "{") [ appSep (docLitS "{")
, appSep $ docForceSingleline fName1 , appSep $ docForceSingleline fName1
, docSeq [docLitS "::", docSeparator] , docSeq [docLitS "::", docSeparator]
@ -383,8 +387,7 @@ createDetailsDoc consNameStr details = case details of
] ]
, docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->
docAlt docAlt
[ docCols [ docCols ColRecDecl
ColRecDecl
[ docCommaSep [ docCommaSep
, appSep $ docForceSingleline fName , appSep $ docForceSingleline fName
, docSeq [docLitS "::", docSeparator] , docSeq [docLitS "::", docSeparator]
@ -415,11 +418,10 @@ 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 createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
:: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
createForallDoc [] = Nothing createForallDoc [] = Nothing
createForallDoc lhsTyVarBndrs = createForallDoc lhsTyVarBndrs = Just $ docSeq
Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs] [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
createNamesAndTypeDoc createNamesAndTypeDoc
:: Data.Data.Data ast :: Data.Data.Data ast
@ -429,8 +431,12 @@ 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 $ List.intersperse docCommaSep $ names <&> \case [ docSeq
L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName $ List.intersperse docCommaSep
$ names
<&> \case
L _ (FieldOcc _ fieldName) ->
docLit =<< lrdrNameToTextAnn fieldName
] ]
, docWrapNodeRest lField $ layoutType t , docWrapNodeRest lField $ layoutType t
) )

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

@ -5,38 +5,48 @@
module Language.Haskell.Brittany.Internal.Layouters.Decl where module Language.Haskell.Brittany.Internal.Layouters.Decl where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Data import qualified Data.Data
import qualified Data.Foldable import qualified Data.Foldable
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L)) import qualified GHC.OldList as List
import GHC.Data.Bag (bagToList, emptyBag)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Layouters.Type
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import GHC ( GenLocated(L)
, AnnKeywordId(..)
)
import GHC.Types.SrcLoc ( SrcSpan, Located , getLoc, unLoc )
import qualified GHC.Data.FastString as FastString import qualified GHC.Data.FastString as FastString
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List import GHC.Types.Basic ( InlinePragma(..)
import GHC.Types.Basic , Activation(..)
( Activation(..)
, InlinePragma(..)
, InlineSpec(..) , InlineSpec(..)
, LexicalFixity(..)
, RuleMatchInfo(..) , RuleMatchInfo(..)
, LexicalFixity(..)
) )
import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.DataDecl
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Layouters.DataDecl
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import GHC.Data.Bag ( bagToList, emptyBag )
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types (mkAnnKey)
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint
layoutDecl :: ToBriDoc HsDecl layoutDecl :: ToBriDoc HsDecl
layoutDecl d@(L loc decl) = case decl of layoutDecl d@(L loc decl) = case decl of
@ -57,53 +67,44 @@ layoutDecl d@(L loc decl) = case decl of
layoutSig :: ToBriDoc Sig layoutSig :: ToBriDoc Sig
layoutSig lsig@(L _loc sig) = case sig of layoutSig lsig@(L _loc sig) = case sig of
TypeSig _ names (HsWC _ (HsIB _ typ)) -> TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ
layoutNamesAndType Nothing names typ
InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) -> InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
specStr <- specStringCompat lsig spec specStr <- specStringCompat lsig spec
let let phaseStr = case phaseAct of
phaseStr = case phaseAct of
NeverActive -> "" -- not [] - for NOINLINE NeverActive is NeverActive -> "" -- not [] - for NOINLINE NeverActive is
-- in fact the default -- in fact the default
AlwaysActive -> "" AlwaysActive -> ""
ActiveBefore _ i -> "[~" ++ show i ++ "] " ActiveBefore _ i -> "[~" ++ show i ++ "] "
ActiveAfter _ i -> "[" ++ show i ++ "] " ActiveAfter _ i -> "[" ++ show i ++ "] "
FinalActive -> error "brittany internal error: FinalActive" FinalActive -> error "brittany internal error: FinalActive"
let let conlikeStr = case conlike of
conlikeStr = case conlike of
FunLike -> "" FunLike -> ""
ConLike -> "CONLIKE " ConLike -> "CONLIKE "
docLit docLit
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr) $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
<> nameStr <> nameStr
<> Text.pack " #-}" <> Text.pack " #-}"
ClassOpSig _ False names (HsIB _ typ) -> ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ
layoutNamesAndType Nothing names typ PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ
PatSynSig _ names (HsIB _ typ) ->
layoutNamesAndType (Just "pattern") names typ
_ -> briDocByExactNoComment lsig -- TODO _ -> briDocByExactNoComment lsig -- TODO
where where
layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do
let let keyDoc = case mKeyword of
keyDoc = case mKeyword of
Just key -> [appSep . docLit $ Text.pack key] Just key -> [appSep . docLit $ Text.pack key]
Nothing -> [] Nothing -> []
nameStrs <- names `forM` lrdrNameToTextAnn nameStrs <- names `forM` lrdrNameToTextAnn
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
typeDoc <- docSharedWrapper layoutType typ typeDoc <- docSharedWrapper layoutType typ
hasComments <- hasAnyCommentsBelow lsig hasComments <- hasAnyCommentsBelow lsig
shouldBeHanging <- shouldBeHanging <- mAsk
mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack <&> _conf_layout
.> _lconfig_hangingTypeSignature
.> confUnpack
if shouldBeHanging if shouldBeHanging
then then docSeq $
docSeq [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr]
$ [ appSep
$ docWrapNodeRest lsig
$ docSeq
$ keyDoc
<> [docLit nameStr]
, docSetBaseY $ docLines , docSetBaseY $ docLines
[ docCols [ docCols
ColTyOpPrefix ColTyOpPrefix
@ -132,8 +133,7 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
BindStmt _ lPat expr -> do BindStmt _ lPat expr -> do
patDoc <- docSharedWrapper layoutPat lPat patDoc <- docSharedWrapper layoutPat lPat
expDoc <- docSharedWrapper layoutExpr expr expDoc <- docSharedWrapper layoutExpr expr
docCols docCols ColBindStmt
ColBindStmt
[ appSep $ colsWrapPat =<< patDoc [ appSep $ colsWrapPat =<< patDoc
, docSeq [appSep $ docLit $ Text.pack "<-", expDoc] , docSeq [appSep $ docLit $ Text.pack "<-", expDoc]
] ]
@ -145,7 +145,9 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
layoutBind layoutBind
:: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered) :: ToBriDocC
(HsBindLR GhcPs GhcPs)
(Either [BriDocNumbered] BriDocNumbered)
layoutBind lbind@(L _ bind) = case bind of layoutBind lbind@(L _ bind) = case bind of
FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do
idStr <- lrdrNameToTextAnn fId idStr <- lrdrNameToTextAnn fId
@ -163,15 +165,17 @@ layoutBind lbind@(L _ bind) = case bind of
let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey? let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey?
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
hasComments <- hasAnyCommentsBelow lbind hasComments <- hasAnyCommentsBelow lbind
fmap Right $ docWrapNode lbind $ layoutPatternBindFinal fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing
Nothing
binderDoc binderDoc
(Just patDocs) (Just patDocs)
clauseDocs clauseDocs
mWhereArg mWhereArg
hasComments hasComments
PatSynBind _ (PSB _ patID lpat rpat dir) -> do PatSynBind _ (PSB _ patID lpat rpat dir) -> do
fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat fmap Right $ docWrapNode lbind $ layoutPatSynBind patID
lpat
dir
rpat
_ -> Right <$> unknownNodeError "" lbind _ -> Right <$> unknownNodeError "" lbind
layoutIPBind :: ToBriDoc IPBind layoutIPBind :: ToBriDoc IPBind
layoutIPBind lipbind@(L _ bind) = case bind of layoutIPBind lipbind@(L _ bind) = case bind of
@ -181,13 +185,7 @@ layoutIPBind lipbind@(L _ bind) = case bind of
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
exprDoc <- layoutExpr expr exprDoc <- layoutExpr expr
hasComments <- hasAnyCommentsBelow lipbind hasComments <- hasAnyCommentsBelow lipbind
layoutPatternBindFinal layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments
Nothing
binderDoc
(Just ipName)
[([], exprDoc, expr)]
Nothing
hasComments
data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs) data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)
@ -205,8 +203,7 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
-- x@(HsValBinds (ValBindsIn{})) -> -- x@(HsValBinds (ValBindsIn{})) ->
-- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x -- Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x
HsValBinds _ (ValBinds _ bindlrs sigs) -> do HsValBinds _ (ValBinds _ bindlrs sigs) -> do
let let unordered =
unordered =
[ BagBind b | b <- Data.Foldable.toList bindlrs ] [ BagBind b | b <- Data.Foldable.toList bindlrs ]
++ [ BagSig s | s <- sigs ] ++ [ BagSig s | s <- sigs ]
ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered
@ -216,7 +213,8 @@ layoutLocalBinds lbinds@(L _ binds) = case binds of
return $ Just $ docs return $ Just $ docs
-- x@(HsValBinds (ValBindsOut _binds _lsigs)) -> -- x@(HsValBinds (ValBindsOut _binds _lsigs)) ->
HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR" HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR"
HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb HsIPBinds _ (IPBinds _ bb) ->
Just <$> mapM layoutIPBind bb
EmptyLocalBinds{} -> return $ Nothing EmptyLocalBinds{} -> return $ Nothing
-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is -- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is
@ -244,17 +242,16 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
_ -> pure Nothing _ -> pure Nothing
let mIdStr' = fixPatternBindIdentifier match <$> mIdStr let mIdStr' = fixPatternBindIdentifier match <$> mIdStr
patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
(Just idStr, p1 : p2 : pr) | isInfix -> if null pr (Just idStr, p1:p2:pr) | isInfix -> if null pr
then docCols then
ColPatternsFuncInfix docCols ColPatternsFuncInfix
[ appSep $ docForceSingleline p1 [ appSep $ docForceSingleline p1
, appSep $ docLit $ idStr , appSep $ docLit $ idStr
, docForceSingleline p2 , docForceSingleline p2
] ]
else docCols else
ColPatternsFuncInfix docCols ColPatternsFuncInfix
([ docCols ( [docCols ColPatterns
ColPatterns
[ docParenL [ docParenL
, appSep $ docForceSingleline p1 , appSep $ docForceSingleline p1
, appSep $ docLit $ idStr , appSep $ docLit $ idStr
@ -277,22 +274,22 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch) let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)
let alignmentToken = if null pats then Nothing else funId let alignmentToken = if null pats then Nothing else funId
hasComments <- hasAnyCommentsBelow lmatch hasComments <- hasAnyCommentsBelow lmatch
layoutPatternBindFinal layoutPatternBindFinal alignmentToken
alignmentToken
binderDoc binderDoc
(Just patDoc) (Just patDoc)
clauseDocs clauseDocs
mWhereArg mWhereArg
hasComments hasComments
fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text fixPatternBindIdentifier
:: Match GhcPs (LHsExpr GhcPs) -> Text -> Text
fixPatternBindIdentifier match idStr = go $ m_ctxt match fixPatternBindIdentifier match idStr = go $ m_ctxt match
where where
go = \case go = \case
(FunRhs _ _ SrcLazy) -> Text.cons '~' idStr (FunRhs _ _ SrcLazy ) -> Text.cons '~' idStr
(FunRhs _ _ SrcStrict) -> Text.cons '!' idStr (FunRhs _ _ SrcStrict ) -> Text.cons '!' idStr
(FunRhs _ _ NoSrcStrict) -> idStr (FunRhs _ _ NoSrcStrict) -> idStr
(StmtCtxt ctx1) -> goInner ctx1 (StmtCtxt ctx1 ) -> goInner ctx1
_ -> idStr _ -> idStr
-- I have really no idea if this path ever occurs, but better safe than -- I have really no idea if this path ever occurs, but better safe than
-- risking another "drop bangpatterns" bugs. -- risking another "drop bangpatterns" bugs.
@ -311,20 +308,22 @@ layoutPatternBindFinal
-- ^ AnnKey for the node that contains the AnnWhere position annotation -- ^ AnnKey for the node that contains the AnnWhere position annotation
-> Bool -> Bool
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do
= do let patPartInline = case mPatDoc of
let
patPartInline = case mPatDoc of
Nothing -> [] Nothing -> []
Just patDoc -> [appSep $ docForceSingleline $ return patDoc] Just patDoc -> [appSep $ docForceSingleline $ return patDoc]
patPartParWrap = case mPatDoc of patPartParWrap = case mPatDoc of
Nothing -> id Nothing -> id
Just patDoc -> docPar (return patDoc) Just patDoc -> docPar (return patDoc)
whereIndent <- do whereIndent <- do
shouldSpecial <- shouldSpecial <- mAsk
mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack <&> _conf_layout
regularIndentAmount <- .> _lconfig_indentWhereSpecial
mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack .> confUnpack
regularIndentAmount <- mAsk
<&> _conf_layout
.> _lconfig_indentAmount
.> confUnpack
pure $ if shouldSpecial pure $ if shouldSpecial
then BrIndentSpecial (max 1 (regularIndentAmount `div` 2)) then BrIndentSpecial (max 1 (regularIndentAmount `div` 2))
else BrIndentRegular else BrIndentRegular
@ -333,7 +332,8 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of
Nothing -> return $ [] Nothing -> return $ []
Just (annKeyWhere, [w]) -> pure . pure <$> docAlt Just (annKeyWhere, [w]) -> pure . pure <$> docAlt
[ docEnsureIndent BrIndentRegular $ docSeq [ docEnsureIndent BrIndentRegular
$ docSeq
[ docLit $ Text.pack "where" [ docLit $ Text.pack "where"
, docSeparator , docSeparator
, docForceSingleline $ return w , docForceSingleline $ return w
@ -361,16 +361,13 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ return $ return
<$> ws <$> ws
] ]
let let singleLineGuardsDoc guards = appSep $ case guards of
singleLineGuardsDoc guards = appSep $ case guards of
[] -> docEmpty [] -> docEmpty
[g] -> docSeq [g] -> docSeq
[appSep $ docLit $ Text.pack "|", docForceSingleline $ return g] [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g]
gs -> gs -> docSeq
docSeq
$ [appSep $ docLit $ Text.pack "|"] $ [appSep $ docLit $ Text.pack "|"]
++ (List.intersperse ++ (List.intersperse docCommaSep
docCommaSep
(docForceSingleline . return <$> gs) (docForceSingleline . return <$> gs)
) )
wherePart = case mWhereDocs of wherePart = case mWhereDocs of
@ -382,8 +379,10 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
] ]
_ -> Nothing _ -> Nothing
indentPolicy <- indentPolicy <- mAsk
mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack <&> _conf_layout
.> _lconfig_indentPolicy
.> confUnpack
runFilteredAlternative $ do runFilteredAlternative $ do
@ -409,8 +408,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
[ docSeq (patPartInline ++ [guardPart]) [ docSeq (patPartInline ++ [guardPart])
, docSeq , docSeq
[ appSep $ return binderDoc [ appSep $ return binderDoc
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
body
] ]
] ]
] ]
@ -420,8 +418,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ docLines $ docLines
$ [ docForceSingleline $ [ docForceSingleline
$ docSeq (patPartInline ++ [guardPart, return binderDoc]) $ docSeq (patPartInline ++ [guardPart, return binderDoc])
, docEnsureIndent BrIndentRegular $ docForceSingleline $ return , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body
body
] ]
++ wherePartMultiLine ++ wherePartMultiLine
-- pattern and exactly one clause in single line, body as par; -- pattern and exactly one clause in single line, body as par;
@ -433,8 +430,7 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
[ docSeq (patPartInline ++ [guardPart]) [ docSeq (patPartInline ++ [guardPart])
, docSeq , docSeq
[ appSep $ return binderDoc [ appSep $ return binderDoc
, docForceParSpacing $ docAddBaseY BrIndentRegular $ return , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body
body
] ]
] ]
] ]
@ -523,11 +519,11 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ clauseDocs $ clauseDocs
<&> \(guardDocs, bodyDoc, _) -> <&> \(guardDocs, bodyDoc, _) ->
docSeq docSeq
$ (case guardDocs of $ ( case guardDocs of
[] -> [] [] -> []
[g] -> [g] ->
[ docForceSingleline $ docSeq [ docForceSingleline
[appSep $ docLit $ Text.pack "|", return g] $ docSeq [appSep $ docLit $ Text.pack "|", return g]
] ]
gs -> gs ->
[ docForceSingleline [ docForceSingleline
@ -557,11 +553,11 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ map docSetBaseY $ map docSetBaseY
$ clauseDocs $ clauseDocs
>>= \(guardDocs, bodyDoc, _) -> >>= \(guardDocs, bodyDoc, _) ->
(case guardDocs of ( case guardDocs of
[] -> [] [] -> []
[g] -> [g] ->
[ docForceSingleline $ docSeq [ docForceSingleline
[appSep $ docLit $ Text.pack "|", return g] $ docSeq [appSep $ docLit $ Text.pack "|", return g]
] ]
gs -> gs ->
[ docForceSingleline [ docForceSingleline
@ -589,14 +585,15 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
$ map docSetBaseY $ map docSetBaseY
$ clauseDocs $ clauseDocs
>>= \(guardDocs, bodyDoc, _) -> >>= \(guardDocs, bodyDoc, _) ->
(case guardDocs of ( case guardDocs of
[] -> [] [] -> []
[g] -> [g] ->
[docSeq [appSep $ docLit $ Text.pack "|", return g]] [docSeq [appSep $ docLit $ Text.pack "|", return g]]
(g1 : gr) -> (g1:gr) ->
(docSeq [appSep $ docLit $ Text.pack "|", return g1] ( docSeq [appSep $ docLit $ Text.pack "|", return g1]
: (gr : ( gr
<&> \g -> docSeq <&> \g ->
docSeq
[appSep $ docLit $ Text.pack ",", return g] [appSep $ docLit $ Text.pack ",", return g]
) )
) )
@ -618,50 +615,43 @@ layoutPatSynBind
-> LPat GhcPs -> LPat GhcPs
-> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
layoutPatSynBind name patSynDetails patDir rpat = do layoutPatSynBind name patSynDetails patDir rpat = do
let let patDoc = docLit $ Text.pack "pattern"
patDoc = docLit $ Text.pack "pattern"
binderDoc = case patDir of binderDoc = case patDir of
ImplicitBidirectional -> docLit $ Text.pack "=" ImplicitBidirectional -> docLit $ Text.pack "="
_ -> docLit $ Text.pack "<-" _ -> docLit $ Text.pack "<-"
body = colsWrapPat =<< layoutPat rpat body = colsWrapPat =<< layoutPat rpat
whereDoc = docLit $ Text.pack "where" whereDoc = docLit $ Text.pack "where"
mWhereDocs <- layoutPatSynWhere patDir mWhereDocs <- layoutPatSynWhere patDir
headDoc <- headDoc <- fmap pure $ docSeq $
fmap pure [ patDoc
$ docSeq
$ [ patDoc
, docSeparator , docSeparator
, layoutLPatSyn name patSynDetails , layoutLPatSyn name patSynDetails
, docSeparator , docSeparator
, binderDoc , binderDoc
] ]
runFilteredAlternative $ do runFilteredAlternative $ do
addAlternative addAlternative $
$
-- pattern .. where -- pattern .. where
-- .. -- ..
-- .. -- ..
docAddBaseY BrIndentRegular docAddBaseY BrIndentRegular $ docSeq
$ docSeq ( [headDoc, docSeparator, body]
([headDoc, docSeparator, body] ++ case mWhereDocs of ++ case mWhereDocs of
Just ds -> [docSeparator, docPar whereDoc (docLines ds)] Just ds -> [docSeparator, docPar whereDoc (docLines ds)]
Nothing -> [] Nothing -> []
) )
addAlternative addAlternative $
$
-- pattern .. = -- pattern .. =
-- .. -- ..
-- pattern .. <- -- pattern .. <-
-- .. where -- .. where
-- .. -- ..
-- .. -- ..
docAddBaseY BrIndentRegular docAddBaseY BrIndentRegular $ docPar
$ docPar
headDoc headDoc
(case mWhereDocs of (case mWhereDocs of
Nothing -> body Nothing -> body
Just ds -> Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds)
docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds)
) )
-- | Helper method for the left hand side of a pattern synonym -- | Helper method for the left hand side of a pattern synonym
@ -681,21 +671,18 @@ layoutLPatSyn name (InfixCon left right) = do
layoutLPatSyn name (RecCon recArgs) = do layoutLPatSyn name (RecCon recArgs) = do
docName <- lrdrNameToTextAnn name docName <- lrdrNameToTextAnn name
args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs
docSeq docSeq . fmap docLit
. fmap docLit $ [docName, Text.pack " { " ]
$ [docName, Text.pack " { "]
<> intersperse (Text.pack ", ") args <> intersperse (Text.pack ", ") args
<> [Text.pack " }"] <> [Text.pack " }"]
-- | Helper method to get the where clause from of explicitly bidirectional -- | Helper method to get the where clause from of explicitly bidirectional
-- pattern synonyms -- pattern synonyms
layoutPatSynWhere layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered])
:: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered])
layoutPatSynWhere hs = case hs of layoutPatSynWhere hs = case hs of
ExplicitBidirectional (MG _ (L _ lbinds) _) -> do ExplicitBidirectional (MG _ (L _ lbinds) _) -> do
binderDoc <- docLit $ Text.pack "=" binderDoc <- docLit $ Text.pack "="
Just Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds
<$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds
_ -> pure Nothing _ -> pure Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -705,8 +692,7 @@ layoutPatSynWhere hs = case hs of
layoutTyCl :: ToBriDoc TyClDecl layoutTyCl :: ToBriDoc TyClDecl
layoutTyCl ltycl@(L _loc tycl) = case tycl of layoutTyCl ltycl@(L _loc tycl) = case tycl of
SynDecl _ name vars fixity typ -> do SynDecl _ name vars fixity typ -> do
let let isInfix = case fixity of
isInfix = case fixity of
Prefix -> False Prefix -> False
Infix -> True Infix -> True
-- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP
@ -737,7 +723,9 @@ layoutSynDecl isInfix wrapNodeRest name vars typ = do
-- This isn't quite right, but does give syntactically valid results -- This isn't quite right, but does give syntactically valid results
let needsParens = not (null rest) || hasOwnParens let needsParens = not (null rest) || hasOwnParens
docSeq docSeq
$ [docLit $ Text.pack "type", docSeparator] $ [ docLit $ Text.pack "type"
, docSeparator
]
++ [ docParenL | needsParens ] ++ [ docParenL | needsParens ]
++ [ layoutTyVarBndr False a ++ [ layoutTyVarBndr False a
, docSeparator , docSeparator
@ -764,7 +752,7 @@ layoutTyVarBndr needsSep lbndr@(L _ bndr) = do
docWrapNodePrior lbndr $ case bndr of docWrapNodePrior lbndr $ case bndr of
UserTyVar _ _ name -> do UserTyVar _ _ name -> do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr] docSeq $ [docSeparator | needsSep] ++ [docLit nameStr]
KindedTyVar _ _ name kind -> do KindedTyVar _ _ name kind -> do
nameStr <- lrdrNameToTextAnn name nameStr <- lrdrNameToTextAnn name
docSeq docSeq
@ -807,7 +795,7 @@ layoutTyFamInstDecl inClass outerNode tfid = do
makeForallDoc bndrs = do makeForallDoc bndrs = do
bndrDocs <- layoutTyVarBndrs bndrs bndrDocs <- layoutTyVarBndrs bndrs
docSeq docSeq
([docLit (Text.pack "forall")] ( [docLit (Text.pack "forall")]
++ processTyVarBndrsSingleline bndrDocs ++ processTyVarBndrsSingleline bndrDocs
) )
lhs = lhs =
@ -819,16 +807,14 @@ layoutTyFamInstDecl inClass outerNode tfid = do
++ [appSep $ docWrapNode name $ docLit nameStr] ++ [appSep $ docWrapNode name $ docLit nameStr]
++ intersperse docSeparator (layoutHsTyPats pats) ++ intersperse docSeparator (layoutHsTyPats pats)
++ [ docParenR | needsParens ] ++ [ docParenR | needsParens ]
hasComments <- hasComments <- (||)
(||)
<$> hasAnyRegularCommentsConnected outerNode <$> hasAnyRegularCommentsConnected outerNode
<*> hasAnyRegularCommentsRest innerNode <*> hasAnyRegularCommentsRest innerNode
typeDoc <- docSharedWrapper layoutType typ typeDoc <- docSharedWrapper layoutType typ
layoutLhsAndType hasComments lhs "=" typeDoc layoutLhsAndType hasComments lhs "=" typeDoc
layoutHsTyPats layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]
:: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]
layoutHsTyPats pats = pats <&> \case layoutHsTyPats pats = pats <&> \case
HsValArg tm -> layoutType tm HsValArg tm -> layoutType tm
HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty] HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty]
@ -878,11 +864,7 @@ layoutClsInst lcid@(L _ cid) = docLines
docSortedLines docSortedLines
:: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered
docSortedLines l = docSortedLines l =
allocateNode allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l
. BDFLines
. fmap unLoc
. List.sortOn (ExactPrint.rs . getLoc)
=<< sequence l
layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered) layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered)
layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig
@ -963,8 +945,7 @@ layoutClsInst lcid@(L _ cid) = docLines
where where
go [] = [] go [] = []
go (line1 : lineR) = case Text.stripStart line1 of go (line1 : lineR) = case Text.stripStart line1 of
st st | isTypeOrData st -> st : lineR
| isTypeOrData st -> st : lineR
| otherwise -> st : go lineR | otherwise -> st : go lineR
isTypeOrData t' = isTypeOrData t' =
(Text.pack "type" `Text.isPrefixOf` t') (Text.pack "type" `Text.isPrefixOf` t')
@ -988,12 +969,7 @@ layoutLhsAndType hasComments lhs sep typeDoc = do
-- lhs = type -- lhs = type
-- lhs :: type -- lhs :: type
addAlternativeCond (not hasComments) $ docSeq addAlternativeCond (not hasComments) $ docSeq
[ lhs [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc]
, docSeparator
, docLitS sep
, docSeparator
, docForceSingleline typeDoc
]
-- lhs -- lhs
-- :: typeA -- :: typeA
-- -> typeB -- -> typeB

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

File diff suppressed because it is too large Load Diff

11
source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot
View File

@ -2,11 +2,20 @@
module Language.Haskell.Brittany.Internal.Layouters.Expr where module Language.Haskell.Brittany.Internal.Layouters.Expr where
import GHC.Hs
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import GHC.Hs
layoutExpr :: ToBriDoc HsExpr layoutExpr :: ToBriDoc HsExpr
-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
litBriDoc :: HsLit GhcPs -> BriDocFInt litBriDoc :: HsLit GhcPs -> BriDocFInt
overLitValBriDoc :: OverLitVal -> BriDocFInt overLitValBriDoc :: OverLitVal -> BriDocFInt

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

@ -4,23 +4,27 @@
module Language.Haskell.Brittany.Internal.Layouters.IE where module Language.Haskell.Brittany.Internal.Layouters.IE where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Data.List.Extra import qualified Data.List.Extra
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC import qualified GHC.OldList as List
( AnnKeywordId(..)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( unLoc
, GenLocated(L) , GenLocated(L)
, moduleNameString
, AnnKeywordId(..)
, Located , Located
, ModuleName , ModuleName
, moduleNameString
, unLoc
) )
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
prepareName :: LIEWrappedName name -> Located name prepareName :: LIEWrappedName name -> Located name
prepareName = ieLWrappedName prepareName = ieLWrappedName
@ -33,7 +37,7 @@ 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
) )
@ -47,27 +51,22 @@ layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of
addAlternative addAlternative
$ docWrapNodeRest lie $ docWrapNodeRest lie
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs)) $ docPar
(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] [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR]
, docParenR
]
layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines
[ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n] [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR]
, 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 ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR]
[docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]
, docParenR
]
IEModuleContents _ n -> docSeq IEModuleContents _ n -> docSeq
[ docLit $ Text.pack "module" [ docLit $ Text.pack "module"
, docSeparator , docSeparator
@ -93,19 +92,16 @@ 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 :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered]
-> 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 let sortedLies =
sortedLies =
[ items [ items
| group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies | group <- Data.List.Extra.groupOn lieToText
$ List.sortOn lieToText lies
, items <- mergeGroup group , items <- mergeGroup group
] ]
let let ieDocs = fmap layoutIE $ case shouldSort of
ieDocs = fmap layoutIE $ case shouldSort of
ShouldSortItems -> sortedLies ShouldSortItems -> sortedLies
KeepItemsUnsorted -> lies KeepItemsUnsorted -> lies
ieCommaDocs <- ieCommaDocs <-
@ -137,16 +133,15 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
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 (IEThingWith x
x
wn wn
NoIEWildcard NoIEWildcard
(consItems1 ++ consItems2) (consItems1 ++ consItems2)
@ -169,8 +164,7 @@ layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do
-- () -- no comments -- () -- no comments
-- ( -- a comment -- ( -- a comment
-- ) -- )
layoutLLIEs layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered
:: 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
@ -206,9 +200,9 @@ wrappedNameToText = \case
-- 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
@ -219,5 +213,4 @@ lieToText = \case
L _ IEDocNamed{} -> Text.pack "@IEDocNamed" L _ IEDocNamed{} -> Text.pack "@IEDocNamed"
where where
moduleNameToText :: Located ModuleName -> Text moduleNameToText :: Located ModuleName -> Text
moduleNameToText (L _ name) = moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)
Text.pack ("@IEModuleContents" ++ moduleNameString name)

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

@ -2,18 +2,26 @@
module Language.Haskell.Brittany.Internal.Layouters.Import where module Language.Haskell.Brittany.Internal.Layouters.Import where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (GenLocated(L), Located, moduleNameString, unLoc)
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Config.Types
import GHC ( unLoc
, GenLocated(L)
, moduleNameString
, Located
)
import GHC.Hs import GHC.Hs
import GHC.Types.Basic import GHC.Types.Basic
import GHC.Unit.Types (IsBootInterface(..)) import GHC.Unit.Types (IsBootInterface(..))
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
prepPkg :: SourceText -> String prepPkg :: SourceText -> String
prepPkg rawN = case rawN of prepPkg rawN = case rawN of
@ -28,10 +36,8 @@ 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 <- importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack
mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> 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
@ -40,13 +46,10 @@ layoutImport importD = case importD of
hiding = maybe False fst mllies hiding = maybe False fst mllies
minQLength = length "import qualified " minQLength = length "import qualified "
qLengthReal = qLengthReal =
let let qualifiedPart = if q /= NotQualified then length "qualified " else 0
qualifiedPart = if q /= NotQualified then length "qualified " else 0
safePart = if safe then length "safe " else 0 safePart = if safe then length "safe " else 0
pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT
srcPart = case src of srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 }
IsBoot -> length "{-# SOURCE #-} "
NotBoot -> 0
in length "import " + srcPart + safePart + qualifiedPart + pkgPart in length "import " + srcPart + safePart + qualifiedPart + pkgPart
qLength = max minQLength qLengthReal qLength = max minQLength qLengthReal
-- Cost in columns of importColumn -- Cost in columns of importColumn
@ -55,23 +58,20 @@ layoutImport importD = case importD of
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 , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty }
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 , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty
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 = indentName $ appSep $ docLit modNameT modNameD =
hidDocCol = indentName $ appSep $ docLit modNameT
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 = hidDoc = if hiding
if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty then appSep $ docLit $ Text.pack "hiding"
else docEmpty
importHead = docSeq [importQualifiers, modNameD] importHead = docSeq [importQualifiers, modNameD]
bindingsD = case mllies of bindingsD = case mllies of
Nothing -> docEmpty Nothing -> docEmpty
@ -79,12 +79,8 @@ layoutImport importD = case importD of
hasComments <- hasAnyCommentsBelow llies hasComments <- hasAnyCommentsBelow llies
if compact if compact
then docAlt then docAlt
[ docSeq [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies]
[ hidDoc , let makeParIfHiding = if hiding
, 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)
@ -97,15 +93,9 @@ layoutImport importD = case importD of
-- ..[hiding].( ) -- ..[hiding].( )
[] -> if hasComments [] -> if hasComments
then docPar then docPar
(docSeq (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty])
[hidDoc, docParenLSep, docWrapNode llies docEmpty] (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)
) else docSeq [hidDoc, docParenLSep, docSeparator, docParenR]
(docEnsureIndent
(BrIndentSpecial hidDocColDiff)
docParenR
)
else docSeq
[hidDoc, docParenLSep, docSeparator, docParenR]
-- ..[hiding].( b ) -- ..[hiding].( b )
[ieD] -> runFilteredAlternative $ do [ieD] -> runFilteredAlternative $ do
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
@ -117,20 +107,15 @@ layoutImport importD = case importD of
, docParenR , docParenR
] ]
addAlternative $ docPar addAlternative $ docPar
(docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD] (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])
) (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)
(docEnsureIndent
(BrIndentSpecial hidDocColDiff)
docParenR
)
-- ..[hiding].( b -- ..[hiding].( b
-- , b' -- , b'
-- ) -- )
(ieD : ieDs') -> docPar (ieD:ieDs') ->
(docSeq docPar
[hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]] (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]])
) ( docEnsureIndent (BrIndentSpecial hidDocColDiff)
(docEnsureIndent (BrIndentSpecial hidDocColDiff)
$ docLines $ docLines
$ ieDs' $ ieDs'
++ [docParenR] ++ [docParenR]
@ -140,19 +125,21 @@ layoutImport importD = case importD of
if compact if compact
then then
let asDoc = maybe docEmpty makeAsDoc masT let asDoc = maybe docEmpty makeAsDoc masT
in in docAlt
docAlt
[ docForceSingleline $ docSeq [importHead, asDoc, bindingsD] [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD]
, docAddBaseY BrIndentRegular , docAddBaseY BrIndentRegular $
$ docPar (docSeq [importHead, asDoc]) bindingsD docPar (docSeq [importHead, asDoc]) bindingsD
] ]
else case masT of else
case masT of
Just n -> if enoughRoom Just n -> if enoughRoom
then docLines [docSeq [importHead, asDoc], bindingsD] then docLines
[ 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 = docEnsureIndent (BrIndentSpecial (importAsCol - asCost)) asDoc =
docEnsureIndent (BrIndentSpecial (importAsCol - asCost))
$ makeAsDoc n $ makeAsDoc n
Nothing -> if enoughRoom Nothing -> if enoughRoom
then docSeq [importHead, bindingsD] then docSeq [importHead, bindingsD]

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

@ -3,22 +3,29 @@
module Language.Haskell.Brittany.Internal.Layouters.Module where module Language.Haskell.Brittany.Internal.Layouters.Module where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc)
import GHC.Hs
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Layouters.IE import Language.Haskell.Brittany.Internal.Layouters.IE
import Language.Haskell.Brittany.Internal.Layouters.Import import Language.Haskell.Brittany.Internal.Layouters.Import
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import GHC (unLoc, GenLocated(L), moduleNameString, AnnKeywordId(..))
import GHC.Hs
import Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types
(DeltaPos(..), commentContents, deltaRow) ( DeltaPos(..)
, deltaRow
, commentContents
)
layoutModule :: ToBriDoc' HsModule layoutModule :: ToBriDoc' HsModule
layoutModule lmod@(L _ mod') = case mod' of layoutModule lmod@(L _ mod') = case mod' of
@ -34,19 +41,22 @@ 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 <- allowSingleLineExportList <- mAsk
mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack <&> _conf_layout
.> _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 let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les
docLines docLines
$ docSeq $ docSeq
[ docNodeAnnKW lmod Nothing docEmpty [ docNodeAnnKW lmod Nothing docEmpty
-- 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 $ docForceSingleline $ docSeq addAlternativeCond allowSingleLine $
docForceSingleline
$ docSeq
[ appSep $ docLit $ Text.pack "module" [ appSep $ docLit $ Text.pack "module"
, appSep $ docLit tn , appSep $ docLit tn
, docWrapNode lmod $ appSep $ case les of , docWrapNode lmod $ appSep $ case les of
@ -55,11 +65,13 @@ layoutModule lmod@(L _ mod') = case mod' of
, docSeparator , docSeparator
, docLit $ Text.pack "where" , 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 )
[ docWrapNode lmod $ case les of (docSeq [
docWrapNode lmod $ case les of
Nothing -> docEmpty Nothing -> docEmpty
Just x -> layoutLLIEs False KeepItemsUnsorted x Just x -> layoutLLIEs False KeepItemsUnsorted x
, docSeparator , docSeparator
@ -90,8 +102,7 @@ data ImportStatementRecord = ImportStatementRecord
} }
instance Show ImportStatementRecord where instance Show ImportStatementRecord where
show r = show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
"ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show
(length $ commentsAfter r) (length $ commentsAfter r)
transformToCommentedImport transformToCommentedImport
@ -110,8 +121,7 @@ transformToCommentedImport is = do
accumF accConnectedComm (annMay, decl) = case annMay of accumF accConnectedComm (annMay, decl) = case annMay of
Nothing -> Nothing ->
( [] ( []
, [ ImportStatement ImportStatementRecord , [ ImportStatement ImportStatementRecord { commentsBefore = []
{ commentsBefore = []
, commentsAfter = [] , commentsAfter = []
, importStatement = decl , importStatement = decl
} }
@ -190,8 +200,10 @@ commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered
commentedImportsToDoc = \case commentedImportsToDoc = \case
EmptyLine -> docLitS "" EmptyLine -> docLitS ""
IndependentComment c -> commentToDoc c IndependentComment c -> commentToDoc c
ImportStatement r -> docSeq ImportStatement r ->
(layoutImport (importStatement r) : map commentToDoc (commentsAfter r)) docSeq
( layoutImport (importStatement r)
: map commentToDoc (commentsAfter r)
)
where where
commentToDoc (c, DP (_y, x)) = commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)
docLitS (replicate x ' ' ++ commentContents c)

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

@ -3,19 +3,28 @@
module Language.Haskell.Brittany.Internal.Layouters.Pattern where module Language.Haskell.Brittany.Internal.Layouters.Pattern where
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (GenLocated(L), ol_val)
import GHC.Hs
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Types.Basic
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( GenLocated(L)
, ol_val
)
import GHC.Hs
import GHC.Types.Basic
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Type
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
-- | layouts patterns (inside function bindings, case alternatives, let -- | layouts patterns (inside function bindings, case alternatives, let
-- bindings or do notation). E.g. for input -- bindings or do notation). E.g. for input
@ -31,9 +40,11 @@ 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 -> fmap Seq.singleton $ docLit $ lrdrNameToText n VarPat _ n ->
fmap Seq.singleton $ docLit $ lrdrNameToText n
-- abc -> expr -- abc -> expr
LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit LitPat _ lit ->
fmap Seq.singleton $ allocateNode $ litBriDoc lit
-- 0 -> expr -- 0 -> expr
ParPat _ inner -> do ParPat _ inner -> do
-- (nestedpat) -> expr -- (nestedpat) -> expr
@ -63,9 +74,10 @@ 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 $ sequence $ spacifyDocs $ fmap xR <- fmap Seq.fromList
colsWrapPat $ sequence
argDocs $ spacifyDocs
$ 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
@ -78,7 +90,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
@ -91,7 +103,8 @@ 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 $ fds <&> \case , docSeq $ List.intersperse docCommaSep
$ fds <&> \case
(fieldName, Just fieldDoc) -> docSeq (fieldName, Just fieldDoc) -> docSeq
[ appSep $ docLit fieldName [ appSep $ docLit fieldName
, appSep $ docLit $ Text.pack "=" , appSep $ docLit $ Text.pack "="
@ -104,9 +117,11 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
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 [appSep $ docLit t, docLit $ Text.pack "{..}"] Seq.singleton <$> docSeq
ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti)))) [ appSep $ docLit t
| dotdoti == length fs -> do , docLit $ Text.pack "{..}"
]
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
@ -169,8 +184,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
wrapPatPrepend pat1 (docLit $ Text.pack "~") wrapPatPrepend pat1 (docLit $ Text.pack "~")
NPat _ llit@(L _ ol) mNegative _ -> do NPat _ llit@(L _ ol) mNegative _ -> do
-- -13 -> expr -- -13 -> expr
litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol
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]
@ -182,7 +196,9 @@ colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered
colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList
wrapPatPrepend wrapPatPrepend
:: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered) :: LPat GhcPs
-> 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
@ -204,5 +220,8 @@ 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 [docCommaSep, return bd] rest' <- rest `forM` \bd -> docSeq
[ docCommaSep
, return bd
]
return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc

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

@ -4,19 +4,26 @@
module Language.Haskell.Brittany.Internal.Layouters.Stmt where module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import GHC (GenLocated(L))
import GHC.Hs
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Config.Types
import GHC ( GenLocated(L)
)
import GHC.Hs
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Decl
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import Language.Haskell.Brittany.Internal.Layouters.Pattern
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
layoutStmt lstmt@(L _ stmt) = do layoutStmt lstmt@(L _ stmt) = do
@ -61,8 +68,7 @@ layoutStmt lstmt@(L _ stmt) = do
f = case indentPolicy of f = case indentPolicy of
IndentPolicyFree -> docSetBaseAndIndent IndentPolicyFree -> docSetBaseAndIndent
IndentPolicyLeft -> docForceSingleline IndentPolicyLeft -> docForceSingleline
IndentPolicyMultiple IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent
| indentFourPlus -> docSetBaseAndIndent
| otherwise -> docForceSingleline | otherwise -> docForceSingleline
in f $ return bindDoc in f $ return bindDoc
] ]
@ -78,8 +84,7 @@ 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 , let f = if indentFourPlus
f = if indentFourPlus
then docEnsureIndent BrIndentRegular then docEnsureIndent BrIndentRegular
else docSetBaseAndIndent else docSetBaseAndIndent
in f $ docLines $ return <$> bindDocs in f $ docLines $ return <$> bindDocs
@ -90,8 +95,7 @@ layoutStmt lstmt@(L _ stmt) = do
-- ccc = exprc -- ccc = exprc
addAlternativeCond (not indentFourPlus) addAlternativeCond (not indentFourPlus)
$ docAddBaseY BrIndentRegular $ docAddBaseY BrIndentRegular
$ docPar $ docPar (docLit $ Text.pack "let")
(docLit $ Text.pack "let")
(docSetBaseAndIndent $ docLines $ return <$> bindDocs) (docSetBaseAndIndent $ docLines $ return <$> bindDocs)
RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do
-- rec stmt1 -- rec stmt1

9
source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot
View File

@ -2,7 +2,14 @@
module Language.Haskell.Brittany.Internal.Layouters.Stmt where module Language.Haskell.Brittany.Internal.Layouters.Stmt where
import GHC.Hs
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import GHC.Hs
layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs)) layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))

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

@ -3,18 +3,28 @@
module Language.Haskell.Brittany.Internal.Layouters.Type where module Language.Haskell.Brittany.Internal.Layouters.Type where
import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L))
import GHC.Hs
import qualified GHC.OldList as List
import GHC.Types.Basic
import GHC.Utils.Outputable (ftext, showSDocUnsafe)
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Text as Text
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
(FirstLastView(..), splitFirstLast) ( splitFirstLast
, FirstLastView(..)
)
import GHC ( GenLocated(L)
, AnnKeywordId (..)
)
import GHC.Hs
import GHC.Utils.Outputable ( ftext, showSDocUnsafe )
import GHC.Types.Basic
layoutType :: ToBriDoc HsType layoutType :: ToBriDoc HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
@ -22,33 +32,43 @@ 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 -> IsPromoted -> docSeq
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 let maybeForceML = case typ2 of
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline (L _ HsFunTy{}) -> docForceMultiline
_ -> id _ -> id
let let
tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
forallDoc = docAlt forallDoc = docAlt
[ let open = docLit $ Text.pack "forall" [ let
in docSeq ([open] ++ tyVarDocLineList) open = docLit $ Text.pack "forall"
in docSeq ([open]++tyVarDocLineList)
, docPar , docPar
(docLit (Text.pack "forall")) (docLit (Text.pack "forall"))
(docLines $ tyVarDocs <&> \case (docLines
$ 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 "()"
@ -57,19 +77,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ let [ let
open = docLit $ Text.pack "(" open = docLit $ Text.pack "("
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = list = List.intersperse docCommaSep
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close]) in docSeq ([open]++list++[close])
, let , let
open = docCols open = docCols ColTyOpPrefix
ColTyOpPrefix
[ docParenLSep [ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
] ]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols list = List.tail cntxtDocs <&> \cntxtDoc ->
ColTyOpPrefix docCols ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc] [ docCommaSep
, docAddBaseY (BrIndentSpecial 2) cntxtDoc
]
in docPar open $ docLines $ list ++ [close] in docPar open $ docLines $ list ++ [close]
] ]
docAlt docAlt
@ -77,11 +98,10 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ docSeq [ docSeq
[ if null bndrs [ if null bndrs
then docEmpty then docEmpty
else else let
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
@ -92,14 +112,13 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- -> c -- -> c
, docPar , docPar
forallDoc forallDoc
(docLines ( docLines
[ docCols [ docCols ColTyOpPrefix
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, docAddBaseY (BrIndentSpecial 3) $ contextDoc , docAddBaseY (BrIndentSpecial 3)
$ contextDoc
] ]
, docCols , docCols ColTyOpPrefix
ColTyOpPrefix
[ docLit $ Text.pack "=> " [ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
] ]
@ -110,8 +129,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
let bndrs = getBinders hsf let bndrs = getBinders hsf
typeDoc <- layoutType typ2 typeDoc <- layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
let let maybeForceML = case typ2 of
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline (L _ HsFunTy{}) -> docForceMultiline
_ -> id _ -> id
let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs
@ -120,19 +138,17 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ docSeq [ docSeq
[ if null bndrs [ if null bndrs
then docEmpty then docEmpty
else else let
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 ( docCols ColTyOpPrefix
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc , maybeForceML $ return typeDoc
] ]
@ -144,16 +160,21 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
(docLit (Text.pack "forall")) (docLit (Text.pack "forall"))
(docLines (docLines
$ (tyVarDocs <&> \case $ (tyVarDocs <&> \case
(tname, Nothing) -> (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
docEnsureIndent BrIndentRegular $ docLit tname (tname, Just doc) -> docEnsureIndent BrIndentRegular
(tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines $ docLines
[ docCols ColTyOpPrefix [docParenLSep, docLit tname] [ docCols ColTyOpPrefix
, docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc] [ docParenLSep
, docLit tname
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
) )
++ [ docCols ++[ docCols ColTyOpPrefix
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . " [ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc , maybeForceML $ return typeDoc
] ]
@ -171,23 +192,25 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
[ let [ let
open = docLit $ Text.pack "(" open = docLit $ Text.pack "("
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = list = List.intersperse docCommaSep
List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs $ docForceSingleline <$> cntxtDocs
in docSeq ([open] ++ list ++ [close]) in docSeq ([open]++list++[close])
, let , let
open = docCols open = docCols ColTyOpPrefix
ColTyOpPrefix
[ docParenLSep [ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs , docAddBaseY (BrIndentSpecial 2)
$ head cntxtDocs
] ]
close = docLit $ Text.pack ")" close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc -> docCols list = List.tail cntxtDocs <&> \cntxtDoc ->
ColTyOpPrefix docCols ColTyOpPrefix
[docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc] [ docCommaSep
, docAddBaseY (BrIndentSpecial 2)
$ cntxtDoc
]
in docPar open $ docLines $ list ++ [close] in docPar open $ docLines $ list ++ [close]
] ]
let let maybeForceML = case typ1 of
maybeForceML = case typ1 of
(L _ HsFunTy{}) -> docForceMultiline (L _ HsFunTy{}) -> docForceMultiline
_ -> id _ -> id
docAlt docAlt
@ -202,8 +225,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- -> c -- -> c
, docPar , docPar
(docForceSingleline contextDoc) (docForceSingleline contextDoc)
(docCols ( docCols ColTyOpPrefix
ColTyOpPrefix
[ docLit $ Text.pack "=> " [ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
] ]
@ -212,25 +234,24 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
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 let maybeForceML = case typ2 of
maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline (L _ HsFunTy{}) -> docForceMultiline
_ -> id _ -> 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 [ docPar
(docNodeAnnKW ltype Nothing typeDoc1) (docNodeAnnKW ltype Nothing typeDoc1)
(docCols ( docCols ColTyOpPrefix
ColTyOpPrefix
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->" [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2 , docAddBaseY (BrIndentSpecial 3)
$ maybeForceML typeDoc2
] ]
) )
] ]
@ -243,28 +264,24 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
, docPar , docPar
(docCols ( docCols ColTyOpPrefix
ColTyOpPrefix
[ docWrapNodeRest ltype $ docParenLSep [ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
] ])
)
(docLit $ Text.pack ")") (docLit $ Text.pack ")")
] ]
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather
:: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather list = \case gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1 L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1
final -> (final, list) 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 $ docForceSingleline docHead : (docRest >>= \d ->
: (docRest >>= \d -> [docSeparator, docForceSingleline d]) [ docSeparator, docForceSingleline d ])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest) , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
] ]
HsAppTy _ typ1 typ2 -> do HsAppTy _ typ1 typ2 -> do
@ -276,7 +293,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docSeparator , docSeparator
, docForceSingleline typeDoc2 , docForceSingleline typeDoc2
] ]
, docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2) , docPar
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
] ]
HsListTy _ typ1 -> do HsListTy _ typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
@ -287,12 +306,10 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "]" , docLit $ Text.pack "]"
] ]
, docPar , docPar
(docCols ( docCols ColTyOpPrefix
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ " [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1 , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
] ])
)
(docLit $ Text.pack "]") (docLit $ Text.pack "]")
] ]
HsTupleTy _ tupleSort typs -> case tupleSort of HsTupleTy _ tupleSort typs -> case tupleSort of
@ -301,46 +318,38 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsConstraintTuple -> simple HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple HsBoxedOrConstraintTuple -> simple
where where
unboxed = if null typs unboxed = if null typs then error "brittany internal error: unboxed unit"
then error "brittany internal error: unboxed unit"
else unboxedL 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 let end = docLit $ Text.pack ")"
end = docLit $ Text.pack ")" lines = List.tail docs <&> \d ->
lines = docAddBaseY (BrIndentSpecial 2)
List.tail docs
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d] $ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
docAlt docAlt
[ docSeq [ docSeq $ [docLit $ Text.pack "("]
$ [docLit $ Text.pack "("]
++ docWrapNodeRest ltype commaDocs ++ docWrapNodeRest ltype commaDocs
++ [end] ++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in in docPar
docPar
(docAddBaseY (BrIndentSpecial 2) $ line1) (docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ docWrapNodeRest ltype lines ++ [end]) (docLines $ docWrapNodeRest ltype lines ++ [end])
] ]
unboxedL = do unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
let let start = docParenHashLSep
start = docParenHashLSep
end = docParenHashRSep end = docParenHashRSep
docAlt docAlt
[ docSeq [ docSeq $ [start]
$ [start]
++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ [end] ++ [end]
, let , let
line1 = docCols ColTyOpPrefix [start, head docs] line1 = docCols ColTyOpPrefix [start, head docs]
lines = lines = List.tail docs <&> \d ->
List.tail docs docAddBaseY (BrIndentSpecial 2)
<&> \d -> docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d] $ docCols ColTyOpPrefix [docCommaSep, d]
in docPar in docPar
(docAddBaseY (BrIndentSpecial 2) line1) (docAddBaseY (BrIndentSpecial 2) line1)
@ -410,18 +419,20 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 <- docSharedWrapper layoutType typ1
docAlt docAlt
[ docSeq [ docSeq
[ docWrapNodeRest ltype $ docLit $ Text.pack [ docWrapNodeRest ltype
("?" ++ showSDocUnsafe (ftext ipName) ++ "::") $ docLit
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1 , docForceSingleline typeDoc1
] ]
, docPar , docPar
(docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))) ( docLit
(docCols $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 2) typeDoc1
]
) )
(docCols ColTyOpPrefix
[ docWrapNodeRest ltype
$ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 2) typeDoc1
])
] ]
-- TODO: test KindSig -- TODO: test KindSig
HsKindSig _ typ1 kind1 -> do HsKindSig _ typ1 kind1 -> do
@ -462,7 +473,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
@ -560,19 +571,15 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
addAlternativeCond (not hasComments) addAlternativeCond (not hasComments)
$ docSeq $ docSeq
$ [docLit $ Text.pack "'["] $ [docLit $ Text.pack "'["]
++ List.intersperse ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]))
specialCommaSep
(docForceSingleline
<$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])
)
++ [docLit $ Text.pack " ]"] ++ [docLit $ Text.pack " ]"]
addAlternative addAlternative $
$ let let
start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1] start = docCols ColList
linesM = ems <&> \d -> docCols ColList [specialCommaSep, d] [appSep $ docLit $ Text.pack "'[", e1]
lineN = docCols linesM = ems <&> \d ->
ColList docCols ColList [specialCommaSep, d]
[specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN] lineN = docCols ColList [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]
] ]
@ -585,7 +592,8 @@ 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 _ -> docLit $ Text.pack "_" HsWildCardTy _ ->
docLit $ Text.pack "_"
HsSumTy{} -> -- TODO HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype briDocByExactInlineOnly "HsSumTy{}" ltype
HsStarTy _ isUnicode -> do HsStarTy _ isUnicode -> do
@ -603,7 +611,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
, docLit $ Text.pack "@" , docLit $ Text.pack "@"
, docForceSingleline k , docForceSingleline k
] ]
, docPar t (docSeq [docLit $ Text.pack "@", k]) , docPar
t
(docSeq [docLit $ Text.pack "@", k ])
] ]
layoutTyVarBndrs layoutTyVarBndrs

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

@ -2,22 +2,26 @@
module Language.Haskell.Brittany.Internal.Obfuscation where module Language.Haskell.Brittany.Internal.Obfuscation where
import Data.Char
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Data.Char
import System.Random import System.Random
obfuscate :: Text -> IO Text obfuscate :: Text -> IO Text
obfuscate input = do 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 let exceptionFilter x | x `elem` keywords = False
exceptionFilter x | x `elem` keywords = False
exceptionFilter x | x `elem` extraKWs = False exceptionFilter x | x `elem` extraKWs = False
exceptionFilter x = not $ null $ drop 1 x exceptionFilter x = not $ null $ drop 1 x
let filtered = filter exceptionFilter idents let filtered = filter exceptionFilter idents

503
source/library/Language/Haskell/Brittany/Internal/Prelude.hs
View File

@ -1,195 +1,346 @@
module Language.Haskell.Brittany.Internal.Prelude module Language.Haskell.Brittany.Internal.Prelude ( module E ) where
( module E
) where
import GHC.Hs.Extension as E (GhcPs)
import GHC.Types.Name.Reader as E (RdrName)
import Control.Applicative as E (Alternative(..), Applicative(..))
import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second) -- rather project-specific stuff:
import Control.Concurrent as E (forkIO, forkOS, threadDelay) ---------------------------------
import Control.Concurrent.Chan as E (Chan) import GHC.Hs.Extension as E ( GhcPs )
import Control.Concurrent.MVar as E
(MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar) import GHC.Types.Name.Reader as E ( RdrName )
import Control.Exception as E (assert, bracket, evaluate)
import Control.Monad as E
( (<$!>) -- more general:
, (<=<) ----------------
, (=<<)
, (>=>) import Data.Functor.Identity as E ( Identity(..) )
, Functor(..) import Control.Concurrent.Chan as E ( Chan )
, Monad(..) import Control.Concurrent.MVar as E ( MVar
, MonadPlus(..) , newEmptyMVar
, filterM , newMVar
, putMVar
, readMVar
, takeMVar
, swapMVar
)
import Data.Int as E ( Int )
import Data.Word as E ( Word
, Word32
)
import Prelude as E ( Integer
, Float
, Double
, undefined
, Eq (..)
, Ord (..)
, Enum (..)
, Bounded (..)
, (<$>)
, (.)
, ($)
, ($!)
, Num (..)
, Integral (..)
, Fractional (..)
, Floating (..)
, RealFrac (..)
, RealFloat (..)
, fromIntegral
, error
, foldr
, foldl
, foldr1
, id
, map
, subtract
, putStrLn
, putStr
, Show (..)
, print
, fst
, snd
, (++)
, not
, (&&)
, (||)
, curry
, uncurry
, flip
, const
, seq
, reverse
, otherwise
, traverse
, realToFrac
, or
, and
, head
, any
, (^)
, Foldable
, Traversable
)
import Control.Monad.ST as E ( ST )
import Data.Bool as E ( Bool(..) )
import Data.Char as E ( Char
, ord
, chr
)
import Data.Either as E ( Either(..)
, either
)
import Data.IORef as E ( IORef )
import Data.Maybe as E ( Maybe(..)
, fromMaybe
, maybe
, listToMaybe
, maybeToList
, catMaybes
)
import Data.Monoid as E ( Endo(..)
, All(..)
, Any(..)
, Sum(..)
, Product(..)
, Alt(..)
, mconcat
, Monoid (..)
)
import Data.Ord as E ( Ordering(..)
, Down(..)
, comparing
)
import Data.Ratio as E ( Ratio
, Rational
, (%)
, numerator
, denominator
)
import Data.String as E ( String )
import Data.Void as E ( Void )
import System.IO as E ( IO
, hFlush
, stdout
)
import Data.Proxy as E ( Proxy(..) )
import Data.Sequence as E ( Seq )
import Data.Map as E ( Map )
import Data.Set as E ( Set )
import Data.Text as E ( Text )
import Data.Function as E ( fix
, (&)
)
import Data.Foldable as E ( foldl'
, foldr'
, fold
, asum
)
import Data.List as E ( partition
, null
, elem
, notElem
, minimum
, maximum
, length
, all
, take
, drop
, find
, sum
, zip
, zip3
, zipWith
, repeat
, replicate
, iterate
, nub
, filter
, intersperse
, intercalate
, isSuffixOf
, isPrefixOf
, dropWhile
, takeWhile
, unzip
, break
, transpose
, sortBy
, mapAccumL
, mapAccumR
, uncons
)
import Data.List.NonEmpty as E ( NonEmpty(..)
, nonEmpty
)
import Data.Tuple as E ( swap
)
import Text.Read as E ( readMaybe
)
import Control.Monad as E ( Functor (..)
, Monad (..)
, MonadPlus (..)
, mapM
, mapM_
, forM , forM
, forM_ , forM_
, sequence
, sequence_
, (=<<)
, (>=>)
, (<=<)
, forever , forever
, guard , void
, join , join
, replicateM
, replicateM_
, guard
, when
, unless
, liftM , liftM
, liftM2 , liftM2
, liftM3 , liftM3
, liftM4 , liftM4
, liftM5 , liftM5
, mapM , filterM
, mapM_ , (<$!>)
, replicateM
, replicateM_
, sequence
, sequence_
, unless
, void
, when
) )
import Control.Monad.Extra as E
(allM, andM, anyM, ifM, notM, orM, unlessM, whenM) import Control.Applicative as E ( Applicative (..)
import Control.Monad.IO.Class as E (MonadIO(..)) , Alternative (..)
import Control.Monad.ST as E (ST)
import Control.Monad.Trans.Class as E (lift)
import Control.Monad.Trans.Maybe as E (MaybeT(..))
import Control.Monad.Trans.MultiRWS as E
(MonadMultiReader(..), MonadMultiState(..), MonadMultiWriter(..), mGet)
import Data.Bifunctor as E (bimap)
import Data.Bool as E (Bool(..))
import Data.Char as E (Char, chr, ord)
import Data.Data as E (toConstr)
import Data.Either as E (Either(..), either)
import Data.Foldable as E (asum, fold, foldl', foldr')
import Data.Function as E ((&), fix)
import Data.Functor as E (($>))
import Data.Functor.Identity as E (Identity(..))
import Data.IORef as E (IORef)
import Data.Int as E (Int)
import Data.List as E
( all
, break
, drop
, dropWhile
, elem
, filter
, find
, intercalate
, intersperse
, isPrefixOf
, isSuffixOf
, iterate
, length
, mapAccumL
, mapAccumR
, maximum
, minimum
, notElem
, nub
, null
, partition
, repeat
, replicate
, sortBy
, sum
, take
, takeWhile
, transpose
, uncons
, unzip
, zip
, zip3
, zipWith
) )
import Data.List.Extra as E (nubOrd, stripSuffix)
import Data.List.NonEmpty as E (NonEmpty(..), nonEmpty) import Foreign.Storable as E ( Storable )
import Data.Map as E (Map) import GHC.Exts as E ( Constraint )
import Data.Maybe as E
(Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList) import Control.Concurrent as E ( threadDelay
import Data.Monoid as E , forkIO
( All(..) , forkOS
, Alt(..)
, Any(..)
, Endo(..)
, Monoid(..)
, Product(..)
, Sum(..)
, mconcat
) )
import Data.Ord as E (Down(..), Ordering(..), comparing)
import Data.Proxy as E (Proxy(..)) import Control.Exception as E ( evaluate
import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator) , bracket
import Data.Semigroup as E ((<>), Semigroup(..)) , assert
import Data.Sequence as E (Seq) )
import Data.Set as E (Set)
import Data.String as E (String) import Debug.Trace as E ( trace
import Data.Text as E (Text)
import Data.Tree as E (Tree(..))
import Data.Tuple as E (swap)
import Data.Typeable as E (Typeable)
import Data.Version as E (showVersion)
import Data.Void as E (Void)
import Data.Word as E (Word, Word32)
import Debug.Trace as E
( trace
, traceIO
, traceId , traceId
, traceM
, traceShow
, traceShowId , traceShowId
, traceShowM , traceShow
, traceStack , traceStack
, traceShowId
, traceIO
, traceM
, traceShowM
) )
import Foreign.ForeignPtr as E (ForeignPtr)
import Foreign.Storable as E (Storable) import Foreign.ForeignPtr as E ( ForeignPtr
import GHC.Exts as E (Constraint) )
import Prelude as E
( ($) import Data.Bifunctor as E ( bimap )
, ($!) import Data.Functor as E ( ($>) )
, (&&) import Data.Semigroup as E ( (<>)
, (++) , Semigroup(..)
, (.) )
, (<$>)
, Bounded(..) import Data.Typeable as E ( Typeable
, Double )
, Enum(..)
, Eq(..) import Control.Arrow as E ( first
, Float , second
, Floating(..) , (***)
, Foldable , (&&&)
, Fractional(..) , (>>>)
, Integer , (<<<)
, Integral(..) )
, Num(..)
, Ord(..) import Data.Version as E ( showVersion
, RealFloat(..) )
, RealFrac(..)
, Show(..) import Data.List.Extra as E ( nubOrd
, Traversable , stripSuffix
, (^) )
, and import Control.Monad.Extra as E ( whenM
, any , unlessM
, const , ifM
, curry , notM
, error , orM
, flip , andM
, foldl , anyM
, foldr , allM
, foldr1 )
, fromIntegral
, fst import Data.Tree as E ( Tree(..)
, head )
, id
, map import Control.Monad.Trans.MultiRWS as E ( -- MultiRWST (..)
, not -- , MultiRWSTNull
, or -- , MultiRWS
, otherwise -- ,
, print MonadMultiReader(..)
, putStr , MonadMultiWriter(..)
, putStrLn , MonadMultiState(..)
, realToFrac , mGet
, reverse -- , runMultiRWST
, seq -- , runMultiRWSTASW
, snd -- , runMultiRWSTW
, subtract -- , runMultiRWSTAW
, traverse -- , runMultiRWSTSW
, uncurry -- , runMultiRWSTNil
, undefined -- , runMultiRWSTNil_
, (||) -- , withMultiReader
-- , withMultiReader_
-- , withMultiReaders
-- , withMultiReaders_
-- , withMultiWriter
-- , withMultiWriterAW
-- , withMultiWriterWA
-- , withMultiWriterW
-- , withMultiWriters
-- , withMultiWritersAW
-- , withMultiWritersWA
-- , withMultiWritersW
-- , withMultiState
-- , withMultiStateAS
-- , withMultiStateSA
-- , withMultiStateA
-- , withMultiStateS
-- , withMultiState_
-- , withMultiStates
-- , withMultiStatesAS
-- , withMultiStatesSA
-- , withMultiStatesA
-- , withMultiStatesS
-- , withMultiStates_
-- , inflateReader
-- , inflateMultiReader
-- , inflateWriter
-- , inflateMultiWriter
-- , inflateState
-- , inflateMultiState
-- , mapMultiRWST
-- , mGetRawR
-- , mGetRawW
-- , mGetRawS
-- , mPutRawR
-- , mPutRawW
-- , mPutRawS
)
import Control.Monad.IO.Class as E ( MonadIO (..)
)
import Control.Monad.Trans.Class as E ( lift
)
import Control.Monad.Trans.Maybe as E ( MaybeT (..)
)
import Data.Data as E ( toConstr
) )
import System.IO as E (IO, hFlush, stdout)
import Text.Read as E (readMaybe)

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

@ -1,15 +1,21 @@
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.Brittany.Internal.PreludeUtils where module Language.Haskell.Brittany.Internal.PreludeUtils where
import Control.Applicative
import Control.DeepSeq (NFData, force)
import Control.Exception.Base (evaluate) import Prelude
import Control.Monad
import qualified Data.Strict.Maybe as Strict import qualified Data.Strict.Maybe as Strict
import Debug.Trace import Debug.Trace
import Prelude import Control.Monad
import System.IO import System.IO
import Control.DeepSeq ( NFData, force )
import Control.Exception.Base ( evaluate )
import Control.Applicative
instance Applicative Strict.Maybe where instance Applicative Strict.Maybe where
pure = Strict.Just pure = Strict.Just
Strict.Just f <*> Strict.Just x = Strict.Just (f x) Strict.Just f <*> Strict.Just x = Strict.Just (f x)
@ -24,12 +30,12 @@ instance Alternative Strict.Maybe where
x <|> Strict.Nothing = x x <|> Strict.Nothing = x
_ <|> x = x _ <|> x = x
traceFunctionWith traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)
:: 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 = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y traceStr =
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 (<$!>)

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

@ -9,18 +9,25 @@
module Language.Haskell.Brittany.Internal.Transformations.Alt where module Language.Haskell.Brittany.Internal.Transformations.Alt where
import qualified Control.Monad.Memo as Memo
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import Data.HList.ContainsType
import qualified Data.List.Extra import qualified Data.List.Extra
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude import Data.HList.ContainsType
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import qualified Control.Monad.Memo as Memo
data AltCurPos = AltCurPos data AltCurPos = AltCurPos
{ _acp_line :: Int -- chars in the current line { _acp_line :: Int -- chars in the current line
@ -28,7 +35,7 @@ data AltCurPos = AltCurPos
, _acp_indentPrep :: Int -- indentChange affecting the next Par , _acp_indentPrep :: Int -- indentChange affecting the next Par
, _acp_forceMLFlag :: AltLineModeState , _acp_forceMLFlag :: AltLineModeState
} }
deriving Show deriving (Show)
data AltLineModeState data AltLineModeState
= AltLineModeStateNone = AltLineModeStateNone
@ -42,14 +49,12 @@ altLineModeRefresh :: AltLineModeState -> AltLineModeState
altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone
altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False
altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeRefresh AltLineModeStateContradiction = altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction
AltLineModeStateContradiction
altLineModeDecay :: AltLineModeState -> AltLineModeState altLineModeDecay :: AltLineModeState -> AltLineModeState
altLineModeDecay AltLineModeStateNone = AltLineModeStateNone altLineModeDecay AltLineModeStateNone = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML False) = altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True
AltLineModeStateForceML True altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone
altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone
altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL
altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction
@ -114,13 +119,7 @@ transformAlts =
rec rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered
:: BriDocNumbered
-> Memo.MemoT
Int
[VerticalSpacing]
(MultiRWSS.MultiRWS r w (AltCurPos ': s))
BriDocNumbered
rec bdX@(brDcId, brDc) = do rec bdX@(brDcId, brDc) = do
let reWrap = (,) brDcId let reWrap = (,) brDcId
-- debugAcp :: AltCurPos <- mGet -- debugAcp :: AltCurPos <- mGet
@ -131,8 +130,10 @@ transformAlts =
-- BDWrapAnnKey annKey <$> rec bd -- BDWrapAnnKey annKey <$> rec bd
BDFEmpty{} -> processSpacingSimple bdX $> bdX BDFEmpty{} -> processSpacingSimple bdX $> bdX
BDFLit{} -> processSpacingSimple bdX $> bdX BDFLit{} -> processSpacingSimple bdX $> bdX
BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec BDFSeq list ->
BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec reWrap . BDFSeq <$> list `forM` rec
BDFCols sig list ->
reWrap . BDFCols sig <$> list `forM` rec
BDFSeparator -> processSpacingSimple bdX $> bdX BDFSeparator -> processSpacingSimple bdX $> bdX
BDFAddBaseY indent bd -> do BDFAddBaseY indent bd -> do
acp <- mGet acp <- mGet
@ -161,18 +162,22 @@ transformAlts =
BDFIndentLevelPop bd -> do BDFIndentLevelPop bd -> do
reWrap . BDFIndentLevelPop <$> rec bd reWrap . BDFIndentLevelPop <$> rec bd
BDFPar indent sameLine indented -> do BDFPar indent sameLine indented -> do
indAmount <- indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack let indAdd = case indent of
let
indAdd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> indAmount BrIndentRegular -> indAmount
BrIndentSpecial i -> i BrIndentSpecial i -> i
acp <- mGet acp <- mGet
let ind = _acp_indent acp + _acp_indentPrep acp + indAdd let ind = _acp_indent acp + _acp_indentPrep acp + indAdd
mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 } mSet $ acp
{ _acp_indent = ind
, _acp_indentPrep = 0
}
sameLine' <- rec sameLine sameLine' <- rec sameLine
mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind } mModify $ \acp' -> acp'
{ _acp_line = ind
, _acp_indent = ind
}
indented' <- rec indented indented' <- rec indented
return $ reWrap $ BDFPar indent sameLine' indented' return $ reWrap $ BDFPar indent sameLine' indented'
BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a
@ -180,16 +185,14 @@ transformAlts =
-- fail-early approach; BDEmpty does not -- fail-early approach; BDEmpty does not
-- make sense semantically for Alt[]. -- make sense semantically for Alt[].
BDFAlt alts -> do BDFAlt alts -> do
altChooser <- altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack
mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack
case altChooser of case altChooser of
AltChooserSimpleQuick -> do AltChooserSimpleQuick -> do
rec $ head alts rec $ head alts
AltChooserShallowBest -> do AltChooserShallowBest -> do
spacings <- alts `forM` getSpacing spacings <- alts `forM` getSpacing
acp <- mGet acp <- mGet
let let lineCheck LineModeInvalid = False
lineCheck LineModeInvalid = False
lineCheck (LineModeValid (VerticalSpacing _ p _)) = lineCheck (LineModeValid (VerticalSpacing _ p _)) =
case _acp_forceMLFlag acp of case _acp_forceMLFlag acp of
AltLineModeStateNone -> True AltLineModeStateNone -> True
@ -199,42 +202,36 @@ transformAlts =
-- TODO: use COMPLETE pragma instead? -- TODO: use COMPLETE pragma instead?
lineCheck _ = error "ghc exhaustive check is insufficient" lineCheck _ = error "ghc exhaustive check is insufficient"
lconf <- _conf_layout <$> mAsk lconf <- _conf_layout <$> mAsk
let let options = -- trace ("considering options:" ++ show (length alts, acp)) $
options = -- trace ("considering options:" ++ show (length alts, acp)) $
(zip spacings alts (zip spacings alts
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
(hasSpace1 lconf acp vs && lineCheck vs, bd) ( hasSpace1 lconf acp vs && lineCheck vs, bd))
)
rec rec
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
List.last alts) List.last alts)
$ Data.List.Extra.firstJust $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) ->
(\(_i :: Int, (b, x)) ->
[ -- traceShow ("choosing option " ++ show i) $ [ -- traceShow ("choosing option " ++ show i) $
x x
| b | b
] ])
) $ zip [1..] options
$ zip [1 ..] options
AltChooserBoundedSearch limit -> do AltChooserBoundedSearch limit -> do
spacings <- alts `forM` getSpacings limit spacings <- alts `forM` getSpacings limit
acp <- mGet acp <- mGet
let let lineCheck (VerticalSpacing _ p _) =
lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of case _acp_forceMLFlag acp of
AltLineModeStateNone -> True AltLineModeStateNone -> True
AltLineModeStateForceSL{} -> p == VerticalSpacingParNone AltLineModeStateForceSL{} -> p == VerticalSpacingParNone
AltLineModeStateForceML{} -> p /= VerticalSpacingParNone AltLineModeStateForceML{} -> p /= VerticalSpacingParNone
AltLineModeStateContradiction -> False AltLineModeStateContradiction -> False
lconf <- _conf_layout <$> mAsk lconf <- _conf_layout <$> mAsk
let let options = -- trace ("considering options:" ++ show (length alts, acp)) $
options = -- trace ("considering options:" ++ show (length alts, acp)) $
(zip spacings alts (zip spacings alts
<&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs)) <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))
(any (hasSpace2 lconf acp) vs && any lineCheck vs, bd) ( any (hasSpace2 lconf acp) vs
) && any lineCheck vs, bd))
let let checkedOptions :: [Maybe (Int, BriDocNumbered)] =
checkedOptions :: [Maybe (Int, BriDocNumbered)] = zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ])
zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ])
rec rec
$ fromMaybe (-- trace ("choosing last") $ $ fromMaybe (-- trace ("choosing last") $
List.last alts) List.last alts)
@ -258,9 +255,7 @@ transformAlts =
BDFForwardLineMode bd -> do BDFForwardLineMode bd -> do
acp <- mGet acp <- mGet
x <- do x <- do
mSet $ acp mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp }
{ _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp
}
rec bd rec bd
acp' <- mGet acp' <- mGet
mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp } mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
@ -269,9 +264,7 @@ transformAlts =
BDFPlain{} -> processSpacingSimple bdX $> bdX BDFPlain{} -> processSpacingSimple bdX $> bdX
BDFAnnotationPrior annKey bd -> do BDFAnnotationPrior annKey bd -> do
acp <- mGet acp <- mGet
mSet $ acp mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
{ _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp
}
bd' <- rec bd bd' <- rec bd
return $ reWrap $ BDFAnnotationPrior annKey bd' return $ reWrap $ BDFAnnotationPrior annKey bd'
BDFAnnotationRest annKey bd -> BDFAnnotationRest annKey bd ->
@ -281,13 +274,16 @@ transformAlts =
BDFMoveToKWDP annKey kw b bd -> BDFMoveToKWDP annKey kw b bd ->
reWrap . BDFMoveToKWDP annKey kw b <$> rec bd reWrap . BDFMoveToKWDP annKey kw b <$> rec bd
BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless. BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.
BDFLines (l : lr) -> do BDFLines (l:lr) -> do
ind <- _acp_indent <$> mGet ind <- _acp_indent <$> mGet
l' <- rec l l' <- rec l
lr' <- lr `forM` \x -> do lr' <- lr `forM` \x -> do
mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind } mModify $ \acp -> acp
{ _acp_line = ind
, _acp_indent = ind
}
rec x rec x
return $ reWrap $ BDFLines (l' : lr') return $ reWrap $ BDFLines (l':lr')
BDFEnsureIndent indent bd -> do BDFEnsureIndent indent bd -> do
acp <- mGet acp <- mGet
indAdd <- fixIndentationForMultiple acp indent indAdd <- fixIndentationForMultiple acp indent
@ -306,21 +302,14 @@ transformAlts =
mSet $ acp' { _acp_indent = _acp_indent acp } mSet $ acp' { _acp_indent = _acp_indent acp }
return $ case indent of return $ case indent of
BrIndentNone -> r BrIndentNone -> r
BrIndentRegular -> BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r
reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r
BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r
BDFNonBottomSpacing _ bd -> rec bd BDFNonBottomSpacing _ bd -> rec bd
BDFSetParSpacing bd -> rec bd BDFSetParSpacing bd -> rec bd
BDFForceParSpacing bd -> rec bd BDFForceParSpacing bd -> rec bd
BDFDebug s bd -> do BDFDebug s bd -> do
acp :: AltCurPos <- mGet acp :: AltCurPos <- mGet
tellDebugMess tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp
$ "transformAlts: BDFDEBUG "
++ s
++ " (node-id="
++ show brDcId
++ "): acp="
++ show acp
reWrap . BDFDebug s <$> rec bd reWrap . BDFDebug s <$> rec bd
processSpacingSimple processSpacingSimple
:: ( MonadMultiReader Config m :: ( MonadMultiReader Config m
@ -336,8 +325,7 @@ transformAlts =
mSet $ acp { _acp_line = _acp_line acp + i } mSet $ acp { _acp_line = _acp_line acp + i }
LineModeValid VerticalSpacing{} -> error "processSpacingSimple par" LineModeValid VerticalSpacing{} -> error "processSpacingSimple par"
_ -> error "ghc exhaustive check is insufficient" _ -> error "ghc exhaustive check is insufficient"
hasSpace1 hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool
:: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool
hasSpace1 _ _ LineModeInvalid = False hasSpace1 _ _ LineModeInvalid = False
hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs
hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient" hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient"
@ -345,13 +333,8 @@ transformAlts =
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _) hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _)
= line + sameLine <= confUnpack (_lconfig_cols lconf) = line + sameLine <= confUnpack (_lconfig_cols lconf)
hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _) hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _)
= line = line + sameLine <= confUnpack (_lconfig_cols lconf)
+ sameLine && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf)
<= confUnpack (_lconfig_cols lconf)
&& indent
+ indentPrep
+ par
<= confUnpack (_lconfig_cols lconf)
hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _) hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)
= line + sameLine <= confUnpack (_lconfig_cols lconf) = line + sameLine <= confUnpack (_lconfig_cols lconf)
@ -370,11 +353,10 @@ getSpacing !bridoc = rec bridoc
-- BDWrapAnnKey _annKey bd -> rec bd -- BDWrapAnnKey _annKey bd -> rec bd
BDFEmpty -> BDFEmpty ->
return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False
BDFLit t -> return $ LineModeValid $ VerticalSpacing BDFLit t ->
(Text.length t) return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False
VerticalSpacingParNone BDFSeq list ->
False sumVs <$> rec `mapM` list
BDFSeq list -> sumVs <$> rec `mapM` list
BDFCols _sig list -> sumVs <$> rec `mapM` list BDFCols _sig list -> sumVs <$> rec `mapM` list
BDFSeparator -> BDFSeparator ->
return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False
@ -383,23 +365,17 @@ getSpacing !bridoc = rec bridoc
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
{ _vs_paragraph = case _vs_paragraph vs of { _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParAlways i -> VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of
VerticalSpacingParAlways $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> BrIndentRegular -> i + ( confUnpack
i
+ (confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
) )
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
VerticalSpacingParSome $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> BrIndentRegular -> i + ( confUnpack
i
+ (confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
@ -414,13 +390,11 @@ getSpacing !bridoc = rec bridoc
-- the reason is that we really want to _keep_ it Just if it is -- the reason is that we really want to _keep_ it Just if it is
-- just so we properly communicate the is-multiline fact. -- just so we properly communicate the is-multiline fact.
-- An alternative would be setting to (Just 0). -- An alternative would be setting to (Just 0).
{ _vs_sameLine = max { _vs_sameLine = max (_vs_sameLine vs)
(_vs_sameLine vs)
(case _vs_paragraph vs of (case _vs_paragraph vs of
VerticalSpacingParNone -> 0 VerticalSpacingParNone -> 0
VerticalSpacingParSome i -> i VerticalSpacingParSome i -> i
VerticalSpacingParAlways i -> min colMax i VerticalSpacingParAlways i -> min colMax i)
)
, _vs_paragraph = VerticalSpacingParSome 0 , _vs_paragraph = VerticalSpacingParSome 0
} }
BDFBaseYPop bd -> rec bd BDFBaseYPop bd -> rec bd
@ -434,24 +408,17 @@ getSpacing !bridoc = rec bridoc
| VerticalSpacing lsp mPsp _ <- mVs | VerticalSpacing lsp mPsp _ <- mVs
, indSp <- mIndSp , indSp <- mIndSp
, lineMax <- getMaxVS $ mIndSp , lineMax <- getMaxVS $ mIndSp
, let , let pspResult = case mPsp of
pspResult = case mPsp of VerticalSpacingParSome psp -> VerticalSpacingParSome $ max psp lineMax
VerticalSpacingParSome psp ->
VerticalSpacingParSome $ max psp lineMax
VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax
VerticalSpacingParAlways psp -> VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax
VerticalSpacingParAlways $ max psp lineMax , let parFlagResult = mPsp == VerticalSpacingParNone
, let && _vs_paragraph indSp == VerticalSpacingParNone
parFlagResult =
mPsp
== VerticalSpacingParNone
&& _vs_paragraph indSp
== VerticalSpacingParNone
&& _vs_parFlag indSp && _vs_parFlag indSp
] ]
BDFPar{} -> error "BDPar with indent in getSpacing" BDFPar{} -> error "BDPar with indent in getSpacing"
BDFAlt [] -> error "empty BDAlt" BDFAlt [] -> error "empty BDAlt"
BDFAlt (alt : _) -> rec alt BDFAlt (alt:_) -> rec alt
BDFForceMultiline bd -> do BDFForceMultiline bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs >>= _vs_paragraph .> \case return $ mVs >>= _vs_paragraph .> \case
@ -473,33 +440,35 @@ getSpacing !bridoc = rec bridoc
BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd
BDFMoveToKWDP _annKey _kw _b bd -> rec bd BDFMoveToKWDP _annKey _kw _b bd -> rec bd
BDFLines [] -> BDFLines [] -> return
return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False $ LineModeValid
BDFLines ls@(_ : _) -> do $ VerticalSpacing 0 VerticalSpacingParNone False
BDFLines ls@(_:_) -> do
lSps <- rec `mapM` ls lSps <- rec `mapM` ls
let (mVs : _) = lSps -- separated into let to avoid MonadFail let (mVs:_) = lSps -- separated into let to avoid MonadFail
return return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False
$ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False
| VerticalSpacing lsp _ _ <- mVs | VerticalSpacing lsp _ _ <- mVs
, lineMax <- getMaxVS $ maxVs $ lSps , lineMax <- getMaxVS $ maxVs $ lSps
] ]
BDFEnsureIndent indent bd -> do BDFEnsureIndent indent bd -> do
mVs <- rec bd mVs <- rec bd
let let addInd = case indent of
addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> BrIndentRegular -> confUnpack
confUnpack $ _lconfig_indentAmount $ _conf_layout $ config $ _lconfig_indentAmount
$ _conf_layout
$ config
BrIndentSpecial i -> i BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp pf) -> return $ mVs <&> \(VerticalSpacing lsp psp pf) ->
VerticalSpacing (lsp + addInd) psp pf VerticalSpacing (lsp + addInd) psp pf
BDFNonBottomSpacing b bd -> do BDFNonBottomSpacing b bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <|> LineModeValid return
$ mVs
<|> LineModeValid
(VerticalSpacing (VerticalSpacing
0 0
(if b (if b then VerticalSpacingParSome 0
then VerticalSpacingParSome 0
else VerticalSpacingParAlways colMax else VerticalSpacingParAlways colMax
) )
False False
@ -509,29 +478,16 @@ getSpacing !bridoc = rec bridoc
return $ mVs <&> \vs -> vs { _vs_parFlag = True } return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDFForceParSpacing bd -> do BDFForceParSpacing bd -> do
mVs <- rec bd mVs <- rec bd
return return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ]
$ [ vs
| vs <- mVs
, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone
]
BDFDebug s bd -> do BDFDebug s bd -> do
r <- rec bd r <- rec bd
tellDebugMess tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r
$ "getSpacing: BDFDebug "
++ show s
++ " (node-id="
++ show brDcId
++ "): mVs="
++ show r
return r return r
return result return result
maxVs maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
:: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
maxVs = foldl' maxVs = foldl'
(liftM2 (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->
(\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing VerticalSpacing (max x1 y1) (case (x2, y2) of
(max x1 y1)
(case (x2, y2) of
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x (VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
@ -541,14 +497,9 @@ getSpacing !bridoc = rec bridoc
(VerticalSpacingParSome j, VerticalSpacingParAlways i) -> (VerticalSpacingParSome j, VerticalSpacingParAlways i) ->
VerticalSpacingParAlways $ max i j VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> (VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ max x y VerticalSpacingParSome $ max x y) False))
)
False
)
)
(LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False) (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False)
sumVs sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
:: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing
sumVs sps = foldl' (liftM2 go) initial sps sumVs sps = foldl' (liftM2 go) initial sps
where where
go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing
@ -557,14 +508,13 @@ getSpacing !bridoc = rec bridoc
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x (VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i + j VerticalSpacingParAlways $ i+j
(VerticalSpacingParAlways i, VerticalSpacingParSome j) -> (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->
VerticalSpacingParAlways $ i + j VerticalSpacingParAlways $ i+j
(VerticalSpacingParSome i, VerticalSpacingParAlways j) -> (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i + j VerticalSpacingParAlways $ i+j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> (VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ x + y VerticalSpacingParSome $ x + y)
)
x3 x3
singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone
singleline _ = False singleline _ = False
@ -596,23 +546,20 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- process could lead to exponential runtime behaviour. -- process could lead to exponential runtime behaviour.
-- TODO: 3 is arbitrary. -- TODO: 3 is arbitrary.
preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing] preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]
preFilterLimit = take (3 * limit) preFilterLimit = take (3*limit)
memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v
memoWithKey k v = Memo.memo (const v) k memoWithKey k v = Memo.memo (const v) k
rec rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
:: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]
rec (brDcId, brdc) = memoWithKey brDcId $ do rec (brDcId, brdc) = memoWithKey brDcId $ do
config <- mAsk config <- mAsk
let colMax = config & _conf_layout & _lconfig_cols & confUnpack let colMax = config & _conf_layout & _lconfig_cols & confUnpack
let let hasOkColCount (VerticalSpacing lsp psp _) =
hasOkColCount (VerticalSpacing lsp psp _) =
lsp <= colMax && case psp of lsp <= colMax && case psp of
VerticalSpacingParNone -> True VerticalSpacingParNone -> True
VerticalSpacingParSome i -> i <= colMax VerticalSpacingParSome i -> i <= colMax
VerticalSpacingParAlways{} -> True VerticalSpacingParAlways{} -> True
let let specialCompare vs1 vs2 =
specialCompare vs1 vs2 = if ( (_vs_sameLine vs1 == _vs_sameLine vs2)
if ((_vs_sameLine vs1 == _vs_sameLine vs2)
&& (_vs_parFlag vs1 == _vs_parFlag vs2) && (_vs_parFlag vs1 == _vs_parFlag vs2)
) )
then case (_vs_paragraph vs1, _vs_paragraph vs2) of then case (_vs_paragraph vs1, _vs_paragraph vs2) of
@ -620,9 +567,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
if i1 < i2 then Smaller else Bigger if i1 < i2 then Smaller else Bigger
(p1, p2) -> if p1 == p2 then Smaller else Unequal (p1, p2) -> if p1 == p2 then Smaller else Unequal
else Unequal else Unequal
let let allowHangingQuasiQuotes =
allowHangingQuasiQuotes = config
config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack & _conf_layout
& _lconfig_allowHangingQuasiQuotes
& confUnpack
let -- this is like List.nub, with one difference: if two elements let -- this is like List.nub, with one difference: if two elements
-- are unequal only in _vs_paragraph, with both ParAlways, we -- are unequal only in _vs_paragraph, with both ParAlways, we
-- treat them like equals and replace the first occurence with the -- treat them like equals and replace the first occurence with the
@ -642,8 +591,7 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- applied whenever in a parent the combination of spacings from -- applied whenever in a parent the combination of spacings from
-- its children might cause excess of the upper bound. -- its children might cause excess of the upper bound.
filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing] filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing]
filterAndLimit = filterAndLimit = take limit
take limit
-- prune so we always consider a constant -- prune so we always consider a constant
-- amount of spacings per node of the BriDoc. -- amount of spacings per node of the BriDoc.
. specialNub . specialNub
@ -675,11 +623,12 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
. preFilterLimit . preFilterLimit
result <- case brdc of result <- case brdc of
-- BDWrapAnnKey _annKey bd -> rec bd -- BDWrapAnnKey _annKey bd -> rec bd
BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFEmpty ->
return $ [VerticalSpacing 0 VerticalSpacingParNone False]
BDFLit t -> BDFLit t ->
return return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
$ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] BDFSeq list ->
BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
BDFCols _sig list -> BDFCols _sig list ->
fmap sumVs . mapM filterAndLimit <$> rec `mapM` list fmap sumVs . mapM filterAndLimit <$> rec `mapM` list
BDFSeparator -> BDFSeparator ->
@ -689,23 +638,17 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ mVs <&> \vs -> vs return $ mVs <&> \vs -> vs
{ _vs_paragraph = case _vs_paragraph vs of { _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParAlways i -> VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of
VerticalSpacingParAlways $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> BrIndentRegular -> i + ( confUnpack
i
+ (confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
) )
BrIndentSpecial j -> i + j BrIndentSpecial j -> i + j
VerticalSpacingParSome i -> VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of
VerticalSpacingParSome $ case indent of
BrIndentNone -> i BrIndentNone -> i
BrIndentRegular -> BrIndentRegular -> i + ( confUnpack
i
+ (confUnpack
$ _lconfig_indentAmount $ _lconfig_indentAmount
$ _conf_layout $ _conf_layout
$ config $ config
@ -720,13 +663,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- the reason is that we really want to _keep_ it Just if it is -- the reason is that we really want to _keep_ it Just if it is
-- just so we properly communicate the is-multiline fact. -- just so we properly communicate the is-multiline fact.
-- An alternative would be setting to (Just 0). -- An alternative would be setting to (Just 0).
{ _vs_sameLine = max { _vs_sameLine = max (_vs_sameLine vs)
(_vs_sameLine vs)
(case _vs_paragraph vs of (case _vs_paragraph vs of
VerticalSpacingParNone -> 0 VerticalSpacingParNone -> 0
VerticalSpacingParSome i -> i VerticalSpacingParSome i -> i
VerticalSpacingParAlways i -> min colMax i VerticalSpacingParAlways i -> min colMax i)
)
, _vs_paragraph = case _vs_paragraph vs of , _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParSome i -> VerticalSpacingParSome i VerticalSpacingParSome i -> VerticalSpacingParSome i
@ -738,8 +679,13 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BDFPar BrIndentNone sameLine indented -> do BDFPar BrIndentNone sameLine indented -> do
mVss <- filterAndLimit <$> rec sameLine mVss <- filterAndLimit <$> rec sameLine
indSps <- filterAndLimit <$> rec indented indSps <- filterAndLimit <$> rec indented
let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ] let mVsIndSp = take limit
return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) -> $ [ (x,y)
| x<-mVss
, y<-indSps
]
return $ mVsIndSp <&>
\(VerticalSpacing lsp mPsp _, indSp) ->
VerticalSpacing VerticalSpacing
lsp lsp
(case mPsp of (case mPsp of
@ -747,12 +693,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO
VerticalSpacingParNone -> spMakePar indSp VerticalSpacingParNone -> spMakePar indSp
VerticalSpacingParAlways psp -> VerticalSpacingParAlways psp ->
VerticalSpacingParAlways $ max psp $ getMaxVS indSp VerticalSpacingParAlways $ max psp $ getMaxVS indSp)
) ( mPsp == VerticalSpacingParNone
(mPsp && _vs_paragraph indSp == VerticalSpacingParNone
== VerticalSpacingParNone
&& _vs_paragraph indSp
== VerticalSpacingParNone
&& _vs_parFlag indSp && _vs_parFlag indSp
) )
@ -764,21 +707,23 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ filterAndLimit =<< r return $ filterAndLimit =<< r
BDFForceMultiline bd -> do BDFForceMultiline bd -> do
mVs <- filterAndLimit <$> rec bd mVs <- filterAndLimit <$> rec bd
return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs
BDFForceSingleline bd -> do BDFForceSingleline bd -> do
mVs <- filterAndLimit <$> rec bd mVs <- filterAndLimit <$> rec bd
return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs
BDFForwardLineMode bd -> rec bd BDFForwardLineMode bd -> rec bd
BDFExternal _ _ _ txt | [t] <- Text.lines txt -> BDFExternal _ _ _ txt | [t] <- Text.lines txt ->
return return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]
$ [VerticalSpacing (Text.length t) VerticalSpacingParNone False] BDFExternal{} ->
BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout return $ [] -- yes, we just assume that we cannot properly layout
-- this. -- this.
BDFPlain t -> return BDFPlain t -> return
[ case Text.lines t of [ case Text.lines t of
[] -> VerticalSpacing 0 VerticalSpacingParNone False [] -> VerticalSpacing 0 VerticalSpacingParNone False
[t1] -> [t1 ] -> VerticalSpacing
VerticalSpacing (Text.length t1) VerticalSpacingParNone False (Text.length t1)
VerticalSpacingParNone
False
(t1 : _) -> VerticalSpacing (t1 : _) -> VerticalSpacing
(Text.length t1) (Text.length t1)
(VerticalSpacingParAlways 0) (VerticalSpacingParAlways 0)
@ -789,22 +734,22 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BDFAnnotationKW _annKey _kw bd -> rec bd BDFAnnotationKW _annKey _kw bd -> rec bd
BDFAnnotationRest _annKey bd -> rec bd BDFAnnotationRest _annKey bd -> rec bd
BDFMoveToKWDP _annKey _kw _b bd -> rec bd BDFMoveToKWDP _annKey _kw _b bd -> rec bd
BDFLines [] -> BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]
return $ [VerticalSpacing 0 VerticalSpacingParNone False] BDFLines ls@(_:_) -> do
BDFLines ls@(_ : _) -> do
-- we simply assume that lines is only used "properly", i.e. in -- we simply assume that lines is only used "properly", i.e. in
-- such a way that the first line can be treated "as a part of the -- such a way that the first line can be treated "as a part of the
-- paragraph". That most importantly means that Lines should never -- paragraph". That most importantly means that Lines should never
-- be inserted anywhere but at the start of the line. A -- be inserted anywhere but at the start of the line. A
-- counterexample would be anything like Seq[Lit "foo", Lines]. -- counterexample would be anything like Seq[Lit "foo", Lines].
lSpss <- map filterAndLimit <$> rec `mapM` ls lSpss <- map filterAndLimit <$> rec `mapM` ls
let let worbled = fmap reverse
worbled = fmap reverse $ sequence $ reverse $ lSpss $ sequence
sumF lSps@(lSp1 : _) = $ reverse
VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False $ lSpss
sumF [] = sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1)
error (spMakePar $ maxVs lSps)
$ "should not happen. if my logic does not fail" False
sumF [] = error $ "should not happen. if my logic does not fail"
++ "me, this follows from not (null ls)." ++ "me, this follows from not (null ls)."
return $ sumF <$> worbled return $ sumF <$> worbled
-- lSpss@(mVs:_) <- rec `mapM` ls -- lSpss@(mVs:_) <- rec `mapM` ls
@ -820,11 +765,12 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps -- VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps
BDFEnsureIndent indent bd -> do BDFEnsureIndent indent bd -> do
mVs <- rec bd mVs <- rec bd
let let addInd = case indent of
addInd = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> BrIndentRegular -> confUnpack
confUnpack $ _lconfig_indentAmount $ _conf_layout $ config $ _lconfig_indentAmount
$ _conf_layout
$ config
BrIndentSpecial i -> i BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> return $ mVs <&> \(VerticalSpacing lsp psp parFlag) ->
VerticalSpacing (lsp + addInd) psp parFlag VerticalSpacing (lsp + addInd) psp parFlag
@ -835,11 +781,9 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
-- problem but breaks certain other cases. -- problem but breaks certain other cases.
mVs <- rec bd mVs <- rec bd
return $ if null mVs return $ if null mVs
then then [VerticalSpacing
[ VerticalSpacing
0 0
(if b (if b then VerticalSpacingParSome 0
then VerticalSpacingParSome 0
else VerticalSpacingParAlways colMax else VerticalSpacingParAlways colMax
) )
False False
@ -888,25 +832,16 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
return $ mVs <&> \vs -> vs { _vs_parFlag = True } return $ mVs <&> \vs -> vs { _vs_parFlag = True }
BDFForceParSpacing bd -> do BDFForceParSpacing bd -> do
mVs <- preFilterLimit <$> rec bd mVs <- preFilterLimit <$> rec bd
return return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ]
$ [ vs
| vs <- mVs
, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone
]
BDFDebug s bd -> do BDFDebug s bd -> do
r <- rec bd r <- rec bd
tellDebugMess tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r)
$ "getSpacings: BDFDebug "
++ show s
++ " (node-id="
++ show brDcId
++ "): vs="
++ show (take 9 r)
return r return r
return result return result
maxVs :: [VerticalSpacing] -> VerticalSpacing maxVs :: [VerticalSpacing] -> VerticalSpacing
maxVs = foldl' maxVs = foldl'
(\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->
VerticalSpacing
(max x1 y1) (max x1 y1)
(case (x2, y2) of (case (x2, y2) of
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
@ -918,10 +853,8 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
(VerticalSpacingParSome i, VerticalSpacingParAlways j) -> (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ max i j VerticalSpacingParAlways $ max i j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> (VerticalSpacingParSome x, VerticalSpacingParSome y) ->
VerticalSpacingParSome $ max x y VerticalSpacingParSome $ max x y)
) False)
False
)
(VerticalSpacing 0 VerticalSpacingParNone False) (VerticalSpacing 0 VerticalSpacingParNone False)
sumVs :: [VerticalSpacing] -> VerticalSpacing sumVs :: [VerticalSpacing] -> VerticalSpacing
sumVs sps = foldl' go initial sps sumVs sps = foldl' go initial sps
@ -932,14 +865,12 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
(x, VerticalSpacingParNone) -> x (x, VerticalSpacingParNone) -> x
(VerticalSpacingParNone, x) -> x (VerticalSpacingParNone, x) -> x
(VerticalSpacingParAlways i, VerticalSpacingParAlways j) -> (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i + j VerticalSpacingParAlways $ i+j
(VerticalSpacingParAlways i, VerticalSpacingParSome j) -> (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->
VerticalSpacingParAlways $ i + j VerticalSpacingParAlways $ i+j
(VerticalSpacingParSome i, VerticalSpacingParAlways j) -> (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->
VerticalSpacingParAlways $ i + j VerticalSpacingParAlways $ i+j
(VerticalSpacingParSome x, VerticalSpacingParSome y) -> (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y)
VerticalSpacingParSome $ x + y
)
x3 x3
singleline x = _vs_paragraph x == VerticalSpacingParNone singleline x = _vs_paragraph x == VerticalSpacingParNone
isPar x = _vs_parFlag x isPar x = _vs_parFlag x
@ -962,8 +893,7 @@ fixIndentationForMultiple
:: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int
fixIndentationForMultiple acp indent = do fixIndentationForMultiple acp indent = do
indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack
let let indAddRaw = case indent of
indAddRaw = case indent of
BrIndentNone -> 0 BrIndentNone -> 0
BrIndentRegular -> indAmount BrIndentRegular -> indAmount
BrIndentSpecial i -> i BrIndentSpecial i -> i
@ -973,8 +903,7 @@ fixIndentationForMultiple acp indent = do
indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack
pure $ if indPolicy == IndentPolicyMultiple pure $ if indPolicy == IndentPolicyMultiple
then then
let let indAddMultiple1 =
indAddMultiple1 =
indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount) indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount)
indAddMultiple2 = if indAddMultiple1 <= 0 indAddMultiple2 = if indAddMultiple1 <= 0
then indAddMultiple1 + indAmount then indAddMultiple1 + indAmount

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

@ -3,135 +3,109 @@
module Language.Haskell.Brittany.Internal.Transformations.Columns where module Language.Haskell.Brittany.Internal.Transformations.Columns where
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
transformSimplifyColumns :: BriDoc -> BriDoc transformSimplifyColumns :: BriDoc -> BriDoc
transformSimplifyColumns = Uniplate.rewrite $ \case transformSimplifyColumns = Uniplate.rewrite $ \case
-- BDWrapAnnKey annKey bd -> -- BDWrapAnnKey annKey bd ->
-- BDWrapAnnKey annKey $ transformSimplify bd -- BDWrapAnnKey annKey $ transformSimplify bd
BDEmpty -> Nothing BDEmpty -> Nothing
BDLit{} -> Nothing BDLit{} -> Nothing
BDSeq list BDSeq list | any (\case BDSeq{} -> True
| any
(\case
BDSeq{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False _ -> False) list -> Just $ BDSeq $ list >>= \case
)
list
-> Just $ BDSeq $ list >>= \case
BDEmpty -> [] BDEmpty -> []
BDSeq l -> l BDSeq l -> l
x -> [x] x -> [x]
BDSeq (BDCols sig1 cols1@(_ : _) : rest) BDSeq (BDCols sig1 cols1@(_:_):rest)
| all | all (\case BDSeparator -> True; _ -> False) rest ->
(\case Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)])
BDSeparator -> True BDLines lines | any (\case BDLines{} -> True
_ -> False
)
rest
-> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)])
BDLines lines
| any
(\case
BDLines{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False _ -> False) lines ->
) Just $ BDLines $ filter isNotEmpty $ lines >>= \case
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 Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationKW annKey1 kw (BDSeq list) -> BDAnnotationKW annKey1 kw (BDSeq list) ->
Just Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) -> BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]
$ 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 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest) | sig1==sig2 ->
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, sig1 == sig2 -> Just | BDCols sig1 _ <- List.last lines1
$ BDAddBaseY ind (BDLines $ lines1 ++ [col2]) , sig1==sig2 ->
BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : rest)) Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])
| BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):rest))
$ BDPar ind (BDLines $ lines1 ++ [col2]) (BDLines rest) | BDCols sig1 _ <- List.last lines1
, 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 BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols
| BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2 , sig1==sig2 ->
-> Just Just $ BDLines
$ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2] [ BDCols sig1 (List.init cols ++ [line])
BDCols sig1 cols , BDCols sig2 cols2
| BDPar ind line (BDLines lines) <- List.last cols ]
BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols
, BDCols sig2 cols2 <- List.last lines , BDCols sig2 cols2 <- List.last lines
, sig1 == sig2 , sig1==sig2 ->
-> Just $ BDLines Just $ BDLines
[ BDCols sig1 [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)]
$ List.init cols
++ [BDPar ind line (BDLines $ List.init lines)]
, BDCols sig2 cols2 , BDCols sig2 cols2
] ]
BDLines [x] -> Just $ x BDLines [x] -> Just $ x

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

@ -3,19 +3,24 @@
module Language.Haskell.Brittany.Internal.Transformations.Floating where module Language.Haskell.Brittany.Internal.Transformations.Floating where
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
-- 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) = mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j)
BrIndentSpecial (max i j)
mergeIndents _ _ = error "mergeIndents" mergeIndents _ _ = error "mergeIndents"
@ -31,12 +36,12 @@ transformSimplifyFloating = stepBO .> stepFull
-- 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) ->
@ -47,20 +52,11 @@ transformSimplifyFloating = stepBO .> stepFull
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 Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
BDAnnotationRest annKey1 (BDAddBaseY indent x) -> BDAnnotationRest annKey1 (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x
BDAnnotationRest annKey1 (BDDebug s x) -> BDAnnotationRest annKey1 (BDDebug s x) ->
@ -71,57 +67,49 @@ transformSimplifyFloating = stepBO .> stepFull
BDAnnotationKW annKey1 kw (BDPar ind line indented) -> BDAnnotationKW annKey1 kw (BDPar ind line indented) ->
Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented
BDAnnotationKW annKey1 kw (BDSeq list) -> BDAnnotationKW annKey1 kw (BDSeq list) ->
Just Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
$ BDSeq
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDLines list) -> BDAnnotationKW annKey1 kw (BDLines list) ->
Just Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]
$ BDLines
$ List.init list
++ [BDAnnotationKW annKey1 kw $ List.last list]
BDAnnotationKW annKey1 kw (BDCols sig cols) -> BDAnnotationKW annKey1 kw (BDCols sig cols) ->
Just Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]
$ BDCols sig
$ List.init cols
++ [BDAnnotationKW annKey1 kw $ List.last cols]
BDAnnotationKW annKey1 kw (BDAddBaseY indent x) -> BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->
Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x
BDAnnotationKW annKey1 kw (BDDebug s x) -> BDAnnotationKW annKey1 kw (BDDebug s x) ->
Just $ BDDebug s $ BDAnnotationKW annKey1 kw x Just $ BDDebug s $ BDAnnotationKW annKey1 kw x
_ -> Nothing _ -> Nothing
descendBYPush = transformDownMay $ \case descendBYPush = transformDownMay $ \case
BDBaseYPushCur (BDCols sig cols@(_ : _)) -> BDBaseYPushCur (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols) Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)
BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x) BDBaseYPushCur (BDDebug s x) ->
Just $ BDDebug s (BDBaseYPushCur x)
_ -> Nothing _ -> Nothing
descendBYPop = transformDownMay $ \case descendBYPop = transformDownMay $ \case
BDBaseYPop (BDCols sig cols@(_ : _)) -> BDBaseYPop (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)]) Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])
BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x) BDBaseYPop (BDDebug s x) ->
Just $ BDDebug s (BDBaseYPop x)
_ -> Nothing _ -> Nothing
descendILPush = transformDownMay $ \case descendILPush = transformDownMay $ \case
BDIndentLevelPushCur (BDCols sig cols@(_ : _)) -> Just BDIndentLevelPushCur (BDCols sig cols@(_:_)) ->
$ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols) Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)
BDIndentLevelPushCur (BDDebug s x) -> BDIndentLevelPushCur (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPushCur x) Just $ BDDebug s (BDIndentLevelPushCur x)
_ -> Nothing _ -> Nothing
descendILPop = transformDownMay $ \case descendILPop = transformDownMay $ \case
BDIndentLevelPop (BDCols sig cols@(_ : _)) -> BDIndentLevelPop (BDCols sig cols@(_:_)) ->
Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)]) Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])
BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x) BDIndentLevelPop (BDDebug s x) ->
Just $ BDDebug s (BDIndentLevelPop x)
_ -> Nothing _ -> Nothing
descendAddB = transformDownMay $ \case descendAddB = transformDownMay $ \case
BDAddBaseY BrIndentNone x -> Just x BDAddBaseY BrIndentNone x ->
Just x
-- AddIndent floats into Lines. -- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) -> BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column -- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) -> BDAddBaseY indent (BDCols sig cols) ->
Just Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
$ BDCols sig
$ List.init cols
++ [BDAddBaseY indent $ List.last cols]
-- merge AddIndent and Par -- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) -> BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented Just $ BDPar (mergeIndents ind1 ind2) line indented
@ -133,11 +121,14 @@ transformSimplifyFloating = stepBO .> stepFull
Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x) Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)
BDAddBaseY ind (BDSeq list) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
BDAddBaseY _ lit@BDLit{} -> Just $ lit BDAddBaseY _ lit@BDLit{} ->
Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) -> BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x) Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) BDAddBaseY ind (BDBaseYPop x) ->
BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x) Just $ BDBaseYPop (BDAddBaseY ind x)
BDAddBaseY ind (BDDebug s x) ->
Just $ BDDebug s (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPop x) -> BDAddBaseY ind (BDIndentLevelPop x) ->
Just $ BDIndentLevelPop (BDAddBaseY ind x) Just $ BDIndentLevelPop (BDAddBaseY ind x)
BDAddBaseY ind (BDIndentLevelPushCur x) -> BDAddBaseY ind (BDIndentLevelPushCur x) ->
@ -161,34 +152,34 @@ transformSimplifyFloating = stepBO .> stepFull
x -> x x -> x
stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $ stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $
Uniplate.rewrite $ \case Uniplate.rewrite $ \case
BDAddBaseY BrIndentNone x -> Just $ x BDAddBaseY BrIndentNone x ->
Just $ x
-- AddIndent floats into Lines. -- AddIndent floats into Lines.
BDAddBaseY indent (BDLines lines) -> BDAddBaseY indent (BDLines lines) ->
Just $ BDLines $ BDAddBaseY indent <$> lines Just $ BDLines $ BDAddBaseY indent <$> lines
-- AddIndent floats into last column -- AddIndent floats into last column
BDAddBaseY indent (BDCols sig cols) -> BDAddBaseY indent (BDCols sig cols) ->
Just Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]
$ BDCols sig
$ List.init cols
++ [BDAddBaseY indent $ List.last cols]
BDAddBaseY ind (BDSeq list) -> BDAddBaseY ind (BDSeq list) ->
Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)] Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]
-- merge AddIndent and Par -- merge AddIndent and Par
BDAddBaseY ind1 (BDPar ind2 line indented) -> BDAddBaseY ind1 (BDPar ind2 line indented) ->
Just $ BDPar (mergeIndents ind1 ind2) line indented Just $ BDPar (mergeIndents ind1 ind2) line indented
BDAddBaseY _ lit@BDLit{} -> Just $ lit BDAddBaseY _ lit@BDLit{} ->
Just $ lit
BDAddBaseY ind (BDBaseYPushCur x) -> BDAddBaseY ind (BDBaseYPushCur x) ->
Just $ BDBaseYPushCur (BDAddBaseY ind x) Just $ BDBaseYPushCur (BDAddBaseY ind x)
BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x) BDAddBaseY ind (BDBaseYPop x) ->
Just $ BDBaseYPop (BDAddBaseY ind x)
-- 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)
-- EnsureIndent float-in -- EnsureIndent float-in
-- BDEnsureIndent indent (BDCols sig (col:colr)) -> -- BDEnsureIndent indent (BDCols sig (col:colr)) ->
-- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr)) -- Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))
@ -200,18 +191,9 @@ transformSimplifyFloating = stepBO .> stepFull
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 Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
$ BDSeq
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDLines list) -> BDAnnotationRest annKey1 (BDLines list) ->
Just Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]
$ BDLines
$ List.init list
++ [BDAnnotationRest annKey1 $ List.last list]
BDAnnotationRest annKey1 (BDCols sig cols) -> BDAnnotationRest annKey1 (BDCols sig cols) ->
Just Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]
$ BDCols sig
$ List.init cols
++ [BDAnnotationRest annKey1 $ List.last cols]
_ -> Nothing _ -> Nothing

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

@ -3,11 +3,17 @@
module Language.Haskell.Brittany.Internal.Transformations.Indent where module Language.Haskell.Brittany.Internal.Transformations.Indent where
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
-- prepare layouting by translating BDPar's, replacing them with Indents and -- prepare layouting by translating BDPar's, replacing them with Indents and
-- floating those in. This gives a more clear picture of what exactly is -- floating those in. This gives a more clear picture of what exactly is
-- affected by what amount of indentation. -- affected by what amount of indentation.
@ -25,15 +31,13 @@ transformSimplifyIndent = Uniplate.rewrite $ \case
-- [ BDAddBaseY ind x -- [ BDAddBaseY ind x
-- , BDEnsureIndent ind indented -- , BDEnsureIndent ind indented
-- ] -- ]
BDLines lines BDLines lines | any ( \case
| any
(\case
BDLines{} -> True BDLines{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False _ -> False
) )
lines lines ->
-> Just $ BDLines $ filter isNotEmpty $ lines >>= \case Just $ BDLines $ filter isNotEmpty $ lines >>= \case
BDLines l -> l BDLines l -> l
x -> [x] x -> [x]
BDLines [l] -> Just l BDLines [l] -> Just l

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

@ -3,9 +3,14 @@
module Language.Haskell.Brittany.Internal.Transformations.Par where module Language.Haskell.Brittany.Internal.Transformations.Par where
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import Language.Haskell.Brittany.Internal.Types
transformSimplifyPar :: BriDoc -> BriDoc transformSimplifyPar :: BriDoc -> BriDoc
transformSimplifyPar = transformUp $ \case transformSimplifyPar = transformUp $ \case
@ -19,15 +24,12 @@ 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 BDLines lines | any ( \case
| any
(\case
BDLines{} -> True BDLines{} -> True
BDEmpty{} -> True BDEmpty{} -> True
_ -> False _ -> False
) )
lines lines -> case go lines of
-> case go lines of
[] -> BDEmpty [] -> BDEmpty
[x] -> x [x] -> x
xs -> BDLines xs xs -> BDLines xs

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

@ -12,41 +12,46 @@
module Language.Haskell.Brittany.Internal.Types where module Language.Haskell.Brittany.Internal.Types where
import Language.Haskell.Brittany.Internal.Prelude
import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
import qualified Data.Data import qualified Data.Data
import Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Kind as Kind
import qualified Data.Strict.Maybe as Strict import qualified Data.Strict.Maybe as Strict
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import Language.Haskell.GHC.ExactPrint (AnnKey)
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Types (Anns)
import qualified Safe import qualified Safe
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Data.Text.Lazy.Builder as Text.Builder
import GHC ( Located, GenLocated, AnnKeywordId, SrcSpan )
import Language.Haskell.GHC.ExactPrint ( AnnKey )
import Language.Haskell.GHC.ExactPrint.Types ( Anns )
import Language.Haskell.Brittany.Internal.Config.Types
import Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Kind as Kind
data PerItemConfig = PerItemConfig data PerItemConfig = PerItemConfig
{ _icd_perBinding :: Map String (CConfig Maybe) { _icd_perBinding :: Map String (CConfig Maybe)
, _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe) , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe)
} }
deriving Data.Data.Data deriving Data.Data.Data
type PPM type PPM = MultiRWSS.MultiRWS
= MultiRWSS.MultiRWS '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]
'[ Map ExactPrint.AnnKey ExactPrint.Anns '[Text.Builder.Builder, [BrittanyError], Seq String]
, PerItemConfig
, Config
, ExactPrint.Anns
]
'[Text.Builder.Builder , [BrittanyError] , Seq String]
'[] '[]
type PPMLocal type PPMLocal = MultiRWSS.MultiRWS
= MultiRWSS.MultiRWS '[Config, ExactPrint.Anns]
'[Config , ExactPrint.Anns] '[Text.Builder.Builder, [BrittanyError], Seq String]
'[Text.Builder.Builder , [BrittanyError] , Seq String]
'[] '[]
newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String) newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)
@ -110,20 +115,13 @@ lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels
instance Show LayoutState where instance Show LayoutState where
show state = show state =
"LayoutState" "LayoutState"
++ "{baseYs=" ++ "{baseYs=" ++ show (_lstate_baseYs state)
++ show (_lstate_baseYs state) ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)
++ ",curYOrAddNewline=" ++ ",indLevels=" ++ show (_lstate_indLevels state)
++ show (_lstate_curYOrAddNewline state) ++ ",indLevelLinger=" ++ show (_lstate_indLevelLinger state)
++ ",indLevels=" ++ ",commentCol=" ++ show (_lstate_commentCol state)
++ show (_lstate_indLevels state) ++ ",addSepSpace=" ++ show (_lstate_addSepSpace state)
++ ",indLevelLinger=" ++ ",commentNewlines=" ++ show (_lstate_commentNewlines state)
++ show (_lstate_indLevelLinger state)
++ ",commentCol="
++ show (_lstate_commentCol state)
++ ",addSepSpace="
++ show (_lstate_addSepSpace state)
++ ",commentNewlines="
++ show (_lstate_commentNewlines state)
++ "}" ++ "}"
-- data NewLineState = NewLineStateInit -- initial state. we do not know if in a -- data NewLineState = NewLineStateInit -- initial state. we do not know if in a
@ -225,14 +223,12 @@ data BrIndent = BrIndentNone
| BrIndentSpecial Int | BrIndentSpecial Int
deriving (Eq, Ord, Data.Data.Data, Show) deriving (Eq, Ord, Data.Data.Data, Show)
type ToBriDocM type ToBriDocM = MultiRWSS.MultiRWS
= MultiRWSS.MultiRWS '[Config, Anns] -- reader
'[Config , Anns] -- reader '[[BrittanyError], Seq String] -- writer
'[[BrittanyError] , Seq String] -- writer
'[NodeAllocIndex] -- state '[NodeAllocIndex] -- state
type ToBriDoc (sym :: Kind.Type -> Kind.Type) type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered
= Located (sym GhcPs) -> ToBriDocM BriDocNumbered
type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered type ToBriDoc' sym = Located sym -> ToBriDocM BriDocNumbered
type ToBriDocC sym c = Located sym -> ToBriDocM c type ToBriDocC sym c = Located sym -> ToBriDocM c
@ -344,17 +340,17 @@ type BriDocNumbered = (Int, BriDocFInt)
instance Uniplate.Uniplate BriDoc where instance Uniplate.Uniplate BriDoc where
uniplate x@BDEmpty{} = plate x uniplate x@BDEmpty{} = plate x
uniplate x@BDLit{} = plate x uniplate x@BDLit{} = plate x
uniplate (BDSeq list) = plate BDSeq ||* list uniplate (BDSeq list ) = plate BDSeq ||* list
uniplate (BDCols sig list) = plate BDCols |- sig ||* list uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts) = plate BDAlt ||* alts uniplate (BDAlt alts ) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd) = plate BDForwardLineMode |* bd uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x uniplate x@BDExternal{} = plate x
uniplate x@BDPlain{} = plate x uniplate x@BDPlain{} = plate x
uniplate (BDAnnotationPrior annKey bd) = uniplate (BDAnnotationPrior annKey bd) =
@ -365,14 +361,14 @@ instance Uniplate.Uniplate BriDoc where
plate BDAnnotationRest |- annKey |* bd plate BDAnnotationRest |- annKey |* bd
uniplate (BDMoveToKWDP annKey kw b bd) = uniplate (BDMoveToKWDP annKey kw b bd) =
plate BDMoveToKWDP |- annKey |- kw |- b |* bd plate BDMoveToKWDP |- annKey |- kw |- b |* bd
uniplate (BDLines lines) = plate BDLines ||* lines uniplate (BDLines lines ) = plate BDLines ||* lines
uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd
uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd
uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd
uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd
uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd
uniplate (BDDebug s bd) = plate BDDebug |- s |* bd uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd
newtype NodeAllocIndex = NodeAllocIndex Int newtype NodeAllocIndex = NodeAllocIndex Int
@ -425,8 +421,7 @@ briDocSeqSpine = \case
BDBaseYPop bd -> briDocSeqSpine bd BDBaseYPop bd -> briDocSeqSpine bd
BDIndentLevelPushCur bd -> briDocSeqSpine bd BDIndentLevelPushCur bd -> briDocSeqSpine bd
BDIndentLevelPop bd -> briDocSeqSpine bd BDIndentLevelPop bd -> briDocSeqSpine bd
BDPar _ind line indented -> BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
briDocSeqSpine line `seq` briDocSeqSpine indented
BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts BDAlt alts -> foldl' (\() -> briDocSeqSpine) () alts
BDForwardLineMode bd -> briDocSeqSpine bd BDForwardLineMode bd -> briDocSeqSpine bd
BDExternal{} -> () BDExternal{} -> ()
@ -461,7 +456,8 @@ data VerticalSpacingPar
-- product like (Normal|Always, None|Some Int). -- product like (Normal|Always, None|Some Int).
deriving (Eq, Show) deriving (Eq, Show)
data VerticalSpacing = VerticalSpacing data VerticalSpacing
= VerticalSpacing
{ _vs_sameLine :: !Int { _vs_sameLine :: !Int
, _vs_paragraph :: !VerticalSpacingPar , _vs_paragraph :: !VerticalSpacingPar
, _vs_parFlag :: !Bool , _vs_parFlag :: !Bool
@ -471,9 +467,7 @@ data VerticalSpacing = VerticalSpacing
newtype LineModeValidity a = LineModeValidity (Strict.Maybe a) newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)
deriving (Functor, Applicative, Monad, Show, Alternative) deriving (Functor, Applicative, Monad, Show, Alternative)
pattern LineModeValid :: forall t . t -> LineModeValidity t pattern LineModeValid :: forall t. t -> LineModeValidity t
pattern LineModeValid x = pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t
LineModeValidity (Strict.Just x) :: LineModeValidity t pattern LineModeInvalid :: forall t. LineModeValidity t
pattern LineModeInvalid :: forall t . LineModeValidity t pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t
pattern LineModeInvalid =
LineModeValidity Strict.Nothing :: LineModeValidity t

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

@ -7,29 +7,40 @@
module Language.Haskell.Brittany.Internal.Utils where module Language.Haskell.Brittany.Internal.Utils where
import qualified Data.ByteString as B
import qualified Data.Coerce
import Data.Data
import Data.Generics.Aliases
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import DataTreePrint
import qualified GHC.Data.FastString as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.Hs.Extension as HsExtension
import qualified GHC.OldList as List
import GHC.Types.Name.Occurrence as OccName (occNameString)
import qualified GHC.Types.SrcLoc as GHC
import qualified GHC.Utils.Outputable as GHC
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types import qualified Data.Coerce
import qualified Data.Semigroup as Semigroup
import qualified Data.Sequence as Seq
import qualified GHC.OldList as List
import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils
import Data.Data
import Data.Generics.Aliases
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import qualified GHC.Utils.Outputable as GHC
import qualified GHC.Driver.Session as GHC
import qualified GHC.Data.FastString as GHC
import qualified GHC.Types.SrcLoc as GHC
import GHC.Types.Name.Occurrence as OccName ( occNameString )
import qualified Data.ByteString as B
import DataTreePrint
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate
import qualified GHC.Hs.Extension as HsExtension
parDoc :: String -> PP.Doc parDoc :: String -> PP.Doc
parDoc = PP.fsep . fmap PP.text . List.words parDoc = PP.fsep . fmap PP.text . List.words
@ -44,8 +55,7 @@ showOutputable :: (GHC.Outputable a) => a -> String
showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
fromMaybeIdentity :: Identity a -> Maybe a -> Identity a fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
fromMaybeIdentity x y = fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
fromOptionIdentity :: Identity a -> Maybe a -> Identity a fromOptionIdentity :: Identity a -> Maybe a -> Identity a
fromOptionIdentity x y = fromOptionIdentity x y =
@ -65,11 +75,9 @@ instance (Num a, Ord a) => Monoid (Max a) where
newtype ShowIsId = ShowIsId String deriving Data newtype ShowIsId = ShowIsId String deriving Data
instance Show ShowIsId where instance Show ShowIsId where show (ShowIsId x) = x
show (ShowIsId x) = x
data A x = A ShowIsId x data A x = A ShowIsId x deriving Data
deriving Data
customLayouterF :: ExactPrint.Types.Anns -> LayouterF customLayouterF :: ExactPrint.Types.Anns -> LayouterF
customLayouterF anns layoutF = customLayouterF anns layoutF =
@ -91,18 +99,14 @@ customLayouterF anns layoutF =
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 = occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString
srcSpan :: GHC.SrcSpan -> NodeLayouter srcSpan :: GHC.SrcSpan -> NodeLayouter
srcSpan ss = srcSpan ss = simpleLayouter
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
@ -131,11 +135,10 @@ customLayouterNoAnnsF layoutF =
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 = occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString
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
@ -199,11 +202,12 @@ 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 (Seq String) m => String -> m () tellDebugMess :: MonadMultiWriter
(Seq String) m => String -> m ()
tellDebugMess s = mTell $ Seq.singleton s tellDebugMess s = mTell $ Seq.singleton s
tellDebugMessShow tellDebugMessShow :: forall a m . (MonadMultiWriter
:: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m () (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..
@ -226,19 +230,20 @@ briDocToDocWithAnns :: BriDoc -> PP.Doc
briDocToDocWithAnns = astToDoc briDocToDocWithAnns = astToDoc
annsDoc :: ExactPrint.Types.Anns -> PP.Doc annsDoc :: ExactPrint.Types.Anns -> PP.Doc
annsDoc = annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)
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 (bs, cs) = breakEither fn aR where
(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 (ys, xs) = spanMaybe f xR where
(ys, xs) = spanMaybe f xR
spanMaybe _ xs = ([], xs) spanMaybe _ xs = ([], xs)
data FirstLastView a data FirstLastView a
@ -249,7 +254,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`
@ -268,7 +273,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

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

@ -4,42 +4,59 @@
module Language.Haskell.Brittany.Main where module Language.Haskell.Brittany.Main where
import Control.Monad (zipWithM)
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified Control.Monad.Trans.Except as ExceptT import qualified Control.Monad.Trans.Except as ExceptT
import Data.CZipWith
import qualified Data.Either import qualified Data.Either
import qualified Data.List.Extra import qualified Data.List.Extra
import qualified Data.Monoid
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO import qualified Data.Text.IO as Text.IO
import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy as TextL
import DataTreePrint
import GHC (GenLocated(L))
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Utils.Outputable (Outputable(..), showSDocUnsafe) import qualified System.IO
-- brittany { lconfig_importAsColumn: 60, lconfig_importColumn: 60 }
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
import qualified Data.Monoid
import GHC ( GenLocated(L) )
import GHC.Utils.Outputable ( Outputable(..)
, showSDocUnsafe
)
import Text.Read ( Read(..) )
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import Control.Monad ( zipWithM )
import Data.CZipWith
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Obfuscation
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Utils
import qualified Language.Haskell.GHC.ExactPrint as ExactPrint import Language.Haskell.Brittany.Internal.Obfuscation
import Paths_brittany
import qualified System.Directory as Directory
import qualified System.Exit
import qualified System.FilePath.Posix as FilePath
import qualified System.IO
import qualified Text.ParserCombinators.ReadP as ReadP
import qualified Text.ParserCombinators.ReadPrec as ReadPrec
import qualified Text.PrettyPrint as PP import qualified Text.PrettyPrint as PP
import Text.Read (Read(..))
import DataTreePrint
import UI.Butcher.Monadic import UI.Butcher.Monadic
import qualified System.Exit
import qualified System.Directory as Directory
import qualified System.FilePath.Posix as FilePath
import qualified GHC.Driver.Session as GHC
import qualified GHC.LanguageExtensions.Type as GHC
import Paths_brittany
data WriteMode = Display | Inplace data WriteMode = Display | Inplace
instance Read WriteMode where instance Read WriteMode where
@ -134,8 +151,7 @@ mainCmdParser helpDesc = do
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"] ["config-file"]
"PATH" "PATH"
(flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ? (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
@ -165,7 +181,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!)"
@ -195,11 +211,9 @@ mainCmdParser helpDesc = do
$ ppHelpShallow helpDesc $ ppHelpShallow helpDesc
System.Exit.exitSuccess System.Exit.exitSuccess
let let inputPaths =
inputPaths =
if null inputParams then [Nothing] else map Just inputParams if null inputParams then [Nothing] else map Just inputParams
let let outputPaths = case writeMode of
outputPaths = case writeMode of
Display -> repeat Nothing Display -> repeat Nothing
Inplace -> inputPaths Inplace -> inputPaths
@ -221,8 +235,7 @@ mainCmdParser helpDesc = do
$ trace (showConfigYaml config) $ trace (showConfigYaml config)
$ return () $ return ()
results <- zipWithM results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode)
(coreIO putStrErrLn config suppressOutput checkMode)
inputPaths inputPaths
outputPaths outputPaths
@ -253,8 +266,7 @@ coreIO
-> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status. -> IO (Either Int ChangeStatus) -- ^ Either an errorNo, or the change status.
coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM = coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
ExceptT.runExceptT $ do ExceptT.runExceptT $ do
let let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()
let ghcOptions = config & _conf_forward & _options_ghc & runIdentity let ghcOptions = config & _conf_forward & _options_ghc & runIdentity
-- there is a good of code duplication between the following code and the -- there is a good of code duplication between the following code and the
-- `pureModuleTransform` function. Unfortunately, there are also a good -- `pureModuleTransform` function. Unfortunately, there are also a good
@ -268,18 +280,15 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
-- 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 let hackAroundIncludes =
hackAroundIncludes =
config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack
let let exactprintOnly = viaGlobal || viaDebug
exactprintOnly = viaGlobal || viaDebug
where where
viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack
viaDebug = viaDebug =
config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack
let let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags
then case cppMode of then case cppMode of
CPPModeAbort -> do CPPModeAbort -> do
return $ Left "Encountered -XCPP. Aborting." return $ Left "Encountered -XCPP. Aborting."
@ -295,17 +304,14 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
(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 let hackF s = if "#include" `isPrefixOf` s
hackF s = if "#include" `isPrefixOf` s
then "-- BRITANY_INCLUDE_HACK " ++ s then "-- BRITANY_INCLUDE_HACK " ++ s
else s else s
let let hackTransform = if hackAroundIncludes && not exactprintOnly
hackTransform = if hackAroundIncludes && not exactprintOnly
then List.intercalate "\n" . fmap hackF . lines' then List.intercalate "\n" . fmap hackF . lines'
else id else id
inputString <- liftIO System.IO.getContents inputString <- liftIO System.IO.getContents
parseRes <- liftIO $ parseModuleFromString parseRes <- liftIO $ parseModuleFromString ghcOptions
ghcOptions
"stdin" "stdin"
cppCheckFunc cppCheckFunc
(hackTransform inputString) (hackTransform inputString)
@ -340,11 +346,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
pure c pure c
let moduleConf = cZipWith fromOptionIdentity config inlineConf let moduleConf = cZipWith fromOptionIdentity config inlineConf
when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do
let let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
trace ("---- ast ----\n" ++ show val) $ return () trace ("---- ast ----\n" ++ show val) $ return ()
let let disableFormatting =
disableFormatting =
moduleConf & _conf_disable_formatting & confUnpack moduleConf & _conf_disable_formatting & confUnpack
(errsWarns, outSText, hasChanges) <- do (errsWarns, outSText, hasChanges) <- do
if if
@ -354,8 +358,7 @@ 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 let omitCheck =
omitCheck =
moduleConf moduleConf
& _conf_errorHandling & _conf_errorHandling
.> _econf_omit_output_valid_check .> _econf_omit_output_valid_check
@ -363,17 +366,14 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
(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 else liftIO $ pPrintModuleAndCheck moduleConf
moduleConf
perItemConf perItemConf
anns anns
parsedSource parsedSource
let let hackF s = fromMaybe s $ TextL.stripPrefix
hackF s = fromMaybe s $ TextL.stripPrefix
(TextL.pack "-- BRITANY_INCLUDE_HACK ") (TextL.pack "-- BRITANY_INCLUDE_HACK ")
s s
let let out = TextL.toStrict $ if hackAroundIncludes
out = TextL.toStrict $ if hackAroundIncludes
then then
TextL.intercalate (TextL.pack "\n") TextL.intercalate (TextL.pack "\n")
$ hackF $ hackF
@ -383,16 +383,14 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
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 let customErrOrder ErrorInput{} = 4
customErrOrder ErrorInput{} = 4
customErrOrder LayoutWarning{} = -1 :: Int customErrOrder LayoutWarning{} = -1 :: Int
customErrOrder ErrorOutputCheck{} = 1 customErrOrder ErrorOutputCheck{} = 1
customErrOrder ErrorUnusedComment{} = 2 customErrOrder ErrorUnusedComment{} = 2
customErrOrder ErrorUnknownNode{} = -2 :: Int customErrOrder ErrorUnknownNode{} = -2 :: Int
customErrOrder ErrorMacroConfig{} = 5 customErrOrder ErrorMacroConfig{} = 5
unless (null errsWarns) $ do unless (null errsWarns) $ do
let let groupedErrsWarns =
groupedErrsWarns =
Data.List.Extra.groupOn customErrOrder Data.List.Extra.groupOn customErrOrder
$ List.sortOn customErrOrder $ List.sortOn customErrOrder
$ errsWarns $ errsWarns
@ -408,10 +406,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ "WARNING: encountered unknown syntactical constructs:" $ "WARNING: encountered unknown syntactical constructs:"
uns `forM_` \case uns `forM_` \case
ErrorUnknownNode str ast@(L loc _) -> do ErrorUnknownNode str ast@(L loc _) -> do
putErrorLn $ " " <> str <> " at " <> showSDocUnsafe putErrorLn $ " " <> str <> " at " <> showSDocUnsafe (ppr loc)
(ppr loc)
when when
(config ( config
& _conf_debug & _conf_debug
& _dconf_dump_ast_unknown & _dconf_dump_ast_unknown
& confUnpack & confUnpack
@ -463,8 +460,7 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
$ 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 let isIdentical = case inputPathM of
isIdentical = case inputPathM of
Nothing -> False Nothing -> False
Just _ -> not hasChanges Just _ -> not hasChanges
unless isIdentical $ Text.IO.writeFile p $ outSText unless isIdentical $ Text.IO.writeFile p $ outSText

58
source/test-suite/Main.hs
View File

@ -2,24 +2,35 @@
{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
import Data.Coerce (coerce) import Language.Haskell.Brittany.Internal.Prelude
import Data.List (groupBy)
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Semigroup as Semigroup import qualified Data.Semigroup as Semigroup
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified GHC.OldList as List import qualified GHC.OldList as List
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Prelude
import Language.Haskell.Brittany.Internal.PreludeUtils
import qualified System.Directory import qualified System.Directory
import System.FilePath ((</>))
import System.Timeout (timeout)
import Test.Hspec import Test.Hspec
import qualified Text.Parsec as Parsec import qualified Text.Parsec as Parsec
import Text.Parsec.Text (Parser) import Text.Parsec.Text ( Parser )
import Data.List ( groupBy )
import Language.Haskell.Brittany.Internal
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Config
import Data.Coerce ( coerce )
import qualified Data.Text.IO as Text.IO
import System.FilePath ( (</>) )
import System.Timeout ( timeout )
import Language.Haskell.Brittany.Internal.PreludeUtils
hush :: Either a b -> Maybe b hush :: Either a b -> Maybe b
hush = either (const Nothing) Just hush = either (const Nothing) Just
@ -36,7 +47,8 @@ asymptoticPerfTest = do
$ roundTripEqualWithTimeout 4000000 $ roundTripEqualWithTimeout 4000000
$ (Text.pack "func = ") $ (Text.pack "func = ")
<> mconcat <> mconcat
([1 .. 10] <&> \(i :: Int) -> ( [1 .. 10]
<&> \(i :: Int) ->
(Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n")
) )
<> Text.replicate 2000 (Text.pack " ") <> Text.replicate 2000 (Text.pack " ")
@ -50,10 +62,9 @@ asymptoticPerfTest = do
roundTripEqualWithTimeout :: Int -> Text -> Expectation roundTripEqualWithTimeout :: Int -> Text -> Expectation
roundTripEqualWithTimeout time t = roundTripEqualWithTimeout time t =
timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust) timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust)
where where
action = fmap action = fmap (fmap PPTextWrapper)
(fmap PPTextWrapper)
(parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t)
@ -74,8 +85,7 @@ data TestCase = TestCase
main :: IO () main :: IO ()
main = do main = do
files <- System.Directory.listDirectory "data/" files <- System.Directory.listDirectory "data/"
let let blts =
blts =
List.sort List.sort
$ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))
$ filter (".blt" `isSuffixOf`) files $ filter (".blt" `isSuffixOf`) files
@ -89,10 +99,8 @@ main = do
it "gives properly formatted result for valid input" $ do it "gives properly formatted result for valid input" $ do
let let
input = Text.pack $ unlines input = Text.pack $ unlines
[ "func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]" ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"]
] let expected = Text.pack $ unlines
let
expected = Text.pack $ unlines
[ "func =" [ "func ="
, " [ 00000000000000000000000" , " [ 00000000000000000000000"
, " , 00000000000000000000000" , " , 00000000000000000000000"
@ -146,16 +154,13 @@ main = do
testProcessor = \case testProcessor = \case
HeaderLine n : rest -> HeaderLine n : rest ->
let normalLines = Data.Maybe.mapMaybe extractNormal rest let normalLines = Data.Maybe.mapMaybe extractNormal rest
in in TestCase
TestCase
{ testName = n { testName = n
, isPending = any isPendingLine rest , isPending = any isPendingLine rest
, content = Text.unlines normalLines , content = Text.unlines normalLines
} }
l -> l ->
error error $ "first non-empty line must start with #test footest\n" ++ show l
$ "first non-empty line must start with #test footest\n"
++ show l
extractNormal (NormalLine l) = Just l extractNormal (NormalLine l) = Just l
extractNormal _ = Nothing extractNormal _ = Nothing
isPendingLine PendingLine{} = True isPendingLine PendingLine{} = True
@ -220,6 +225,7 @@ instance Show PPTextWrapper where
show (PPTextWrapper t) = "\n" ++ Text.unpack t show (PPTextWrapper t) = "\n" ++ Text.unpack t
-- brittany-next-binding --columns 160 -- brittany-next-binding --columns 160
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
defaultTestConfig :: Config defaultTestConfig :: Config
defaultTestConfig = Config defaultTestConfig = Config
{ _conf_version = _conf_version staticDefaultConfig { _conf_version = _conf_version staticDefaultConfig