Compare commits
No commits in common. "34c8fd93d73dbf4a11f3dffbf314501bb5eb5393" and "2b77142617a35afa0f935b1e9cc49ec0c11e83fe" have entirely different histories.
34c8fd93d7
...
2b77142617
|
|
@ -170,8 +170,6 @@ test-suite brittany-test-suite
|
|||
|
||||
build-depends:
|
||||
, hspec >= 2.8.3 && < 2.10
|
||||
, HUnit >= 1.6.2 && < 1.7
|
||||
, ansi-terminal >= 0.11.4 && < 0.12
|
||||
, parsec ^>= 3.1.14
|
||||
, these ^>= 1.1
|
||||
hs-source-dirs: source/test-suite
|
||||
|
|
|
|||
|
|
@ -145,7 +145,7 @@ doop =
|
|||
#expected
|
||||
doop =
|
||||
some long invocation == loooooooooongman + (third nested expression) - 4
|
||||
&& {- meow -} 5 - 6 > 7 `mod` loooooooooongwoman
|
||||
&& {- meow -} 5 - 6 > 7 `mod` loooooooooongwoman
|
||||
|| ill just invoke a function with these args
|
||||
|| foo
|
||||
&& dooasdoiaosdoi ** oaisdoioasido
|
||||
|
|
@ -165,7 +165,7 @@ doop =
|
|||
-- brittany { lconfig_fixityBasedAddAlignParens: True }
|
||||
doop =
|
||||
( ( some long invocation == loooooooooongman + (third nested expression) - 4
|
||||
&& {- meow -} 5 - 6 > 7 `mod` loooooooooongwoman
|
||||
&& {- meow -} 5 - 6 > 7 `mod` loooooooooongwoman
|
||||
)
|
||||
|| ill just invoke a function with these args
|
||||
|| ( foo
|
||||
|
|
|
|||
|
|
@ -57,9 +57,9 @@ test = Proxy @'[{- comment -} 'True ]
|
|||
#test with-comment-4
|
||||
test
|
||||
:: Proxy '[{- comment -}
|
||||
'True ]
|
||||
'True ]
|
||||
test = Proxy @'[{- comment -}
|
||||
'True ]
|
||||
'True ]
|
||||
|
||||
#test with-comment-5
|
||||
test
|
||||
|
|
@ -69,9 +69,9 @@ test = Proxy @'[{- comment -} True]
|
|||
#test with-comment-6
|
||||
test
|
||||
:: Proxy '[{- comment -}
|
||||
True]
|
||||
True]
|
||||
test = Proxy @'[{- comment -}
|
||||
True]
|
||||
True]
|
||||
|
||||
#test explicit-list-type non-promoted
|
||||
type Foo = '[Bool, Bool, Bool]
|
||||
|
|
|
|||
|
|
@ -329,13 +329,11 @@ func =
|
|||
foooooooooooooooooooooooooooooooo
|
||||
|
||||
#test opapp-specialcasing-3
|
||||
func =
|
||||
fooooooooooooooooooooooooooooooooo
|
||||
+ foooooooooooooooooooooooooooooooo
|
||||
[ foooooooooooooooooooooooooooooooo
|
||||
, foooooooooooooooooooooooooooooooo
|
||||
, foooooooooooooooooooooooooooooooo
|
||||
]
|
||||
func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo
|
||||
[ foooooooooooooooooooooooooooooooo
|
||||
, foooooooooooooooooooooooooooooooo
|
||||
, foooooooooooooooooooooooooooooooo
|
||||
]
|
||||
|
||||
#test opapp-indenting
|
||||
parserPrim =
|
||||
|
|
@ -958,43 +956,3 @@ func = other $ meep
|
|||
[q|hello
|
||||
world|]
|
||||
(some other very long linnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnne)
|
||||
|
||||
#test multiline-lambda-whitespace
|
||||
func =
|
||||
Text.intercalate
|
||||
"\n"
|
||||
( (\(abc, def) ->
|
||||
abc ++ def ++ "lkajsdljkasdlkjasldjkljkasd" ++ asdasdasdasd
|
||||
)
|
||||
<$> mylist
|
||||
)
|
||||
|
||||
#test operator newline behaviour
|
||||
func =
|
||||
fromIntegral aaaaaaaaaaaaaaaaaaa
|
||||
/ fromIntegral (aaaaaaaaaaaaaaaaaaa + bbbbbbbbbbbbbbbbbb)
|
||||
|
||||
#test multi-constructor associated data decl
|
||||
data POtfuggj
|
||||
instance BMGuwigoc POtfuggj where
|
||||
data KVeeweknc POtfuggj r
|
||||
= ILpieakli
|
||||
| USilcnhkYaraposqu (WeyOoovf (Nubwlhtjd EculdW.QaeopznkAc r))
|
||||
deriving stock (Lirylfj1, Jexr)
|
||||
deriving anyclass Qart2.Vrzxuvcf
|
||||
|
||||
#test bang-type
|
||||
data LabeledBool = LabeledBool !Int !Bool
|
||||
|
||||
#test block-comment after let
|
||||
func = do
|
||||
let cipInuihz = Vuozczdm.yhEfun tuhiuRasohy
|
||||
let {- CAZEB mecwbd "Caa ||" -}
|
||||
doeeRbaviceQzymin a b = olivhuwqbaq
|
||||
iqnz biwomeJhhujy _ _ | biwomeJhhujy < volpoqAsizmHdwpl = pure 0
|
||||
pure True
|
||||
|
||||
#test comment-inside-decl
|
||||
func False = 0
|
||||
-- comment
|
||||
func True = 1
|
||||
|
|
|
|||
|
|
@ -1278,13 +1278,11 @@ func =
|
|||
foooooooooooooooooooooooooooooooo
|
||||
|
||||
#test opapp-specialcasing-3
|
||||
func =
|
||||
fooooooooooooooooooooooooooooooooo
|
||||
+ foooooooooooooooooooooooooooooooo
|
||||
[ foooooooooooooooooooooooooooooooo
|
||||
, foooooooooooooooooooooooooooooooo
|
||||
, foooooooooooooooooooooooooooooooo
|
||||
]
|
||||
func = fooooooooooooooooooooooooooooooooo + foooooooooooooooooooooooooooooooo
|
||||
[ foooooooooooooooooooooooooooooooo
|
||||
, foooooooooooooooooooooooooooooooo
|
||||
, foooooooooooooooooooooooooooooooo
|
||||
]
|
||||
|
||||
#test opapp-indenting
|
||||
parserPrim =
|
||||
|
|
|
|||
|
|
@ -10,8 +10,6 @@ module Language.Haskell.Brittany.Internal
|
|||
-- re-export from utils:
|
||||
, extractCommentConfigs
|
||||
, TraceFunc(TraceFunc)
|
||||
, Splitting.splitModuleDecls
|
||||
, Splitting.extractDeclMap
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -19,6 +17,7 @@ import Control.Monad.Trans.Except
|
|||
import Data.CZipWith
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy as TextL
|
||||
import qualified GHC hiding ( parseModule )
|
||||
import qualified GHC.Driver.Session as GHC
|
||||
import GHC.Hs
|
||||
import qualified GHC.LanguageExtensions.Type as GHC
|
||||
|
|
@ -30,8 +29,6 @@ import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
|||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import qualified Language.Haskell.Brittany.Internal.S1_Parsing
|
||||
as Parsing
|
||||
import qualified Language.Haskell.Brittany.Internal.S2_SplitModule
|
||||
as Splitting
|
||||
import Language.Haskell.Brittany.Internal.StepOrchestrate
|
||||
( processModule )
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
|
|
@ -82,13 +79,9 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
|
|||
case parseResult of
|
||||
Left err -> throwE [ErrorInput err]
|
||||
Right x -> pure x
|
||||
let moduleElementList = Splitting.splitModuleDecls parsedSource
|
||||
(inlineConf, perItemConf) <-
|
||||
mapExceptT (fmap $ bimap (\(a, b) -> [ErrorMacroConfig a b]) id)
|
||||
$ extractCommentConfigs
|
||||
(useTraceFunc traceFunc)
|
||||
(Splitting.extractDeclMap parsedSource)
|
||||
moduleElementList
|
||||
$ extractCommentConfigs (useTraceFunc traceFunc) parsedSource
|
||||
let moduleConfig = cZipWith fromOptionIdentity config inlineConf
|
||||
let disableFormatting =
|
||||
moduleConfig & _conf_disable_formatting & confUnpack
|
||||
|
|
@ -103,12 +96,11 @@ parsePrintModule traceFunc configWithDebugs inputText = runExceptT $ do
|
|||
& _econf_omit_output_valid_check
|
||||
& confUnpack
|
||||
(ews, outRaw) <- if hasCPP || omitCheck
|
||||
then lift
|
||||
$ processModule traceFunc moduleConfig perItemConf moduleElementList
|
||||
then lift $ processModule traceFunc moduleConfig perItemConf parsedSource
|
||||
else lift $ pPrintModuleAndCheck traceFunc
|
||||
moduleConfig
|
||||
perItemConf
|
||||
moduleElementList
|
||||
parsedSource
|
||||
let hackF s = fromMaybe s
|
||||
$ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s
|
||||
pure $ if hackAroundIncludes
|
||||
|
|
@ -142,17 +134,17 @@ pPrintModuleAndCheck
|
|||
:: TraceFunc
|
||||
-> Config
|
||||
-> PerItemConfig
|
||||
-> FinalList ModuleElement p
|
||||
-> GHC.ParsedSource
|
||||
-> IO ([BrittanyError], TextL.Text)
|
||||
pPrintModuleAndCheck traceFunc conf inlineConf moduleElementList = do
|
||||
pPrintModuleAndCheck traceFunc conf inlineConf parsedModule = do
|
||||
let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity
|
||||
(errs, output) <- processModule traceFunc conf inlineConf moduleElementList
|
||||
(errs, output) <- processModule traceFunc conf inlineConf parsedModule
|
||||
parseResult <- Parsing.parseModuleFromString ghcOptions
|
||||
"output"
|
||||
(\_ -> return $ Right ())
|
||||
(TextL.unpack output)
|
||||
let errs' = errs ++ case parseResult of
|
||||
Left x -> [ErrorOutputCheck x]
|
||||
Left{} -> [ErrorOutputCheck]
|
||||
Right{} -> []
|
||||
return (errs', output)
|
||||
|
||||
|
|
@ -170,14 +162,10 @@ parsePrintModuleTests conf filename input = do
|
|||
case parseResult of
|
||||
Left err -> return $ Left err
|
||||
Right (parsedModule, _) -> runExceptT $ do
|
||||
let moduleElementList = Splitting.splitModuleDecls parsedModule
|
||||
(inlineConf, perItemConf) <-
|
||||
mapExceptT
|
||||
(fmap (bimap (\(a, _) -> "when parsing inline config: " ++ a) id))
|
||||
$ extractCommentConfigs
|
||||
(\_ -> pure ())
|
||||
(Splitting.extractDeclMap parsedModule)
|
||||
moduleElementList
|
||||
$ extractCommentConfigs (\_ -> pure ()) parsedModule
|
||||
let moduleConf = cZipWith fromOptionIdentity conf inlineConf
|
||||
let omitCheck =
|
||||
conf
|
||||
|
|
@ -188,11 +176,11 @@ parsePrintModuleTests conf filename input = do
|
|||
then lift $ processModule (TraceFunc $ \_ -> pure ())
|
||||
moduleConf
|
||||
perItemConf
|
||||
moduleElementList
|
||||
parsedModule
|
||||
else lift $ pPrintModuleAndCheck (TraceFunc $ \_ -> pure ())
|
||||
moduleConf
|
||||
perItemConf
|
||||
moduleElementList
|
||||
parsedModule
|
||||
if null errs
|
||||
then pure $ TextL.toStrict $ ltext
|
||||
else throwE
|
||||
|
|
@ -207,7 +195,7 @@ parsePrintModuleTests conf filename input = do
|
|||
LayoutWarning str -> str
|
||||
ErrorUnknownNode str _ -> str
|
||||
ErrorMacroConfig str _ -> "when parsing inline config: " ++ str
|
||||
ErrorOutputCheck str -> "Output is not syntactically valid: " ++ str
|
||||
ErrorOutputCheck -> "Output is not syntactically valid."
|
||||
-- this approach would for if there was a pure GHC.parseDynamicFilePragma.
|
||||
-- Unfortunately that does not exist yet, so we cannot provide a nominally
|
||||
-- pure interface.
|
||||
|
|
|
|||
|
|
@ -64,8 +64,6 @@ keywords =
|
|||
, "proc"
|
||||
, "rec"
|
||||
, "family"
|
||||
, "stock"
|
||||
, "anyclass"
|
||||
]
|
||||
|
||||
extraKWs :: [String]
|
||||
|
|
|
|||
|
|
@ -64,7 +64,6 @@ staticDefaultConfig = Config
|
|||
, _lconfig_fixityBasedAddAlignParens = coerce False
|
||||
, _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep
|
||||
, _lconfig_operatorAllowUnqualify = coerce True
|
||||
, _lconfig_allowSinglelineRecord = coerce True
|
||||
}
|
||||
, _conf_errorHandling = ErrorHandlingConfig
|
||||
{ _econf_produceOutputOnErrors = coerce False
|
||||
|
|
@ -164,7 +163,7 @@ cmdlineConfigParser = do
|
|||
, _lconfig_allowSingleLineExportList = mempty
|
||||
, _lconfig_allowHangingQuasiQuotes = mempty
|
||||
, _lconfig_experimentalSemicolonNewlines = mempty
|
||||
, _lconfig_allowSinglelineRecord = mempty
|
||||
-- , _lconfig_allowSinglelineRecord = mempty
|
||||
, _lconfig_fixityAwareOps = mempty
|
||||
, _lconfig_fixityAwareTypeOps = mempty
|
||||
, _lconfig_fixityBasedAddAlignParens = mempty
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ import Control.Monad.Trans.Except
|
|||
|
||||
import Language.Haskell.Brittany.Internal.Config.Config
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Util.AST
|
||||
import Language.Haskell.Brittany.Internal.Config.Types.Instances1 ()
|
||||
import Language.Haskell.Brittany.Internal.Config.Types.Instances2 ()
|
||||
-- import Language.Haskell.Brittany.Internal.Utils
|
||||
|
|
@ -44,26 +44,46 @@ data InlineConfigTarget
|
|||
|
||||
extractCommentConfigs
|
||||
:: (String -> IO ())
|
||||
-> Map GHC.RealSrcSpan [String]
|
||||
-> FinalList ModuleElement a
|
||||
-> GHC.ParsedSource
|
||||
-> ExceptT (String, String) IO (CConfig Maybe, PerItemConfig)
|
||||
extractCommentConfigs _putErrorLn declMap moduleElementList = do
|
||||
let comments = concatMapFinal (void moduleElementList) $ \case
|
||||
MEExactModuleHead modul -> case GHC.hsmodAnn $ GHC.unLoc modul of
|
||||
GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior
|
||||
GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) ->
|
||||
prior ++ following
|
||||
GHC.EpAnnNotUsed -> []
|
||||
MEPrettyModuleHead{} -> []
|
||||
MEImportDecl{} -> []
|
||||
MEDecl{} -> []
|
||||
MEComment (_, comment) -> [comment]
|
||||
MEWhitespace{} -> []
|
||||
extractCommentConfigs _putErrorLn modul = do
|
||||
let (L _ (GHC.HsModule modAnn _ _ _ _ decls _ _)) = modul
|
||||
let declMap :: Map GHC.RealSrcSpan [String]
|
||||
declMap = Map.fromList
|
||||
[ ( case span of
|
||||
GHC.RealSrcSpan s _ -> s
|
||||
GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
|
||||
, getDeclBindingNames decl
|
||||
)
|
||||
| decl <- decls
|
||||
, let (L (GHC.SrcSpanAnn _ span) _) = decl
|
||||
]
|
||||
let epAnnComms = \case
|
||||
GHC.EpAnn _ _ (GHC.EpaComments prior) -> prior
|
||||
GHC.EpAnn _ _ (GHC.EpaCommentsBalanced prior following) ->
|
||||
prior ++ following
|
||||
GHC.EpAnnNotUsed -> []
|
||||
let gatheredComments =
|
||||
join
|
||||
$ epAnnComms modAnn
|
||||
: [ epAnnComms epAnn | L (GHC.SrcSpanAnn epAnn _) _x <- decls ]
|
||||
-- gatheredComments `forM_` \comm@(L anchor _) -> do
|
||||
-- liftIO $ putErrorLn $ showOutputable comm
|
||||
-- case Map.lookupLE (GHC.anchor anchor) declMap of
|
||||
-- Nothing -> pure ()
|
||||
-- Just (pos, le) -> do
|
||||
-- liftIO $ putErrorLn $ " le = " ++ show (toConstr le) ++ " at " ++ show
|
||||
-- (ExactPrint.Utils.ss2deltaEnd pos (GHC.anchor anchor))
|
||||
-- case Map.lookupGE (GHC.anchor anchor) declMap of
|
||||
-- Nothing -> pure ()
|
||||
-- Just (pos, ge) -> do
|
||||
-- liftIO $ putErrorLn $ " ge = " ++ show (toConstr ge) ++ " at " ++ show
|
||||
-- (ExactPrint.Utils.ss2deltaStart (GHC.anchor anchor) pos)
|
||||
lineConfigs <- sequence
|
||||
[ case Butcher.runCmdParserSimpleString line2 parser of
|
||||
Left err -> throwE (err, line2)
|
||||
Right (target, conf) -> pure $ (GHC.anchor anchr, target, conf)
|
||||
| L anchr (EpaComment comm _) <- comments
|
||||
| L anchr (EpaComment comm _) <- gatheredComments
|
||||
, Just line1 <- case comm of
|
||||
EpaLineComment l ->
|
||||
[ List.stripPrefix "-- BRITTANY" l
|
||||
|
|
|
|||
|
|
@ -135,14 +135,14 @@ data CLayoutConfig f = LayoutConfig
|
|||
-- The implementation for this is a bit hacky and not tested; it might
|
||||
-- break output syntax or not work properly for every kind of brace. So
|
||||
-- far I have considered `do` and `case-of`.
|
||||
, _lconfig_allowSinglelineRecord :: f (Last Bool)
|
||||
-- if true, layouts record data decls as a single line when possible, e.g.
|
||||
-- > MyPoint { x :: Double, y :: Double }
|
||||
-- if false, always use the multi-line layout
|
||||
-- > MyPoint
|
||||
-- > { x :: Double
|
||||
-- > , y :: Double
|
||||
-- > }
|
||||
-- , _lconfig_allowSinglelineRecord :: f (Last Bool)
|
||||
-- -- if true, layouts record data decls as a single line when possible, e.g.
|
||||
-- -- > MyPoint { x :: Double, y :: Double }
|
||||
-- -- if false, always use the multi-line layout
|
||||
-- -- > MyPoint
|
||||
-- -- > { x :: Double
|
||||
-- -- > , y :: Double
|
||||
-- -- > }
|
||||
, _lconfig_fixityAwareOps :: f (Last Bool)
|
||||
-- enables fixity-based layouting, e.g.
|
||||
-- > foo =
|
||||
|
|
|
|||
|
|
@ -3,17 +3,15 @@
|
|||
-- TODO92
|
||||
|
||||
module Language.Haskell.Brittany.Internal.S2_SplitModule
|
||||
( extractDeclMap
|
||||
, splitModuleDecls
|
||||
, splitModuleStart
|
||||
) where
|
||||
( splitModule
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
|
||||
import qualified Data.Generics as SYB
|
||||
import qualified Data.Map as Map
|
||||
import qualified GHC
|
||||
import GHC ( AddEpAnn(AddEpAnn)
|
||||
, Anchor(Anchor)
|
||||
|
|
@ -58,104 +56,88 @@ import GHC.Parser.Annotation ( DeltaPos
|
|||
)
|
||||
, EpaCommentTok(EpaEofComment)
|
||||
)
|
||||
import GHC.Types.SrcLoc ( realSrcSpanEnd
|
||||
, realSrcSpanStart
|
||||
)
|
||||
import GHC.Types.SrcLoc ( realSrcSpanEnd )
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Types
|
||||
as ExactPrint
|
||||
import qualified Language.Haskell.GHC.ExactPrint.Utils
|
||||
as ExactPrint
|
||||
import Safe ( maximumMay )
|
||||
import qualified Control.Monad.Trans.Writer.Strict
|
||||
as WriterS
|
||||
|
||||
import Language.Haskell.Brittany.Internal.Components.BriDoc
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc.Module
|
||||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Util.AST
|
||||
|
||||
|
||||
|
||||
extractDeclMap :: GHC.ParsedSource -> Map GHC.RealSrcSpan [String]
|
||||
extractDeclMap modul =
|
||||
Map.fromList
|
||||
[ ( case span of
|
||||
GHC.RealSrcSpan s _ -> s
|
||||
GHC.UnhelpfulSpan _ -> error "unexpected UnhelpfulSpan"
|
||||
, getDeclBindingNames decl
|
||||
)
|
||||
| decl <- decls
|
||||
, let (L (GHC.SrcSpanAnn _ span) _) = decl
|
||||
]
|
||||
where (L _ (GHC.HsModule _ _ _ _ _ decls _ _)) = modul
|
||||
|
||||
splitModuleDecls :: GHC.ParsedSource -> FinalList ModuleElement ExactPrint.Pos
|
||||
splitModuleDecls lmod = do
|
||||
splitModule
|
||||
:: Bool
|
||||
-> GHC.ParsedSource
|
||||
-> Maybe GHC.RealSrcLoc
|
||||
-> FinalList ModuleElement ExactPrint.Pos
|
||||
splitModule shouldReformatHead lmod posWhere = do
|
||||
let L moduleSpan modl = lmod
|
||||
HsModule _ _layout _name _exports _imports decls _ _ = modl
|
||||
HsModule _ _layout _name _exports imports decls _ _ = modl
|
||||
(hsModAnn', finalComments) = case GHC.hsmodAnn modl of
|
||||
EpAnn a modAnns (EpaCommentsBalanced prior post) ->
|
||||
(EpAnn a modAnns (EpaCommentsBalanced prior []), post)
|
||||
_ -> (GHC.hsmodAnn modl, [])
|
||||
moduleWithoutComments = L moduleSpan modl { GHC.hsmodAnn = hsModAnn'
|
||||
, GHC.hsmodDecls = []
|
||||
}
|
||||
lastSpan <- do
|
||||
finalYield $ MEExactModuleHead moduleWithoutComments
|
||||
pure
|
||||
$ maybe (1, 1) (ExactPrint.ss2posEnd)
|
||||
$ maximumMay
|
||||
$ [ GHC.anchor a
|
||||
| L a _ <- GHC.priorComments $ case hsModAnn' of
|
||||
EpAnn _ _ cs -> cs
|
||||
EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
|
||||
]
|
||||
++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ]
|
||||
++ [ GHC.anchor a
|
||||
| L da _ <- GHC.hsmodImports modl
|
||||
, L a _ <- case GHC.ann da of
|
||||
EpAnn _ _ (EpaComments l ) -> l
|
||||
EpAnn _ _ (EpaCommentsBalanced _ l) -> l
|
||||
EpAnnNotUsed -> []
|
||||
]
|
||||
++ [ span
|
||||
| L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports modl
|
||||
]
|
||||
moduleWithoutComments =
|
||||
L moduleSpan modl { GHC.hsmodAnn = hsModAnn', GHC.hsmodDecls = [] }
|
||||
lastSpan <- if shouldReformatHead
|
||||
then do
|
||||
finalYield $ MEPrettyModuleHead moduleWithoutComments
|
||||
let locBeforeImports =
|
||||
maximumMay
|
||||
$ [ realSrcSpanEnd $ anchor a
|
||||
| L a _ <- case hsModAnn' of
|
||||
EpAnn _ _ (EpaComments cs ) -> cs
|
||||
EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2
|
||||
EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
|
||||
]
|
||||
++ [ pos | Just pos <- [posWhere] ]
|
||||
let (importLines, lastSpan) = finalToList $ transformToImportLine
|
||||
( maybe 0 srcLocLine locBeforeImports
|
||||
, maybe 1 srcLocCol locBeforeImports
|
||||
)
|
||||
imports
|
||||
let commentedImports = groupifyImportLines importLines
|
||||
sortCommentedImports commentedImports `forM_` \case
|
||||
EmptyLines n ->
|
||||
finalYield $ MEWhitespace $ DifferentLine n 1
|
||||
SamelineComment{} ->
|
||||
error "brittany internal error: splitModule SamelineComment"
|
||||
NewlineComment comm -> finalYield $ MEComment comm
|
||||
ImportStatement record -> do
|
||||
forM_ (commentsBefore record) $ finalYield . MEComment
|
||||
finalYield
|
||||
$ MEImportDecl (importStatement record) (commentsSameline record)
|
||||
forM_ (commentsAfter record) $ finalYield . MEComment
|
||||
pure $ lastSpan
|
||||
else do
|
||||
finalYield $ MEExactModuleHead moduleWithoutComments
|
||||
pure
|
||||
$ maybe (1, 1) (ExactPrint.ss2posEnd)
|
||||
$ maximumMay
|
||||
$ [ GHC.anchor a
|
||||
| L a _ <- GHC.priorComments $ case hsModAnn' of
|
||||
EpAnn _ _ cs -> cs
|
||||
EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
|
||||
]
|
||||
++ [ s | AddEpAnn _ (EpaSpan s) <- GHC.am_main $ GHC.anns hsModAnn' ]
|
||||
++ [ GHC.anchor a
|
||||
| L da _ <- GHC.hsmodImports modl
|
||||
, L a _ <- case GHC.ann da of
|
||||
EpAnn _ _ (EpaComments l ) -> l
|
||||
EpAnn _ _ (EpaCommentsBalanced _ l) -> l
|
||||
EpAnnNotUsed -> []
|
||||
]
|
||||
++ [ span
|
||||
| L (SrcSpanAnn _ (GHC.RealSrcSpan span _)) _ <- GHC.hsmodImports
|
||||
modl
|
||||
]
|
||||
spanAfterDecls <- enrichDecls lastSpan decls
|
||||
enrichComms spanAfterDecls finalComments
|
||||
|
||||
splitModuleStart
|
||||
:: GHC.ParsedSource
|
||||
-> Maybe GHC.RealSrcLoc
|
||||
-> FinalList ModuleElement ExactPrint.Pos
|
||||
splitModuleStart modul posWhere = do
|
||||
finalYield $ MEPrettyModuleHead modul
|
||||
let locBeforeImports =
|
||||
maximumMay
|
||||
$ [ realSrcSpanEnd $ anchor a
|
||||
| L a _ <- case GHC.hsmodAnn $ unLoc modul of
|
||||
EpAnn _ _ (EpaComments cs ) -> cs
|
||||
EpAnn _ _ (EpaCommentsBalanced cs1 cs2) -> cs1 ++ cs2
|
||||
EpAnnNotUsed -> error "unexpected EpAnnNotUsed"
|
||||
]
|
||||
++ [ pos | Just pos <- [posWhere] ]
|
||||
let (importLines, lastSpan) = finalToList $ transformToImportLine
|
||||
( maybe 0 srcLocLine locBeforeImports
|
||||
, maybe 1 srcLocCol locBeforeImports
|
||||
)
|
||||
(GHC.hsmodImports $ unLoc modul)
|
||||
let commentedImports = groupifyImportLines importLines
|
||||
sortCommentedImports commentedImports `forM_` \case
|
||||
EmptyLines n -> finalYield $ MEWhitespace $ DifferentLine n 1
|
||||
SamelineComment{} ->
|
||||
error "brittany internal error: splitModuleStart SamelineComment"
|
||||
NewlineComment comm -> finalYield $ MEComment comm
|
||||
ImportStatement record -> do
|
||||
forM_ (commentsBefore record) $ finalYield . MEComment
|
||||
finalYield $ MEImportDecl (importStatement record)
|
||||
(commentsSameline record)
|
||||
forM_ (commentsAfter record) $ finalYield . MEComment
|
||||
pure $ lastSpan
|
||||
|
||||
enrichComms
|
||||
:: ExactPrint.Pos -> [LEpaComment] -> FinalList ModuleElement ExactPrint.Pos
|
||||
|
|
@ -166,57 +148,52 @@ enrichComms lastSpanEnd = \case
|
|||
SameLine i -> SameLine i
|
||||
DifferentLine l c -> DifferentLine (l - 1) c
|
||||
enrichComms (ExactPrint.ss2posEnd span) commRest
|
||||
lcomm@(L (Anchor span _) _) : commRest -> do
|
||||
(L (Anchor span _) (EpaComment comm _) : commRest) -> do
|
||||
case ExactPrint.ss2delta lastSpanEnd span of
|
||||
SameLine i -> do
|
||||
finalYield $ MEComment (i, lcomm)
|
||||
finalYield $ MEComment (i, comm)
|
||||
DifferentLine l c -> do
|
||||
finalYield $ MEWhitespace $ DifferentLine (l - 1) c
|
||||
finalYield $ MEComment (0, lcomm)
|
||||
finalYield $ MEComment (0, comm)
|
||||
enrichComms (ExactPrint.ss2posEnd span) commRest
|
||||
|
||||
enrichDecls
|
||||
:: ExactPrint.Pos -> [LHsDecl GhcPs] -> FinalList ModuleElement ExactPrint.Pos
|
||||
enrichDecls lastSpanEnd = \case
|
||||
[] -> finalPure $ lastSpanEnd
|
||||
ldecl@(L (SrcSpanAnn dAnn (GHC.RealSrcSpan span _)) _) : declRest ->
|
||||
(L (SrcSpanAnn dAnn rlspan@(GHC.RealSrcSpan span _)) decl : declRest) ->
|
||||
case dAnn of
|
||||
EpAnn _dAnchor _items (EpaComments _dComments) -> do
|
||||
EpAnn dAnchor items (EpaComments dComments) -> do
|
||||
let
|
||||
commentExtract
|
||||
:: [LEpaComment] -> WriterS.Writer [LEpaComment] [LEpaComment]
|
||||
commentExtract comms = do
|
||||
let (innerComments, outerComments) =
|
||||
partition
|
||||
(\(L (Anchor anch _) _) ->
|
||||
( realSrcSpanStart anch < realSrcSpanEnd span
|
||||
&& realSrcSpanEnd anch > realSrcSpanStart span
|
||||
)
|
||||
)
|
||||
comms
|
||||
WriterS.tell outerComments
|
||||
pure innerComments
|
||||
(ldecl', extractedComments) = WriterS.runWriter
|
||||
$ SYB.everywhereM (SYB.mkM commentExtract) ldecl
|
||||
withoutComments =
|
||||
(L (SrcSpanAnn (EpAnn dAnchor items (EpaComments [])) rlspan) decl)
|
||||
commentExtract = \case
|
||||
L (GHC.Anchor anch _) EpaComment{} -> ExactPrint.ss2posEnd anch
|
||||
-- It would be really nice if `ExactPrint.ss2posEnd span` was
|
||||
-- sufficient. But for some reason the comments are not
|
||||
-- (consistently) included in the length of the anchor. I.e.
|
||||
-- there are cases where a syntax tree node has an anchor from
|
||||
-- pos A -> pos B. But then somewhere _below_ that node is a
|
||||
-- comment that has an anchor pos B -> pos C.
|
||||
-- We simply detect this here.
|
||||
-- We probably do some redundant `SYB.everything` lookups
|
||||
-- throughout the code now. But optimizing it is not easy, and
|
||||
-- at worst it is larger constant factor on the size of the
|
||||
-- input, so it isn't _that_ bad.
|
||||
fixedSpanEnd = SYB.everything
|
||||
max
|
||||
(SYB.mkQ (ExactPrint.ss2posEnd span) commentExtract)
|
||||
decl
|
||||
case ExactPrint.ss2delta lastSpanEnd span of
|
||||
SameLine{} -> pure ()
|
||||
DifferentLine n _ ->
|
||||
finalYield $ MEWhitespace $ DifferentLine (n - 1) 1
|
||||
let fixedSpanEnd = ExactPrint.ss2posEnd span
|
||||
let (afterComms, span2) = finalToList
|
||||
$ enrichComms fixedSpanEnd
|
||||
(List.sortOn (\(L l _) -> l) extractedComments)
|
||||
let (immediate, later) =
|
||||
List.span
|
||||
(\case
|
||||
MEComment{} -> True
|
||||
_ -> False
|
||||
)
|
||||
afterComms
|
||||
finalYield
|
||||
$ MEDecl
|
||||
ldecl'
|
||||
[ (ind, GHC.ac_tok comm) | MEComment (ind, L _ comm) <- immediate ]
|
||||
let (afterComms, span2) = finalToList $ enrichComms fixedSpanEnd (reverse dComments)
|
||||
let (immediate, later) = List.span (\case
|
||||
MEComment{} -> True
|
||||
_ -> False
|
||||
) afterComms
|
||||
finalYield $ MEDecl withoutComments [ comm | MEComment comm <- immediate ]
|
||||
later `forM_` finalYield
|
||||
enrichDecls span2 declRest
|
||||
EpAnn _anchor _items (EpaCommentsBalanced{}) ->
|
||||
|
|
@ -230,8 +207,8 @@ enrichDecls lastSpanEnd = \case
|
|||
|
||||
data ImportLine
|
||||
= EmptyLines Int
|
||||
| SamelineComment (Int, LEpaComment)
|
||||
| NewlineComment (Int, LEpaComment) -- indentation and comment
|
||||
| SamelineComment (Int, EpaCommentTok)
|
||||
| NewlineComment (Int, EpaCommentTok) -- indentation and comment
|
||||
| ImportStatement ImportStatementRecord
|
||||
|
||||
instance Show ImportLine where
|
||||
|
|
@ -244,10 +221,10 @@ instance Show ImportLine where
|
|||
(length $ commentsAfter r)
|
||||
|
||||
data ImportStatementRecord = ImportStatementRecord
|
||||
{ commentsBefore :: [(Int, LEpaComment)]
|
||||
{ commentsBefore :: [(Int, EpaCommentTok)]
|
||||
, importStatement :: LImportDecl GhcPs
|
||||
, commentsSameline :: [(Int, EpaCommentTok)]
|
||||
, commentsAfter :: [(Int, LEpaComment)]
|
||||
, commentsAfter :: [(Int, EpaCommentTok)]
|
||||
}
|
||||
|
||||
instance Show ImportStatementRecord where
|
||||
|
|
@ -266,13 +243,13 @@ transformToImportLine startPos is =
|
|||
:: [LEpaComment] -> ExactPrint.Pos -> FinalList ImportLine ExactPrint.Pos
|
||||
flattenComms = \case
|
||||
[] -> finalPure
|
||||
lcomm@(L (Anchor span _) _) : commRest -> \lastSpanEnd -> do
|
||||
(L (Anchor span _) (EpaComment comm _) : commRest) -> \lastSpanEnd -> do
|
||||
case ExactPrint.ss2delta lastSpanEnd span of
|
||||
SameLine i -> do
|
||||
finalYield $ SamelineComment (i, lcomm)
|
||||
finalYield $ SamelineComment (i, comm)
|
||||
DifferentLine l c -> do
|
||||
finalYield $ EmptyLines (l - 1)
|
||||
finalYield $ NewlineComment (c - 1, lcomm)
|
||||
finalYield $ NewlineComment (c - 1, comm)
|
||||
flattenComms commRest (ExactPrint.ss2posEnd span)
|
||||
flattenDecls
|
||||
:: [LImportDecl GhcPs]
|
||||
|
|
@ -281,41 +258,43 @@ transformToImportLine startPos is =
|
|||
flattenDecls = \case
|
||||
[] -> finalPure
|
||||
(L (SrcSpanAnn epAnn srcSpan@(RealSrcSpan declSpan _)) decl : declRest)
|
||||
-> \lastSpanEnd ->
|
||||
-> \lastSpanEnd ->
|
||||
let (commsBefore, commsAfter, cleanEpAnn) = case epAnn of
|
||||
EpAnn anch s (EpaComments cs) ->
|
||||
([], reverse cs, EpAnn anch s (EpaComments []))
|
||||
EpAnn anch s (EpaCommentsBalanced cs1 cs2) ->
|
||||
(reverse cs1, reverse cs2, EpAnn anch s (EpaComments []))
|
||||
EpAnnNotUsed -> ([], [], EpAnnNotUsed)
|
||||
in do
|
||||
span1 <- flattenComms commsBefore lastSpanEnd
|
||||
let newlines = case ExactPrint.ss2delta span1 declSpan of
|
||||
SameLine _ -> 0
|
||||
DifferentLine i _ -> i - 1
|
||||
finalYield $ EmptyLines newlines
|
||||
finalYield $ ImportStatement ImportStatementRecord
|
||||
{ commentsBefore = []
|
||||
, importStatement = L (SrcSpanAnn cleanEpAnn srcSpan) decl
|
||||
, commentsSameline = []
|
||||
, commentsAfter = []
|
||||
}
|
||||
span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan)
|
||||
flattenDecls declRest span2
|
||||
in
|
||||
do
|
||||
span1 <- flattenComms commsBefore lastSpanEnd
|
||||
let newlines = case ExactPrint.ss2delta span1 declSpan of
|
||||
SameLine _ -> 0
|
||||
DifferentLine i _ -> i - 1
|
||||
finalYield
|
||||
$ EmptyLines newlines
|
||||
finalYield $ ImportStatement ImportStatementRecord
|
||||
{ commentsBefore = []
|
||||
, importStatement = L (SrcSpanAnn cleanEpAnn srcSpan) decl
|
||||
, commentsSameline = []
|
||||
, commentsAfter = []
|
||||
}
|
||||
span2 <- flattenComms commsAfter (ExactPrint.ss2posEnd declSpan)
|
||||
flattenDecls declRest span2
|
||||
(L (SrcSpanAnn _epAnn UnhelpfulSpan{}) _decl : _declRest) ->
|
||||
error "UnhelpfulSpan"
|
||||
in
|
||||
flattenDecls is startPos
|
||||
|
||||
data Partial = PartialCommsOnly [(Int, LEpaComment)]
|
||||
data Partial = PartialCommsOnly [(Int, EpaCommentTok)]
|
||||
| PartialImport ImportStatementRecord
|
||||
|
||||
groupifyImportLines :: [ImportLine] -> [ImportLine]
|
||||
groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
|
||||
where
|
||||
go acc [] = case acc of
|
||||
PartialCommsOnly comms -> reverse comms `forM_` \comm ->
|
||||
finalYield $ NewlineComment comm
|
||||
PartialCommsOnly comms ->
|
||||
reverse comms `forM_` \comm -> finalYield $ NewlineComment comm
|
||||
PartialImport partialRecord ->
|
||||
finalYield $ ImportStatement $ unpartial partialRecord
|
||||
go acc (line1 : lineR) = do
|
||||
|
|
@ -327,10 +306,9 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
|
|||
pure $ PartialCommsOnly []
|
||||
SamelineComment comm -> do
|
||||
pure $ PartialCommsOnly (comm : comms)
|
||||
NewlineComment comm -> pure $ PartialCommsOnly (comm : comms)
|
||||
ImportStatement record -> pure $ PartialImport $ record
|
||||
{ commentsBefore = comms
|
||||
}
|
||||
NewlineComment comm -> pure $ PartialCommsOnly (comm : comms)
|
||||
ImportStatement record ->
|
||||
pure $ PartialImport $ record { commentsBefore = comms }
|
||||
PartialImport partialRecord -> case line1 of
|
||||
e@EmptyLines{} -> do
|
||||
finalYield $ ImportStatement $ unpartial partialRecord
|
||||
|
|
@ -339,8 +317,7 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
|
|||
SamelineComment comm -> do
|
||||
if (null $ commentsAfter partialRecord)
|
||||
then pure $ PartialImport partialRecord
|
||||
{ commentsSameline = tokenOnly comm
|
||||
: commentsSameline partialRecord
|
||||
{ commentsSameline = comm : commentsSameline partialRecord
|
||||
}
|
||||
else pure $ PartialImport partialRecord
|
||||
{ commentsAfter = comm : commentsAfter partialRecord
|
||||
|
|
@ -356,8 +333,6 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
|
|||
pure $ PartialImport $ record { commentsBefore = contestedComments }
|
||||
-- comments in between will stay connected to the following decl
|
||||
go newAcc lineR
|
||||
tokenOnly :: (Int, LEpaComment) -> (Int, EpaCommentTok)
|
||||
tokenOnly (ind, L _ (EpaComment tok _)) = (ind, tok)
|
||||
unpartial :: ImportStatementRecord -> ImportStatementRecord
|
||||
unpartial partialRecord = ImportStatementRecord
|
||||
{ commentsBefore = reverse (commentsBefore partialRecord)
|
||||
|
|
@ -370,7 +345,7 @@ groupifyImportLines ls = finalToList_ $ go (PartialCommsOnly []) ls
|
|||
sortCommentedImports :: [ImportLine] -> [ImportLine]
|
||||
sortCommentedImports =
|
||||
-- TODO92 we don't need this unpackImports, it is implied later in the process
|
||||
mergeGroups . map (fmap (sortGroups)) . groupify
|
||||
mergeGroups . map (fmap (sortGroups)) . groupify
|
||||
where
|
||||
-- unpackImports :: [ImportLine] -> [ImportLine]
|
||||
-- unpackImports xs = xs >>= \case
|
||||
|
|
@ -386,8 +361,8 @@ sortCommentedImports =
|
|||
Left x -> [x]
|
||||
Right y -> ImportStatement <$> y
|
||||
sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]
|
||||
sortGroups = List.sortOn
|
||||
(moduleNameString . unLoc . ideclName . unLoc . importStatement)
|
||||
sortGroups =
|
||||
List.sortOn (moduleNameString . unLoc . ideclName . unLoc . importStatement)
|
||||
groupify :: [ImportLine] -> [Either ImportLine [ImportStatementRecord]]
|
||||
groupify cs = go [] cs
|
||||
where
|
||||
|
|
|
|||
|
|
@ -389,9 +389,6 @@ docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
|||
docSeq [] = docEmpty
|
||||
docSeq l = allocateNode . BDSeq =<< sequence l
|
||||
|
||||
docSeqSep :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
||||
docSeqSep = docSeq . List.intersperse docSeparator
|
||||
|
||||
docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
|
||||
docLines l = allocateNode . BDLines =<< sequence l
|
||||
|
||||
|
|
@ -723,10 +720,6 @@ instance DocFlushCommsPost (Maybe GHC.RealSrcSpan) (ToBriDocM BriDocNumbered) wh
|
|||
bd <- bdm
|
||||
pure (i1, BDFlushCommentsPost (GHC.realSrcSpanEnd loc) shouldMark bd)
|
||||
|
||||
instance DocFlushCommsPost GHC.EpaLocation (ToBriDocM BriDocNumbered) where
|
||||
docFlushCommsPost shouldMark epaLocation =
|
||||
docFlushCommsPost shouldMark (Just $ GHC.epaLocationRealSrcSpan epaLocation)
|
||||
|
||||
instance DocFlushCommsPost ann (ToBriDocM BriDocNumbered)
|
||||
=> DocFlushCommsPost ann (ToBriDocM [BriDocNumbered]) where
|
||||
docFlushCommsPost shouldMark loc bdm = do
|
||||
|
|
|
|||
|
|
@ -275,53 +275,21 @@ layoutBriDocM = \case
|
|||
layoutBriDocM bd
|
||||
BDFlushCommentsPrior loc bd -> do
|
||||
comms <- takeBefore loc
|
||||
startCurY <- mGet <&> _lstate_curY
|
||||
printComments comms
|
||||
mModify (\s -> s + CommentCounter (length comms))
|
||||
mModify $ \s -> s
|
||||
{ _lstate_markerForDelta = Nothing
|
||||
, _lstate_plannedSpace =
|
||||
case _lstate_markerForDelta s of
|
||||
, _lstate_plannedSpace = case _lstate_markerForDelta s of
|
||||
Nothing -> _lstate_plannedSpace s
|
||||
Just m ->
|
||||
let p1 = (srcLocLine m, srcLocCol m)
|
||||
p2 = (srcLocLine loc, srcLocCol loc)
|
||||
in -- trace ("_lstate_plannedSpace = " ++ show (_lstate_plannedSpace s)
|
||||
-- ++ ", _lstate_markerForDelta = " ++ show (_lstate_markerForDelta s)
|
||||
-- ++ ", _lstate_curY = " ++ show (_lstate_curY s)
|
||||
-- ++ ", p1 = " ++ show p1
|
||||
-- ++ ", p2 = " ++ show p2
|
||||
-- ++ ", startCurY = " ++ show startCurY
|
||||
-- -- ++ ", delta = " ++ show (ExactPrint.pos2delta p1 p2)
|
||||
-- ) $
|
||||
case ExactPrint.pos2delta p1 p2 of
|
||||
SameLine iDelta -> case _lstate_plannedSpace s of
|
||||
-- There is a delta after a marker. That should only happen
|
||||
-- after a block-comment. And the marker-delta is SameLine,
|
||||
-- so if layout doesn't force a newline we respect the marker
|
||||
-- delta (i.e. respect whitespace immediately after a block
|
||||
-- comment) or we just use the plan.
|
||||
PlannedNone -> PlannedSameline iDelta
|
||||
PlannedSameline i -> PlannedSameline (max (iDelta - 0) i)
|
||||
p@PlannedNewline{} -> p
|
||||
p@PlannedDelta{} -> p
|
||||
-- traceShow (m, ExactPrint.pos2delta p1 p2) $ pure ()
|
||||
in case ExactPrint.pos2delta p1 p2 of
|
||||
SameLine{} -> _lstate_plannedSpace s
|
||||
DifferentLine n _ -> case _lstate_plannedSpace s of
|
||||
-- Marker with DifferentLine delta means that we want to
|
||||
-- reproduce the newlines that were present in the input.
|
||||
-- These will be emptylines in cases where it makes sense to
|
||||
-- reproduce them, e.g. between statements in a do-block.
|
||||
PlannedNone -> PlannedDelta n startCurY
|
||||
-- ^^^^^^^^^
|
||||
--
|
||||
-- after a block-comment, _lstate_curY
|
||||
-- matches the end of the comment.
|
||||
-- But to not break layout we need to
|
||||
-- restore the original.
|
||||
-- E.g. consider > let {-comm-}
|
||||
-- > x = 13
|
||||
--
|
||||
-- vvvvvvvvvvvvvvv
|
||||
PlannedSameline i -> PlannedDelta n (startCurY + i)
|
||||
PlannedNone -> PlannedNone
|
||||
PlannedSameline i -> PlannedDelta n (_lstate_curY s + i)
|
||||
PlannedNewline{} -> PlannedNewline n
|
||||
PlannedDelta _ i -> PlannedDelta n i
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Language.Haskell.Brittany.Internal.StepOrchestrate
|
||||
( processModule
|
||||
) where
|
||||
)
|
||||
where
|
||||
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
|
||||
|
|
@ -15,8 +15,7 @@ import qualified Data.Text.Lazy as TextL
|
|||
import qualified Data.Text.Lazy.Builder as TextL.Builder
|
||||
import qualified Data.Text.Lazy.Builder as Text.Builder
|
||||
import qualified GHC
|
||||
import GHC ( EpaComment(EpaComment)
|
||||
, EpaCommentTok
|
||||
import GHC ( EpaCommentTok
|
||||
( EpaBlockComment
|
||||
, EpaEofComment
|
||||
, EpaLineComment
|
||||
|
|
@ -37,7 +36,7 @@ import Language.Haskell.Brittany.Internal.Config.Types
|
|||
import Language.Haskell.Brittany.Internal.Config.Types.Instances2
|
||||
( )
|
||||
import Language.Haskell.Brittany.Internal.S2_SplitModule
|
||||
( splitModuleStart )
|
||||
( splitModule )
|
||||
import Language.Haskell.Brittany.Internal.S3_ToBriDocTools
|
||||
import Language.Haskell.Brittany.Internal.S4_WriteBriDoc
|
||||
( ppBriDoc )
|
||||
|
|
@ -47,8 +46,7 @@ import Language.Haskell.Brittany.Internal.ToBriDoc.Module
|
|||
import Language.Haskell.Brittany.Internal.Types
|
||||
import Language.Haskell.Brittany.Internal.Util.AST
|
||||
import Language.Haskell.Brittany.Internal.Utils
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc
|
||||
( layouters )
|
||||
import Language.Haskell.Brittany.Internal.ToBriDoc (layouters)
|
||||
|
||||
|
||||
|
||||
|
|
@ -60,26 +58,86 @@ processModule
|
|||
:: TraceFunc
|
||||
-> Config
|
||||
-> PerItemConfig
|
||||
-> FinalList ModuleElement p
|
||||
-> GHC.ParsedSource
|
||||
-> IO ([BrittanyError], TextL.Text)
|
||||
processModule traceFunc conf inlineConf moduleElems = do
|
||||
let FinalList moduleElementsStream = moduleElems
|
||||
((out, errs), debugStrings) =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterW
|
||||
$ MultiRWSS.withMultiReader traceFunc
|
||||
$ moduleElementsStream
|
||||
(\modElem cont -> do
|
||||
processModuleElement modElem
|
||||
cont
|
||||
)
|
||||
(\x -> do
|
||||
processModule traceFunc conf inlineConf parsedModule = do
|
||||
let shouldReformatHead =
|
||||
conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
|
||||
let
|
||||
wrapNonDeclToBriDoc = MultiRWSS.withMultiReader conf
|
||||
. MultiRWSS.withMultiState_ (CommentCounter 0)
|
||||
FinalList moduleElementsStream = splitModule
|
||||
shouldReformatHead
|
||||
parsedModule
|
||||
(fmap GHC.realSrcSpanStart $ obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc parsedModule) GHC.AnnWhere)
|
||||
((out, errs), debugStrings) =
|
||||
runIdentity
|
||||
$ MultiRWSS.runMultiRWSTNil
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterAW
|
||||
$ MultiRWSS.withMultiWriterW
|
||||
$ MultiRWSS.withMultiReader traceFunc
|
||||
$ moduleElementsStream
|
||||
(\modElem cont -> do
|
||||
case modElem of
|
||||
MEExactModuleHead modHead -> wrapNonDeclToBriDoc $ do
|
||||
bdMay <- ppModuleHead modHead
|
||||
case bdMay of
|
||||
Nothing -> pure ()
|
||||
Just bd -> ppBriDoc bd True
|
||||
MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do
|
||||
case modHead of
|
||||
HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do
|
||||
(bd, _) <-
|
||||
briDocMToPPM layouters
|
||||
$ maybe id
|
||||
docFlushRemaining
|
||||
(srcSpanFileName_maybe loc)
|
||||
$ docHandleComms epAnn docSeparator
|
||||
ppBriDoc bd True
|
||||
HsModule _ _layoutInfo Nothing Just{} _ _ _ _ -> error
|
||||
"brittany internal error: exports without module name"
|
||||
HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do
|
||||
(bd, _) <-
|
||||
briDocMToPPM layouters
|
||||
$ maybe id
|
||||
docFlushRemaining
|
||||
(srcSpanFileName_maybe loc)
|
||||
$ moduleNameExportBridoc epAnn n les
|
||||
ppBriDoc bd True
|
||||
MEImportDecl importDecl immediateAfterComms ->
|
||||
wrapNonDeclToBriDoc $ do
|
||||
(bd, _) <-
|
||||
briDocMToPPM layouters
|
||||
$ docSeq
|
||||
( layoutImport importDecl
|
||||
: map commentToDoc immediateAfterComms
|
||||
)
|
||||
ppBriDoc bd False
|
||||
MEDecl decl immediateAfterComms -> do
|
||||
let declConfig = getDeclConfig conf inlineConf decl
|
||||
MultiRWSS.withMultiReader declConfig
|
||||
$ MultiRWSS.withMultiState_ (CommentCounter 0)
|
||||
$ ppToplevelDecl decl immediateAfterComms
|
||||
MEComment (ind, EpaLineComment str) -> do
|
||||
mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
|
||||
mTell $ TextL.Builder.fromString "\n"
|
||||
MEComment (ind, EpaBlockComment str) -> do
|
||||
mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
|
||||
mTell $ TextL.Builder.fromString "\n"
|
||||
MEComment (_, EpaEofComment) -> pure ()
|
||||
MEComment _ ->
|
||||
mTell $ TextL.Builder.fromString "some other comment"
|
||||
MEWhitespace dp -> do
|
||||
-- mTell $ TextL.Builder.fromString "B"
|
||||
-- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp)
|
||||
ppmMoveToExactLoc dp
|
||||
cont
|
||||
)
|
||||
(\x -> do
|
||||
-- mTell $ TextL.Builder.fromString "\n"
|
||||
pure x
|
||||
)
|
||||
pure x
|
||||
)
|
||||
-- _tracer =
|
||||
-- -- if Seq.null debugStrings
|
||||
-- -- then id
|
||||
|
|
@ -93,94 +151,13 @@ processModule traceFunc conf inlineConf moduleElems = do
|
|||
-- MEExactModuleHead{} -> useTraceFunc traceFunc "MEExactModuleHead"
|
||||
-- MEPrettyModuleHead{} -> useTraceFunc traceFunc "MEPrettyModuleHead"
|
||||
-- MEImportDecl{} -> useTraceFunc traceFunc "MEImportDecl"
|
||||
-- MEDecl decl _ ->
|
||||
-- useTraceFunc
|
||||
-- traceFunc
|
||||
-- ("MEDecl " ++ intercalate "," (getDeclBindingNames decl))
|
||||
-- MEComment (y, L _ (EpaComment (EpaLineComment str) _)) ->
|
||||
-- useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ str)
|
||||
-- MEComment (y, L _ (EpaComment (EpaBlockComment str) _)) ->
|
||||
-- useTraceFunc traceFunc ("MEComment " ++ show y ++ " " ++ take 5 str)
|
||||
-- MEComment (y, _) ->
|
||||
-- useTraceFunc traceFunc ("MEComment " ++ show y ++ " _")
|
||||
-- MEDecl{} -> useTraceFunc traceFunc "MEDecl"
|
||||
-- MEComment{} -> useTraceFunc traceFunc "MEComment"
|
||||
-- MEWhitespace dp -> useTraceFunc traceFunc ("MEWhitespace " ++ show dp)
|
||||
-- rest
|
||||
-- )
|
||||
-- (\_ -> pure ())
|
||||
pure (errs, TextL.Builder.toLazyText out)
|
||||
where
|
||||
shouldReformatHead =
|
||||
conf & _conf_layout & _lconfig_reformatModulePreamble & confUnpack
|
||||
wrapNonDeclToBriDoc =
|
||||
MultiRWSS.withMultiReader conf . MultiRWSS.withMultiState_
|
||||
(CommentCounter 0)
|
||||
processModuleElement
|
||||
:: ModuleElement
|
||||
-> MultiRWSS.MultiRWST
|
||||
'[TraceFunc]
|
||||
'[Text.Builder.Builder , [BrittanyError] , Seq String]
|
||||
'[]
|
||||
Identity
|
||||
()
|
||||
processModuleElement = \case
|
||||
MEExactModuleHead modHead -> if shouldReformatHead
|
||||
then do
|
||||
let FinalList startElems =
|
||||
splitModuleStart
|
||||
modHead
|
||||
( fmap GHC.realSrcSpanStart
|
||||
$ obtainAnnPos (GHC.hsmodAnn $ GHC.unLoc modHead) GHC.AnnWhere
|
||||
)
|
||||
startElems
|
||||
(\modElem cont -> do
|
||||
processModuleElement modElem
|
||||
cont
|
||||
)
|
||||
(\_ -> pure ())
|
||||
else wrapNonDeclToBriDoc $ do
|
||||
bdMay <- ppModuleHead modHead
|
||||
case bdMay of
|
||||
Nothing -> pure ()
|
||||
Just bd -> do
|
||||
ppBriDoc bd True
|
||||
mTell $ Text.Builder.fromString "\n"
|
||||
MEPrettyModuleHead (L loc modHead) -> wrapNonDeclToBriDoc $ do
|
||||
case modHead of
|
||||
HsModule epAnn _layoutInfo Nothing Nothing _ _ _ _ -> do
|
||||
(bd, _) <-
|
||||
briDocMToPPM layouters
|
||||
$ maybe id docFlushRemaining (srcSpanFileName_maybe loc)
|
||||
$ docHandleComms epAnn docSeparator
|
||||
ppBriDoc bd True
|
||||
HsModule _ _layoutInfo Nothing Just{} _ _ _ _ ->
|
||||
error "brittany internal error: exports without module name"
|
||||
HsModule epAnn _layoutInfo (Just n) les _ _ _ _ -> do
|
||||
(bd, _) <-
|
||||
briDocMToPPM layouters
|
||||
$ maybe id docFlushRemaining (srcSpanFileName_maybe loc)
|
||||
$ moduleNameExportBridoc epAnn n les
|
||||
ppBriDoc bd True
|
||||
MEImportDecl importDecl immediateAfterComms -> wrapNonDeclToBriDoc $ do
|
||||
(bd, _) <- briDocMToPPM layouters $ docSeq
|
||||
(layoutImport importDecl : map commentToDoc immediateAfterComms)
|
||||
ppBriDoc bd False
|
||||
MEDecl decl immediateAfterComms -> do
|
||||
let declConfig = getDeclConfig conf inlineConf decl
|
||||
MultiRWSS.withMultiReader declConfig
|
||||
$ MultiRWSS.withMultiState_ (CommentCounter 0)
|
||||
$ ppToplevelDecl decl immediateAfterComms
|
||||
MEComment (ind, L _ (EpaComment (EpaLineComment str) _)) -> do
|
||||
mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
|
||||
mTell $ TextL.Builder.fromString "\n"
|
||||
MEComment (ind, L _ (EpaComment (EpaBlockComment str) _)) -> do
|
||||
mTell $ TextL.Builder.fromString (replicate ind ' ' ++ str)
|
||||
mTell $ TextL.Builder.fromString "\n"
|
||||
MEComment (_, L _ (EpaComment EpaEofComment _)) -> pure ()
|
||||
MEComment _ -> mTell $ TextL.Builder.fromString "some other comment"
|
||||
MEWhitespace dp -> do
|
||||
-- mTell $ TextL.Builder.fromString "B"
|
||||
-- mTell $ TextL.Builder.fromString ("whitespace " ++ show dp)
|
||||
ppmMoveToExactLoc dp
|
||||
|
||||
commentToDoc :: (Int, EpaCommentTok) -> ToBriDocM BriDocNumbered
|
||||
commentToDoc (indent, c) = case c of
|
||||
|
|
@ -220,13 +197,17 @@ processDefault x = do
|
|||
_ -> mTell $ Text.Builder.fromString $ List.dropWhileEnd ((==) '\n') str
|
||||
|
||||
|
||||
getDeclConfig :: Config -> PerItemConfig -> GHC.LHsDecl GhcPs -> Config
|
||||
getDeclConfig
|
||||
:: Config
|
||||
-> PerItemConfig
|
||||
-> GHC.LHsDecl GhcPs
|
||||
-> Config
|
||||
getDeclConfig config inlineConf decl = cZipWith fromOptionIdentity config
|
||||
$ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))
|
||||
where
|
||||
declBindingNames = getDeclBindingNames decl
|
||||
mBindingConfs = declBindingNames <&> \n ->
|
||||
Map.lookup n $ _icd_perBinding inlineConf
|
||||
mBindingConfs =
|
||||
declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf
|
||||
mDeclConf = case GHC.locA $ GHC.getLoc decl of
|
||||
GHC.RealSrcSpan x _ -> Map.lookup x $ _icd_perAnchor inlineConf
|
||||
GHC.UnhelpfulSpan{} -> Nothing
|
||||
|
|
@ -236,15 +217,16 @@ ppToplevelDecl decl immediateAfterComms = do
|
|||
exactprintOnly <- mAsk <&> \declConfig ->
|
||||
declConfig & _conf_roundtrip_exactprint_only & confUnpack
|
||||
bd <- fmap fst $ if exactprintOnly
|
||||
then briDocMToPPM layouters $ docSeq
|
||||
(briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
|
||||
then briDocMToPPM layouters
|
||||
$ docSeq
|
||||
(briDocByExactNoComment decl : map commentToDoc immediateAfterComms)
|
||||
else do
|
||||
let innerDoc = case decl of
|
||||
L (SrcSpanAnn _ (GHC.RealSrcSpan s _)) _ ->
|
||||
docFlushRemaining (GHC.srcSpanFile s) $ layoutDecl decl
|
||||
_ -> layoutDecl decl
|
||||
(r, errorCount) <- briDocMToPPM layouters $ docSeq
|
||||
(innerDoc : map commentToDoc immediateAfterComms)
|
||||
(r, errorCount) <- briDocMToPPM layouters
|
||||
$ docSeq (innerDoc : map commentToDoc immediateAfterComms)
|
||||
if errorCount == 0
|
||||
then pure (r, 0)
|
||||
else briDocMToPPM layouters $ briDocByExactNoComment decl
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ import Language.Haskell.Brittany.Internal.Components.BriDoc
|
|||
|
||||
|
||||
layoutDataDecl
|
||||
:: Maybe (LTyClDecl GhcPs)
|
||||
:: LTyClDecl GhcPs
|
||||
-> EpAnn [AddEpAnn]
|
||||
-> LIdP GhcPs
|
||||
-> LHsQTyVars GhcPs
|
||||
|
|
@ -35,7 +35,7 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of
|
|||
then do
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
consNameStr <- lrdrNameToTextAnn consName
|
||||
tyVars <- mapM shareDoc $ createBndrDoc bndrs
|
||||
tyVarLine <- shareDoc $ createBndrDoc bndrs
|
||||
patDocs <- mapM shareDoc $ layoutHsTyPats pats
|
||||
-- headDoc <- fmap return $ docSeq
|
||||
-- [ appSep $ docLitS "newtype")
|
||||
|
|
@ -43,252 +43,181 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of
|
|||
-- , appSep tyVarLine
|
||||
-- ]
|
||||
rhsDoc <- return <$> createDetailsDoc consNameStr details
|
||||
docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
|
||||
[ -- newtype Tagged s b = Tagged { unTagged :: b }
|
||||
docSeq
|
||||
[ appSep $ docLitS "newtype"
|
||||
, appSep $ docLit nameStr
|
||||
, appSep (docSeqSep tyVars)
|
||||
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
, docSeparator
|
||||
, docLitS "="
|
||||
, docSeparator
|
||||
, docForceParSpacing $ docHandleComms epAnn $ rhsDoc
|
||||
]
|
||||
, -- newtype Tagged s b
|
||||
-- = Tagged { unTagged :: b }
|
||||
-- newtype Tagged s
|
||||
-- b
|
||||
-- = Tagged { unTagged :: b }
|
||||
docAddBaseY BrIndentRegular $ docPar
|
||||
( docSeq
|
||||
[ appSep $ docLitS "newtype"
|
||||
, appSep $ docLit nameStr
|
||||
, docAlt
|
||||
[ docForceSingleline $ docSeq
|
||||
[ appSep (docSeqSep tyVars)
|
||||
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
]
|
||||
, docSetBaseY $ docLines
|
||||
$ map docForceSingleline $ tyVars ++ patDocs
|
||||
]
|
||||
]
|
||||
)
|
||||
( docSeq
|
||||
[ docLitS "="
|
||||
, docSeparator
|
||||
, docHandleComms epAnn $ rhsDoc
|
||||
]
|
||||
)
|
||||
, -- newtype Tagged
|
||||
-- s
|
||||
-- b
|
||||
-- = Tagged { unTagged :: b }
|
||||
docAddBaseY BrIndentRegular $ docPar
|
||||
( docSeq
|
||||
[ appSep $ docLitS "newtype"
|
||||
, appSep $ docLit nameStr
|
||||
-- , appSep tyVarLine
|
||||
-- , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
]
|
||||
)
|
||||
( docLines
|
||||
$ map (docEnsureIndent BrIndentRegular) tyVars
|
||||
++ map (docEnsureIndent BrIndentRegular) patDocs
|
||||
++ [ docSeq
|
||||
[ docLitS "="
|
||||
, docSeparator
|
||||
, docHandleComms epAnn $ rhsDoc
|
||||
]
|
||||
]
|
||||
)
|
||||
docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
|
||||
[ appSep $ docLitS "newtype"
|
||||
, appSep $ docLit nameStr
|
||||
, appSep tyVarLine
|
||||
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
, docSeparator
|
||||
, docLitS "="
|
||||
, docSeparator
|
||||
, docHandleComms epAnn $ rhsDoc
|
||||
]
|
||||
else maybe
|
||||
(error
|
||||
$ "Unsupported form of DataFamInstDecl:"
|
||||
++ " ConDeclH98 with context"
|
||||
)
|
||||
briDocByExactNoComment
|
||||
ltycl
|
||||
_ -> maybe
|
||||
(error
|
||||
$ "Unsupported form of DataFamInstDecl:"
|
||||
++ " ConDeclH98 with forall"
|
||||
)
|
||||
briDocByExactNoComment
|
||||
ltycl
|
||||
HsDataDefn NoExtField NewType _ _ Just{} _ _ -> maybe
|
||||
(error $ "Unsupported form of DataFamInstDecl: NewType _ _ Just _ _")
|
||||
briDocByExactNoComment
|
||||
ltycl
|
||||
HsDataDefn NoExtField NewType _ _ Nothing _ _ -> maybe
|
||||
(error $ "Unsupported form of DataFamInstDecl: NewType _ _ Nothing _ _")
|
||||
briDocByExactNoComment
|
||||
ltycl
|
||||
else briDocByExactNoComment ltycl
|
||||
_ -> briDocByExactNoComment ltycl
|
||||
|
||||
-- data MyData = MyData ..
|
||||
-- data MyData = MyData { .. }
|
||||
HsDataDefn NoExtField DataType ctxMay _ctype Nothing conss mDerivs -> do
|
||||
|
||||
-- data MyData a b
|
||||
-- (zero constructors)
|
||||
HsDataDefn NoExtField DataType ctxMay _ctype Nothing [] mDerivs -> do
|
||||
lhsContextDoc <- case ctxMay of
|
||||
Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
|
||||
Nothing -> pure docEmpty
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
tyVarLine <- shareDoc $ docSeqSep $ createBndrDoc bndrs
|
||||
tyVarLine <- return <$> createBndrDoc bndrs
|
||||
patDocs <- mapM shareDoc $ layoutHsTyPats pats
|
||||
lhsDoc <- shareDoc $ docSeq
|
||||
[ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $
|
||||
appSep $ docLitS "data"
|
||||
, docForceSingleline $ lhsContextDoc
|
||||
docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
|
||||
[ appSep $ docLitS "data"
|
||||
, lhsContextDoc
|
||||
, appSep $ docLit nameStr
|
||||
, appSep tyVarLine
|
||||
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
]
|
||||
let prefixes = "=" : repeat "|"
|
||||
layoutConssResult <- mapM layoutConDecl (zip prefixes conss)
|
||||
case sequence layoutConssResult of
|
||||
Left err -> maybe (error err) briDocByExactNoComment ltycl
|
||||
Right [] -> do
|
||||
docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
|
||||
[ appSep $ docLitS "data"
|
||||
, lhsContextDoc
|
||||
, appSep $ docLit nameStr
|
||||
, appSep tyVarLine
|
||||
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
]
|
||||
Right [(consDocSl, consDocMl)] -> do
|
||||
docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
|
||||
[ -- data D = forall a . Show a => D a
|
||||
docSeq [lhsDoc, consDocSl]
|
||||
, -- data D
|
||||
-- = forall a . Show a => D a
|
||||
-- data D
|
||||
-- = forall a
|
||||
-- . Show a =>
|
||||
-- D a
|
||||
docAddBaseY BrIndentRegular
|
||||
$ docPar lhsDoc
|
||||
(docNonBottomSpacing $ docAlt [consDocSl, consDocMl])
|
||||
, -- data
|
||||
-- Show a =>
|
||||
-- D
|
||||
-- = rhsDoc
|
||||
-- This alternative is only for -XDatatypeContexts.
|
||||
-- But I think it is rather unlikely this will trigger without
|
||||
-- -XDataTypeContexts, especially with the `docNonBottomSpacing`
|
||||
-- above, so while not strictly necessary, this should not
|
||||
-- hurt.
|
||||
docAddBaseY BrIndentRegular $ docPar
|
||||
(-- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
|
||||
docLitS "data")
|
||||
(docLines
|
||||
[ lhsContextDoc
|
||||
, docSeq
|
||||
[ appSep $ docLit nameStr
|
||||
|
||||
-- data MyData = MyData ..
|
||||
-- data MyData = MyData { .. }
|
||||
HsDataDefn NoExtField DataType ctxMay _ctype Nothing [cons] mDerivs ->
|
||||
case cons of
|
||||
(L _ (ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc))
|
||||
-> do
|
||||
lhsContextDoc <- case ctxMay of
|
||||
Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
|
||||
Nothing -> pure docEmpty
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
consNameStr <- lrdrNameToTextAnn consName
|
||||
tyVarLine <- return <$> createBndrDoc bndrs
|
||||
patDocs <- mapM shareDoc $ layoutHsTyPats pats
|
||||
forallDocMay <- case createForallDoc qvars of
|
||||
Nothing -> pure Nothing
|
||||
Just x -> Just . pure <$> x
|
||||
rhsContextDocMay <- case mRhsContext of
|
||||
Nothing -> pure Nothing
|
||||
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
|
||||
rhsDoc <- return <$> createDetailsDoc consNameStr details
|
||||
let posEqual = obtainAnnPos epAnn AnnEqual
|
||||
consDoc <-
|
||||
shareDoc
|
||||
$ docHandleComms epAnn
|
||||
$ docHandleComms posEqual
|
||||
$ docNonBottomSpacing
|
||||
$ case (forallDocMay, rhsContextDocMay) of
|
||||
(Just forallDoc, Just rhsContextDoc) -> docLines
|
||||
[ docSeq
|
||||
[docLitS "=", docSeparator, docForceSingleline forallDoc]
|
||||
, docSeq
|
||||
[ docLitS "."
|
||||
, docSeparator
|
||||
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
|
||||
]
|
||||
]
|
||||
(Just forallDoc, Nothing) -> docLines
|
||||
[ docSeq
|
||||
[docLitS "=", docSeparator, docForceSingleline forallDoc]
|
||||
, docSeq [docLitS ".", docSeparator, rhsDoc]
|
||||
]
|
||||
(Nothing, Just rhsContextDoc) -> docSeq
|
||||
[ docLitS "="
|
||||
, docSeparator
|
||||
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc]
|
||||
]
|
||||
(Nothing, Nothing) ->
|
||||
docSeq [docLitS "=", docSeparator, rhsDoc]
|
||||
docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
|
||||
[ -- data D = forall a . Show a => D a
|
||||
docSeq
|
||||
[ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $
|
||||
docSeq
|
||||
[ appSep $ docLitS "data"
|
||||
, docForceSingleline $ lhsContextDoc
|
||||
, appSep $ docLit nameStr
|
||||
, appSep tyVarLine
|
||||
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
]
|
||||
, docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
|
||||
, docSeparator
|
||||
, docSetIndentLevel $ docSeq
|
||||
[ case forallDocMay of
|
||||
Nothing -> docEmpty
|
||||
Just forallDoc ->
|
||||
docSeq
|
||||
[ docForceSingleline forallDoc
|
||||
, docSeparator
|
||||
, docLitS "."
|
||||
, docSeparator
|
||||
]
|
||||
, maybe docEmpty docForceSingleline rhsContextDocMay
|
||||
, rhsDoc
|
||||
]
|
||||
]
|
||||
, -- data D
|
||||
-- = forall a . Show a => D a
|
||||
docAddBaseY BrIndentRegular $ docPar
|
||||
( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
|
||||
docSeq
|
||||
[ appSep $ docLitS "data"
|
||||
, docForceSingleline lhsContextDoc
|
||||
, appSep $ docLit nameStr
|
||||
, tyVarLine
|
||||
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
]
|
||||
, consDocMl
|
||||
]
|
||||
)
|
||||
]
|
||||
Right consDocTuples -> do
|
||||
docHandleComms declEpAnn
|
||||
$ createDerivingPar mDerivs
|
||||
$ docAddBaseY BrIndentRegular
|
||||
$ docPar
|
||||
(docAlt
|
||||
[ -- data Show a => D a
|
||||
lhsDoc
|
||||
, -- data
|
||||
-- Show a =>
|
||||
-- D
|
||||
-- This alternative is only for -XDatatypeContexts.
|
||||
-- But I think it is rather unlikely this will trigger without
|
||||
-- -XDataTypeContexts, especially with the `docNonBottomSpacing`
|
||||
-- above, so while not strictly necessary, this should not
|
||||
-- hurt.
|
||||
docAddBaseY BrIndentRegular $ docPar
|
||||
(-- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
|
||||
docLitS "data")
|
||||
(docLines
|
||||
[ lhsContextDoc
|
||||
, docSeq
|
||||
[ appSep $ docLit nameStr
|
||||
, tyVarLine
|
||||
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
]
|
||||
)
|
||||
(docSeq
|
||||
[ docHandleComms epAnn $ docHandleComms posEqual $ docLitS "="
|
||||
, docSeparator
|
||||
, docSetIndentLevel $ docSeq
|
||||
[ case forallDocMay of
|
||||
Nothing -> docEmpty
|
||||
Just forallDoc ->
|
||||
docSeq
|
||||
[ docForceSingleline forallDoc
|
||||
, docSeparator
|
||||
, docLitS "."
|
||||
, docSeparator
|
||||
]
|
||||
, maybe docEmpty docForceSingleline rhsContextDocMay
|
||||
, rhsDoc
|
||||
]
|
||||
)
|
||||
]
|
||||
)
|
||||
(docLines $ [docAlt [sl, ml] | (sl, ml) <- consDocTuples])
|
||||
|
||||
HsDataDefn NoExtField DataType _ _ Just{} _ _ -> maybe
|
||||
(error $ "Unsupported form of DataFamInstDecl: DataType _ _ Just _ _")
|
||||
briDocByExactNoComment
|
||||
ltycl
|
||||
|
||||
layoutConDecl
|
||||
:: (String, LConDecl GhcPs)
|
||||
-> ToBriDocM
|
||||
(Either String (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered))
|
||||
layoutConDecl (prefix, L _ con) = case con of
|
||||
ConDeclH98 epAnn consName _hasExt qvars mRhsContext details _conDoc -> do
|
||||
consNameStr <- lrdrNameToTextAnn consName
|
||||
forallDocMay <- case createForallDoc qvars of
|
||||
Nothing -> pure Nothing
|
||||
Just x -> Just . pure <$> x
|
||||
rhsContextDocMay <- case mRhsContext of
|
||||
Nothing -> pure Nothing
|
||||
Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt
|
||||
detailsDoc <- shareDoc $ createDetailsDoc consNameStr details
|
||||
let posEqual = obtainAnnPos epAnn AnnEqual
|
||||
pure $ Right
|
||||
( docSeq
|
||||
[ docHandleComms epAnn $ docHandleComms posEqual $ docLitS prefix
|
||||
, docSeparator
|
||||
, docSetIndentLevel $ docSeq
|
||||
[ case forallDocMay of
|
||||
Nothing -> docEmpty
|
||||
Just forallDoc -> docSeq
|
||||
[ docForceSingleline forallDoc
|
||||
, docSeparator
|
||||
, docLitS "."
|
||||
, docSeparator
|
||||
]
|
||||
, maybe docEmpty docForceSingleline rhsContextDocMay
|
||||
, detailsDoc
|
||||
)
|
||||
, -- data D
|
||||
-- = forall a
|
||||
-- . Show a =>
|
||||
-- D a
|
||||
docAddBaseY BrIndentRegular $ docPar
|
||||
( -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
|
||||
docSeq
|
||||
[ appSep $ docLitS "data"
|
||||
, docForceSingleline lhsContextDoc
|
||||
, appSep $ docLit nameStr
|
||||
, tyVarLine
|
||||
, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
|
||||
]
|
||||
)
|
||||
consDoc
|
||||
, -- data
|
||||
-- Show a =>
|
||||
-- D
|
||||
-- = forall a
|
||||
-- . Show a =>
|
||||
-- D a
|
||||
-- This alternative is only for -XDatatypeContexts.
|
||||
-- But I think it is rather unlikely this will trigger without
|
||||
-- -XDataTypeContexts, especially with the `docNonBottomSpacing`
|
||||
-- above, so while not strictly necessary, this should not
|
||||
-- hurt.
|
||||
docAddBaseY BrIndentRegular $ docPar
|
||||
(docLitS "data")
|
||||
(docLines
|
||||
[ lhsContextDoc
|
||||
, -- TODO92 docNodeAnnKW ltycl (Just GHC.AnnData) $
|
||||
docSeq [appSep $ docLit nameStr, tyVarLine, docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]]
|
||||
, consDoc
|
||||
]
|
||||
)
|
||||
]
|
||||
]
|
||||
, docHandleComms epAnn
|
||||
$ docHandleComms posEqual
|
||||
$ docNonBottomSpacing
|
||||
$ case (forallDocMay, rhsContextDocMay) of
|
||||
(Just forallDoc, Just rhsContextDoc) -> docLines
|
||||
[ docSeq
|
||||
[docLitS prefix, docSeparator, docForceSingleline forallDoc]
|
||||
, docSeq
|
||||
[ docLitS "."
|
||||
, docSeparator
|
||||
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY detailsDoc]
|
||||
]
|
||||
]
|
||||
(Just forallDoc, Nothing) -> docLines
|
||||
[ docSeq
|
||||
[docLitS prefix, docSeparator, docForceSingleline forallDoc]
|
||||
, docSeq [docLitS ".", docSeparator, detailsDoc]
|
||||
]
|
||||
(Nothing, Just rhsContextDoc) -> docSeq
|
||||
[ docLitS prefix
|
||||
, docSeparator
|
||||
, docSetBaseY $ docLines [rhsContextDoc, docSetBaseY detailsDoc]
|
||||
]
|
||||
(Nothing, Nothing) -> docSeq
|
||||
[docLitS prefix, docSeparator, detailsDoc]
|
||||
)
|
||||
ConDeclGADT{} -> pure
|
||||
$ Left "Unsupported: ConDeclGADT inside DataFamInstDecl"
|
||||
_ -> briDocByExactNoComment ltycl
|
||||
|
||||
_ -> briDocByExactNoComment ltycl
|
||||
|
||||
layoutHsTyPats
|
||||
:: [LHsTypeArg GhcPs] -> [ToBriDocM BriDocNumbered]
|
||||
|
|
@ -324,24 +253,25 @@ createContextDoc (t1 : tR) = do
|
|||
]
|
||||
]
|
||||
|
||||
createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> [ToBriDocM BriDocNumbered]
|
||||
createBndrDoc = map $ \x -> do
|
||||
(vname, mKind) <- case x of
|
||||
createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered
|
||||
createBndrDoc bs = do
|
||||
tyVarDocs <- bs `forM` \case
|
||||
(L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing)
|
||||
(L _ (KindedTyVar _ _ext lrdrName kind)) -> do
|
||||
d <- shareDoc $ callLayouter layout_type kind
|
||||
return $ (lrdrNameToText lrdrName, Just $ d)
|
||||
case mKind of
|
||||
Nothing -> docLit vname
|
||||
Just kind -> docSeq
|
||||
[ docLitS "("
|
||||
, docLit vname
|
||||
, docSeparator
|
||||
, docLitS "::"
|
||||
, docSeparator
|
||||
, kind
|
||||
, docLitS ")"
|
||||
]
|
||||
docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) ->
|
||||
case mKind of
|
||||
Nothing -> docLit vname
|
||||
Just kind -> docSeq
|
||||
[ docLitS "("
|
||||
, docLit vname
|
||||
, docSeparator
|
||||
, docLitS "::"
|
||||
, docSeparator
|
||||
, kind
|
||||
, docLitS ")"
|
||||
]
|
||||
|
||||
createDerivingPar
|
||||
:: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
|
||||
|
|
@ -455,7 +385,8 @@ createDetailsDoc consNameStr details = case details of
|
|||
let ((fName1, fType1), fDocR) = case mkFieldDocs fields of
|
||||
(doc1:docR) -> (doc1, docR)
|
||||
_ -> error "cannot happen (TM)"
|
||||
allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
|
||||
-- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
|
||||
let allowSingleline = False
|
||||
docAddBaseY BrIndentRegular $ runFilteredAlternative $ do
|
||||
-- single-line: { i :: Int, b :: Bool }
|
||||
addAlternativeCond allowSingleline $ docSeq
|
||||
|
|
@ -481,7 +412,7 @@ createDetailsDoc consNameStr details = case details of
|
|||
, docSeparator
|
||||
, docHandleComms posClose $ docLitS "}"
|
||||
]
|
||||
addAlternative $ docSetParSpacing $ docPar
|
||||
addAlternative $ docPar
|
||||
(docLit consNameStr)
|
||||
(docNonBottomSpacingS $ docLines
|
||||
[ docAlt
|
||||
|
|
@ -537,7 +468,7 @@ createForallDoc
|
|||
:: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
|
||||
createForallDoc [] = Nothing
|
||||
createForallDoc lhsTyVarBndrs =
|
||||
Just $ docSeq [docLitS "forall ", docSeqSep $ createBndrDoc lhsTyVarBndrs]
|
||||
Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
|
||||
|
||||
createNamesAndTypeDoc
|
||||
:: LConDeclField GhcPs
|
||||
|
|
|
|||
|
|
@ -238,10 +238,7 @@ layoutGrhs (L _ (GRHS epAnn guards body)) = do
|
|||
guardDocs <- case guards of
|
||||
[] -> pure []
|
||||
_ -> docFlushCommsPost False posArrow $ callLayouter layout_stmt `mapM` guards
|
||||
let bodyEndPos = case locA $ getLoc body of
|
||||
GHC.RealSrcSpan s _ -> Just s
|
||||
GHC.UnhelpfulSpan{} -> Nothing
|
||||
bodyDoc <- docFlushCommsPost True bodyEndPos $ callLayouter layout_expr body
|
||||
bodyDoc <- callLayouter layout_expr body
|
||||
return (Just epAnn, guardDocs, bodyDoc)
|
||||
|
||||
layoutPatternBind
|
||||
|
|
@ -263,7 +260,7 @@ layoutPatternBind funId binderDoc lmatch@(L _ match) = do
|
|||
let t' = fixPatternBindIdentifier match t
|
||||
docLit t'
|
||||
_ -> pure Nothing
|
||||
patDoc <- case (mIdDoc, patDocs) of
|
||||
patDoc <- docHandleComms lmatch $ case (mIdDoc, patDocs) of -- TODO92 we use lmatch twice here!
|
||||
(Just idDoc, p1 : p2 : pr) | isInfix -> if null pr
|
||||
then docCols
|
||||
ColPatternsFuncInfix
|
||||
|
|
@ -808,7 +805,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
|
|||
typeDoc
|
||||
DataDecl epAnn name tyVars _ dataDefn -> do
|
||||
layouters <- mAsk
|
||||
layout_dataDecl layouters (Just ltycl) epAnn name tyVars [] dataDefn
|
||||
layout_dataDecl layouters ltycl epAnn name tyVars [] dataDefn
|
||||
_ -> briDocByExactNoComment ltycl
|
||||
|
||||
layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ())
|
||||
|
|
@ -976,7 +973,7 @@ layoutClsInst (L declLoc _) cid = do
|
|||
layouters <- mAsk
|
||||
layout_dataDecl
|
||||
layouters
|
||||
Nothing
|
||||
(error "Unsupported form of DataFamInstDecl")
|
||||
epAnn
|
||||
tycon
|
||||
(case bndrs of
|
||||
|
|
|
|||
|
|
@ -556,10 +556,7 @@ layoutExpr lexpr@(L _ expr) = do
|
|||
-- to making brittany idempotent, even though the result is non-optimal
|
||||
-- if "let" is moved horizontally as part of the transformation, as the
|
||||
-- comments before the first let item are moved horizontally with it.
|
||||
letDoc <- shareDoc
|
||||
$ docFlushCommsPost True spanLet
|
||||
$ wrapLet
|
||||
$ docLitS "let"
|
||||
letDoc <- shareDoc $ wrapLet $ docLit $ Text.pack "let"
|
||||
inDoc <- shareDoc $ wrapIn $ docLit $ Text.pack "in"
|
||||
docSetBaseAndIndent $ case fmap snd mBindDocs of
|
||||
Just [bindDoc] -> runFilteredAlternative $ do
|
||||
|
|
|
|||
|
|
@ -198,9 +198,6 @@ layoutOpTree allowSinglelinePar = \case
|
|||
pure (pure op, subDoc)
|
||||
sharedOpsFlat <- flattenList docOps
|
||||
sharedOps <- simpleTransform docOps
|
||||
let lastWrap = if getPrec fixity <= 1
|
||||
then docForceParSpacing
|
||||
else docForceSingleline
|
||||
coreAlternative hasParen
|
||||
locO
|
||||
locC
|
||||
|
|
@ -208,12 +205,11 @@ layoutOpTree allowSinglelinePar = \case
|
|||
docL
|
||||
sharedOps
|
||||
sharedOpsFlat
|
||||
lastWrap
|
||||
docForceParSpacing
|
||||
OpLeaf l -> pure l
|
||||
where
|
||||
isPrec0 x = getPrec x == 0
|
||||
getPrec = \case
|
||||
Fixity _ prec _ -> prec
|
||||
isPrec0 = \case
|
||||
Fixity _ prec _ -> prec == 0
|
||||
coreAlternative
|
||||
:: Bool
|
||||
-> Maybe GHC.RealSrcLoc
|
||||
|
|
@ -227,10 +223,7 @@ layoutOpTree allowSinglelinePar = \case
|
|||
coreAlternative hasParen locO locC fixity docL sharedOps sharedOpsFlat lastWrap
|
||||
= do
|
||||
indentPolicy <- askLayoutConf _lconfig_indentPolicy
|
||||
let zeroOps = null sharedOps
|
||||
wrapParenIfSl x inner = if x
|
||||
then wrapParenSl inner
|
||||
else docSetParSpacing inner
|
||||
let wrapParenIfSl x inner = if x then wrapParenSl inner else docSetParSpacing inner
|
||||
wrapParenSl inner = docAlt
|
||||
[ docSeq
|
||||
[ docLit $ Text.pack "("
|
||||
|
|
@ -248,7 +241,7 @@ layoutOpTree allowSinglelinePar = \case
|
|||
wrapParenMl innerHead innerLines = docSetBaseY $ docLines
|
||||
( [ docCols
|
||||
ColOpPrefix
|
||||
[ (if zeroOps then id else appSep) $ docLit $ Text.pack "("
|
||||
[ appSep $ docLit $ Text.pack "("
|
||||
, docHandleComms locO $ innerHead
|
||||
]
|
||||
]
|
||||
|
|
@ -272,35 +265,33 @@ layoutOpTree allowSinglelinePar = \case
|
|||
$ wrapParenIfSl hasParen
|
||||
$ docSetParSpacing
|
||||
$ docSeq
|
||||
([docForceSingleline docL] ++ case splitFirstLast sharedOpsFlat of
|
||||
FirstLastEmpty -> []
|
||||
FirstLastSingleton (od, ed) ->
|
||||
[ docSeparator
|
||||
, docForceSingleline od
|
||||
, docSeparator
|
||||
, lastWrap ed
|
||||
]
|
||||
FirstLast (od1, ed1) ems (odN, edN) ->
|
||||
( [ docSeparator
|
||||
, docForceSingleline od1
|
||||
([docForceSingleline docL] ++ case splitFirstLast sharedOpsFlat of
|
||||
FirstLastEmpty -> []
|
||||
FirstLastSingleton (od, ed) ->
|
||||
[docSeparator, docForceSingleline od, docSeparator, lastWrap ed]
|
||||
FirstLast (od1, ed1) ems (odN, edN) ->
|
||||
( [ docSeparator
|
||||
, docForceSingleline od1
|
||||
, docSeparator
|
||||
, docForceSingleline ed1
|
||||
]
|
||||
++ join
|
||||
[ [ docSeparator
|
||||
, docForceSingleline od
|
||||
, docSeparator
|
||||
, docForceSingleline ed1
|
||||
, docForceSingleline ed
|
||||
]
|
||||
++ join
|
||||
[ [ docSeparator
|
||||
, docForceSingleline od
|
||||
, docSeparator
|
||||
, docForceSingleline ed
|
||||
]
|
||||
| (od, ed) <- ems
|
||||
]
|
||||
++ [ docSeparator
|
||||
, docForceSingleline odN
|
||||
, docSeparator
|
||||
, lastWrap edN
|
||||
]
|
||||
)
|
||||
| (od, ed) <- ems
|
||||
]
|
||||
++ [ docSeparator
|
||||
, docForceSingleline odN
|
||||
, docSeparator
|
||||
, lastWrap edN
|
||||
]
|
||||
)
|
||||
)
|
||||
-- this case rather leads to some unfortunate layouting than to anything
|
||||
-- useful; disabling for now. (it interfers with cols stuff.)
|
||||
-- one
|
||||
-- + two
|
||||
-- + three
|
||||
|
|
@ -314,14 +305,15 @@ layoutOpTree allowSinglelinePar = \case
|
|||
IndentPolicyMultiple -> docForceSingleline
|
||||
IndentPolicyFree -> id
|
||||
let curIsPrec0 = case fixity of
|
||||
Nothing -> False
|
||||
Nothing -> False
|
||||
Just (Fixity _ prec _) -> prec == 0
|
||||
case sharedOps of
|
||||
[(od, ed)] | curIsPrec0 ->
|
||||
addAlternativeCond (not hasParen && isSingleOp)
|
||||
$ docSetParSpacing
|
||||
$ docPar (docHandleComms locO $ docForceSingleline $ docL)
|
||||
(docSeq [od, docSeparator, singlelineUnlessFree ed])
|
||||
$ docPar
|
||||
(docHandleComms locO $ docForceSingleline $ docL)
|
||||
(docSeq [od, docSeparator, singlelineUnlessFree ed])
|
||||
_ -> pure ()
|
||||
-- > ( one
|
||||
-- > + two
|
||||
|
|
@ -339,9 +331,9 @@ layoutOpTree allowSinglelinePar = \case
|
|||
-- > + three
|
||||
addAlternative
|
||||
$ wrapParenMlIf
|
||||
hasParen
|
||||
hasParen
|
||||
-- ((if not hasParen then docAddBaseY BrIndentRegular else id) docL)
|
||||
(if hasParen then docSetBaseY docL else docL)
|
||||
((if hasParen then sharedOps else sharedOpsFlat) <&> \(od, ed) ->
|
||||
docCols ColOpPrefix [appSep od, docSetBaseY ed]
|
||||
)
|
||||
(if hasParen then docSetBaseY docL else docL)
|
||||
((if hasParen then sharedOps else sharedOpsFlat) <&> \(od, ed) ->
|
||||
docCols ColOpPrefix [appSep od, docSetBaseY ed]
|
||||
)
|
||||
|
|
|
|||
|
|
@ -47,20 +47,18 @@ layoutStmt lstmt@(L _ stmt) = do
|
|||
]
|
||||
]
|
||||
LetStmt epAnn binds -> docHandleComms epAnn $ do
|
||||
let spanLet = obtainAnnPos epAnn AnnLet
|
||||
letDoc <- shareDoc $ docFlushCommsPost True spanLet $ docLitS "let"
|
||||
let isFree = indentPolicy == IndentPolicyFree
|
||||
let indentFourPlus = indentAmount >= 4
|
||||
(wrapBinds, bindrDocsMay) <- callLayouter layout_localBinds binds
|
||||
case bindrDocsMay of
|
||||
Nothing -> letDoc
|
||||
Nothing -> docLit $ Text.pack "let"
|
||||
-- i just tested the above, and it is indeed allowed. heh.
|
||||
Just (_, []) -> letDoc -- this probably never happens
|
||||
Just (_, []) -> docLit $ Text.pack "let" -- this probably never happens
|
||||
Just (_, [bindDoc]) -> docAlt
|
||||
[ -- let bind = expr
|
||||
docCols
|
||||
ColDoLet
|
||||
[ appSep $ letDoc
|
||||
[ appSep $ docLit $ Text.pack "let"
|
||||
, let
|
||||
f = case indentPolicy of
|
||||
IndentPolicyFree -> docSetBaseAndIndent
|
||||
|
|
@ -73,7 +71,7 @@ layoutStmt lstmt@(L _ stmt) = do
|
|||
, -- let
|
||||
-- bind = expr
|
||||
docAddBaseY BrIndentRegular $ docPar
|
||||
letDoc
|
||||
(docLit $ Text.pack "let")
|
||||
(wrapBinds $ docSetBaseAndIndent $ return bindDoc)
|
||||
]
|
||||
Just (_, bindDocs) -> runFilteredAlternative $ do
|
||||
|
|
@ -81,7 +79,7 @@ layoutStmt lstmt@(L _ stmt) = do
|
|||
-- bbb = exprb
|
||||
-- ccc = exprc
|
||||
addAlternativeCond (isFree || indentFourPlus) $ docSeq
|
||||
[ appSep $ letDoc
|
||||
[ appSep $ docLit $ Text.pack "let"
|
||||
, let
|
||||
f = if indentFourPlus
|
||||
then docEnsureIndent BrIndentRegular
|
||||
|
|
@ -95,7 +93,7 @@ layoutStmt lstmt@(L _ stmt) = do
|
|||
addAlternativeCond (not indentFourPlus)
|
||||
$ docAddBaseY BrIndentRegular
|
||||
$ docPar
|
||||
letDoc
|
||||
(docLit $ Text.pack "let")
|
||||
(wrapBinds $ docSetBaseAndIndent $ docLines $ return <$> bindDocs)
|
||||
RecStmt epAnn (L _ stmts) _ _ _ _ _ ->
|
||||
docHandleComms epAnn $ runFilteredAlternative $ do
|
||||
|
|
|
|||
|
|
@ -370,9 +370,7 @@ layoutType ltype@(L _ typ) = docHandleComms ltype $ case typ of
|
|||
]
|
||||
)
|
||||
]
|
||||
HsBangTy epAnn (HsSrcBang NoSourceText NoSrcUnpack SrcStrict) innerTy -> do
|
||||
docHandleComms epAnn $ docSeq [docLitS "!", layoutType innerTy]
|
||||
HsBangTy {} ->
|
||||
HsBangTy{} -> -- TODO
|
||||
briDocByExactInlineOnly "HsBangTy{}" ltype
|
||||
-- HsBangTy bang typ1 -> do
|
||||
-- let bangStr = case bang of
|
||||
|
|
|
|||
|
|
@ -24,7 +24,6 @@ import GHC ( Anno
|
|||
, ParsedSource
|
||||
, XRec
|
||||
, LImportDecl
|
||||
, LEpaComment
|
||||
)
|
||||
import GHC.Utils.Outputable(Outputable)
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
|
|
@ -53,7 +52,7 @@ data BrittanyError
|
|||
| forall ast . (Data.Data.Data (XRec GhcPs ast), Outputable (Anno ast)) => ErrorUnknownNode String (XRec GhcPs ast)
|
||||
-- ^ internal error: pretty-printing is not implemented for type of node
|
||||
-- in the syntax-tree
|
||||
| ErrorOutputCheck String
|
||||
| ErrorOutputCheck
|
||||
-- ^ checking the output for syntactic validity failed
|
||||
|
||||
|
||||
|
|
@ -90,8 +89,6 @@ finalToList_ :: FinalList a () -> [a]
|
|||
finalToList_ (FinalList l) = l (:) (\() -> [])
|
||||
finalToList :: FinalList a b -> ([a], b)
|
||||
finalToList (FinalList l) = l (\x (a, b) -> (x:a, b)) (\b -> ([], b))
|
||||
concatMapFinal :: FinalList a () -> (a -> [b]) -> [b]
|
||||
concatMapFinal (FinalList l) f = l (\x rest -> f x ++ rest) (\() -> [])
|
||||
|
||||
instance Functor (FinalList a) where
|
||||
fmap = _finalRMap
|
||||
|
|
@ -122,7 +119,7 @@ data ModuleElement
|
|||
-- ^ an import decl, only occurs if pretty-printing the module head.
|
||||
| MEDecl (LHsDecl GhcPs) [(Int, EpaCommentTok)]
|
||||
-- ^ a top-level declaration
|
||||
| MEComment (Int, LEpaComment)
|
||||
| MEComment (Int, EpaCommentTok)
|
||||
-- ^ a top-level comment, i.e. a comment located between top-level elements
|
||||
-- (and not associated to some nested node, which might in theory happen).
|
||||
-- The Int carries the indentation of the comment.
|
||||
|
|
@ -239,7 +236,7 @@ data Layouters = Layouters
|
|||
)
|
||||
)
|
||||
, layout_dataDecl
|
||||
:: Maybe (GHC.LTyClDecl GhcPs)
|
||||
:: GHC.LTyClDecl GhcPs
|
||||
-> GHC.EpAnn [GHC.AddEpAnn]
|
||||
-> GHC.LIdP GhcPs
|
||||
-> GHC.LHsQTyVars GhcPs
|
||||
|
|
|
|||
|
|
@ -152,7 +152,7 @@ layoutWriteComment absolute isBlock dp commentLines s = do -- TODO92 we don't mo
|
|||
mSet state
|
||||
{ _lstate_plannedSpace = if isBlock
|
||||
then case _lstate_plannedSpace state of
|
||||
p@PlannedNone -> p
|
||||
PlannedNone -> PlannedSameline 1
|
||||
p@PlannedSameline{} -> p
|
||||
PlannedNewline l ->
|
||||
if l <= y then PlannedSameline 1 else PlannedNewline (l - y)
|
||||
|
|
|
|||
|
|
@ -381,15 +381,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
|
|||
putErrorLn left
|
||||
ExceptT.throwE 60
|
||||
Right (parsedSource, hasCPP) -> do
|
||||
let moduleElementList = splitModuleDecls parsedSource
|
||||
(inlineConf, perItemConf) <- do
|
||||
resE <-
|
||||
liftIO
|
||||
$ ExceptT.runExceptT
|
||||
$ extractCommentConfigs
|
||||
putErrorLnIO
|
||||
(extractDeclMap parsedSource)
|
||||
moduleElementList
|
||||
liftIO $ ExceptT.runExceptT $ extractCommentConfigs putErrorLnIO parsedSource
|
||||
case resE of
|
||||
Left (err, input) -> do
|
||||
putErrorLn $ "Error: parse error in inline configuration:"
|
||||
|
|
@ -420,9 +414,9 @@ coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =
|
|||
.> _econf_omit_output_valid_check
|
||||
.> confUnpack
|
||||
(ews, outRaw) <- if hasCPP || omitCheck
|
||||
then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
|
||||
then liftIO $ processModule (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
|
||||
else liftIO
|
||||
$ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf moduleElementList
|
||||
$ pPrintModuleAndCheck (TraceFunc putErrorLnIO) moduleConf perItemConf parsedSource
|
||||
let
|
||||
hackF s = fromMaybe s $ TextL.stripPrefix
|
||||
(TextL.pack "-- BRITANY_INCLUDE_HACK ")
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ import Language.Haskell.Brittany.Internal
|
|||
import Language.Haskell.Brittany.Internal.Config.Config
|
||||
import Language.Haskell.Brittany.Internal.Config.Types
|
||||
import Language.Haskell.Brittany.Internal.Prelude
|
||||
import Test.HUnit (assertEqual)
|
||||
import qualified System.Directory
|
||||
import System.FilePath ((</>))
|
||||
import System.Timeout (timeout)
|
||||
|
|
@ -23,7 +22,6 @@ import Test.Hspec
|
|||
import qualified Text.Parsec as Parsec
|
||||
import Text.Parsec.Text (Parser)
|
||||
import qualified Data.List.Extra
|
||||
import qualified System.Console.ANSI as ANSI
|
||||
|
||||
hush :: Either a b -> Maybe b
|
||||
hush = either (const Nothing) Just
|
||||
|
|
@ -284,15 +282,9 @@ roundTripEqual c t =
|
|||
`shouldReturn` Right (PPTextWrapper t)
|
||||
|
||||
goldenTest :: Config -> Text -> Text -> Expectation
|
||||
goldenTest c input expected = do
|
||||
result <- parsePrintModuleTests c "TestFakeFileName.hs" input
|
||||
assertEqual
|
||||
( ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
|
||||
++ "golden input: see test source!"
|
||||
++ ANSI.setSGRCode [ANSI.Reset]
|
||||
)
|
||||
(Right (PPTextWrapper expected))
|
||||
(fmap PPTextWrapper result)
|
||||
goldenTest c input expected =
|
||||
fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" input)
|
||||
`shouldReturn` Right (PPTextWrapper expected)
|
||||
|
||||
newtype PPTextWrapper = PPTextWrapper Text
|
||||
deriving Eq
|
||||
|
|
@ -323,7 +315,7 @@ defaultTestConfig = Config
|
|||
, _lconfig_allowSingleLineExportList = coerce True
|
||||
, _lconfig_allowHangingQuasiQuotes = coerce True
|
||||
, _lconfig_experimentalSemicolonNewlines = coerce False
|
||||
, _lconfig_allowSinglelineRecord = coerce False
|
||||
-- , _lconfig_allowSinglelineRecord = coerce False
|
||||
, _lconfig_fixityAwareOps = coerce True
|
||||
, _lconfig_fixityAwareTypeOps = coerce True
|
||||
, _lconfig_fixityBasedAddAlignParens = coerce False
|
||||
|
|
|
|||
Loading…
Reference in New Issue