packages feed

brittany 0.14.0.0 → 0.14.0.1

raw patch · 68 files changed

+11193/−11184 lines, 68 files

Files

README.md view
@@ -61,7 +61,7 @@ - via `stack`      ~~~~.sh-    stack install brittany # --resolver lts-10.0+    stack install brittany # --resolver lts-16.31     ~~~~      If you use an lts that includes brittany this should just work; otherwise@@ -104,8 +104,8 @@ #### VSCode   [This extension](https://marketplace.visualstudio.com/items?itemName=MaxGabriel.brittany)   connects commandline `brittany` to VSCode formatting API. Thanks to @MaxGabriel.-#### Via HIE-  [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine)+#### Via HLS+  [haskell-language-server](https://github.com/haskell/haskell-language-server)   includes a `brittany` plugin that directly uses the brittany library.   Relevant for any editors that properly support the language-server-protocol. #### Neovim / Vim 8
brittany.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2  name:                 brittany-version:              0.14.0.0+version:              0.14.0.1 synopsis:             Haskell source code formatter description:   See <https://github.com/lspitzner/brittany/blob/master/README.md the README>.@@ -101,36 +101,36 @@   autogen-modules: Paths_brittany   hs-source-dirs: source/library   exposed-modules:-    Language.Haskell.Brittany-    Language.Haskell.Brittany.Internal-    Language.Haskell.Brittany.Internal.Backend-    Language.Haskell.Brittany.Internal.BackendUtils-    Language.Haskell.Brittany.Internal.Config-    Language.Haskell.Brittany.Internal.Config.Types-    Language.Haskell.Brittany.Internal.Config.Types.Instances-    Language.Haskell.Brittany.Internal.ExactPrintUtils-    Language.Haskell.Brittany.Internal.LayouterBasics-    Language.Haskell.Brittany.Internal.Layouters.DataDecl-    Language.Haskell.Brittany.Internal.Layouters.Decl-    Language.Haskell.Brittany.Internal.Layouters.Expr-    Language.Haskell.Brittany.Internal.Layouters.IE-    Language.Haskell.Brittany.Internal.Layouters.Import-    Language.Haskell.Brittany.Internal.Layouters.Module-    Language.Haskell.Brittany.Internal.Layouters.Pattern-    Language.Haskell.Brittany.Internal.Layouters.Stmt-    Language.Haskell.Brittany.Internal.Layouters.Type-    Language.Haskell.Brittany.Internal.Obfuscation-    Language.Haskell.Brittany.Internal.ParseModule-    Language.Haskell.Brittany.Internal.Prelude-    Language.Haskell.Brittany.Internal.PreludeUtils-    Language.Haskell.Brittany.Internal.Transformations.Alt-    Language.Haskell.Brittany.Internal.Transformations.Columns-    Language.Haskell.Brittany.Internal.Transformations.Floating-    Language.Haskell.Brittany.Internal.Transformations.Indent-    Language.Haskell.Brittany.Internal.Transformations.Par-    Language.Haskell.Brittany.Internal.Types-    Language.Haskell.Brittany.Internal.Utils-    Language.Haskell.Brittany.Main+    Brittany+    Brittany.Internal+    Brittany.Internal.Backend+    Brittany.Internal.BackendUtils+    Brittany.Internal.Config+    Brittany.Internal.Config.Types+    Brittany.Internal.Config.Types.Instances+    Brittany.Internal.ExactPrintUtils+    Brittany.Internal.LayouterBasics+    Brittany.Internal.Layouters.DataDecl+    Brittany.Internal.Layouters.Decl+    Brittany.Internal.Layouters.Expr+    Brittany.Internal.Layouters.IE+    Brittany.Internal.Layouters.Import+    Brittany.Internal.Layouters.Module+    Brittany.Internal.Layouters.Pattern+    Brittany.Internal.Layouters.Stmt+    Brittany.Internal.Layouters.Type+    Brittany.Internal.Obfuscation+    Brittany.Internal.ParseModule+    Brittany.Internal.Prelude+    Brittany.Internal.PreludeUtils+    Brittany.Internal.Transformations.Alt+    Brittany.Internal.Transformations.Columns+    Brittany.Internal.Transformations.Floating+    Brittany.Internal.Transformations.Indent+    Brittany.Internal.Transformations.Par+    Brittany.Internal.Types+    Brittany.Internal.Utils+    Brittany.Main     Paths_brittany  executable brittany
source/executable/Main.hs view
@@ -1,4 +1,4 @@-import qualified Language.Haskell.Brittany.Main as BrittanyMain+import qualified Brittany.Main as BrittanyMain  main :: IO () main = BrittanyMain.main
+ source/library/Brittany.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany+  ( parsePrintModule+  , staticDefaultConfig+  , forwardOptionsSyntaxExtsEnabled+  , userConfigPath+  , findLocalConfigPath+  , readConfigs+  , readConfigsWithUserConfig+  , Config+  , CConfig(..)+  , CDebugConfig(..)+  , CLayoutConfig(..)+  , CErrorHandlingConfig(..)+  , CForwardOptions(..)+  , CPreProcessorConfig(..)+  , BrittanyError(..)+  ) where++import Brittany.Internal+import Brittany.Internal.Config+import Brittany.Internal.Config.Types+import Brittany.Internal.Types
+ source/library/Brittany/Internal.hs view
@@ -0,0 +1,684 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Brittany.Internal+  ( parsePrintModule+  , parsePrintModuleTests+  , pPrintModule+  , pPrintModuleAndCheck+   -- re-export from utils:+  , parseModule+  , parseModuleFromString+  , extractCommentConfigs+  , getTopLevelDeclNameMap+  ) where++import Control.Monad.Trans.Except+import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS+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.Maybe+import qualified Data.Semigroup as Semigroup+import qualified Data.Sequence as Seq+import qualified Data.Text as Text+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 qualified GHC.Driver.Session as GHC+import GHC.Hs+import qualified GHC.LanguageExtensions.Type as GHC+import qualified GHC.OldList as List+import GHC.Parser.Annotation (AnnKeywordId(..))+import GHC.Types.SrcLoc (SrcSpan)+import Brittany.Internal.Backend+import Brittany.Internal.BackendUtils+import Brittany.Internal.Config+import Brittany.Internal.Config.Types+import Brittany.Internal.ExactPrintUtils+import Brittany.Internal.LayouterBasics+import Brittany.Internal.Layouters.Decl+import Brittany.Internal.Layouters.Module+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Transformations.Alt+import Brittany.Internal.Transformations.Columns+import Brittany.Internal.Transformations.Floating+import Brittany.Internal.Transformations.Indent+import Brittany.Internal.Transformations.Par+import Brittany.Internal.Types+import Brittany.Internal.Utils+import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint+import qualified UI.Butcher.Monadic as Butcher++++data InlineConfigTarget+    = InlineConfigTargetModule+    | InlineConfigTargetNextDecl    -- really only next in module+    | InlineConfigTargetNextBinding -- by name+    | InlineConfigTargetBinding String++extractCommentConfigs+  :: ExactPrint.Anns+  -> TopLevelDeclNameMap+  -> Either (String, String) (CConfig Maybe, PerItemConfig)+extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do+  let+    commentLiness =+      [ ( k+        , [ x+          | (ExactPrint.Comment x _ _, _) <-+            (ExactPrint.annPriorComments ann+            ++ ExactPrint.annFollowingComments ann+            )+          ]+        ++ [ x+           | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <-+             ExactPrint.annsDP ann+           ]+        )+      | (k, ann) <- Map.toList anns+      ]+  let+    configLiness = commentLiness <&> second+      (Data.Maybe.mapMaybe $ \line -> do+        l1 <-+          List.stripPrefix "-- BRITTANY" line+          <|> List.stripPrefix "--BRITTANY" line+          <|> List.stripPrefix "-- brittany" line+          <|> List.stripPrefix "--brittany" line+          <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")+        let l2 = dropWhile isSpace l1+        guard+          (("@" `isPrefixOf` l2)+          || ("-disable" `isPrefixOf` l2)+          || ("-next" `isPrefixOf` l2)+          || ("{" `isPrefixOf` l2)+          || ("--" `isPrefixOf` l2)+          )+        pure l2+      )+  let+    configParser = Butcher.addAlternatives+      [ ( "commandline-config"+        , \s -> "-" `isPrefixOf` dropWhile (== ' ') s+        , cmdlineConfigParser+        )+      , ( "yaml-config-document"+        , \s -> "{" `isPrefixOf` dropWhile (== ' ') s+        , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document")+        $ fmap (\lconf -> (mempty { _conf_layout = lconf }, ""))+        . either (const Nothing) Just+        . Data.Yaml.decodeEither'+        . Data.ByteString.Char8.pack+          -- TODO: use some proper utf8 encoder instead?+        )+      ]+    parser = do -- we will (mis?)use butcher here to parse the inline config+                -- line.+      let+        nextDecl = do+          conf <- configParser+          Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)+      Butcher.addCmd "-next-declaration" nextDecl+      Butcher.addCmd "-Next-Declaration" nextDecl+      Butcher.addCmd "-NEXT-DECLARATION" nextDecl+      let+        nextBinding = do+          conf <- configParser+          Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)+      Butcher.addCmd "-next-binding" nextBinding+      Butcher.addCmd "-Next-Binding" nextBinding+      Butcher.addCmd "-NEXT-BINDING" nextBinding+      let+        disableNextBinding = do+          Butcher.addCmdImpl+            ( InlineConfigTargetNextBinding+            , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }+            )+      Butcher.addCmd "-disable-next-binding" disableNextBinding+      Butcher.addCmd "-Disable-Next-Binding" disableNextBinding+      Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding+      let+        disableNextDecl = do+          Butcher.addCmdImpl+            ( InlineConfigTargetNextDecl+            , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }+            )+      Butcher.addCmd "-disable-next-declaration" disableNextDecl+      Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl+      Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl+      let+        disableFormatting = do+          Butcher.addCmdImpl+            ( InlineConfigTargetModule+            , mempty { _conf_disable_formatting = pure $ pure True }+            )+      Butcher.addCmd "-disable" disableFormatting+      Butcher.addCmd "@" $ do+        -- Butcher.addCmd "module" $ do+        --   conf <- configParser+        --   Butcher.addCmdImpl (InlineConfigTargetModule, conf)+        Butcher.addNullCmd $ do+          bindingName <- Butcher.addParamString "BINDING" mempty+          conf <- configParser+          Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf)+      conf <- configParser+      Butcher.addCmdImpl (InlineConfigTargetModule, conf)+  lineConfigss <- configLiness `forM` \(k, ss) -> do+    r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of+      Left err -> Left $ (err, s)+      Right c -> Right $ c+    pure (k, r)++  let+    perModule = foldl'+      (<>)+      mempty+      [ conf+      | (_, lineConfigs) <- lineConfigss+      , (InlineConfigTargetModule, conf) <- lineConfigs+      ]+  let+    perBinding = Map.fromListWith+      (<>)+      [ (n, conf)+      | (k, lineConfigs) <- lineConfigss+      , (target, conf) <- lineConfigs+      , n <- case target of+        InlineConfigTargetBinding s -> [s]+        InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->+          [name]+        _ -> []+      ]+  let+    perKey = Map.fromListWith+      (<>)+      [ (k, conf)+      | (k, lineConfigs) <- lineConfigss+      , (target, conf) <- lineConfigs+      , case target of+        InlineConfigTargetNextDecl -> True+        InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap ->+          True+        _ -> False+      ]++  pure+    $ ( perModule+      , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey }+      )+++getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap+getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =+  TopLevelDeclNameMap $ Map.fromList+    [ (ExactPrint.mkAnnKey decl, name)+    | decl <- decls+    , (name : _) <- [getDeclBindingNames decl]+    ]+++-- | Exposes the transformation in an pseudo-pure fashion. The signature+-- contains `IO` due to the GHC API not exposing a pure parsing function, but+-- there should be no observable effects.+--+-- Note that this function ignores/resets all config values regarding+-- debugging, i.e. it will never use `trace`/write to stderr.+--+-- Note that the ghc parsing function used internally currently is wrapped in+-- `mask_`, so cannot be killed easily. If you don't control the input, you+-- may wish to put some proper upper bound on the input's size as a timeout+-- won't do.+parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)+parsePrintModule configWithDebugs inputText = runExceptT $ do+  let+    config = configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }+  let ghcOptions = config & _conf_forward & _options_ghc & runIdentity+  let config_pp = config & _conf_preprocessor+  let cppMode = config_pp & _ppconf_CPPMode & confUnpack+  let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack+  (anns, parsedSource, hasCPP) <- do+    let+      hackF s =+        if "#include" `isPrefixOf` s then "-- BRITANY_INCLUDE_HACK " ++ s else s+    let+      hackTransform = if hackAroundIncludes+        then List.intercalate "\n" . fmap hackF . lines'+        else id+    let+      cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags+        then case cppMode of+          CPPModeAbort -> return $ Left "Encountered -XCPP. Aborting."+          CPPModeWarn -> return $ Right True+          CPPModeNowarn -> return $ Right True+        else return $ Right False+    parseResult <- lift $ parseModuleFromString+      ghcOptions+      "stdin"+      cppCheckFunc+      (hackTransform $ Text.unpack inputText)+    case parseResult of+      Left err -> throwE [ErrorInput err]+      Right x -> pure x+  (inlineConf, perItemConf) <-+    either (throwE . (: []) . uncurry ErrorMacroConfig) pure+      $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)+  let moduleConfig = cZipWith fromOptionIdentity config inlineConf+  let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack+  if disableFormatting+    then do+      return inputText+    else do+      (errsWarns, outputTextL) <- do+        let+          omitCheck =+            moduleConfig+              & _conf_errorHandling+              & _econf_omit_output_valid_check+              & confUnpack+        (ews, outRaw) <- if hasCPP || omitCheck+          then return $ pPrintModule moduleConfig perItemConf anns parsedSource+          else lift+            $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource+        let+          hackF s = fromMaybe s+            $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s+        pure $ if hackAroundIncludes+          then+            ( ews+            , TextL.intercalate (TextL.pack "\n")+            $ hackF+            <$> TextL.splitOn (TextL.pack "\n") outRaw+            )+          else (ews, outRaw)+      let+        customErrOrder ErrorInput{} = 4+        customErrOrder LayoutWarning{} = 0 :: Int+        customErrOrder ErrorOutputCheck{} = 1+        customErrOrder ErrorUnusedComment{} = 2+        customErrOrder ErrorUnknownNode{} = 3+        customErrOrder ErrorMacroConfig{} = 5+      let+        hasErrors =+          if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack+            then not $ null errsWarns+            else 0 < maximum (-1 : fmap customErrOrder errsWarns)+      if hasErrors+        then throwE $ errsWarns+        else pure $ TextL.toStrict outputTextL++++-- BrittanyErrors can be non-fatal warnings, thus both are returned instead+-- of an Either.+-- This should be cleaned up once it is clear what kinds of errors really+-- can occur.+pPrintModule+  :: Config+  -> PerItemConfig+  -> ExactPrint.Anns+  -> GHC.ParsedSource+  -> ([BrittanyError], TextL.Text)+pPrintModule conf inlineConf anns parsedModule =+  let+    ((out, errs), debugStrings) =+      runIdentity+        $ MultiRWSS.runMultiRWSTNil+        $ MultiRWSS.withMultiWriterAW+        $ MultiRWSS.withMultiWriterAW+        $ MultiRWSS.withMultiWriterW+        $ MultiRWSS.withMultiReader anns+        $ MultiRWSS.withMultiReader conf+        $ MultiRWSS.withMultiReader inlineConf+        $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)+        $ do+            traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations+              $ annsDoc anns+            ppModule parsedModule+    tracer = if Seq.null debugStrings+      then id+      else+        trace ("---- DEBUGMESSAGES ---- ")+          . foldr (seq . join trace) id debugStrings+  in tracer $ (errs, Text.Builder.toLazyText out)+  -- unless () $ do+  --+  --   debugStrings `forM_` \s ->+  --     trace s $ return ()++-- | Additionally checks that the output compiles again, appending an error+-- if it does not.+pPrintModuleAndCheck+  :: Config+  -> PerItemConfig+  -> ExactPrint.Anns+  -> GHC.ParsedSource+  -> IO ([BrittanyError], TextL.Text)+pPrintModuleAndCheck conf inlineConf anns parsedModule = do+  let ghcOptions = conf & _conf_forward & _options_ghc & runIdentity+  let (errs, output) = pPrintModule conf inlineConf anns parsedModule+  parseResult <- parseModuleFromString+    ghcOptions+    "output"+    (\_ -> return $ Right ())+    (TextL.unpack output)+  let+    errs' = errs ++ case parseResult of+      Left{} -> [ErrorOutputCheck]+      Right{} -> []+  return (errs', output)+++-- used for testing mostly, currently.+-- TODO: use parsePrintModule instead and remove this function.+parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text)+parsePrintModuleTests conf filename input = do+  let inputStr = Text.unpack input+  parseResult <- parseModuleFromString+    (conf & _conf_forward & _options_ghc & runIdentity)+    filename+    (const . pure $ Right ())+    inputStr+  case parseResult of+    Left err -> return $ Left err+    Right (anns, parsedModule, _) -> runExceptT $ do+      (inlineConf, perItemConf) <-+        case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of+          Left err -> throwE $ "error in inline config: " ++ show err+          Right x -> pure x+      let moduleConf = cZipWith fromOptionIdentity conf inlineConf+      let+        omitCheck =+          conf+            & _conf_errorHandling+            .> _econf_omit_output_valid_check+            .> confUnpack+      (errs, ltext) <- if omitCheck+        then return $ pPrintModule moduleConf perItemConf anns parsedModule+        else lift+          $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule+      if null errs+        then pure $ TextL.toStrict $ ltext+        else+          let+            errStrs = errs <&> \case+              ErrorInput str -> str+              ErrorUnusedComment str -> str+              LayoutWarning str -> str+              ErrorUnknownNode str _ -> str+              ErrorMacroConfig str _ -> "when parsing inline config: " ++ str+              ErrorOutputCheck -> "Output is not syntactically valid."+          in throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs++-- 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.++-- parsePrintModuleTests :: Text -> Either String Text+-- parsePrintModuleTests input = do+--   let dflags = GHC.unsafeGlobalDynFlags+--   let fakeFileName = "SomeTestFakeFileName.hs"+--   let pragmaInfo = GHC.getOptions+--         dflags+--         (GHC.stringToStringBuffer $ Text.unpack input)+--         fakeFileName+--   (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo+--   let parseResult = ExactPrint.Parsers.parseWith+--         dflags1+--         fakeFileName+--         GHC.parseModule+--         inputStr+--   case parseResult of+--     Left (_, s) -> Left $ "parsing error: " ++ s+--     Right (anns, parsedModule) -> do+--       let (out, errs) = runIdentity+--                       $ runMultiRWSTNil+--                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW+--                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW+--                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns+--                       $ ppModule parsedModule+--       if (not $ null errs)+--         then do+--           let errStrs = errs <&> \case+--                 ErrorUnusedComment str -> str+--           Left $ "pretty printing error(s):\n" ++ List.unlines errStrs+--         else return $ TextL.toStrict $ Text.Builder.toLazyText out++toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a+toLocal conf anns m = do+  (x, write) <-+    lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m+  MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write)+  pure x++ppModule :: GenLocated SrcSpan HsModule -> PPM ()+ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do+  defaultAnns <- do+    anns <- mAsk+    let annKey = ExactPrint.mkAnnKey lmod+    let annMap = Map.findWithDefault Map.empty annKey anns+    let isEof = (== ExactPrint.AnnEofPos)+    let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a }+    pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap++  post <- ppPreamble lmod+  decls `forM_` \decl -> do+    let declAnnKey = ExactPrint.mkAnnKey decl+    let declBindingNames = getDeclBindingNames decl+    inlineConf <- mAsk+    let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf+    let+      mBindingConfs =+        declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf+    filteredAnns <- mAsk <&> \annMap ->+      Map.union defaultAnns $ Map.findWithDefault Map.empty declAnnKey annMap++    traceIfDumpConf+        "bridoc annotations filtered/transformed"+        _dconf_dump_annotations+      $ annsDoc filteredAnns++    config <- mAsk++    let+      config' = cZipWith fromOptionIdentity config+        $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))++    let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack+    toLocal config' filteredAnns $ do+      bd <- if exactprintOnly+        then briDocMToPPM $ briDocByExactNoComment decl+        else do+          (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl+          mTell debugs+          mTell errs+          if null errs+            then pure r+            else briDocMToPPM $ briDocByExactNoComment decl+      layoutBriDoc bd++  let+    finalComments = filter+      (fst .> \case+        ExactPrint.AnnComment{} -> True+        _ -> False+      )+      post+  post `forM_` \case+    (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do+      ppmMoveToExactLoc l+      mTell $ Text.Builder.fromString cmStr+    (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->+      let+        folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of+          ExactPrint.AnnComment cm | span <- ExactPrint.commentIdentifier cm ->+            ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span+            , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span+            )+          _ -> (acc + y, x)+        (cmY, cmX) = foldl' folder (0, 0) finalComments+      in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)+    _ -> return ()++getDeclBindingNames :: LHsDecl GhcPs -> [String]+getDeclBindingNames (L _ decl) = case decl of+  SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)+  ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]+  _ -> []+++-- Prints the information associated with the module annotation+-- This includes the imports+ppPreamble+  :: GenLocated SrcSpan HsModule+  -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]+ppPreamble lmod@(L loc m@HsModule{}) = do+  filteredAnns <- mAsk <&> \annMap ->+    Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap+    -- Since ghc-exactprint adds annotations following (implicit)+    -- modules to both HsModule and the elements in the module+    -- this can cause duplication of comments. So strip+    -- attached annotations that come after the module's where+    -- from the module node+  config <- mAsk+  let+    shouldReformatPreamble =+      config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack++  let+    (filteredAnns', post) =+      case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of+        Nothing -> (filteredAnns, [])+        Just mAnn ->+          let+            modAnnsDp = ExactPrint.annsDP mAnn+            isWhere (ExactPrint.G AnnWhere) = True+            isWhere _ = False+            isEof (ExactPrint.AnnEofPos) = True+            isEof _ = False+            whereInd = List.findIndex (isWhere . fst) modAnnsDp+            eofInd = List.findIndex (isEof . fst) modAnnsDp+            (pre, post') = case (whereInd, eofInd) of+              (Nothing, Nothing) -> ([], modAnnsDp)+              (Just i, Nothing) -> List.splitAt (i + 1) modAnnsDp+              (Nothing, Just _i) -> ([], modAnnsDp)+              (Just i, Just j) -> List.splitAt (min (i + 1) j) modAnnsDp+            mAnn' = mAnn { ExactPrint.annsDP = pre }+            filteredAnns'' =+              Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns+          in (filteredAnns'', post')+  traceIfDumpConf+      "bridoc annotations filtered/transformed"+      _dconf_dump_annotations+    $ annsDoc filteredAnns'++  if shouldReformatPreamble+    then toLocal config filteredAnns' $ withTransformedAnns lmod $ do+      briDoc <- briDocMToPPM $ layoutModule lmod+      layoutBriDoc briDoc+    else+      let emptyModule = L loc m { hsmodDecls = [] }+      in MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule+  return post++_sigHead :: Sig GhcPs -> String+_sigHead = \case+  TypeSig _ names _ ->+    "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)+  _ -> "unknown sig"++_bindHead :: HsBind GhcPs -> String+_bindHead = \case+  FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)+  PatBind _ _pat _ ([], []) -> "PatBind smth"+  _ -> "unknown bind"++++layoutBriDoc :: BriDocNumbered -> PPMLocal ()+layoutBriDoc briDoc = do+  -- first step: transform the briDoc.+  briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do+    -- Note that briDoc is BriDocNumbered, but state type is BriDoc.+    -- That's why the alt-transform looks a bit special here.+    traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw+      $ briDocToDoc+      $ unwrapBriDocNumbered+      $ briDoc+    -- bridoc transformation: remove alts+    transformAlts briDoc >>= mSet+    mGet+      >>= briDocToDoc+      .> traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt+    -- bridoc transformation: float stuff in+    mGet >>= transformSimplifyFloating .> mSet+    mGet+      >>= briDocToDoc+      .> traceIfDumpConf+           "bridoc post-floating"+           _dconf_dump_bridoc_simpl_floating+    -- bridoc transformation: par removal+    mGet >>= transformSimplifyPar .> mSet+    mGet+      >>= briDocToDoc+      .> traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par+    -- bridoc transformation: float stuff in+    mGet >>= transformSimplifyColumns .> mSet+    mGet+      >>= briDocToDoc+      .> traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns+    -- bridoc transformation: indent+    mGet >>= transformSimplifyIndent .> mSet+    mGet+      >>= briDocToDoc+      .> traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent+    mGet+      >>= briDocToDoc+      .> traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final+    -- -- convert to Simple type+    -- simpl <- mGet <&> transformToSimple+    -- return simpl++  anns :: ExactPrint.Anns <- mAsk++  let+    state = LayoutState+      { _lstate_baseYs = [0]+      , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left+                                           -- here because moveToAnn stuff+                                           -- of the first node needs to do+                                           -- its thing properly.+      , _lstate_indLevels = [0]+      , _lstate_indLevelLinger = 0+      , _lstate_comments = anns+      , _lstate_commentCol = Nothing+      , _lstate_addSepSpace = Nothing+      , _lstate_commentNewlines = 0+      }++  state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'++  let+    remainingComments =+      [ c+      | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList+        (_lstate_comments state')+    -- With the new import layouter, we manually process comments+    -- without relying on the backend to consume the comments out of+    -- the state/map. So they will end up here, and we need to ignore+    -- them.+      , ExactPrint.unConName con /= "ImportDecl"+      , c <- extractAllComments elemAnns+      ]+  remainingComments+    `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)++  return $ ()
+ source/library/Brittany/Internal/Backend.hs view
@@ -0,0 +1,732 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Brittany.Internal.Backend where++import qualified Control.Monad.Trans.State.Strict as StateS+import qualified Data.Either as Either+import qualified Data.Foldable as Foldable+import qualified Data.IntMap.Lazy as IntMapL+import qualified Data.IntMap.Strict as IntMapS+import qualified Data.Map as Map+import qualified Data.Maybe as Maybe+import qualified Data.Semigroup as Semigroup+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified Data.Text.Lazy.Builder as Text.Builder+import qualified GHC.OldList as List+import Brittany.Internal.BackendUtils+import Brittany.Internal.Config.Types+import Brittany.Internal.LayouterBasics+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import Brittany.Internal.Utils+import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types++++type ColIndex = Int++data ColumnSpacing+  = ColumnSpacingLeaf Int+  | ColumnSpacingRef Int Int++type ColumnBlock a = [a]+type ColumnBlocks a = Seq [a]+type ColMap1+  = IntMapL.IntMap {- ColIndex -}+                   (Bool, ColumnBlocks ColumnSpacing)+type ColMap2+  = IntMapL.IntMap {- ColIndex -}+                   (Float, ColumnBlock Int, ColumnBlocks Int)+                                          -- (ratio of hasSpace, maximum, raw)++data ColInfo+  = ColInfoStart -- start value to begin the mapAccumL.+  | ColInfoNo BriDoc+  | ColInfo ColIndex ColSig [(Int, ColInfo)]++instance Show ColInfo where+  show ColInfoStart = "ColInfoStart"+  show (ColInfoNo bd) =+    "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")+  show (ColInfo ind sig list) =+    "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list++data ColBuildState = ColBuildState+  { _cbs_map :: ColMap1+  , _cbs_index :: ColIndex+  }++type LayoutConstraints m+  = ( MonadMultiReader Config m+    , MonadMultiReader ExactPrint.Types.Anns m+    , MonadMultiWriter Text.Builder.Builder m+    , MonadMultiWriter (Seq String) m+    , MonadMultiState LayoutState m+    )++layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()+layoutBriDocM = \case+  BDEmpty -> do+    return () -- can it be that simple+  BDLit t -> do+    layoutIndentRestorePostComment+    layoutRemoveIndentLevelLinger+    layoutWriteAppend t+  BDSeq list -> do+    list `forM_` layoutBriDocM+  -- in this situation, there is nothing to do about cols.+  -- i think this one does not happen anymore with the current simplifications.+  -- BDCols cSig list | BDPar sameLine lines <- List.last list ->+  --   alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines+  BDCols _ list -> do+    list `forM_` layoutBriDocM+  BDSeparator -> do+    layoutAddSepSpace+  BDAddBaseY indent bd -> do+    let+      indentF = case indent of+        BrIndentNone -> id+        BrIndentRegular -> layoutWithAddBaseCol+        BrIndentSpecial i -> layoutWithAddBaseColN i+    indentF $ layoutBriDocM bd+  BDBaseYPushCur bd -> do+    layoutBaseYPushCur+    layoutBriDocM bd+  BDBaseYPop bd -> do+    layoutBriDocM bd+    layoutBaseYPop+  BDIndentLevelPushCur bd -> do+    layoutIndentLevelPushCur+    layoutBriDocM bd+  BDIndentLevelPop bd -> do+    layoutBriDocM bd+    layoutIndentLevelPop+  BDEnsureIndent indent bd -> do+    let+      indentF = case indent of+        BrIndentNone -> id+        BrIndentRegular -> layoutWithAddBaseCol+        BrIndentSpecial i -> layoutWithAddBaseColN i+    indentF $ do+      layoutWriteEnsureBlock+      layoutBriDocM bd+  BDPar indent sameLine indented -> do+    layoutBriDocM sameLine+    let+      indentF = case indent of+        BrIndentNone -> id+        BrIndentRegular -> layoutWithAddBaseCol+        BrIndentSpecial i -> layoutWithAddBaseColN i+    indentF $ do+      layoutWriteNewlineBlock+      layoutBriDocM indented+  BDLines lines -> alignColsLines lines+  BDAlt [] -> error "empty BDAlt"+  BDAlt (alt : _) -> layoutBriDocM alt+  BDForceMultiline bd -> layoutBriDocM bd+  BDForceSingleline bd -> layoutBriDocM bd+  BDForwardLineMode bd -> layoutBriDocM bd+  BDExternal annKey subKeys shouldAddComment t -> do+    let+      tlines = Text.lines $ t <> Text.pack "\n"+      tlineCount = length tlines+    anns :: ExactPrint.Anns <- mAsk+    when shouldAddComment $ do+      layoutWriteAppend+        $ Text.pack+        $ "{-"+        ++ show (annKey, Map.lookup annKey anns)+        ++ "-}"+    zip [1 ..] tlines `forM_` \(i, l) -> do+      layoutWriteAppend $ l+      unless (i == tlineCount) layoutWriteNewlineBlock+    do+      state <- mGet+      let filterF k _ = not $ k `Set.member` subKeys+      mSet $ state+        { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state+        }+  BDPlain t -> do+    layoutWriteAppend t+  BDAnnotationPrior annKey bd -> do+    state <- mGet+    let m = _lstate_comments state+    let+      moveToExactLocationAction = case _lstate_curYOrAddNewline state of+        Left{} -> pure ()+        Right{} -> moveToExactAnn annKey+    mAnn <- do+      let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m+      mSet $ state+        { _lstate_comments = Map.adjust+          (\ann -> ann { ExactPrint.annPriorComments = [] })+          annKey+          m+        }+      return mAnn+    case mAnn of+      Nothing -> moveToExactLocationAction+      Just [] -> moveToExactLocationAction+      Just priors -> do+        -- layoutResetSepSpace+        priors+          `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->+                    when (comment /= "(" && comment /= ")") $ do+                      let commentLines = Text.lines $ Text.pack $ comment+                      case comment of+                        ('#' : _) ->+                          layoutMoveToCommentPos y (-999) (length commentLines)+                                   --  ^ evil hack for CPP+                        _ -> layoutMoveToCommentPos y x (length commentLines)+                      -- fixedX <- fixMoveToLineByIsNewline x+                      -- replicateM_ fixedX layoutWriteNewline+                      -- layoutMoveToIndentCol y+                      layoutWriteAppendMultiline commentLines+          -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }+        moveToExactLocationAction+    layoutBriDocM bd+  BDAnnotationKW annKey keyword bd -> do+    layoutBriDocM bd+    mComments <- do+      state <- mGet+      let m = _lstate_comments state+      let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m+      let+        mToSpan = case mAnn of+          Just anns | Maybe.isNothing keyword -> Just anns+          Just ((ExactPrint.Types.G kw1, _) : annR) | keyword == Just kw1 ->+            Just annR+          _ -> Nothing+      case mToSpan of+        Just anns -> do+          let+            (comments, rest) = flip spanMaybe anns $ \case+              (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)+              _ -> Nothing+          mSet $ state+            { _lstate_comments = Map.adjust+              (\ann -> ann { ExactPrint.annsDP = rest })+              annKey+              m+            }+          return $ nonEmpty comments+        _ -> return Nothing+    case mComments of+      Nothing -> pure ()+      Just comments -> do+        comments+          `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->+                    when (comment /= "(" && comment /= ")") $ do+                      let commentLines = Text.lines $ Text.pack $ comment+                      -- evil hack for CPP:+                      case comment of+                        ('#' : _) ->+                          layoutMoveToCommentPos y (-999) (length commentLines)+                        _ -> layoutMoveToCommentPos y x (length commentLines)+                      -- fixedX <- fixMoveToLineByIsNewline x+                      -- replicateM_ fixedX layoutWriteNewline+                      -- layoutMoveToIndentCol y+                      layoutWriteAppendMultiline commentLines+      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }+  BDAnnotationRest annKey bd -> do+    layoutBriDocM bd+    annMay <- do+      state <- mGet+      let m = _lstate_comments state+      pure $ Map.lookup annKey m+    let mComments = nonEmpty . extractAllComments =<< annMay+    let+      semiCount = length+        [ ()+        | Just ann <- [annMay]+        , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann+        ]+    shouldAddSemicolonNewlines <-+      mAsk+      <&> _conf_layout+      .> _lconfig_experimentalSemicolonNewlines+      .> confUnpack+    mModify $ \state -> state+      { _lstate_comments = Map.adjust+        (\ann -> ann+          { ExactPrint.annFollowingComments = []+          , ExactPrint.annPriorComments = []+          , ExactPrint.annsDP = flip filter (ExactPrint.annsDP ann) $ \case+            (ExactPrint.Types.AnnComment{}, _) -> False+            _ -> True+          }+        )+        annKey+        (_lstate_comments state)+      }+    case mComments of+      Nothing -> do+        when shouldAddSemicolonNewlines $ do+          [1 .. semiCount] `forM_` const layoutWriteNewline+      Just comments -> do+        comments+          `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->+                    when (comment /= "(" && comment /= ")") $ do+                      let commentLines = Text.lines $ Text.pack comment+                      case comment of+                        ('#' : _) -> layoutMoveToCommentPos y (-999) 1+                                   --  ^ evil hack for CPP+                        ")" -> pure ()+                                   --  ^ fixes the formatting of parens+                                   --    on the lhs of type alias defs+                        _ -> layoutMoveToCommentPos y x (length commentLines)+                      -- fixedX <- fixMoveToLineByIsNewline x+                      -- replicateM_ fixedX layoutWriteNewline+                      -- layoutMoveToIndentCol y+                      layoutWriteAppendMultiline commentLines+      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }+  BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do+    mDP <- do+      state <- mGet+      let m = _lstate_comments state+      let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m+      let+        relevant =+          [ dp+          | Just ann <- [mAnn]+          , (ExactPrint.Types.G kw1, dp) <- ann+          , keyword == kw1+          ]+      -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]+      case relevant of+        [] -> pure Nothing+        (ExactPrint.Types.DP (y, x) : _) -> do+          mSet state { _lstate_commentNewlines = 0 }+          pure $ Just (y - _lstate_commentNewlines state, x)+    case mDP of+      Nothing -> pure ()+      Just (y, x) ->+        -- we abuse this, as we probably will print the KW next, which is+        -- _not_ a comment..+        layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1+    layoutBriDocM bd+  BDNonBottomSpacing _ bd -> layoutBriDocM bd+  BDSetParSpacing bd -> layoutBriDocM bd+  BDForceParSpacing bd -> layoutBriDocM bd+  BDDebug s bd -> do+    mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"+    layoutBriDocM bd++briDocLineLength :: BriDoc -> Int+briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc+                          -- the state encodes whether a separator was already+                          -- appended at the current position.+ where+  rec = \case+    BDEmpty -> return $ 0+    BDLit t -> StateS.put False $> Text.length t+    BDSeq bds -> sum <$> rec `mapM` bds+    BDCols _ bds -> sum <$> rec `mapM` bds+    BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1+    BDAddBaseY _ bd -> rec bd+    BDBaseYPushCur bd -> rec bd+    BDBaseYPop bd -> rec bd+    BDIndentLevelPushCur bd -> rec bd+    BDIndentLevelPop bd -> rec bd+    BDPar _ line _ -> rec line+    BDAlt{} -> error "briDocLineLength BDAlt"+    BDForceMultiline bd -> rec bd+    BDForceSingleline bd -> rec bd+    BDForwardLineMode bd -> rec bd+    BDExternal _ _ _ t -> return $ Text.length t+    BDPlain t -> return $ Text.length t+    BDAnnotationPrior _ bd -> rec bd+    BDAnnotationKW _ _ bd -> rec bd+    BDAnnotationRest _ bd -> rec bd+    BDMoveToKWDP _ _ _ bd -> rec bd+    BDLines ls@(_ : _) -> do+      x <- StateS.get+      return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x+    BDLines [] -> error "briDocLineLength BDLines []"+    BDEnsureIndent _ bd -> rec bd+    BDSetParSpacing bd -> rec bd+    BDForceParSpacing bd -> rec bd+    BDNonBottomSpacing _ bd -> rec bd+    BDDebug _ bd -> rec bd++briDocIsMultiLine :: BriDoc -> Bool+briDocIsMultiLine briDoc = rec briDoc+ where+  rec :: BriDoc -> Bool+  rec = \case+    BDEmpty -> False+    BDLit _ -> False+    BDSeq bds -> any rec bds+    BDCols _ bds -> any rec bds+    BDSeparator -> False+    BDAddBaseY _ bd -> rec bd+    BDBaseYPushCur bd -> rec bd+    BDBaseYPop bd -> rec bd+    BDIndentLevelPushCur bd -> rec bd+    BDIndentLevelPop bd -> rec bd+    BDPar{} -> True+    BDAlt{} -> error "briDocIsMultiLine BDAlt"+    BDForceMultiline _ -> True+    BDForceSingleline bd -> rec bd+    BDForwardLineMode bd -> rec bd+    BDExternal _ _ _ t | [_] <- Text.lines t -> False+    BDExternal{} -> True+    BDPlain t | [_] <- Text.lines t -> False+    BDPlain _ -> True+    BDAnnotationPrior _ bd -> rec bd+    BDAnnotationKW _ _ bd -> rec bd+    BDAnnotationRest _ bd -> rec bd+    BDMoveToKWDP _ _ _ bd -> rec bd+    BDLines (_ : _ : _) -> True+    BDLines [_] -> False+    BDLines [] -> error "briDocIsMultiLine BDLines []"+    BDEnsureIndent _ bd -> rec bd+    BDSetParSpacing bd -> rec bd+    BDForceParSpacing bd -> rec bd+    BDNonBottomSpacing _ bd -> rec bd+    BDDebug _ bd -> rec bd++-- In theory+-- =========++-- .. this algorithm works roughly in these steps:+--+-- 1. For each line, get the (nested) column info, descending as far as+--    BDCols nodes go. The column info is a (rose) tree where the leafs+--    are arbitrary (non-BDCols) BriDocs.+-- 2. Walk through the lines and compare its column info with that of its+--    predecessor. If both are non-leafs and the column "signatures" align+--    (they don't align e.g. when they are totally different syntactical+--    structures or the number of children differs), mark these parts of+--    the two tree structures as connected and recurse to its children+--    (i.e. again comparing the children in this line with the children in+--    the previous line).+-- 3. What we now have is one tree per line, and connections between "same"+--    nodes between lines. These connection can span multiple lines.+--    We next look at spacing information. This is available at the leafs,+--    but in this step we aggregate _over connections_. At the top level, this+--    gives us one piece of data: How long would each line be, if we fully+--    aligned everything (kept all connections "active"). In contrast to+--    just taking the sum of all leafs for each tree, this line length includes+--    the spaces used for alignment.+-- 4. Treat those lines where alignment would result in overflowing of the+--    column limit. This "treatment" is currently configurable, and can e.g.+--    mean:+--    a) we stop alignment alltogether,+--    b) we remove alignment just from the overflowing lines,+--    c) we reduce the number of spaces inserted in overflowing lines using+--       some technique to make them not overflow, but without reducing the+--       space insertion to zero,+--    d) don't do anything+-- 5. Actually print the lines, walking over each tree and inserting spaces+--    according to the info and decisions gathered in the previous steps.+--+-- Possible improvements+-- =====================+--+-- - If alignment is disabled for specific lines, the aggregated per-connection+--   info of those lines is still retained and not recalculated. This can+--   result in spaces being inserted to create alignment with a line that+--   would overflow and thus gets disabled entirely.+--   An better approach would be to repeat step 3 after marking overflowing+--   lines as such, and not include the overflowing spacings as references+--   for non-overflowing ones. In the simplest case one additional iteration+--   would suffice, e.g. 1-2-3-4-3-5, but it would also be possible to refine+--   this and first remove alignment in the deepest parts of the tree for+--   overflowing lines, repeating and moving upwards until no lines are+--   anymore overflowing.+--   Further, it may make sense to break up connections when overflowing would+--   occur.+-- - It may also make sense to not filter all overflowing lines, but remove+--   them one-by-one and in each step recalculate the aggregated connection+--   spacing info. Because removing one overflowing line from the calculation+--   may very well cause another previously overflowing line to not overflow+--   any longer.+--   There is also a nasty optimization problem hiding in there (find the+--   minimal amount of alignment disabling that results in no overflows)+--   but that is overkill.+--+--   (with both these improvements there would be quite some repetition between+--   steps 3 and 4, but it should be possible to ensure termination. Still,+--   performance might become an issue as such an approach is not necessarily+--   linear in bridoc size any more.)+--+-- In practice+-- ===========+--+-- .. the current implementation is somewhat sloppy. Steps 1 and 2+-- are executed in one step, step 3 already applies one strategy that disables+-- certain connections (see `_lconfig_alignmentLimit`) and step 4 does some+-- of the calculations one might expect to occur in step 3. Steps 4 and 5+-- are executed in the same recursion, too.+-- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue+-- mentioned in the first "possible improvement".+alignColsLines :: LayoutConstraints m => [BriDoc] -> m ()+alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do+  -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs))+  curX <- do+    state <- mGet+    return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe+      0+      (_lstate_addSepSpace state)+  colMax <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack+  alignMax <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack+  alignBreak <-+    mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack+  case () of+    _ -> do+      -- tellDebugMess ("processedMap: " ++ show processedMap)+      sequence_+        $ List.intersperse layoutWriteEnsureNewlineBlock+        $ colInfos+        <&> processInfo colMax processedMap+     where+      (colInfos, finalState) =+        StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0)+      -- maxZipper :: [Int] -> [Int] -> [Int]+      -- maxZipper [] ys = ys+      -- maxZipper xs [] = xs+      -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr+      colAggregation :: [Int] -> Int+      colAggregation [] = 0 -- this probably cannot happen the way we call+                            -- this function, because _cbs_map only ever+                            -- contains nonempty Seqs.+      colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ]+        where alignMax' = max 0 alignMax++      processedMap :: ColMap2+      processedMap = fix $ \result ->+        _cbs_map finalState <&> \(lastFlag, colSpacingss) ->+          let+            colss = colSpacingss <&> \spss -> case reverse spss of+              [] -> []+              (xN : xR) ->+                reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR+             where+              fLast (ColumnSpacingLeaf len) = len+              fLast (ColumnSpacingRef len _) = len+              fInit (ColumnSpacingLeaf len) = len+              fInit (ColumnSpacingRef _ i) = case IntMapL.lookup i result of+                Nothing -> 0+                Just (_, maxs, _) -> sum maxs+            maxCols = {-Foldable.foldl1 maxZipper-}+              fmap colAggregation $ transpose $ Foldable.toList colss+            (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $+              mapAccumL (\acc x -> (acc + x, acc)) curX maxCols+            counter count l = if List.last posXs + List.last l <= colMax+              then count + 1+              else count+            ratio = fromIntegral (foldl counter (0 :: Int) colss)+              / fromIntegral (length colss)+          in (ratio, maxCols, colss)++      mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]+      mergeBriDocs bds = mergeBriDocsW ColInfoStart bds++      mergeBriDocsW+        :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]+      mergeBriDocsW _ [] = return []+      mergeBriDocsW lastInfo (bd : bdr) = do+        info <- mergeInfoBriDoc True lastInfo bd+        infor <- mergeBriDocsW+          -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)+          (if shouldBreakAfter bd then ColInfoStart else info)+          bdr+        return $ info : infor++      -- even with alignBreak config flag, we don't stop aligning for certain+      -- ColSigs - the ones with "False" below. The main reason is that+      -- there are uses of BDCols where they provide the alignment of several+      -- consecutive full larger code segments, for example ColOpPrefix.+      -- Motivating example is+      -- > foo+      -- >   $  [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa+      -- >      , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb+      -- >      ]+      -- >   ++ [ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ]+      -- If we break the alignment here, then all three lines for the first+      -- list move left by one, which is horrible. We really don't want to+      -- break whole-block alignments.+      -- For list, listcomp, tuple and tuples the reasoning is much simpler:+      -- alignment should not have much effect anyways, so i simply make the+      -- choice here that enabling alignment is the safer route for preventing+      -- potential glitches, and it should never have a negative effect.+      -- For RecUpdate the argument is much less clear - it is mostly a+      -- personal preference to not break alignment for those, even if+      -- multiline. Really, this should be configurable.. (TODO)+      shouldBreakAfter :: BriDoc -> Bool+      shouldBreakAfter bd = alignBreak && briDocIsMultiLine bd && case bd of+        (BDCols ColTyOpPrefix _) -> False+        (BDCols ColPatternsFuncPrefix _) -> True+        (BDCols ColPatternsFuncInfix _) -> True+        (BDCols ColPatterns _) -> True+        (BDCols ColCasePattern _) -> True+        (BDCols ColBindingLine{} _) -> True+        (BDCols ColGuard _) -> True+        (BDCols ColGuardedBody _) -> True+        (BDCols ColBindStmt _) -> True+        (BDCols ColDoLet _) -> True+        (BDCols ColRec _) -> False+        (BDCols ColRecUpdate _) -> False+        (BDCols ColRecDecl _) -> False+        (BDCols ColListComp _) -> False+        (BDCols ColList _) -> False+        (BDCols ColApp{} _) -> True+        (BDCols ColTuple _) -> False+        (BDCols ColTuples _) -> False+        (BDCols ColOpPrefix _) -> False+        _ -> True++      mergeInfoBriDoc+        :: Bool+        -> ColInfo+        -> BriDoc+        -> StateS.StateT ColBuildState Identity ColInfo+      mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag+      mergeInfoBriDoc lastFlag ColInfoNo{} = briDocToColInfo lastFlag+      mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =+        \case+          brdc@(BDCols colSig subDocs)+            | infoSig == colSig && length subLengthsInfos == length subDocs -> do+              let+                isLastList = if lastFlag+                  then (== length subDocs) <$> [1 ..]+                  else repeat False+              infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs+                `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd+              let curLengths = briDocLineLength <$> subDocs+              let trueSpacings = getTrueSpacings (zip curLengths infos)+              do -- update map+                s <- StateS.get+                let m = _cbs_map s+                let (Just (_, spaces)) = IntMapS.lookup infoInd m+                StateS.put s+                  { _cbs_map = IntMapS.insert+                    infoInd+                    (lastFlag, spaces Seq.|> trueSpacings)+                    m+                  }+              return $ ColInfo infoInd colSig (zip curLengths infos)+            | otherwise -> briDocToColInfo lastFlag brdc+          brdc -> return $ ColInfoNo brdc++briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo+briDocToColInfo lastFlag = \case+  BDCols sig list -> withAlloc lastFlag $ \ind -> do+    let+      isLastList =+        if lastFlag then (== length list) <$> [1 ..] else repeat False+    subInfos <- zip isLastList list `forM` uncurry briDocToColInfo+    let lengthInfos = zip (briDocLineLength <$> list) subInfos+    let trueSpacings = getTrueSpacings lengthInfos+    return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)+  bd -> return $ ColInfoNo bd++getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]+getTrueSpacings lengthInfos = lengthInfos <&> \case+  (len, ColInfo i _ _) -> ColumnSpacingRef len i+  (len, _) -> ColumnSpacingLeaf len++withAlloc+  :: Bool+  -> ( ColIndex+     -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)+     )+  -> StateS.State ColBuildState ColInfo+withAlloc lastFlag f = do+  cbs <- StateS.get+  let ind = _cbs_index cbs+  StateS.put $ cbs { _cbs_index = ind + 1 }+  (space, info) <- f ind+  StateS.get >>= \c -> StateS.put+    $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }+  return info++processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m ()+processInfo maxSpace m = \case+  ColInfoStart -> error "should not happen (TM)"+  ColInfoNo doc -> layoutBriDocM doc+  ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $+                        do+    colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack+    alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack+    curX <- do+      state <- mGet+      -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))+      let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state+      return $ case _lstate_curYOrAddNewline state of+        Left i -> case _lstate_commentCol state of+          Nothing -> spaceAdd + i+          Just c -> c+        Right{} -> spaceAdd+    let colMax = min colMaxConf (curX + maxSpace)+    -- tellDebugMess $ show curX+    let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m+    let+      maxCols2 = list <&> \case+        (_, ColInfo i _ _) ->+          let Just (_, ms, _) = IntMapS.lookup i m in sum ms+        (l, _) -> l+    let maxCols = zipWith max maxCols1 maxCols2+    let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols+    -- handle the cases that the vertical alignment leads to more than max+    -- cols:+    -- this is not a full fix, and we must correct individually in addition.+    -- because: the (at least) line with the largest element in the last+    -- column will always still overflow, because we just updated the column+    -- 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+    -- forced to occupy the full vertical space, not reduced by any factor.+    let+      fixedPosXs = case alignMode of+        ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+ curX)+         where+          factor :: Float =+            -- 0.0001 as an offering to the floating point gods.+                            min+            1.0001+            (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))+          offsets = (subtract curX) <$> posXs+          fixed = offsets <&> fromIntegral .> (* factor) .> truncate+        _ -> posXs+    let+      spacings =+        zipWith (-) (List.tail fixedPosXs ++ [min maxX colMax]) fixedPosXs+    -- tellDebugMess $ "ind = " ++ show ind+    -- tellDebugMess $ "maxCols = " ++ show maxCols+    -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs+    -- tellDebugMess $ "list = " ++ show list+    -- tellDebugMess $ "maxSpace = " ++ show maxSpace+    let+      alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do+        layoutWriteEnsureAbsoluteN destX+        processInfo s m (snd x)+      noAlignAct = list `forM_` (snd .> processInfoIgnore)+      animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $+                   if List.last fixedPosXs + fst (List.last list) > colMax+                                                                                                                                                                   -- per-item check if there is overflowing.+        then noAlignAct+        else alignAct+    case alignMode of+      ColumnAlignModeDisabled -> noAlignAct+      ColumnAlignModeUnanimously | maxX <= colMax -> alignAct+      ColumnAlignModeUnanimously -> noAlignAct+      ColumnAlignModeMajority limit | ratio >= limit -> animousAct+      ColumnAlignModeMajority{} -> noAlignAct+      ColumnAlignModeAnimouslyScale{} -> animousAct+      ColumnAlignModeAnimously -> animousAct+      ColumnAlignModeAlways -> alignAct++processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()+processInfoIgnore = \case+  ColInfoStart -> error "should not happen (TM)"+  ColInfoNo doc -> layoutBriDocM doc+  ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
+ source/library/Brittany/Internal/BackendUtils.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.BackendUtils where++import qualified Data.Data+import qualified Data.Either+import qualified Data.Map as Map+import qualified Data.Maybe+import qualified Data.Semigroup as Semigroup+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 Brittany.Internal.Config.Types+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import 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 ()+traceLocal _ = return ()+++layoutWriteAppend+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => Text+  -> m ()+layoutWriteAppend t = do+  traceLocal ("layoutWriteAppend", t)+  state <- mGet+  case _lstate_curYOrAddNewline state of+    Right i -> do+      replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"+    Left{} -> do+      return ()+  let spaces = fromMaybe 0 $ _lstate_addSepSpace state+  mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ')+  mTell $ Text.Builder.fromText $ t+  mModify $ \s -> s+    { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of+      Left c -> c + Text.length t + spaces+      Right{} -> Text.length t + spaces+    , _lstate_addSepSpace = Nothing+    }++layoutWriteAppendSpaces+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => Int+  -> m ()+layoutWriteAppendSpaces i = do+  traceLocal ("layoutWriteAppendSpaces", i)+  unless (i == 0) $ do+    state <- mGet+    mSet $ state+      { _lstate_addSepSpace = Just $ maybe i (+ i) $ _lstate_addSepSpace state+      }++layoutWriteAppendMultiline+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => [Text]+  -> m ()+layoutWriteAppendMultiline ts = do+  traceLocal ("layoutWriteAppendMultiline", ts)+  case ts of+    [] -> layoutWriteAppend (Text.pack "") -- need to write empty, too.+    (l : lr) -> do+      layoutWriteAppend l+      lr `forM_` \x -> do+        layoutWriteNewline+        layoutWriteAppend x++-- adds a newline and adds spaces to reach the base column.+layoutWriteNewlineBlock+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => m ()+layoutWriteNewlineBlock = do+  traceLocal ("layoutWriteNewlineBlock")+  state <- mGet+  mSet $ state+    { _lstate_curYOrAddNewline = Right 1+    , _lstate_addSepSpace = Just $ lstate_baseY state+    }++-- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m+--                     , MonadMultiWriter (Seq String) m) => Int -> m ()+-- layoutMoveToIndentCol i = do+-- #if INSERTTRACES+--   tellDebugMessShow ("layoutMoveToIndentCol", i)+-- #endif+--   state <- mGet+--   mSet $ state+--     { _lstate_addSepSpace = Just+--                           $ if isJust $ _lstate_addNewline state+--         then i+--         else _lstate_indLevelLinger state + i - _lstate_curY state+--     }++layoutSetCommentCol :: (MonadMultiState LayoutState m) => m ()+layoutSetCommentCol = do+  state <- mGet+  let+    col = case _lstate_curYOrAddNewline state of+      Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)+      Right{} -> lstate_baseY state+  traceLocal ("layoutSetCommentCol", col)+  unless (Data.Maybe.isJust $ _lstate_commentCol state)+    $ mSet state { _lstate_commentCol = Just col }++-- This is also used to move to non-comments in a couple of places. Seems+-- to be harmless so far..+layoutMoveToCommentPos+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => Int+  -> Int+  -> Int+  -> m ()+layoutMoveToCommentPos y x commentLines = do+  traceLocal ("layoutMoveToCommentPos", y, x, commentLines)+  state <- mGet+  mSet state+    { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of+      Left i -> if y == 0 then Left i else Right y+      Right{} -> Right y+    , _lstate_addSepSpace =+      Just $ if Data.Maybe.isJust (_lstate_commentCol state)+        then case _lstate_curYOrAddNewline state of+          Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x+          Right{} -> _lstate_indLevelLinger state + x+        else if y == 0 then x else _lstate_indLevelLinger state + x+    , _lstate_commentCol = Just $ case _lstate_commentCol state of+      Just existing -> existing+      Nothing -> case _lstate_curYOrAddNewline state of+        Left i -> i + fromMaybe 0 (_lstate_addSepSpace state)+        Right{} -> lstate_baseY state+    , _lstate_commentNewlines =+      _lstate_commentNewlines state + y + commentLines - 1+    }++-- | does _not_ add spaces to again reach the current base column.+layoutWriteNewline+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => m ()+layoutWriteNewline = do+  traceLocal ("layoutWriteNewline")+  state <- mGet+  mSet $ state+    { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of+      Left{} -> Right 1+      Right i -> Right (i + 1)+    , _lstate_addSepSpace = Nothing+    }++_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m ()+_layoutResetCommentNewlines = do+  mModify $ \state -> state { _lstate_commentNewlines = 0 }++layoutWriteEnsureNewlineBlock+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => m ()+layoutWriteEnsureNewlineBlock = do+  traceLocal ("layoutWriteEnsureNewlineBlock")+  state <- mGet+  mSet $ state+    { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of+      Left{} -> Right 1+      Right i -> Right $ max 1 i+    , _lstate_addSepSpace = Just $ lstate_baseY state+    , _lstate_commentCol = Nothing+    }++layoutWriteEnsureAbsoluteN+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => Int+  -> m ()+layoutWriteEnsureAbsoluteN n = do+  state <- mGet+  let+    diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of+      (Just c, _) -> n - c+      (Nothing, Left i) -> n - i+      (Nothing, Right{}) -> n+  traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)+  when (diff > 0) $ do+    mSet $ state { _lstate_addSepSpace = Just diff } -- this always sets to+                                            -- at least (Just 1), so we won't+                                            -- overwrite any old value in any+                                            -- bad way.++layoutBaseYPushInternal :: (MonadMultiState LayoutState m) => Int -> m ()+layoutBaseYPushInternal i = do+  traceLocal ("layoutBaseYPushInternal", i)+  mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }++layoutBaseYPopInternal :: (MonadMultiState LayoutState m) => m ()+layoutBaseYPopInternal = do+  traceLocal ("layoutBaseYPopInternal")+  mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }++layoutIndentLevelPushInternal :: (MonadMultiState LayoutState m) => Int -> m ()+layoutIndentLevelPushInternal i = do+  traceLocal ("layoutIndentLevelPushInternal", i)+  mModify $ \s -> s+    { _lstate_indLevelLinger = lstate_indLevel s+    , _lstate_indLevels = i : _lstate_indLevels s+    }++layoutIndentLevelPopInternal :: (MonadMultiState LayoutState m) => m ()+layoutIndentLevelPopInternal = do+  traceLocal ("layoutIndentLevelPopInternal")+  mModify $ \s -> s+    { _lstate_indLevelLinger = lstate_indLevel s+    , _lstate_indLevels = List.tail $ _lstate_indLevels s+    }++layoutRemoveIndentLevelLinger :: (MonadMultiState LayoutState m) => m ()+layoutRemoveIndentLevelLinger = do+  mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s }++layoutWithAddBaseCol+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiReader Config m+     )+  => m ()+  -> m ()+layoutWithAddBaseCol m = do+  amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+  state <- mGet+  layoutBaseYPushInternal $ lstate_baseY state + amount+  m+  layoutBaseYPopInternal++layoutWithAddBaseColBlock+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiReader Config m+     )+  => m ()+  -> m ()+layoutWithAddBaseColBlock m = do+  amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+  state <- mGet+  layoutBaseYPushInternal $ lstate_baseY state + amount+  layoutWriteEnsureBlock+  m+  layoutBaseYPopInternal++layoutWithAddBaseColNBlock+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => Int+  -> m ()+  -> m ()+layoutWithAddBaseColNBlock amount m = do+  traceLocal ("layoutWithAddBaseColNBlock", amount)+  state <- mGet+  layoutBaseYPushInternal $ lstate_baseY state + amount+  layoutWriteEnsureBlock+  m+  layoutBaseYPopInternal++layoutWriteEnsureBlock+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => m ()+layoutWriteEnsureBlock = do+  traceLocal ("layoutWriteEnsureBlock")+  state <- mGet+  let+    diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of+      (Nothing, Left i) -> lstate_baseY state - i+      (Nothing, Right{}) -> lstate_baseY state+      (Just sp, Left i) -> max sp (lstate_baseY state - i)+      (Just sp, Right{}) -> max sp (lstate_baseY state)+  -- when (diff>0) $ layoutWriteNewlineBlock+  when (diff > 0) $ do+    mSet $ state { _lstate_addSepSpace = Just $ diff }++layoutWithAddBaseColN+  :: (MonadMultiWriter Text.Builder.Builder m, MonadMultiState LayoutState m)+  => Int+  -> m ()+  -> m ()+layoutWithAddBaseColN amount m = do+  state <- mGet+  layoutBaseYPushInternal $ lstate_baseY state + amount+  m+  layoutBaseYPopInternal++layoutBaseYPushCur :: (MonadMultiState LayoutState m) => m ()+layoutBaseYPushCur = do+  traceLocal ("layoutBaseYPushCur")+  state <- mGet+  case _lstate_commentCol state of+    Nothing ->+      case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of+        (Left i, Just j) -> layoutBaseYPushInternal (i + j)+        (Left i, Nothing) -> layoutBaseYPushInternal i+        (Right{}, _) -> layoutBaseYPushInternal $ lstate_baseY state+    Just cCol -> layoutBaseYPushInternal cCol++layoutBaseYPop :: (MonadMultiState LayoutState m) => m ()+layoutBaseYPop = do+  traceLocal ("layoutBaseYPop")+  layoutBaseYPopInternal++layoutIndentLevelPushCur :: (MonadMultiState LayoutState m) => m ()+layoutIndentLevelPushCur = do+  traceLocal ("layoutIndentLevelPushCur")+  state <- mGet+  let+    y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of+      (Left i, Just j) -> i + j+      (Left i, Nothing) -> i+      (Right{}, Just j) -> j+      (Right{}, Nothing) -> 0+  layoutIndentLevelPushInternal y++layoutIndentLevelPop :: (MonadMultiState LayoutState m) => m ()+layoutIndentLevelPop = do+  traceLocal ("layoutIndentLevelPop")+  layoutIndentLevelPopInternal+  -- why are comment indentations relative to the previous indentation on+  -- the first node of an additional indentation, and relative to the outer+  -- indentation after the last node of some indented stuff? sure does not+  -- make sense.+  layoutRemoveIndentLevelLinger++layoutAddSepSpace :: (MonadMultiState LayoutState m) => m ()+layoutAddSepSpace = do+  state <- mGet+  mSet $ state+    { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state+    }++-- TODO: when refactoring is complete, the other version of this method+-- can probably be removed.+moveToExactAnn+  :: ( MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     , MonadMultiReader (Map AnnKey Annotation) m+     )+  => AnnKey+  -> m ()+moveToExactAnn annKey = do+  traceLocal ("moveToExactAnn", annKey)+  anns <- mAsk+  case Map.lookup annKey anns of+    Nothing -> return ()+    Just ann -> do+      -- curY <- mGet <&> _lstate_curY+      let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann+      -- mModify $ \state -> state { _lstate_addNewline = Just x }+      moveToY y++moveToY :: MonadMultiState LayoutState m => Int -> m ()+moveToY y = mModify $ \state ->+  let+    upd = case _lstate_curYOrAddNewline state of+      Left i -> if y == 0 then Left i else Right y+      Right i -> Right $ max y i+  in+    state+      { _lstate_curYOrAddNewline = upd+      , _lstate_addSepSpace = if Data.Either.isRight upd+        then _lstate_commentCol state <|> _lstate_addSepSpace state <|> Just+          (lstate_baseY state)+        else Nothing+      , _lstate_commentCol = Nothing+      }+-- fixMoveToLineByIsNewline :: MonadMultiState+--                                                   LayoutState m => Int -> m Int+-- fixMoveToLineByIsNewline x = do+--   newLineState <- mGet <&> _lstate_isNewline+--   return $ if newLineState == NewLineStateYes+--     then x-1+--     else x++ppmMoveToExactLoc+  :: MonadMultiWriter Text.Builder.Builder m => ExactPrint.DeltaPos -> m ()+ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do+  replicateM_ x $ mTell $ Text.Builder.fromString "\n"+  replicateM_ y $ mTell $ Text.Builder.fromString " "++-- TODO: update and use, or clean up. Currently dead code.+layoutWritePriorComments+  :: ( Data.Data.Data ast+     , MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     )+  => Located ast+  -> m ()+layoutWritePriorComments ast = do+  mAnn <- do+    state <- mGet+    let key = ExactPrint.mkAnnKey ast+    let anns = _lstate_comments state+    let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns+    mSet $ state+      { _lstate_comments = Map.adjust+        (\ann -> ann { ExactPrint.annPriorComments = [] })+        key+        anns+      }+    return mAnn+  case mAnn of+    Nothing -> return ()+    Just priors -> do+      unless (null priors) $ layoutSetCommentCol+      priors `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->+        do+          replicateM_ x layoutWriteNewline+          layoutWriteAppendSpaces y+          layoutWriteAppendMultiline $ Text.lines $ Text.pack comment++-- TODO: update and use, or clean up. Currently dead code.+-- this currently only extracs from the `annsDP` field of Annotations.+-- per documentation, this seems sufficient, as the+-- "..`annFollowingComments` are only added by AST transformations ..".+layoutWritePostComments+  :: ( Data.Data.Data ast+     , MonadMultiWriter Text.Builder.Builder m+     , MonadMultiState LayoutState m+     )+  => Located ast+  -> m ()+layoutWritePostComments ast = do+  mAnn <- do+    state <- mGet+    let key = ExactPrint.mkAnnKey ast+    let anns = _lstate_comments state+    let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns+    mSet $ state+      { _lstate_comments = Map.adjust+        (\ann -> ann { ExactPrint.annFollowingComments = [] })+        key+        anns+      }+    return mAnn+  case mAnn of+    Nothing -> return ()+    Just posts -> do+      unless (null posts) $ layoutSetCommentCol+      posts `forM_` \(ExactPrint.Comment comment _ _, ExactPrint.DP (x, y)) ->+        do+          replicateM_ x layoutWriteNewline+          layoutWriteAppend $ Text.pack $ replicate y ' '+          mModify $ \s -> s { _lstate_addSepSpace = Nothing }+          layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment++layoutIndentRestorePostComment+  :: (MonadMultiState LayoutState m, MonadMultiWriter Text.Builder.Builder m)+  => m ()+layoutIndentRestorePostComment = do+  state <- mGet+  let mCommentCol = _lstate_commentCol state+  let eCurYAddNL = _lstate_curYOrAddNewline state+  mModify+    $ \s -> s { _lstate_commentCol = Nothing, _lstate_commentNewlines = 0 }+  case (mCommentCol, eCurYAddNL) of+    (Just commentCol, Left{}) -> do+      layoutWriteEnsureNewlineBlock+      layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe+        0+        (_lstate_addSepSpace state)+    _ -> return ()++-- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,+--                                                MonadMultiWriter Text.Builder.Builder m,+--                                                MonadMultiState LayoutState m+--                                   , MonadMultiWriter (Seq String) m)+--                                 => Located ast -> m ()+-- layoutWritePriorCommentsRestore x = do+--   layoutWritePriorComments x+--   layoutIndentRestorePostComment+--+-- layoutWritePostCommentsRestore :: (Data.Data.Data ast,+--                                                MonadMultiWriter Text.Builder.Builder m,+--                                                MonadMultiState LayoutState m+--                                                , MonadMultiWriter (Seq String) m)+--                                 => Located ast -> m ()+-- layoutWritePostCommentsRestore x = do+--   layoutWritePostComments x+--   layoutIndentRestorePostComment
+ source/library/Brittany/Internal/Config.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Config where++import qualified Data.Bool as Bool+import qualified Data.ByteString as ByteString+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.Yaml+import qualified GHC.OldList as List+import Brittany.Internal.Config.Types+import Brittany.Internal.Config.Types.Instances ()+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Utils+import qualified System.Console.CmdArgs.Explicit as CmdArgs+import qualified System.Directory+import qualified System.Directory as Directory+import qualified System.FilePath.Posix as FilePath+import qualified System.IO+import UI.Butcher.Monadic++-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }+staticDefaultConfig :: Config+staticDefaultConfig = Config+  { _conf_version = coerce (1 :: Int)+  , _conf_debug = DebugConfig+    { _dconf_dump_config = coerce False+    , _dconf_dump_annotations = coerce False+    , _dconf_dump_ast_unknown = coerce False+    , _dconf_dump_ast_full = coerce False+    , _dconf_dump_bridoc_raw = coerce False+    , _dconf_dump_bridoc_simpl_alt = coerce False+    , _dconf_dump_bridoc_simpl_floating = coerce False+    , _dconf_dump_bridoc_simpl_par = coerce False+    , _dconf_dump_bridoc_simpl_columns = coerce False+    , _dconf_dump_bridoc_simpl_indent = coerce False+    , _dconf_dump_bridoc_final = coerce False+    , _dconf_roundtrip_exactprint_only = coerce False+    }+  , _conf_layout = LayoutConfig+    { _lconfig_cols = coerce (80 :: Int)+    , _lconfig_indentPolicy = coerce IndentPolicyFree+    , _lconfig_indentAmount = coerce (2 :: Int)+    , _lconfig_indentWhereSpecial = coerce True+    , _lconfig_indentListSpecial = coerce True+    , _lconfig_importColumn = coerce (50 :: Int)+    , _lconfig_importAsColumn = coerce (50 :: Int)+    , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)+    , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)+    , _lconfig_alignmentLimit = coerce (30 :: Int)+    , _lconfig_alignmentBreakOnMultiline = coerce True+    , _lconfig_hangingTypeSignature = coerce False+    , _lconfig_reformatModulePreamble = coerce True+    , _lconfig_allowSingleLineExportList = coerce False+    , _lconfig_allowHangingQuasiQuotes = coerce True+    , _lconfig_experimentalSemicolonNewlines = coerce False+    -- , _lconfig_allowSinglelineRecord     = coerce False+    }+  , _conf_errorHandling = ErrorHandlingConfig+    { _econf_produceOutputOnErrors = coerce False+    , _econf_Werror = coerce False+    , _econf_ExactPrintFallback = coerce ExactPrintFallbackModeInline+    , _econf_omit_output_valid_check = coerce False+    }+  , _conf_preprocessor = PreProcessorConfig+    { _ppconf_CPPMode = coerce CPPModeAbort+    , _ppconf_hackAroundIncludes = coerce False+    }+  , _conf_forward = ForwardOptions { _options_ghc = Identity [] }+  , _conf_roundtrip_exactprint_only = coerce False+  , _conf_disable_formatting = coerce False+  , _conf_obfuscate = coerce False+  }++forwardOptionsSyntaxExtsEnabled :: ForwardOptions+forwardOptionsSyntaxExtsEnabled = ForwardOptions+  { _options_ghc = Identity+    [ "-XLambdaCase"+    , "-XMultiWayIf"+    , "-XGADTs"+    , "-XPatternGuards"+    , "-XViewPatterns"+    , "-XTupleSections"+    , "-XExplicitForAll"+    , "-XImplicitParams"+    , "-XQuasiQuotes"+    , "-XTemplateHaskell"+    , "-XBangPatterns"+    , "-XTypeApplications"+    ]+  }++-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 }+cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe)+cmdlineConfigParser = do+  -- TODO: why does the default not trigger; ind never should be []!!+  ind <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")+  cols <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")+  importCol <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at")+  importAsCol <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at")++  dumpConfig <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)")+  dumpAnnotations <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")+  dumpUnknownAST <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")+  dumpCompleteAST <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")+  dumpBriDocRaw <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")+  dumpBriDocAlt <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")+  dumpBriDocPar <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")+  dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")+  dumpBriDocColumns <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")+  dumpBriDocIndent <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")+  dumpBriDocFinal <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")++  outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)")+  wError <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")+  omitValidCheck <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)")++  roundtripOnly <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)")++  optionsGhc <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")+  disableFormatting <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.")+  obfuscate <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.")++  return $ Config+    { _conf_version = mempty+    , _conf_debug = DebugConfig+      { _dconf_dump_config = wrapLast $ falseToNothing dumpConfig+      , _dconf_dump_annotations = wrapLast $ falseToNothing dumpAnnotations+      , _dconf_dump_ast_unknown = wrapLast $ falseToNothing dumpUnknownAST+      , _dconf_dump_ast_full = wrapLast $ falseToNothing dumpCompleteAST+      , _dconf_dump_bridoc_raw = wrapLast $ falseToNothing dumpBriDocRaw+      , _dconf_dump_bridoc_simpl_alt = wrapLast $ falseToNothing dumpBriDocAlt+      , _dconf_dump_bridoc_simpl_par = wrapLast $ falseToNothing dumpBriDocPar+      , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating+      , _dconf_dump_bridoc_simpl_columns = wrapLast $ falseToNothing dumpBriDocColumns+      , _dconf_dump_bridoc_simpl_indent = wrapLast $ falseToNothing dumpBriDocIndent+      , _dconf_dump_bridoc_final = wrapLast $ falseToNothing dumpBriDocFinal+      , _dconf_roundtrip_exactprint_only = mempty+      }+    , _conf_layout = LayoutConfig+      { _lconfig_cols = optionConcat cols+      , _lconfig_indentPolicy = mempty+      , _lconfig_indentAmount = optionConcat ind+      , _lconfig_indentWhereSpecial = mempty -- falseToNothing _+      , _lconfig_indentListSpecial = mempty -- falseToNothing _+      , _lconfig_importColumn = optionConcat importCol+      , _lconfig_importAsColumn = optionConcat importAsCol+      , _lconfig_altChooser = mempty+      , _lconfig_columnAlignMode = mempty+      , _lconfig_alignmentLimit = mempty+      , _lconfig_alignmentBreakOnMultiline = mempty+      , _lconfig_hangingTypeSignature = mempty+      , _lconfig_reformatModulePreamble = mempty+      , _lconfig_allowSingleLineExportList = mempty+      , _lconfig_allowHangingQuasiQuotes = mempty+      , _lconfig_experimentalSemicolonNewlines = mempty+      -- , _lconfig_allowSinglelineRecord     = mempty+      }+    , _conf_errorHandling = ErrorHandlingConfig+      { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors+      , _econf_Werror = wrapLast $ falseToNothing wError+      , _econf_ExactPrintFallback = mempty+      , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck+      }+    , _conf_preprocessor = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty }+    , _conf_forward = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] }+    , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly+    , _conf_disable_formatting = wrapLast $ falseToNothing disableFormatting+    , _conf_obfuscate = wrapLast $ falseToNothing obfuscate+    }+ where+  falseToNothing = Bool.bool Nothing (Just True)+  wrapLast :: Maybe a -> Maybe (Semigroup.Last a)+  wrapLast = fmap Semigroup.Last+  optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Maybe (f a)+  optionConcat = mconcat . fmap (pure . pure)++-- configParser :: Parser Config+-- configParser = Config+--   <$> option (eitherReader $ maybe (Left "required <int>!") Right . readMaybe)+--         (long "indent" <> value 2 <> metavar "AMOUNT" <> help "spaces per indentation level")+--   <*> (Bar+--     <$> switch (long "bara" <> help "bara help")+--     <*> switch (long "barb")+--     <*> flag 3 5 (long "barc")+--   )+--+-- configParserInfo :: ParserInfo Config+-- configParserInfo = ParserInfo+--   { infoParser      = configParser+--   , infoFullDesc    = True+--   , infoProgDesc    = return $ PP.text "a haskell code formatting utility based on ghc-exactprint"+--   , infoHeader      = return $ PP.text "brittany"+--   , infoFooter      = empty+--   , infoFailureCode = (-55)+--   , infoIntersperse = True+--   }+++-- | Reads a config from a file. If the file does not exist, returns+-- Nothing. If the file exists and parsing fails, prints to stderr and+-- aborts the MaybeT. Otherwise succeed via Just.+-- If the second parameter is True and the file does not exist, writes the+-- staticDefaultConfig to the file.+readConfig+  :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe))+readConfig path = do+  -- TODO: probably should catch IOErrors and then omit the existence check.+  exists <- liftIO $ System.Directory.doesFileExist path+  if exists+    then do+      contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.+      fileConf <- case Data.Yaml.decodeEither' contents of+        Left e -> do+          liftIO+            $ putStrErrLn+            $ "error reading in brittany config from "+            ++ path+            ++ ":"+          liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e)+          mzero+        Right x -> return x+      return $ Just fileConf+    else return $ Nothing++-- | Looks for a user-global config file and return its path.+-- If there is no global config in a system, one will be created.+userConfigPath :: IO System.IO.FilePath+userConfigPath = do+  userBritPathSimple <- Directory.getAppUserDataDirectory "brittany"+  userBritPathXdg <- Directory.getXdgDirectory Directory.XdgConfig "brittany"+  let searchDirs = [userBritPathSimple, userBritPathXdg]+  globalConfig <- Directory.findFileWith+    Directory.doesFileExist+    searchDirs+    "config.yaml"+  maybe (writeUserConfig userBritPathXdg) pure globalConfig+ where+  writeUserConfig dir = do+    let createConfPath = dir FilePath.</> "config.yaml"+    liftIO $ Directory.createDirectoryIfMissing True dir+    writeDefaultConfig $ createConfPath+    pure createConfPath++-- | Searches for a local (per-project) brittany config starting from a given directory+findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath)+findLocalConfigPath dir = do+  let dirParts = FilePath.splitDirectories dir+  -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"]+  let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts)+  Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml"++-- | Reads specified configs.+readConfigs+  :: CConfig Maybe        -- ^ Explicit options, take highest priority+  -> [System.IO.FilePath]  -- ^ List of config files to load and merge, highest priority first+  -> MaybeT IO Config+readConfigs cmdlineConfig configPaths = do+  configs <- readConfig `mapM` configPaths+  let+    merged =+      Semigroup.sconcat $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)+  return $ cZipWith fromOptionIdentity staticDefaultConfig merged++-- | Reads provided configs+-- but also applies the user default configuration (with lowest priority)+readConfigsWithUserConfig+  :: CConfig Maybe        -- ^ Explicit options, take highest priority+  -> [System.IO.FilePath]  -- ^ List of config files to load and merge, highest priority first+  -> MaybeT IO Config+readConfigsWithUserConfig cmdlineConfig configPaths = do+  defaultPath <- liftIO $ userConfigPath+  readConfigs cmdlineConfig (configPaths ++ [defaultPath])++writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m ()+writeDefaultConfig path =+  liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap+    (Just . runIdentity)+    staticDefaultConfig++showConfigYaml :: Config -> String+showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap+  (\(Identity x) -> Just x)
+ source/library/Brittany/Internal/Config/Types.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}++module 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 Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils ()++++confUnpack :: Coercible a b => Identity a -> b+confUnpack (Identity x) = coerce x++data CDebugConfig f = DebugConfig+  { _dconf_dump_config :: f (Semigroup.Last Bool)+  , _dconf_dump_annotations :: f (Semigroup.Last Bool)+  , _dconf_dump_ast_unknown :: f (Semigroup.Last Bool)+  , _dconf_dump_ast_full :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_raw :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_alt :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_par :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_columns :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_simpl_indent :: f (Semigroup.Last Bool)+  , _dconf_dump_bridoc_final :: f (Semigroup.Last Bool)+  , _dconf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)+  }+  deriving Generic++data CLayoutConfig f = LayoutConfig+  { _lconfig_cols :: f (Last Int) -- the thing that has default 80.+  , _lconfig_indentPolicy :: f (Last IndentPolicy)+  , _lconfig_indentAmount :: f (Last Int)+  , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO).+  , _lconfig_indentListSpecial :: f (Last Bool) -- use some special indentation for ","+                                                 -- when creating zero-indentation+                                                 -- multi-line list literals.+  , _lconfig_importColumn :: f (Last Int)+    -- ^ for import statement layouting, column at which to align the+    -- elements to be imported from a module.+    -- It is expected that importAsColumn >= importCol.+  , _lconfig_importAsColumn :: f (Last Int)+    -- ^ for import statement layouting, column at which put the module's+    -- "as" name (which also affects the positioning of the "as" keyword).+    -- It is expected that importAsColumn >= importCol.+  , _lconfig_altChooser :: f (Last AltChooser)+  , _lconfig_columnAlignMode :: f (Last ColumnAlignMode)+  , _lconfig_alignmentLimit :: f (Last Int)+    -- roughly speaking, this sets an upper bound to the number of spaces+    -- inserted to create horizontal alignment.+    -- More specifically, if 'xs' are the widths of the columns in some+    -- alignment-block, then the block will be aligned with the width+    -- maximum [ x | x <- xs, x < minimum xs + alignmentLimit ].+  , _lconfig_alignmentBreakOnMultiline :: f (Last Bool)+    -- stops alignment between items that are not layouted as a single line.+    -- e.g. for single-line alignment, things remain unchanged:+    --   do+    --     short       <- stuff+    --     loooooooong <- stuff+    -- but not in cases such as:+    --   do+    --     short <- some more stuff+    --       that requires two lines+    --     loooooooong <- stuff+  , _lconfig_hangingTypeSignature :: f (Last Bool)+    -- Do not put "::" in a new line, and use hanging indentation for the+    -- signature, i.e.:+    -- func :: SomeLongStuff+    --      -> SomeLongStuff+    -- instead of the usual+    -- func+    --   :: SomeLongStuff+    --   -> SomeLongStuff+    -- As usual for hanging indentation, the result will be+    -- context-sensitive (in the function name).+  , _lconfig_reformatModulePreamble :: f (Last Bool)+    -- whether the module preamble/header (module keyword, name, export list,+    -- import statements) are reformatted. If false, only the elements of the+    -- module (everything past the "where") are reformatted.+  , _lconfig_allowSingleLineExportList :: f (Last Bool)+    -- if true, and it fits in a single line, and there are no comments in the+    -- export list, the following layout will be used:+    -- > module MyModule (abc, def) where+    -- > [stuff]+    -- otherwise, the multi-line version is used:+    -- > module MyModule+    -- >   ( abc+    -- >   , def+    -- >   )+    -- > where+  , _lconfig_allowHangingQuasiQuotes :: f (Last Bool)+    -- if false, the layouter sees any splices as infinitely big and places+    -- them accordingly (in newlines, most likely); This also influences+    -- parent nodes.+    -- if true, the layouter is free to start a quasi-quotation at the end+    -- of a line.+    --+    -- false:+    -- > let+    -- >   body =+    -- >     [json|+    -- >     hello+    -- >     |]+    --+    -- true:+    -- > let body = [json|+    -- >     hello+    -- >     |]+  , _lconfig_experimentalSemicolonNewlines :: f (Last Bool)+    -- enables an experimental feature to turn semicolons in brace notation+    -- into newlines when using layout:+    --+    -- > do { a ;; b }+    --+    -- turns into+    -- > do+    -- >   a+    -- >+    -- >   b+    --+    -- 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+  --   -- >   }+  }+  deriving Generic++data CForwardOptions f = ForwardOptions+  { _options_ghc :: f [String]+  }+  deriving Generic++data CErrorHandlingConfig f = ErrorHandlingConfig+  { _econf_produceOutputOnErrors :: f (Semigroup.Last Bool)+  , _econf_Werror :: f (Semigroup.Last Bool)+  , _econf_ExactPrintFallback :: f (Semigroup.Last ExactPrintFallbackMode)+    -- ^ Determines when to fall back on the exactprint'ed output when+    -- syntactical constructs are encountered which are not yet handled by+    -- brittany.+    -- Note that the "risky" setting is risky because even with the check of+    -- the syntactic validity of the brittany output, at least in theory there+    -- may be cases where the output is syntactically/semantically valid but+    -- has different semantics than the code pre-transformation.+  , _econf_omit_output_valid_check :: f (Semigroup.Last Bool)+  }+  deriving Generic++data CPreProcessorConfig f = PreProcessorConfig+  { _ppconf_CPPMode :: f (Semigroup.Last CPPMode)+  , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool)+  }+  deriving Generic++data CConfig f = Config+  { _conf_version :: f (Semigroup.Last Int)+  , _conf_debug :: CDebugConfig f+  , _conf_layout :: CLayoutConfig f+  , _conf_errorHandling :: CErrorHandlingConfig f+  , _conf_forward :: CForwardOptions f+  , _conf_preprocessor :: CPreProcessorConfig f+  , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)+    -- ^ this field is somewhat of a duplicate of the one in DebugConfig.+    -- It is used for per-declaration disabling by the inline config+    -- implementation. Could have re-used the existing field, but felt risky+    -- to use a "debug" labeled field for non-debug functionality.+  , _conf_disable_formatting :: f (Semigroup.Last Bool)+    -- ^ Used for inline config that disables brittany entirely for this+    -- module. Useful for wildcard application+    -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something+    -- in that direction).+  , _conf_obfuscate :: f (Semigroup.Last Bool)+  }+  deriving Generic++type DebugConfig = CDebugConfig Identity+type LayoutConfig = CLayoutConfig Identity+type ForwardOptions = CForwardOptions Identity+type ErrorHandlingConfig = CErrorHandlingConfig Identity+type Config = CConfig Identity++-- i wonder if any Show1 stuff could be leveraged.+deriving instance Show (CDebugConfig Identity)+deriving instance Show (CLayoutConfig Identity)+deriving instance Show (CErrorHandlingConfig Identity)+deriving instance Show (CForwardOptions Identity)+deriving instance Show (CPreProcessorConfig Identity)+deriving instance Show (CConfig Identity)++deriving instance Show (CDebugConfig Maybe)+deriving instance Show (CLayoutConfig Maybe)+deriving instance Show (CErrorHandlingConfig Maybe)+deriving instance Show (CForwardOptions Maybe)+deriving instance Show (CPreProcessorConfig Maybe)+deriving instance Show (CConfig Maybe)++deriving instance Data (CDebugConfig Identity)+deriving instance Data (CLayoutConfig Identity)+deriving instance Data (CErrorHandlingConfig Identity)+deriving instance Data (CForwardOptions Identity)+deriving instance Data (CPreProcessorConfig Identity)+deriving instance Data (CConfig Identity)++deriving instance Data (CDebugConfig Maybe)+deriving instance Data (CLayoutConfig Maybe)+deriving instance Data (CErrorHandlingConfig Maybe)+deriving instance Data (CForwardOptions Maybe)+deriving instance Data (CPreProcessorConfig Maybe)+deriving instance Data (CConfig Maybe)++instance Semigroup.Semigroup (CDebugConfig Maybe) where+  (<>) = gmappend+instance Semigroup.Semigroup (CLayoutConfig Maybe) where+  (<>) = gmappend+instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where+  (<>) = gmappend+instance Semigroup.Semigroup (CForwardOptions Maybe) where+  (<>) = gmappend+instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where+  (<>) = gmappend+instance Semigroup.Semigroup (CConfig Maybe) where+  (<>) = gmappend++instance Semigroup.Semigroup (CDebugConfig Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CLayoutConfig Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CForwardOptions Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CPreProcessorConfig Identity) where+  (<>) = gmappend+instance Semigroup.Semigroup (CConfig Identity) where+  (<>) = gmappend++instance Monoid (CDebugConfig Maybe) where+  mempty = gmempty+instance Monoid (CLayoutConfig Maybe) where+  mempty = gmempty+instance Monoid (CErrorHandlingConfig Maybe) where+  mempty = gmempty+instance Monoid (CForwardOptions Maybe) where+  mempty = gmempty+instance Monoid (CPreProcessorConfig Maybe) where+  mempty = gmempty+instance Monoid (CConfig Maybe) where+  mempty = gmempty+++data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more+                                     -- than old indentation + amount+                  | IndentPolicyFree -- can create new indentations whereever+                  | IndentPolicyMultiple -- can create indentations only+                                         -- at any n * amount.+  deriving (Eq, Show, Generic, Data)++data AltChooser = AltChooserSimpleQuick -- always choose last alternative.+                                        -- leads to tons of sparsely filled+                                        -- lines.+                | AltChooserShallowBest -- choose the first matching alternative+                                        -- using the simplest spacing+                                        -- information for the children.+                | AltChooserBoundedSearch Int+                                        -- choose the first matching alternative+                                        -- using a bounded list of recursive+                                        -- options having sufficient space.+  deriving (Show, Generic, Data)++data ColumnAlignMode+  = ColumnAlignModeDisabled+    -- ^ Make no column alignments whatsoever+  | ColumnAlignModeUnanimously+    -- ^ Make column alignments only if it does not cause overflow for any of+    -- the affected lines.+  | ColumnAlignModeMajority Float+    -- ^ If at least (ratio::Float) of the aligned elements have sufficient+    -- space for the alignment, act like ColumnAlignModeAnimously; otherwise+    -- act like ColumnAlignModeDisabled.+  | ColumnAlignModeAnimouslyScale Int+    -- ^ Scale back columns to some degree if their sum leads to overflow.+    -- This is done in a linear fashion.+    -- The Int specifies additional columns to be added to column maximum for+    -- scaling calculation purposes.+  | ColumnAlignModeAnimously+    -- ^ Decide on a case-by-case basis if alignment would cause overflow.+    -- If it does, cancel all alignments for this (nested) column description.+  -- ColumnAlignModeAnimouslySome -- potentially to implement+  | ColumnAlignModeAlways+    -- ^ Always respect column alignments, even if it makes stuff overflow.+  deriving (Show, Generic, Data)++data CPPMode = CPPModeAbort  -- abort program on seeing -XCPP+             | CPPModeWarn   -- warn about CPP and non-roundtripping in its+                             -- presence.+             | CPPModeNowarn -- silently allow CPP, if possible (i.e. input is+                             -- file.)+  deriving (Show, Generic, Data)++data ExactPrintFallbackMode+  = ExactPrintFallbackModeNever  -- never fall back on exactprinting+  | ExactPrintFallbackModeInline -- fall back only if there are no newlines in+                                 -- the exactprint'ed output.+  | ExactPrintFallbackModeRisky  -- fall back even in the presence of newlines.+                                 -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF+                                 -- A PROGRAM BY TRANSFORMING IT.+  deriving (Show, Generic, Data)++deriveCZipWith ''CDebugConfig+deriveCZipWith ''CLayoutConfig+deriveCZipWith ''CErrorHandlingConfig+deriveCZipWith ''CForwardOptions+deriveCZipWith ''CPreProcessorConfig+deriveCZipWith ''CConfig++instance CFunctor CDebugConfig+instance CFunctor CLayoutConfig+instance CFunctor CErrorHandlingConfig+instance CFunctor CForwardOptions+instance CFunctor CPreProcessorConfig+instance CFunctor CConfig
+ source/library/Brittany/Internal/Config/Types/Instances.hs view
@@ -0,0 +1,131 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- These optimizations are disabled to improve compile times (and compilation+-- memory usage). When we do not disable them, the CI servers take more than+-- 10 minutes to compile this module alone.+-- Having looked into aeson and how the instances are written, I still do+-- not understand what makes GHC choke so much here. The size of the raw+-- expressions below looks fairly negligible, so there must be some expansion+-- due to inlining going on. But even disabling INLINE pragmas in aeson did+-- not seem to change anything.+-- Nonetheless, this solution works and has no downsides because the+-- instances defined here are not in any way performance-critical.+{-# OPTIONS_GHC -fno-pre-inlining #-}+{-# OPTIONS_GHC -fno-specialise #-}+{-# OPTIONS_GHC -fignore-interface-pragmas #-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Config.Types.Instances where++import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.Types as Aeson+import Data.Yaml+import Brittany.Internal.Config.Types+import Brittany.Internal.Prelude++++aesonDecodeOptionsBrittany :: Aeson.Options+aesonDecodeOptionsBrittany = Aeson.defaultOptions+  { Aeson.omitNothingFields = True+  , Aeson.fieldLabelModifier = dropWhile (== '_')+  }++instance FromJSON (CDebugConfig Maybe) where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON (CDebugConfig Maybe) where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany++instance FromJSON IndentPolicy where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON IndentPolicy where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany+  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany++instance FromJSON AltChooser where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON AltChooser where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany+  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany++instance FromJSON ColumnAlignMode where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON ColumnAlignMode where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany+  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany++instance FromJSON CPPMode where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON CPPMode where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany+  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany++instance FromJSON ExactPrintFallbackMode where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON ExactPrintFallbackMode where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany+  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany++instance FromJSON (CLayoutConfig Maybe) where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON (CLayoutConfig Maybe) where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany++instance FromJSON (CErrorHandlingConfig Maybe) where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON (CErrorHandlingConfig Maybe) where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany++instance FromJSON (CForwardOptions Maybe) where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON (CForwardOptions Maybe) where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany++instance FromJSON (CPreProcessorConfig Maybe) where+  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany++instance ToJSON (CPreProcessorConfig Maybe) where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany++instance ToJSON (CConfig Maybe) where+  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany++-- This custom instance ensures the "omitNothingFields" behaviour not only for+-- leafs, but for nodes of the config as well. This way e.g. "{}" is valid+-- config file content.+instance FromJSON (CConfig Maybe) where+  parseJSON (Object v) =+    Config+      <$> v+      .:? Key.fromString "conf_version"+      <*> v+      .:?= Key.fromString "conf_debug"+      <*> v+      .:?= Key.fromString "conf_layout"+      <*> v+      .:?= Key.fromString "conf_errorHandling"+      <*> v+      .:?= Key.fromString "conf_forward"+      <*> v+      .:?= Key.fromString "conf_preprocessor"+      <*> v+      .:? Key.fromString "conf_roundtrip_exactprint_only"+      <*> v+      .:? Key.fromString "conf_disable_formatting"+      <*> v+      .:? Key.fromString "conf_obfuscate"+  parseJSON invalid = Aeson.typeMismatch "Config" invalid++-- Pretends that the value is {} when the key is not present.+(.:?=) :: FromJSON a => Object -> Key.Key -> Parser a+o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure
+ source/library/Brittany/Internal/ExactPrintUtils.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Brittany.Internal.ExactPrintUtils where++import qualified Control.Monad.State.Class as State.Class+import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS+import Data.Data+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.Maybe+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import GHC (GenLocated(L))+import qualified GHC hiding (parseModule)+import qualified GHC.Driver.CmdLine as GHC+import GHC.Hs+import qualified GHC.Types.SrcLoc as GHC+import GHC.Types.SrcLoc (Located, SrcSpan)+import Brittany.Internal.Config.Types+import qualified Brittany.Internal.ParseModule as ParseModule+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint+import qualified System.IO++++parseModule+  :: [String]+  -> System.IO.FilePath+  -> (GHC.DynFlags -> IO (Either String a))+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))+parseModule args fp dynCheck = do+  str <- System.IO.readFile fp+  parseModuleFromString args fp dynCheck str++parseModuleFromString+  :: [String]+  -> System.IO.FilePath+  -> (GHC.DynFlags -> IO (Either String a))+  -> String+  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))+parseModuleFromString = ParseModule.parseModule+++commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()+commentAnnFixTransformGlob ast = do+  let+    extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)+    extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $+      const Seq.empty+        `SYB.ext1Q` (\l@(L span _) ->+                      Seq.singleton (span, ExactPrint.mkAnnKey l)+                    )+  let nodes = SYB.everything (<>) extract ast+  let+    annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey+    annsMap = Map.fromListWith+      (const id)+      [ (GHC.realSrcSpanEnd span, annKey)+      | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes+      ]+  nodes `forM_` (snd .> processComs annsMap)+ where+  processComs annsMap annKey1 = do+    mAnn <- State.Class.gets fst <&> Map.lookup annKey1+    mAnn `forM_` \ann1 -> do+      let+        priors = ExactPrint.annPriorComments ann1+        follows = ExactPrint.annFollowingComments ann1+        assocs = ExactPrint.annsDP ann1+      let+        processCom+          :: (ExactPrint.Comment, ExactPrint.DeltaPos)+          -> ExactPrint.TransformT Identity Bool+        processCom comPair@(com, _) =+          case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of+            comLoc -> case Map.lookupLE comLoc annsMap of+              Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of+                (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->+                  move $> False+                (x, y) | x == y -> move $> False+                _ -> return True+               where+                ExactPrint.AnnKey annKeyLoc1 con1 = annKey1+                ExactPrint.AnnKey annKeyLoc2 con2 = annKey2+                loc1 = GHC.realSrcSpanStart annKeyLoc1+                loc2 = GHC.realSrcSpanStart annKeyLoc2+                move = ExactPrint.modifyAnnsT $ \anns ->+                  let+                    ann2 = Data.Maybe.fromJust $ Map.lookup annKey2 anns+                    ann2' = ann2+                      { ExactPrint.annFollowingComments =+                        ExactPrint.annFollowingComments ann2 ++ [comPair]+                      }+                  in Map.insert annKey2 ann2' anns+              _ -> return True -- retain comment at current node.+      priors' <- filterM processCom priors+      follows' <- filterM processCom follows+      assocs' <- flip filterM assocs $ \case+        (ExactPrint.AnnComment com, dp) -> processCom (com, dp)+        _ -> return True+      let+        ann1' = ann1+          { ExactPrint.annPriorComments = priors'+          , ExactPrint.annFollowingComments = follows'+          , ExactPrint.annsDP = assocs'+          }+      ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns+++-- TODO: this is unused by now, but it contains one detail that+--       commentAnnFixTransformGlob does not include: Moving of comments for+--       "RecordUpd"s.+-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()+-- commentAnnFixTransform modul = SYB.everything (>>) genF modul+--  where+--   genF :: Data.Data.Data a => a -> ExactPrint.Transform ()+--   genF = (\_ -> return ()) `SYB.extQ` exprF+--   exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()+--   exprF lexpr@(L _ expr) = case expr of+-- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */+--     RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->+-- #else+--     RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) ->+-- #endif+--       moveTrailingComments lexpr (List.last fs)+-- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */+--     RecordUpd _ _e fs@(_:_) ->+-- #else+--     RecordUpd _e fs@(_:_) _cons _ _ _ ->+-- #endif+--       moveTrailingComments lexpr (List.last fs)+--     _ -> return ()++-- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()+-- commentAnnFixTransform modul = SYB.everything (>>) genF modul+--  where+--   genF :: Data.Data.Data a => a -> ExactPrint.Transform ()+--   genF = (\_ -> return ()) `SYB.extQ` exprF+--   exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()+--   exprF lexpr@(L _ expr) = case expr of+--     RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->+--       moveTrailingComments lexpr (List.last fs)+--     RecordUpd _ _e fs@(_:_) ->+--       moveTrailingComments lexpr (List.last fs)+--     _ -> return ()++-- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)+--                      => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()+-- moveTrailingComments astFrom astTo = do+--   let+--     k1 = ExactPrint.mkAnnKey astFrom+--     k2 = ExactPrint.mkAnnKey astTo+--     moveComments ans = ans'+--       where+--         an1 = Data.Maybe.fromJust $ Map.lookup k1 ans+--         an2 = Data.Maybe.fromJust $ Map.lookup k2 ans+--         cs1f = ExactPrint.annFollowingComments an1+--         cs2f = ExactPrint.annFollowingComments an2+--         (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)+--              $ \case+--                (ExactPrint.AnnComment com, dp) -> Left (com, dp)+--                x -> Right x+--         an1' = an1+--           { ExactPrint.annsDP               = nonComments+--           , ExactPrint.annFollowingComments = []+--           }+--         an2' = an2+--           { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments+--           }+--         ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans++--   ExactPrint.modifyAnnsT moveComments++-- | split a set of annotations in a module into a map from top-level module+-- elements to the relevant annotations. Avoids quadratic behaviour a trivial+-- implementation would have.+extractToplevelAnns+  :: Located HsModule+  -> ExactPrint.Anns+  -> Map ExactPrint.AnnKey ExactPrint.Anns+extractToplevelAnns lmod anns = output+ where+  (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod+  declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey+  declMap1 = Map.unions $ ldecls <&> \ldecl ->+    Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl)+  declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey+  declMap2 =+    Map.fromList+      $ [ (captured, declMap1 Map.! k)+        | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns+        ]+  declMap = declMap1 `Map.union` declMap2+  modKey = ExactPrint.mkAnnKey lmod+  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 f = Map.foldlWithKey'+  (\m k a -> Map.alter (insert k a) (f k a) m)+  Map.empty+ where+  insert k a Nothing = Just (Map.singleton k a)+  insert k a (Just m) = Just (Map.insert k a m)++foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey+foldedAnnKeys ast = SYB.everything+  Set.union+  (\x -> maybe+    Set.empty+    Set.singleton+    [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x+    | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)+    , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x+    ]+      -- 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+      -- SrcSpan.+  )+  ast+  where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))+++withTransformedAnns+  :: Data ast+  => ast+  -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a+  -> MultiRWSS.MultiRWS '[Config , ExactPrint.Anns] w s a+withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case+  readers@(conf :+: anns :+: HNil) -> do+    -- TODO: implement `local` for MultiReader/MultiRWS+    MultiRWSS.mPutRawR (conf :+: f anns :+: HNil)+    x <- m+    MultiRWSS.mPutRawR readers+    pure x+ where+  f anns =+    let+      ((), (annsBalanced, _), _) =+        ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)+    in annsBalanced+++warnExtractorCompat :: GHC.Warn -> String+warnExtractorCompat (GHC.Warn _ (L _ s)) = s
+ source/library/Brittany/Internal/LayouterBasics.hs view
@@ -0,0 +1,781 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.LayouterBasics where++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.Semigroup as Semigroup+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+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 GHC.Parser.Annotation (AnnKeywordId(..))+import GHC.Types.Name (getOccString)+import GHC.Types.Name.Occurrence (occNameString)+import GHC.Types.Name.Reader (RdrName(..))+import qualified GHC.Types.SrcLoc as GHC+import Brittany.Internal.Config.Types+import Brittany.Internal.ExactPrintUtils+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import Brittany.Internal.Utils+import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+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+import Language.Haskell.GHC.ExactPrint.Types (AnnKey, Annotation)+import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils++++processDefault+  :: ( ExactPrint.Annotate.Annotate ast+     , MonadMultiWriter Text.Builder.Builder m+     , MonadMultiReader ExactPrint.Types.Anns m+     )+  => Located ast+  -> m ()+processDefault x = do+  anns <- mAsk+  let str = ExactPrint.exactPrint x anns+  -- this hack is here so our print-empty-module trick does not add+  -- a newline at the start if there actually is no module header / imports+  -- / anything.+  -- TODO: instead the appropriate annotation could be removed when "cleaning"+  --       the module (header). This would remove the need for this hack!+  case str of+    "\n" -> return ()+    _ -> mTell $ Text.Builder.fromString str++-- | Use ExactPrint's output for this node; add a newly generated inline comment+-- at insertion position (meant to point out to the user that this node is+-- not handled by brittany yet). Useful when starting implementing new+-- syntactic constructs when children are not handled yet.+briDocByExact+  :: (ExactPrint.Annotate.Annotate ast)+  => Located ast+  -> ToBriDocM BriDocNumbered+briDocByExact ast = do+  anns <- mAsk+  traceIfDumpConf+    "ast"+    _dconf_dump_ast_unknown+    (printTreeWithCustom 100 (customLayouterF anns) ast)+  docExt ast anns True++-- | Use ExactPrint's output for this node.+-- Consider that for multi-line input, the indentation of the code produced+-- by ExactPrint might be different, and even incompatible with the indentation+-- of its surroundings as layouted by brittany. But there are safe uses of+-- this, e.g. for any top-level declarations.+briDocByExactNoComment+  :: (ExactPrint.Annotate.Annotate ast)+  => Located ast+  -> ToBriDocM BriDocNumbered+briDocByExactNoComment ast = do+  anns <- mAsk+  traceIfDumpConf+    "ast"+    _dconf_dump_ast_unknown+    (printTreeWithCustom 100 (customLayouterF anns) ast)+  docExt ast anns False++-- | Use ExactPrint's output for this node, presuming that this output does+-- not contain any newlines. If this property is not met, the semantics+-- depend on the @econf_AllowRiskyExactPrintUse@ config flag.+briDocByExactInlineOnly+  :: (ExactPrint.Annotate.Annotate ast)+  => String+  -> Located ast+  -> ToBriDocM BriDocNumbered+briDocByExactInlineOnly infoStr ast = do+  anns <- mAsk+  traceIfDumpConf+    "ast"+    _dconf_dump_ast_unknown+    (printTreeWithCustom 100 (customLayouterF anns) ast)+  let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns+  fallbackMode <-+    mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack+  let+    exactPrintNode t = allocateNode $ BDFExternal+      (ExactPrint.Types.mkAnnKey ast)+      (foldedAnnKeys ast)+      False+      t+  let+    errorAction = do+      mTell [ErrorUnknownNode infoStr ast]+      docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"+  case (fallbackMode, Text.lines exactPrinted) of+    (ExactPrintFallbackModeNever, _) -> errorAction+    (_, [t]) -> exactPrintNode+      (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)+    (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted+    _ -> errorAction++rdrNameToText :: RdrName -> Text+-- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr+rdrNameToText (Unqual occname) = Text.pack $ occNameString occname+rdrNameToText (Qual mname occname) =+  Text.pack $ moduleNameString mname ++ "." ++ occNameString occname+rdrNameToText (Orig modul occname) =+  Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname+rdrNameToText (Exact name) = Text.pack $ getOccString name++lrdrNameToText :: GenLocated l RdrName -> Text+lrdrNameToText (L _ n) = rdrNameToText n++lrdrNameToTextAnnGen+  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)+  => (Text -> Text)+  -> Located RdrName+  -> m Text+lrdrNameToTextAnnGen f ast@(L _ n) = do+  anns <- mAsk+  let t = f $ rdrNameToText n+  let+    hasUni x (ExactPrint.Types.G y, _) = x == y+    hasUni _ _ = False+  -- TODO: in general: we should _always_ process all annotaiton stuff here.+  --       whatever we don't probably should have had some effect on the+  --       output. in such cases, resorting to byExact is probably the safe+  --       choice.+  return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of+    Nothing -> t+    Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of+      Exact{} | t == Text.pack "()" -> t+      _ | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"+      _ | any (hasUni AnnCommaTuple) aks -> t+      _ | any (hasUni AnnOpenP) aks -> Text.pack "(" <> t <> Text.pack ")"+      _ | otherwise -> t++lrdrNameToTextAnn+  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)+  => Located RdrName+  -> m Text+lrdrNameToTextAnn = lrdrNameToTextAnnGen id++lrdrNameToTextAnnTypeEqualityIsSpecial+  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)+  => Located RdrName+  -> m Text+lrdrNameToTextAnnTypeEqualityIsSpecial ast = do+  let+    f x = if x == Text.pack "Data.Type.Equality~"+      then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh+      else x+  lrdrNameToTextAnnGen f ast++-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects+-- the annotations for a (parent) node for a tick to be added to the+-- literal.+-- Excessively long name to reflect on us having to work around such+-- excessively obscure special cases in the exactprint API.+lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick+  :: ( Data ast+     , MonadMultiReader Config m+     , MonadMultiReader (Map AnnKey Annotation) m+     )+  => Located ast+  -> Located RdrName+  -> m Text+lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do+  hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote+  x <- lrdrNameToTextAnn ast2+  let+    lit = if x == Text.pack "Data.Type.Equality~"+      then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh+      else x+  return $ if hasQuote then Text.cons '\'' lit else lit++askIndent :: (MonadMultiReader Config m) => m Int+askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk+++extractAllComments+  :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]+extractAllComments ann =+  ExactPrint.annPriorComments ann ++ extractRestComments ann++extractRestComments+  :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]+extractRestComments ann =+  ExactPrint.annFollowingComments ann+    ++ (ExactPrint.annsDP ann >>= \case+         (ExactPrint.AnnComment com, dp) -> [(com, dp)]+         _ -> []+       )++filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns+filterAnns ast = Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)++-- | True if there are any comments that are+-- a) connected to any node below (in AST sense) the given node AND+-- b) after (in source code order) the node.+hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool+hasAnyCommentsBelow ast@(L l _) =+  List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)+    <$> astConnectedComments ast++hasCommentsBetween+  :: Data ast+  => GHC.Located ast+  -> AnnKeywordId+  -> AnnKeywordId+  -> ToBriDocM Bool+hasCommentsBetween ast leftKey rightKey = do+  mAnn <- astAnn ast+  let+    go1 [] = False+    go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest+    go1 (_ : rest) = go1 rest+    go2 [] = False+    go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True+    go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False+    go2 (_ : rest) = go2 rest+  case mAnn of+    Nothing -> pure False+    Just ann -> pure $ go1 $ ExactPrint.annsDP ann++-- | True if there are any comments that are connected to any node below (in AST+--   sense) the given node+hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool+hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast++-- | True if there are any regular comments connected to any node below (in AST+--   sense) the given node+hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool+hasAnyRegularCommentsConnected ast =+  any isRegularComment <$> astConnectedComments ast++-- | Regular comments are comments that are actually "source code comments",+-- i.e. things that start with "--" or "{-". In contrast to comment-annotations+-- used by ghc-exactprint for capturing symbols (and their exact positioning).+--+-- Only the type instance layouter makes use of this filter currently, but+-- it might make sense to apply it more aggressively or make it the default -+-- I believe that most of the time we branch on the existence of comments, we+-- only care about "regular" comments. We simply did not need the distinction+-- because "irregular" comments are not that common outside of type/data decls.+isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool+isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst++astConnectedComments+  :: Data ast+  => GHC.Located ast+  -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)]+astConnectedComments ast = do+  anns <- filterAnns ast <$> mAsk+  pure $ extractAllComments =<< Map.elems anns++hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool+hasAnyCommentsPrior ast = astAnn ast <&> \case+  Nothing -> False+  Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors++hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool+hasAnyRegularCommentsRest ast = astAnn ast <&> \case+  Nothing -> False+  Just ann -> any isRegularComment (extractRestComments ann)++hasAnnKeywordComment+  :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool+hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case+  Nothing -> False+  Just ann -> any hasK (extractAllComments ann)+  where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst++hasAnnKeyword+  :: (Data a, MonadMultiReader (Map AnnKey Annotation) m)+  => Located a+  -> AnnKeywordId+  -> m Bool+hasAnnKeyword ast annKeyword = astAnn ast <&> \case+  Nothing -> False+  Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks+ where+  hasK (ExactPrint.Types.G x, _) = x == annKeyword+  hasK _ = False++astAnn+  :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)+  => GHC.Located ast+  -> m (Maybe Annotation)+astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk++-- new BriDoc stuff++allocateNode+  :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered+allocateNode bd = do+  i <- allocNodeIndex+  return (i, bd)++allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int+allocNodeIndex = do+  NodeAllocIndex i <- mGet+  mSet $ NodeAllocIndex (i + 1)+  return i++-- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered+-- docEmpty = allocateNode BDFEmpty+--+-- docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered+-- docLit t = allocateNode $ BDFLit t+--+-- docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m)+--        => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered+-- docExt x anns shouldAddComment = allocateNode $ BDFExternal+--                   (ExactPrint.Types.mkAnnKey x)+--                   (foldedAnnKeys x)+--                   shouldAddComment+--                   (Text.pack $ ExactPrint.exactPrint x anns)+--+-- docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered+-- docAlt l = allocateNode . BDFAlt =<< sequence l+--+--+-- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered+-- docSeq l = allocateNode . BDFSeq =<< sequence l+--+-- docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered+-- docLines l = allocateNode . BDFLines =<< sequence l+--+-- docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered+-- docCols sig l = allocateNode . BDFCols sig =<< sequence l+--+-- docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered+-- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm+--+-- docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm+--+-- docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm+--+-- docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered+-- docSeparator = allocateNode BDFSeparator+--+-- docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered+-- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm+--+-- docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered+-- docAnnotationPost  annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm+--+-- docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm+--+-- appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- appSep x = docSeq [x, docSeparator]+--+-- docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered+-- docCommaSep = appSep $ docLit $ Text.pack ","+--+-- docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered+-- docParenLSep = appSep $ docLit $ Text.pack "("+--+--+-- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m)+--                => Located ast+--                -> m BriDocNumbered+--                -> m BriDocNumbered+-- docPostComment ast bdm = do+--   bd <- bdm+--   allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd+--+-- docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m)+--             => Located ast+--             -> m BriDocNumbered+--             -> m BriDocNumbered+-- docWrapNode ast bdm = do+--   bd <- bdm+--   i1 <- allocNodeIndex+--   i2 <- allocNodeIndex+--   return+--     $ (,) i1+--     $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)+--     $ (,) i2+--     $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)+--     $ bd+--+-- docPar :: MonadMultiState NodeAllocIndex m+--        => m BriDocNumbered+--        -> m BriDocNumbered+--        -> m BriDocNumbered+-- docPar lineM indentedM = do+--   line <- lineM+--   indented <- indentedM+--   allocateNode $ BDFPar BrIndentNone line indented+--+-- docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm+--+-- docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered+-- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm+--+-- docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered+-- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd++docEmpty :: ToBriDocM BriDocNumbered+docEmpty = allocateNode BDFEmpty++docLit :: Text -> ToBriDocM BriDocNumbered+docLit t = allocateNode $ BDFLit t++docLitS :: String -> ToBriDocM BriDocNumbered+docLitS s = allocateNode $ BDFLit $ Text.pack s++docExt+  :: (ExactPrint.Annotate.Annotate ast)+  => Located ast+  -> ExactPrint.Types.Anns+  -> Bool+  -> ToBriDocM BriDocNumbered+docExt x anns shouldAddComment = allocateNode $ BDFExternal+  (ExactPrint.Types.mkAnnKey x)+  (foldedAnnKeys x)+  shouldAddComment+  (Text.pack $ ExactPrint.exactPrint x anns)++docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered+docAlt l = allocateNode . BDFAlt =<< sequence l++newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)+  deriving (Functor, Applicative, Monad)++addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()+addAlternativeCond cond doc = when cond (addAlternative doc)++addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()+addAlternative = CollectAltM . Writer.tell . (: [])++runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered+runFilteredAlternative (CollectAltM action) = docAlt $ Writer.execWriter action+++docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered+docSeq [] = docEmpty+docSeq l = allocateNode . BDFSeq =<< sequence l++docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered+docLines l = allocateNode . BDFLines =<< sequence l++docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered+docCols sig l = allocateNode . BDFCols sig =<< sequence l++docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm++docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docSetBaseY bdm = do+  bd <- bdm+  -- the order here is important so that these two nodes can be treated+  -- properly over at `transformAlts`.+  n1 <- allocateNode $ BDFBaseYPushCur bd+  n2 <- allocateNode $ BDFBaseYPop n1+  return n2++docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docSetIndentLevel bdm = do+  bd <- bdm+  n1 <- allocateNode $ BDFIndentLevelPushCur bd+  n2 <- allocateNode $ BDFIndentLevelPop n1+  return n2++docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docSetBaseAndIndent = docSetBaseY . docSetIndentLevel++docSeparator :: ToBriDocM BriDocNumbered+docSeparator = allocateNode BDFSeparator++docAnnotationPrior+  :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docAnnotationPrior annKey bdm =+  allocateNode . BDFAnnotationPrior annKey =<< bdm++docAnnotationKW+  :: AnnKey+  -> Maybe AnnKeywordId+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+docAnnotationKW annKey kw bdm =+  allocateNode . BDFAnnotationKW annKey kw =<< bdm++docMoveToKWDP+  :: AnnKey+  -> AnnKeywordId+  -> Bool+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+docMoveToKWDP annKey kw shouldRestoreIndent bdm =+  allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm++docAnnotationRest+  :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm++docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm++docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm++docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm++docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm++docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docDebug s bdm = allocateNode . BDFDebug s =<< bdm++appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+appSep x = docSeq [x, docSeparator]++docCommaSep :: ToBriDocM BriDocNumbered+docCommaSep = appSep $ docLit $ Text.pack ","++docParenLSep :: ToBriDocM BriDocNumbered+docParenLSep = appSep docParenL++-- TODO: we don't make consistent use of these (yet). However, I think the+-- most readable approach overall might be something else: define+-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`.+-- I think those two would make the usage most readable.+-- lit "("  and  appSep (lit "(")  are understandable and short without+-- introducing a new top-level binding for all types of parentheses.+docParenL :: ToBriDocM BriDocNumbered+docParenL = docLit $ Text.pack "("++docParenR :: ToBriDocM BriDocNumbered+docParenR = docLit $ Text.pack ")"++docParenHashLSep :: ToBriDocM BriDocNumbered+docParenHashLSep = docSeq [docLit $ Text.pack "(#", docSeparator]++docParenHashRSep :: ToBriDocM BriDocNumbered+docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]++docBracketL :: ToBriDocM BriDocNumbered+docBracketL = docLit $ Text.pack "["++docBracketR :: ToBriDocM BriDocNumbered+docBracketR = docLit $ Text.pack "]"+++docTick :: ToBriDocM BriDocNumbered+docTick = docLit $ Text.pack "'"++docNodeAnnKW+  :: Data.Data.Data ast+  => Located ast+  -> Maybe AnnKeywordId+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+docNodeAnnKW ast kw bdm =+  docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm++docNodeMoveToKWDP+  :: Data.Data.Data ast+  => Located ast+  -> AnnKeywordId+  -> Bool+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =+  docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm++class DocWrapable a where+  docWrapNode :: ( Data.Data.Data ast)+              => Located ast+              -> a+              -> a+  docWrapNodePrior :: ( Data.Data.Data ast)+                   => Located ast+                   -> a+                   -> a+  docWrapNodeRest  :: ( Data.Data.Data ast)+                   => Located ast+                   -> a+                   -> a++instance DocWrapable (ToBriDocM BriDocNumbered) where+  docWrapNode ast bdm = do+    bd <- bdm+    i1 <- allocNodeIndex+    i2 <- allocNodeIndex+    return+      $ (,) i1+      $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)+      $ (,) i2+      $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)+      $ bd+  docWrapNodePrior ast bdm = do+    bd <- bdm+    i1 <- allocNodeIndex+    return $ (,) i1 $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast) $ bd+  docWrapNodeRest ast bdm = do+    bd <- bdm+    i2 <- allocNodeIndex+    return $ (,) i2 $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd++instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where+  docWrapNode ast bdms = case bdms of+    [] -> []+    [bd] -> [docWrapNode ast bd]+    (bd1 : bdR) | (bdN : bdM) <- reverse bdR ->+      [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]+    _ -> error "cannot happen (TM)"+  docWrapNodePrior ast bdms = case bdms of+    [] -> []+    [bd] -> [docWrapNodePrior ast bd]+    (bd1 : bdR) -> docWrapNodePrior ast bd1 : bdR+  docWrapNodeRest ast bdms = case reverse bdms of+    [] -> []+    (bdN : bdR) -> reverse $ docWrapNodeRest ast bdN : bdR++instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where+  docWrapNode ast bdsm = do+    bds <- bdsm+    case bds of+      [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well.+      [bd] -> do+        bd' <- docWrapNode ast (return bd)+        return [bd']+      (bd1 : bdR) | (bdN : bdM) <- reverse bdR -> do+        bd1' <- docWrapNodePrior ast (return bd1)+        bdN' <- docWrapNodeRest ast (return bdN)+        return $ [bd1'] ++ reverse bdM ++ [bdN']+      _ -> error "cannot happen (TM)"+  docWrapNodePrior ast bdsm = do+    bds <- bdsm+    case bds of+      [] -> return []+      (bd1 : bdR) -> do+        bd1' <- docWrapNodePrior ast (return bd1)+        return (bd1' : bdR)+  docWrapNodeRest ast bdsm = do+    bds <- bdsm+    case reverse bds of+      [] -> return []+      (bdN : bdR) -> do+        bdN' <- docWrapNodeRest ast (return bdN)+        return $ reverse (bdN' : bdR)++instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where+  docWrapNode ast bdsm = do+    bds <- bdsm+    case Seq.viewl bds of+      Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.+      bd1 Seq.:< rest -> case Seq.viewr rest of+        Seq.EmptyR -> do+          bd1' <- docWrapNode ast (return bd1)+          return $ Seq.singleton bd1'+        bdM Seq.:> bdN -> do+          bd1' <- docWrapNodePrior ast (return bd1)+          bdN' <- docWrapNodeRest ast (return bdN)+          return $ (bd1' Seq.<| bdM) Seq.|> bdN'+  docWrapNodePrior ast bdsm = do+    bds <- bdsm+    case Seq.viewl bds of+      Seq.EmptyL -> return Seq.empty+      bd1 Seq.:< bdR -> do+        bd1' <- docWrapNodePrior ast (return bd1)+        return $ bd1' Seq.<| bdR+  docWrapNodeRest ast bdsm = do+    bds <- bdsm+    case Seq.viewr bds of+      Seq.EmptyR -> return Seq.empty+      bdR Seq.:> bdN -> do+        bdN' <- docWrapNodeRest ast (return bdN)+        return $ bdR Seq.|> bdN'++instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where+  docWrapNode ast stuffM = do+    (bds, bd, x) <- stuffM+    if null bds+      then do+        bd' <- docWrapNode ast (return bd)+        return (bds, bd', x)+      else do+        bds' <- docWrapNodePrior ast (return bds)+        bd' <- docWrapNodeRest ast (return bd)+        return (bds', bd', x)+  docWrapNodePrior ast stuffM = do+    (bds, bd, x) <- stuffM+    bds' <- docWrapNodePrior ast (return bds)+    return (bds', bd, x)+  docWrapNodeRest ast stuffM = do+    (bds, bd, x) <- stuffM+    bd' <- docWrapNodeRest ast (return bd)+    return (bds, bd', x)++++docPar+  :: ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+docPar lineM indentedM = do+  line <- lineM+  indented <- indentedM+  allocateNode $ BDFPar BrIndentNone line indented++docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm++docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm++docEnsureIndent+  :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered+docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd++unknownNodeError+  :: Data.Data.Data ast+  => String+  -> GenLocated GHC.SrcSpan ast+  -> ToBriDocM BriDocNumbered+unknownNodeError infoStr ast = do+  mTell [ErrorUnknownNode infoStr ast]+  docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"++spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered]+spacifyDocs [] = []+spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]++briDocMToPPM :: ToBriDocM a -> PPMLocal a+briDocMToPPM m = do+  (x, errs, debugs) <- briDocMToPPMInner m+  mTell debugs+  mTell errs+  return x++briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)+briDocMToPPMInner m = do+  readers <- MultiRWSS.mGetRawR+  let+    ((x, errs), debugs) =+      runIdentity+        $ MultiRWSS.runMultiRWSTNil+        $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)+        $ MultiRWSS.withMultiReaders readers+        $ MultiRWSS.withMultiWriterAW+        $ MultiRWSS.withMultiWriterAW+        $ m+  pure (x, errs, debugs)++docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)+docSharedWrapper f x = return <$> f x
+ source/library/Brittany/Internal/Layouters/DataDecl.hs view
@@ -0,0 +1,434 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Layouters.DataDecl where++import qualified Data.Data+import qualified Data.Semigroup as Semigroup+import qualified Data.Text as Text+import GHC (GenLocated(L), Located)+import qualified GHC+import GHC.Hs+import qualified GHC.OldList as List+import Brittany.Internal.Config.Types+import Brittany.Internal.LayouterBasics+import Brittany.Internal.Layouters.Type+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types++++layoutDataDecl+  :: Located (TyClDecl GhcPs)+  -> Located RdrName+  -> LHsQTyVars GhcPs+  -> HsDataDefn GhcPs+  -> ToBriDocM BriDocNumbered+layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of+  -- newtype MyType a b = MyType ..+  HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs ->+    case cons of+      (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc))+        -> docWrapNode ltycl $ do+          nameStr <- lrdrNameToTextAnn name+          consNameStr <- lrdrNameToTextAnn consName+          tyVarLine <- return <$> createBndrDoc bndrs+          -- headDoc     <- fmap return $ docSeq+          --   [ appSep $ docLitS "newtype")+          --   , appSep $ docLit nameStr+          --   , appSep tyVarLine+          --   ]+          rhsDoc <- return <$> createDetailsDoc consNameStr details+          createDerivingPar mDerivs $ docSeq+            [ appSep $ docLitS "newtype"+            , appSep $ docLit nameStr+            , appSep tyVarLine+            , docSeparator+            , docLitS "="+            , docSeparator+            , rhsDoc+            ]+      _ -> briDocByExactNoComment ltycl+++  -- data MyData a b+  -- (zero constructors)+  HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->+    docWrapNode ltycl $ do+      lhsContextDoc <- docSharedWrapper createContextDoc lhsContext+      nameStr <- lrdrNameToTextAnn name+      tyVarLine <- return <$> createBndrDoc bndrs+      createDerivingPar mDerivs $ docSeq+        [ appSep $ docLitS "data"+        , lhsContextDoc+        , appSep $ docLit nameStr+        , appSep tyVarLine+        ]++  -- data MyData = MyData ..+  -- data MyData = MyData { .. }+  HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->+    case cons of+      (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc))+        -> docWrapNode ltycl $ do+          lhsContextDoc <- docSharedWrapper createContextDoc lhsContext+          nameStr <- lrdrNameToTextAnn name+          consNameStr <- lrdrNameToTextAnn consName+          tyVarLine <- return <$> createBndrDoc bndrs+          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+          consDoc <-+            fmap pure+            $ 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]+          createDerivingPar mDerivs $ docAlt+            [ -- data D = forall a . Show a => D a+              docSeq+              [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq+                [ appSep $ docLitS "data"+                , docForceSingleline $ lhsContextDoc+                , appSep $ docLit nameStr+                , appSep tyVarLine+                , docSeparator+                ]+              , 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+              (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq+                [ appSep $ docLitS "data"+                , docForceSingleline lhsContextDoc+                , appSep $ docLit nameStr+                , tyVarLine+                ]+              )+              (docSeq+                [ 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+              (docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq+                [ appSep $ docLitS "data"+                , docForceSingleline lhsContextDoc+                , appSep $ docLit nameStr+                , tyVarLine+                ]+              )+              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+                , docNodeAnnKW ltycl (Just GHC.AnnData)+                  $ docSeq [appSep $ docLit nameStr, tyVarLine]+                , consDoc+                ]+              )+            ]+      _ -> briDocByExactNoComment ltycl++  _ -> briDocByExactNoComment ltycl++createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered+createContextDoc [] = docEmpty+createContextDoc [t] =+  docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]+createContextDoc (t1 : tR) = do+  t1Doc <- docSharedWrapper layoutType t1+  tRDocs <- tR `forM` docSharedWrapper layoutType+  docAlt+    [ docSeq+      [ docLitS "("+      , docForceSingleline $ docSeq $ List.intersperse+        docCommaSep+        (t1Doc : tRDocs)+      , docLitS ") =>"+      , docSeparator+      ]+    , docLines $ join+      [ [docSeq [docLitS "(", docSeparator, t1Doc]]+      , tRDocs <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]+      , [docLitS ") =>", docSeparator]+      ]+    ]++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 <- docSharedWrapper layoutType kind+      return $ (lrdrNameToText lrdrName, Just $ d)+  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+createDerivingPar derivs mainDoc = do+  case derivs of+    (L _ []) -> mainDoc+    (L _ types) ->+      docPar mainDoc+        $ docEnsureIndent BrIndentRegular+        $ docLines+        $ docWrapNode derivs+        $ derivingClauseDoc+        <$> types++derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered+derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of+  (L _ []) -> docSeq []+  (L _ ts) ->+    let+      tsLength = length ts+      whenMoreThan1Type val = if tsLength > 1 then docLitS val else docLitS ""+      (lhsStrategy, rhsStrategy) =+        maybe (docEmpty, docEmpty) strategyLeftRight mStrategy+    in docSeq+      [ docDeriving+      , docWrapNodePrior types $ lhsStrategy+      , docSeparator+      , whenMoreThan1Type "("+      , docWrapNodeRest types+      $ docSeq+      $ List.intersperse docCommaSep+      $ ts+      <&> \case+            HsIB _ t -> layoutType t+      , whenMoreThan1Type ")"+      , rhsStrategy+      ]+ where+  strategyLeftRight = \case+    (L _ StockStrategy) -> (docLitS " stock", docEmpty)+    (L _ AnyclassStrategy) -> (docLitS " anyclass", docEmpty)+    (L _ NewtypeStrategy) -> (docLitS " newtype", docEmpty)+    lVia@(L _ (ViaStrategy viaTypes)) ->+      ( docEmpty+      , case viaTypes of+        HsIB _ext t ->+          docSeq [docWrapNode lVia $ docLitS " via", docSeparator, layoutType t]+      )++docDeriving :: ToBriDocM BriDocNumbered+docDeriving = docLitS "deriving"++createDetailsDoc+  :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)+createDetailsDoc consNameStr details = case details of+  PrefixCon args -> do+    indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack+    let+      singleLine = docSeq+        [ docLit consNameStr+        , docSeparator+        , docForceSingleline+        $ docSeq+        $ List.intersperse docSeparator+        $ fmap hsScaledThing args+        <&> layoutType+        ]+      leftIndented =+        docSetParSpacing+          . docAddBaseY BrIndentRegular+          . docPar (docLit consNameStr)+          . docLines+          $ layoutType+          <$> fmap hsScaledThing args+      multiAppended = docSeq+        [ docLit consNameStr+        , docSeparator+        , docSetBaseY $ docLines $ layoutType <$> fmap hsScaledThing args+        ]+      multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar+        (docLit consNameStr)+        (docLines $ layoutType <$> fmap hsScaledThing args)+    case indentPolicy of+      IndentPolicyLeft -> docAlt [singleLine, leftIndented]+      IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]+      IndentPolicyFree ->+        docAlt [singleLine, multiAppended, multiIndented, leftIndented]+  RecCon (L _ []) ->+    docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]+  RecCon lRec@(L _ fields@(_ : _)) -> do+    let ((fName1, fType1) : fDocR) = mkFieldDocs fields+    -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack+    let allowSingleline = False+    docAddBaseY BrIndentRegular $ runFilteredAlternative $ do+        -- single-line: { i :: Int, b :: Bool }+      addAlternativeCond allowSingleline $ docSeq+        [ docLit consNameStr+        , docSeparator+        , docWrapNodePrior lRec $ docLitS "{"+        , docSeparator+        , docWrapNodeRest lRec+        $ docForceSingleline+        $ docSeq+        $ join+        $ [fName1, docSeparator, docLitS "::", docSeparator, fType1]+        : [ [ docLitS ","+            , docSeparator+            , fName+            , docSeparator+            , docLitS "::"+            , docSeparator+            , fType+            ]+          | (fName, fType) <- fDocR+          ]+        , docSeparator+        , docLitS "}"+        ]+      addAlternative $ docPar+        (docLit consNameStr)+        (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines+          [ docAlt+            [ docCols+              ColRecDecl+              [ appSep (docLitS "{")+              , appSep $ docForceSingleline fName1+              , docSeq [docLitS "::", docSeparator]+              , docForceSingleline $ fType1+              ]+            , docSeq+              [ docLitS "{"+              , docSeparator+              , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar+                fName1+                (docSeq [docLitS "::", docSeparator, fType1])+              ]+            ]+          , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->+            docAlt+              [ docCols+                ColRecDecl+                [ docCommaSep+                , appSep $ docForceSingleline fName+                , docSeq [docLitS "::", docSeparator]+                , docForceSingleline fType+                ]+              , docSeq+                [ docLitS ","+                , docSeparator+                , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar+                  fName+                  (docSeq [docLitS "::", docSeparator, fType])+                ]+              ]+          , docLitS "}"+          ]+        )+  InfixCon arg1 arg2 -> docSeq+    [ layoutType $ hsScaledThing arg1+    , docSeparator+    , docLit consNameStr+    , docSeparator+    , layoutType $ hsScaledThing arg2+    ]+ where+  mkFieldDocs+    :: [LConDeclField GhcPs]+    -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]+  mkFieldDocs = fmap $ \lField -> case lField of+    L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t++createForallDoc+  :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)+createForallDoc [] = Nothing+createForallDoc lhsTyVarBndrs =+  Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]++createNamesAndTypeDoc+  :: Data.Data.Data ast+  => Located ast+  -> [GenLocated t (FieldOcc GhcPs)]+  -> Located (HsType GhcPs)+  -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)+createNamesAndTypeDoc lField names t =+  ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq+    [ docSeq $ List.intersperse docCommaSep $ names <&> \case+        L _ (FieldOcc _ fieldName) -> docLit =<< lrdrNameToTextAnn fieldName+    ]+  , docWrapNodeRest lField $ layoutType t+  )
+ source/library/Brittany/Internal/Layouters/Decl.hs view
@@ -0,0 +1,998 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Brittany.Internal.Layouters.Decl where++import qualified Data.Data+import qualified Data.Foldable+import qualified Data.Maybe+import qualified Data.Semigroup as Semigroup+import qualified Data.Text as Text+import GHC (AnnKeywordId(..), GenLocated(L))+import GHC.Data.Bag (bagToList, emptyBag)+import qualified GHC.Data.FastString as FastString+import GHC.Hs+import qualified GHC.OldList as List+import GHC.Types.Basic+  ( Activation(..)+  , InlinePragma(..)+  , InlineSpec(..)+  , LexicalFixity(..)+  , RuleMatchInfo(..)+  )+import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc)+import Brittany.Internal.Config.Types+import Brittany.Internal.ExactPrintUtils+import Brittany.Internal.LayouterBasics+import Brittany.Internal.Layouters.DataDecl+import {-# SOURCE #-} Brittany.Internal.Layouters.Expr+import Brittany.Internal.Layouters.Pattern+import {-# SOURCE #-} Brittany.Internal.Layouters.Stmt+import Brittany.Internal.Layouters.Type+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+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 d@(L loc decl) = case decl of+  SigD _ sig -> withTransformedAnns d $ layoutSig (L loc sig)+  ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case+    Left ns -> docLines $ return <$> ns+    Right n -> return n+  TyClD _ tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl)+  InstD _ (TyFamInstD _ tfid) ->+    withTransformedAnns d $ layoutTyFamInstDecl False d tfid+  InstD _ (ClsInstD _ inst) ->+    withTransformedAnns d $ layoutClsInst (L loc inst)+  _ -> briDocByExactNoComment d++--------------------------------------------------------------------------------+-- Sig+--------------------------------------------------------------------------------++layoutSig :: ToBriDoc Sig+layoutSig lsig@(L _loc sig) = case sig of+  TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ+  InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->+    docWrapNode lsig $ do+      nameStr <- lrdrNameToTextAnn name+      specStr <- specStringCompat lsig spec+      let+        phaseStr = case phaseAct of+          NeverActive -> "" -- not [] - for NOINLINE NeverActive is+                                 -- in fact the default+          AlwaysActive -> ""+          ActiveBefore _ i -> "[~" ++ show i ++ "] "+          ActiveAfter _ i -> "[" ++ show i ++ "] "+          FinalActive -> error "brittany internal error: FinalActive"+      let+        conlikeStr = case conlike of+          FunLike -> ""+          ConLike -> "CONLIKE "+      docLit+        $ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)+        <> nameStr+        <> Text.pack " #-}"+  ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ+  PatSynSig _ names (HsIB _ typ) ->+    layoutNamesAndType (Just "pattern") names typ+  _ -> briDocByExactNoComment lsig -- TODO+ where+  layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do+    let+      keyDoc = case mKeyword of+        Just key -> [appSep . docLit $ Text.pack key]+        Nothing -> []+    nameStrs <- names `forM` lrdrNameToTextAnn+    let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs+    typeDoc <- docSharedWrapper layoutType typ+    hasComments <- hasAnyCommentsBelow lsig+    shouldBeHanging <-+      mAsk <&> _conf_layout .> _lconfig_hangingTypeSignature .> confUnpack+    if shouldBeHanging+      then+        docSeq+          $ [ appSep+            $ docWrapNodeRest lsig+            $ docSeq+            $ keyDoc+            <> [docLit nameStr]+            , docSetBaseY $ docLines+              [ docCols+                  ColTyOpPrefix+                  [ docLit $ Text.pack ":: "+                  , docAddBaseY (BrIndentSpecial 3) $ typeDoc+                  ]+              ]+            ]+      else layoutLhsAndType+        hasComments+        (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr])+        "::"+        typeDoc++specStringCompat+  :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String+specStringCompat ast = \case+  NoUserInline -> mTell [ErrorUnknownNode "NoUserInline" ast] $> ""+  Inline -> pure "INLINE "+  Inlinable -> pure "INLINABLE "+  NoInline -> pure "NOINLINE "++layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs))+layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of+  BodyStmt _ body _ _ -> layoutExpr body+  BindStmt _ lPat expr -> do+    patDoc <- docSharedWrapper layoutPat lPat+    expDoc <- docSharedWrapper layoutExpr expr+    docCols+      ColBindStmt+      [ appSep $ colsWrapPat =<< patDoc+      , docSeq [appSep $ docLit $ Text.pack "<-", expDoc]+      ]+  _ -> unknownNodeError "" lgstmt -- TODO+++--------------------------------------------------------------------------------+-- HsBind+--------------------------------------------------------------------------------++layoutBind+  :: ToBriDocC (HsBindLR GhcPs GhcPs) (Either [BriDocNumbered] BriDocNumbered)+layoutBind lbind@(L _ bind) = case bind of+  FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do+    idStr <- lrdrNameToTextAnn fId+    binderDoc <- docLit $ Text.pack "="+    funcPatDocs <-+      docWrapNode lbind+      $ docWrapNode lmatches+      $ layoutPatternBind (Just idStr) binderDoc+      `mapM` matches+    return $ Left $ funcPatDocs+  PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do+    patDocs <- colsWrapPat =<< layoutPat pat+    clauseDocs <- layoutGrhs `mapM` grhss+    mWhereDocs <- layoutLocalBinds whereBinds+    let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey?+    binderDoc <- docLit $ Text.pack "="+    hasComments <- hasAnyCommentsBelow lbind+    fmap Right $ docWrapNode lbind $ layoutPatternBindFinal+      Nothing+      binderDoc+      (Just patDocs)+      clauseDocs+      mWhereArg+      hasComments+  PatSynBind _ (PSB _ patID lpat rpat dir) -> do+    fmap Right $ docWrapNode lbind $ layoutPatSynBind patID lpat dir rpat+  _ -> Right <$> unknownNodeError "" lbind+layoutIPBind :: ToBriDoc IPBind+layoutIPBind lipbind@(L _ bind) = case bind of+  IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right"+  IPBind _ (Left (L _ (HsIPName name))) expr -> do+    ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name+    binderDoc <- docLit $ Text.pack "="+    exprDoc <- layoutExpr expr+    hasComments <- hasAnyCommentsBelow lipbind+    layoutPatternBindFinal+      Nothing+      binderDoc+      (Just ipName)+      [([], exprDoc, expr)]+      Nothing+      hasComments+++data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)+                  | BagSig (LSig GhcPs)++bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan+bindOrSigtoSrcSpan (BagBind (L l _)) = l+bindOrSigtoSrcSpan (BagSig (L l _)) = l++layoutLocalBinds+  :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])+layoutLocalBinds lbinds@(L _ binds) = case binds of+  -- HsValBinds (ValBindsIn lhsBindsLR []) ->+  --   Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering+  -- x@(HsValBinds (ValBindsIn{})) ->+  --   Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x+  HsValBinds _ (ValBinds _ bindlrs sigs) -> do+    let+      unordered =+        [ BagBind b | b <- Data.Foldable.toList bindlrs ]+        ++ [ BagSig s | s <- sigs ]+      ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered+    docs <- docWrapNode lbinds $ join <$> ordered `forM` \case+      BagBind b -> either id return <$> layoutBind b+      BagSig s -> return <$> layoutSig s+    return $ Just $ docs+--  x@(HsValBinds (ValBindsOut _binds _lsigs)) ->+  HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR"+  HsIPBinds _ (IPBinds _ bb) -> Just <$> mapM layoutIPBind bb+  EmptyLocalBinds{} -> return $ Nothing++-- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is+-- parSpacing stuff.B+layoutGrhs+  :: LGRHS GhcPs (LHsExpr GhcPs)+  -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)+layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do+  guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards+  bodyDoc <- layoutExpr body+  return (guardDocs, bodyDoc, body)++layoutPatternBind+  :: Maybe Text+  -> BriDocNumbered+  -> LMatch GhcPs (LHsExpr GhcPs)+  -> ToBriDocM BriDocNumbered+layoutPatternBind funId binderDoc lmatch@(L _ match) = do+  let pats = m_pats match+  let (GRHSs _ grhss whereBinds) = m_grhss match+  patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p+  let isInfix = isInfixMatch match+  mIdStr <- case match of+    Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId+    _ -> pure Nothing+  let mIdStr' = fixPatternBindIdentifier match <$> mIdStr+  patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of+    (Just idStr, p1 : p2 : pr) | isInfix -> if null pr+      then docCols+        ColPatternsFuncInfix+        [ appSep $ docForceSingleline p1+        , appSep $ docLit $ idStr+        , docForceSingleline p2+        ]+      else docCols+        ColPatternsFuncInfix+        ([ docCols+             ColPatterns+             [ docParenL+             , appSep $ docForceSingleline p1+             , appSep $ docLit $ idStr+             , docForceSingleline p2+             , appSep $ docParenR+             ]+         ]+        ++ (spacifyDocs $ docForceSingleline <$> pr)+        )+    (Just idStr, []) -> docLit idStr+    (Just idStr, ps) ->+      docCols ColPatternsFuncPrefix+        $ appSep (docLit $ idStr)+        : (spacifyDocs $ docForceSingleline <$> ps)+    (Nothing, ps) ->+      docCols ColPatterns+        $ (List.intersperse docSeparator $ docForceSingleline <$> ps)+  clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss+  mWhereDocs <- layoutLocalBinds whereBinds+  let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)+  let alignmentToken = if null pats then Nothing else funId+  hasComments <- hasAnyCommentsBelow lmatch+  layoutPatternBindFinal+    alignmentToken+    binderDoc+    (Just patDoc)+    clauseDocs+    mWhereArg+    hasComments++fixPatternBindIdentifier :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text+fixPatternBindIdentifier match idStr = go $ m_ctxt match+ where+  go = \case+    (FunRhs _ _ SrcLazy) -> Text.cons '~' idStr+    (FunRhs _ _ SrcStrict) -> Text.cons '!' idStr+    (FunRhs _ _ NoSrcStrict) -> idStr+    (StmtCtxt ctx1) -> goInner ctx1+    _ -> idStr+  -- I have really no idea if this path ever occurs, but better safe than+  -- risking another "drop bangpatterns" bugs.+  goInner = \case+    (PatGuard ctx1) -> go ctx1+    (ParStmtCtxt ctx1) -> goInner ctx1+    (TransStmtCtxt ctx1) -> goInner ctx1+    _ -> idStr++layoutPatternBindFinal+  :: Maybe Text+  -> BriDocNumbered+  -> Maybe BriDocNumbered+  -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)]+  -> Maybe (ExactPrint.AnnKey, [BriDocNumbered])+     -- ^ AnnKey for the node that contains the AnnWhere position annotation+  -> Bool+  -> ToBriDocM BriDocNumbered+layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments+  = do+    let+      patPartInline = case mPatDoc of+        Nothing -> []+        Just patDoc -> [appSep $ docForceSingleline $ return patDoc]+      patPartParWrap = case mPatDoc of+        Nothing -> id+        Just patDoc -> docPar (return patDoc)+    whereIndent <- do+      shouldSpecial <-+        mAsk <&> _conf_layout .> _lconfig_indentWhereSpecial .> confUnpack+      regularIndentAmount <-+        mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+      pure $ if shouldSpecial+        then BrIndentSpecial (max 1 (regularIndentAmount `div` 2))+        else BrIndentRegular+    -- TODO: apart from this, there probably are more nodes below which could+    --       be shared between alternatives.+    wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of+      Nothing -> return $ []+      Just (annKeyWhere, [w]) -> pure . pure <$> docAlt+        [ docEnsureIndent BrIndentRegular+          $ docSeq+              [ docLit $ Text.pack "where"+              , docSeparator+              , docForceSingleline $ return w+              ]+        , docMoveToKWDP annKeyWhere AnnWhere False+        $ docEnsureIndent whereIndent+        $ docLines+            [ docLit $ Text.pack "where"+            , docEnsureIndent whereIndent+            $ docSetIndentLevel+            $ docNonBottomSpacing+            $ return w+            ]+        ]+      Just (annKeyWhere, ws) ->+        fmap (pure . pure)+          $ docMoveToKWDP annKeyWhere AnnWhere False+          $ docEnsureIndent whereIndent+          $ docLines+              [ docLit $ Text.pack "where"+              , docEnsureIndent whereIndent+              $ docSetIndentLevel+              $ docNonBottomSpacing+              $ docLines+              $ return+              <$> ws+              ]+    let+      singleLineGuardsDoc guards = appSep $ case guards of+        [] -> docEmpty+        [g] -> docSeq+          [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g]+        gs ->+          docSeq+            $ [appSep $ docLit $ Text.pack "|"]+            ++ (List.intersperse+                 docCommaSep+                 (docForceSingleline . return <$> gs)+               )+      wherePart = case mWhereDocs of+        Nothing -> Just docEmpty+        Just (_, [w]) -> Just $ docSeq+          [ docSeparator+          , appSep $ docLit $ Text.pack "where"+          , docSetIndentLevel $ docForceSingleline $ return w+          ]+        _ -> Nothing++    indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack++    runFilteredAlternative $ do++      case clauseDocs of+        [(guards, body, _bodyRaw)] -> do+          let guardPart = singleLineGuardsDoc guards+          forM_ wherePart $ \wherePart' ->+            -- one-line solution+            addAlternativeCond (not hasComments) $ docCols+              (ColBindingLine alignmentToken)+              [ docSeq (patPartInline ++ [guardPart])+              , docSeq+                [ appSep $ return binderDoc+                , docForceSingleline $ return body+                , wherePart'+                ]+              ]+          -- one-line solution + where in next line(s)+          addAlternativeCond (Data.Maybe.isJust mWhereDocs)+            $ docLines+            $ [ docCols+                  (ColBindingLine alignmentToken)+                  [ docSeq (patPartInline ++ [guardPart])+                  , docSeq+                    [ appSep $ return binderDoc+                    , docForceParSpacing $ docAddBaseY BrIndentRegular $ return+                      body+                    ]+                  ]+              ]+            ++ wherePartMultiLine+          -- two-line solution + where in next line(s)+          addAlternative+            $ docLines+            $ [ docForceSingleline+                $ docSeq (patPartInline ++ [guardPart, return binderDoc])+              , docEnsureIndent BrIndentRegular $ docForceSingleline $ return+                body+              ]+            ++ wherePartMultiLine+          -- pattern and exactly one clause in single line, body as par;+          -- where in following lines+          addAlternative+            $ docLines+            $ [ docCols+                  (ColBindingLine alignmentToken)+                  [ docSeq (patPartInline ++ [guardPart])+                  , docSeq+                    [ appSep $ return binderDoc+                    , docForceParSpacing $ docAddBaseY BrIndentRegular $ return+                      body+                    ]+                  ]+              ]+             -- , lineMod $ docAlt+             --   [ docSetBaseY $ return body+             --   , docAddBaseY BrIndentRegular $ return body+             --   ]+            ++ wherePartMultiLine+          -- pattern and exactly one clause in single line, body in new line.+          addAlternative+            $ docLines+            $ [ docSeq (patPartInline ++ [guardPart, return binderDoc])+              , docNonBottomSpacing+              $ docEnsureIndent BrIndentRegular+              $ docAddBaseY BrIndentRegular+              $ return body+              ]+            ++ wherePartMultiLine++        _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1`++      case mPatDoc of+        Nothing -> return ()+        Just patDoc ->+          -- multiple clauses added in-paragraph, each in a single line+          -- example: foo | bar = baz+          --              | lll = asd+          addAlternativeCond (indentPolicy == IndentPolicyFree)+            $ docLines+            $ [ docSeq+                  [ appSep $ docForceSingleline $ return patDoc+                  , docSetBaseY+                  $ docLines+                  $ clauseDocs+                  <&> \(guardDocs, bodyDoc, _) -> do+                        let guardPart = singleLineGuardsDoc guardDocs+                        -- the docForceSingleline might seems superflous, but it+                        -- helps the alternative resolving impl.+                        docForceSingleline $ docCols+                          ColGuardedBody+                          [ guardPart+                          , docSeq+                            [ appSep $ return binderDoc+                            , docForceSingleline $ return bodyDoc+                            -- i am not sure if there is a benefit to using+                            -- docForceParSpacing additionally here:+                            -- , docAddBaseY BrIndentRegular $ return bodyDoc+                            ]+                          ]+                  ]+              ]+            ++ wherePartMultiLine+      -- multiple clauses, each in a separate, single line+      addAlternative+        $ docLines+        $ [ docAddBaseY BrIndentRegular+            $ patPartParWrap+            $ docLines+            $ map docSetBaseY+            $ clauseDocs+            <&> \(guardDocs, bodyDoc, _) -> do+                  let guardPart = singleLineGuardsDoc guardDocs+                  -- the docForceSingleline might seems superflous, but it+                  -- helps the alternative resolving impl.+                  docForceSingleline $ docCols+                    ColGuardedBody+                    [ guardPart+                    , docSeq+                      [ appSep $ return binderDoc+                      , docForceSingleline $ return bodyDoc+                      -- i am not sure if there is a benefit to using+                      -- docForceParSpacing additionally here:+                      -- , docAddBaseY BrIndentRegular $ return bodyDoc+                      ]+                    ]+          ]+        ++ wherePartMultiLine+      -- multiple clauses, each with the guard(s) in a single line, body+      -- as a paragraph+      addAlternative+        $ docLines+        $ [ docAddBaseY BrIndentRegular+            $ patPartParWrap+            $ docLines+            $ map docSetBaseY+            $ clauseDocs+            <&> \(guardDocs, bodyDoc, _) ->+                  docSeq+                    $ (case guardDocs of+                        [] -> []+                        [g] ->+                          [ docForceSingleline $ docSeq+                              [appSep $ docLit $ Text.pack "|", return g]+                          ]+                        gs ->+                          [ docForceSingleline+                              $ docSeq+                              $ [appSep $ docLit $ Text.pack "|"]+                              ++ List.intersperse docCommaSep (return <$> gs)+                          ]+                      )+                    ++ [ docSeparator+                       , docCols+                         ColOpPrefix+                         [ appSep $ return binderDoc+                         , docAddBaseY BrIndentRegular+                         $ docForceParSpacing+                         $ return bodyDoc+                         ]+                       ]+          ]+        ++ wherePartMultiLine+      -- multiple clauses, each with the guard(s) in a single line, body+      -- in a new line as a paragraph+      addAlternative+        $ docLines+        $ [ docAddBaseY BrIndentRegular+            $ patPartParWrap+            $ docLines+            $ map docSetBaseY+            $ clauseDocs+            >>= \(guardDocs, bodyDoc, _) ->+                  (case guardDocs of+                      [] -> []+                      [g] ->+                        [ docForceSingleline+                            $ docSeq [appSep $ docLit $ Text.pack "|", return g]+                        ]+                      gs ->+                        [ docForceSingleline+                            $ docSeq+                            $ [appSep $ docLit $ Text.pack "|"]+                            ++ List.intersperse docCommaSep (return <$> gs)+                        ]+                    )+                    ++ [ docCols+                           ColOpPrefix+                           [ appSep $ return binderDoc+                           , docAddBaseY BrIndentRegular+                           $ docForceParSpacing+                           $ return bodyDoc+                           ]+                       ]+          ]+        ++ wherePartMultiLine+      -- conservative approach: everything starts on the left.+      addAlternative+        $ docLines+        $ [ docAddBaseY BrIndentRegular+            $ patPartParWrap+            $ docLines+            $ map docSetBaseY+            $ clauseDocs+            >>= \(guardDocs, bodyDoc, _) ->+                  (case guardDocs of+                      [] -> []+                      [g] -> [docSeq [appSep $ docLit $ Text.pack "|", return g]]+                      (g1 : gr) ->+                        (docSeq [appSep $ docLit $ Text.pack "|", return g1]+                        : (gr <&> \g ->+                            docSeq [appSep $ docLit $ Text.pack ",", return g]+                          )+                        )+                    )+                    ++ [ docCols+                           ColOpPrefix+                           [ appSep $ return binderDoc+                           , docAddBaseY BrIndentRegular $ return bodyDoc+                           ]+                       ]+          ]+        ++ wherePartMultiLine++-- | Layout a pattern synonym binding+layoutPatSynBind+  :: Located (IdP GhcPs)+  -> HsPatSynDetails (Located (IdP GhcPs))+  -> HsPatSynDir GhcPs+  -> LPat GhcPs+  -> ToBriDocM BriDocNumbered+layoutPatSynBind name patSynDetails patDir rpat = do+  let+    patDoc = docLit $ Text.pack "pattern"+    binderDoc = case patDir of+      ImplicitBidirectional -> docLit $ Text.pack "="+      _ -> docLit $ Text.pack "<-"+    body = colsWrapPat =<< layoutPat rpat+    whereDoc = docLit $ Text.pack "where"+  mWhereDocs <- layoutPatSynWhere patDir+  headDoc <-+    fmap pure+    $ docSeq+    $ [ patDoc+      , docSeparator+      , layoutLPatSyn name patSynDetails+      , docSeparator+      , binderDoc+      ]+  runFilteredAlternative $ do+    addAlternative+      $+      -- pattern .. where+      --   ..+      --   ..+        docAddBaseY BrIndentRegular+      $ docSeq+          ([headDoc, docSeparator, body] ++ case mWhereDocs of+            Just ds -> [docSeparator, docPar whereDoc (docLines ds)]+            Nothing -> []+          )+    addAlternative+      $+      -- pattern .. =+      --   ..+      -- pattern .. <-+      --   .. where+      --   ..+      --   ..+        docAddBaseY BrIndentRegular+      $ docPar+          headDoc+          (case mWhereDocs of+            Nothing -> body+            Just ds -> docLines ([docSeq [body, docSeparator, whereDoc]] ++ ds)+          )++-- | Helper method for the left hand side of a pattern synonym+layoutLPatSyn+  :: Located (IdP GhcPs)+  -> HsPatSynDetails (Located (IdP GhcPs))+  -> ToBriDocM BriDocNumbered+layoutLPatSyn name (PrefixCon vars) = do+  docName <- lrdrNameToTextAnn name+  names <- mapM lrdrNameToTextAnn vars+  docSeq . fmap appSep $ docLit docName : (docLit <$> names)+layoutLPatSyn name (InfixCon left right) = do+  leftDoc <- lrdrNameToTextAnn left+  docName <- lrdrNameToTextAnn name+  rightDoc <- lrdrNameToTextAnn right+  docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc]+layoutLPatSyn name (RecCon recArgs) = do+  docName <- lrdrNameToTextAnn name+  args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs+  docSeq+    . fmap docLit+    $ [docName, Text.pack " { "]+    <> intersperse (Text.pack ", ") args+    <> [Text.pack " }"]++-- | Helper method to get the where clause from of explicitly bidirectional+-- pattern synonyms+layoutPatSynWhere+  :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered])+layoutPatSynWhere hs = case hs of+  ExplicitBidirectional (MG _ (L _ lbinds) _) -> do+    binderDoc <- docLit $ Text.pack "="+    Just+      <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds+  _ -> pure Nothing++--------------------------------------------------------------------------------+-- TyClDecl+--------------------------------------------------------------------------------++layoutTyCl :: ToBriDoc TyClDecl+layoutTyCl ltycl@(L _loc tycl) = case tycl of+  SynDecl _ name vars fixity typ -> do+    let+      isInfix = case fixity of+        Prefix -> False+        Infix -> True+    -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP+    -- let parenWrapper = if hasTrailingParen+    --       then appSep . docWrapNodeRest ltycl+    --       else id+    let wrapNodeRest = docWrapNodeRest ltycl+    docWrapNodePrior ltycl+      $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ+  DataDecl _ext name tyVars _ dataDefn ->+    layoutDataDecl ltycl name tyVars dataDefn+  _ -> briDocByExactNoComment ltycl++layoutSynDecl+  :: Bool+  -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)+  -> Located (IdP GhcPs)+  -> [LHsTyVarBndr () GhcPs]+  -> LHsType GhcPs+  -> ToBriDocM BriDocNumbered+layoutSynDecl isInfix wrapNodeRest name vars typ = do+  nameStr <- lrdrNameToTextAnn name+  let+    lhs = appSep . wrapNodeRest $ if isInfix+      then do+        let (a : b : rest) = vars+        hasOwnParens <- hasAnnKeywordComment a AnnOpenP+        -- This isn't quite right, but does give syntactically valid results+        let needsParens = not (null rest) || hasOwnParens+        docSeq+          $ [docLit $ Text.pack "type", docSeparator]+          ++ [ docParenL | needsParens ]+          ++ [ layoutTyVarBndr False a+             , docSeparator+             , docLit nameStr+             , docSeparator+             , layoutTyVarBndr False b+             ]+          ++ [ docParenR | needsParens ]+          ++ fmap (layoutTyVarBndr True) rest+      else+        docSeq+        $ [ docLit $ Text.pack "type"+          , docSeparator+          , docWrapNode name $ docLit nameStr+          ]+        ++ fmap (layoutTyVarBndr True) vars+  sharedLhs <- docSharedWrapper id lhs+  typeDoc <- docSharedWrapper layoutType typ+  hasComments <- hasAnyCommentsConnected typ+  layoutLhsAndType hasComments sharedLhs "=" typeDoc++layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ())+layoutTyVarBndr needsSep lbndr@(L _ bndr) = do+  docWrapNodePrior lbndr $ case bndr of+    UserTyVar _ _ name -> do+      nameStr <- lrdrNameToTextAnn name+      docSeq $ [ docSeparator | needsSep ] ++ [docLit nameStr]+    KindedTyVar _ _ name kind -> do+      nameStr <- lrdrNameToTextAnn name+      docSeq+        $ [ docSeparator | needsSep ]+        ++ [ docLit $ Text.pack "("+           , appSep $ docLit nameStr+           , appSep . docLit $ Text.pack "::"+           , docForceSingleline $ layoutType kind+           , docLit $ Text.pack ")"+           ]+++--------------------------------------------------------------------------------+-- TyFamInstDecl+--------------------------------------------------------------------------------++++layoutTyFamInstDecl+  :: Data.Data.Data a+  => Bool+  -> Located a+  -> TyFamInstDecl GhcPs+  -> ToBriDocM BriDocNumbered+layoutTyFamInstDecl inClass outerNode tfid = do+  let+    FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid+    -- bndrsMay isJust e.g. with+    --   type instance forall a . MyType (Maybe a) = Either () a+    innerNode = outerNode+  docWrapNodePrior outerNode $ do+    nameStr <- lrdrNameToTextAnn name+    needsParens <- hasAnnKeyword outerNode AnnOpenP+    let+      instanceDoc = if inClass+        then docLit $ Text.pack "type"+        else docSeq+          [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"]+      makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered+      makeForallDoc bndrs = do+        bndrDocs <- layoutTyVarBndrs bndrs+        docSeq+          ([docLit (Text.pack "forall")] ++ processTyVarBndrsSingleline bndrDocs+          )+      lhs =+        docWrapNode innerNode+          . docSeq+          $ [appSep instanceDoc]+          ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ]+          ++ [ docParenL | needsParens ]+          ++ [appSep $ docWrapNode name $ docLit nameStr]+          ++ intersperse docSeparator (layoutHsTyPats pats)+          ++ [ docParenR | needsParens ]+    hasComments <-+      (||)+      <$> hasAnyRegularCommentsConnected outerNode+      <*> hasAnyRegularCommentsRest innerNode+    typeDoc <- docSharedWrapper layoutType typ+    layoutLhsAndType hasComments lhs "=" typeDoc+++layoutHsTyPats+  :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]+layoutHsTyPats pats = pats <&> \case+  HsValArg tm -> layoutType tm+  HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty]+    -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change+    -- is a bit strange. Hopefully this does not ignore any important+    -- annotations.+  HsArgPar _l -> error "brittany internal error: HsArgPar{}"++--------------------------------------------------------------------------------+-- ClsInstDecl+--------------------------------------------------------------------------------++-- | Layout an @instance@ declaration+--+--   Layout signatures and bindings using the corresponding layouters from the+--   top-level. Layout the instance head, type family instances, and data family+--   instances using ExactPrint.+layoutClsInst :: ToBriDoc ClsInstDecl+layoutClsInst lcid@(L _ cid) = docLines+  [ layoutInstanceHead+  , docEnsureIndent BrIndentRegular+  $ docSetIndentLevel+  $ docSortedLines+  $ fmap layoutAndLocateSig (cid_sigs cid)+  ++ fmap layoutAndLocateBind (bagToList $ cid_binds cid)+  ++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid)+  ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid)+  ]+ where+  layoutInstanceHead :: ToBriDocM BriDocNumbered+  layoutInstanceHead =+    briDocByExactNoComment+      $ InstD NoExtField+      . ClsInstD NoExtField+      . removeChildren+      <$> lcid++  removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs+  removeChildren c = c+    { cid_binds = emptyBag+    , cid_sigs = []+    , cid_tyfam_insts = []+    , cid_datafam_insts = []+    }++  -- | Like 'docLines', but sorts the lines based on location+  docSortedLines+    :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered+  docSortedLines l =+    allocateNode+      . BDFLines+      . fmap unLoc+      . List.sortOn (ExactPrint.rs . getLoc)+      =<< sequence l++  layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered)+  layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig++  layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered)+  layoutAndLocateBind lbind@(L loc _) =+    L loc <$> (joinBinds =<< layoutBind lbind)++  joinBinds+    :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered+  joinBinds = \case+    Left ns -> docLines $ return <$> ns+    Right n -> return n++  layoutAndLocateTyFamInsts+    :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered)+  layoutAndLocateTyFamInsts ltfid@(L loc tfid) =+    L loc <$> layoutTyFamInstDecl True ltfid tfid++  layoutAndLocateDataFamInsts+    :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered)+  layoutAndLocateDataFamInsts ldfid@(L loc _) =+    L loc <$> layoutDataFamInstDecl ldfid++  -- | Send to ExactPrint then remove unecessary whitespace+  layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl+  layoutDataFamInstDecl ldfid =+    fmap stripWhitespace <$> briDocByExactNoComment ldfid++  -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations+  stripWhitespace :: BriDocF f -> BriDocF f+  stripWhitespace (BDFExternal ann anns b t) =+    BDFExternal ann anns b $ stripWhitespace' t+  stripWhitespace b = b++  -- | This fixes two issues of output coming from Exactprinting+  --   associated (data) type decls. Firstly we place the output into docLines,+  --   so one newline coming from Exactprint is superfluous, so we drop the+  --   first (empty) line. The second issue is Exactprint indents the first+  --   member in a strange fashion:+  --+  --   input:+  --+  --   > instance MyClass Int where+  --   >   -- | This data is very important+  --   >   data MyData = IntData+  --   >     { intData  :: String+  --   >     , intData2 :: Int+  --   >     }+  --+  --   output of just exactprinting the associated data type syntax node+  --+  --   >+  --   >   -- | This data is very important+  --   >   data MyData = IntData+  --   >   { intData  :: String+  --   >   , intData2 :: Int+  --   >   }+  --+  --   To fix this, we strip whitespace from the start of the comments and the+  --   first line of the declaration, stopping when we see "data" or "type" at+  --   the start of a line. I.e., this function yields+  --+  --   > -- | This data is very important+  --   > data MyData = IntData+  --   >   { intData  :: String+  --   >   , intData2 :: Int+  --   >   }+  --+  --   Downside apart from being a hacky and brittle fix is that this removes+  --   possible additional indentation from comments before the first member.+  --+  --   But the whole thing is just a temporary measure until brittany learns+  --   to layout data/type decls.+  stripWhitespace' :: Text -> Text+  stripWhitespace' t =+    Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t+   where+    go [] = []+    go (line1 : lineR) = case Text.stripStart line1 of+      st+        | isTypeOrData st -> st : lineR+        | otherwise -> st : go lineR+    isTypeOrData t' =+      (Text.pack "type" `Text.isPrefixOf` t')+        || (Text.pack "newtype" `Text.isPrefixOf` t')+        || (Text.pack "data" `Text.isPrefixOf` t')+++--------------------------------------------------------------------------------+-- Common Helpers+--------------------------------------------------------------------------------++layoutLhsAndType+  :: Bool+  -> ToBriDocM BriDocNumbered+  -> String+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+layoutLhsAndType hasComments lhs sep typeDoc = do+  runFilteredAlternative $ do+    -- (separators probably are "=" or "::")+    -- lhs = type+    -- lhs :: type+    addAlternativeCond (not hasComments) $ docSeq+      [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc]+    -- lhs+    --   :: typeA+    --   -> typeB+    -- lhs+    --   =  typeA+    --   -> typeB+    addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols+      ColTyOpPrefix+      [ appSep $ docLitS sep+      , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc+      ]
+ source/library/Brittany/Internal/Layouters/Expr.hs view
@@ -0,0 +1,1086 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Layouters.Expr where++import qualified Data.Data+import qualified Data.Semigroup as Semigroup+import qualified Data.Sequence as Seq+import qualified Data.Text as Text+import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan)+import qualified GHC.Data.FastString as FastString+import GHC.Hs+import qualified GHC.OldList as List+import GHC.Types.Basic+import GHC.Types.Name+import Brittany.Internal.Config.Types+import Brittany.Internal.LayouterBasics+import Brittany.Internal.Layouters.Decl+import Brittany.Internal.Layouters.Pattern+import Brittany.Internal.Layouters.Stmt+import Brittany.Internal.Layouters.Type+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import Brittany.Internal.Utils++++layoutExpr :: ToBriDoc HsExpr+layoutExpr lexpr@(L _ expr) = do+  indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack+  let allowFreeIndent = indentPolicy == IndentPolicyFree+  docWrapNode lexpr $ case expr of+    HsVar _ vname -> do+      docLit =<< lrdrNameToTextAnn vname+    HsUnboundVar _ oname -> docLit $ Text.pack $ occNameString oname+    HsRecFld{} -> do+      -- TODO+      briDocByExactInlineOnly "HsRecFld" lexpr+    HsOverLabel _ext _reboundFromLabel name ->+      let label = FastString.unpackFS name in docLit . Text.pack $ '#' : label+    HsIPVar _ext (HsIPName name) ->+      let label = FastString.unpackFS name in docLit . Text.pack $ '?' : label+    HsOverLit _ olit -> do+      allocateNode $ overLitValBriDoc $ ol_val olit+    HsLit _ lit -> do+      allocateNode $ litBriDoc lit+    HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _)+      | pats <- m_pats match+      , GRHSs _ [lgrhs] llocals <- m_grhss match+      , L _ EmptyLocalBinds{} <- llocals+      , L _ (GRHS _ [] body) <- lgrhs+      -> do+        patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) ->+          fmap return $ do+            -- this code could be as simple as `colsWrapPat =<< layoutPat p`+            -- if it was not for the following two cases:+            -- \ !x -> x+            -- \ ~x -> x+            -- These make it necessary to special-case an additional separator.+            -- (TODO: we create a BDCols here, but then make it ineffective+            -- by wrapping it in docSeq below. We _could_ add alignments for+            -- stuff like lists-of-lambdas. Nothing terribly important..)+            let+              shouldPrefixSeparator = case p of+                L _ LazyPat{} -> isFirst+                L _ BangPat{} -> isFirst+                _ -> False+            patDocSeq <- layoutPat p+            fixed <- case Seq.viewl patDocSeq of+              p1 Seq.:< pr | shouldPrefixSeparator -> do+                p1' <- docSeq [docSeparator, pure p1]+                pure (p1' Seq.<| pr)+              _ -> pure patDocSeq+            colsWrapPat fixed+        bodyDoc <-+          docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body+        let+          funcPatternPartLine = docCols+            ColCasePattern+            (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))+        docAlt+          [ -- single line+            docSeq+            [ docLit $ Text.pack "\\"+            , docWrapNode lmatch $ docForceSingleline funcPatternPartLine+            , appSep $ docLit $ Text.pack "->"+            , docWrapNode lgrhs $ docForceSingleline bodyDoc+            ]+            -- double line+          , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+            (docSeq+              [ docLit $ Text.pack "\\"+              , docWrapNode lmatch $ appSep $ docForceSingleline+                funcPatternPartLine+              , docLit $ Text.pack "->"+              ]+            )+            (docWrapNode lgrhs $ docForceSingleline bodyDoc)+            -- wrapped par spacing+          , docSetParSpacing $ docSeq+            [ docLit $ Text.pack "\\"+            , docWrapNode lmatch $ docForceSingleline funcPatternPartLine+            , appSep $ docLit $ Text.pack "->"+            , docWrapNode lgrhs $ docForceParSpacing bodyDoc+            ]+            -- conservative+          , docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+            (docSeq+              [ docLit $ Text.pack "\\"+              , docWrapNode lmatch $ appSep $ docForceSingleline+                funcPatternPartLine+              , docLit $ Text.pack "->"+              ]+            )+            (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc)+          ]+    HsLam{} -> unknownNodeError "HsLam too complex" lexpr+    HsLamCase _ (MG _ (L _ []) _) -> do+      docSetParSpacing+        $ docAddBaseY BrIndentRegular+        $ (docLit $ Text.pack "\\case {}")+    HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do+      binderDoc <- docLit $ Text.pack "->"+      funcPatDocs <-+        docWrapNode lmatches+        $ layoutPatternBind Nothing binderDoc+        `mapM` matches+      docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+        (docLit $ Text.pack "\\case")+        (docSetBaseAndIndent+        $ docNonBottomSpacing+        $ docLines+        $ return+        <$> funcPatDocs+        )+    HsApp _ exp1@(L _ HsApp{}) exp2 -> do+      let+        gather+          :: [LHsExpr GhcPs]+          -> LHsExpr GhcPs+          -> (LHsExpr GhcPs, [LHsExpr GhcPs])+        gather list = \case+          L _ (HsApp _ l r) -> gather (r : list) l+          x -> (x, list)+      let (headE, paramEs) = gather [exp2] exp1+      let+        colsOrSequence = case headE of+          L _ (HsVar _ (L _ (Unqual occname))) ->+            docCols (ColApp $ Text.pack $ occNameString occname)+          _ -> docSeq+      headDoc <- docSharedWrapper layoutExpr headE+      paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs+      hasComments <- hasAnyCommentsConnected exp2+      runFilteredAlternative $ do+        -- foo x y+        addAlternativeCond (not hasComments)+          $ colsOrSequence+          $ appSep (docForceSingleline headDoc)+          : spacifyDocs (docForceSingleline <$> paramDocs)+        -- foo x+        --     y+        addAlternativeCond allowFreeIndent $ docSeq+          [ appSep (docForceSingleline headDoc)+          , docSetBaseY+          $ docAddBaseY BrIndentRegular+          $ docLines+          $ docForceSingleline+          <$> paramDocs+          ]+        -- foo+        --   x+        --   y+        addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+          (docForceSingleline headDoc)+          (docNonBottomSpacing $ docLines paramDocs)+        -- ( multi+        --   line+        --   function+        -- )+        --   x+        --   y+        addAlternative $ docAddBaseY BrIndentRegular $ docPar+          headDoc+          (docNonBottomSpacing $ docLines paramDocs)+    HsApp _ exp1 exp2 -> do+      -- TODO: if expDoc1 is some literal, we may want to create a docCols here.+      expDoc1 <- docSharedWrapper layoutExpr exp1+      expDoc2 <- docSharedWrapper layoutExpr exp2+      docAlt+        [ -- func arg+          docSeq+          [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2]+        , -- func argline1+          --   arglines+          -- e.g.+          -- func Abc+          --   { member1 = True+          --   , member2 = 13+          --   }+          docSetParSpacing -- this is most likely superfluous because+                           -- this is a sequence of a one-line and a par-space+                           -- anyways, so it is _always_ par-spaced.+        $ docAddBaseY BrIndentRegular+        $ docSeq+            [appSep $ docForceSingleline expDoc1, docForceParSpacing expDoc2]+        , -- func+          --   arg+          docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+          (docForceSingleline expDoc1)+          (docNonBottomSpacing expDoc2)+        , -- fu+          --   nc+          --   ar+          --     gument+          docAddBaseY BrIndentRegular $ docPar expDoc1 expDoc2+        ]+    HsAppType _ exp1 (HsWC _ ty1) -> do+      t <- docSharedWrapper layoutType ty1+      e <- docSharedWrapper layoutExpr exp1+      docAlt+        [ docSeq+          [ docForceSingleline e+          , docSeparator+          , docLit $ Text.pack "@"+          , docForceSingleline t+          ]+        , docPar e (docSeq [docLit $ Text.pack "@", t])+        ]+    OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do+      let+        gather+          :: [(LHsExpr GhcPs, LHsExpr GhcPs)]+          -> LHsExpr GhcPs+          -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)])+        gather opExprList = \case+          (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1) : opExprList) l1+          final -> (final, opExprList)+        (leftOperand, appList) = gather [] expLeft+      leftOperandDoc <- docSharedWrapper layoutExpr leftOperand+      appListDocs <- appList `forM` \(x, y) ->+        [ (xD, yD)+        | xD <- docSharedWrapper layoutExpr x+        , yD <- docSharedWrapper layoutExpr y+        ]+      opLastDoc <- docSharedWrapper layoutExpr expOp+      expLastDoc <- docSharedWrapper layoutExpr expRight+      allowSinglelinePar <- do+        hasComLeft <- hasAnyCommentsConnected expLeft+        hasComOp <- hasAnyCommentsConnected expOp+        pure $ not hasComLeft && not hasComOp+      let+        allowPar = case (expOp, expRight) of+          (L _ (HsVar _ (L _ (Unqual occname))), _)+            | occNameString occname == "$" -> True+          (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False+          _ -> True+      runFilteredAlternative $ do+        -- > one + two + three+        -- or+        -- > one + two + case x of+        -- >   _ -> three+        addAlternativeCond allowSinglelinePar $ docSeq+          [ appSep $ docForceSingleline leftOperandDoc+          , docSeq $ appListDocs <&> \(od, ed) -> docSeq+            [appSep $ docForceSingleline od, appSep $ docForceSingleline ed]+          , appSep $ docForceSingleline opLastDoc+          , (if allowPar then docForceParSpacing else docForceSingleline)+            expLastDoc+          ]+        -- this case rather leads to some unfortunate layouting than to anything+        -- useful; disabling for now. (it interfers with cols stuff.)+        -- addAlternative+        --   $ docSetBaseY+        --   $ docPar+        --     leftOperandDoc+        --     ( docLines+        --      $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])+        --       ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]+        --     )+        -- > one+        -- >   + two+        -- >   + three+        addAlternative $ docPar+          leftOperandDoc+          (docLines+          $ (appListDocs <&> \(od, ed) ->+              docCols ColOpPrefix [appSep od, docSetBaseY ed]+            )+          ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]+          )+    OpApp _ expLeft expOp expRight -> do+      expDocLeft <- docSharedWrapper layoutExpr expLeft+      expDocOp <- docSharedWrapper layoutExpr expOp+      expDocRight <- docSharedWrapper layoutExpr expRight+      let+        allowPar = case (expOp, expRight) of+          (L _ (HsVar _ (L _ (Unqual occname))), _)+            | occNameString occname == "$" -> True+          (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False+          _ -> True+      let+        leftIsDoBlock = case expLeft of+          L _ HsDo{} -> True+          _ -> False+      runFilteredAlternative $ do+        -- one-line+        addAlternative $ docSeq+          [ appSep $ docForceSingleline expDocLeft+          , appSep $ docForceSingleline expDocOp+          , docForceSingleline expDocRight+          ]+        -- -- line + freely indented block for right expression+        -- addAlternative+        --   $ docSeq+        --   [ appSep $ docForceSingleline expDocLeft+        --   , appSep $ docForceSingleline expDocOp+        --   , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight+        --   ]+        -- two-line+        addAlternative $ do+          let+            expDocOpAndRight = docForceSingleline $ docCols+              ColOpPrefix+              [appSep $ expDocOp, docSetBaseY expDocRight]+          if leftIsDoBlock+            then docLines [expDocLeft, expDocOpAndRight]+            else docAddBaseY BrIndentRegular+              $ docPar expDocLeft expDocOpAndRight+              -- TODO: in both cases, we don't force expDocLeft to be+              -- single-line, which has certain.. interesting consequences.+              -- At least, the "two-line" label is not entirely+              -- accurate.+        -- one-line + par+        addAlternativeCond allowPar $ docSeq+          [ appSep $ docForceSingleline expDocLeft+          , appSep $ docForceSingleline expDocOp+          , docForceParSpacing expDocRight+          ]+        -- more lines+        addAlternative $ do+          let+            expDocOpAndRight =+              docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]+          if leftIsDoBlock+            then docLines [expDocLeft, expDocOpAndRight]+            else docAddBaseY BrIndentRegular+              $ docPar expDocLeft expDocOpAndRight+    NegApp _ op _ -> do+      opDoc <- docSharedWrapper layoutExpr op+      docSeq [docLit $ Text.pack "-", opDoc]+    HsPar _ innerExp -> do+      innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp+      docAlt+        [ docSeq+          [ docLit $ Text.pack "("+          , docForceSingleline innerExpDoc+          , docLit $ Text.pack ")"+          ]+        , docSetBaseY $ docLines+          [ docCols+            ColOpPrefix+            [ docLit $ Text.pack "("+            , docAddBaseY (BrIndentSpecial 2) innerExpDoc+            ]+          , docLit $ Text.pack ")"+          ]+        ]+    SectionL _ left op -> do -- TODO: add to testsuite+      leftDoc <- docSharedWrapper layoutExpr left+      opDoc <- docSharedWrapper layoutExpr op+      docSeq [leftDoc, docSeparator, opDoc]+    SectionR _ op right -> do -- TODO: add to testsuite+      opDoc <- docSharedWrapper layoutExpr op+      rightDoc <- docSharedWrapper layoutExpr right+      docSeq [opDoc, docSeparator, rightDoc]+    ExplicitTuple _ args boxity -> do+      let+        argExprs = args <&> \arg -> case arg of+          (L _ (Present _ e)) -> (arg, Just e)+          (L _ (Missing NoExtField)) -> (arg, Nothing)+      argDocs <- forM argExprs $ docSharedWrapper $ \(arg, exprM) ->+        docWrapNode arg $ maybe docEmpty layoutExpr exprM+      hasComments <-+        orM+          (hasCommentsBetween lexpr AnnOpenP AnnCloseP+          : map hasAnyCommentsBelow args+          )+      let+        (openLit, closeLit) = case boxity of+          Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")")+          Unboxed -> (docParenHashLSep, docParenHashRSep)+      case splitFirstLast argDocs of+        FirstLastEmpty ->+          docSeq [openLit, docNodeAnnKW lexpr (Just AnnOpenP) closeLit]+        FirstLastSingleton e -> docAlt+          [ docCols+            ColTuple+            [ openLit+            , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e+            , closeLit+            ]+          , docSetBaseY $ docLines+            [ docSeq+              [ openLit+              , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e+              ]+            , closeLit+            ]+          ]+        FirstLast e1 ems eN -> runFilteredAlternative $ do+          addAlternativeCond (not hasComments)+            $ docCols ColTuple+            $ [docSeq [openLit, docForceSingleline e1]]+            ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e])+            ++ [ docSeq+                   [ docCommaSep+                   , docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN)+                   , closeLit+                   ]+               ]+          addAlternative+            $ let+                start = docCols ColTuples [appSep openLit, e1]+                linesM = ems <&> \d -> docCols ColTuples [docCommaSep, d]+                lineN = docCols+                  ColTuples+                  [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN]+                end = closeLit+              in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end]+    HsCase _ cExp (MG _ (L _ []) _) -> do+      cExpDoc <- docSharedWrapper layoutExpr cExp+      docAlt+        [ docAddBaseY BrIndentRegular $ docSeq+          [ appSep $ docLit $ Text.pack "case"+          , appSep $ docForceSingleline cExpDoc+          , docLit $ Text.pack "of {}"+          ]+        , docPar+          (docAddBaseY BrIndentRegular+          $ docPar (docLit $ Text.pack "case") cExpDoc+          )+          (docLit $ Text.pack "of {}")+        ]+    HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do+      cExpDoc <- docSharedWrapper layoutExpr cExp+      binderDoc <- docLit $ Text.pack "->"+      funcPatDocs <-+        docWrapNode lmatches+        $ layoutPatternBind Nothing binderDoc+        `mapM` matches+      docAlt+        [ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+          (docSeq+            [ appSep $ docLit $ Text.pack "case"+            , appSep $ docForceSingleline cExpDoc+            , docLit $ Text.pack "of"+            ]+          )+          (docSetBaseAndIndent+          $ docNonBottomSpacing+          $ docLines+          $ return+          <$> funcPatDocs+          )+        , docPar+          (docAddBaseY BrIndentRegular+          $ docPar (docLit $ Text.pack "case") cExpDoc+          )+          (docAddBaseY BrIndentRegular $ docPar+            (docLit $ Text.pack "of")+            (docSetBaseAndIndent+            $ docNonBottomSpacing+            $ docLines+            $ return+            <$> funcPatDocs+            )+          )+        ]+    HsIf _ ifExpr thenExpr elseExpr -> do+      ifExprDoc <- docSharedWrapper layoutExpr ifExpr+      thenExprDoc <- docSharedWrapper layoutExpr thenExpr+      elseExprDoc <- docSharedWrapper layoutExpr elseExpr+      hasComments <- hasAnyCommentsBelow lexpr+      let+        maySpecialIndent = case indentPolicy of+          IndentPolicyLeft -> BrIndentRegular+          IndentPolicyMultiple -> BrIndentRegular+          IndentPolicyFree -> BrIndentSpecial 3+      -- TODO: some of the alternatives (especially last and last-but-one)+      -- overlap.+      docSetIndentLevel $ runFilteredAlternative $ do+        -- if _ then _ else _+        addAlternativeCond (not hasComments) $ docSeq+          [ appSep $ docLit $ Text.pack "if"+          , appSep $ docForceSingleline ifExprDoc+          , appSep $ docLit $ Text.pack "then"+          , appSep $ docForceSingleline thenExprDoc+          , appSep $ docLit $ Text.pack "else"+          , docForceSingleline elseExprDoc+          ]+        -- either+        --   if expr+        --   then foo+        --     bar+        --   else foo+        --     bar+        -- or+        --   if expr+        --   then+        --     stuff+        --   else+        --     stuff+        -- note that this has par-spacing+        addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+          (docSeq+            [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"+            , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc+            ]+          )+          (docLines+            [ docAddBaseY BrIndentRegular+            $ docNodeAnnKW lexpr (Just AnnThen)+            $ docNonBottomSpacing+            $ docAlt+                [ docSeq+                  [ appSep $ docLit $ Text.pack "then"+                  , docForceParSpacing thenExprDoc+                  ]+                , docAddBaseY BrIndentRegular+                  $ docPar (docLit $ Text.pack "then") thenExprDoc+                ]+            , docAddBaseY BrIndentRegular $ docNonBottomSpacing $ docAlt+              [ docSeq+                [ appSep $ docLit $ Text.pack "else"+                , docForceParSpacing elseExprDoc+                ]+              , docAddBaseY BrIndentRegular+                $ docPar (docLit $ Text.pack "else") elseExprDoc+              ]+            ]+          )+        -- either+        --   if multi+        --      line+        --      condition+        --   then foo+        --     bar+        --   else foo+        --     bar+        -- or+        --   if multi+        --      line+        --      condition+        --   then+        --     stuff+        --   else+        --     stuff+        -- note that this does _not_ have par-spacing+        addAlternative $ docAddBaseY BrIndentRegular $ docPar+          (docAddBaseY maySpecialIndent $ docSeq+            [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"+            , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc+            ]+          )+          (docLines+            [ docAddBaseY BrIndentRegular+            $ docNodeAnnKW lexpr (Just AnnThen)+            $ docAlt+                [ docSeq+                  [ appSep $ docLit $ Text.pack "then"+                  , docForceParSpacing thenExprDoc+                  ]+                , docAddBaseY BrIndentRegular+                  $ docPar (docLit $ Text.pack "then") thenExprDoc+                ]+            , docAddBaseY BrIndentRegular $ docAlt+              [ docSeq+                [ appSep $ docLit $ Text.pack "else"+                , docForceParSpacing elseExprDoc+                ]+              , docAddBaseY BrIndentRegular+                $ docPar (docLit $ Text.pack "else") elseExprDoc+              ]+            ]+          )+        addAlternative $ docSetBaseY $ docLines+          [ docAddBaseY maySpecialIndent $ docSeq+            [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"+            , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc+            ]+          , docNodeAnnKW lexpr (Just AnnThen)+          $ docAddBaseY BrIndentRegular+          $ docPar (docLit $ Text.pack "then") thenExprDoc+          , docAddBaseY BrIndentRegular+            $ docPar (docLit $ Text.pack "else") elseExprDoc+          ]+    HsMultiIf _ cases -> do+      clauseDocs <- cases `forM` layoutGrhs+      binderDoc <- docLit $ Text.pack "->"+      hasComments <- hasAnyCommentsBelow lexpr+      docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+        (docLit $ Text.pack "if")+        (layoutPatternBindFinal+          Nothing+          binderDoc+          Nothing+          clauseDocs+          Nothing+          hasComments+        )+    HsLet _ binds exp1 -> do+      expDoc1 <- docSharedWrapper layoutExpr exp1+      -- We jump through some ugly hoops here to ensure proper sharing.+      hasComments <- hasAnyCommentsBelow lexpr+      mBindDocs <- fmap (fmap pure) <$> layoutLocalBinds binds+      let+        ifIndentFreeElse :: a -> a -> a+        ifIndentFreeElse x y = case indentPolicy of+          IndentPolicyLeft -> y+          IndentPolicyMultiple -> y+          IndentPolicyFree -> x+      -- this `docSetBaseAndIndent` might seem out of place (especially the+      -- Indent part; setBase is necessary due to the use of docLines below),+      -- but is here due to ghc-exactprint's DP handling of "let" in+      -- particular.+      -- Just pushing another indentation level is a straightforward approach+      -- 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.+      docSetBaseAndIndent $ case mBindDocs of+        Just [bindDoc] -> runFilteredAlternative $ do+          addAlternativeCond (not hasComments) $ docSeq+            [ appSep $ docLit $ Text.pack "let"+            , docNodeAnnKW lexpr (Just AnnLet) $ appSep $ docForceSingleline+              bindDoc+            , appSep $ docLit $ Text.pack "in"+            , docForceSingleline expDoc1+            ]+          addAlternative $ docLines+            [ docNodeAnnKW lexpr (Just AnnLet) $ docAlt+              [ docSeq+                [ appSep $ docLit $ Text.pack "let"+                , ifIndentFreeElse docSetBaseAndIndent docForceSingleline+                  $ bindDoc+                ]+              , docAddBaseY BrIndentRegular $ docPar+                (docLit $ Text.pack "let")+                (docSetBaseAndIndent bindDoc)+              ]+            , docAlt+              [ docSeq+                [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in"+                , ifIndentFreeElse+                  docSetBaseAndIndent+                  docForceSingleline+                  expDoc1+                ]+              , docAddBaseY BrIndentRegular+                $ docPar (docLit $ Text.pack "in") (docSetBaseY expDoc1)+              ]+            ]+        Just bindDocs@(_ : _) -> runFilteredAlternative $ do+          --either+          --  let+          --    a = b+          --    c = d+          --  in foo+          --    bar+          --    baz+          --or+          --  let+          --    a = b+          --    c = d+          --  in+          --    fooooooooooooooooooo+          let+            noHangingBinds =+              [ docNonBottomSpacing $ docAddBaseY BrIndentRegular $ docPar+                (docLit $ Text.pack "let")+                (docSetBaseAndIndent $ docLines bindDocs)+              , docSeq+                [ docLit $ Text.pack "in "+                , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc1+                ]+              ]+          addAlternative $ case indentPolicy of+            IndentPolicyLeft -> docLines noHangingBinds+            IndentPolicyMultiple -> docLines noHangingBinds+            IndentPolicyFree -> docLines+              [ docNodeAnnKW lexpr (Just AnnLet) $ docSeq+                [ appSep $ docLit $ Text.pack "let"+                , docSetBaseAndIndent $ docLines bindDocs+                ]+              , docSeq [appSep $ docLit $ Text.pack "in ", docSetBaseY expDoc1]+              ]+          addAlternative $ docLines+            [ docNodeAnnKW lexpr (Just AnnLet)+            $ docAddBaseY BrIndentRegular+            $ docPar+                (docLit $ Text.pack "let")+                (docSetBaseAndIndent $ docLines $ bindDocs)+            , docAddBaseY BrIndentRegular+              $ docPar (docLit $ Text.pack "in") (docSetBaseY $ expDoc1)+            ]+        _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1]+      -- docSeq [appSep $ docLit "let in", expDoc1]+    HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of+      DoExpr _ -> do+        stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts+        docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+          (docLit $ Text.pack "do")+          (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)+      MDoExpr _ -> do+        stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts+        docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+          (docLit $ Text.pack "mdo")+          (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)+      x+        | case x of+          ListComp -> True+          MonadComp -> True+          _ -> False+        -> do+          stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts+          hasComments <- hasAnyCommentsBelow lexpr+          runFilteredAlternative $ do+            addAlternativeCond (not hasComments) $ docSeq+              [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "["+              , docNodeAnnKW lexpr (Just AnnOpenS)+              $ appSep+              $ docForceSingleline+              $ List.last stmtDocs+              , appSep $ docLit $ Text.pack "|"+              , docSeq+              $ List.intersperse docCommaSep+              $ docForceSingleline+              <$> List.init stmtDocs+              , docLit $ Text.pack " ]"+              ]+            addAlternative+              $ let+                  start = docCols+                    ColListComp+                    [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack+                      "["+                    , docSetBaseY+                    $ docNodeAnnKW lexpr (Just AnnOpenS)+                    $ List.last stmtDocs+                    ]+                  (s1 : sM) = List.init stmtDocs+                  line1 =+                    docCols ColListComp [appSep $ docLit $ Text.pack "|", s1]+                  lineM = sM <&> \d -> docCols ColListComp [docCommaSep, d]+                  end = docLit $ Text.pack "]"+                in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]+      _ -> do+        -- TODO+        unknownNodeError "HsDo{} unknown stmtCtx" lexpr+    ExplicitList _ _ elems@(_ : _) -> do+      elemDocs <- elems `forM` docSharedWrapper layoutExpr+      hasComments <- hasAnyCommentsBelow lexpr+      case splitFirstLast elemDocs of+        FirstLastEmpty -> docSeq+          [ docLit $ Text.pack "["+          , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]"+          ]+        FirstLastSingleton e -> docAlt+          [ docSeq+            [ docLit $ Text.pack "["+            , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e+            , docLit $ Text.pack "]"+            ]+          , docSetBaseY $ docLines+            [ docSeq+              [ docLit $ Text.pack "["+              , docSeparator+              , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e+              ]+            , docLit $ Text.pack "]"+            ]+          ]+        FirstLast e1 ems eN -> runFilteredAlternative $ do+          addAlternativeCond (not hasComments)+            $ docSeq+            $ [docLit $ Text.pack "["]+            ++ List.intersperse+                 docCommaSep+                 (docForceSingleline+                 <$> (e1 : ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN])+                 )+            ++ [docLit $ Text.pack "]"]+          addAlternative+            $ let+                start = docCols ColList [appSep $ docLit $ Text.pack "[", e1]+                linesM = ems <&> \d -> docCols ColList [docCommaSep, d]+                lineN = docCols+                  ColList+                  [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN]+                end = docLit $ Text.pack "]"+              in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]+    ExplicitList _ _ [] -> docLit $ Text.pack "[]"+    RecordCon _ lname fields -> case fields of+      HsRecFields fs Nothing -> do+        let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname+        rFs <-+          fs `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do+            let FieldOcc _ lnameF = fieldOcc+            rFExpDoc <- if pun+              then return Nothing+              else Just <$> docSharedWrapper layoutExpr rFExpr+            return $ (lfield, lrdrNameToText lnameF, rFExpDoc)+        recordExpression False indentPolicy lexpr nameDoc rFs+      HsRecFields [] (Just (L _ 0)) -> do+        let t = lrdrNameToText lname+        docWrapNode lname $ docLit $ t <> Text.pack " { .. }"+      HsRecFields fs@(_ : _) (Just (L _ dotdoti)) | dotdoti == length fs -> do+        let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname+        fieldDocs <-+          fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do+            let FieldOcc _ lnameF = fieldOcc+            fExpDoc <- if pun+              then return Nothing+              else Just <$> docSharedWrapper layoutExpr fExpr+            return (fieldl, lrdrNameToText lnameF, fExpDoc)+        recordExpression True indentPolicy lexpr nameDoc fieldDocs+      _ -> unknownNodeError "RecordCon with puns" lexpr+    RecordUpd _ rExpr fields -> do+      rExprDoc <- docSharedWrapper layoutExpr rExpr+      rFs <-+        fields `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do+          rFExpDoc <- if pun+            then return Nothing+            else Just <$> docSharedWrapper layoutExpr rFExpr+          return $ case ambName of+            Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)+            Ambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)+      recordExpression False indentPolicy lexpr rExprDoc rFs+    ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do+      expDoc <- docSharedWrapper layoutExpr exp1+      typDoc <- docSharedWrapper layoutType typ1+      docSeq [appSep expDoc, appSep $ docLit $ Text.pack "::", typDoc]+    ArithSeq _ Nothing info -> case info of+      From e1 -> do+        e1Doc <- docSharedWrapper layoutExpr e1+        docSeq+          [ docLit $ Text.pack "["+          , appSep $ docForceSingleline e1Doc+          , docLit $ Text.pack "..]"+          ]+      FromThen e1 e2 -> do+        e1Doc <- docSharedWrapper layoutExpr e1+        e2Doc <- docSharedWrapper layoutExpr e2+        docSeq+          [ docLit $ Text.pack "["+          , docForceSingleline e1Doc+          , appSep $ docLit $ Text.pack ","+          , appSep $ docForceSingleline e2Doc+          , docLit $ Text.pack "..]"+          ]+      FromTo e1 eN -> do+        e1Doc <- docSharedWrapper layoutExpr e1+        eNDoc <- docSharedWrapper layoutExpr eN+        docSeq+          [ docLit $ Text.pack "["+          , appSep $ docForceSingleline e1Doc+          , appSep $ docLit $ Text.pack ".."+          , docForceSingleline eNDoc+          , docLit $ Text.pack "]"+          ]+      FromThenTo e1 e2 eN -> do+        e1Doc <- docSharedWrapper layoutExpr e1+        e2Doc <- docSharedWrapper layoutExpr e2+        eNDoc <- docSharedWrapper layoutExpr eN+        docSeq+          [ docLit $ Text.pack "["+          , docForceSingleline e1Doc+          , appSep $ docLit $ Text.pack ","+          , appSep $ docForceSingleline e2Doc+          , appSep $ docLit $ Text.pack ".."+          , docForceSingleline eNDoc+          , docLit $ Text.pack "]"+          ]+    ArithSeq{} -> briDocByExactInlineOnly "ArithSeq" lexpr+    HsBracket{} -> do+      -- TODO+      briDocByExactInlineOnly "HsBracket{}" lexpr+    HsRnBracketOut{} -> do+      -- TODO+      briDocByExactInlineOnly "HsRnBracketOut{}" lexpr+    HsTcBracketOut{} -> do+      -- TODO+      briDocByExactInlineOnly "HsTcBracketOut{}" lexpr+    HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do+      allocateNode $ BDFPlain+        (Text.pack+        $ "["+        ++ showOutputable quoter+        ++ "|"+        ++ showOutputable content+        ++ "|]"+        )+    HsSpliceE{} -> do+      -- TODO+      briDocByExactInlineOnly "HsSpliceE{}" lexpr+    HsProc{} -> do+      -- TODO+      briDocByExactInlineOnly "HsProc{}" lexpr+    HsStatic{} -> do+      -- TODO+      briDocByExactInlineOnly "HsStatic{}" lexpr+    HsTick{} -> do+      -- TODO+      briDocByExactInlineOnly "HsTick{}" lexpr+    HsBinTick{} -> do+      -- TODO+      briDocByExactInlineOnly "HsBinTick{}" lexpr+    HsConLikeOut{} -> do+      -- TODO+      briDocByExactInlineOnly "HsWrap{}" lexpr+    ExplicitSum{} -> do+      -- TODO+      briDocByExactInlineOnly "ExplicitSum{}" lexpr+    HsPragE{} -> do+      -- TODO+      briDocByExactInlineOnly "HsPragE{}" lexpr++recordExpression+  :: (Data.Data.Data lExpr, Data.Data.Data name)+  => Bool+  -> IndentPolicy+  -> GenLocated SrcSpan lExpr+  -> ToBriDocM BriDocNumbered+  -> [ ( GenLocated SrcSpan name+       , Text+       , Maybe (ToBriDocM BriDocNumbered)+       )+     ]+  -> ToBriDocM BriDocNumbered+recordExpression False _ lexpr nameDoc [] = docSeq+  [ docNodeAnnKW lexpr (Just AnnOpenC)+    $ docSeq [nameDoc, docLit $ Text.pack "{"]+  , docLit $ Text.pack "}"+  ]+recordExpression True _ lexpr nameDoc [] = docSeq -- this case might still be incomplete, and is probably not used+         -- atm anyway.+  [ docNodeAnnKW lexpr (Just AnnOpenC)+    $ docSeq [nameDoc, docLit $ Text.pack "{"]+  , docLit $ Text.pack " .. }"+  ]+recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1 : rFr) = do+  let (rF1f, rF1n, rF1e) = rF1+  runFilteredAlternative $ do+    -- container { fieldA = blub, fieldB = blub }+    addAlternative $ docSeq+      [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc+      , appSep $ docLit $ Text.pack "{"+      , docSeq $ List.intersperse docCommaSep $ rFs <&> \case+        (lfield, fieldStr, Just fieldDoc) -> docWrapNode lfield $ docSeq+          [ appSep $ docLit fieldStr+          , appSep $ docLit $ Text.pack "="+          , docForceSingleline fieldDoc+          ]+        (lfield, fieldStr, Nothing) -> docWrapNode lfield $ docLit fieldStr+      , if dotdot+        then docSeq [docCommaSep, docLit $ Text.pack "..", docSeparator]+        else docSeparator+      , docLit $ Text.pack "}"+      ]+    -- hanging single-line fields+    -- container { fieldA = blub+    --           , fieldB = blub+    --           }+    addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq+      [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc+      , docSetBaseY+      $ docLines+      $ let+          line1 = docCols+            ColRec+            [ appSep $ docLit $ Text.pack "{"+            , docWrapNodePrior rF1f $ appSep $ docLit rF1n+            , case rF1e of+              Just x -> docWrapNodeRest rF1f $ docSeq+                [appSep $ docLit $ Text.pack "=", docForceSingleline x]+              Nothing -> docEmpty+            ]+          lineR = rFr <&> \(lfield, fText, fDoc) ->+            docWrapNode lfield $ docCols+              ColRec+              [ docCommaSep+              , appSep $ docLit fText+              , case fDoc of+                Just x ->+                  docSeq [appSep $ docLit $ Text.pack "=", docForceSingleline x]+                Nothing -> docEmpty+              ]+          dotdotLine = if dotdot+            then docCols+              ColRec+              [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep+              , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".."+              ]+            else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty+          lineN = docLit $ Text.pack "}"+        in [line1] ++ lineR ++ [dotdotLine, lineN]+      ]+    -- non-hanging with expressions placed to the right of the names+    -- container+    -- { fieldA = blub+    -- , fieldB = potentially+    --     multiline+    -- }+    addAlternative $ docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar+      (docNodeAnnKW lexpr Nothing nameDoc)+      (docNonBottomSpacing+      $ docLines+      $ let+          line1 = docCols+            ColRec+            [ appSep $ docLit $ Text.pack "{"+            , docWrapNodePrior rF1f $ appSep $ docLit rF1n+            , docWrapNodeRest rF1f $ case rF1e of+              Just x -> runFilteredAlternative $ do+                addAlternativeCond (indentPolicy == IndentPolicyFree) $ do+                  docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x]+                addAlternative $ do+                  docSeq+                    [appSep $ docLit $ Text.pack "=", docForceParSpacing x]+                addAlternative $ do+                  docAddBaseY BrIndentRegular+                    $ docPar (docLit $ Text.pack "=") x+              Nothing -> docEmpty+            ]+          lineR = rFr <&> \(lfield, fText, fDoc) ->+            docWrapNode lfield $ docCols+              ColRec+              [ docCommaSep+              , appSep $ docLit fText+              , case fDoc of+                Just x -> runFilteredAlternative $ do+                  addAlternativeCond (indentPolicy == IndentPolicyFree) $ do+                    docSeq [appSep $ docLit $ Text.pack "=", docSetBaseY x]+                  addAlternative $ do+                    docSeq+                      [appSep $ docLit $ Text.pack "=", docForceParSpacing x]+                  addAlternative $ do+                    docAddBaseY BrIndentRegular+                      $ docPar (docLit $ Text.pack "=") x+                Nothing -> docEmpty+              ]+          dotdotLine = if dotdot+            then docCols+              ColRec+              [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep+              , docNodeAnnKW lexpr (Just AnnDotdot) $ docLit $ Text.pack ".."+              ]+            else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty+          lineN = docLit $ Text.pack "}"+        in [line1] ++ lineR ++ [dotdotLine, lineN]+      )++litBriDoc :: HsLit GhcPs -> BriDocFInt+litBriDoc = \case+  HsChar (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']+  HsCharPrim (SourceText t) _c -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']+  HsString (SourceText t) _fastString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString+  HsStringPrim (SourceText t) _byteString -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString+  HsInt _ (IL (SourceText t) _ _) -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsIntPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsWordPrim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsInt64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsWord64Prim (SourceText t) _i -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsInteger (SourceText t) _i _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i+  HsRat _ (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t+  HsFloatPrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t+  HsDoublePrim _ (FL (SourceText t) _ _) -> BDFLit $ Text.pack t+  _ -> error "litBriDoc: literal with no SourceText"++overLitValBriDoc :: OverLitVal -> BriDocFInt+overLitValBriDoc = \case+  HsIntegral (IL (SourceText t) _ _) -> BDFLit $ Text.pack t+  HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t+  HsIsString (SourceText t) _ -> BDFLit $ Text.pack t+  _ -> error "overLitValBriDoc: literal with no SourceText"
+ source/library/Brittany/Internal/Layouters/Expr.hs-boot view
@@ -0,0 +1,16 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Layouters.Expr where++import GHC.Hs+import Brittany.Internal.Types++++layoutExpr :: ToBriDoc HsExpr++-- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))++litBriDoc :: HsLit GhcPs -> BriDocFInt++overLitValBriDoc :: OverLitVal -> BriDocFInt
+ source/library/Brittany/Internal/Layouters/IE.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Layouters.IE where++import qualified Data.List.Extra+import qualified Data.Text as Text+import GHC+  ( AnnKeywordId(..)+  , GenLocated(L)+  , Located+  , ModuleName+  , moduleNameString+  , unLoc+  )+import GHC.Hs+import qualified GHC.OldList as List+import Brittany.Internal.LayouterBasics+import Brittany.Internal.Prelude+import Brittany.Internal.Types+import Brittany.Internal.Utils++++prepareName :: LIEWrappedName name -> Located name+prepareName = ieLWrappedName++layoutIE :: ToBriDoc IE+layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of+  IEVar _ x -> layoutWrapped lie x+  IEThingAbs _ x -> layoutWrapped lie x+  IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]+  IEThingWith _ x (IEWildcard _) _ _ ->+    docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]+  IEThingWith _ x _ ns _ -> do+    hasComments <- orM+      (hasCommentsBetween lie AnnOpenP AnnCloseP+      : hasAnyCommentsBelow x+      : map hasAnyCommentsBelow ns+      )+    let sortedNs = List.sortOn wrappedNameToText ns+    runFilteredAlternative $ do+      addAlternativeCond (not hasComments)+        $ docSeq+        $ [layoutWrapped lie x, docLit $ Text.pack "("]+        ++ intersperse docCommaSep (map nameDoc sortedNs)+        ++ [docParenR]+      addAlternative+        $ docWrapNodeRest lie+        $ docAddBaseY BrIndentRegular+        $ docPar (layoutWrapped lie x) (layoutItems (splitFirstLast sortedNs))+   where+    nameDoc = docLit <=< lrdrNameToTextAnn . prepareName+    layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]+    layoutItems FirstLastEmpty = docSetBaseY $ docLines+      [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty]+      , docParenR+      ]+    layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines+      [ docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n]+      , docParenR+      ]+    layoutItems (FirstLast n1 nMs nN) =+      docSetBaseY+        $ docLines+        $ [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]+        ++ map layoutItem nMs+        ++ [ docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN]+           , docParenR+           ]+  IEModuleContents _ n -> docSeq+    [ docLit $ Text.pack "module"+    , docSeparator+    , docLit . Text.pack . moduleNameString $ unLoc n+    ]+  _ -> docEmpty+ where+  layoutWrapped _ = \case+    L _ (IEName n) -> docLit =<< lrdrNameToTextAnn n+    L _ (IEPattern n) -> do+      name <- lrdrNameToTextAnn n+      docLit $ Text.pack "pattern " <> name+    L _ (IEType n) -> do+      name <- lrdrNameToTextAnn n+      docLit $ Text.pack "type " <> name++data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted+-- Helper function to deal with Located lists of LIEs.+-- In particular this will also associate documentation+-- from the located list that actually belongs to the last IE.+-- It also adds docCommaSep to all but the first element+-- This configuration allows both vertical and horizontal+-- handling of the resulting list. Adding parens is+-- left to the caller since that is context sensitive+layoutAnnAndSepLLIEs+  :: SortItemsFlag+  -> Located [LIE GhcPs]+  -> ToBriDocM [ToBriDocM BriDocNumbered]+layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do+  let makeIENode ie = docSeq [docCommaSep, ie]+  let+    sortedLies =+      [ items+      | group <- Data.List.Extra.groupOn lieToText $ List.sortOn lieToText lies+      , items <- mergeGroup group+      ]+  let+    ieDocs = fmap layoutIE $ case shouldSort of+      ShouldSortItems -> sortedLies+      KeepItemsUnsorted -> lies+  ieCommaDocs <-+    docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of+      FirstLastEmpty -> []+      FirstLastSingleton ie -> [ie]+      FirstLast ie1 ieMs ieN ->+        [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]+  pure $ fmap pure ieCommaDocs -- returned shared nodes+ where+  mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]+  mergeGroup [] = []+  mergeGroup items@[_] = items+  mergeGroup items = if+    | all isProperIEThing items -> [List.foldl1' thingFolder items]+    | all isIEVar items -> [List.foldl1' thingFolder items]+    | otherwise -> items+  -- proper means that if it is a ThingWith, it does not contain a wildcard+  -- (because I don't know what a wildcard means if it is not already a+  -- IEThingAll).+  isProperIEThing :: LIE GhcPs -> Bool+  isProperIEThing = \case+    L _ (IEThingAbs _ _wn) -> True+    L _ (IEThingAll _ _wn) -> True+    L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True+    _ -> False+  isIEVar :: LIE GhcPs -> Bool+  isIEVar = \case+    L _ IEVar{} -> True+    _ -> False+  thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs+  thingFolder l1@(L _ IEVar{}) _ = l1+  thingFolder l1@(L _ IEThingAll{}) _ = l1+  thingFolder _ l2@(L _ IEThingAll{}) = l2+  thingFolder l1 (L _ IEThingAbs{}) = l1+  thingFolder (L _ IEThingAbs{}) l2 = l2+  thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))+    = L+      l+      (IEThingWith+        x+        wn+        NoIEWildcard+        (consItems1 ++ consItems2)+        (fieldLbls1 ++ fieldLbls2)+      )+  thingFolder _ _ =+    error "thingFolder should be exhaustive because we have a guard above"+++-- Builds a complete layout for the given located+-- list of LIEs. The layout provides two alternatives:+-- (item, item, ..., item)+-- ( item+-- , item+-- ...+-- , item+-- )+-- If the llies contains comments the list will+-- always expand over multiple lines, even when empty:+-- () -- no comments+-- ( -- a comment+-- )+layoutLLIEs+  :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered+layoutLLIEs enableSingleline shouldSort llies = do+  ieDs <- layoutAnnAndSepLLIEs shouldSort llies+  hasComments <- hasAnyCommentsBelow llies+  runFilteredAlternative $ case ieDs of+    [] -> do+      addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"+      addAlternativeCond hasComments $ docPar+        (docSeq [docParenLSep, docWrapNodeRest llies docEmpty])+        docParenR+    (ieDsH : ieDsT) -> do+      addAlternativeCond (not hasComments && enableSingleline)+        $ docSeq+        $ [docLit (Text.pack "(")]+        ++ (docForceSingleline <$> ieDs)+        ++ [docParenR]+      addAlternative+        $ docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])+        $ docLines+        $ ieDsT+        ++ [docParenR]++-- | Returns a "fingerprint string", not a full text representation, nor even+-- a source code representation of this syntax node.+-- Used for sorting, not for printing the formatter's output source code.+wrappedNameToText :: LIEWrappedName RdrName -> Text+wrappedNameToText = \case+  L _ (IEName n) -> lrdrNameToText n+  L _ (IEPattern n) -> lrdrNameToText n+  L _ (IEType n) -> lrdrNameToText n++-- | Returns a "fingerprint string", not a full text representation, nor even+-- a source code representation of this syntax node.+-- Used for sorting, not for printing the formatter's output source code.+lieToText :: LIE GhcPs -> Text+lieToText = \case+  L _ (IEVar _ wn) -> wrappedNameToText wn+  L _ (IEThingAbs _ wn) -> wrappedNameToText wn+  L _ (IEThingAll _ wn) -> wrappedNameToText wn+  L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn+  -- TODO: These _may_ appear in exports!+  -- Need to check, and either put them at the top (for module) or do some+  -- other clever thing.+  L _ (IEModuleContents _ n) -> moduleNameToText n+  L _ IEGroup{} -> Text.pack "@IEGroup"+  L _ IEDoc{} -> Text.pack "@IEDoc"+  L _ IEDocNamed{} -> Text.pack "@IEDocNamed"+ where+  moduleNameToText :: Located ModuleName -> Text+  moduleNameToText (L _ name) =+    Text.pack ("@IEModuleContents" ++ moduleNameString name)
+ source/library/Brittany/Internal/Layouters/Import.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Layouters.Import where++import qualified Data.Semigroup as Semigroup+import qualified Data.Text as Text+import GHC (GenLocated(L), Located, moduleNameString, unLoc)+import GHC.Hs+import GHC.Types.Basic+import GHC.Unit.Types (IsBootInterface(..))+import Brittany.Internal.Config.Types+import Brittany.Internal.LayouterBasics+import Brittany.Internal.Layouters.IE+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types++++prepPkg :: SourceText -> String+prepPkg rawN = case rawN of+  SourceText n -> n+  -- This would be odd to encounter and the+  -- result will most certainly be wrong+  NoSourceText -> ""+prepModName :: Located e -> e+prepModName = unLoc++layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered+layoutImport importD = case importD of+  ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do+    importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack+    importAsCol <-+      mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack+    indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack+    let+      compact = indentPolicy /= IndentPolicyFree+      modNameT = Text.pack $ moduleNameString modName+      pkgNameT = Text.pack . prepPkg . sl_st <$> pkg+      masT = Text.pack . moduleNameString . prepModName <$> mas+      hiding = maybe False fst mllies+      minQLength = length "import qualified "+      qLengthReal =+        let+          qualifiedPart = if q /= NotQualified then length "qualified " else 0+          safePart = if safe then length "safe " else 0+          pkgPart = maybe 0 ((+ 1) . Text.length) pkgNameT+          srcPart = case src of+            IsBoot -> length "{-# SOURCE #-} "+            NotBoot -> 0+        in length "import " + srcPart + safePart + qualifiedPart + pkgPart+      qLength = max minQLength qLengthReal+      -- Cost in columns of importColumn+      asCost = length "as "+      hidingParenCost = if hiding then length "hiding ( " else length "( "+      nameCost = Text.length modNameT + qLength+      importQualifiers = docSeq+        [ appSep $ docLit $ Text.pack "import"+        , case src of+          IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"+          NotBoot -> docEmpty+        , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty+        , if q /= NotQualified+          then appSep $ docLit $ Text.pack "qualified"+          else docEmpty+        , maybe docEmpty (appSep . docLit) pkgNameT+        ]+      indentName =+        if compact then id else docEnsureIndent (BrIndentSpecial qLength)+      modNameD = indentName $ appSep $ docLit modNameT+      hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2+      hidDocColDiff = importCol - 2 - hidDocCol+      hidDoc =+        if hiding then appSep $ docLit $ Text.pack "hiding" else docEmpty+      importHead = docSeq [importQualifiers, modNameD]+      bindingsD = case mllies of+        Nothing -> docEmpty+        Just (_, llies) -> do+          hasComments <- hasAnyCommentsBelow llies+          if compact+            then docAlt+              [ docSeq+                [ hidDoc+                , docForceSingleline $ layoutLLIEs True ShouldSortItems llies+                ]+              , let+                  makeParIfHiding = if hiding+                    then docAddBaseY BrIndentRegular . docPar hidDoc+                    else id+                in makeParIfHiding (layoutLLIEs True ShouldSortItems llies)+              ]+            else do+              ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies+              docWrapNodeRest llies+                $ docEnsureIndent (BrIndentSpecial hidDocCol)+                $ case ieDs of+                  -- ..[hiding].( )+                    [] -> if hasComments+                      then docPar+                        (docSeq+                          [hidDoc, docParenLSep, docWrapNode llies docEmpty]+                        )+                        (docEnsureIndent+                          (BrIndentSpecial hidDocColDiff)+                          docParenR+                        )+                      else docSeq+                        [hidDoc, docParenLSep, docSeparator, docParenR]+                    -- ..[hiding].( b )+                    [ieD] -> runFilteredAlternative $ do+                      addAlternativeCond (not hasComments)+                        $ docSeq+                            [ hidDoc+                            , docParenLSep+                            , docForceSingleline ieD+                            , docSeparator+                            , docParenR+                            ]+                      addAlternative $ docPar+                        (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])+                        (docEnsureIndent+                          (BrIndentSpecial hidDocColDiff)+                          docParenR+                        )+                    -- ..[hiding].( b+                    --            , b'+                    --            )+                    (ieD : ieDs') -> docPar+                      (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]]+                      )+                      (docEnsureIndent (BrIndentSpecial hidDocColDiff)+                      $ docLines+                      $ ieDs'+                      ++ [docParenR]+                      )+      makeAsDoc asT =+        docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT]+    if compact+      then+        let asDoc = maybe docEmpty makeAsDoc masT+        in+          docAlt+            [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD]+            , docAddBaseY BrIndentRegular+              $ docPar (docSeq [importHead, asDoc]) bindingsD+            ]+      else case masT of+        Just n -> if enoughRoom+          then docLines [docSeq [importHead, asDoc], bindingsD]+          else docLines [importHead, asDoc, bindingsD]+         where+          enoughRoom = nameCost < importAsCol - asCost+          asDoc = docEnsureIndent (BrIndentSpecial (importAsCol - asCost))+            $ makeAsDoc n+        Nothing -> if enoughRoom+          then docSeq [importHead, bindingsD]+          else docLines [importHead, bindingsD]+          where enoughRoom = nameCost < importCol - hidingParenCost+  _ -> docEmpty
+ source/library/Brittany/Internal/Layouters/Module.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Layouters.Module where++import qualified Data.Maybe+import qualified Data.Semigroup as Semigroup+import qualified Data.Text as Text+import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc)+import GHC.Hs+import qualified GHC.OldList as List+import Brittany.Internal.Config.Types+import Brittany.Internal.LayouterBasics+import Brittany.Internal.Layouters.IE+import Brittany.Internal.Layouters.Import+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import Language.Haskell.GHC.ExactPrint as ExactPrint+import Language.Haskell.GHC.ExactPrint.Types+  (DeltaPos(..), commentContents, deltaRow)++++layoutModule :: ToBriDoc' HsModule+layoutModule lmod@(L _ mod') = case mod' of+    -- Implicit module Main+  HsModule _ Nothing _ imports _ _ _ -> do+    commentedImports <- transformToCommentedImport imports+    -- groupify commentedImports `forM_` tellDebugMessShow+    docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)+    -- sortedImports <- sortImports imports+    -- docLines $ [layoutImport y i | (y, i) <- sortedImports]+  HsModule _ (Just n) les imports _ _ _ -> do+    commentedImports <- transformToCommentedImport imports+    -- groupify commentedImports `forM_` tellDebugMessShow+    -- sortedImports <- sortImports imports+    let tn = Text.pack $ moduleNameString $ unLoc n+    allowSingleLineExportList <-+      mAsk <&> _conf_layout .> _lconfig_allowSingleLineExportList .> confUnpack+    -- the config should not prevent single-line layout when there is no+    -- export list+    let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les+    docLines+      $ docSeq+          [ docNodeAnnKW lmod Nothing docEmpty+             -- A pseudo node that serves merely to force documentation+             -- before the node+          , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do+            addAlternativeCond allowSingleLine $ docForceSingleline $ docSeq+              [ appSep $ docLit $ Text.pack "module"+              , appSep $ docLit tn+              , docWrapNode lmod $ appSep $ case les of+                Nothing -> docEmpty+                Just x -> layoutLLIEs True KeepItemsUnsorted x+              , docSeparator+              , docLit $ Text.pack "where"+              ]+            addAlternative $ docLines+              [ docAddBaseY BrIndentRegular $ docPar+                  (docSeq [appSep $ docLit $ Text.pack "module", docLit tn])+                  (docSeq+                    [ docWrapNode lmod $ case les of+                      Nothing -> docEmpty+                      Just x -> layoutLLIEs False KeepItemsUnsorted x+                    , docSeparator+                    , docLit $ Text.pack "where"+                    ]+                  )+              ]+          ]+      : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports]++data CommentedImport+  = EmptyLine+  | IndependentComment (Comment, DeltaPos)+  | ImportStatement ImportStatementRecord++instance Show CommentedImport where+  show = \case+    EmptyLine -> "EmptyLine"+    IndependentComment _ -> "IndependentComment"+    ImportStatement r ->+      "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show+        (length $ commentsAfter r)++data ImportStatementRecord = ImportStatementRecord+  { commentsBefore :: [(Comment, DeltaPos)]+  , commentsAfter :: [(Comment, DeltaPos)]+  , importStatement :: ImportDecl GhcPs+  }++instance Show ImportStatementRecord where+  show r =+    "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show+      (length $ commentsAfter r)++transformToCommentedImport+  :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]+transformToCommentedImport is = do+  nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do+    annotionMay <- astAnn i+    pure (annotionMay, rawImport)+  let+    convertComment (c, DP (y, x)) =+      replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]+    accumF+      :: [(Comment, DeltaPos)]+      -> (Maybe Annotation, ImportDecl GhcPs)+      -> ([(Comment, DeltaPos)], [CommentedImport])+    accumF accConnectedComm (annMay, decl) = case annMay of+      Nothing ->+        ( []+        , [ ImportStatement ImportStatementRecord+              { commentsBefore = []+              , commentsAfter = []+              , importStatement = decl+              }+          ]+        )+      Just ann ->+        let+          blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1+          (newAccumulator, priorComments') =+            List.span ((== 0) . deltaRow . snd) (annPriorComments ann)+          go+            :: [(Comment, DeltaPos)]+            -> [(Comment, DeltaPos)]+            -> ([CommentedImport], [(Comment, DeltaPos)], Int)+          go acc [] = ([], acc, 0)+          go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)+          go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs+          go acc ((c1, DP (y, x)) : xs) =+            ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine+            , (c1, DP (1, x)) : acc+            , 0+            )+          (convertedIndependentComments, beforeComments, initialBlanks) =+            if blanksBeforeImportDecl /= 0+              then (convertComment =<< priorComments', [], 0)+              else go [] (reverse priorComments')+        in+          ( newAccumulator+          , convertedIndependentComments+          ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine+          ++ [ ImportStatement ImportStatementRecord+                 { commentsBefore = beforeComments+                 , commentsAfter = accConnectedComm+                 , importStatement = decl+                 }+             ]+          )+  let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations+  pure $ join $ (convertComment =<< finalAcc) : finalList++sortCommentedImports :: [CommentedImport] -> [CommentedImport]+sortCommentedImports =+  unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify+ where+  unpackImports :: [CommentedImport] -> [CommentedImport]+  unpackImports xs = xs >>= \case+    l@EmptyLine -> [l]+    l@IndependentComment{} -> [l]+    ImportStatement r ->+      map IndependentComment (commentsBefore r) ++ [ImportStatement r]+  mergeGroups+    :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport]+  mergeGroups xs = xs >>= \case+    Left x -> [x]+    Right y -> ImportStatement <$> y+  sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]+  sortGroups =+    List.sortOn (moduleNameString . unLoc . ideclName . importStatement)+  groupify+    :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]]+  groupify cs = go [] cs+   where+    go [] = \case+      (l@EmptyLine : rest) -> Left l : go [] rest+      (l@IndependentComment{} : rest) -> Left l : go [] rest+      (ImportStatement r : rest) -> go [r] rest+      [] -> []+    go acc = \case+      (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest+      (l@IndependentComment{} : rest) ->+        Left l : Right (reverse acc) : go [] rest+      (ImportStatement r : rest) -> go (r : acc) rest+      [] -> [Right (reverse acc)]++commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered+commentedImportsToDoc = \case+  EmptyLine -> docLitS ""+  IndependentComment c -> commentToDoc c+  ImportStatement r -> docSeq+    (layoutImport (importStatement r) : map commentToDoc (commentsAfter r))+ where+  commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)
+ source/library/Brittany/Internal/Layouters/Pattern.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Layouters.Pattern where++import qualified Data.Foldable as Foldable+import qualified Data.Sequence as Seq+import qualified Data.Text as Text+import GHC (GenLocated(L), ol_val)+import GHC.Hs+import qualified GHC.OldList as List+import GHC.Types.Basic+import Brittany.Internal.LayouterBasics+import {-# SOURCE #-} Brittany.Internal.Layouters.Expr+import Brittany.Internal.Layouters.Type+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types++++-- | layouts patterns (inside function bindings, case alternatives, let+-- bindings or do notation). E.g. for input+--        > case computation of+--        >   (warnings, Success a b) -> ..+-- This part  ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by+-- 'layoutPat'. Similarly for+-- > func abc True 0 = []+--        ^^^^^^^^^^ this part+-- We will use `case .. of` as the imagined prefix to the examples used in+-- the different cases below.+layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)+layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of+  WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_"+    -- _ -> expr+  VarPat _ n -> fmap Seq.singleton $ docLit $ lrdrNameToText n+    -- abc -> expr+  LitPat _ lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit+    -- 0 -> expr+  ParPat _ inner -> do+    -- (nestedpat) -> expr+    left <- docLit $ Text.pack "("+    right <- docLit $ Text.pack ")"+    innerDocs <- colsWrapPat =<< layoutPat inner+    return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right+    -- return $ (left Seq.<| innerDocs) Seq.|> right+    -- case Seq.viewl innerDocs of+    --   Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur..+    --   x1 Seq.:< rest -> case Seq.viewr rest of+    --     Seq.EmptyR ->+    --       fmap return $ docSeq+    --       [ docLit $ Text.pack "("+    --       , return x1+    --       , docLit $ Text.pack ")"+    --       ]+    --     middle Seq.:> xN -> do+    --       x1' <- docSeq [docLit $ Text.pack "(", return x1]+    --       xN' <- docSeq [return xN, docLit $ Text.pack ")"]+    --       return $ (x1' Seq.<| middle) Seq.|> xN'+  ConPat _ lname (PrefixCon args) -> do+    -- Abc a b c -> expr+    nameDoc <- lrdrNameToTextAnn lname+    argDocs <- layoutPat `mapM` args+    if null argDocs+      then return <$> docLit nameDoc+      else do+        x1 <- appSep (docLit nameDoc)+        xR <- fmap Seq.fromList $ sequence $ spacifyDocs $ fmap+          colsWrapPat+          argDocs+        return $ x1 Seq.<| xR+  ConPat _ lname (InfixCon left right) -> do+    -- a :< b -> expr+    nameDoc <- lrdrNameToTextAnn lname+    leftDoc <- appSep . colsWrapPat =<< layoutPat left+    rightDoc <- colsWrapPat =<< layoutPat right+    middle <- appSep $ docLit nameDoc+    return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc+  ConPat _ lname (RecCon (HsRecFields [] Nothing)) -> do+    -- Abc{} -> expr+    let t = lrdrNameToText lname+    fmap Seq.singleton $ docLit $ t <> Text.pack "{}"+  ConPat _ lname (RecCon (HsRecFields fs@(_ : _) Nothing)) -> do+    -- Abc { a = locA, b = locB, c = locC } -> expr1+    -- Abc { a, b, c } -> expr2+    let t = lrdrNameToText lname+    fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do+      let FieldOcc _ lnameF = fieldOcc+      fExpDoc <- if pun+        then return Nothing+        else Just <$> docSharedWrapper layoutPat fPat+      return (lrdrNameToText lnameF, fExpDoc)+    Seq.singleton <$> docSeq+      [ appSep $ docLit t+      , appSep $ docLit $ Text.pack "{"+      , docSeq $ List.intersperse docCommaSep $ fds <&> \case+        (fieldName, Just fieldDoc) -> docSeq+          [ appSep $ docLit fieldName+          , appSep $ docLit $ Text.pack "="+          , fieldDoc >>= colsWrapPat+          ]+        (fieldName, Nothing) -> docLit fieldName+      , docSeparator+      , docLit $ Text.pack "}"+      ]+  ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do+    -- Abc { .. } -> expr+    let t = lrdrNameToText lname+    Seq.singleton <$> docSeq [appSep $ docLit t, docLit $ Text.pack "{..}"]+  ConPat _ lname (RecCon (HsRecFields fs@(_ : _) (Just (L _ dotdoti))))+    | dotdoti == length fs -> do+    -- Abc { a = locA, .. }+      let t = lrdrNameToText lname+      fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do+        let FieldOcc _ lnameF = fieldOcc+        fExpDoc <- if pun+          then return Nothing+          else Just <$> docSharedWrapper layoutPat fPat+        return (lrdrNameToText lnameF, fExpDoc)+      Seq.singleton <$> docSeq+        [ appSep $ docLit t+        , appSep $ docLit $ Text.pack "{"+        , docSeq $ fds >>= \case+          (fieldName, Just fieldDoc) ->+            [ appSep $ docLit fieldName+            , appSep $ docLit $ Text.pack "="+            , fieldDoc >>= colsWrapPat+            , docCommaSep+            ]+          (fieldName, Nothing) -> [docLit fieldName, docCommaSep]+        , docLit $ Text.pack "..}"+        ]+  TuplePat _ args boxity -> do+    -- (nestedpat1, nestedpat2, nestedpat3) -> expr+    -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr+    case boxity of+      Boxed -> wrapPatListy args "()" docParenL docParenR+      Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep+  AsPat _ asName asPat -> do+    -- bind@nestedpat -> expr+    wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")+  SigPat _ pat1 (HsPS _ ty1) -> do+    -- i :: Int -> expr+    patDocs <- layoutPat pat1+    tyDoc <- docSharedWrapper layoutType ty1+    case Seq.viewr patDocs of+      Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"+      xR Seq.:> xN -> do+        xN' <- -- at the moment, we don't support splitting patterns into+               -- multiple lines. but we cannot enforce pasting everything+               -- into one line either, because the type signature will ignore+               -- this if we overflow sufficiently.+               -- In order to prevent syntactically invalid results in such+               -- cases, we need the AddBaseY here.+               -- This can all change when patterns get multiline support.+               docAddBaseY BrIndentRegular $ docSeq+          [ appSep $ return xN+          , appSep $ docLit $ Text.pack "::"+          , docForceSingleline tyDoc+          ]+        return $ xR Seq.|> xN'+  ListPat _ elems ->+    -- [] -> expr1+    -- [nestedpat1, nestedpat2, nestedpat3] -> expr2+    wrapPatListy elems "[]" docBracketL docBracketR+  BangPat _ pat1 -> do+    -- !nestedpat -> expr+    wrapPatPrepend pat1 (docLit $ Text.pack "!")+  LazyPat _ pat1 -> do+    -- ~nestedpat -> expr+    wrapPatPrepend pat1 (docLit $ Text.pack "~")+  NPat _ llit@(L _ ol) mNegative _ -> do+    -- -13 -> expr+    litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol+    negDoc <- docLit $ Text.pack "-"+    pure $ case mNegative of+      Just{} -> Seq.fromList [negDoc, litDoc]+      Nothing -> Seq.singleton litDoc++  _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat++colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered+colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList++wrapPatPrepend+  :: LPat GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM (Seq BriDocNumbered)+wrapPatPrepend pat prepElem = do+  patDocs <- layoutPat pat+  case Seq.viewl patDocs of+    Seq.EmptyL -> return Seq.empty+    x1 Seq.:< xR -> do+      x1' <- docSeq [prepElem, return x1]+      return $ x1' Seq.<| xR++wrapPatListy+  :: [LPat GhcPs]+  -> String+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM BriDocNumbered+  -> ToBriDocM (Seq BriDocNumbered)+wrapPatListy elems both start end = do+  elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat)+  case Seq.viewl elemDocs of+    Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both+    x1 Seq.:< rest -> do+      sDoc <- start+      eDoc <- end+      rest' <- rest `forM` \bd -> docSeq [docCommaSep, return bd]+      return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc
+ source/library/Brittany/Internal/Layouters/Stmt.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++module 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 Brittany.Internal.Config.Types+import Brittany.Internal.LayouterBasics+import Brittany.Internal.Layouters.Decl+import {-# SOURCE #-} Brittany.Internal.Layouters.Expr+import Brittany.Internal.Layouters.Pattern+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types++++layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))+layoutStmt lstmt@(L _ stmt) = do+  indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack+  indentAmount :: Int <-+    mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+  docWrapNode lstmt $ case stmt of+    LastStmt _ body Nothing _ -> do+      layoutExpr body+    BindStmt _ lPat expr -> do+      patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat+      expDoc <- docSharedWrapper layoutExpr expr+      docAlt+        [ docCols+          ColBindStmt+          [ appSep patDoc+          , docSeq+            [ appSep $ docLit $ Text.pack "<-"+            , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc+            ]+          ]+        , docCols+          ColBindStmt+          [ appSep patDoc+          , docAddBaseY BrIndentRegular+            $ docPar (docLit $ Text.pack "<-") (expDoc)+          ]+        ]+    LetStmt _ binds -> do+      let isFree = indentPolicy == IndentPolicyFree+      let indentFourPlus = indentAmount >= 4+      layoutLocalBinds binds >>= \case+        Nothing -> docLit $ Text.pack "let"+          -- i just tested the above, and it is indeed allowed. heh.+        Just [] -> docLit $ Text.pack "let" -- this probably never happens+        Just [bindDoc] -> docAlt+          [ -- let bind = expr+            docCols+            ColDoLet+            [ appSep $ docLit $ Text.pack "let"+            , let+                f = case indentPolicy of+                  IndentPolicyFree -> docSetBaseAndIndent+                  IndentPolicyLeft -> docForceSingleline+                  IndentPolicyMultiple+                    | indentFourPlus -> docSetBaseAndIndent+                    | otherwise -> docForceSingleline+              in f $ return bindDoc+            ]+          , -- let+              --   bind = expr+            docAddBaseY BrIndentRegular $ docPar+            (docLit $ Text.pack "let")+            (docSetBaseAndIndent $ return bindDoc)+          ]+        Just bindDocs -> runFilteredAlternative $ do+          -- let aaa = expra+          --     bbb = exprb+          --     ccc = exprc+          addAlternativeCond (isFree || indentFourPlus) $ docSeq+            [ appSep $ docLit $ Text.pack "let"+            , let+                f = if indentFourPlus+                  then docEnsureIndent BrIndentRegular+                  else docSetBaseAndIndent+              in f $ docLines $ return <$> bindDocs+            ]+          -- let+          --   aaa = expra+          --   bbb = exprb+          --   ccc = exprc+          addAlternativeCond (not indentFourPlus)+            $ docAddBaseY BrIndentRegular+            $ docPar+                (docLit $ Text.pack "let")+                (docSetBaseAndIndent $ docLines $ return <$> bindDocs)+    RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do+      -- rec stmt1+      --     stmt2+      --     stmt3+      addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq+        [ docLit (Text.pack "rec")+        , docSeparator+        , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts+        ]+      -- rec+      --   stmt1+      --   stmt2+      --   stmt3+      addAlternative $ docAddBaseY BrIndentRegular $ docPar+        (docLit (Text.pack "rec"))+        (docLines $ layoutStmt <$> stmts)+    BodyStmt _ expr _ _ -> do+      expDoc <- docSharedWrapper layoutExpr expr+      docAddBaseY BrIndentRegular $ expDoc+    _ -> briDocByExactInlineOnly "some unknown statement" lstmt
+ source/library/Brittany/Internal/Layouters/Stmt.hs-boot view
@@ -0,0 +1,10 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Layouters.Stmt where++import GHC.Hs+import Brittany.Internal.Types++++layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
+ source/library/Brittany/Internal/Layouters/Type.hs view
@@ -0,0 +1,635 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module 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 Brittany.Internal.LayouterBasics+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import Brittany.Internal.Utils+  (FirstLastView(..), splitFirstLast)++++layoutType :: ToBriDoc HsType+layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of+  -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"+  HsTyVar _ promoted name -> do+    t <- lrdrNameToTextAnnTypeEqualityIsSpecial name+    case promoted of+      IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t]+      NotPromoted -> docWrapNode name $ docLit t+  HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do+    let bndrs = getBinders hsf+    typeDoc <- docSharedWrapper layoutType typ2+    tyVarDocs <- layoutTyVarBndrs bndrs+    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType+    let+      maybeForceML = case typ2 of+        (L _ HsFunTy{}) -> docForceMultiline+        _ -> id+    let+      tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs+      forallDoc = docAlt+        [ let open = docLit $ Text.pack "forall"+          in docSeq ([open] ++ tyVarDocLineList)+        , docPar+          (docLit (Text.pack "forall"))+          (docLines $ tyVarDocs <&> \case+            (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname+            (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines+              [ docCols ColTyOpPrefix [docParenLSep, docLit tname]+              , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]+              , docLit $ Text.pack ")"+              ]+          )+        ]+      contextDoc = case cntxtDocs of+        [] -> docLit $ Text.pack "()"+        [x] -> x+        _ -> docAlt+          [ let+              open = docLit $ Text.pack "("+              close = docLit $ Text.pack ")"+              list =+                List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs+            in docSeq ([open] ++ list ++ [close])+          , let+              open = docCols+                ColTyOpPrefix+                [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs]+              close = docLit $ Text.pack ")"+              list = List.tail cntxtDocs <&> \cntxtDoc -> docCols+                ColTyOpPrefix+                [docCommaSep, docAddBaseY (BrIndentSpecial 2) cntxtDoc]+            in docPar open $ docLines $ list ++ [close]+          ]+    docAlt+      -- :: forall a b c . (Foo a b c) => a b -> c+      [ docSeq+        [ if null bndrs+          then docEmpty+          else+            let+              open = docLit $ Text.pack "forall"+              close = docLit $ Text.pack " . "+            in docSeq ([open, docSeparator] ++ tyVarDocLineList ++ [close])+        , docForceSingleline contextDoc+        , docLit $ Text.pack " => "+        , docForceSingleline typeDoc+        ]+      -- :: forall a b c+      --  . (Foo a b c)+      -- => a b+      -- -> c+      , docPar+        forallDoc+        (docLines+          [ docCols+            ColTyOpPrefix+            [ docWrapNodeRest ltype $ docLit $ Text.pack " . "+            , docAddBaseY (BrIndentSpecial 3) $ contextDoc+            ]+          , docCols+            ColTyOpPrefix+            [ docLit $ Text.pack "=> "+            , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc+            ]+          ]+        )+      ]+  HsForAllTy _ hsf typ2 -> do+    let bndrs = getBinders hsf+    typeDoc <- layoutType typ2+    tyVarDocs <- layoutTyVarBndrs bndrs+    let+      maybeForceML = case typ2 of+        (L _ HsFunTy{}) -> docForceMultiline+        _ -> id+    let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs+    docAlt+      -- forall x . x+      [ docSeq+        [ if null bndrs+          then docEmpty+          else+            let+              open = docLit $ Text.pack "forall"+              close = docLit $ Text.pack " . "+            in docSeq ([open] ++ tyVarDocLineList ++ [close])+        , docForceSingleline $ return $ typeDoc+        ]+      -- :: forall x+      --  . x+      , docPar+        (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)+        (docCols+          ColTyOpPrefix+          [ docWrapNodeRest ltype $ docLit $ Text.pack " . "+          , maybeForceML $ return typeDoc+          ]+        )+      -- :: forall+      --      (x :: *)+      --  . x+      , docPar+        (docLit (Text.pack "forall"))+        (docLines+        $ (tyVarDocs <&> \case+            (tname, Nothing) ->+              docEnsureIndent BrIndentRegular $ docLit tname+            (tname, Just doc) -> docEnsureIndent BrIndentRegular $ docLines+              [ docCols ColTyOpPrefix [docParenLSep, docLit tname]+              , docCols ColTyOpPrefix [docLit $ Text.pack ":: ", doc]+              , docLit $ Text.pack ")"+              ]+          )+        ++ [ docCols+               ColTyOpPrefix+               [ docWrapNodeRest ltype $ docLit $ Text.pack " . "+               , maybeForceML $ return typeDoc+               ]+           ]+        )+      ]+  HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do+    typeDoc <- docSharedWrapper layoutType typ1+    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType+    let+      contextDoc = docWrapNode lcntxts $ case cntxtDocs of+        [] -> docLit $ Text.pack "()"+        [x] -> x+        _ -> docAlt+          [ let+              open = docLit $ Text.pack "("+              close = docLit $ Text.pack ")"+              list =+                List.intersperse docCommaSep $ docForceSingleline <$> cntxtDocs+            in docSeq ([open] ++ list ++ [close])+          , let+              open = docCols+                ColTyOpPrefix+                [docParenLSep, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs]+              close = docLit $ Text.pack ")"+              list = List.tail cntxtDocs <&> \cntxtDoc -> docCols+                ColTyOpPrefix+                [docCommaSep, docAddBaseY (BrIndentSpecial 2) $ cntxtDoc]+            in docPar open $ docLines $ list ++ [close]+          ]+    let+      maybeForceML = case typ1 of+        (L _ HsFunTy{}) -> docForceMultiline+        _ -> id+    docAlt+      -- (Foo a b c) => a b -> c+      [ docSeq+        [ docForceSingleline contextDoc+        , docLit $ Text.pack " => "+        , docForceSingleline typeDoc+        ]+      --    (Foo a b c)+      -- => a b+      -- -> c+      , docPar+        (docForceSingleline contextDoc)+        (docCols+          ColTyOpPrefix+          [ docLit $ Text.pack "=> "+          , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc+          ]+        )+      ]+  HsFunTy _ _ typ1 typ2 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    typeDoc2 <- docSharedWrapper layoutType typ2+    let+      maybeForceML = case typ2 of+        (L _ HsFunTy{}) -> docForceMultiline+        _ -> id+    hasComments <- hasAnyCommentsBelow ltype+    docAlt+      $ [ docSeq+            [ appSep $ docForceSingleline typeDoc1+            , appSep $ docLit $ Text.pack "->"+            , docForceSingleline typeDoc2+            ]+        | not hasComments+        ]+      ++ [ docPar+             (docNodeAnnKW ltype Nothing typeDoc1)+             (docCols+               ColTyOpPrefix+               [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"+               , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc2+               ]+             )+         ]+  HsParTy _ typ1 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    docAlt+      [ docSeq+        [ docWrapNodeRest ltype $ docLit $ Text.pack "("+        , docForceSingleline typeDoc1+        , docLit $ Text.pack ")"+        ]+      , docPar+        (docCols+          ColTyOpPrefix+          [ docWrapNodeRest ltype $ docParenLSep+          , docAddBaseY (BrIndentSpecial 2) $ typeDoc1+          ]+        )+        (docLit $ Text.pack ")")+      ]+  HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do+    let+      gather+        :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])+      gather list = \case+        L _ (HsAppTy _ ty1 ty2) -> gather (ty2 : list) ty1+        final -> (final, list)+    let (typHead, typRest) = gather [typ2] typ1+    docHead <- docSharedWrapper layoutType typHead+    docRest <- docSharedWrapper layoutType `mapM` typRest+    docAlt+      [ docSeq+      $ docForceSingleline docHead+      : (docRest >>= \d -> [docSeparator, docForceSingleline d])+      , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)+      ]+  HsAppTy _ typ1 typ2 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    typeDoc2 <- docSharedWrapper layoutType typ2+    docAlt+      [ docSeq+        [docForceSingleline typeDoc1, docSeparator, docForceSingleline typeDoc2]+      , docPar typeDoc1 (docEnsureIndent BrIndentRegular typeDoc2)+      ]+  HsListTy _ typ1 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    docAlt+      [ docSeq+        [ docWrapNodeRest ltype $ docLit $ Text.pack "["+        , docForceSingleline typeDoc1+        , docLit $ Text.pack "]"+        ]+      , docPar+        (docCols+          ColTyOpPrefix+          [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "+          , docAddBaseY (BrIndentSpecial 2) $ typeDoc1+          ]+        )+        (docLit $ Text.pack "]")+      ]+  HsTupleTy _ tupleSort typs -> case tupleSort of+    HsUnboxedTuple -> unboxed+    HsBoxedTuple -> simple+    HsConstraintTuple -> simple+    HsBoxedOrConstraintTuple -> simple+   where+    unboxed = if null typs+      then error "brittany internal error: unboxed unit"+      else unboxedL+    simple = if null typs then unitL else simpleL+    unitL = docLit $ Text.pack "()"+    simpleL = do+      docs <- docSharedWrapper layoutType `mapM` typs+      let+        end = docLit $ Text.pack ")"+        lines =+          List.tail docs+            <&> \d -> docAddBaseY (BrIndentSpecial 2)+                  $ docCols ColTyOpPrefix [docCommaSep, d]+        commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)+      docAlt+        [ docSeq+        $ [docLit $ Text.pack "("]+        ++ docWrapNodeRest ltype commaDocs+        ++ [end]+        , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]+          in+            docPar+              (docAddBaseY (BrIndentSpecial 2) $ line1)+              (docLines $ docWrapNodeRest ltype lines ++ [end])+        ]+    unboxedL = do+      docs <- docSharedWrapper layoutType `mapM` typs+      let+        start = docParenHashLSep+        end = docParenHashRSep+      docAlt+        [ docSeq+        $ [start]+        ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)+        ++ [end]+        , let+            line1 = docCols ColTyOpPrefix [start, head docs]+            lines =+              List.tail docs+                <&> \d -> docAddBaseY (BrIndentSpecial 2)+                      $ docCols ColTyOpPrefix [docCommaSep, d]+          in docPar+            (docAddBaseY (BrIndentSpecial 2) line1)+            (docLines $ lines ++ [end])+        ]+  HsOpTy{} -> -- TODO+    briDocByExactInlineOnly "HsOpTy{}" ltype+  -- HsOpTy typ1 opName typ2 -> do+  --   -- TODO: these need some proper fixing. precedences don't add up.+  --   --       maybe the parser just returns some trivial right recursion+  --   --       parse result for any type level operators.+  --   --       need to check how things are handled on the expression level.+  --   let opStr = lrdrNameToText opName+  --   let opLen = Text.length opStr+  --   layouter1@(Layouter desc1 _ _) <- layoutType typ1+  --   layouter2@(Layouter desc2 _ _) <- layoutType typ2+  --   let line = do -- Maybe+  --         l1 <- _ldesc_line desc1+  --         l2 <- _ldesc_line desc2+  --         let len1 = _lColumns_min l1+  --         let len2 = _lColumns_min l2+  --         let len = 2 + opLen + len1 + len2+  --         return $ LayoutColumns+  --           { _lColumns_key = ColumnKeyUnique+  --           , _lColumns_lengths = [len]+  --           , _lColumns_min = len+  --           }+  --   let block = do -- Maybe+  --         rol1 <- descToBlockStart desc1+  --         (min2, max2) <- descToMinMax (1+opLen) desc2+  --         let (minR, maxR) = case descToBlockMinMax desc1 of+  --               Nothing -> (min2, max2)+  --               Just (min1, max1) -> (max min1 min2, max max1 max2)+  --         return $ BlockDesc+  --           { _bdesc_blockStart = rol1+  --           , _bdesc_min = minR+  --           , _bdesc_max = maxR+  --           , _bdesc_opIndentFloatUp = Just (1+opLen)+  --           }+  --   return $ Layouter+  --     { _layouter_desc = LayoutDesc+  --       { _ldesc_line = line+  --       , _ldesc_block = block+  --       }+  --     , _layouter_func = \params -> do+  --         remaining <- getCurRemaining+  --         let allowSameLine = _params_sepLines params /= SepLineTypeOp+  --         case line of+  --           Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do+  --             applyLayouterRestore layouter1 defaultParams+  --             layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " "+  --             applyLayouterRestore layouter2 defaultParams+  --           _ -> do+  --             let upIndent   = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params+  --             let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2+  --             layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams+  --             layoutWriteNewline+  --             layoutWriteAppend $ opStr <> Text.pack " "+  --             layoutWriteEnsureBlockPlusN downIndent+  --             applyLayouterRestore layouter2 defaultParams+  --               { _params_sepLines = SepLineTypeOp+  --               , _params_opIndent = Just downIndent+  --               }+  --     , _layouter_ast = ltype+  --     }+  HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    docAlt+      [ docSeq+        [ docWrapNodeRest ltype $ docLit $ Text.pack+          ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")+        , docForceSingleline typeDoc1+        ]+      , docPar+        (docLit $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName)))+        (docCols+          ColTyOpPrefix+          [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "+          , docAddBaseY (BrIndentSpecial 2) typeDoc1+          ]+        )+      ]+  -- TODO: test KindSig+  HsKindSig _ typ1 kind1 -> do+    typeDoc1 <- docSharedWrapper layoutType typ1+    kindDoc1 <- docSharedWrapper layoutType kind1+    hasParens <- hasAnnKeyword ltype AnnOpenP+    docAlt+      [ if hasParens+        then docSeq+          [ docLit $ Text.pack "("+          , docForceSingleline typeDoc1+          , docSeparator+          , docLit $ Text.pack "::"+          , docSeparator+          , docForceSingleline kindDoc1+          , docLit $ Text.pack ")"+          ]+        else docSeq+          [ docForceSingleline typeDoc1+          , docSeparator+          , docLit $ Text.pack "::"+          , docSeparator+          , docForceSingleline kindDoc1+          ]+      , if hasParens+        then docLines+          [ docCols+            ColTyOpPrefix+            [ docWrapNodeRest ltype $ docParenLSep+            , docAddBaseY (BrIndentSpecial 3) $ typeDoc1+            ]+          , docCols+            ColTyOpPrefix+            [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "+            , docAddBaseY (BrIndentSpecial 3) kindDoc1+            ]+          , (docLit $ Text.pack ")")+          ]+        else docPar+          typeDoc1+          (docCols+            ColTyOpPrefix+            [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "+            , docAddBaseY (BrIndentSpecial 3) kindDoc1+            ]+          )+      ]+  HsBangTy{} -> -- TODO+    briDocByExactInlineOnly "HsBangTy{}" ltype+  -- HsBangTy bang typ1 -> do+  --   let bangStr = case bang of+  --         HsSrcBang _ unpackness strictness ->+  --           (++)+  --             (case unpackness of+  --               SrcUnpack   -> "{-# UNPACK -#} "+  --               SrcNoUnpack -> "{-# NOUNPACK -#} "+  --               NoSrcUnpack -> ""+  --             )+  --             (case strictness of+  --               SrcLazy     -> "~"+  --               SrcStrict   -> "!"+  --               NoSrcStrict -> ""+  --             )+  --   let bangLen = length bangStr+  --   layouter@(Layouter desc _ _) <- layoutType typ1+  --   let line = do -- Maybe+  --         l <- _ldesc_line desc+  --         let len = bangLen + _lColumns_min l+  --         return $ LayoutColumns+  --           { _lColumns_key = ColumnKeyUnique+  --           , _lColumns_lengths = [len]+  --           , _lColumns_min = len+  --           }+  --   let block = do -- Maybe+  --         rol <- descToBlockStart desc+  --         (minR,maxR) <- descToBlockMinMax desc+  --         return $ BlockDesc+  --           { _bdesc_blockStart = rol+  --           , _bdesc_min = minR+  --           , _bdesc_max = maxR+  --           , _bdesc_opIndentFloatUp = Nothing+  --           }+  --   return $ Layouter+  --     { _layouter_desc = LayoutDesc+  --       { _ldesc_line = line+  --       , _ldesc_block = block+  --       }+  --     , _layouter_func = \_params -> do+  --         remaining <- getCurRemaining+  --         case line of+  --           Just (LayoutColumns _ _ m) | m <= remaining -> do+  --             layoutWriteAppend $ Text.pack $ bangStr+  --             applyLayouterRestore layouter defaultParams+  --           _ -> do+  --             layoutWriteAppend $ Text.pack $ bangStr+  --             layoutWritePostCommentsRestore ltype+  --             applyLayouterRestore layouter defaultParams+  --     , _layouter_ast = ltype+  --     }+  HsSpliceTy{} -> -- TODO+    briDocByExactInlineOnly "HsSpliceTy{}" ltype+  HsDocTy{} -> -- TODO+    briDocByExactInlineOnly "HsDocTy{}" ltype+  HsRecTy{} -> -- TODO+    briDocByExactInlineOnly "HsRecTy{}" ltype+  HsExplicitListTy _ _ typs -> do+    typDocs <- docSharedWrapper layoutType `mapM` typs+    hasComments <- hasAnyCommentsBelow ltype+    let specialCommaSep = appSep $ docLit $ Text.pack " ,"+    docAlt+      [ docSeq+      $ [docLit $ Text.pack "'["]+      ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)+      ++ [docLit $ Text.pack "]"]+      , case splitFirstLast typDocs of+        FirstLastEmpty -> docSeq+          [ docLit $ Text.pack "'["+          , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]"+          ]+        FirstLastSingleton e -> docAlt+          [ docSeq+            [ docLit $ Text.pack "'["+            , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e+            , docLit $ Text.pack "]"+            ]+          , docSetBaseY $ docLines+            [ docSeq+              [ docLit $ Text.pack "'["+              , docSeparator+              , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e+              ]+            , docLit $ Text.pack " ]"+            ]+          ]+        FirstLast e1 ems eN -> runFilteredAlternative $ do+          addAlternativeCond (not hasComments)+            $ docSeq+            $ [docLit $ Text.pack "'["]+            ++ List.intersperse+                 specialCommaSep+                 (docForceSingleline+                 <$> (e1 : ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN])+                 )+            ++ [docLit $ Text.pack " ]"]+          addAlternative+            $ let+                start = docCols ColList [appSep $ docLit $ Text.pack "'[", e1]+                linesM = ems <&> \d -> docCols ColList [specialCommaSep, d]+                lineN = docCols+                  ColList+                  [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]+                end = docLit $ Text.pack " ]"+              in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]+      ]+  HsExplicitTupleTy{} -> -- TODO+    briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype+  HsTyLit _ lit -> case lit of+    HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext+    HsNumTy NoSourceText _ ->+      error "overLitValBriDoc: literal with no SourceText"+    HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext+    HsStrTy NoSourceText _ ->+      error "overLitValBriDoc: literal with no SourceText"+  HsWildCardTy _ -> docLit $ Text.pack "_"+  HsSumTy{} -> -- TODO+    briDocByExactInlineOnly "HsSumTy{}" ltype+  HsStarTy _ isUnicode -> do+    if isUnicode+      then docLit $ Text.pack "\x2605" -- Unicode star+      else docLit $ Text.pack "*"+  XHsType{} -> error "brittany internal error: XHsType"+  HsAppKindTy _ ty kind -> do+    t <- docSharedWrapper layoutType ty+    k <- docSharedWrapper layoutType kind+    docAlt+      [ docSeq+        [ docForceSingleline t+        , docSeparator+        , docLit $ Text.pack "@"+        , docForceSingleline k+        ]+      , docPar t (docSeq [docLit $ Text.pack "@", k])+      ]++layoutTyVarBndrs+  :: [LHsTyVarBndr () GhcPs]+  -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))]+layoutTyVarBndrs = mapM $ \case+  (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing)+  (L _ (KindedTyVar _ _ lrdrName kind)) -> do+    d <- docSharedWrapper layoutType kind+    return $ (lrdrNameToText lrdrName, Just $ d)++-- there is no specific reason this returns a list instead of a single+-- BriDoc node.+processTyVarBndrsSingleline+  :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered]+processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case+  (tname, Nothing) -> [docSeparator, docLit tname]+  (tname, Just doc) ->+    [ docSeparator+    , docLit $ Text.pack "(" <> tname <> Text.pack " :: "+    , docForceSingleline $ doc+    , docLit $ Text.pack ")"+    ]++getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass]+getBinders x = case x of+  HsForAllVis _ b -> b+  HsForAllInvis _ b -> fmap withoutSpecificity b+  XHsForAllTelescope _ -> []++withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass+withoutSpecificity = fmap $ \case+  UserTyVar a _ c -> UserTyVar a () c+  KindedTyVar a _ c d -> KindedTyVar a () c d+  XTyVarBndr a -> XTyVarBndr a
+ source/library/Brittany/Internal/Obfuscation.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Obfuscation where++import Data.Char+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified GHC.OldList as List+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import System.Random++++obfuscate :: Text -> IO Text+obfuscate input = do+  let predi x = isAlphaNum x || x `elem` "_'"+  let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input)+  let idents = Set.toList $ Set.fromList $ filter (all predi) groups+  let+    exceptionFilter x | x `elem` keywords = False+    exceptionFilter x | x `elem` extraKWs = False+    exceptionFilter x = not $ null $ drop 1 x+  let filtered = filter exceptionFilter idents+  mappings <- fmap Map.fromList $ filtered `forM` \x -> do+    r <- createAlias x+    pure (x, r)+  let groups' = groups <&> \w -> fromMaybe w (Map.lookup w mappings)+  pure $ Text.concat $ fmap Text.pack groups'++keywords :: [String]+keywords =+  [ "case"+  , "class"+  , "data"+  , "default"+  , "deriving"+  , "do"+  , "mdo"+  , "else"+  , "forall"+  , "if"+  , "import"+  , "in"+  , "infix"+  , "infixl"+  , "infixr"+  , "instance"+  , "let"+  , "module"+  , "newtype"+  , "of"+  , "qualified"+  , "then"+  , "type"+  , "where"+  , "_"+  , "foreign"+  , "ccall"+  , "as"+  , "safe"+  , "unsafe"+  , "hiding"+  , "proc"+  , "rec"+  , "family"+  ]++extraKWs :: [String]+extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"]++createAlias :: String -> IO String+createAlias xs = go NoHint xs+ where+  go _hint "" = pure ""+  go hint (c : cr) = do+    c' <- case hint of+      VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z']+      _ | isUpper c -> randomFrom ['A' .. 'Z']+      VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z']+      _ | isLower c -> randomFrom ['a' .. 'z']+      _ -> pure c+    cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr+    pure (c' : cr')++data Hint = NoHint | VocalHint | NoVocalHint++_randomRange :: Random a => a -> a -> IO a+_randomRange lo hi = do+  gen <- getStdGen+  let (x, gen') = randomR (lo, hi) gen+  setStdGen gen'+  pure x++randomFrom :: [a] -> IO a+randomFrom l = do+  let hi = length l - 1+  gen <- getStdGen+  let (x, gen') = randomR (0, hi) gen+  setStdGen gen'+  pure $ l List.!! x
+ source/library/Brittany/Internal/ParseModule.hs view
@@ -0,0 +1,316 @@+{-# OPTIONS_GHC -Wno-implicit-prelude #-}++module Brittany.Internal.ParseModule where++import qualified Control.Monad as Monad+import qualified Control.Monad.IO.Class as IO+import qualified Control.Monad.Trans.Except as Except+import qualified GHC+import qualified GHC.ByteOrder+import qualified GHC.Data.Bag+import qualified GHC.Data.StringBuffer+import qualified GHC.Driver.Session+import qualified GHC.Parser.Header+import qualified GHC.Platform+import qualified GHC.Settings+import qualified GHC.Types.SrcLoc+import qualified GHC.Utils.Error+import qualified GHC.Utils.Fingerprint+import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint++-- | Parses a Haskell module. Although this nominally requires IO, it is+-- morally pure. It should have no observable effects.+parseModule+  :: IO.MonadIO io+  => [String]+  -> FilePath+  -> (GHC.Driver.Session.DynFlags -> io (Either String a))+  -> String+  -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a))+parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do+  let+    dynFlags1 = GHC.Driver.Session.gopt_set+      -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both+      -- of those modes have trouble parsing safe imports (@import safe ...@).+      -- Neither passing in @"-XUnsafe"@ as a command line argument nor having+      -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.+      initialDynFlags+        { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe+        }+      GHC.Driver.Session.Opt_KeepRawTokenStream+  (dynFlags2, leftovers1, _) <-+    GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1+      $ fmap GHC.Types.SrcLoc.noLoc arguments1+  handleLeftovers leftovers1+  let+    stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string+    arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath+  (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma+    dynFlags2+    arguments2+  handleLeftovers leftovers2+  dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3+  let+    parseResult =+      ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string+  case parseResult of+    Left errorMessages -> handleErrorMessages errorMessages+    Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult)++handleLeftovers+  :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m ()+handleLeftovers leftovers =+  Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show+    (fmap GHC.Types.SrcLoc.unLoc leftovers)++handleErrorMessages+  :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a+handleErrorMessages =+  Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList++initialDynFlags :: GHC.Driver.Session.DynFlags+initialDynFlags = GHC.Driver.Session.defaultDynFlags initialSettings initialLlvmConfig++initialSettings :: GHC.Driver.Session.Settings+initialSettings = GHC.Driver.Session.Settings+  { GHC.Driver.Session.sGhcNameVersion = initialGhcNameVersion+  , GHC.Driver.Session.sFileSettings = initialFileSettings+  , GHC.Driver.Session.sTargetPlatform = initialTargetPlatform+  , GHC.Driver.Session.sToolSettings = initialToolSettings+  , GHC.Driver.Session.sPlatformMisc = initialPlatformMisc+  , GHC.Driver.Session.sPlatformConstants = initialPlatformConstants+  , GHC.Driver.Session.sRawSettings = []+  }++initialFileSettings :: GHC.Driver.Session.FileSettings+initialFileSettings = GHC.Driver.Session.FileSettings+  { GHC.Driver.Session.fileSettings_ghciUsagePath = ""+  , GHC.Driver.Session.fileSettings_ghcUsagePath = ""+  , GHC.Driver.Session.fileSettings_globalPackageDatabase = ""+  , GHC.Driver.Session.fileSettings_tmpDir = ""+  , GHC.Driver.Session.fileSettings_toolDir = Nothing+  , GHC.Driver.Session.fileSettings_topDir = ""+  }++initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion+initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion+  { GHC.Driver.Session.ghcNameVersion_programName = ""+  , GHC.Driver.Session.ghcNameVersion_projectVersion = ""+  }++initialPlatformMisc :: GHC.Driver.Session.PlatformMisc+initialPlatformMisc = GHC.Driver.Session.PlatformMisc+  { GHC.Driver.Session.platformMisc_ghcDebugged = False+  , GHC.Driver.Session.platformMisc_ghcRTSWays = ""+  , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False+  , GHC.Driver.Session.platformMisc_ghcThreaded = False+  , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False+  , GHC.Driver.Session.platformMisc_ghcWithSMP = False+  , GHC.Driver.Session.platformMisc_libFFI = False+  , GHC.Driver.Session.platformMisc_llvmTarget = ""+  , GHC.Driver.Session.platformMisc_targetPlatformString = ""+  }++initialLlvmConfig :: GHC.Driver.Session.LlvmConfig+initialLlvmConfig = GHC.Driver.Session.LlvmConfig+  { GHC.Driver.Session.llvmPasses = []+  , GHC.Driver.Session.llvmTargets = []+  }++initialPlatformConstants :: GHC.Settings.PlatformConstants+initialPlatformConstants = GHC.Settings.PlatformConstants+  { GHC.Settings.pc_AP_STACK_SPLIM = 0+  , GHC.Settings.pc_BITMAP_BITS_SHIFT = 0+  , GHC.Settings.pc_BLOCK_SIZE = 0+  , GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0+  , GHC.Settings.pc_CINT_SIZE = 0+  , GHC.Settings.pc_CLONG_LONG_SIZE = 0+  , GHC.Settings.pc_CLONG_SIZE = 0+  , GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0+  , GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False+  , GHC.Settings.pc_ILDV_CREATE_MASK = 0+  , GHC.Settings.pc_ILDV_STATE_CREATE = 0+  , GHC.Settings.pc_ILDV_STATE_USE = 0+  , GHC.Settings.pc_LDV_SHIFT = 0+  , GHC.Settings.pc_MAX_CHARLIKE = 0+  , GHC.Settings.pc_MAX_Double_REG = 0+  , GHC.Settings.pc_MAX_Float_REG = 0+  , GHC.Settings.pc_MAX_INTLIKE = 0+  , GHC.Settings.pc_MAX_Long_REG = 0+  , GHC.Settings.pc_MAX_Real_Double_REG = 0+  , GHC.Settings.pc_MAX_Real_Float_REG = 0+  , GHC.Settings.pc_MAX_Real_Long_REG = 0+  , GHC.Settings.pc_MAX_Real_Vanilla_REG = 0+  , GHC.Settings.pc_MAX_Real_XMM_REG = 0+  , GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0+  , GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0+  , GHC.Settings.pc_MAX_Vanilla_REG = 0+  , GHC.Settings.pc_MAX_XMM_REG = 0+  , GHC.Settings.pc_MIN_CHARLIKE = 0+  , GHC.Settings.pc_MIN_INTLIKE = 0+  , GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0+  , GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0+  , GHC.Settings.pc_OFFSET_bdescr_blocks = 0+  , GHC.Settings.pc_OFFSET_bdescr_flags = 0+  , GHC.Settings.pc_OFFSET_bdescr_free = 0+  , GHC.Settings.pc_OFFSET_bdescr_start = 0+  , GHC.Settings.pc_OFFSET_Capability_r = 0+  , GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0+  , GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0+  , GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0+  , GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0+  , GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0+  , GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0+  , GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0+  , GHC.Settings.pc_OFFSET_StgEntCounter_link = 0+  , GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0+  , GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0+  , GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0+  , GHC.Settings.pc_OFFSET_stgGCEnter1 = 0+  , GHC.Settings.pc_OFFSET_stgGCFun = 0+  , GHC.Settings.pc_OFFSET_StgHeader_ccs = 0+  , GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0+  , GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0+  , GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0+  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0+  , GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0+  , GHC.Settings.pc_OFFSET_StgStack_sp = 0+  , GHC.Settings.pc_OFFSET_StgStack_stack = 0+  , GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0+  , GHC.Settings.pc_OFFSET_StgTSO_cccs = 0+  , GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0+  , GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0+  , GHC.Settings.pc_PROF_HDR_SIZE = 0+  , GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0+  , GHC.Settings.pc_REP_CostCentreStack_scc_count = 0+  , GHC.Settings.pc_REP_StgEntCounter_allocd = 0+  , GHC.Settings.pc_REP_StgEntCounter_allocs = 0+  , GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0+  , GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0+  , GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0+  , GHC.Settings.pc_RESERVED_STACK_WORDS = 0+  , GHC.Settings.pc_SIZEOF_CostCentreStack = 0+  , GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0+  , GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0+  , GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0+  , GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0+  , GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0+  , GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0+  , GHC.Settings.pc_STD_HDR_SIZE = 0+  , GHC.Settings.pc_TAG_BITS = 0+  , GHC.Settings.pc_TICKY_BIN_COUNT = 0+  , GHC.Settings.pc_WORD_SIZE = 0+  }++initialPlatformMini :: GHC.Settings.PlatformMini+initialPlatformMini = GHC.Settings.PlatformMini+  { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64+  , GHC.Settings.platformMini_os = GHC.Platform.OSLinux+  }++initialTargetPlatform :: GHC.Settings.Platform+initialTargetPlatform = GHC.Settings.Platform+  { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian+  , GHC.Settings.platformHasGnuNonexecStack = False+  , GHC.Settings.platformHasIdentDirective = False+  , GHC.Settings.platformHasSubsectionsViaSymbols = False+  , GHC.Settings.platformIsCrossCompiling = False+  , GHC.Settings.platformLeadingUnderscore = False+  , GHC.Settings.platformMini = initialPlatformMini+  , GHC.Settings.platformTablesNextToCode = False+  , GHC.Settings.platformUnregisterised = False+  , GHC.Settings.platformWordSize = GHC.Platform.PW8+  }++initialToolSettings :: GHC.Settings.ToolSettings+initialToolSettings = GHC.Settings.ToolSettings+  { GHC.Settings.toolSettings_ccSupportsNoPie = False+  , GHC.Settings.toolSettings_extraGccViaCFlags = []+  , GHC.Settings.toolSettings_ldIsGnuLd = False+  , GHC.Settings.toolSettings_ldSupportsBuildId = False+  , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False+  , GHC.Settings.toolSettings_ldSupportsFilelist = False+  , GHC.Settings.toolSettings_opt_a = []+  , GHC.Settings.toolSettings_opt_c = []+  , GHC.Settings.toolSettings_opt_cxx = []+  , GHC.Settings.toolSettings_opt_F = []+  , GHC.Settings.toolSettings_opt_i = []+  , GHC.Settings.toolSettings_opt_l = []+  , GHC.Settings.toolSettings_opt_L = []+  , GHC.Settings.toolSettings_opt_lc = []+  , GHC.Settings.toolSettings_opt_lcc = []+  , GHC.Settings.toolSettings_opt_lm = []+  , GHC.Settings.toolSettings_opt_lo = []+  , GHC.Settings.toolSettings_opt_P = []+  , GHC.Settings.toolSettings_opt_P_fingerprint =+    GHC.Utils.Fingerprint.fingerprint0+  , GHC.Settings.toolSettings_opt_windres = []+  , GHC.Settings.toolSettings_pgm_a = ("", [])+  , GHC.Settings.toolSettings_pgm_ar = ""+  , GHC.Settings.toolSettings_pgm_c = ""+  , GHC.Settings.toolSettings_pgm_dll = ("", [])+  , GHC.Settings.toolSettings_pgm_F = ""+  , GHC.Settings.toolSettings_pgm_i = ""+  , GHC.Settings.toolSettings_pgm_install_name_tool = ""+  , GHC.Settings.toolSettings_pgm_l = ("", [])+  , GHC.Settings.toolSettings_pgm_L = ""+  , GHC.Settings.toolSettings_pgm_lc = ("", [])+  , GHC.Settings.toolSettings_pgm_lcc = ("", [])+  , GHC.Settings.toolSettings_pgm_libtool = ""+  , GHC.Settings.toolSettings_pgm_lm = ("", [])+  , GHC.Settings.toolSettings_pgm_lo = ("", [])+  , GHC.Settings.toolSettings_pgm_otool = ""+  , GHC.Settings.toolSettings_pgm_P = ("", [])+  , GHC.Settings.toolSettings_pgm_ranlib = ""+  , GHC.Settings.toolSettings_pgm_T = ""+  , GHC.Settings.toolSettings_pgm_windres = ""+  }
+ source/library/Brittany/Internal/Prelude.hs view
@@ -0,0 +1,194 @@+module Brittany.Internal.Prelude+  ( module E+  ) where++import Control.Applicative as E (Alternative(..), Applicative(..))+import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second)+import Control.Concurrent as E (forkIO, forkOS, threadDelay)+import Control.Concurrent.Chan as E (Chan)+import Control.Concurrent.MVar as E+  (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar)+import Control.Exception as E (assert, bracket, evaluate)+import Control.Monad as E+  ( (<$!>)+  , (<=<)+  , (=<<)+  , (>=>)+  , Functor(..)+  , Monad(..)+  , MonadPlus(..)+  , filterM+  , forM+  , forM_+  , forever+  , guard+  , join+  , liftM+  , liftM2+  , liftM3+  , liftM4+  , liftM5+  , mapM+  , mapM_+  , replicateM+  , replicateM_+  , sequence+  , sequence_+  , unless+  , void+  , when+  )+import Control.Monad.Extra as E+  (allM, andM, anyM, ifM, notM, orM, unlessM, whenM)+import Control.Monad.IO.Class as E (MonadIO(..))+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 Data.Map as E (Map)+import Data.Maybe as E+  (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList)+import Data.Monoid as E+  ( All(..)+  , Alt(..)+  , Any(..)+  , Endo(..)+  , Monoid(..)+  , Product(..)+  , Sum(..)+  , mconcat+  )+import Data.Ord as E (Down(..), Ordering(..), comparing)+import Data.Proxy as E (Proxy(..))+import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator)+import Data.Semigroup as E ((<>), Semigroup(..))+import Data.Sequence as E (Seq)+import Data.Set as E (Set)+import Data.String as E (String)+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+  , traceM+  , traceShow+  , traceShowId+  , traceShowM+  , traceStack+  )+import Foreign.ForeignPtr as E (ForeignPtr)+import Foreign.Storable as E (Storable)+import GHC.Exts as E (Constraint)+import GHC.Hs.Extension as E (GhcPs)+import GHC.Types.Name.Reader as E (RdrName)+import Prelude as E+  ( ($)+  , ($!)+  , (&&)+  , (++)+  , (.)+  , (<$>)+  , Bounded(..)+  , Double+  , Enum(..)+  , Eq(..)+  , Float+  , Floating(..)+  , Foldable+  , Fractional(..)+  , Integer+  , Integral(..)+  , Num(..)+  , Ord(..)+  , RealFloat(..)+  , RealFrac(..)+  , Show(..)+  , Traversable+  , (^)+  , and+  , any+  , const+  , curry+  , error+  , flip+  , foldl+  , foldr+  , foldr1+  , fromIntegral+  , fst+  , head+  , id+  , map+  , not+  , or+  , otherwise+  , print+  , putStr+  , putStrLn+  , realToFrac+  , reverse+  , seq+  , snd+  , subtract+  , traverse+  , uncurry+  , undefined+  , (||)+  )+import System.IO as E (IO, hFlush, stdout)+import Text.Read as E (readMaybe)
+ source/library/Brittany/Internal/PreludeUtils.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Brittany.Internal.PreludeUtils where++import Control.Applicative+import Control.DeepSeq (NFData, force)+import Control.Exception.Base (evaluate)+import Control.Monad+import qualified Data.Strict.Maybe as Strict+import Debug.Trace+import Prelude+import System.IO++++instance Applicative Strict.Maybe where+  pure = Strict.Just+  Strict.Just f <*> Strict.Just x = Strict.Just (f x)+  _ <*> _ = Strict.Nothing++instance Monad Strict.Maybe where+  Strict.Nothing >>= _ = Strict.Nothing+  Strict.Just x >>= f = f x++instance Alternative Strict.Maybe where+  empty = Strict.Nothing+  x <|> Strict.Nothing = x+  _ <|> x = x++traceFunctionWith+  :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)+traceFunctionWith name s1 s2 f x = trace traceStr y+ where+  y = f x+  traceStr = name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y++(<&!>) :: Monad m => m a -> (a -> b) -> m b+(<&!>) = flip (<$!>)++putStrErrLn :: String -> IO ()+putStrErrLn s = hPutStrLn stderr s++putStrErr :: String -> IO ()+putStrErr s = hPutStr stderr s++printErr :: Show a => a -> IO ()+printErr = putStrErrLn . show++errorIf :: Bool -> a -> a+errorIf False = id+errorIf True = error "errorIf"++errorIfNote :: Maybe String -> a -> a+errorIfNote Nothing = id+errorIfNote (Just x) = error x++(<&>) :: Functor f => f a -> (a -> b) -> f b+(<&>) = flip fmap+infixl 4 <&>++(.>) :: (a -> b) -> (b -> c) -> (a -> c)+f .> g = g . f+infixl 9 .>++evaluateDeep :: NFData a => a -> IO a+evaluateDeep = evaluate . force
+ source/library/Brittany/Internal/Transformations/Alt.hs view
@@ -0,0 +1,961 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Brittany.Internal.Transformations.Alt where++import qualified Control.Monad.Memo as Memo+import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS+import Data.HList.ContainsType+import qualified Data.List.Extra+import qualified Data.Semigroup as Semigroup+import qualified Data.Text as Text+import qualified GHC.OldList as List+import Brittany.Internal.Config.Types+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import Brittany.Internal.Utils++++data AltCurPos = AltCurPos+  { _acp_line :: Int -- chars in the current line+  , _acp_indent :: Int -- current indentation level+  , _acp_indentPrep :: Int -- indentChange affecting the next Par+  , _acp_forceMLFlag :: AltLineModeState+  }+  deriving Show++data AltLineModeState+  = AltLineModeStateNone+  | AltLineModeStateForceML Bool -- true ~ decays on next wrap+  | AltLineModeStateForceSL+  | AltLineModeStateContradiction+  -- i.e. ForceX False -> ForceX True -> None+  deriving (Show)++altLineModeRefresh :: AltLineModeState -> AltLineModeState+altLineModeRefresh AltLineModeStateNone = AltLineModeStateNone+altLineModeRefresh AltLineModeStateForceML{} = AltLineModeStateForceML False+altLineModeRefresh AltLineModeStateForceSL = AltLineModeStateForceSL+altLineModeRefresh AltLineModeStateContradiction =+  AltLineModeStateContradiction++altLineModeDecay :: AltLineModeState -> AltLineModeState+altLineModeDecay AltLineModeStateNone = AltLineModeStateNone+altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True+altLineModeDecay (AltLineModeStateForceML True) = AltLineModeStateNone+altLineModeDecay AltLineModeStateForceSL = AltLineModeStateForceSL+altLineModeDecay AltLineModeStateContradiction = AltLineModeStateContradiction++mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos+mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of+  (AltLineModeStateContradiction, _) -> acp+  (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x }+  (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp+  (AltLineModeStateForceML{}, AltLineModeStateForceML{}) ->+    acp { _acp_forceMLFlag = s }+  _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction }+++-- removes any BDAlt's from the BriDoc+transformAlts+  :: forall r w s+   . ( Data.HList.ContainsType.ContainsType Config r+     , Data.HList.ContainsType.ContainsType (Seq String) w+     )+  => BriDocNumbered+  -> MultiRWSS.MultiRWS r w s BriDoc+transformAlts =+  MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone)+    . Memo.startEvalMemoT+    . fmap unwrapBriDocNumbered+    . rec+ where+    -- this function is exponential by nature and cannot be improved in any+    -- way i can think of, and i've tried. (stupid StableNames.)+    -- transWrap :: BriDoc -> BriDocNumbered+    -- transWrap brDc = flip StateS.evalState (1::Int)+    --                $ Memo.startEvalMemoT+    --                $ go brDc+    --   where+    --     incGet = StateS.get >>= \i -> StateS.put (i+1) $> i+    --     go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered+    --     go = Memo.memo $ \bdX -> do+    --       i <- lift $ incGet+    --       fmap (\bd' -> (i,bd')) $ case bdX of+    --         BDEmpty           -> return $ BDFEmpty+    --         BDLit t           -> return $ BDFLit t+    --         BDSeq list        -> BDFSeq <$> go `mapM` list+    --         BDCols sig list   -> BDFCols sig <$> go `mapM` list+    --         BDSeparator       -> return $ BDFSeparator+    --         BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd+    --         BDSetBaseY bd     -> BDFSetBaseY <$> go bd+    --         BDSetIndentLevel bd     -> BDFSetIndentLevel <$> go bd+    --         BDPar ind line indented -> [ BDFPar ind line' indented'+    --                                    | line' <- go line+    --                                    , indented' <- go indented+    --                                    ]+    --         BDAlt alts              -> BDFAlt <$> go `mapM` alts -- not that this will happen+    --         BDForceMultiline  bd    -> BDFForceMultiline <$> go bd+    --         BDForceSingleline bd    -> BDFForceSingleline <$> go bd+    --         BDForwardLineMode bd    -> BDFForwardLineMode <$> go bd+    --         BDExternal k ks c t         -> return $ BDFExternal k ks c t+    --         BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd+    --         BDAnnotationPost  annKey bd -> BDFAnnotationRest  annKey <$> go bd+    --         BDLines lines         -> BDFLines <$> go `mapM` lines+    --         BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd+    --         BDProhibitMTEL bd     -> BDFProhibitMTEL <$> go bd++++  rec+    :: BriDocNumbered+    -> Memo.MemoT+         Int+         [VerticalSpacing]+         (MultiRWSS.MultiRWS r w (AltCurPos ': s))+         BriDocNumbered+  rec bdX@(brDcId, brDc) = do+    let reWrap = (,) brDcId+    -- debugAcp :: AltCurPos <- mGet+    case brDc of+      -- BDWrapAnnKey annKey bd -> do+      --   acp <- mGet+      --   mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }+      --   BDWrapAnnKey annKey <$> rec bd+      BDFEmpty{} -> processSpacingSimple bdX $> bdX+      BDFLit{} -> processSpacingSimple bdX $> bdX+      BDFSeq list -> reWrap . BDFSeq <$> list `forM` rec+      BDFCols sig list -> reWrap . BDFCols sig <$> list `forM` rec+      BDFSeparator -> processSpacingSimple bdX $> bdX+      BDFAddBaseY indent bd -> do+        acp <- mGet+        indAdd <- fixIndentationForMultiple acp indent+        mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd }+        r <- rec bd+        acp' <- mGet+        mSet $ acp' { _acp_indent = _acp_indent acp }+        return $ case indent of+          BrIndentNone -> r+          BrIndentRegular -> reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r+          BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r+      BDFBaseYPushCur bd -> do+        acp <- mGet+        mSet $ acp { _acp_indent = _acp_line acp }+        r <- rec bd+        return $ reWrap $ BDFBaseYPushCur r+      BDFBaseYPop bd -> do+        acp <- mGet+        r <- rec bd+        acp' <- mGet+        mSet $ acp' { _acp_indent = _acp_indentPrep acp }+        return $ reWrap $ BDFBaseYPop r+      BDFIndentLevelPushCur bd -> do+        reWrap . BDFIndentLevelPushCur <$> rec bd+      BDFIndentLevelPop bd -> do+        reWrap . BDFIndentLevelPop <$> rec bd+      BDFPar indent sameLine indented -> do+        indAmount <-+          mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+        let+          indAdd = case indent of+            BrIndentNone -> 0+            BrIndentRegular -> indAmount+            BrIndentSpecial i -> i+        acp <- mGet+        let ind = _acp_indent acp + _acp_indentPrep acp + indAdd+        mSet $ acp { _acp_indent = ind, _acp_indentPrep = 0 }+        sameLine' <- rec sameLine+        mModify $ \acp' -> acp' { _acp_line = ind, _acp_indent = ind }+        indented' <- rec indented+        return $ reWrap $ BDFPar indent sameLine' indented'+      BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a+                                      -- possibility, but i will prefer a+                                      -- fail-early approach; BDEmpty does not+                                      -- make sense semantically for Alt[].+      BDFAlt alts -> do+        altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack+        case altChooser of+          AltChooserSimpleQuick -> do+            rec $ head alts+          AltChooserShallowBest -> do+            spacings <- alts `forM` getSpacing+            acp <- mGet+            let+              lineCheck LineModeInvalid = False+              lineCheck (LineModeValid (VerticalSpacing _ p _)) =+                case _acp_forceMLFlag acp of+                  AltLineModeStateNone -> True+                  AltLineModeStateForceSL{} -> p == VerticalSpacingParNone+                  AltLineModeStateForceML{} -> p /= VerticalSpacingParNone+                  AltLineModeStateContradiction -> False+              -- TODO: use COMPLETE pragma instead?+              lineCheck _ = error "ghc exhaustive check is insufficient"+            lconf <- _conf_layout <$> mAsk+            let+              options = -- trace ("considering options:" ++ show (length alts, acp)) $+                (zip spacings alts+                <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))+                                 (hasSpace1 lconf acp vs && lineCheck vs, bd)+                )+            rec+              $ fromMaybe (-- trace ("choosing last") $+                           List.last alts)+              $ Data.List.Extra.firstJust+                  (\(_i :: Int, (b, x)) ->+                    [ -- traceShow ("choosing option " ++ show i) $+                      x+                    | b+                    ]+                  )+              $ zip [1 ..] options+          AltChooserBoundedSearch limit -> do+            spacings <- alts `forM` getSpacings limit+            acp <- mGet+            let+              lineCheck (VerticalSpacing _ p _) = case _acp_forceMLFlag acp of+                AltLineModeStateNone -> True+                AltLineModeStateForceSL{} -> p == VerticalSpacingParNone+                AltLineModeStateForceML{} -> p /= VerticalSpacingParNone+                AltLineModeStateContradiction -> False+            lconf <- _conf_layout <$> mAsk+            let+              options = -- trace ("considering options:" ++ show (length alts, acp)) $+                (zip spacings alts+                <&> \(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)+                )+            let+              checkedOptions :: [Maybe (Int, BriDocNumbered)] =+                zip [1 ..] options <&> (\(i, (b, x)) -> [ (i, x) | b ])+            rec+              $ fromMaybe (-- trace ("choosing last") $+                           List.last alts)+              $ Data.List.Extra.firstJust (fmap snd) checkedOptions+      BDFForceMultiline bd -> do+        acp <- mGet+        x <- do+          mSet $ mergeLineMode acp (AltLineModeStateForceML False)+          rec bd+        acp' <- mGet+        mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }+        return $ x+      BDFForceSingleline bd -> do+        acp <- mGet+        x <- do+          mSet $ mergeLineMode acp AltLineModeStateForceSL+          rec bd+        acp' <- mGet+        mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }+        return $ x+      BDFForwardLineMode bd -> do+        acp <- mGet+        x <- do+          mSet $ acp+            { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp+            }+          rec bd+        acp' <- mGet+        mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }+        return $ x+      BDFExternal{} -> processSpacingSimple bdX $> bdX+      BDFPlain{} -> processSpacingSimple bdX $> bdX+      BDFAnnotationPrior annKey bd -> do+        acp <- mGet+        mSet+          $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }+        bd' <- rec bd+        return $ reWrap $ BDFAnnotationPrior annKey bd'+      BDFAnnotationRest annKey bd ->+        reWrap . BDFAnnotationRest annKey <$> rec bd+      BDFAnnotationKW annKey kw bd ->+        reWrap . BDFAnnotationKW annKey kw <$> rec bd+      BDFMoveToKWDP annKey kw b bd ->+        reWrap . BDFMoveToKWDP annKey kw b <$> rec bd+      BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.+      BDFLines (l : lr) -> do+        ind <- _acp_indent <$> mGet+        l' <- rec l+        lr' <- lr `forM` \x -> do+          mModify $ \acp -> acp { _acp_line = ind, _acp_indent = ind }+          rec x+        return $ reWrap $ BDFLines (l' : lr')+      BDFEnsureIndent indent bd -> do+        acp <- mGet+        indAdd <- fixIndentationForMultiple acp indent+        mSet $ acp+          { _acp_indentPrep = 0+            -- TODO: i am not sure this is valid, in general.+          , _acp_indent = _acp_indent acp + indAdd+          , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd)+            -- we cannot use just _acp_line acp + indAdd because of the case+            -- where there are multiple BDFEnsureIndents in the same line.+            -- Then, the actual indentation is relative to the current+            -- indentation, not the current cursor position.+          }+        r <- rec bd+        acp' <- mGet+        mSet $ acp' { _acp_indent = _acp_indent acp }+        return $ case indent of+          BrIndentNone -> r+          BrIndentRegular ->+            reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r+          BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r+      BDFNonBottomSpacing _ bd -> rec bd+      BDFSetParSpacing bd -> rec bd+      BDFForceParSpacing bd -> rec bd+      BDFDebug s bd -> do+        acp :: AltCurPos <- mGet+        tellDebugMess+          $ "transformAlts: BDFDEBUG "+          ++ s+          ++ " (node-id="+          ++ show brDcId+          ++ "): acp="+          ++ show acp+        reWrap . BDFDebug s <$> rec bd+  processSpacingSimple+    :: ( MonadMultiReader Config m+       , MonadMultiState AltCurPos m+       , MonadMultiWriter (Seq String) m+       )+    => BriDocNumbered+    -> m ()+  processSpacingSimple bd = getSpacing bd >>= \case+    LineModeInvalid -> error "processSpacingSimple inv"+    LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do+      acp <- mGet+      mSet $ acp { _acp_line = _acp_line acp + i }+    LineModeValid VerticalSpacing{} -> error "processSpacingSimple par"+    _ -> error "ghc exhaustive check is insufficient"+  hasSpace1+    :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool+  hasSpace1 _ _ LineModeInvalid = False+  hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs+  hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient"+  hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool+  hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _)+    = line + sameLine <= confUnpack (_lconfig_cols lconf)+  hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _)+    = line+      + sameLine+      <= confUnpack (_lconfig_cols lconf)+      && indent+      + indentPrep+      + par+      <= confUnpack (_lconfig_cols lconf)+  hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)+    = line + sameLine <= confUnpack (_lconfig_cols lconf)++getSpacing+  :: forall m+   . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)+  => BriDocNumbered+  -> m (LineModeValidity VerticalSpacing)+getSpacing !bridoc = rec bridoc+ where+  rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing)+  rec (brDcId, brDc) = do+    config <- mAsk+    let colMax = config & _conf_layout & _lconfig_cols & confUnpack+    result <- case brDc of+      -- BDWrapAnnKey _annKey bd -> rec bd+      BDFEmpty ->+        return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False+      BDFLit t -> return $ LineModeValid $ VerticalSpacing+        (Text.length t)+        VerticalSpacingParNone+        False+      BDFSeq list -> sumVs <$> rec `mapM` list+      BDFCols _sig list -> sumVs <$> rec `mapM` list+      BDFSeparator ->+        return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False+      BDFAddBaseY indent bd -> do+        mVs <- rec bd+        return $ mVs <&> \vs -> vs+          { _vs_paragraph = case _vs_paragraph vs of+            VerticalSpacingParNone -> VerticalSpacingParNone+            VerticalSpacingParAlways i ->+              VerticalSpacingParAlways $ case indent of+                BrIndentNone -> i+                BrIndentRegular ->+                  i+                    + (confUnpack+                      $ _lconfig_indentAmount+                      $ _conf_layout+                      $ config+                      )+                BrIndentSpecial j -> i + j+            VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of+              BrIndentNone -> i+              BrIndentRegular ->+                i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config)+              BrIndentSpecial j -> i + j+          }+      BDFBaseYPushCur bd -> do+        mVs <- rec bd+        return $ mVs <&> \vs -> vs+          -- We leave par as-is, even though it technically is not+          -- accurate (in general).+          -- the reason is that we really want to _keep_ it Just if it is+          -- just so we properly communicate the is-multiline fact.+          -- An alternative would be setting to (Just 0).+          { _vs_sameLine = max+            (_vs_sameLine vs)+            (case _vs_paragraph vs of+              VerticalSpacingParNone -> 0+              VerticalSpacingParSome i -> i+              VerticalSpacingParAlways i -> min colMax i+            )+          , _vs_paragraph = VerticalSpacingParSome 0+          }+      BDFBaseYPop bd -> rec bd+      BDFIndentLevelPushCur bd -> rec bd+      BDFIndentLevelPop bd -> rec bd+      BDFPar BrIndentNone sameLine indented -> do+        mVs <- rec sameLine+        mIndSp <- rec indented+        return+          $ [ VerticalSpacing lsp pspResult parFlagResult+            | VerticalSpacing lsp mPsp _ <- mVs+            , indSp <- mIndSp+            , lineMax <- getMaxVS $ mIndSp+            , let+              pspResult = case mPsp of+                VerticalSpacingParSome psp ->+                  VerticalSpacingParSome $ max psp lineMax+                VerticalSpacingParNone -> VerticalSpacingParSome $ lineMax+                VerticalSpacingParAlways psp ->+                  VerticalSpacingParAlways $ max psp lineMax+            , let+              parFlagResult =+                mPsp+                  == VerticalSpacingParNone+                  && _vs_paragraph indSp+                  == VerticalSpacingParNone+                  && _vs_parFlag indSp+            ]+      BDFPar{} -> error "BDPar with indent in getSpacing"+      BDFAlt [] -> error "empty BDAlt"+      BDFAlt (alt : _) -> rec alt+      BDFForceMultiline bd -> do+        mVs <- rec bd+        return $ mVs >>= _vs_paragraph .> \case+          VerticalSpacingParNone -> LineModeInvalid+          _ -> mVs+      BDFForceSingleline bd -> do+        mVs <- rec bd+        return $ mVs >>= _vs_paragraph .> \case+          VerticalSpacingParNone -> mVs+          _ -> LineModeInvalid+      BDFForwardLineMode bd -> rec bd+      BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of+        [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False+        _ -> VerticalSpacing 999 VerticalSpacingParNone False+      BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of+        [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False+        _ -> VerticalSpacing 999 VerticalSpacingParNone False+      BDFAnnotationPrior _annKey bd -> rec bd+      BDFAnnotationKW _annKey _kw bd -> rec bd+      BDFAnnotationRest _annKey bd -> rec bd+      BDFMoveToKWDP _annKey _kw _b bd -> rec bd+      BDFLines [] ->+        return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False+      BDFLines ls@(_ : _) -> do+        lSps <- rec `mapM` ls+        let (mVs : _) = lSps -- separated into let to avoid MonadFail+        return+          $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False+            | VerticalSpacing lsp _ _ <- mVs+            , lineMax <- getMaxVS $ maxVs $ lSps+            ]+      BDFEnsureIndent indent bd -> do+        mVs <- rec bd+        let+          addInd = case indent of+            BrIndentNone -> 0+            BrIndentRegular ->+              confUnpack $ _lconfig_indentAmount $ _conf_layout $ config+            BrIndentSpecial i -> i+        return $ mVs <&> \(VerticalSpacing lsp psp pf) ->+          VerticalSpacing (lsp + addInd) psp pf+      BDFNonBottomSpacing b bd -> do+        mVs <- rec bd+        return $ mVs <|> LineModeValid+          (VerticalSpacing+            0+            (if b+              then VerticalSpacingParSome 0+              else VerticalSpacingParAlways colMax+            )+            False+          )+      BDFSetParSpacing bd -> do+        mVs <- rec bd+        return $ mVs <&> \vs -> vs { _vs_parFlag = True }+      BDFForceParSpacing bd -> do+        mVs <- rec bd+        return+          $ [ vs+            | vs <- mVs+            , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone+            ]+      BDFDebug s bd -> do+        r <- rec bd+        tellDebugMess+          $ "getSpacing: BDFDebug "+          ++ show s+          ++ " (node-id="+          ++ show brDcId+          ++ "): mVs="+          ++ show r+        return r+    return result+  maxVs+    :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing+  maxVs = foldl'+    (liftM2+      (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing+        (max x1 y1)+        (case (x2, y2) of+          (x, VerticalSpacingParNone) -> x+          (VerticalSpacingParNone, x) -> x+          (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->+            VerticalSpacingParAlways $ max i j+          (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->+            VerticalSpacingParAlways $ max i j+          (VerticalSpacingParSome j, VerticalSpacingParAlways i) ->+            VerticalSpacingParAlways $ max i j+          (VerticalSpacingParSome x, VerticalSpacingParSome y) ->+            VerticalSpacingParSome $ max x y+        )+        False+      )+    )+    (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False)+  sumVs+    :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing+  sumVs sps = foldl' (liftM2 go) initial sps+   where+    go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing+      (x1 + y1)+      (case (x2, y2) of+        (x, VerticalSpacingParNone) -> x+        (VerticalSpacingParNone, x) -> x+        (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->+          VerticalSpacingParAlways $ i + j+        (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->+          VerticalSpacingParAlways $ i + j+        (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->+          VerticalSpacingParAlways $ i + j+        (VerticalSpacingParSome x, VerticalSpacingParSome y) ->+          VerticalSpacingParSome $ x + y+      )+      x3+    singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone+    singleline _ = False+    isPar (LineModeValid x) = _vs_parFlag x+    isPar _ = False+    parFlag = case sps of+      [] -> True+      _ -> all singleline (List.init sps) && isPar (List.last sps)+    initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag+  getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int+  getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of+    VerticalSpacingParSome i -> i+    VerticalSpacingParNone -> 0+    VerticalSpacingParAlways i -> i++data SpecialCompare = Unequal | Smaller | Bigger++getSpacings+  :: forall m+   . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)+  => Int+  -> BriDocNumbered+  -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]+getSpacings limit bridoc = preFilterLimit <$> rec bridoc+ where+    -- when we do `take K . filter someCondition` on a list of spacings, we+    -- need to first (also) limit the size of the input list, otherwise a+    -- _large_ input with a similarly _large_ prefix not passing our filtering+    -- process could lead to exponential runtime behaviour.+    -- TODO: 3 is arbitrary.+  preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]+  preFilterLimit = take (3 * limit)+  memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v+  memoWithKey k v = Memo.memo (const v) k+  rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]+  rec (brDcId, brdc) = memoWithKey brDcId $ do+    config <- mAsk+    let colMax = config & _conf_layout & _lconfig_cols & confUnpack+    let+      hasOkColCount (VerticalSpacing lsp psp _) = lsp <= colMax && case psp of+        VerticalSpacingParNone -> True+        VerticalSpacingParSome i -> i <= colMax+        VerticalSpacingParAlways{} -> True+    let+      specialCompare vs1 vs2 =+        if ((_vs_sameLine vs1 == _vs_sameLine vs2)+           && (_vs_parFlag vs1 == _vs_parFlag vs2)+           )+          then case (_vs_paragraph vs1, _vs_paragraph vs2) of+            (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) ->+              if i1 < i2 then Smaller else Bigger+            (p1, p2) -> if p1 == p2 then Smaller else Unequal+          else Unequal+    let+      allowHangingQuasiQuotes =+        config & _conf_layout & _lconfig_allowHangingQuasiQuotes & confUnpack+    let -- this is like List.nub, with one difference: if two elements+        -- are unequal only in _vs_paragraph, with both ParAlways, we+        -- treat them like equals and replace the first occurence with the+        -- smallest member of this "equal group".+      specialNub :: [VerticalSpacing] -> [VerticalSpacing]+      specialNub [] = []+      specialNub (x1 : xr) = case go x1 xr of+        (r, xs') -> r : specialNub xs'+       where+        go y1 [] = (y1, [])+        go y1 (y2 : yr) = case specialCompare y1 y2 of+          Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr')+          Smaller -> go y1 yr+          Bigger -> go y2 yr+    let -- the standard function used to enforce a constant upper bound+        -- on the number of elements returned for each node. Should be+        -- applied whenever in a parent the combination of spacings from+        -- its children might cause excess of the upper bound.+      filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing]+      filterAndLimit =+        take limit+                       -- prune so we always consider a constant+                       -- amount of spacings per node of the BriDoc.+          . specialNub+                       -- In the end we want to know if there is at least+                       -- one valid spacing for any alternative.+                       -- If there are duplicates in the list, then these+                       -- will either all be valid (so having more than the+                       -- first is pointless) or all invalid (in which+                       -- case having any of them is pointless).+                       -- Nonetheless I think the order of spacings should+                       -- be preserved as it provides a deterministic+                       -- choice for which spacings to prune (which is+                       -- an argument against simply using a Set).+                       -- I have also considered `fmap head . group` which+                       -- seems to work similarly well for common cases+                       -- and which might behave even better when it comes+                       -- to determinism of the algorithm. But determinism+                       -- should not be overrated here either - in the end+                       -- this is about deterministic behaviour of the+                       -- pruning we do that potentially results in+                       -- non-optimal layouts, and we'd rather take optimal+                       -- layouts when we can than take non-optimal layouts+                       -- just to be consistent with other cases where+                       -- we'd choose non-optimal layouts.+          . filter hasOkColCount+                       -- throw out any spacings (i.e. children) that+                       -- already use more columns than available in+                       -- total.+          . preFilterLimit+    result <- case brdc of+      -- BDWrapAnnKey _annKey bd -> rec bd+      BDFEmpty -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]+      BDFLit t ->+        return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]+      BDFSeq list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list+      BDFCols _sig list -> fmap sumVs . mapM filterAndLimit <$> rec `mapM` list+      BDFSeparator -> return $ [VerticalSpacing 1 VerticalSpacingParNone False]+      BDFAddBaseY indent bd -> do+        mVs <- rec bd+        return $ mVs <&> \vs -> vs+          { _vs_paragraph = case _vs_paragraph vs of+            VerticalSpacingParNone -> VerticalSpacingParNone+            VerticalSpacingParAlways i ->+              VerticalSpacingParAlways $ case indent of+                BrIndentNone -> i+                BrIndentRegular ->+                  i+                    + (confUnpack+                      $ _lconfig_indentAmount+                      $ _conf_layout+                      $ config+                      )+                BrIndentSpecial j -> i + j+            VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of+              BrIndentNone -> i+              BrIndentRegular ->+                i + (confUnpack $ _lconfig_indentAmount $ _conf_layout $ config)+              BrIndentSpecial j -> i + j+          }+      BDFBaseYPushCur bd -> do+        mVs <- rec bd+        return $ mVs <&> \vs -> vs+          -- We leave par as-is, even though it technically is not+          -- accurate (in general).+          -- the reason is that we really want to _keep_ it Just if it is+          -- just so we properly communicate the is-multiline fact.+          -- An alternative would be setting to (Just 0).+          { _vs_sameLine = max+            (_vs_sameLine vs)+            (case _vs_paragraph vs of+              VerticalSpacingParNone -> 0+              VerticalSpacingParSome i -> i+              VerticalSpacingParAlways i -> min colMax i+            )+          , _vs_paragraph = case _vs_paragraph vs of+            VerticalSpacingParNone -> VerticalSpacingParNone+            VerticalSpacingParSome i -> VerticalSpacingParSome i+            VerticalSpacingParAlways i -> VerticalSpacingParAlways i+          }+      BDFBaseYPop bd -> rec bd+      BDFIndentLevelPushCur bd -> rec bd+      BDFIndentLevelPop bd -> rec bd+      BDFPar BrIndentNone sameLine indented -> do+        mVss <- filterAndLimit <$> rec sameLine+        indSps <- filterAndLimit <$> rec indented+        let mVsIndSp = take limit $ [ (x, y) | x <- mVss, y <- indSps ]+        return $ mVsIndSp <&> \(VerticalSpacing lsp mPsp _, indSp) ->+          VerticalSpacing+            lsp+            (case mPsp of+              VerticalSpacingParSome psp ->+                VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO+              VerticalSpacingParNone -> spMakePar indSp+              VerticalSpacingParAlways psp ->+                VerticalSpacingParAlways $ max psp $ getMaxVS indSp+            )+            (mPsp+            == VerticalSpacingParNone+            && _vs_paragraph indSp+            == VerticalSpacingParNone+            && _vs_parFlag indSp+            )++      BDFPar{} -> error "BDPar with indent in getSpacing"+      BDFAlt [] -> error "empty BDAlt"+      -- BDAlt (alt:_) -> rec alt+      BDFAlt alts -> do+        r <- rec `mapM` alts+        return $ filterAndLimit =<< r+      BDFForceMultiline bd -> do+        mVs <- filterAndLimit <$> rec bd+        return $ filter ((/= VerticalSpacingParNone) . _vs_paragraph) mVs+      BDFForceSingleline bd -> do+        mVs <- filterAndLimit <$> rec bd+        return $ filter ((== VerticalSpacingParNone) . _vs_paragraph) mVs+      BDFForwardLineMode bd -> rec bd+      BDFExternal _ _ _ txt | [t] <- Text.lines txt ->+        return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]+      BDFExternal{} -> return $ [] -- yes, we just assume that we cannot properly layout+                    -- this.+      BDFPlain t -> return+        [ case Text.lines t of+            [] -> VerticalSpacing 0 VerticalSpacingParNone False+            [t1] ->+              VerticalSpacing (Text.length t1) VerticalSpacingParNone False+            (t1 : _) ->+              VerticalSpacing (Text.length t1) (VerticalSpacingParAlways 0) True+        | allowHangingQuasiQuotes+        ]+      BDFAnnotationPrior _annKey bd -> rec bd+      BDFAnnotationKW _annKey _kw bd -> rec bd+      BDFAnnotationRest _annKey bd -> rec bd+      BDFMoveToKWDP _annKey _kw _b bd -> rec bd+      BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]+      BDFLines ls@(_ : _) -> do+        -- 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+        -- paragraph". That most importantly means that Lines should never+        -- be inserted anywhere but at the start of the line. A+        -- counterexample would be anything like Seq[Lit "foo", Lines].+        lSpss <- map filterAndLimit <$> rec `mapM` ls+        let+          worbled = fmap reverse $ sequence $ reverse $ lSpss+          sumF lSps@(lSp1 : _) =+            VerticalSpacing (_vs_sameLine lSp1) (spMakePar $ maxVs lSps) False+          sumF [] =+            error+              $ "should not happen. if my logic does not fail"+              ++ "me, this follows from not (null ls)."+        return $ sumF <$> worbled+        -- lSpss@(mVs:_) <- rec `mapM` ls+        -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only+        --                      -- consider the first alternative for the+        --                      -- line's spacings.+        --                      -- also i am not sure if always including+        --                      -- the first line length in the paragraph+        --                      -- length gives the desired results.+        --                      -- it is the safe path though, for now.+        --   []       -> []+        --   (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) ->+        --     VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps+      BDFEnsureIndent indent bd -> do+        mVs <- rec bd+        let+          addInd = case indent of+            BrIndentNone -> 0+            BrIndentRegular ->+              confUnpack $ _lconfig_indentAmount $ _conf_layout $ config+            BrIndentSpecial i -> i+        return $ mVs <&> \(VerticalSpacing lsp psp parFlag) ->+          VerticalSpacing (lsp + addInd) psp parFlag+      BDFNonBottomSpacing b bd -> do+        -- TODO: the `b` flag is an ugly hack, but I was not able to make+        -- all tests work without it. It should be possible to have+        -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this+        -- problem but breaks certain other cases.+        mVs <- rec bd+        return $ if null mVs+          then+            [ VerticalSpacing+                0+                (if b+                  then VerticalSpacingParSome 0+                  else VerticalSpacingParAlways colMax+                )+                False+            ]+          else mVs <&> \vs -> vs+            { _vs_sameLine = min colMax (_vs_sameLine vs)+            , _vs_paragraph = case _vs_paragraph vs of+              VerticalSpacingParNone -> VerticalSpacingParNone+              VerticalSpacingParAlways i+                | b -> VerticalSpacingParSome 0+                | otherwise -> VerticalSpacingParAlways i+              VerticalSpacingParSome i+                | b -> VerticalSpacingParSome 0+                | otherwise -> VerticalSpacingParAlways i+            }+          -- the version below is an alternative idea: fold the input+          -- spacings into a single spacing. This was hoped to improve in+          -- certain cases where non-bottom alternatives took up "too much+          -- explored search space"; the downside is that it also cuts+          -- the search-space short in other cases where it is not necessary,+          -- leading to unnecessary new-lines. Disabled for now. A better+          -- solution would require conditionally folding the search-space+          -- only in appropriate locations (i.e. a new BriDoc node type+          -- for this purpose, perhaps "BDFNonBottomSpacing1").+          -- else+          --   [ Foldable.foldl1+          --     (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->+          --       VerticalSpacing+          --         (min x1 y1)+          --         (case (x2, y2) of+          --           (x, VerticalSpacingParNone) -> x+          --           (VerticalSpacingParNone, x) -> x+          --           (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->+          --             VerticalSpacingParAlways $ min i j+          --           (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->+          --             VerticalSpacingParAlways $ min i j+          --           (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->+          --             VerticalSpacingParAlways $ min i j+          --           (VerticalSpacingParSome x, VerticalSpacingParSome y) ->+          --             VerticalSpacingParSome $ min x y)+          --         False)+          --     mVs+          --   ]+      BDFSetParSpacing bd -> do+        mVs <- rec bd+        return $ mVs <&> \vs -> vs { _vs_parFlag = True }+      BDFForceParSpacing bd -> do+        mVs <- preFilterLimit <$> rec bd+        return+          $ [ vs+            | vs <- mVs+            , _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone+            ]+      BDFDebug s bd -> do+        r <- rec bd+        tellDebugMess+          $ "getSpacings: BDFDebug "+          ++ show s+          ++ " (node-id="+          ++ show brDcId+          ++ "): vs="+          ++ show (take 9 r)+        return r+    return result+  maxVs :: [VerticalSpacing] -> VerticalSpacing+  maxVs = foldl'+    (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) -> VerticalSpacing+      (max x1 y1)+      (case (x2, y2) of+        (x, VerticalSpacingParNone) -> x+        (VerticalSpacingParNone, x) -> x+        (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->+          VerticalSpacingParAlways $ max i j+        (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->+          VerticalSpacingParAlways $ max i j+        (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->+          VerticalSpacingParAlways $ max i j+        (VerticalSpacingParSome x, VerticalSpacingParSome y) ->+          VerticalSpacingParSome $ max x y+      )+      False+    )+    (VerticalSpacing 0 VerticalSpacingParNone False)+  sumVs :: [VerticalSpacing] -> VerticalSpacing+  sumVs sps = foldl' go initial sps+   where+    go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing+      (x1 + y1)+      (case (x2, y2) of+        (x, VerticalSpacingParNone) -> x+        (VerticalSpacingParNone, x) -> x+        (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->+          VerticalSpacingParAlways $ i + j+        (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->+          VerticalSpacingParAlways $ i + j+        (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->+          VerticalSpacingParAlways $ i + j+        (VerticalSpacingParSome x, VerticalSpacingParSome y) ->+          VerticalSpacingParSome $ x + y+      )+      x3+    singleline x = _vs_paragraph x == VerticalSpacingParNone+    isPar x = _vs_parFlag x+    parFlag = case sps of+      [] -> True+      _ -> all singleline (List.init sps) && isPar (List.last sps)+    initial = VerticalSpacing 0 VerticalSpacingParNone parFlag+  getMaxVS :: VerticalSpacing -> Int+  getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of+    VerticalSpacingParSome i -> i+    VerticalSpacingParNone -> 0+    VerticalSpacingParAlways i -> i+  spMakePar :: VerticalSpacing -> VerticalSpacingPar+  spMakePar (VerticalSpacing x1 x2 _) = case x2 of+    VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i+    VerticalSpacingParNone -> VerticalSpacingParSome $ x1+    VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i++fixIndentationForMultiple+  :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int+fixIndentationForMultiple acp indent = do+  indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack+  let+    indAddRaw = case indent of+      BrIndentNone -> 0+      BrIndentRegular -> indAmount+      BrIndentSpecial i -> i+  -- for IndentPolicyMultiple, we restrict the amount of added+  -- indentation in such a manner that we end up on a multiple of the+  -- base indentation.+  indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack+  pure $ if indPolicy == IndentPolicyMultiple+    then+      let+        indAddMultiple1 =+          indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount)+        indAddMultiple2 = if indAddMultiple1 <= 0+          then indAddMultiple1 + indAmount+          else indAddMultiple1+      in indAddMultiple2+    else indAddRaw
+ source/library/Brittany/Internal/Transformations/Columns.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Transformations.Columns where++import qualified Data.Generics.Uniplate.Direct as Uniplate+import qualified GHC.OldList as List+import Brittany.Internal.Prelude+import Brittany.Internal.Types++++transformSimplifyColumns :: BriDoc -> BriDoc+transformSimplifyColumns = Uniplate.rewrite $ \case+  -- BDWrapAnnKey annKey bd ->+  --   BDWrapAnnKey annKey $ transformSimplify bd+  BDEmpty -> Nothing+  BDLit{} -> Nothing+  BDSeq list+    | any+      (\case+        BDSeq{} -> True+        BDEmpty{} -> True+        _ -> False+      )+      list+    -> Just $ BDSeq $ list >>= \case+      BDEmpty -> []+      BDSeq l -> l+      x -> [x]+  BDSeq (BDCols sig1 cols1@(_ : _) : rest)+    | all+      (\case+        BDSeparator -> True+        _ -> False+      )+      rest+    -> Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1 : rest)])+  BDLines lines+    | any+      (\case+        BDLines{} -> True+        BDEmpty{} -> True+        _ -> False+      )+      lines+    -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case+      BDLines l -> l+      x -> [x]+  -- prior floating in+  BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->+    Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)+  BDAnnotationPrior annKey1 (BDLines (l : lr)) ->+    Just $ BDLines (BDAnnotationPrior annKey1 l : lr)+  BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->+    Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)+  -- post floating in+  BDAnnotationRest annKey1 (BDSeq list) ->+    Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]+  BDAnnotationRest annKey1 (BDLines list) ->+    Just+      $ BDLines+      $ List.init list+      ++ [BDAnnotationRest annKey1 $ List.last list]+  BDAnnotationRest annKey1 (BDCols sig cols) ->+    Just+      $ BDCols sig+      $ List.init cols+      ++ [BDAnnotationRest annKey1 $ List.last cols]+  BDAnnotationKW annKey1 kw (BDSeq list) ->+    Just+      $ BDSeq+      $ List.init list+      ++ [BDAnnotationKW annKey1 kw $ List.last list]+  BDAnnotationKW annKey1 kw (BDLines list) ->+    Just+      $ BDLines+      $ List.init list+      ++ [BDAnnotationKW annKey1 kw $ List.last list]+  BDAnnotationKW annKey1 kw (BDCols sig cols) ->+    Just+      $ BDCols sig+      $ List.init cols+      ++ [BDAnnotationKW annKey1 kw $ List.last cols]+  -- ensureIndent float-in+  -- not sure if the following rule is necessary; tests currently are+  -- unaffected.+  -- BDEnsureIndent indent (BDLines lines) ->+  --   Just $ BDLines $ BDEnsureIndent indent <$> lines+  -- matching col special transformation+  BDCols sig1 cols1@(_ : _)+    | BDLines lines@(_ : _ : _) <- List.last cols1+    , BDCols sig2 cols2 <- List.last lines+    , sig1 == sig2+    -> Just $ BDLines+      [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]+      , BDCols sig2 cols2+      ]+  BDCols sig1 cols1@(_ : _)+    | BDLines lines@(_ : _ : _) <- List.last cols1+    , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines+    , sig1 == sig2+    -> Just $ BDLines+      [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]+      , BDCols sig2 cols2+      ]+  BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1 == sig2 ->+    Just $ BDAddBaseY ind (BDLines [col1, col2])+  BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _) : rest))+    | sig1 == sig2 -> Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)+  BDPar ind (BDLines lines1) col2@(BDCols sig2 _)+    | BDCols sig1 _ <- List.last lines1, sig1 == sig2 -> Just+    $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])+  BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _) : 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))+  --   | sig1==sig2 ->+  --       Just $ BDPar+  --         ind1+  --         (BDLines [BDCols sig1 cols1, BDCols sig])+  BDCols sig1 cols+    | BDPar _ind line (BDCols sig2 cols2) <- List.last cols, sig1 == sig2+    -> Just+      $ BDLines [BDCols sig1 (List.init cols ++ [line]), BDCols sig2 cols2]+  BDCols sig1 cols+    | BDPar ind line (BDLines lines) <- List.last cols+    , BDCols sig2 cols2 <- List.last lines+    , sig1 == sig2+    -> Just $ BDLines+      [ BDCols sig1+      $ List.init cols+      ++ [BDPar ind line (BDLines $ List.init lines)]+      , BDCols sig2 cols2+      ]+  BDLines [x] -> Just $ x+  BDLines [] -> Just $ BDEmpty+  BDSeq{} -> Nothing+  BDCols{} -> Nothing+  BDSeparator -> Nothing+  BDAddBaseY{} -> Nothing+  BDBaseYPushCur{} -> Nothing+  BDBaseYPop{} -> Nothing+  BDIndentLevelPushCur{} -> Nothing+  BDIndentLevelPop{} -> Nothing+  BDPar{} -> Nothing+  BDAlt{} -> Nothing+  BDForceMultiline{} -> Nothing+  BDForceSingleline{} -> Nothing+  BDForwardLineMode{} -> Nothing+  BDExternal{} -> Nothing+  BDPlain{} -> Nothing+  BDLines{} -> Nothing+  BDAnnotationPrior{} -> Nothing+  BDAnnotationKW{} -> Nothing+  BDAnnotationRest{} -> Nothing+  BDMoveToKWDP{} -> Nothing+  BDEnsureIndent{} -> Nothing+  BDSetParSpacing{} -> Nothing+  BDForceParSpacing{} -> Nothing+  BDDebug{} -> Nothing+  BDNonBottomSpacing _ x -> Just x
+ source/library/Brittany/Internal/Transformations/Floating.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Transformations.Floating where++import qualified Data.Generics.Uniplate.Direct as Uniplate+import qualified GHC.OldList as List+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import Brittany.Internal.Utils++++-- note that this is not total, and cannot be with that exact signature.+mergeIndents :: BrIndent -> BrIndent -> BrIndent+mergeIndents BrIndentNone x = x+mergeIndents x BrIndentNone = x+mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) =+  BrIndentSpecial (max i j)+mergeIndents _ _ = error "mergeIndents"+++transformSimplifyFloating :: BriDoc -> BriDoc+transformSimplifyFloating = stepBO .> stepFull+  -- note that semantically, stepFull is completely sufficient.+  -- but the bottom-up switch-to-top-down-on-match transformation has much+  -- better complexity.+  -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence+  --         the push/pop cases would need to be copied over+ where+  descendPrior = transformDownMay $ \case+    -- prior floating in+    BDAnnotationPrior annKey1 (BDPar ind line indented) ->+      Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented+    BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->+      Just $ BDSeq (BDAnnotationPrior annKey1 l : lr)+    BDAnnotationPrior annKey1 (BDLines (l : lr)) ->+      Just $ BDLines (BDAnnotationPrior annKey1 l : lr)+    BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->+      Just $ BDCols sig (BDAnnotationPrior annKey1 l : lr)+    BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->+      Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x+    BDAnnotationPrior annKey1 (BDDebug s x) ->+      Just $ BDDebug s $ BDAnnotationPrior annKey1 x+    _ -> Nothing+  descendRest = transformDownMay $ \case+    -- post floating in+    BDAnnotationRest annKey1 (BDPar ind line indented) ->+      Just $ BDPar ind line $ BDAnnotationRest annKey1 indented+    BDAnnotationRest annKey1 (BDSeq list) ->+      Just+        $ BDSeq+        $ List.init list+        ++ [BDAnnotationRest annKey1 $ List.last list]+    BDAnnotationRest annKey1 (BDLines list) ->+      Just+        $ BDLines+        $ List.init list+        ++ [BDAnnotationRest annKey1 $ List.last list]+    BDAnnotationRest annKey1 (BDCols sig cols) ->+      Just+        $ BDCols sig+        $ List.init cols+        ++ [BDAnnotationRest annKey1 $ List.last cols]+    BDAnnotationRest annKey1 (BDAddBaseY indent x) ->+      Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x+    BDAnnotationRest annKey1 (BDDebug s x) ->+      Just $ BDDebug s $ BDAnnotationRest annKey1 x+    _ -> Nothing+  descendKW = transformDownMay $ \case+    -- post floating in+    BDAnnotationKW annKey1 kw (BDPar ind line indented) ->+      Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented+    BDAnnotationKW annKey1 kw (BDSeq list) ->+      Just+        $ BDSeq+        $ List.init list+        ++ [BDAnnotationKW annKey1 kw $ List.last list]+    BDAnnotationKW annKey1 kw (BDLines list) ->+      Just+        $ BDLines+        $ List.init list+        ++ [BDAnnotationKW annKey1 kw $ List.last list]+    BDAnnotationKW annKey1 kw (BDCols sig cols) ->+      Just+        $ BDCols sig+        $ List.init cols+        ++ [BDAnnotationKW annKey1 kw $ List.last cols]+    BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->+      Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x+    BDAnnotationKW annKey1 kw (BDDebug s x) ->+      Just $ BDDebug s $ BDAnnotationKW annKey1 kw x+    _ -> Nothing+  descendBYPush = transformDownMay $ \case+    BDBaseYPushCur (BDCols sig cols@(_ : _)) ->+      Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)+    BDBaseYPushCur (BDDebug s x) -> Just $ BDDebug s (BDBaseYPushCur x)+    _ -> Nothing+  descendBYPop = transformDownMay $ \case+    BDBaseYPop (BDCols sig cols@(_ : _)) ->+      Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])+    BDBaseYPop (BDDebug s x) -> Just $ BDDebug s (BDBaseYPop x)+    _ -> Nothing+  descendILPush = transformDownMay $ \case+    BDIndentLevelPushCur (BDCols sig cols@(_ : _)) ->+      Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)+    BDIndentLevelPushCur (BDDebug s x) ->+      Just $ BDDebug s (BDIndentLevelPushCur x)+    _ -> Nothing+  descendILPop = transformDownMay $ \case+    BDIndentLevelPop (BDCols sig cols@(_ : _)) ->+      Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])+    BDIndentLevelPop (BDDebug s x) -> Just $ BDDebug s (BDIndentLevelPop x)+    _ -> Nothing+  descendAddB = transformDownMay $ \case+    BDAddBaseY BrIndentNone x -> Just x+    -- AddIndent floats into Lines.+    BDAddBaseY indent (BDLines lines) ->+      Just $ BDLines $ BDAddBaseY indent <$> lines+    -- AddIndent floats into last column+    BDAddBaseY indent (BDCols sig cols) ->+      Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]+    -- merge AddIndent and Par+    BDAddBaseY ind1 (BDPar ind2 line indented) ->+      Just $ BDPar (mergeIndents ind1 ind2) line indented+    BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->+      Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)+    BDAddBaseY ind (BDAnnotationRest annKey1 x) ->+      Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)+    BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->+      Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)+    BDAddBaseY ind (BDSeq list) ->+      Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]+    BDAddBaseY _ lit@BDLit{} -> Just $ lit+    BDAddBaseY ind (BDBaseYPushCur x) ->+      Just $ BDBaseYPushCur (BDAddBaseY ind x)+    BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)+    BDAddBaseY ind (BDDebug s x) -> Just $ BDDebug s (BDAddBaseY ind x)+    BDAddBaseY ind (BDIndentLevelPop x) ->+      Just $ BDIndentLevelPop (BDAddBaseY ind x)+    BDAddBaseY ind (BDIndentLevelPushCur x) ->+      Just $ BDIndentLevelPushCur (BDAddBaseY ind x)+    BDAddBaseY ind (BDEnsureIndent ind2 x) ->+      Just $ BDEnsureIndent (mergeIndents ind ind2) x+    _ -> Nothing+  stepBO :: BriDoc -> BriDoc+  stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $+           transformUp f+   where+    f = \case+      x@BDAnnotationPrior{} -> descendPrior x+      x@BDAnnotationKW{} -> descendKW x+      x@BDAnnotationRest{} -> descendRest x+      x@BDAddBaseY{} -> descendAddB x+      x@BDBaseYPushCur{} -> descendBYPush x+      x@BDBaseYPop{} -> descendBYPop x+      x@BDIndentLevelPushCur{} -> descendILPush x+      x@BDIndentLevelPop{} -> descendILPop x+      x -> x+  stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $+             Uniplate.rewrite $ \case+    BDAddBaseY BrIndentNone x -> Just $ x+    -- AddIndent floats into Lines.+    BDAddBaseY indent (BDLines lines) ->+      Just $ BDLines $ BDAddBaseY indent <$> lines+    -- AddIndent floats into last column+    BDAddBaseY indent (BDCols sig cols) ->+      Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]+    BDAddBaseY ind (BDSeq list) ->+      Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]+    -- merge AddIndent and Par+    BDAddBaseY ind1 (BDPar ind2 line indented) ->+      Just $ BDPar (mergeIndents ind1 ind2) line indented+    BDAddBaseY _ lit@BDLit{} -> Just $ lit+    BDAddBaseY ind (BDBaseYPushCur x) ->+      Just $ BDBaseYPushCur (BDAddBaseY ind x)+    BDAddBaseY ind (BDBaseYPop x) -> Just $ BDBaseYPop (BDAddBaseY ind x)+    -- prior floating in+    BDAnnotationPrior annKey1 (BDPar ind line indented) ->+      Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented+    BDAnnotationPrior annKey1 (BDSeq (l : lr)) ->+      Just $ BDSeq ((BDAnnotationPrior annKey1 l) : lr)+    BDAnnotationPrior annKey1 (BDLines (l : lr)) ->+      Just $ BDLines ((BDAnnotationPrior annKey1 l) : lr)+    BDAnnotationPrior annKey1 (BDCols sig (l : lr)) ->+      Just $ BDCols sig ((BDAnnotationPrior annKey1 l) : lr)+    -- EnsureIndent float-in+    -- BDEnsureIndent indent (BDCols sig (col:colr)) ->+    --   Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))+    -- not sure if the following rule is necessary; tests currently are+    -- unaffected.+    -- BDEnsureIndent indent (BDLines lines) ->+    --   Just $ BDLines $ BDEnsureIndent indent <$> lines+    -- post floating in+    BDAnnotationRest annKey1 (BDPar ind line indented) ->+      Just $ BDPar ind line $ BDAnnotationRest annKey1 indented+    BDAnnotationRest annKey1 (BDSeq list) ->+      Just+        $ BDSeq+        $ List.init list+        ++ [BDAnnotationRest annKey1 $ List.last list]+    BDAnnotationRest annKey1 (BDLines list) ->+      Just+        $ BDLines+        $ List.init list+        ++ [BDAnnotationRest annKey1 $ List.last list]+    BDAnnotationRest annKey1 (BDCols sig cols) ->+      Just+        $ BDCols sig+        $ List.init cols+        ++ [BDAnnotationRest annKey1 $ List.last cols]+    _ -> Nothing
+ source/library/Brittany/Internal/Transformations/Indent.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Transformations.Indent where++import qualified Data.Generics.Uniplate.Direct as Uniplate+import qualified GHC.OldList as List+import Brittany.Internal.Prelude+import Brittany.Internal.Types++++-- prepare layouting by translating BDPar's, replacing them with Indents and+-- floating those in. This gives a more clear picture of what exactly is+-- affected by what amount of indentation.+transformSimplifyIndent :: BriDoc -> BriDoc+transformSimplifyIndent = Uniplate.rewrite $ \case+  BDPar ind (BDLines lines) indented ->+    Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]+  BDPar ind (BDCols sig cols) indented ->+    Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented])+  BDPar BrIndentNone _ _ -> Nothing+  BDPar ind x indented ->+    Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind indented)+  -- BDPar ind x indented ->+  --   Just $ BDLines+  --     [ BDAddBaseY ind x+  --     , BDEnsureIndent ind indented+  --     ]+  BDLines lines+    | any+      (\case+        BDLines{} -> True+        BDEmpty{} -> True+        _ -> False+      )+      lines+    -> Just $ BDLines $ filter isNotEmpty $ lines >>= \case+      BDLines l -> l+      x -> [x]+  BDLines [l] -> Just l+  BDAddBaseY i (BDAnnotationPrior k x) ->+    Just $ BDAnnotationPrior k (BDAddBaseY i x)+  BDAddBaseY i (BDAnnotationKW k kw x) ->+    Just $ BDAnnotationKW k kw (BDAddBaseY i x)+  BDAddBaseY i (BDAnnotationRest k x) ->+    Just $ BDAnnotationRest k (BDAddBaseY i x)+  BDAddBaseY i (BDSeq l) ->+    Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]+  BDAddBaseY i (BDCols sig l) ->+    Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]+  BDAddBaseY _ lit@BDLit{} -> Just lit++  _ -> Nothing
+ source/library/Brittany/Internal/Transformations/Par.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Internal.Transformations.Par where++import Brittany.Internal.Prelude+import Brittany.Internal.Types+import Brittany.Internal.Utils++++transformSimplifyPar :: BriDoc -> BriDoc+transformSimplifyPar = transformUp $ \case+  -- BDPar BrIndentNone line1 line2 -> Just $ BDLines [line1, line2]+  -- BDPar line indented ->+  --   Just $ BDLines [line, indented]+  -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 ->+  --   Just $ BDPar ind1 line (BDLines [p1, p2])+  x@(BDPar _ (BDPar _ BDPar{} _) _) -> x+  BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) ->+    BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))+  BDPar ind1 (BDPar ind2 line p1) p2 ->+    BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])+  BDLines lines+    | any+      (\case+        BDLines{} -> True+        BDEmpty{} -> True+        _ -> False+      )+      lines+    -> case go lines of+      [] -> BDEmpty+      [x] -> x+      xs -> BDLines xs+   where+    go = (=<<) $ \case+      BDLines l -> go l+      BDEmpty -> []+      x -> [x]+  BDLines [] -> BDEmpty+  BDLines [x] -> x+  -- BDCols sig cols | BDPar ind line indented <- List.last cols ->+  --   Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented+  -- BDPar BrIndentNone line indented ->+  --   Just $ BDLines [line, indented]+  BDEnsureIndent BrIndentNone x -> x+  x -> x
+ source/library/Brittany/Internal/Types.hs view
@@ -0,0 +1,463 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module Brittany.Internal.Types where++import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS+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.Text.Lazy.Builder as Text.Builder+import GHC (AnnKeywordId, GenLocated, Located, SrcSpan)+import Brittany.Internal.Config.Types+import 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+++data PerItemConfig = PerItemConfig+  { _icd_perBinding :: Map String (CConfig Maybe)+  , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe)+  }+  deriving Data.Data.Data++type PPM = MultiRWSS.MultiRWS+  '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]+  '[Text.Builder.Builder, [BrittanyError], Seq String]+  '[]++type PPMLocal = MultiRWSS.MultiRWS+  '[Config, ExactPrint.Anns]+  '[Text.Builder.Builder, [BrittanyError], Seq String]+  '[]++newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)++data LayoutState = LayoutState+  { _lstate_baseYs         :: [Int]+     -- ^ stack of number of current indentation columns+     -- (not number of indentations).+  , _lstate_curYOrAddNewline :: Either Int Int+             -- ^ Either:+             -- 1) number of chars in the current line.+             -- 2) number of newlines to be inserted before inserting any+             --    non-space elements.+  , _lstate_indLevels      :: [Int]+    -- ^ stack of current indentation levels. set for+    -- any layout-affected elements such as+    -- let/do/case/where elements.+    -- The main purpose of this member is to+    -- properly align comments, as their+    -- annotation positions are relative to the+    -- current layout indentation level.+  , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for+                                  -- properly treating cases where comments+                                  -- on the first indented element have an+                                  -- annotation offset relative to the last+                                  -- non-indented element, which is confusing.+  , _lstate_comments      :: Anns+  , _lstate_commentCol    :: Maybe Int -- this communicates two things:+                                       -- firstly, that cursor is currently+                                       -- at the end of a comment (so needs+                                       -- newline before any actual content).+                                       -- secondly, the column at which+                                       -- insertion of comments started.+  , _lstate_addSepSpace   :: Maybe Int -- number of spaces to insert if anyone+                                       -- writes (any non-spaces) in the+                                       -- current line.+  -- , _lstate_isNewline     :: NewLineState+  --     -- captures if the layouter currently is in a new line, i.e. if the+  --     -- current line only contains (indentation) spaces.+  -- this is mostly superseeded by curYOrAddNewline, iirc.+  , _lstate_commentNewlines :: Int -- number of newlines inserted due to+                                   -- move-to-DP at a start of a comment.+                                   -- Necessary because some keyword DPs+                                   -- are relative to the last non-comment+                                   -- entity (for some reason).+                                   -- This is not very strictly reset to 0,+                                   -- so we might in some cases get "artifacts"+                                   -- from previous document elements.+                                   -- But the worst effect at the moment would+                                   -- be that we introduce less newlines on+                                   -- moveToKWDP, which seems harmless enough.+  }++lstate_baseY :: LayoutState -> Int+lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs++lstate_indLevel :: LayoutState -> Int+lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels++-- evil, incomplete Show instance; only for debugging.+instance Show LayoutState where+  show state =+    "LayoutState"+    ++ "{baseYs=" ++ show (_lstate_baseYs state)+    ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)+    ++ ",indLevels=" ++ show (_lstate_indLevels state)+    ++ ",indLevelLinger=" ++ 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+--                                      -- newline, really. by special-casing+--                                      -- this we can appropriately handle it+--                                      -- differently at use-site.+--                   | NewLineStateYes+--                   | NewLineStateNo+--   deriving Eq++-- data LayoutSettings = LayoutSettings+--   { _lsettings_cols :: Int -- the thing that has default 80.+--   , _lsettings_indentPolicy :: IndentPolicy+--   , _lsettings_indentAmount :: Int+--   , _lsettings_indentWhereSpecial :: Bool -- indent where only 1 sometimes (TODO).+--   , _lsettings_indentListSpecial  :: Bool -- use some special indentation for ","+--                                           -- when creating zero-indentation+--                                           -- multi-line list literals.+--   , _lsettings_importColumn :: Int+--   , _lsettings_initialAnns :: ExactPrint.Anns+--   }++data BrittanyError+  = ErrorInput String+    -- ^ parsing failed+  | ErrorUnusedComment String+    -- ^ internal error: some comment went missing+  | ErrorMacroConfig String String+    -- ^ in-source config string parsing error; first argument is the parser+    --   output and second the corresponding, ill-formed input.+  | LayoutWarning String+    -- ^ some warning+  | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast)+    -- ^ internal error: pretty-printing is not implemented for type of node+    --   in the syntax-tree+  | ErrorOutputCheck+    -- ^ checking the output for syntactic validity failed++data BriSpacing = BriSpacing+  { _bs_spacePastLineIndent :: Int -- space in the current,+                                   -- potentially somewhat filled+                                   -- line.+  , _bs_spacePastIndent :: Int     -- space required in properly+                                   -- indented blocks below the+                                   -- current line.+  }++data ColSig+  = ColTyOpPrefix+    -- any prefixed operator/paren/"::"/..+    -- expected to have exactly two colums.+    -- e.g. ":: foo"+    --       111222+    --      "-> bar asd asd"+    --       11122222222222+  | ColPatternsFuncPrefix+    -- pattern-part of the lhs, e.g. "func (foo a b) c _".+    -- Has variable number of columns depending on the number of patterns.+  | ColPatternsFuncInfix+    -- pattern-part of the lhs, e.g. "Foo a <> Foo b".+    -- Has variable number of columns depending on the number of patterns.+  | ColPatterns+  | ColCasePattern+  | ColBindingLine (Maybe Text)+    -- e.g. "func pat pat = expr"+    --       1111111111111222222+    -- or   "pat | stmt -> expr"+    --       111111111112222222+    -- expected to have exactly two columns.+  | ColGuard+    -- e.g. "func pat pat | cond = ..."+    --       11111111111112222222+    -- or   "pat | cond1, cond2 -> ..."+    --       1111222222222222222+    -- expected to have exactly two columns+  | ColGuardedBody+    -- e.g. | foofoo = 1+    --      | bar    = 2+    --      111111111222+    -- expected to have exactly two columns+  | ColBindStmt+  | ColDoLet -- the non-indented variant+  | ColRec+  | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?+  | ColRecDecl+  | ColListComp+  | ColList+  | ColApp Text+  | ColTuple+  | ColTuples+  | ColOpPrefix -- merge with ColList ? other stuff?+  | ColImport++  -- TODO+  deriving (Eq, Ord, Data.Data.Data, Show)++data BrIndent = BrIndentNone+              | BrIndentRegular+              | BrIndentSpecial Int+  deriving (Eq, Ord, Data.Data.Data, Show)++type ToBriDocM = MultiRWSS.MultiRWS+                   '[Config, Anns] -- reader+                   '[[BrittanyError], Seq String] -- writer+                   '[NodeAllocIndex] -- state++type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered+type ToBriDoc' sym            = Located sym         -> ToBriDocM BriDocNumbered+type ToBriDocC sym c          = Located sym         -> ToBriDocM c++data DocMultiLine+  = MultiLineNo+  | MultiLinePossible+  deriving (Eq)++-- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot+-- of transformations on `BriDocF Identity`s and it is really annoying to+-- `Identity`/`runIdentity` everywhere.+data BriDoc+  = -- BDWrapAnnKey AnnKey BriDoc+    BDEmpty+  | BDLit !Text+  | BDSeq [BriDoc] -- elements other than the last should+                   -- not contains BDPars.+  | BDCols ColSig [BriDoc] -- elements other than the last+                         -- should not contains BDPars+  | BDSeparator -- semantically, space-unless-at-end-of-line.+  | BDAddBaseY BrIndent BriDoc+  | BDBaseYPushCur BriDoc+  | BDBaseYPop BriDoc+  | BDIndentLevelPushCur BriDoc+  | BDIndentLevelPop BriDoc+  | BDPar+    { _bdpar_indent :: BrIndent+    , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars+    , _bdpar_indented :: BriDoc+    }+  -- | BDAddIndent BrIndent (BriDocF f)+  -- | BDNewline+  | BDAlt [BriDoc]+  | BDForwardLineMode BriDoc+  | BDExternal AnnKey+               (Set AnnKey) -- set of annkeys contained within the node+                            -- to be printed via exactprint+               Bool -- should print extra comment ?+               Text+  | BDPlain !Text -- used for QuasiQuotes, content can be multi-line+                  -- (contrast to BDLit)+  | BDAnnotationPrior AnnKey BriDoc+  | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc+  | BDAnnotationRest  AnnKey BriDoc+  | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset+  | BDLines [BriDoc]+  | BDEnsureIndent BrIndent BriDoc+  -- the following constructors are only relevant for the alt transformation+  -- and are removed afterwards. They should never occur in any BriDoc+  -- after the alt transformation.+  | BDForceMultiline BriDoc+  | BDForceSingleline BriDoc+  | BDNonBottomSpacing Bool BriDoc+  | BDSetParSpacing BriDoc+  | BDForceParSpacing BriDoc+  -- pseudo-deprecated+  | BDDebug String BriDoc+  deriving (Data.Data.Data, Eq, Ord)++data BriDocF f+  = -- BDWrapAnnKey AnnKey BriDoc+    BDFEmpty+  | BDFLit !Text+  | BDFSeq [f (BriDocF f)] -- elements other than the last should+                   -- not contains BDPars.+  | BDFCols ColSig [f (BriDocF f)] -- elements other than the last+                         -- should not contains BDPars+  | BDFSeparator -- semantically, space-unless-at-end-of-line.+  | BDFAddBaseY BrIndent (f (BriDocF f))+  | BDFBaseYPushCur (f (BriDocF f))+  | BDFBaseYPop (f (BriDocF f))+  | BDFIndentLevelPushCur (f (BriDocF f))+  | BDFIndentLevelPop (f (BriDocF f))+  | BDFPar+    { _bdfpar_indent :: BrIndent+    , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars+    , _bdfpar_indented :: f (BriDocF f)+    }+  -- | BDAddIndent BrIndent (BriDocF f)+  -- | BDNewline+  | BDFAlt [f (BriDocF f)]+  | BDFForwardLineMode (f (BriDocF f))+  | BDFExternal AnnKey+               (Set AnnKey) -- set of annkeys contained within the node+                            -- to be printed via exactprint+               Bool -- should print extra comment ?+               Text+  | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line+                   -- (contrast to BDLit)+  | BDFAnnotationPrior AnnKey (f (BriDocF f))+  | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f))+  | BDFAnnotationRest  AnnKey (f (BriDocF f))+  | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset+  | BDFLines [(f (BriDocF f))]+  | BDFEnsureIndent BrIndent (f (BriDocF f))+  | BDFForceMultiline (f (BriDocF f))+  | BDFForceSingleline (f (BriDocF f))+  | BDFNonBottomSpacing Bool (f (BriDocF f))+  | BDFSetParSpacing (f (BriDocF f))+  | BDFForceParSpacing (f (BriDocF f))+  | BDFDebug String (f (BriDocF f))++-- deriving instance Data.Data.Data (BriDocF Identity)+deriving instance Data.Data.Data (BriDocF ((,) Int))++type BriDocFInt = BriDocF ((,) Int)+type BriDocNumbered = (Int, BriDocFInt)++instance Uniplate.Uniplate BriDoc where+  uniplate x@BDEmpty{}               = plate x+  uniplate x@BDLit{}                 = plate x+  uniplate (BDSeq list     )         = plate BDSeq ||* list+  uniplate (BDCols sig list)         = plate BDCols |- sig ||* list+  uniplate x@BDSeparator             = plate x+  uniplate (BDAddBaseY ind bd      ) = plate BDAddBaseY |- ind |* bd+  uniplate (BDBaseYPushCur       bd) = plate BDBaseYPushCur |* bd+  uniplate (BDBaseYPop           bd) = plate BDBaseYPop |* bd+  uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd+  uniplate (BDIndentLevelPop     bd) = plate BDIndentLevelPop |* bd+  uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented+  uniplate (BDAlt             alts ) = plate BDAlt ||* alts+  uniplate (BDForwardLineMode bd   ) = plate BDForwardLineMode |* bd+  uniplate x@BDExternal{}            = plate x+  uniplate x@BDPlain{}               = plate x+  uniplate (BDAnnotationPrior annKey bd) =+    plate BDAnnotationPrior |- annKey |* bd+  uniplate (BDAnnotationKW annKey kw bd) =+    plate BDAnnotationKW |- annKey |- kw |* bd+  uniplate (BDAnnotationRest annKey bd) =+    plate BDAnnotationRest |- annKey |* bd+  uniplate (BDMoveToKWDP annKey kw b bd) =+    plate BDMoveToKWDP |- annKey |- kw |- b |* bd+  uniplate (BDLines lines          ) = plate BDLines ||* lines+  uniplate (BDEnsureIndent ind bd  ) = plate BDEnsureIndent |- ind |* bd+  uniplate (BDForceMultiline  bd   ) = plate BDForceMultiline |* bd+  uniplate (BDForceSingleline bd   ) = plate BDForceSingleline |* bd+  uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd+  uniplate (BDSetParSpacing   bd   ) = plate BDSetParSpacing |* bd+  uniplate (BDForceParSpacing bd   ) = plate BDForceParSpacing |* bd+  uniplate (BDDebug s bd           ) = plate BDDebug |- s |* bd++newtype NodeAllocIndex = NodeAllocIndex Int++-- TODO: rename to "dropLabels" ?+unwrapBriDocNumbered :: BriDocNumbered -> BriDoc+unwrapBriDocNumbered tpl = case snd tpl of+  BDFEmpty                     -> BDEmpty+  BDFLit t                     -> BDLit t+  BDFSeq list                  -> BDSeq $ rec <$> list+  BDFCols sig list             -> BDCols sig $ rec <$> list+  BDFSeparator                 -> BDSeparator+  BDFAddBaseY ind bd           -> BDAddBaseY ind $ rec bd+  BDFBaseYPushCur       bd     -> BDBaseYPushCur $ rec bd+  BDFBaseYPop           bd     -> BDBaseYPop $ rec bd+  BDFIndentLevelPushCur bd     -> BDIndentLevelPushCur $ rec bd+  BDFIndentLevelPop     bd     -> BDIndentLevelPop $ rec bd+  BDFPar ind line indented     -> BDPar ind (rec line) (rec indented)+  BDFAlt             alts      -> BDAlt $ rec <$> alts -- not that this will happen+  BDFForwardLineMode bd        -> BDForwardLineMode $ rec bd+  BDFExternal k ks c t         -> BDExternal k ks c t+  BDFPlain t                   -> BDPlain t+  BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd+  BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd+  BDFAnnotationRest annKey bd  -> BDAnnotationRest annKey $ rec bd+  BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd+  BDFLines lines               -> BDLines $ rec <$> lines+  BDFEnsureIndent ind bd       -> BDEnsureIndent ind $ rec bd+  BDFForceMultiline  bd        -> BDForceMultiline $ rec bd+  BDFForceSingleline bd        -> BDForceSingleline $ rec bd+  BDFNonBottomSpacing b bd     -> BDNonBottomSpacing b $ rec bd+  BDFSetParSpacing   bd        -> BDSetParSpacing $ rec bd+  BDFForceParSpacing bd        -> BDForceParSpacing $ rec bd+  BDFDebug s bd                -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd+  where rec = unwrapBriDocNumbered++isNotEmpty :: BriDoc -> Bool+isNotEmpty BDEmpty = False+isNotEmpty _       = True++-- this might not work. is not used anywhere either.+briDocSeqSpine :: BriDoc -> ()+briDocSeqSpine = \case+  BDEmpty                        -> ()+  BDLit _t                       -> ()+  BDSeq list                     -> foldl' ((briDocSeqSpine .) . seq) () list+  BDCols _sig list               -> foldl' ((briDocSeqSpine .) . seq) () list+  BDSeparator                    -> ()+  BDAddBaseY _ind bd             -> briDocSeqSpine bd+  BDBaseYPushCur       bd        -> briDocSeqSpine bd+  BDBaseYPop           bd        -> briDocSeqSpine bd+  BDIndentLevelPushCur bd        -> briDocSeqSpine bd+  BDIndentLevelPop     bd        -> briDocSeqSpine bd+  BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented+  BDAlt             alts         -> foldl' (\() -> briDocSeqSpine) () alts+  BDForwardLineMode bd           -> briDocSeqSpine bd+  BDExternal{}                   -> ()+  BDPlain{}                      -> ()+  BDAnnotationPrior _annKey bd   -> briDocSeqSpine bd+  BDAnnotationKW _annKey _kw bd  -> briDocSeqSpine bd+  BDAnnotationRest _annKey bd    -> briDocSeqSpine bd+  BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd+  BDLines lines                  -> foldl' (\() -> briDocSeqSpine) () lines+  BDEnsureIndent _ind bd         -> briDocSeqSpine bd+  BDForceMultiline  bd           -> briDocSeqSpine bd+  BDForceSingleline bd           -> briDocSeqSpine bd+  BDNonBottomSpacing _ bd        -> briDocSeqSpine bd+  BDSetParSpacing   bd           -> briDocSeqSpine bd+  BDForceParSpacing bd           -> briDocSeqSpine bd+  BDDebug _s bd                  -> briDocSeqSpine bd++briDocForceSpine :: BriDoc -> BriDoc+briDocForceSpine bd = briDocSeqSpine bd `seq` bd+++data VerticalSpacingPar+  = VerticalSpacingParNone -- no indented lines+  | VerticalSpacingParSome   Int -- indented lines, requiring this much+                                 -- vertical space at most+  | VerticalSpacingParAlways Int -- indented lines, requiring this much+                                 -- vertical space at most, but should+                                 -- be considered as having space for+                                 -- any spacing validity check.+    -- TODO: it might be wrong not to extend "always" to the none case, i.e.+    -- we might get better properties of spacing operators by having a+    -- product like (Normal|Always, None|Some Int).+  deriving (Eq, Show)++data VerticalSpacing+  = VerticalSpacing+    { _vs_sameLine  :: !Int+    , _vs_paragraph :: !VerticalSpacingPar+    , _vs_parFlag   :: !Bool+    }+  deriving (Eq, Show)++newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)+  deriving (Functor, Applicative, Monad, Show, Alternative)++pattern LineModeValid :: forall t. t -> LineModeValidity t+pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t+pattern LineModeInvalid :: forall t. LineModeValidity t+pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t
+ source/library/Brittany/Internal/Utils.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}++module 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 Brittany.Internal.Config.Types+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types+import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils+import qualified Text.PrettyPrint as PP++++parDoc :: String -> PP.Doc+parDoc = PP.fsep . fmap PP.text . List.words++parDocW :: [String] -> PP.Doc+parDocW = PP.fsep . fmap PP.text . List.words . List.unwords+++showSDoc_ :: GHC.SDoc -> String+showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags++showOutputable :: (GHC.Outputable a) => a -> String+showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags++fromMaybeIdentity :: Identity a -> Maybe a -> Identity a+fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y++fromOptionIdentity :: Identity a -> Maybe a -> Identity a+fromOptionIdentity x y =+  Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y++-- maximum monoid over N+0+-- or more than N, because Num is allowed.+newtype Max a = Max { getMax :: a }+  deriving (Eq, Ord, Show, Bounded, Num)++instance (Num a, Ord a) => Semigroup (Max a) where+  (<>) = Data.Coerce.coerce (max :: a -> a -> a)++instance (Num a, Ord a) => Monoid (Max a) where+  mempty = Max 0+  mappend = (<>)++newtype ShowIsId = ShowIsId String deriving Data++instance Show ShowIsId where+  show (ShowIsId x) = x++data A x = A ShowIsId x+  deriving Data++customLayouterF :: ExactPrint.Types.Anns -> LayouterF+customLayouterF anns layoutF =+  DataToLayouter+    $ f+    `extQ` showIsId+    `extQ` fastString+    `extQ` bytestring+    `extQ` occName+    `extQ` srcSpan+    `ext2Q` located+ where+  DataToLayouter f = defaultLayouterF layoutF+  simpleLayouter :: String -> NodeLayouter+  simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)+  showIsId :: ShowIsId -> NodeLayouter+  showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case+    Left True -> PP.parens $ PP.text s+    Left False -> PP.text s+    Right _ -> PP.text s+  fastString =+    simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString+      -> NodeLayouter+  bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter+  occName =+    simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString+  srcSpan :: GHC.SrcSpan -> NodeLayouter+  srcSpan ss =+    simpleLayouter+             -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"+      $ "{"+      ++ showOutputable ss+      ++ "}"+  located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter+  located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a+   where+    annStr = case cast ss of+      Just (s :: GHC.SrcSpan) ->+        ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)+      Nothing -> ShowIsId "nnnnnnnn"++customLayouterNoAnnsF :: LayouterF+customLayouterNoAnnsF layoutF =+  DataToLayouter+    $ f+    `extQ` showIsId+    `extQ` fastString+    `extQ` bytestring+    `extQ` occName+    `extQ` srcSpan+    `ext2Q` located+ where+  DataToLayouter f = defaultLayouterF layoutF+  simpleLayouter :: String -> NodeLayouter+  simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)+  showIsId :: ShowIsId -> NodeLayouter+  showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case+    Left True -> PP.parens $ PP.text s+    Left False -> PP.text s+    Right _ -> PP.text s+  fastString =+    simpleLayouter . ("{FastString: " ++) . (++ "}") . show :: GHC.FastString+      -> NodeLayouter+  bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter+  occName =+    simpleLayouter . ("{OccName: " ++) . (++ "}") . OccName.occNameString+  srcSpan :: GHC.SrcSpan -> NodeLayouter+  srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"+  located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter+  located (GHC.L _ss a) = runDataToLayouter layoutF a++-- displayBriDocTree :: BriDoc -> PP.Doc+-- displayBriDocTree = \case+--   BDWrapAnnKey annKey doc -> def "BDWrapAnnKey"+--                            $ PP.text (show annKey)+--                          $+$ displayBriDocTree doc+--   BDEmpty         -> PP.text "BDEmpty"+--   BDLit t         -> def "BDLit" $ PP.text (show t)+--   BDSeq list      -> def "BDSeq" $ displayList list+--   BDCols sig list -> def "BDCols" $ PP.text (show sig)+--                                 $+$ displayList list+--   BDSeparator     -> PP.text "BDSeparator"+--   BDPar rol indent lines -> def "BDPar" $ displayBriDocTree rol+--                                       $+$ PP.text (show indent)+--                                       $+$ displayList lines+--   BDAlt alts      -> def "BDAlt" $ displayList alts+--   BDExternal ast _t -> def "BDExternal" (astToDoc ast)+--   BDSpecialPostCommentLoc _ -> PP.text "BDSpecialPostCommentLoc"+--  where+--   def x r = PP.text x $+$ PP.nest 2 r+--   displayList :: [BriDoc] -> PP.Doc+--   displayList [] = PP.text "[]"+--   displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocTree x+--                               : [PP.text "," <+> displayBriDocTree t | t<-xr]+--                              ++ [PP.text "]"]++-- displayBriDocSimpleTree :: BriDocSimple -> PP.Doc+-- displayBriDocSimpleTree = \case+--   BDSWrapAnnKey annKey doc -> def "BDSWrapAnnKey"+--                            $ PP.text (show annKey)+--                          $+$ displayBriDocSimpleTree doc+--   BDSLit t         -> def "BDSLit" $ PP.text (show t)+--   BDSSeq list      -> def "BDSSeq" $ displayList list+--   BDSCols sig list -> def "BDSCols" $ PP.text (show sig)+--                                 $+$ displayList list+--   BDSSeparator     -> PP.text "BDSSeparator"+--   BDSPar rol indent lines -> def "BDSPar" $ displayBriDocSimpleTree rol+--                                       $+$ PP.text (show indent)+--                                       $+$ displayList lines+--   BDSExternal annKey _subKeys _t -> def "BDSExternal" (PP.text $ show annKey)+--   BDSSpecialPostCommentLoc _ -> PP.text "BDSSpecialPostCommentLoc"+--  where+--   def x r = PP.text x $+$ PP.nest 2 r+--   displayList :: [BriDocSimple] -> PP.Doc+--   displayList [] = PP.text "[]"+--   displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocSimpleTree x+--                               : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr]+--                              ++ [PP.text "]"]++traceIfDumpConf+  :: (MonadMultiReader Config m, Show a)+  => String+  -> (DebugConfig -> Identity (Semigroup.Last Bool))+  -> a+  -> m ()+traceIfDumpConf s accessor val = do+  whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do+    trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()++tellDebugMess :: MonadMultiWriter (Seq String) m => String -> m ()+tellDebugMess s = mTell $ Seq.singleton s++tellDebugMessShow+  :: forall a m . (MonadMultiWriter (Seq String) m, Show a) => a -> m ()+tellDebugMessShow = tellDebugMess . show++-- i should really put that into multistate..+mModify :: MonadMultiState s m => (s -> s) -> m ()+mModify f = mGet >>= mSet . f++astToDoc :: Data ast => ast -> PP.Doc+astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast++briDocToDoc :: BriDoc -> PP.Doc+briDocToDoc = astToDoc . removeAnnotations+ where+  removeAnnotations = Uniplate.transform $ \case+    BDAnnotationPrior _ x -> x+    BDAnnotationKW _ _ x -> x+    BDAnnotationRest _ x -> x+    x -> x++briDocToDocWithAnns :: BriDoc -> PP.Doc+briDocToDocWithAnns = astToDoc++annsDoc :: ExactPrint.Types.Anns -> PP.Doc+annsDoc =+  printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)++breakEither :: (a -> Either b c) -> [a] -> ([b], [c])+breakEither _ [] = ([], [])+breakEither fn (a1 : aR) = case fn a1 of+  Left b -> (b : bs, cs)+  Right c -> (bs, c : cs)+  where (bs, cs) = breakEither fn aR++spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])+spanMaybe f (x1 : xR) | Just y <- f x1 = (y : ys, xs)+  where (ys, xs) = spanMaybe f xR+spanMaybe _ xs = ([], xs)++data FirstLastView a+  = FirstLastEmpty+  | FirstLastSingleton a+  | FirstLast a [a] a++splitFirstLast :: [a] -> FirstLastView a+splitFirstLast [] = FirstLastEmpty+splitFirstLast [x] = FirstLastSingleton x+splitFirstLast (x1 : xr) = FirstLast x1 (List.init xr) (List.last xr)++-- TODO: move to uniplate upstream?+-- aka `transform`+transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)+transformUp f = g where g = f . Uniplate.descend g+_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)+_transformDown f = g where g = Uniplate.descend g . f+transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)+transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x+_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)+_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x++-- | similar to List.lines, but treating the case of final newline character+-- in such a manner that this function is the inverse of @intercalate "\n"@.+lines' :: String -> [String]+lines' s = case break (== '\n') s of+  (s1, []) -> [s1]+  (s1, [_]) -> [s1, ""]+  (s1, (_ : r)) -> s1 : lines' r++absurdExt :: HsExtension.NoExtCon -> a+absurdExt = HsExtension.noExtCon
+ source/library/Brittany/Main.hs view
@@ -0,0 +1,500 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Brittany.Main where++import Control.Monad (zipWithM)+import qualified Control.Monad.Trans.Except as ExceptT+import Data.CZipWith+import qualified Data.Either+import qualified Data.List.Extra+import qualified Data.Monoid+import qualified Data.Semigroup as Semigroup+import qualified Data.Text as Text+import qualified Data.Text.IO as Text.IO+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 GHC.Utils.Outputable (Outputable(..), showSDocUnsafe)+import Brittany.Internal+import Brittany.Internal.Config+import Brittany.Internal.Config.Types+import Brittany.Internal.Obfuscation+import Brittany.Internal.Prelude+import Brittany.Internal.PreludeUtils+import Brittany.Internal.Types+import Brittany.Internal.Utils+import qualified Language.Haskell.GHC.ExactPrint as ExactPrint+import Paths_brittany+import qualified System.Directory as Directory+import qualified System.Environment as Environment+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 Text.Read (Read(..))+import UI.Butcher.Monadic++++data WriteMode = Display | Inplace++instance Read WriteMode where+  readPrec = val "display" Display <|> val "inplace" Inplace+    where val iden v = ReadPrec.lift $ ReadP.string iden >> return v++instance Show WriteMode where+  show Display = "display"+  show Inplace = "inplace"+++main :: IO ()+main = do+  progName <- Environment.getProgName+  args <- Environment.getArgs+  mainWith progName args++mainWith :: String -> [String] -> IO ()+mainWith progName args =+  Environment.withProgName progName+    . Environment.withArgs args+    $ mainFromCmdParserWithHelpDesc mainCmdParser++helpDoc :: PP.Doc+helpDoc = PP.vcat $ List.intersperse+  (PP.text "")+  [ parDocW+    [ "Reformats one or more haskell modules."+    , "Currently affects only the module head (imports/exports), type"+    , "signatures and function bindings;"+    , "everything else is left unmodified."+    , "Based on ghc-exactprint, thus (theoretically) supporting all"+    , "that ghc does."+    ]+  , parDoc $ "Example invocations:"+  , PP.hang (PP.text "") 2 $ PP.vcat+    [ PP.text "brittany"+    , PP.nest 2 $ PP.text "read from stdin, output to stdout"+    ]+  , PP.hang (PP.text "") 2 $ PP.vcat+    [ PP.text "brittany --indent=4 --write-mode=inplace *.hs"+    , PP.nest 2 $ PP.vcat+      [ PP.text "run on all modules in current directory (no backup!)"+      , PP.text "4 spaces indentation"+      ]+    ]+  , parDocW+    [ "This program is written carefully and contains safeguards to ensure"+    , "the output is syntactically valid and that no comments are removed."+    , "Nonetheless, this is a young project, and there will always be bugs,"+    , "and ensuring that the transformation never changes semantics of the"+    , "transformed source is currently not possible."+    , "Please do check the output and do not let brittany override your large"+    , "codebase without having backups."+    ]+  , parDoc $ "There is NO WARRANTY, to the extent permitted by law."+  , parDocW+    [ "This program is free software released under the AGPLv3."+    , "For details use the --license flag."+    ]+  , parDoc $ "See https://github.com/lspitzner/brittany"+  , parDoc+  $ "Please report bugs at"+  ++ " https://github.com/lspitzner/brittany/issues"+  ]++licenseDoc :: PP.Doc+licenseDoc = PP.vcat $ List.intersperse+  (PP.text "")+  [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner"+  , parDoc $ "Copyright (C) 2019 PRODA LTD"+  , parDocW+    [ "This program is free software: you can redistribute it and/or modify"+    , "it under the terms of the GNU Affero General Public License,"+    , "version 3, as published by the Free Software Foundation."+    ]+  , parDocW+    [ "This program is distributed in the hope that it will be useful,"+    , "but WITHOUT ANY WARRANTY; without even the implied warranty of"+    , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"+    , "GNU Affero General Public License for more details."+    ]+  , parDocW+    [ "You should have received a copy of the GNU Affero General Public"+    , "License along with this program.  If not, see"+    , "<http://www.gnu.org/licenses/>."+    ]+  ]+++mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()+mainCmdParser helpDesc = do+  addCmdSynopsis "haskell source pretty printer"+  addCmdHelp $ helpDoc+  -- addCmd "debugArgs" $ do+  addHelpCommand helpDesc+  addCmd "license" $ addCmdImpl $ print $ licenseDoc+  -- addButcherDebugCommand+  reorderStart+  printHelp <- addSimpleBoolFlag "h" ["help"] mempty+  printVersion <- addSimpleBoolFlag "" ["version"] mempty+  printLicense <- addSimpleBoolFlag "" ["license"] mempty+  noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty+  configPaths <- addFlagStringParams+    ""+    ["config-file"]+    "PATH"+    (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?+  cmdlineConfig <- cmdlineConfigParser+  suppressOutput <- addSimpleBoolFlag+    ""+    ["suppress-output"]+    (flagHelp $ parDoc+      "suppress the regular output, i.e. the transformed haskell source"+    )+  _verbosity <- addSimpleCountFlag+    "v"+    ["verbose"]+    (flagHelp $ parDoc "[currently without effect; TODO]")+  checkMode <- addSimpleBoolFlag+    "c"+    ["check-mode"]+    (flagHelp+      (PP.vcat+        [ PP.text "check for changes but do not write them out"+        , PP.text "exits with code 0 if no changes necessary, 1 otherwise"+        , PP.text "and print file path(s) of files that have changes to stdout"+        ]+      )+    )+  writeMode <- addFlagReadParam+    ""+    ["write-mode"]+    "(display|inplace)"+    (flagHelp+        (PP.vcat+          [ PP.text "display: output for any input(s) goes to stdout"+          , PP.text "inplace: override respective input file (without backup!)"+          ]+        )+    Data.Monoid.<> flagDefault Display+    )+  inputParams <- addParamNoFlagStrings+    "PATH"+    (paramHelpStr "paths to input/inout haskell source files")+  reorderStop+  addCmdImpl $ void $ do+    when printLicense $ do+      print licenseDoc+      System.Exit.exitSuccess+    when printVersion $ do+      do+        putStrLn $ "brittany version " ++ showVersion version+        putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner"+        putStrLn $ "Copyright (C) 2019 PRODA LTD"+        putStrLn $ "There is NO WARRANTY, to the extent permitted by law."+      System.Exit.exitSuccess+    when printHelp $ do+      liftIO+        $ putStrLn+        $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 }+        $ ppHelpShallow helpDesc+      System.Exit.exitSuccess++    let+      inputPaths = if null inputParams then [Nothing] else map Just inputParams+    let+      outputPaths = case writeMode of+        Display -> repeat Nothing+        Inplace -> inputPaths++    configsToLoad <- liftIO $ if null configPaths+      then+        maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)+      else pure configPaths++    config <-+      runMaybeT+          (if noUserConfig+            then readConfigs cmdlineConfig configsToLoad+            else readConfigsWithUserConfig cmdlineConfig configsToLoad+          )+        >>= \case+              Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)+              Just x -> return x+    when (config & _conf_debug & _dconf_dump_config & confUnpack)+      $ trace (showConfigYaml config)+      $ return ()++    results <- zipWithM+      (coreIO putStrErrLn config suppressOutput checkMode)+      inputPaths+      outputPaths++    if checkMode+      then when (Changes `elem` (Data.Either.rights results))+        $ System.Exit.exitWith (System.Exit.ExitFailure 1)+      else case results of+        xs | all Data.Either.isRight xs -> pure ()+        [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)+        _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)+++data ChangeStatus = Changes | NoChanges+  deriving (Eq)++-- | The main IO parts for the default mode of operation, and after commandline+-- and config stuff is processed.+coreIO+  :: (String -> IO ()) -- ^ error output function. In parallel operation, you+                       -- may want serialize the different outputs and+                       -- consequently not directly print to stderr.+  -> Config -- ^ global program config.+  -> Bool   -- ^ whether to supress output (to stdout). Purely IO flag, so+            -- currently not part of program config.+  -> Bool   -- ^ whether we are (just) in check mode.+  -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing.+  -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing.+  -> IO (Either Int ChangeStatus)      -- ^ Either an errorNo, or the change status.+coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =+  ExceptT.runExceptT $ do+    let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()+    let ghcOptions = config & _conf_forward & _options_ghc & runIdentity+    -- there is a good of code duplication between the following code and the+    -- `pureModuleTransform` function. Unfortunately, there are also a good+    -- amount of slight differences: This module is a bit more verbose, and+    -- it tries to use the full-blown `parseModule` function which supports+    -- CPP (but requires the input to be a file..).+    let cppMode = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack+    -- the flag will do the following: insert a marker string+    -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with+    -- "#include" before processing (parsing) input; and remove that marker+    -- string from the transformation output.+    -- The flag is intentionally misspelled to prevent clashing with+    -- inline-config stuff.+    let+      hackAroundIncludes =+        config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack+    let+      exactprintOnly = viaGlobal || viaDebug+       where+        viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack+        viaDebug =+          config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack++    let+      cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags+        then case cppMode of+          CPPModeAbort -> do+            return $ Left "Encountered -XCPP. Aborting."+          CPPModeWarn -> do+            putErrorLnIO+              $ "Warning: Encountered -XCPP."+              ++ " Be warned that -XCPP is not supported and that"+              ++ " brittany cannot check that its output is syntactically"+              ++ " valid in its presence."+            return $ Right True+          CPPModeNowarn -> return $ Right True+        else return $ Right False+    (parseResult, originalContents) <- case inputPathM of+      Nothing -> do+        -- TODO: refactor this hack to not be mixed into parsing logic+        let+          hackF s = if "#include" `isPrefixOf` s+            then "-- BRITANY_INCLUDE_HACK " ++ s+            else s+        let+          hackTransform = if hackAroundIncludes && not exactprintOnly+            then List.intercalate "\n" . fmap hackF . lines'+            else id+        inputString <- liftIO System.IO.getContents+        parseRes <- liftIO $ parseModuleFromString+          ghcOptions+          "stdin"+          cppCheckFunc+          (hackTransform inputString)+        return (parseRes, Text.pack inputString)+      Just p -> liftIO $ do+        parseRes <- parseModule ghcOptions p cppCheckFunc+        inputText <- Text.IO.readFile p+        -- The above means we read the file twice, but the+        -- GHC API does not really expose the source it+        -- read. Should be in cache still anyways.+        --+        -- We do not use TextL.IO.readFile because lazy IO is evil.+        -- (not identical -> read is not finished ->+        -- handle still open -> write below crashes - evil.)+        return (parseRes, inputText)+    case parseResult of+      Left left -> do+        putErrorLn "parse error:"+        putErrorLn left+        ExceptT.throwE 60+      Right (anns, parsedSource, hasCPP) -> do+        (inlineConf, perItemConf) <-+          case+            extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)+          of+            Left (err, input) -> do+              putErrorLn $ "Error: parse error in inline configuration:"+              putErrorLn err+              putErrorLn $ "  in the string \"" ++ input ++ "\"."+              ExceptT.throwE 61+            Right c -> -- trace (showTree c) $+              pure c+        let moduleConf = cZipWith fromOptionIdentity config inlineConf+        when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do+          let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource+          trace ("---- ast ----\n" ++ show val) $ return ()+        let+          disableFormatting =+            moduleConf & _conf_disable_formatting & confUnpack+        (errsWarns, outSText, hasChanges) <- do+          if+            | disableFormatting -> do+              pure ([], originalContents, False)+            | exactprintOnly -> do+              let r = Text.pack $ ExactPrint.exactPrint parsedSource anns+              pure ([], r, r /= originalContents)+            | otherwise -> do+              let+                omitCheck =+                  moduleConf+                    & _conf_errorHandling+                    .> _econf_omit_output_valid_check+                    .> confUnpack+              (ews, outRaw) <- if hasCPP || omitCheck+                then return+                  $ pPrintModule moduleConf perItemConf anns parsedSource+                else liftIO $ pPrintModuleAndCheck+                  moduleConf+                  perItemConf+                  anns+                  parsedSource+              let+                hackF s = fromMaybe s $ TextL.stripPrefix+                  (TextL.pack "-- BRITANY_INCLUDE_HACK ")+                  s+              let+                out = TextL.toStrict $ if hackAroundIncludes+                  then+                    TextL.intercalate (TextL.pack "\n")+                    $ hackF+                    <$> TextL.splitOn (TextL.pack "\n") outRaw+                  else outRaw+              out' <- if moduleConf & _conf_obfuscate & confUnpack+                then lift $ obfuscate out+                else pure out+              pure $ (ews, out', out' /= originalContents)+        let+          customErrOrder ErrorInput{} = 4+          customErrOrder LayoutWarning{} = -1 :: Int+          customErrOrder ErrorOutputCheck{} = 1+          customErrOrder ErrorUnusedComment{} = 2+          customErrOrder ErrorUnknownNode{} = -2 :: Int+          customErrOrder ErrorMacroConfig{} = 5+        unless (null errsWarns) $ do+          let+            groupedErrsWarns =+              Data.List.Extra.groupOn customErrOrder+                $ List.sortOn customErrOrder+                $ errsWarns+          groupedErrsWarns `forM_` \case+            (ErrorOutputCheck{} : _) -> do+              putErrorLn+                $ "ERROR: brittany pretty printer"+                ++ " returned syntactically invalid result."+            (ErrorInput str : _) -> do+              putErrorLn $ "ERROR: parse error: " ++ str+            uns@(ErrorUnknownNode{} : _) -> do+              putErrorLn+                $ "WARNING: encountered unknown syntactical constructs:"+              uns `forM_` \case+                ErrorUnknownNode str ast@(L loc _) -> do+                  putErrorLn $ "  " <> str <> " at " <> showSDocUnsafe (ppr loc)+                  when+                      (config+                      & _conf_debug+                      & _dconf_dump_ast_unknown+                      & confUnpack+                      )+                    $ do+                        putErrorLn $ "  " ++ show (astToDoc ast)+                _ -> error "cannot happen (TM)"+              putErrorLn+                "  -> falling back on exactprint for this element of the module"+            warns@(LayoutWarning{} : _) -> do+              putErrorLn $ "WARNINGS:"+              warns `forM_` \case+                LayoutWarning str -> putErrorLn str+                _ -> error "cannot happen (TM)"+            unused@(ErrorUnusedComment{} : _) -> do+              putErrorLn+                $ "Error: detected unprocessed comments."+                ++ " The transformation output will most likely"+                ++ " not contain some of the comments"+                ++ " present in the input haskell source file."+              putErrorLn $ "Affected are the following comments:"+              unused `forM_` \case+                ErrorUnusedComment str -> putErrorLn str+                _ -> error "cannot happen (TM)"+            (ErrorMacroConfig err input : _) -> do+              putErrorLn $ "Error: parse error in inline configuration:"+              putErrorLn err+              putErrorLn $ "  in the string \"" ++ input ++ "\"."+            [] -> error "cannot happen"+        -- TODO: don't output anything when there are errors unless user+        -- adds some override?+        let+          hasErrors =+            if config & _conf_errorHandling & _econf_Werror & confUnpack+              then not $ null errsWarns+              else 0 < maximum (-1 : fmap customErrOrder errsWarns)+          outputOnErrs =+            config+              & _conf_errorHandling+              & _econf_produceOutputOnErrors+              & confUnpack+          shouldOutput =+            not suppressOutput+              && not checkMode+              && (not hasErrors || outputOnErrs)++        when shouldOutput+          $ addTraceSep (_conf_debug config)+          $ case outputPathM of+              Nothing -> liftIO $ Text.IO.putStr $ outSText+              Just p -> liftIO $ do+                let+                  isIdentical = case inputPathM of+                    Nothing -> False+                    Just _ -> not hasChanges+                unless isIdentical $ Text.IO.writeFile p $ outSText++        when (checkMode && hasChanges) $ case inputPathM of+          Nothing -> pure ()+          Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p++        when hasErrors $ ExceptT.throwE 70+        return (if hasChanges then Changes else NoChanges)+ where+  addTraceSep conf =+    if or+        [ confUnpack $ _dconf_dump_annotations conf+        , confUnpack $ _dconf_dump_ast_unknown conf+        , confUnpack $ _dconf_dump_ast_full conf+        , confUnpack $ _dconf_dump_bridoc_raw conf+        , confUnpack $ _dconf_dump_bridoc_simpl_alt conf+        , confUnpack $ _dconf_dump_bridoc_simpl_floating conf+        , confUnpack $ _dconf_dump_bridoc_simpl_columns conf+        , confUnpack $ _dconf_dump_bridoc_simpl_indent conf+        , confUnpack $ _dconf_dump_bridoc_final conf+        ]+      then trace "----"+      else id
− source/library/Language/Haskell/Brittany.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany-  ( parsePrintModule-  , staticDefaultConfig-  , forwardOptionsSyntaxExtsEnabled-  , userConfigPath-  , findLocalConfigPath-  , readConfigs-  , readConfigsWithUserConfig-  , Config-  , CConfig(..)-  , CDebugConfig(..)-  , CLayoutConfig(..)-  , CErrorHandlingConfig(..)-  , CForwardOptions(..)-  , CPreProcessorConfig(..)-  , BrittanyError(..)-  ) where--import Language.Haskell.Brittany.Internal-import Language.Haskell.Brittany.Internal.Config-import Language.Haskell.Brittany.Internal.Config.Types-import Language.Haskell.Brittany.Internal.Types
− source/library/Language/Haskell/Brittany/Internal.hs 
@@ -1,660 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Language.Haskell.Brittany.Internal-  ( parsePrintModule-  , parsePrintModuleTests-  , pPrintModule-  , pPrintModuleAndCheck-   -- re-export from utils:-  , parseModule-  , parseModuleFromString-  , extractCommentConfigs-  , getTopLevelDeclNameMap-  ) where--import Control.Monad.Trans.Except-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS-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.Maybe-import qualified Data.Semigroup as Semigroup-import qualified Data.Sequence as Seq-import qualified Data.Text as Text-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 qualified GHC.Driver.Session as GHC-import GHC.Hs-import qualified GHC.LanguageExtensions.Type as GHC-import qualified GHC.OldList as List-import GHC.Parser.Annotation (AnnKeywordId(..))-import GHC.Types.SrcLoc (SrcSpan)-import Language.Haskell.Brittany.Internal.Backend-import Language.Haskell.Brittany.Internal.BackendUtils-import Language.Haskell.Brittany.Internal.Config-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.Decl-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 qualified Language.Haskell.GHC.ExactPrint as ExactPrint-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint-import qualified UI.Butcher.Monadic as Butcher----data InlineConfigTarget-    = InlineConfigTargetModule-    | InlineConfigTargetNextDecl    -- really only next in module-    | InlineConfigTargetNextBinding -- by name-    | InlineConfigTargetBinding String--extractCommentConfigs-  :: ExactPrint.Anns-  -> TopLevelDeclNameMap-  -> Either (String, String) (CConfig Maybe, PerItemConfig)-extractCommentConfigs anns (TopLevelDeclNameMap declNameMap) = do-  let-    commentLiness =-      [ ( k-        , [ x-          | (ExactPrint.Comment x _ _, _) <--            (  ExactPrint.annPriorComments ann-            ++ ExactPrint.annFollowingComments ann-            )-          ]-          ++ [ x-             | (ExactPrint.AnnComment (ExactPrint.Comment x _ _), _) <--               ExactPrint.annsDP ann-             ]-        )-      | (k, ann) <- Map.toList anns-      ]-  let configLiness = commentLiness <&> second-        (Data.Maybe.mapMaybe $ \line -> do-          l1 <--            List.stripPrefix "-- BRITTANY" line-            <|> List.stripPrefix "--BRITTANY" line-            <|> List.stripPrefix "-- brittany" line-            <|> List.stripPrefix "--brittany" line-            <|> (List.stripPrefix "{- BRITTANY" line >>= stripSuffix "-}")-          let l2 = dropWhile isSpace l1-          guard-            (  ("@" `isPrefixOf` l2)-            || ("-disable" `isPrefixOf` l2)-            || ("-next" `isPrefixOf` l2)-            || ("{" `isPrefixOf` l2)-            || ("--" `isPrefixOf` l2)-            )-          pure l2-        )-  let-    configParser = Butcher.addAlternatives-      [ ( "commandline-config"-        , \s -> "-" `isPrefixOf` dropWhile (== ' ') s-        , cmdlineConfigParser-        )-      , ( "yaml-config-document"-        , \s -> "{" `isPrefixOf` dropWhile (== ' ') s-        , Butcher.addCmdPart (Butcher.varPartDesc "yaml-config-document")-        $ fmap (\lconf -> (mempty { _conf_layout = lconf }, ""))-        . either (const Nothing) Just-        . Data.Yaml.decodeEither'-        . Data.ByteString.Char8.pack-          -- TODO: use some proper utf8 encoder instead?-        )-      ]-    parser = do -- we will (mis?)use butcher here to parse the inline config-                -- line.-      let nextDecl = do-            conf <- configParser-            Butcher.addCmdImpl (InlineConfigTargetNextDecl, conf)-      Butcher.addCmd "-next-declaration" nextDecl-      Butcher.addCmd "-Next-Declaration" nextDecl-      Butcher.addCmd "-NEXT-DECLARATION" nextDecl-      let nextBinding = do-            conf <- configParser-            Butcher.addCmdImpl (InlineConfigTargetNextBinding, conf)-      Butcher.addCmd "-next-binding" nextBinding-      Butcher.addCmd "-Next-Binding" nextBinding-      Butcher.addCmd "-NEXT-BINDING" nextBinding-      let disableNextBinding = do-            Butcher.addCmdImpl-              ( InlineConfigTargetNextBinding-              , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }-              )-      Butcher.addCmd "-disable-next-binding" disableNextBinding-      Butcher.addCmd "-Disable-Next-Binding" disableNextBinding-      Butcher.addCmd "-DISABLE-NEXT-BINDING" disableNextBinding-      let disableNextDecl = do-            Butcher.addCmdImpl-              ( InlineConfigTargetNextDecl-              , mempty { _conf_roundtrip_exactprint_only = pure $ pure True }-              )-      Butcher.addCmd "-disable-next-declaration" disableNextDecl-      Butcher.addCmd "-Disable-Next-Declaration" disableNextDecl-      Butcher.addCmd "-DISABLE-NEXT-DECLARATION" disableNextDecl-      let disableFormatting = do-            Butcher.addCmdImpl-              ( InlineConfigTargetModule-              , mempty { _conf_disable_formatting = pure $ pure True }-              )-      Butcher.addCmd "-disable" disableFormatting-      Butcher.addCmd "@" $ do-        -- Butcher.addCmd "module" $ do-        --   conf <- configParser-        --   Butcher.addCmdImpl (InlineConfigTargetModule, conf)-        Butcher.addNullCmd $ do-          bindingName <- Butcher.addParamString "BINDING" mempty-          conf        <- configParser-          Butcher.addCmdImpl (InlineConfigTargetBinding bindingName, conf)-      conf <- configParser-      Butcher.addCmdImpl (InlineConfigTargetModule, conf)-  lineConfigss <- configLiness `forM` \(k, ss) -> do-    r <- ss `forM` \s -> case Butcher.runCmdParserSimple s parser of-      Left  err -> Left $ (err, s)-      Right c   -> Right $ c-    pure (k, r)--  let perModule = foldl'-        (<>)-        mempty-        [ conf-        | (_                       , lineConfigs) <- lineConfigss-        , (InlineConfigTargetModule, conf       ) <- lineConfigs-        ]-  let-    perBinding = Map.fromListWith-      (<>)-      [ (n, conf)-      | (k     , lineConfigs) <- lineConfigss-      , (target, conf       ) <- lineConfigs-      , n                     <- case target of-        InlineConfigTargetBinding s -> [s]-        InlineConfigTargetNextBinding | Just name <- Map.lookup k declNameMap ->-          [name]-        _ -> []-      ]-  let-    perKey = Map.fromListWith-      (<>)-      [ (k, conf)-      | (k     , lineConfigs) <- lineConfigss-      , (target, conf       ) <- lineConfigs-      , case target of-        InlineConfigTargetNextDecl -> True-        InlineConfigTargetNextBinding | Nothing <- Map.lookup k declNameMap ->-          True-        _ -> False-      ]--  pure-    $ ( perModule-      , PerItemConfig { _icd_perBinding = perBinding, _icd_perKey = perKey }-      )---getTopLevelDeclNameMap :: GHC.ParsedSource -> TopLevelDeclNameMap-getTopLevelDeclNameMap (L _ (HsModule _ _name _exports _ decls _ _)) =-  TopLevelDeclNameMap $ Map.fromList-    [ (ExactPrint.mkAnnKey decl, name)-    | decl       <- decls-    , (name : _) <- [getDeclBindingNames decl]-    ]----- | Exposes the transformation in an pseudo-pure fashion. The signature--- contains `IO` due to the GHC API not exposing a pure parsing function, but--- there should be no observable effects.------ Note that this function ignores/resets all config values regarding--- debugging, i.e. it will never use `trace`/write to stderr.------ Note that the ghc parsing function used internally currently is wrapped in--- `mask_`, so cannot be killed easily. If you don't control the input, you--- may wish to put some proper upper bound on the input's size as a timeout--- won't do.-parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)-parsePrintModule configWithDebugs inputText = runExceptT $ do-  let config =-        configWithDebugs { _conf_debug = _conf_debug staticDefaultConfig }-  let ghcOptions         = config & _conf_forward & _options_ghc & runIdentity-  let config_pp          = config & _conf_preprocessor-  let cppMode            = config_pp & _ppconf_CPPMode & confUnpack-  let hackAroundIncludes = config_pp & _ppconf_hackAroundIncludes & confUnpack-  (anns, parsedSource, hasCPP) <- do-    let hackF s = if "#include" `isPrefixOf` s-          then "-- BRITANY_INCLUDE_HACK " ++ s-          else s-    let hackTransform = if hackAroundIncludes-          then List.intercalate "\n" . fmap hackF . lines'-          else id-    let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags-          then case cppMode of-            CPPModeAbort  -> return $ Left "Encountered -XCPP. Aborting."-            CPPModeWarn   -> return $ Right True-            CPPModeNowarn -> return $ Right True-          else return $ Right False-    parseResult <- lift $ parseModuleFromString-      ghcOptions-      "stdin"-      cppCheckFunc-      (hackTransform $ Text.unpack inputText)-    case parseResult of-      Left  err -> throwE [ErrorInput err]-      Right x   -> pure x-  (inlineConf, perItemConf) <--    either (throwE . (: []) . uncurry ErrorMacroConfig) pure-      $ extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)-  let moduleConfig      = cZipWith fromOptionIdentity config inlineConf-  let disableFormatting = moduleConfig & _conf_disable_formatting & confUnpack-  if disableFormatting-    then do-      return inputText-    else do-      (errsWarns, outputTextL) <- do-        let omitCheck =-              moduleConfig-                & _conf_errorHandling-                & _econf_omit_output_valid_check-                & confUnpack-        (ews, outRaw) <- if hasCPP || omitCheck-          then return $ pPrintModule moduleConfig perItemConf anns parsedSource-          else lift-            $ pPrintModuleAndCheck moduleConfig perItemConf anns parsedSource-        let hackF s = fromMaybe s-              $ TextL.stripPrefix (TextL.pack "-- BRITANY_INCLUDE_HACK ") s-        pure $ if hackAroundIncludes-          then-            ( ews-            , TextL.intercalate (TextL.pack "\n") $ hackF <$> TextL.splitOn-              (TextL.pack "\n")-              outRaw-            )-          else (ews, outRaw)-      let customErrOrder ErrorInput{}         = 4-          customErrOrder LayoutWarning{}      = 0 :: Int-          customErrOrder ErrorOutputCheck{}   = 1-          customErrOrder ErrorUnusedComment{} = 2-          customErrOrder ErrorUnknownNode{}   = 3-          customErrOrder ErrorMacroConfig{}   = 5-      let hasErrors =-            if moduleConfig & _conf_errorHandling & _econf_Werror & confUnpack-            then not $ null errsWarns-            else 0 < maximum (-1 : fmap customErrOrder errsWarns)-      if hasErrors-        then throwE $ errsWarns-        else pure $ TextL.toStrict outputTextL------ BrittanyErrors can be non-fatal warnings, thus both are returned instead--- of an Either.--- This should be cleaned up once it is clear what kinds of errors really--- can occur.-pPrintModule-  :: Config-  -> PerItemConfig-  -> ExactPrint.Anns-  -> GHC.ParsedSource-  -> ([BrittanyError], TextL.Text)-pPrintModule conf inlineConf anns parsedModule =-  let ((out, errs), debugStrings) =-        runIdentity-          $ MultiRWSS.runMultiRWSTNil-          $ MultiRWSS.withMultiWriterAW-          $ MultiRWSS.withMultiWriterAW-          $ MultiRWSS.withMultiWriterW-          $ MultiRWSS.withMultiReader anns-          $ MultiRWSS.withMultiReader conf-          $ MultiRWSS.withMultiReader inlineConf-          $ MultiRWSS.withMultiReader (extractToplevelAnns parsedModule anns)-          $ do-              traceIfDumpConf "bridoc annotations raw" _dconf_dump_annotations-                $ annsDoc anns-              ppModule parsedModule-      tracer = if Seq.null debugStrings-        then id-        else-          trace ("---- DEBUGMESSAGES ---- ")-            . foldr (seq . join trace) id debugStrings-  in  tracer $ (errs, Text.Builder.toLazyText out)-  -- unless () $ do-  ---  --   debugStrings `forM_` \s ->-  --     trace s $ return ()---- | Additionally checks that the output compiles again, appending an error--- if it does not.-pPrintModuleAndCheck-  :: Config-  -> PerItemConfig-  -> ExactPrint.Anns-  -> GHC.ParsedSource-  -> IO ([BrittanyError], TextL.Text)-pPrintModuleAndCheck conf inlineConf anns parsedModule = do-  let ghcOptions     = conf & _conf_forward & _options_ghc & runIdentity-  let (errs, output) = pPrintModule conf inlineConf anns parsedModule-  parseResult <- parseModuleFromString ghcOptions-                                       "output"-                                       (\_ -> return $ Right ())-                                       (TextL.unpack output)-  let errs' = errs ++ case parseResult of-        Left{}  -> [ErrorOutputCheck]-        Right{} -> []-  return (errs', output)----- used for testing mostly, currently.--- TODO: use parsePrintModule instead and remove this function.-parsePrintModuleTests :: Config -> String -> Text -> IO (Either String Text)-parsePrintModuleTests conf filename input = do-  let inputStr = Text.unpack input-  parseResult <- parseModuleFromString-    (conf & _conf_forward & _options_ghc & runIdentity)-    filename-    (const . pure $ Right ())-    inputStr-  case parseResult of-    Left  err                     -> return $ Left err-    Right (anns, parsedModule, _) -> runExceptT $ do-      (inlineConf, perItemConf) <--        case extractCommentConfigs anns (getTopLevelDeclNameMap parsedModule) of-          Left  err -> throwE $ "error in inline config: " ++ show err-          Right x   -> pure x-      let moduleConf = cZipWith fromOptionIdentity conf inlineConf-      let omitCheck =-            conf-              &  _conf_errorHandling-              .> _econf_omit_output_valid_check-              .> confUnpack-      (errs, ltext) <- if omitCheck-        then return $ pPrintModule moduleConf perItemConf anns parsedModule-        else lift-          $ pPrintModuleAndCheck moduleConf perItemConf anns parsedModule-      if null errs-        then pure $ TextL.toStrict $ ltext-        else-          let-            errStrs = errs <&> \case-              ErrorInput         str -> str-              ErrorUnusedComment str -> str-              LayoutWarning      str -> str-              ErrorUnknownNode str _ -> str-              ErrorMacroConfig str _ -> "when parsing inline config: " ++ str-              ErrorOutputCheck       -> "Output is not syntactically valid."-          in  throwE $ "pretty printing error(s):\n" ++ List.unlines errStrs---- 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.---- parsePrintModuleTests :: Text -> Either String Text--- parsePrintModuleTests input = do---   let dflags = GHC.unsafeGlobalDynFlags---   let fakeFileName = "SomeTestFakeFileName.hs"---   let pragmaInfo = GHC.getOptions---         dflags---         (GHC.stringToStringBuffer $ Text.unpack input)---         fakeFileName---   (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags pragmaInfo---   let parseResult = ExactPrint.Parsers.parseWith---         dflags1---         fakeFileName---         GHC.parseModule---         inputStr---   case parseResult of---     Left (_, s) -> Left $ "parsing error: " ++ s---     Right (anns, parsedModule) -> do---       let (out, errs) = runIdentity---                       $ runMultiRWSTNil---                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterAW---                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiWriterW---                       $ Control.Monad.Trans.MultiRWS.Lazy.withMultiReader anns---                       $ ppModule parsedModule---       if (not $ null errs)---         then do---           let errStrs = errs <&> \case---                 ErrorUnusedComment str -> str---           Left $ "pretty printing error(s):\n" ++ List.unlines errStrs---         else return $ TextL.toStrict $ Text.Builder.toLazyText out--toLocal :: Config -> ExactPrint.Anns -> PPMLocal a -> PPM a-toLocal conf anns m = do-  (x, write) <--    lift $ MultiRWSS.runMultiRWSTAW (conf :+: anns :+: HNil) HNil $ m-  MultiRWSS.mGetRawW >>= \w -> MultiRWSS.mPutRawW (w `mappend` write)-  pure x--ppModule :: GenLocated SrcSpan HsModule -> PPM ()-ppModule lmod@(L _loc _m@(HsModule _ _name _exports _ decls _ _)) = do-  defaultAnns <- do-    anns <- mAsk-    let annKey = ExactPrint.mkAnnKey lmod-    let annMap = Map.findWithDefault Map.empty annKey anns-    let isEof = (== ExactPrint.AnnEofPos)-    let overAnnsDP f a = a { ExactPrint.annsDP = f $ ExactPrint.annsDP a }-    pure $ fmap (overAnnsDP . filter $ isEof . fst) annMap--  post <- ppPreamble lmod-  decls `forM_` \decl -> do-    let declAnnKey       = ExactPrint.mkAnnKey decl-    let declBindingNames = getDeclBindingNames decl-    inlineConf <- mAsk-    let mDeclConf = Map.lookup declAnnKey $ _icd_perKey inlineConf-    let mBindingConfs =-          declBindingNames <&> \n -> Map.lookup n $ _icd_perBinding inlineConf-    filteredAnns <- mAsk-      <&> \annMap ->-        Map.union defaultAnns $-        Map.findWithDefault Map.empty declAnnKey annMap--    traceIfDumpConf "bridoc annotations filtered/transformed"-                    _dconf_dump_annotations-      $ annsDoc filteredAnns--    config <- mAsk--    let config' = cZipWith fromOptionIdentity config-          $ mconcat (catMaybes (mBindingConfs ++ [mDeclConf]))--    let exactprintOnly = config' & _conf_roundtrip_exactprint_only & confUnpack-    toLocal config' filteredAnns $ do-      bd <- if exactprintOnly-        then briDocMToPPM $ briDocByExactNoComment decl-        else do-          (r, errs, debugs) <- briDocMToPPMInner $ layoutDecl decl-          mTell debugs-          mTell errs-          if null errs-            then pure r-            else briDocMToPPM $ briDocByExactNoComment decl-      layoutBriDoc bd--  let finalComments = filter-        (fst .> \case-          ExactPrint.AnnComment{} -> True-          _                       -> False-        )-        post-  post `forM_` \case-    (ExactPrint.AnnComment (ExactPrint.Comment cmStr _ _), l) -> do-      ppmMoveToExactLoc l-      mTell $ Text.Builder.fromString cmStr-    (ExactPrint.AnnEofPos, (ExactPrint.DP (eofZ, eofX))) ->-      let folder (acc, _) (kw, ExactPrint.DP (y, x)) = case kw of-            ExactPrint.AnnComment cm-              | span <- ExactPrint.commentIdentifier cm-              -> ( acc + y + GHC.srcSpanEndLine span - GHC.srcSpanStartLine span-                 , x + GHC.srcSpanEndCol span - GHC.srcSpanStartCol span-                 )-            _ -> (acc + y, x)-          (cmY, cmX) = foldl' folder (0, 0) finalComments-      in  ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)-    _ -> return ()--getDeclBindingNames :: LHsDecl GhcPs -> [String]-getDeclBindingNames (L _ decl) = case decl of-  SigD _ (TypeSig _ ns _) -> ns <&> \(L _ n) -> Text.unpack (rdrNameToText n)-  ValD _ (FunBind _ (L _ n) _ _) -> [Text.unpack $ rdrNameToText n]-  _                              -> []----- Prints the information associated with the module annotation--- This includes the imports-ppPreamble-  :: GenLocated SrcSpan HsModule-  -> PPM [(ExactPrint.KeywordId, ExactPrint.DeltaPos)]-ppPreamble lmod@(L loc m@HsModule{}) = do-  filteredAnns <- mAsk <&> \annMap ->-    Map.findWithDefault Map.empty (ExactPrint.mkAnnKey lmod) annMap-    -- Since ghc-exactprint adds annotations following (implicit)-    -- modules to both HsModule and the elements in the module-    -- this can cause duplication of comments. So strip-    -- attached annotations that come after the module's where-    -- from the module node-  config <- mAsk-  let shouldReformatPreamble =-        config & _conf_layout & _lconfig_reformatModulePreamble & confUnpack--  let-    (filteredAnns', post) =-      case Map.lookup (ExactPrint.mkAnnKey lmod) filteredAnns of-        Nothing -> (filteredAnns, [])-        Just mAnn ->-          let-            modAnnsDp = ExactPrint.annsDP mAnn-            isWhere (ExactPrint.G AnnWhere) = True-            isWhere _                       = False-            isEof (ExactPrint.AnnEofPos) = True-            isEof _                        = False-            whereInd     = List.findIndex (isWhere . fst) modAnnsDp-            eofInd       = List.findIndex (isEof . fst) modAnnsDp-            (pre, post') = case (whereInd, eofInd) of-              (Nothing, Nothing) -> ([], modAnnsDp)-              (Just i , Nothing) -> List.splitAt (i + 1) modAnnsDp-              (Nothing, Just _i) -> ([], modAnnsDp)-              (Just i , Just j ) -> List.splitAt (min (i + 1) j) modAnnsDp-            mAnn' = mAnn { ExactPrint.annsDP = pre }-            filteredAnns'' =-              Map.insert (ExactPrint.mkAnnKey lmod) mAnn' filteredAnns-          in-            (filteredAnns'', post')-  traceIfDumpConf "bridoc annotations filtered/transformed"-                  _dconf_dump_annotations-    $ annsDoc filteredAnns'--  if shouldReformatPreamble-    then toLocal config filteredAnns' $ withTransformedAnns lmod $ do-      briDoc <- briDocMToPPM $ layoutModule lmod-      layoutBriDoc briDoc-    else-      let emptyModule = L loc m { hsmodDecls = [] }-      in  MultiRWSS.withMultiReader filteredAnns' $ processDefault emptyModule-  return post--_sigHead :: Sig GhcPs -> String-_sigHead = \case-  TypeSig _ names _ ->-    "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)-  _ -> "unknown sig"--_bindHead :: HsBind GhcPs -> String-_bindHead = \case-  FunBind _ fId _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)-  PatBind _ _pat _ ([], []) -> "PatBind smth"-  _                           -> "unknown bind"----layoutBriDoc :: BriDocNumbered -> PPMLocal ()-layoutBriDoc briDoc = do-  -- first step: transform the briDoc.-  briDoc' <- MultiRWSS.withMultiStateS BDEmpty $ do-    -- Note that briDoc is BriDocNumbered, but state type is BriDoc.-    -- That's why the alt-transform looks a bit special here.-    traceIfDumpConf "bridoc raw" _dconf_dump_bridoc_raw-      $ briDocToDoc-      $ unwrapBriDocNumbered-      $ briDoc-    -- bridoc transformation: remove alts-    transformAlts briDoc >>= mSet-    mGet-      >>= briDocToDoc-      .>  traceIfDumpConf "bridoc post-alt" _dconf_dump_bridoc_simpl_alt-    -- bridoc transformation: float stuff in-    mGet >>= transformSimplifyFloating .> mSet-    mGet-      >>= briDocToDoc-      .>  traceIfDumpConf "bridoc post-floating"-                          _dconf_dump_bridoc_simpl_floating-    -- bridoc transformation: par removal-    mGet >>= transformSimplifyPar .> mSet-    mGet-      >>= briDocToDoc-      .>  traceIfDumpConf "bridoc post-par" _dconf_dump_bridoc_simpl_par-    -- bridoc transformation: float stuff in-    mGet >>= transformSimplifyColumns .> mSet-    mGet-      >>= briDocToDoc-      .>  traceIfDumpConf "bridoc post-columns" _dconf_dump_bridoc_simpl_columns-    -- bridoc transformation: indent-    mGet >>= transformSimplifyIndent .> mSet-    mGet-      >>= briDocToDoc-      .>  traceIfDumpConf "bridoc post-indent" _dconf_dump_bridoc_simpl_indent-    mGet-      >>= briDocToDoc-      .>  traceIfDumpConf "bridoc final" _dconf_dump_bridoc_final-    -- -- convert to Simple type-    -- simpl <- mGet <&> transformToSimple-    -- return simpl--  anns :: ExactPrint.Anns <- mAsk--  let state = LayoutState { _lstate_baseYs           = [0]-                          , _lstate_curYOrAddNewline = Right 0 -- important that we dont use left-                                             -- here because moveToAnn stuff-                                             -- of the first node needs to do-                                             -- its thing properly.-                          , _lstate_indLevels        = [0]-                          , _lstate_indLevelLinger   = 0-                          , _lstate_comments         = anns-                          , _lstate_commentCol       = Nothing-                          , _lstate_addSepSpace      = Nothing-                          , _lstate_commentNewlines  = 0-                          }--  state' <- MultiRWSS.withMultiStateS state $ layoutBriDocM briDoc'--  let remainingComments =-        [ c-        | (ExactPrint.AnnKey _ con, elemAnns) <- Map.toList-          (_lstate_comments state')-          -- With the new import layouter, we manually process comments-          -- without relying on the backend to consume the comments out of-          -- the state/map. So they will end up here, and we need to ignore-          -- them.-        , ExactPrint.unConName con /= "ImportDecl"-        , c <- extractAllComments elemAnns-        ]-  remainingComments-    `forM_` (fst .> show .> ErrorUnusedComment .> (: []) .> mTell)--  return $ ()
− source/library/Language/Haskell/Brittany/Internal/Backend.hs 
@@ -1,707 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Language.Haskell.Brittany.Internal.Backend where--import qualified Control.Monad.Trans.State.Strict as StateS-import qualified Data.Either as Either-import qualified Data.Foldable as Foldable-import qualified Data.IntMap.Lazy as IntMapL-import qualified Data.IntMap.Strict as IntMapS-import qualified Data.Map as Map-import qualified Data.Maybe as Maybe-import qualified Data.Semigroup as Semigroup-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import qualified Data.Text as Text-import qualified Data.Text.Lazy.Builder as Text.Builder-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.Types as ExactPrint.Types----type ColIndex  = Int--data ColumnSpacing-  = ColumnSpacingLeaf Int-  | ColumnSpacingRef Int Int--type ColumnBlock  a = [a]-type ColumnBlocks a = Seq [a]-type ColMap1 = IntMapL.IntMap {- ColIndex -} (Bool, ColumnBlocks ColumnSpacing)-type ColMap2 = IntMapL.IntMap {- ColIndex -} (Float, ColumnBlock Int, ColumnBlocks Int)-                                          -- (ratio of hasSpace, maximum, raw)--data ColInfo-  = ColInfoStart -- start value to begin the mapAccumL.-  | ColInfoNo BriDoc-  | ColInfo ColIndex ColSig [(Int, ColInfo)]--instance Show ColInfo where-  show ColInfoStart = "ColInfoStart"-  show (ColInfoNo bd) = "ColInfoNo " ++ show (take 30 (show (briDocToDoc bd)) ++ "..")-  show (ColInfo ind sig list) = "ColInfo " ++ show ind ++ " " ++ show sig ++ " " ++ show list--data ColBuildState = ColBuildState-  { _cbs_map :: ColMap1-  , _cbs_index :: ColIndex-  }--type LayoutConstraints m = ( MonadMultiReader Config m-                           , MonadMultiReader ExactPrint.Types.Anns m-                           , MonadMultiWriter Text.Builder.Builder m-                           , MonadMultiWriter (Seq String) m-                           , MonadMultiState LayoutState m-                           )--layoutBriDocM :: forall m . LayoutConstraints m => BriDoc -> m ()-layoutBriDocM = \case-  BDEmpty -> do-    return () -- can it be that simple-  BDLit t -> do-    layoutIndentRestorePostComment-    layoutRemoveIndentLevelLinger-    layoutWriteAppend t-  BDSeq list -> do-    list `forM_` layoutBriDocM-  -- in this situation, there is nothing to do about cols.-  -- i think this one does not happen anymore with the current simplifications.-  -- BDCols cSig list | BDPar sameLine lines <- List.last list ->-  --   alignColsPar $ BDCols cSig (List.init list ++ [sameLine]) : lines-  BDCols _ list -> do-    list `forM_` layoutBriDocM-  BDSeparator -> do-    layoutAddSepSpace-  BDAddBaseY indent bd -> do-    let indentF = case indent of-          BrIndentNone      -> id-          BrIndentRegular   -> layoutWithAddBaseCol-          BrIndentSpecial i -> layoutWithAddBaseColN i-    indentF $ layoutBriDocM bd-  BDBaseYPushCur bd -> do-    layoutBaseYPushCur-    layoutBriDocM bd-  BDBaseYPop bd -> do-    layoutBriDocM bd-    layoutBaseYPop-  BDIndentLevelPushCur bd -> do-    layoutIndentLevelPushCur-    layoutBriDocM bd-  BDIndentLevelPop bd -> do-    layoutBriDocM bd-    layoutIndentLevelPop-  BDEnsureIndent indent bd -> do-    let indentF = case indent of-          BrIndentNone      -> id-          BrIndentRegular   -> layoutWithAddBaseCol-          BrIndentSpecial i -> layoutWithAddBaseColN i-    indentF $ do-      layoutWriteEnsureBlock-      layoutBriDocM bd-  BDPar indent sameLine indented -> do-    layoutBriDocM sameLine-    let indentF = case indent of-          BrIndentNone      -> id-          BrIndentRegular   -> layoutWithAddBaseCol-          BrIndentSpecial i -> layoutWithAddBaseColN i-    indentF $ do-      layoutWriteNewlineBlock-      layoutBriDocM indented-  BDLines           lines                      -> alignColsLines lines-  BDAlt             []                         -> error "empty BDAlt"-  BDAlt             (alt:_)                    -> layoutBriDocM alt-  BDForceMultiline  bd                         -> layoutBriDocM bd-  BDForceSingleline bd                         -> layoutBriDocM bd-  BDForwardLineMode bd                         -> layoutBriDocM bd-  BDExternal annKey subKeys shouldAddComment t -> do-    let tlines     = Text.lines $ t <> Text.pack "\n"-        tlineCount = length tlines-    anns :: ExactPrint.Anns <- mAsk-    when shouldAddComment $ do-      layoutWriteAppend-        $  Text.pack-        $  "{-"-        ++ show (annKey, Map.lookup annKey anns)-        ++ "-}"-    zip [1 ..] tlines `forM_` \(i, l) -> do-      layoutWriteAppend $ l-      unless (i == tlineCount) layoutWriteNewlineBlock-    do-      state <- mGet-      let filterF k _ = not $ k `Set.member` subKeys-      mSet $ state-        { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state-        }-  BDPlain t -> do-    layoutWriteAppend t-  BDAnnotationPrior annKey bd -> do-    state <- mGet-    let m = _lstate_comments state-    let moveToExactLocationAction = case _lstate_curYOrAddNewline state of-          Left{} -> pure ()-          Right{} -> moveToExactAnn annKey-    mAnn <- do-      let mAnn = ExactPrint.annPriorComments <$> Map.lookup annKey m-      mSet $ state-        { _lstate_comments = Map.adjust-          (\ann -> ann { ExactPrint.annPriorComments = [] })-          annKey-          m-        }-      return mAnn-    case mAnn of-      Nothing     -> moveToExactLocationAction-      Just []     -> moveToExactLocationAction-      Just priors -> do-        -- layoutResetSepSpace-        priors-          `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->-                    when (comment /= "(" && comment /= ")") $ do-                      let commentLines = Text.lines $ Text.pack $ comment-                      case comment of-                        ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)-                                   --  ^ evil hack for CPP-                        _       -> layoutMoveToCommentPos y x (length commentLines)-                      -- fixedX <- fixMoveToLineByIsNewline x-                      -- replicateM_ fixedX layoutWriteNewline-                      -- layoutMoveToIndentCol y-                      layoutWriteAppendMultiline commentLines-          -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }-        moveToExactLocationAction-    layoutBriDocM bd-  BDAnnotationKW annKey keyword bd -> do-    layoutBriDocM bd-    mComments <- do-      state <- mGet-      let m    = _lstate_comments state-      let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m-      let mToSpan = case mAnn of-            Just anns | Maybe.isNothing keyword -> Just anns-            Just ((ExactPrint.Types.G kw1, _):annR) | keyword == Just kw1 -> Just-              annR-            _ -> Nothing-      case mToSpan of-        Just anns -> do-          let (comments, rest) = flip spanMaybe anns $ \case-                (ExactPrint.Types.AnnComment x, dp) -> Just (x, dp)-                _ -> Nothing-          mSet $ state-            { _lstate_comments = Map.adjust-              (\ann -> ann { ExactPrint.annsDP = rest })-              annKey-              m-            }-          return $ nonEmpty comments-        _ -> return Nothing-    case mComments of-      Nothing -> pure ()-      Just comments -> do-        comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->-          when (comment /= "(" && comment /= ")") $ do-            let commentLines = Text.lines $ Text.pack $ comment-            -- evil hack for CPP:-            case comment of-              ('#':_) -> layoutMoveToCommentPos y (-999) (length commentLines)-              _       -> layoutMoveToCommentPos y x (length commentLines)-            -- fixedX <- fixMoveToLineByIsNewline x-            -- replicateM_ fixedX layoutWriteNewline-            -- layoutMoveToIndentCol y-            layoutWriteAppendMultiline commentLines-      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }-  BDAnnotationRest annKey bd -> do-    layoutBriDocM bd-    annMay <- do-      state <- mGet-      let m = _lstate_comments state-      pure $ Map.lookup annKey m-    let mComments = nonEmpty . extractAllComments =<< annMay-    let semiCount = length [ ()-                | Just ann <- [ annMay ]-                , (ExactPrint.Types.AnnSemiSep, _) <- ExactPrint.Types.annsDP ann-                ]-    shouldAddSemicolonNewlines <- mAsk <&>-      _conf_layout .> _lconfig_experimentalSemicolonNewlines .> confUnpack-    mModify $ \state -> state-      { _lstate_comments = Map.adjust-        ( \ann -> ann { ExactPrint.annFollowingComments = []-                      , ExactPrint.annPriorComments     = []-                      , ExactPrint.annsDP               =-                        flip filter (ExactPrint.annsDP ann) $ \case-                          (ExactPrint.Types.AnnComment{}, _) -> False-                          _                                  -> True-                      }-        )-        annKey-        (_lstate_comments state)-      }-    case mComments of-      Nothing -> do-        when shouldAddSemicolonNewlines $ do-          [1..semiCount] `forM_` const layoutWriteNewline-      Just comments -> do-        comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) ->-          when (comment /= "(" && comment /= ")") $ do-            let commentLines = Text.lines $ Text.pack comment-            case comment of-              ('#':_) -> layoutMoveToCommentPos y (-999) 1-                         --  ^ evil hack for CPP-              ")"     -> pure ()-                         --  ^ fixes the formatting of parens-                         --    on the lhs of type alias defs-              _       -> layoutMoveToCommentPos y x (length commentLines)-            -- fixedX <- fixMoveToLineByIsNewline x-            -- replicateM_ fixedX layoutWriteNewline-            -- layoutMoveToIndentCol y-            layoutWriteAppendMultiline commentLines-      -- mModify $ \s -> s { _lstate_curYOrAddNewline = Right 0 }-  BDMoveToKWDP annKey keyword shouldRestoreIndent bd -> do-    mDP <- do-      state <- mGet-      let m    = _lstate_comments state-      let mAnn = ExactPrint.annsDP <$> Map.lookup annKey m-      let relevant = [ dp-                     | Just ann <- [mAnn]-                     , (ExactPrint.Types.G kw1, dp) <- ann-                     , keyword == kw1-                     ]-      -- mTell $ Seq.fromList [show keyword, "KWDP: " ++ show annKey ++ " " ++ show mAnn, show relevant]-      case relevant of-        [] -> pure Nothing-        (ExactPrint.Types.DP (y, x):_) -> do-          mSet state { _lstate_commentNewlines = 0 }-          pure $ Just (y - _lstate_commentNewlines state, x)-    case mDP of-      Nothing -> pure ()-      Just (y, x) ->-        -- we abuse this, as we probably will print the KW next, which is-        -- _not_ a comment..-        layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) 1-    layoutBriDocM bd-  BDNonBottomSpacing _ bd -> layoutBriDocM bd-  BDSetParSpacing    bd -> layoutBriDocM bd-  BDForceParSpacing  bd -> layoutBriDocM bd-  BDDebug s bd -> do-    mTell $ Text.Builder.fromText $ Text.pack $ "{-" ++ s ++ "-}"-    layoutBriDocM bd--briDocLineLength :: BriDoc -> Int-briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc-                          -- the state encodes whether a separator was already-                          -- appended at the current position.- where-  rec = \case-    BDEmpty                 -> return $ 0-    BDLit t                 -> StateS.put False $> Text.length t-    BDSeq bds               -> sum <$> rec `mapM` bds-    BDCols _ bds            -> sum <$> rec `mapM` bds-    BDSeparator -> StateS.get >>= \b -> StateS.put True $> if b then 0 else 1-    BDAddBaseY _ bd         -> rec bd-    BDBaseYPushCur       bd -> rec bd-    BDBaseYPop           bd -> rec bd-    BDIndentLevelPushCur bd -> rec bd-    BDIndentLevelPop     bd -> rec bd-    BDPar _ line _          -> rec line-    BDAlt{}                 -> error "briDocLineLength BDAlt"-    BDForceMultiline  bd    -> rec bd-    BDForceSingleline bd    -> rec bd-    BDForwardLineMode bd    -> rec bd-    BDExternal _ _ _ t      -> return $ Text.length t-    BDPlain t               -> return $ Text.length t-    BDAnnotationPrior _ bd  -> rec bd-    BDAnnotationKW _ _ bd   -> rec bd-    BDAnnotationRest _ bd   -> rec bd-    BDMoveToKWDP _ _ _ bd   -> rec bd-    BDLines ls@(_ : _)      -> do-      x <- StateS.get-      return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x-    BDLines []              -> error "briDocLineLength BDLines []"-    BDEnsureIndent _ bd     -> rec bd-    BDSetParSpacing   bd    -> rec bd-    BDForceParSpacing bd    -> rec bd-    BDNonBottomSpacing _ bd -> rec bd-    BDDebug            _ bd -> rec bd--briDocIsMultiLine :: BriDoc -> Bool-briDocIsMultiLine briDoc = rec briDoc- where-  rec :: BriDoc -> Bool-  rec = \case-    BDEmpty                                  -> False-    BDLit _                                  -> False-    BDSeq bds                                -> any rec bds-    BDCols _ bds                             -> any rec bds-    BDSeparator                              -> False-    BDAddBaseY _ bd                          -> rec bd-    BDBaseYPushCur       bd                  -> rec bd-    BDBaseYPop           bd                  -> rec bd-    BDIndentLevelPushCur bd                  -> rec bd-    BDIndentLevelPop     bd                  -> rec bd-    BDPar{}                                  -> True-    BDAlt{}                                  -> error "briDocIsMultiLine BDAlt"-    BDForceMultiline  _                      -> True-    BDForceSingleline bd                     -> rec bd-    BDForwardLineMode bd                     -> rec bd-    BDExternal _ _ _ t | [_] <- Text.lines t -> False-    BDExternal{}                             -> True-    BDPlain t | [_] <- Text.lines t          -> False-    BDPlain _                                -> True-    BDAnnotationPrior _ bd                   -> rec bd-    BDAnnotationKW _ _ bd                    -> rec bd-    BDAnnotationRest _ bd                    -> rec bd-    BDMoveToKWDP _ _ _ bd                    -> rec bd-    BDLines (_ : _ : _)                      -> True-    BDLines [_        ]                      -> False-    BDLines [] -> error "briDocIsMultiLine BDLines []"-    BDEnsureIndent _ bd                      -> rec bd-    BDSetParSpacing   bd                     -> rec bd-    BDForceParSpacing bd                     -> rec bd-    BDNonBottomSpacing _ bd                  -> rec bd-    BDDebug            _ bd                  -> rec bd---- In theory--- =========---- .. this algorithm works roughly in these steps:------ 1. For each line, get the (nested) column info, descending as far as---    BDCols nodes go. The column info is a (rose) tree where the leafs---    are arbitrary (non-BDCols) BriDocs.--- 2. Walk through the lines and compare its column info with that of its---    predecessor. If both are non-leafs and the column "signatures" align---    (they don't align e.g. when they are totally different syntactical---    structures or the number of children differs), mark these parts of---    the two tree structures as connected and recurse to its children---    (i.e. again comparing the children in this line with the children in---    the previous line).--- 3. What we now have is one tree per line, and connections between "same"---    nodes between lines. These connection can span multiple lines.---    We next look at spacing information. This is available at the leafs,---    but in this step we aggregate _over connections_. At the top level, this---    gives us one piece of data: How long would each line be, if we fully---    aligned everything (kept all connections "active"). In contrast to---    just taking the sum of all leafs for each tree, this line length includes---    the spaces used for alignment.--- 4. Treat those lines where alignment would result in overflowing of the---    column limit. This "treatment" is currently configurable, and can e.g.---    mean:---    a) we stop alignment alltogether,---    b) we remove alignment just from the overflowing lines,---    c) we reduce the number of spaces inserted in overflowing lines using---       some technique to make them not overflow, but without reducing the---       space insertion to zero,---    d) don't do anything--- 5. Actually print the lines, walking over each tree and inserting spaces---    according to the info and decisions gathered in the previous steps.------ Possible improvements--- =====================------ - If alignment is disabled for specific lines, the aggregated per-connection---   info of those lines is still retained and not recalculated. This can---   result in spaces being inserted to create alignment with a line that---   would overflow and thus gets disabled entirely.---   An better approach would be to repeat step 3 after marking overflowing---   lines as such, and not include the overflowing spacings as references---   for non-overflowing ones. In the simplest case one additional iteration---   would suffice, e.g. 1-2-3-4-3-5, but it would also be possible to refine---   this and first remove alignment in the deepest parts of the tree for---   overflowing lines, repeating and moving upwards until no lines are---   anymore overflowing.---   Further, it may make sense to break up connections when overflowing would---   occur.--- - It may also make sense to not filter all overflowing lines, but remove---   them one-by-one and in each step recalculate the aggregated connection---   spacing info. Because removing one overflowing line from the calculation---   may very well cause another previously overflowing line to not overflow---   any longer.---   There is also a nasty optimization problem hiding in there (find the---   minimal amount of alignment disabling that results in no overflows)---   but that is overkill.------   (with both these improvements there would be quite some repetition between---   steps 3 and 4, but it should be possible to ensure termination. Still,---   performance might become an issue as such an approach is not necessarily---   linear in bridoc size any more.)------ In practice--- ===========------ .. the current implementation is somewhat sloppy. Steps 1 and 2--- are executed in one step, step 3 already applies one strategy that disables--- certain connections (see `_lconfig_alignmentLimit`) and step 4 does some--- of the calculations one might expect to occur in step 3. Steps 4 and 5--- are executed in the same recursion, too.--- Also, _lconfig_alignmentLimit really is itself a hack that hides the issue--- mentioned in the first "possible improvement".-alignColsLines :: LayoutConstraints m => [BriDoc] -> m ()-alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do-  -- tellDebugMess ("alignColsLines: at " ++ take 100 (show $ briDocToDoc $ head bridocs))-  curX <- do-    state <- mGet-    return $ Either.fromLeft 0 (_lstate_curYOrAddNewline state) + fromMaybe-      0-      (_lstate_addSepSpace state)-  colMax     <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack-  alignMax   <- mAsk <&> _conf_layout .> _lconfig_alignmentLimit .> confUnpack-  alignBreak <--    mAsk <&> _conf_layout .> _lconfig_alignmentBreakOnMultiline .> confUnpack-  case () of-    _ -> do-      -- tellDebugMess ("processedMap: " ++ show processedMap)-      sequence_-        $   List.intersperse layoutWriteEnsureNewlineBlock-        $   colInfos-        <&> processInfo colMax processedMap-     where-      (colInfos, finalState) =-        StateS.runState (mergeBriDocs bridocs) (ColBuildState IntMapS.empty 0)-      -- maxZipper :: [Int] -> [Int] -> [Int]-      -- maxZipper [] ys = ys-      -- maxZipper xs [] = xs-      -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr-      colAggregation :: [Int] -> Int-      colAggregation [] = 0 -- this probably cannot happen the way we call-                            -- this function, because _cbs_map only ever-                            -- contains nonempty Seqs.-      colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ]-        where alignMax' = max 0 alignMax--      processedMap :: ColMap2-      processedMap =-        fix $ \result -> _cbs_map finalState <&> \(lastFlag, colSpacingss) ->-          let-            colss = colSpacingss <&> \spss -> case reverse spss of-              [] -> []-              (xN:xR) ->-                reverse $ (if lastFlag then fLast else fInit) xN : fmap fInit xR-             where-              fLast (ColumnSpacingLeaf len ) = len-              fLast (ColumnSpacingRef len _) = len-              fInit (ColumnSpacingLeaf len) = len-              fInit (ColumnSpacingRef _ i ) = case IntMapL.lookup i result of-                Nothing           -> 0-                Just (_, maxs, _) -> sum maxs-            maxCols = {-Foldable.foldl1 maxZipper-}-              fmap colAggregation $ transpose $ Foldable.toList colss-            (_, posXs) = -- trace ("colss=" ++ show colss ++ ", maxCols=" ++ show maxCols ++ " for " ++ take 100 (show $ briDocToDoc $ head bridocs)) $-                         mapAccumL (\acc x -> (acc + x, acc)) curX maxCols-            counter count l = if List.last posXs + List.last l <= colMax-              then count + 1-              else count-            ratio = fromIntegral (foldl counter (0 :: Int) colss)-              / fromIntegral (length colss)-          in-            (ratio, maxCols, colss)--      mergeBriDocs :: [BriDoc] -> StateS.State ColBuildState [ColInfo]-      mergeBriDocs bds = mergeBriDocsW ColInfoStart bds--      mergeBriDocsW-        :: ColInfo -> [BriDoc] -> StateS.State ColBuildState [ColInfo]-      mergeBriDocsW _        []       = return []-      mergeBriDocsW lastInfo (bd:bdr) = do-        info  <- mergeInfoBriDoc True lastInfo bd-        infor <- mergeBriDocsW-          -- (if alignBreak && briDocIsMultiLine bd then ColInfoStart else info)-          (if shouldBreakAfter bd then ColInfoStart else info)-          bdr-        return $ info : infor--      -- even with alignBreak config flag, we don't stop aligning for certain-      -- ColSigs - the ones with "False" below. The main reason is that-      -- there are uses of BDCols where they provide the alignment of several-      -- consecutive full larger code segments, for example ColOpPrefix.-      -- Motivating example is-      -- > foo-      -- >   $  [ aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-      -- >      , bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-      -- >      ]-      -- >   ++ [ ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ]-      -- If we break the alignment here, then all three lines for the first-      -- list move left by one, which is horrible. We really don't want to-      -- break whole-block alignments.-      -- For list, listcomp, tuple and tuples the reasoning is much simpler:-      -- alignment should not have much effect anyways, so i simply make the-      -- choice here that enabling alignment is the safer route for preventing-      -- potential glitches, and it should never have a negative effect.-      -- For RecUpdate the argument is much less clear - it is mostly a-      -- personal preference to not break alignment for those, even if-      -- multiline. Really, this should be configurable.. (TODO)-      shouldBreakAfter :: BriDoc -> Bool-      shouldBreakAfter bd = alignBreak &&-        briDocIsMultiLine bd && case bd of-          (BDCols ColTyOpPrefix         _) -> False-          (BDCols ColPatternsFuncPrefix _) -> True-          (BDCols ColPatternsFuncInfix  _) -> True-          (BDCols ColPatterns           _) -> True-          (BDCols ColCasePattern        _) -> True-          (BDCols ColBindingLine{}      _) -> True-          (BDCols ColGuard              _) -> True-          (BDCols ColGuardedBody        _) -> True-          (BDCols ColBindStmt           _) -> True-          (BDCols ColDoLet              _) -> True-          (BDCols ColRec                _) -> False-          (BDCols ColRecUpdate          _) -> False-          (BDCols ColRecDecl            _) -> False-          (BDCols ColListComp           _) -> False-          (BDCols ColList               _) -> False-          (BDCols ColApp{}              _) -> True-          (BDCols ColTuple              _) -> False-          (BDCols ColTuples             _) -> False-          (BDCols ColOpPrefix           _) -> False-          _                                -> True--      mergeInfoBriDoc-        :: Bool-        -> ColInfo-        -> BriDoc-        -> StateS.StateT ColBuildState Identity ColInfo-      mergeInfoBriDoc lastFlag ColInfoStart = briDocToColInfo lastFlag-      mergeInfoBriDoc lastFlag ColInfoNo{}  = briDocToColInfo lastFlag-      mergeInfoBriDoc lastFlag (ColInfo infoInd infoSig subLengthsInfos) =-        \case-          brdc@(BDCols colSig subDocs)-            | infoSig == colSig && length subLengthsInfos == length subDocs-            -> do-              let-                isLastList = if lastFlag-                  then (==length subDocs) <$> [1 ..]-                  else repeat False-              infos <- zip3 isLastList (snd <$> subLengthsInfos) subDocs-                `forM` \(lf, info, bd) -> mergeInfoBriDoc lf info bd-              let curLengths   = briDocLineLength <$> subDocs-              let trueSpacings = getTrueSpacings (zip curLengths infos)-              do -- update map-                s <- StateS.get-                let m                  = _cbs_map s-                let (Just (_, spaces)) = IntMapS.lookup infoInd m-                StateS.put s-                  { _cbs_map = IntMapS.insert-                    infoInd-                    (lastFlag, spaces Seq.|> trueSpacings)-                    m-                  }-              return $ ColInfo infoInd colSig (zip curLengths infos)-            | otherwise-            -> briDocToColInfo lastFlag brdc-          brdc -> return $ ColInfoNo brdc--briDocToColInfo :: Bool -> BriDoc -> StateS.State ColBuildState ColInfo-briDocToColInfo lastFlag = \case-  BDCols sig list -> withAlloc lastFlag $ \ind -> do-    let isLastList =-          if lastFlag then (==length list) <$> [1 ..] else repeat False-    subInfos <- zip isLastList list `forM` uncurry briDocToColInfo-    let lengthInfos  = zip (briDocLineLength <$> list) subInfos-    let trueSpacings = getTrueSpacings lengthInfos-    return $ (Seq.singleton trueSpacings, ColInfo ind sig lengthInfos)-  bd -> return $ ColInfoNo bd--getTrueSpacings :: [(Int, ColInfo)] -> [ColumnSpacing]-getTrueSpacings lengthInfos = lengthInfos <&> \case-  (len, ColInfo i _ _) -> ColumnSpacingRef len i-  (len, _            ) -> ColumnSpacingLeaf len--withAlloc-  :: Bool-  -> (  ColIndex-     -> StateS.State ColBuildState (ColumnBlocks ColumnSpacing, ColInfo)-     )-  -> StateS.State ColBuildState ColInfo-withAlloc lastFlag f = do-  cbs <- StateS.get-  let ind = _cbs_index cbs-  StateS.put $ cbs { _cbs_index = ind + 1 }-  (space, info) <- f ind-  StateS.get >>= \c -> StateS.put-    $ c { _cbs_map = IntMapS.insert ind (lastFlag, space) $ _cbs_map c }-  return info--processInfo :: LayoutConstraints m => Int -> ColMap2 -> ColInfo -> m ()-processInfo maxSpace m = \case-  ColInfoStart       -> error "should not happen (TM)"-  ColInfoNo doc      -> layoutBriDocM doc-  ColInfo ind _ list -> -- trace ("processInfo ind=" ++ show ind ++ ", list=" ++ show list ++ ", colmap=" ++ show m) $-                        do-    colMaxConf <- mAsk <&> _conf_layout .> _lconfig_cols .> confUnpack-    alignMode <- mAsk <&> _conf_layout .> _lconfig_columnAlignMode .> confUnpack-    curX      <- do-      state <- mGet-      -- tellDebugMess ("processInfo: " ++ show (_lstate_curYOrAddNewline state) ++ " - " ++ show ((_lstate_addSepSpace state)))-      let spaceAdd = fromMaybe 0 $ _lstate_addSepSpace state-      return $ case _lstate_curYOrAddNewline state of-        Left i -> case _lstate_commentCol state of-          Nothing -> spaceAdd + i-          Just c -> c-        Right{} -> spaceAdd-    let colMax = min colMaxConf (curX + maxSpace)-    -- tellDebugMess $ show curX-    let Just (ratio, maxCols1, _colss) = IntMapS.lookup ind m-    let maxCols2 = list <&> \case-          (_, ColInfo i _ _) ->-            let Just (_, ms, _) = IntMapS.lookup i m in sum ms-          (l, _) -> l-    let maxCols = zipWith max maxCols1 maxCols2-    let (maxX, posXs) = mapAccumL (\acc x -> (acc + x, acc)) curX maxCols-    -- handle the cases that the vertical alignment leads to more than max-    -- cols:-    -- this is not a full fix, and we must correct individually in addition.-    -- because: the (at least) line with the largest element in the last-    -- column will always still overflow, because we just updated the column-    -- 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-    -- forced to occupy the full vertical space, not reduced by any factor.-    let fixedPosXs = case alignMode of-          ColumnAlignModeAnimouslyScale i | maxX > colMax -> fixed <&> (+curX)-           where-            factor :: Float =-              -- 0.0001 as an offering to the floating point gods.-                              min-              1.0001-              (fromIntegral (i + colMax - curX) / fromIntegral (maxX - curX))-            offsets = (subtract curX) <$> posXs-            fixed   = offsets <&> fromIntegral .> (*factor) .> truncate-          _ -> posXs-    let spacings = zipWith (-)-                           (List.tail fixedPosXs ++ [min maxX colMax])-                           fixedPosXs-    -- tellDebugMess $ "ind = " ++ show ind-    -- tellDebugMess $ "maxCols = " ++ show maxCols-    -- tellDebugMess $ "fixedPosXs = " ++ show fixedPosXs-    -- tellDebugMess $ "list = " ++ show list-    -- tellDebugMess $ "maxSpace = " ++ show maxSpace-    let alignAct = zip3 fixedPosXs spacings list `forM_` \(destX, s, x) -> do-          layoutWriteEnsureAbsoluteN destX-          processInfo s m (snd x)-        noAlignAct = list `forM_` (snd .> processInfoIgnore)-        animousAct = -- trace ("animousAct fixedPosXs=" ++ show fixedPosXs ++ ", list=" ++ show list ++ ", maxSpace=" ++ show maxSpace ++ ", colMax="++show colMax) $-                     if List.last fixedPosXs + fst (List.last list) > colMax-                     -- per-item check if there is overflowing.-          then noAlignAct-          else alignAct-    case alignMode of-      ColumnAlignModeDisabled                        -> noAlignAct-      ColumnAlignModeUnanimously | maxX <= colMax    -> alignAct-      ColumnAlignModeUnanimously                     -> noAlignAct-      ColumnAlignModeMajority limit | ratio >= limit -> animousAct-      ColumnAlignModeMajority{}                      -> noAlignAct-      ColumnAlignModeAnimouslyScale{}                -> animousAct-      ColumnAlignModeAnimously                       -> animousAct-      ColumnAlignModeAlways                          -> alignAct--processInfoIgnore :: LayoutConstraints m => ColInfo -> m ()-processInfoIgnore = \case-  ColInfoStart     -> error "should not happen (TM)"-  ColInfoNo doc    -> layoutBriDocM doc-  ColInfo _ _ list -> list `forM_` (snd .> processInfoIgnore)
− source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs 
@@ -1,522 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.BackendUtils where--import qualified Data.Data-import qualified Data.Either-import qualified Data.Map as Map-import qualified Data.Maybe-import qualified Data.Semigroup as Semigroup-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 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 ()-traceLocal _ = return ()---layoutWriteAppend-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => Text-  -> m ()-layoutWriteAppend t = do-  traceLocal ("layoutWriteAppend", t)-  state <- mGet-  case _lstate_curYOrAddNewline state of-    Right i -> do-      replicateM_ i $ mTell $ Text.Builder.fromString $ "\n"-    Left{} -> do-      return ()-  let spaces = fromMaybe 0 $ _lstate_addSepSpace state-  mTell $ Text.Builder.fromText $ Text.pack (replicate spaces ' ')-  mTell $ Text.Builder.fromText $ t-  mModify $ \s -> s-    { _lstate_curYOrAddNewline = Left $ case _lstate_curYOrAddNewline s of-        Left c -> c + Text.length t + spaces-        Right{} -> Text.length t + spaces-    , _lstate_addSepSpace = Nothing-    }--layoutWriteAppendSpaces-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => Int-  -> m ()-layoutWriteAppendSpaces i = do-  traceLocal ("layoutWriteAppendSpaces", i)-  unless (i == 0) $ do-    state <- mGet-    mSet $ state-      { _lstate_addSepSpace = Just $ maybe i (+i) $ _lstate_addSepSpace state-      }--layoutWriteAppendMultiline-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => [Text]-  -> m ()-layoutWriteAppendMultiline ts = do-  traceLocal ("layoutWriteAppendMultiline", ts)-  case ts of-    []     -> layoutWriteAppend (Text.pack "") -- need to write empty, too.-    (l:lr) -> do-      layoutWriteAppend l-      lr `forM_` \x -> do-        layoutWriteNewline-        layoutWriteAppend x---- adds a newline and adds spaces to reach the base column.-layoutWriteNewlineBlock-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => m ()-layoutWriteNewlineBlock = do-  traceLocal ("layoutWriteNewlineBlock")-  state <- mGet-  mSet $ state { _lstate_curYOrAddNewline = Right 1-               , _lstate_addSepSpace      = Just $ lstate_baseY state-               }---- layoutMoveToIndentCol :: ( MonadMultiState LayoutState m---                     , MonadMultiWriter (Seq String) m) => Int -> m ()--- layoutMoveToIndentCol i = do--- #if INSERTTRACES---   tellDebugMessShow ("layoutMoveToIndentCol", i)--- #endif---   state <- mGet---   mSet $ state---     { _lstate_addSepSpace = Just---                           $ if isJust $ _lstate_addNewline state---         then i---         else _lstate_indLevelLinger state + i - _lstate_curY state---     }--layoutSetCommentCol-  :: (MonadMultiState LayoutState m) => m ()-layoutSetCommentCol = do-  state <- mGet-  let col = case _lstate_curYOrAddNewline state of-        Left i  -> i + fromMaybe 0 (_lstate_addSepSpace state)-        Right{} -> lstate_baseY state-  traceLocal ("layoutSetCommentCol", col)-  unless (Data.Maybe.isJust $ _lstate_commentCol state)-    $ mSet state { _lstate_commentCol = Just col }---- This is also used to move to non-comments in a couple of places. Seems--- to be harmless so far..-layoutMoveToCommentPos-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => Int-  -> Int-  -> Int-  -> m ()-layoutMoveToCommentPos y x commentLines = do-  traceLocal ("layoutMoveToCommentPos", y, x, commentLines)-  state <- mGet-  mSet state-    { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of-      Left i  -> if y == 0 then Left i else Right y-      Right{} -> Right y-    , _lstate_addSepSpace      =-      Just $ if Data.Maybe.isJust (_lstate_commentCol state)-        then case _lstate_curYOrAddNewline state of-          Left{}  -> if y == 0 then x else _lstate_indLevelLinger state + x-          Right{} -> _lstate_indLevelLinger state + x-        else if y == 0 then x else _lstate_indLevelLinger state + x-    , _lstate_commentCol       =-      Just $ case _lstate_commentCol state of-        Just existing -> existing-        Nothing -> case _lstate_curYOrAddNewline state of-          Left i  -> i + fromMaybe 0 (_lstate_addSepSpace state)-          Right{} -> lstate_baseY state-    , _lstate_commentNewlines =-        _lstate_commentNewlines state + y + commentLines - 1-    }---- | does _not_ add spaces to again reach the current base column.-layoutWriteNewline-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => m ()-layoutWriteNewline = do-  traceLocal ("layoutWriteNewline")-  state <- mGet-  mSet $ state-    { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of-      Left{}  -> Right 1-      Right i -> Right (i + 1)-    , _lstate_addSepSpace      = Nothing-    }--_layoutResetCommentNewlines :: MonadMultiState LayoutState m => m ()-_layoutResetCommentNewlines = do-  mModify $ \state -> state { _lstate_commentNewlines = 0 }--layoutWriteEnsureNewlineBlock-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => m ()-layoutWriteEnsureNewlineBlock = do-  traceLocal ("layoutWriteEnsureNewlineBlock")-  state <- mGet-  mSet $ state-    { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of-      Left{}  -> Right 1-      Right i -> Right $ max 1 i-    , _lstate_addSepSpace      = Just $ lstate_baseY state-    , _lstate_commentCol       = Nothing-    }--layoutWriteEnsureAbsoluteN-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => Int-  -> m ()-layoutWriteEnsureAbsoluteN n = do-  state <- mGet-  let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of-        (Just c , _      ) -> n - c-        (Nothing, Left i ) -> n - i-        (Nothing, Right{}) -> n-  traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)-  when (diff > 0) $ do-    mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to-                                            -- at least (Just 1), so we won't-                                            -- overwrite any old value in any-                                            -- bad way.-                 }--layoutBaseYPushInternal-  :: (MonadMultiState LayoutState m)-  => Int-  -> m ()-layoutBaseYPushInternal i = do-  traceLocal ("layoutBaseYPushInternal", i)-  mModify $ \s -> s { _lstate_baseYs = i : _lstate_baseYs s }--layoutBaseYPopInternal-  :: (MonadMultiState LayoutState m) => m ()-layoutBaseYPopInternal = do-  traceLocal ("layoutBaseYPopInternal")-  mModify $ \s -> s { _lstate_baseYs = List.tail $ _lstate_baseYs s }--layoutIndentLevelPushInternal-  :: (MonadMultiState LayoutState m)-  => Int-  -> m ()-layoutIndentLevelPushInternal i = do-  traceLocal ("layoutIndentLevelPushInternal", i)-  mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s-                    , _lstate_indLevels      = i : _lstate_indLevels s-                    }--layoutIndentLevelPopInternal-  :: (MonadMultiState LayoutState m) => m ()-layoutIndentLevelPopInternal = do-  traceLocal ("layoutIndentLevelPopInternal")-  mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s-                    , _lstate_indLevels      = List.tail $ _lstate_indLevels s-                    }--layoutRemoveIndentLevelLinger :: ( MonadMultiState LayoutState m) => m ()-layoutRemoveIndentLevelLinger = do-  mModify $ \s -> s { _lstate_indLevelLinger = lstate_indLevel s-                    }--layoutWithAddBaseCol-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     , MonadMultiReader Config m-     )-  => m ()-  -> m ()-layoutWithAddBaseCol m = do-  amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack-  state <- mGet-  layoutBaseYPushInternal $ lstate_baseY state + amount-  m-  layoutBaseYPopInternal--layoutWithAddBaseColBlock-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     , MonadMultiReader Config m-     )-  => m ()-  -> m ()-layoutWithAddBaseColBlock m = do-  amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack-  state <- mGet-  layoutBaseYPushInternal $ lstate_baseY state + amount-  layoutWriteEnsureBlock-  m-  layoutBaseYPopInternal--layoutWithAddBaseColNBlock-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => Int-  -> m ()-  -> m ()-layoutWithAddBaseColNBlock amount m = do-  traceLocal ("layoutWithAddBaseColNBlock", amount)-  state <- mGet-  layoutBaseYPushInternal $ lstate_baseY state + amount-  layoutWriteEnsureBlock-  m-  layoutBaseYPopInternal--layoutWriteEnsureBlock-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => m ()-layoutWriteEnsureBlock = do-  traceLocal ("layoutWriteEnsureBlock")-  state <- mGet-  let-    diff = case (_lstate_addSepSpace state, _lstate_curYOrAddNewline state) of-      (Nothing, Left i ) -> lstate_baseY state - i-      (Nothing, Right{}) -> lstate_baseY state-      (Just sp, Left i ) -> max sp (lstate_baseY state - i)-      (Just sp, Right{}) -> max sp (lstate_baseY state)-  -- when (diff>0) $ layoutWriteNewlineBlock-  when (diff > 0) $ do-    mSet $ state { _lstate_addSepSpace = Just $ diff }--layoutWithAddBaseColN-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => Int-  -> m ()-  -> m ()-layoutWithAddBaseColN amount m = do-  state <- mGet-  layoutBaseYPushInternal $ lstate_baseY state + amount-  m-  layoutBaseYPopInternal--layoutBaseYPushCur-  :: (MonadMultiState LayoutState m) => m ()-layoutBaseYPushCur = do-  traceLocal ("layoutBaseYPushCur")-  state <- mGet-  case _lstate_commentCol state of-    Nothing ->-      case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of-        (Left i , Just j ) -> layoutBaseYPushInternal (i + j)-        (Left i , Nothing) -> layoutBaseYPushInternal i-        (Right{}, _      ) -> layoutBaseYPushInternal $ lstate_baseY state-    Just cCol -> layoutBaseYPushInternal cCol--layoutBaseYPop-  :: (MonadMultiState LayoutState m) => m ()-layoutBaseYPop = do-  traceLocal ("layoutBaseYPop")-  layoutBaseYPopInternal--layoutIndentLevelPushCur-  :: (MonadMultiState LayoutState m) => m ()-layoutIndentLevelPushCur = do-  traceLocal ("layoutIndentLevelPushCur")-  state <- mGet-  let y = case (_lstate_curYOrAddNewline state, _lstate_addSepSpace state) of-        (Left i , Just j ) -> i + j-        (Left i , Nothing) -> i-        (Right{}, Just j ) -> j-        (Right{}, Nothing) -> 0-  layoutIndentLevelPushInternal y--layoutIndentLevelPop-  :: (MonadMultiState LayoutState m) => m ()-layoutIndentLevelPop = do-  traceLocal ("layoutIndentLevelPop")-  layoutIndentLevelPopInternal-  -- why are comment indentations relative to the previous indentation on-  -- the first node of an additional indentation, and relative to the outer-  -- indentation after the last node of some indented stuff? sure does not-  -- make sense.-  layoutRemoveIndentLevelLinger--layoutAddSepSpace :: (MonadMultiState LayoutState m)-   => m ()-layoutAddSepSpace = do-  state <- mGet-  mSet $ state-    { _lstate_addSepSpace = Just $ fromMaybe 1 $ _lstate_addSepSpace state }---- TODO: when refactoring is complete, the other version of this method--- can probably be removed.-moveToExactAnn-  :: ( MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     , MonadMultiReader (Map AnnKey Annotation) m-     )-  => AnnKey-  -> m ()-moveToExactAnn annKey = do-  traceLocal ("moveToExactAnn", annKey)-  anns <- mAsk-  case Map.lookup annKey anns of-    Nothing  -> return ()-    Just ann -> do-      -- curY <- mGet <&> _lstate_curY-      let ExactPrint.DP (y, _x) = ExactPrint.annEntryDelta ann-      -- mModify $ \state -> state { _lstate_addNewline = Just x }-      moveToY y--moveToY :: MonadMultiState LayoutState m => Int -> m ()-moveToY y = mModify $ \state ->-  let upd = case _lstate_curYOrAddNewline state of-        Left  i -> if y == 0 then Left i else Right y-        Right i -> Right $ max y i-  in  state-        { _lstate_curYOrAddNewline = upd-        , _lstate_addSepSpace      = if Data.Either.isRight upd-                                       then-                                         _lstate_commentCol state-                                         <|> _lstate_addSepSpace state-                                         <|> Just (lstate_baseY state)-                                       else Nothing-        , _lstate_commentCol       = Nothing-        }--- fixMoveToLineByIsNewline :: MonadMultiState---                                                   LayoutState m => Int -> m Int--- fixMoveToLineByIsNewline x = do---   newLineState <- mGet <&> _lstate_isNewline---   return $ if newLineState == NewLineStateYes---     then x-1---     else x--ppmMoveToExactLoc-  :: MonadMultiWriter Text.Builder.Builder m-  => ExactPrint.DeltaPos-  -> m ()-ppmMoveToExactLoc (ExactPrint.DP (x, y)) = do-  replicateM_ x $ mTell $ Text.Builder.fromString "\n"-  replicateM_ y $ mTell $ Text.Builder.fromString " "---- TODO: update and use, or clean up. Currently dead code.-layoutWritePriorComments-  :: ( Data.Data.Data ast-     , MonadMultiWriter Text.Builder.Builder m-     , MonadMultiState LayoutState m-     )-  => Located ast-  -> m ()-layoutWritePriorComments ast = do-  mAnn <- do-    state <- mGet-    let key  = ExactPrint.mkAnnKey ast-    let anns = _lstate_comments state-    let mAnn = ExactPrint.annPriorComments <$> Map.lookup key anns-    mSet $ state-      { _lstate_comments =-          Map.adjust (\ann -> ann { ExactPrint.annPriorComments = [] }) key anns-      }-    return mAnn-  case mAnn of-    Nothing -> return ()-    Just priors -> do-      unless (null priors) $ layoutSetCommentCol-      priors `forM_` \( ExactPrint.Comment comment _ _-                      , ExactPrint.DP (x, y)-                      ) -> do-        replicateM_ x layoutWriteNewline-        layoutWriteAppendSpaces y-        layoutWriteAppendMultiline $ Text.lines $ Text.pack comment---- TODO: update and use, or clean up. Currently dead code.--- this currently only extracs from the `annsDP` field of Annotations.--- per documentation, this seems sufficient, as the--- "..`annFollowingComments` are only added by AST transformations ..".-layoutWritePostComments :: (Data.Data.Data ast,-                                               MonadMultiWriter Text.Builder.Builder m,-                                               MonadMultiState LayoutState m)-                         => Located ast -> m ()-layoutWritePostComments ast = do-  mAnn <- do-    state <- mGet-    let key  = ExactPrint.mkAnnKey ast-    let anns = _lstate_comments state-    let mAnn = ExactPrint.annFollowingComments <$> Map.lookup key anns-    mSet $ state-      { _lstate_comments =-          Map.adjust (\ann -> ann { ExactPrint.annFollowingComments = [] })-                     key-                     anns-      }-    return mAnn-  case mAnn of-    Nothing -> return ()-    Just posts -> do-      unless (null posts) $ layoutSetCommentCol-      posts `forM_` \( ExactPrint.Comment comment _ _-                      , ExactPrint.DP (x, y)-                      ) -> do-        replicateM_ x layoutWriteNewline-        layoutWriteAppend $ Text.pack $ replicate y ' '-        mModify $ \s -> s { _lstate_addSepSpace = Nothing }-        layoutWriteAppendMultiline $ Text.lines $ Text.pack $ comment--layoutIndentRestorePostComment-  :: ( MonadMultiState LayoutState m-     , MonadMultiWriter Text.Builder.Builder m-     )-  => m ()-layoutIndentRestorePostComment = do-  state <- mGet-  let mCommentCol = _lstate_commentCol state-  let eCurYAddNL  = _lstate_curYOrAddNewline state-  mModify $ \s -> s { _lstate_commentCol = Nothing-                    , _lstate_commentNewlines = 0-                    }-  case (mCommentCol, eCurYAddNL) of-    (Just commentCol, Left{}) -> do-      layoutWriteEnsureNewlineBlock-      layoutWriteEnsureAbsoluteN $ commentCol + fromMaybe 0 (_lstate_addSepSpace state)-    _                              -> return ()---- layoutWritePriorCommentsRestore :: (Data.Data.Data ast,---                                                MonadMultiWriter Text.Builder.Builder m,---                                                MonadMultiState LayoutState m---                                   , MonadMultiWriter (Seq String) m)---                                 => Located ast -> m ()--- layoutWritePriorCommentsRestore x = do---   layoutWritePriorComments x---   layoutIndentRestorePostComment------ layoutWritePostCommentsRestore :: (Data.Data.Data ast,---                                                MonadMultiWriter Text.Builder.Builder m,---                                                MonadMultiState LayoutState m---                                                , MonadMultiWriter (Seq String) m)---                                 => Located ast -> m ()--- layoutWritePostCommentsRestore x = do---   layoutWritePostComments x---   layoutIndentRestorePostComment
− source/library/Language/Haskell/Brittany/Internal/Config.hs 
@@ -1,286 +0,0 @@-{-# LANGUAGE MonadComprehensions #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Config where--import qualified Data.Bool as Bool-import qualified Data.ByteString as ByteString-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.Yaml-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 as Directory-import qualified System.FilePath.Posix as FilePath-import qualified System.IO-import UI.Butcher.Monadic---- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }-staticDefaultConfig :: Config-staticDefaultConfig = Config-  { _conf_version                   = coerce (1 :: Int)-  , _conf_debug                     = DebugConfig-    { _dconf_dump_config                = coerce False-    , _dconf_dump_annotations           = coerce False-    , _dconf_dump_ast_unknown           = coerce False-    , _dconf_dump_ast_full              = coerce False-    , _dconf_dump_bridoc_raw            = coerce False-    , _dconf_dump_bridoc_simpl_alt      = coerce False-    , _dconf_dump_bridoc_simpl_floating = coerce False-    , _dconf_dump_bridoc_simpl_par      = coerce False-    , _dconf_dump_bridoc_simpl_columns  = coerce False-    , _dconf_dump_bridoc_simpl_indent   = coerce False-    , _dconf_dump_bridoc_final          = coerce False-    , _dconf_roundtrip_exactprint_only  = coerce False-    }-  , _conf_layout                    = LayoutConfig-    { _lconfig_cols                          = coerce (80 :: Int)-    , _lconfig_indentPolicy                  = coerce IndentPolicyFree-    , _lconfig_indentAmount                  = coerce (2 :: Int)-    , _lconfig_indentWhereSpecial            = coerce True-    , _lconfig_indentListSpecial             = coerce True-    , _lconfig_importColumn                  = coerce (50 :: Int)-    , _lconfig_importAsColumn                = coerce (50 :: Int)-    , _lconfig_altChooser = coerce (AltChooserBoundedSearch 3)-    , _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)-    , _lconfig_alignmentLimit                = coerce (30 :: Int)-    , _lconfig_alignmentBreakOnMultiline     = coerce True-    , _lconfig_hangingTypeSignature          = coerce False-    , _lconfig_reformatModulePreamble        = coerce True-    , _lconfig_allowSingleLineExportList     = coerce False-    , _lconfig_allowHangingQuasiQuotes       = coerce True-    , _lconfig_experimentalSemicolonNewlines = coerce False-    -- , _lconfig_allowSinglelineRecord     = coerce False-    }-  , _conf_errorHandling             = ErrorHandlingConfig-    { _econf_produceOutputOnErrors   = coerce False-    , _econf_Werror                  = coerce False-    , _econf_ExactPrintFallback      = coerce ExactPrintFallbackModeInline-    , _econf_omit_output_valid_check = coerce False-    }-  , _conf_preprocessor              = PreProcessorConfig-    { _ppconf_CPPMode            = coerce CPPModeAbort-    , _ppconf_hackAroundIncludes = coerce False-    }-  , _conf_forward = ForwardOptions { _options_ghc = Identity [] }-  , _conf_roundtrip_exactprint_only = coerce False-  , _conf_disable_formatting        = coerce False-  , _conf_obfuscate                 = coerce False-  }--forwardOptionsSyntaxExtsEnabled :: ForwardOptions-forwardOptionsSyntaxExtsEnabled = ForwardOptions-  { _options_ghc = Identity-                     [ "-XLambdaCase"-                     , "-XMultiWayIf"-                     , "-XGADTs"-                     , "-XPatternGuards"-                     , "-XViewPatterns"-                     , "-XTupleSections"-                     , "-XExplicitForAll"-                     , "-XImplicitParams"-                     , "-XQuasiQuotes"-                     , "-XTemplateHaskell"-                     , "-XBangPatterns"-                     , "-XTypeApplications"-                     ]-  }---- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft, lconfig_cols: 200 }-cmdlineConfigParser :: CmdParser Identity out (CConfig Maybe)-cmdlineConfigParser = do-  -- TODO: why does the default not trigger; ind never should be []!!-  ind                <- addFlagReadParams "" ["indent"] "AMOUNT" (flagHelpStr "spaces per indentation level")-  cols               <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")-  importCol          <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at")-  importAsCol        <- addFlagReadParams "" ["import-as-col"] "N" (flagHelpStr "column to qualified-as module names at")--  dumpConfig         <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)")-  dumpAnnotations    <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")-  dumpUnknownAST     <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")-  dumpCompleteAST    <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")-  dumpBriDocRaw      <- addSimpleBoolFlag "" ["dump-bridoc-raw"] (flagHelp $ parDoc "dump the pre-transformation bridoc")-  dumpBriDocAlt      <- addSimpleBoolFlag "" ["dump-bridoc-alt"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: alt")-  dumpBriDocPar      <- addSimpleBoolFlag "" ["dump-bridoc-par"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: par")-  dumpBriDocFloating <- addSimpleBoolFlag "" ["dump-bridoc-floating"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: floating")-  dumpBriDocColumns  <- addSimpleBoolFlag "" ["dump-bridoc-columns"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: columns")-  dumpBriDocIndent   <- addSimpleBoolFlag "" ["dump-bridoc-indent"] (flagHelp $ parDoc "dump the partially transformed bridoc: after transformation: indent")-  dumpBriDocFinal    <- addSimpleBoolFlag "" ["dump-bridoc-final"] (flagHelp $ parDoc "dump the post-transformation bridoc")--  outputOnErrors     <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)")-  wError             <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")-  omitValidCheck     <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)")--  roundtripOnly      <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)")--  optionsGhc         <- addFlagStringParams "" ["ghc-options"] "STRING" (flagHelp $ parDoc "allows to define default language extensions. The parameter is forwarded to ghc.")-  disableFormatting  <- addSimpleBoolFlag "" ["disable-formatting"] (flagHelp $ parDoc "parse, but don't transform the input at all. Useful for inline config for specific modules.")-  obfuscate          <- addSimpleBoolFlag "" ["obfuscate"] (flagHelp $ parDoc "apply obfuscator to the output.")--  return $ Config-    { _conf_version                   = mempty-    , _conf_debug                     = DebugConfig-      { _dconf_dump_config                = wrapLast $ falseToNothing dumpConfig-      , _dconf_dump_annotations           = wrapLast $ falseToNothing dumpAnnotations-      , _dconf_dump_ast_unknown           = wrapLast $ falseToNothing dumpUnknownAST-      , _dconf_dump_ast_full              = wrapLast $ falseToNothing dumpCompleteAST-      , _dconf_dump_bridoc_raw            = wrapLast $ falseToNothing dumpBriDocRaw-      , _dconf_dump_bridoc_simpl_alt      = wrapLast $ falseToNothing dumpBriDocAlt-      , _dconf_dump_bridoc_simpl_par      = wrapLast $ falseToNothing dumpBriDocPar-      , _dconf_dump_bridoc_simpl_floating = wrapLast $ falseToNothing dumpBriDocFloating-      , _dconf_dump_bridoc_simpl_columns  = wrapLast $ falseToNothing dumpBriDocColumns-      , _dconf_dump_bridoc_simpl_indent   = wrapLast $ falseToNothing dumpBriDocIndent-      , _dconf_dump_bridoc_final          = wrapLast $ falseToNothing dumpBriDocFinal-      , _dconf_roundtrip_exactprint_only  = mempty-      }-    , _conf_layout                    = LayoutConfig-      { _lconfig_cols                          = optionConcat cols-      , _lconfig_indentPolicy                  = mempty-      , _lconfig_indentAmount                  = optionConcat ind-      , _lconfig_indentWhereSpecial            = mempty -- falseToNothing _-      , _lconfig_indentListSpecial             = mempty -- falseToNothing _-      , _lconfig_importColumn                  = optionConcat importCol-      , _lconfig_importAsColumn                = optionConcat importAsCol-      , _lconfig_altChooser                    = mempty-      , _lconfig_columnAlignMode               = mempty-      , _lconfig_alignmentLimit                = mempty-      , _lconfig_alignmentBreakOnMultiline     = mempty-      , _lconfig_hangingTypeSignature          = mempty-      , _lconfig_reformatModulePreamble        = mempty-      , _lconfig_allowSingleLineExportList     = mempty-      , _lconfig_allowHangingQuasiQuotes       = mempty-      , _lconfig_experimentalSemicolonNewlines = mempty-      -- , _lconfig_allowSinglelineRecord     = mempty-      }-    , _conf_errorHandling             = ErrorHandlingConfig-      { _econf_produceOutputOnErrors   = wrapLast $ falseToNothing outputOnErrors-      , _econf_Werror                  = wrapLast $ falseToNothing wError-      , _econf_ExactPrintFallback      = mempty-      , _econf_omit_output_valid_check = wrapLast $ falseToNothing omitValidCheck-      }-    , _conf_preprocessor              = PreProcessorConfig { _ppconf_CPPMode = mempty, _ppconf_hackAroundIncludes = mempty }-    , _conf_forward                   = ForwardOptions { _options_ghc = [ optionsGhc & List.unwords & CmdArgs.splitArgs | not $ null optionsGhc ] }-    , _conf_roundtrip_exactprint_only = wrapLast $ falseToNothing roundtripOnly-    , _conf_disable_formatting        = wrapLast $ falseToNothing disableFormatting-    , _conf_obfuscate                 = wrapLast $ falseToNothing obfuscate-    }- where-  falseToNothing = Bool.bool Nothing (Just True)-  wrapLast :: Maybe a -> Maybe (Semigroup.Last a)-  wrapLast = fmap Semigroup.Last-  optionConcat :: (Semigroup.Semigroup (f a), Applicative f) => [a] -> Maybe (f a)-  optionConcat = mconcat . fmap (pure . pure)---- configParser :: Parser Config--- configParser = Config---   <$> option (eitherReader $ maybe (Left "required <int>!") Right . readMaybe)---         (long "indent" <> value 2 <> metavar "AMOUNT" <> help "spaces per indentation level")---   <*> (Bar---     <$> switch (long "bara" <> help "bara help")---     <*> switch (long "barb")---     <*> flag 3 5 (long "barc")---   )------ configParserInfo :: ParserInfo Config--- configParserInfo = ParserInfo---   { infoParser      = configParser---   , infoFullDesc    = True---   , infoProgDesc    = return $ PP.text "a haskell code formatting utility based on ghc-exactprint"---   , infoHeader      = return $ PP.text "brittany"---   , infoFooter      = empty---   , infoFailureCode = (-55)---   , infoIntersperse = True---   }----- | Reads a config from a file. If the file does not exist, returns--- Nothing. If the file exists and parsing fails, prints to stderr and--- aborts the MaybeT. Otherwise succeed via Just.--- If the second parameter is True and the file does not exist, writes the--- staticDefaultConfig to the file.-readConfig-  :: MonadIO m => System.IO.FilePath -> MaybeT m (Maybe (CConfig Maybe))-readConfig path = do-  -- TODO: probably should catch IOErrors and then omit the existence check.-  exists <- liftIO $ System.Directory.doesFileExist path-  if exists-    then do-      contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.-      fileConf <- case Data.Yaml.decodeEither' contents of-        Left e -> do-          liftIO-            $  putStrErrLn-            $  "error reading in brittany config from "-            ++ path-            ++ ":"-          liftIO $ putStrErrLn (Data.Yaml.prettyPrintParseException e)-          mzero-        Right x -> return x-      return $ Just fileConf-    else return $ Nothing---- | Looks for a user-global config file and return its path.--- If there is no global config in a system, one will be created.-userConfigPath :: IO System.IO.FilePath-userConfigPath = do-  userBritPathSimple <- Directory.getAppUserDataDirectory "brittany"-  userBritPathXdg    <- Directory.getXdgDirectory Directory.XdgConfig "brittany"-  let searchDirs = [userBritPathSimple, userBritPathXdg]-  globalConfig <- Directory.findFileWith Directory.doesFileExist-                                         searchDirs-                                         "config.yaml"-  maybe (writeUserConfig userBritPathXdg) pure globalConfig- where-  writeUserConfig dir = do-    let createConfPath = dir FilePath.</> "config.yaml"-    liftIO $ Directory.createDirectoryIfMissing True dir-    writeDefaultConfig $ createConfPath-    pure createConfPath---- | Searches for a local (per-project) brittany config starting from a given directory-findLocalConfigPath :: System.IO.FilePath -> IO (Maybe System.IO.FilePath)-findLocalConfigPath dir = do-  let dirParts   = FilePath.splitDirectories dir-  -- when provided dir is "a/b/c", searchDirs is ["a/b/c", "a/b", "a", "/"]-  let searchDirs = FilePath.joinPath <$> reverse (List.inits dirParts)-  Directory.findFileWith Directory.doesFileExist searchDirs "brittany.yaml"---- | Reads specified configs.-readConfigs-  :: CConfig Maybe        -- ^ Explicit options, take highest priority-  -> [System.IO.FilePath]  -- ^ List of config files to load and merge, highest priority first-  -> MaybeT IO Config-readConfigs cmdlineConfig configPaths = do-  configs <- readConfig `mapM` configPaths-  let merged = Semigroup.sconcat-        $ NonEmpty.reverse (cmdlineConfig :| catMaybes configs)-  return $ cZipWith fromOptionIdentity staticDefaultConfig merged---- | Reads provided configs--- but also applies the user default configuration (with lowest priority)-readConfigsWithUserConfig-  :: CConfig Maybe        -- ^ Explicit options, take highest priority-  -> [System.IO.FilePath]  -- ^ List of config files to load and merge, highest priority first-  -> MaybeT IO Config-readConfigsWithUserConfig cmdlineConfig configPaths = do-  defaultPath <- liftIO $ userConfigPath-  readConfigs cmdlineConfig (configPaths ++ [defaultPath])--writeDefaultConfig :: MonadIO m => System.IO.FilePath -> m ()-writeDefaultConfig path =-  liftIO $ ByteString.writeFile path $ Data.Yaml.encode $ cMap-    (Just . runIdentity)-    staticDefaultConfig--showConfigYaml :: Config -> String-showConfigYaml = Data.ByteString.Char8.unpack . Data.Yaml.encode . cMap-  (\(Identity x) -> Just x)
− source/library/Language/Haskell/Brittany/Internal/Config/Types.hs 
@@ -1,339 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}--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.PreludeUtils ()----confUnpack :: Coercible a b => Identity a -> b-confUnpack (Identity x) = coerce x--data CDebugConfig f = DebugConfig-  { _dconf_dump_config                :: f (Semigroup.Last Bool)-  , _dconf_dump_annotations           :: f (Semigroup.Last Bool)-  , _dconf_dump_ast_unknown           :: f (Semigroup.Last Bool)-  , _dconf_dump_ast_full              :: f (Semigroup.Last Bool)-  , _dconf_dump_bridoc_raw            :: f (Semigroup.Last Bool)-  , _dconf_dump_bridoc_simpl_alt      :: f (Semigroup.Last Bool)-  , _dconf_dump_bridoc_simpl_floating :: f (Semigroup.Last Bool)-  , _dconf_dump_bridoc_simpl_par      :: f (Semigroup.Last Bool)-  , _dconf_dump_bridoc_simpl_columns  :: f (Semigroup.Last Bool)-  , _dconf_dump_bridoc_simpl_indent   :: f (Semigroup.Last Bool)-  , _dconf_dump_bridoc_final          :: f (Semigroup.Last Bool)-  , _dconf_roundtrip_exactprint_only  :: f (Semigroup.Last Bool)-  }-  deriving (Generic)--data CLayoutConfig f = LayoutConfig-  { _lconfig_cols         :: f (Last Int) -- the thing that has default 80.-  , _lconfig_indentPolicy :: f (Last IndentPolicy)-  , _lconfig_indentAmount :: f (Last Int)-  , _lconfig_indentWhereSpecial :: f (Last Bool) -- indent where only 1 sometimes (TODO).-  , _lconfig_indentListSpecial  :: f (Last Bool) -- use some special indentation for ","-                                                 -- when creating zero-indentation-                                                 -- multi-line list literals.-  , _lconfig_importColumn    :: f (Last Int)-    -- ^ for import statement layouting, column at which to align the-    -- elements to be imported from a module.-    -- It is expected that importAsColumn >= importCol.-  , _lconfig_importAsColumn  :: f (Last Int)-    -- ^ for import statement layouting, column at which put the module's-    -- "as" name (which also affects the positioning of the "as" keyword).-    -- It is expected that importAsColumn >= importCol.-  , _lconfig_altChooser      :: f (Last AltChooser)-  , _lconfig_columnAlignMode :: f (Last ColumnAlignMode)-  , _lconfig_alignmentLimit  :: f (Last Int)-    -- roughly speaking, this sets an upper bound to the number of spaces-    -- inserted to create horizontal alignment.-    -- More specifically, if 'xs' are the widths of the columns in some-    -- alignment-block, then the block will be aligned with the width-    -- maximum [ x | x <- xs, x < minimum xs + alignmentLimit ].-  , _lconfig_alignmentBreakOnMultiline :: f (Last Bool)-    -- stops alignment between items that are not layouted as a single line.-    -- e.g. for single-line alignment, things remain unchanged:-    --   do-    --     short       <- stuff-    --     loooooooong <- stuff-    -- but not in cases such as:-    --   do-    --     short <- some more stuff-    --       that requires two lines-    --     loooooooong <- stuff-  , _lconfig_hangingTypeSignature :: f (Last Bool)-    -- Do not put "::" in a new line, and use hanging indentation for the-    -- signature, i.e.:-    -- func :: SomeLongStuff-    --      -> SomeLongStuff-    -- instead of the usual-    -- func-    --   :: SomeLongStuff-    --   -> SomeLongStuff-    -- As usual for hanging indentation, the result will be-    -- context-sensitive (in the function name).-  , _lconfig_reformatModulePreamble :: f (Last Bool)-    -- whether the module preamble/header (module keyword, name, export list,-    -- import statements) are reformatted. If false, only the elements of the-    -- module (everything past the "where") are reformatted.-  , _lconfig_allowSingleLineExportList :: f (Last Bool)-    -- if true, and it fits in a single line, and there are no comments in the-    -- export list, the following layout will be used:-    -- > module MyModule (abc, def) where-    -- > [stuff]-    -- otherwise, the multi-line version is used:-    -- > module MyModule-    -- >   ( abc-    -- >   , def-    -- >   )-    -- > where-  , _lconfig_allowHangingQuasiQuotes :: f (Last Bool)-    -- if false, the layouter sees any splices as infinitely big and places-    -- them accordingly (in newlines, most likely); This also influences-    -- parent nodes.-    -- if true, the layouter is free to start a quasi-quotation at the end-    -- of a line.-    ---    -- false:-    -- > let-    -- >   body =-    -- >     [json|-    -- >     hello-    -- >     |]-    ---    -- true:-    -- > let body = [json|-    -- >     hello-    -- >     |]-  , _lconfig_experimentalSemicolonNewlines :: f (Last Bool)-    -- enables an experimental feature to turn semicolons in brace notation-    -- into newlines when using layout:-    ---    -- > do { a ;; b }-    ---    -- turns into-    -- > do-    -- >   a-    -- >-    -- >   b-    ---    -- 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-  --   -- >   }-  }-  deriving (Generic)--data CForwardOptions f = ForwardOptions-  { _options_ghc :: f [String]-  }-  deriving (Generic)--data CErrorHandlingConfig f = ErrorHandlingConfig-  { _econf_produceOutputOnErrors   :: f (Semigroup.Last Bool)-  , _econf_Werror                  :: f (Semigroup.Last Bool)-  , _econf_ExactPrintFallback      :: f (Semigroup.Last ExactPrintFallbackMode)-    -- ^ Determines when to fall back on the exactprint'ed output when-    -- syntactical constructs are encountered which are not yet handled by-    -- brittany.-    -- Note that the "risky" setting is risky because even with the check of-    -- the syntactic validity of the brittany output, at least in theory there-    -- may be cases where the output is syntactically/semantically valid but-    -- has different semantics than the code pre-transformation.-  , _econf_omit_output_valid_check :: f (Semigroup.Last Bool)-  }-  deriving (Generic)--data CPreProcessorConfig f = PreProcessorConfig-  { _ppconf_CPPMode :: f (Semigroup.Last CPPMode)-  , _ppconf_hackAroundIncludes :: f (Semigroup.Last Bool)-  }-  deriving (Generic)--data CConfig f = Config-  { _conf_version       :: f (Semigroup.Last Int)-  , _conf_debug         :: CDebugConfig f-  , _conf_layout        :: CLayoutConfig f-  , _conf_errorHandling :: CErrorHandlingConfig f-  , _conf_forward       :: CForwardOptions f-  , _conf_preprocessor  :: CPreProcessorConfig f-  , _conf_roundtrip_exactprint_only :: f (Semigroup.Last Bool)-    -- ^ this field is somewhat of a duplicate of the one in DebugConfig.-    -- It is used for per-declaration disabling by the inline config-    -- implementation. Could have re-used the existing field, but felt risky-    -- to use a "debug" labeled field for non-debug functionality.-  , _conf_disable_formatting :: f (Semigroup.Last Bool)-    -- ^ Used for inline config that disables brittany entirely for this-    -- module. Useful for wildcard application-    -- (`find -name "*.hs" | xargs brittany --write-mode inplace` or something-    -- in that direction).-  , _conf_obfuscate     :: f (Semigroup.Last Bool)--  }-  deriving (Generic)--type DebugConfig = CDebugConfig Identity-type LayoutConfig = CLayoutConfig Identity-type ForwardOptions = CForwardOptions Identity-type ErrorHandlingConfig = CErrorHandlingConfig Identity-type Config = CConfig Identity---- i wonder if any Show1 stuff could be leveraged.-deriving instance Show (CDebugConfig Identity)-deriving instance Show (CLayoutConfig Identity)-deriving instance Show (CErrorHandlingConfig Identity)-deriving instance Show (CForwardOptions Identity)-deriving instance Show (CPreProcessorConfig Identity)-deriving instance Show (CConfig Identity)--deriving instance Show (CDebugConfig Maybe)-deriving instance Show (CLayoutConfig Maybe)-deriving instance Show (CErrorHandlingConfig Maybe)-deriving instance Show (CForwardOptions Maybe)-deriving instance Show (CPreProcessorConfig Maybe)-deriving instance Show (CConfig Maybe)--deriving instance Data (CDebugConfig Identity)-deriving instance Data (CLayoutConfig Identity)-deriving instance Data (CErrorHandlingConfig Identity)-deriving instance Data (CForwardOptions Identity)-deriving instance Data (CPreProcessorConfig Identity)-deriving instance Data (CConfig Identity)--deriving instance Data (CDebugConfig Maybe)-deriving instance Data (CLayoutConfig Maybe)-deriving instance Data (CErrorHandlingConfig Maybe)-deriving instance Data (CForwardOptions Maybe)-deriving instance Data (CPreProcessorConfig Maybe)-deriving instance Data (CConfig Maybe)--instance Semigroup.Semigroup (CDebugConfig Maybe) where-  (<>) = gmappend-instance Semigroup.Semigroup (CLayoutConfig Maybe) where-  (<>) = gmappend-instance Semigroup.Semigroup (CErrorHandlingConfig Maybe) where-  (<>) = gmappend-instance Semigroup.Semigroup (CForwardOptions Maybe) where-  (<>) = gmappend-instance Semigroup.Semigroup (CPreProcessorConfig Maybe) where-  (<>) = gmappend-instance Semigroup.Semigroup (CConfig Maybe) where-  (<>) = gmappend--instance Semigroup.Semigroup (CDebugConfig Identity) where-  (<>) = gmappend-instance Semigroup.Semigroup (CLayoutConfig Identity) where-  (<>) = gmappend-instance Semigroup.Semigroup (CErrorHandlingConfig Identity) where-  (<>) = gmappend-instance Semigroup.Semigroup (CForwardOptions Identity) where-  (<>) = gmappend-instance Semigroup.Semigroup (CPreProcessorConfig Identity) where-  (<>) = gmappend-instance Semigroup.Semigroup (CConfig Identity) where-  (<>) = gmappend--instance Monoid (CDebugConfig Maybe) where-  mempty = gmempty-instance Monoid (CLayoutConfig Maybe) where-  mempty = gmempty-instance Monoid (CErrorHandlingConfig Maybe) where-  mempty = gmempty-instance Monoid (CForwardOptions Maybe) where-  mempty = gmempty-instance Monoid (CPreProcessorConfig Maybe) where-  mempty = gmempty-instance Monoid (CConfig Maybe) where-  mempty = gmempty---data IndentPolicy = IndentPolicyLeft -- never create a new indentation at more-                                     -- than old indentation + amount-                  | IndentPolicyFree -- can create new indentations whereever-                  | IndentPolicyMultiple -- can create indentations only-                                         -- at any n * amount.-  deriving (Eq, Show, Generic, Data)--data AltChooser = AltChooserSimpleQuick -- always choose last alternative.-                                        -- leads to tons of sparsely filled-                                        -- lines.-                | AltChooserShallowBest -- choose the first matching alternative-                                        -- using the simplest spacing-                                        -- information for the children.-                | AltChooserBoundedSearch Int-                                        -- choose the first matching alternative-                                        -- using a bounded list of recursive-                                        -- options having sufficient space.-  deriving (Show, Generic, Data)--data ColumnAlignMode-  = ColumnAlignModeDisabled-    -- ^ Make no column alignments whatsoever-  | ColumnAlignModeUnanimously-    -- ^ Make column alignments only if it does not cause overflow for any of-    -- the affected lines.-  | ColumnAlignModeMajority Float-    -- ^ If at least (ratio::Float) of the aligned elements have sufficient-    -- space for the alignment, act like ColumnAlignModeAnimously; otherwise-    -- act like ColumnAlignModeDisabled.-  | ColumnAlignModeAnimouslyScale Int-    -- ^ Scale back columns to some degree if their sum leads to overflow.-    -- This is done in a linear fashion.-    -- The Int specifies additional columns to be added to column maximum for-    -- scaling calculation purposes.-  | ColumnAlignModeAnimously-    -- ^ Decide on a case-by-case basis if alignment would cause overflow.-    -- If it does, cancel all alignments for this (nested) column description.-  -- ColumnAlignModeAnimouslySome -- potentially to implement-  | ColumnAlignModeAlways-    -- ^ Always respect column alignments, even if it makes stuff overflow.-  deriving (Show, Generic, Data)--data CPPMode = CPPModeAbort  -- abort program on seeing -XCPP-             | CPPModeWarn   -- warn about CPP and non-roundtripping in its-                             -- presence.-             | CPPModeNowarn -- silently allow CPP, if possible (i.e. input is-                             -- file.)-  deriving (Show, Generic, Data)--data ExactPrintFallbackMode-  = ExactPrintFallbackModeNever  -- never fall back on exactprinting-  | ExactPrintFallbackModeInline -- fall back only if there are no newlines in-                                 -- the exactprint'ed output.-  | ExactPrintFallbackModeRisky  -- fall back even in the presence of newlines.-                                 -- THIS MAY THEORETICALLY CHANGE SEMANTICS OF-                                 -- A PROGRAM BY TRANSFORMING IT.-  deriving (Show, Generic, Data)--deriveCZipWith ''CDebugConfig-deriveCZipWith ''CLayoutConfig-deriveCZipWith ''CErrorHandlingConfig-deriveCZipWith ''CForwardOptions-deriveCZipWith ''CPreProcessorConfig-deriveCZipWith ''CConfig--instance CFunctor CDebugConfig-instance CFunctor CLayoutConfig-instance CFunctor CErrorHandlingConfig-instance CFunctor CForwardOptions-instance CFunctor CPreProcessorConfig-instance CFunctor CConfig
− source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs 
@@ -1,121 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--- These optimizations are disabled to improve compile times (and compilation--- memory usage). When we do not disable them, the CI servers take more than--- 10 minutes to compile this module alone.--- Having looked into aeson and how the instances are written, I still do--- not understand what makes GHC choke so much here. The size of the raw--- expressions below looks fairly negligible, so there must be some expansion--- due to inlining going on. But even disabling INLINE pragmas in aeson did--- not seem to change anything.--- Nonetheless, this solution works and has no downsides because the--- instances defined here are not in any way performance-critical.-{-# OPTIONS_GHC -fno-pre-inlining #-}-{-# OPTIONS_GHC -fno-specialise #-}-{-# OPTIONS_GHC -fignore-interface-pragmas #-}--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Config.Types.Instances where--import qualified Data.Aeson.Key as Key-import qualified Data.Aeson.Types as Aeson-import Data.Yaml-import Language.Haskell.Brittany.Internal.Config.Types-import Language.Haskell.Brittany.Internal.Prelude----aesonDecodeOptionsBrittany :: Aeson.Options-aesonDecodeOptionsBrittany = Aeson.defaultOptions-  { Aeson.omitNothingFields = True-  , Aeson.fieldLabelModifier = dropWhile (=='_')-  }--instance FromJSON (CDebugConfig Maybe) where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON (CDebugConfig Maybe) where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany--instance FromJSON IndentPolicy where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON IndentPolicy where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany-  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany--instance FromJSON AltChooser where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON AltChooser where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany-  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany--instance FromJSON ColumnAlignMode where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON ColumnAlignMode where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany-  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany--instance FromJSON CPPMode where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON CPPMode where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany-  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany--instance FromJSON ExactPrintFallbackMode where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON ExactPrintFallbackMode where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany-  toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany--instance FromJSON (CLayoutConfig Maybe) where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON (CLayoutConfig Maybe) where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany--instance FromJSON (CErrorHandlingConfig Maybe) where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON (CErrorHandlingConfig Maybe) where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany--instance FromJSON (CForwardOptions Maybe) where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON (CForwardOptions Maybe) where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany--instance FromJSON (CPreProcessorConfig Maybe) where-  parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany--instance ToJSON (CPreProcessorConfig Maybe) where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany--instance ToJSON (CConfig Maybe) where-  toJSON = Aeson.genericToJSON aesonDecodeOptionsBrittany---- This custom instance ensures the "omitNothingFields" behaviour not only for--- leafs, but for nodes of the config as well. This way e.g. "{}" is valid--- config file content.-instance FromJSON (CConfig Maybe) where-  parseJSON (Object v) = Config-    <$> v .:?  Key.fromString "conf_version"-    <*> v .:?= Key.fromString "conf_debug"-    <*> v .:?= Key.fromString "conf_layout"-    <*> v .:?= Key.fromString "conf_errorHandling"-    <*> v .:?= Key.fromString "conf_forward"-    <*> v .:?= Key.fromString "conf_preprocessor"-    <*> v .:?  Key.fromString "conf_roundtrip_exactprint_only"-    <*> v .:?  Key.fromString "conf_disable_formatting"-    <*> v .:?  Key.fromString "conf_obfuscate"-  parseJSON invalid    = Aeson.typeMismatch "Config" invalid---- Pretends that the value is {} when the key is not present.-(.:?=) :: FromJSON a => Object -> Key.Key -> Parser a-o .:?= k = o .:? k >>= maybe (parseJSON (Aeson.object [])) pure
− source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs 
@@ -1,247 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MonadComprehensions #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Language.Haskell.Brittany.Internal.ExactPrintUtils where--import qualified Control.Monad.State.Class as State.Class-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS-import Data.Data-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.Maybe-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import GHC (GenLocated(L))-import qualified GHC hiding (parseModule)-import qualified GHC.Driver.CmdLine 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 qualified Language.Haskell.Brittany.Internal.ParseModule as ParseModule-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.Types as ExactPrint-import qualified System.IO----parseModule-  :: [String]-  -> System.IO.FilePath-  -> (GHC.DynFlags -> IO (Either String a))-  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))-parseModule args fp dynCheck = do-  str <- System.IO.readFile fp-  parseModuleFromString args fp dynCheck str--parseModuleFromString-  :: [String]-  -> System.IO.FilePath-  -> (GHC.DynFlags -> IO (Either String a))-  -> String-  -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))-parseModuleFromString = ParseModule.parseModule---commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()-commentAnnFixTransformGlob ast = do-  let extract :: forall a . SYB.Data a => a -> Seq (SrcSpan, ExactPrint.AnnKey)-      extract = -- traceFunctionWith "extract" (show . SYB.typeOf) show $-        const Seq.empty-          `SYB.ext1Q`-            (\l@(L span _) -> Seq.singleton (span, ExactPrint.mkAnnKey l))-  let nodes = SYB.everything (<>) extract ast-  let annsMap :: Map GHC.RealSrcLoc ExactPrint.AnnKey-      annsMap = Map.fromListWith-        (const id)-        [ (GHC.realSrcSpanEnd span, annKey)-        | (GHC.RealSrcSpan span _, annKey) <- Foldable.toList nodes-        ]-  nodes `forM_` (snd .> processComs annsMap)- where-  processComs annsMap annKey1 = do-    mAnn <- State.Class.gets fst <&> Map.lookup annKey1-    mAnn `forM_` \ann1 -> do-      let priors  = ExactPrint.annPriorComments ann1-          follows = ExactPrint.annFollowingComments ann1-          assocs  = ExactPrint.annsDP ann1-      let-        processCom-          :: (ExactPrint.Comment, ExactPrint.DeltaPos)-          -> ExactPrint.TransformT Identity Bool-        processCom comPair@(com, _) =-          case GHC.realSrcSpanStart $ ExactPrint.commentIdentifier com of-            comLoc -> case Map.lookupLE comLoc annsMap of-              Just (_, annKey2) | loc1 /= loc2 -> case (con1, con2) of-                (ExactPrint.CN "RecordCon", ExactPrint.CN "HsRecField") ->-                  move $> False-                (x, y) | x == y -> move $> False-                _               -> return True-               where-                ExactPrint.AnnKey annKeyLoc1 con1 = annKey1-                ExactPrint.AnnKey annKeyLoc2 con2 = annKey2-                loc1                              = GHC.realSrcSpanStart annKeyLoc1-                loc2                              = GHC.realSrcSpanStart annKeyLoc2-                move = ExactPrint.modifyAnnsT $ \anns ->-                  let-                    ann2  = Data.Maybe.fromJust $ Map.lookup annKey2 anns-                    ann2' = ann2-                      { ExactPrint.annFollowingComments =-                          ExactPrint.annFollowingComments ann2 ++ [comPair]-                      }-                  in-                    Map.insert annKey2 ann2' anns-              _ -> return True -- retain comment at current node.-      priors'  <- filterM processCom priors-      follows' <- filterM processCom follows-      assocs'  <- flip filterM assocs $ \case-        (ExactPrint.AnnComment com, dp) -> processCom (com, dp)-        _                               -> return True-      let ann1' = ann1 { ExactPrint.annPriorComments     = priors'-                       , ExactPrint.annFollowingComments = follows'-                       , ExactPrint.annsDP               = assocs'-                       }-      ExactPrint.modifyAnnsT $ \anns -> Map.insert annKey1 ann1' anns----- TODO: this is unused by now, but it contains one detail that---       commentAnnFixTransformGlob does not include: Moving of comments for---       "RecordUpd"s.--- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()--- commentAnnFixTransform modul = SYB.everything (>>) genF modul---  where---   genF :: Data.Data.Data a => a -> ExactPrint.Transform ()---   genF = (\_ -> return ()) `SYB.extQ` exprF---   exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()---   exprF lexpr@(L _ expr) = case expr of--- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */---     RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->--- #else---     RecordCon _ _ _ (HsRecFields fs@(_:_) Nothing) ->--- #endif---       moveTrailingComments lexpr (List.last fs)--- #if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */---     RecordUpd _ _e fs@(_:_) ->--- #else---     RecordUpd _e fs@(_:_) _cons _ _ _ ->--- #endif---       moveTrailingComments lexpr (List.last fs)---     _ -> return ()---- commentAnnFixTransform :: GHC.ParsedSource -> ExactPrint.Transform ()--- commentAnnFixTransform modul = SYB.everything (>>) genF modul---  where---   genF :: Data.Data.Data a => a -> ExactPrint.Transform ()---   genF = (\_ -> return ()) `SYB.extQ` exprF---   exprF :: Located (HsExpr GhcPs) -> ExactPrint.Transform ()---   exprF lexpr@(L _ expr) = case expr of---     RecordCon _ _ (HsRecFields fs@(_:_) Nothing) ->---       moveTrailingComments lexpr (List.last fs)---     RecordUpd _ _e fs@(_:_) ->---       moveTrailingComments lexpr (List.last fs)---     _ -> return ()---- moveTrailingComments :: (Data.Data.Data a,Data.Data.Data b)---                      => GHC.Located a -> GHC.Located b -> ExactPrint.Transform ()--- moveTrailingComments astFrom astTo = do---   let---     k1 = ExactPrint.mkAnnKey astFrom---     k2 = ExactPrint.mkAnnKey astTo---     moveComments ans = ans'---       where---         an1 = Data.Maybe.fromJust $ Map.lookup k1 ans---         an2 = Data.Maybe.fromJust $ Map.lookup k2 ans---         cs1f = ExactPrint.annFollowingComments an1---         cs2f = ExactPrint.annFollowingComments an2---         (comments, nonComments) = flip breakEither (ExactPrint.annsDP an1)---              $ \case---                (ExactPrint.AnnComment com, dp) -> Left (com, dp)---                x -> Right x---         an1' = an1---           { ExactPrint.annsDP               = nonComments---           , ExactPrint.annFollowingComments = []---           }---         an2' = an2---           { ExactPrint.annFollowingComments = cs1f ++ cs2f ++ comments---           }---         ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans----   ExactPrint.modifyAnnsT moveComments---- | split a set of annotations in a module into a map from top-level module--- elements to the relevant annotations. Avoids quadratic behaviour a trivial--- implementation would have.-extractToplevelAnns-  :: Located HsModule-  -> ExactPrint.Anns-  -> Map ExactPrint.AnnKey ExactPrint.Anns-extractToplevelAnns lmod anns = output- where-  (L _ (HsModule _ _ _ _ ldecls _ _)) = lmod-  declMap1 :: Map ExactPrint.AnnKey ExactPrint.AnnKey-  declMap1 = Map.unions $ ldecls <&> \ldecl ->-    Map.fromSet (const (ExactPrint.mkAnnKey ldecl)) (foldedAnnKeys ldecl)-  declMap2 :: Map ExactPrint.AnnKey ExactPrint.AnnKey-  declMap2 =-    Map.fromList-      $ [ (captured, declMap1 Map.! k)-        | (k, ExactPrint.Ann _ _ _ _ _ (Just captured)) <- Map.toList anns-        ]-  declMap = declMap1 `Map.union` declMap2-  modKey  = ExactPrint.mkAnnKey lmod-  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 f = Map.foldlWithKey' (\m k a -> Map.alter (insert k a) (f k a) m)-                               Map.empty- where-  insert k a Nothing  = Just (Map.singleton k a)-  insert k a (Just m) = Just (Map.insert k a m)--foldedAnnKeys :: Data.Data.Data ast => ast -> Set ExactPrint.AnnKey-foldedAnnKeys ast = SYB.everything-  Set.union-  ( \x -> maybe-    Set.empty-    Set.singleton-    [ SYB.gmapQi 1 (ExactPrint.mkAnnKey . L l) x-    | locTyCon == SYB.typeRepTyCon (SYB.typeOf x)-    , l :: SrcSpan <- SYB.gmapQi 0 SYB.cast x-      -- 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-      -- SrcSpan.-    ]-  )-  ast-  where locTyCon = SYB.typeRepTyCon (SYB.typeOf (L () ()))---withTransformedAnns-  :: Data ast-  => ast-  -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a-  -> MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] w s a-withTransformedAnns ast m = MultiRWSS.mGetRawR >>= \case-  readers@(conf :+: anns :+: HNil) -> do-    -- TODO: implement `local` for MultiReader/MultiRWS-    MultiRWSS.mPutRawR (conf :+: f anns :+: HNil)-    x <- m-    MultiRWSS.mPutRawR readers-    pure x- where-  f anns =-    let ((), (annsBalanced, _), _) =-          ExactPrint.runTransform anns (commentAnnFixTransformGlob ast)-    in  annsBalanced---warnExtractorCompat :: GHC.Warn -> String-warnExtractorCompat (GHC.Warn _ (L _ s)) = s
− source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs 
@@ -1,781 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.LayouterBasics where--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.Semigroup as Semigroup-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-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 GHC.Parser.Annotation (AnnKeywordId(..))-import GHC.Types.Name (getOccString)-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.Annotate as ExactPrint.Annotate-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types-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----processDefault-  :: ( ExactPrint.Annotate.Annotate ast-     , MonadMultiWriter Text.Builder.Builder m-     , MonadMultiReader ExactPrint.Types.Anns m-     )-  => Located ast-  -> m ()-processDefault x = do-  anns <- mAsk-  let str = ExactPrint.exactPrint x anns-  -- this hack is here so our print-empty-module trick does not add-  -- a newline at the start if there actually is no module header / imports-  -- / anything.-  -- TODO: instead the appropriate annotation could be removed when "cleaning"-  --       the module (header). This would remove the need for this hack!-  case str of-    "\n" -> return ()-    _    -> mTell $ Text.Builder.fromString str---- | Use ExactPrint's output for this node; add a newly generated inline comment--- at insertion position (meant to point out to the user that this node is--- not handled by brittany yet). Useful when starting implementing new--- syntactic constructs when children are not handled yet.-briDocByExact-  :: (ExactPrint.Annotate.Annotate ast)-  => Located ast-  -> ToBriDocM BriDocNumbered-briDocByExact ast = do-  anns <- mAsk-  traceIfDumpConf "ast"-                  _dconf_dump_ast_unknown-                  (printTreeWithCustom 100 (customLayouterF anns) ast)-  docExt ast anns True---- | Use ExactPrint's output for this node.--- Consider that for multi-line input, the indentation of the code produced--- by ExactPrint might be different, and even incompatible with the indentation--- of its surroundings as layouted by brittany. But there are safe uses of--- this, e.g. for any top-level declarations.-briDocByExactNoComment-  :: (ExactPrint.Annotate.Annotate ast)-  => Located ast-  -> ToBriDocM BriDocNumbered-briDocByExactNoComment ast = do-  anns <- mAsk-  traceIfDumpConf "ast"-                  _dconf_dump_ast_unknown-                  (printTreeWithCustom 100 (customLayouterF anns) ast)-  docExt ast anns False---- | Use ExactPrint's output for this node, presuming that this output does--- not contain any newlines. If this property is not met, the semantics--- depend on the @econf_AllowRiskyExactPrintUse@ config flag.-briDocByExactInlineOnly-  :: (ExactPrint.Annotate.Annotate ast)-  => String-  -> Located ast-  -> ToBriDocM BriDocNumbered-briDocByExactInlineOnly infoStr ast = do-  anns <- mAsk-  traceIfDumpConf "ast"-                  _dconf_dump_ast_unknown-                  (printTreeWithCustom 100 (customLayouterF anns) ast)-  let exactPrinted = Text.pack $ ExactPrint.exactPrint ast anns-  fallbackMode <--    mAsk <&> _conf_errorHandling .> _econf_ExactPrintFallback .> confUnpack-  let exactPrintNode t = allocateNode $ BDFExternal-        (ExactPrint.Types.mkAnnKey ast)-        (foldedAnnKeys ast)-        False-        t-  let errorAction = do-        mTell [ErrorUnknownNode infoStr ast]-        docLit-          $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"-  case (fallbackMode, Text.lines exactPrinted) of-    (ExactPrintFallbackModeNever, _  ) -> errorAction-    (_                          , [t]) -> exactPrintNode-      (Text.dropWhile Char.isSpace . Text.dropWhileEnd Char.isSpace $ t)-    (ExactPrintFallbackModeRisky, _) -> exactPrintNode exactPrinted-    _ -> errorAction--rdrNameToText :: RdrName -> Text--- rdrNameToText = Text.pack . show . flip runSDoc unsafeGlobalDynFlags . ppr-rdrNameToText (Unqual occname) = Text.pack $ occNameString occname-rdrNameToText (Qual mname occname) =-  Text.pack $ moduleNameString mname ++ "." ++ occNameString occname-rdrNameToText (Orig modul occname) =-  Text.pack $ moduleNameString (moduleName modul) ++ occNameString occname-rdrNameToText (Exact name) = Text.pack $ getOccString name--lrdrNameToText :: GenLocated l RdrName -> Text-lrdrNameToText (L _ n) = rdrNameToText n--lrdrNameToTextAnnGen-  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)-  => (Text -> Text)-  -> Located RdrName-  -> m Text-lrdrNameToTextAnnGen f ast@(L _ n) = do-  anns <- mAsk-  let t = f $ rdrNameToText n-  let hasUni x (ExactPrint.Types.G y, _) = x == y-      hasUni _ _                         = False-  -- TODO: in general: we should _always_ process all annotaiton stuff here.-  --       whatever we don't probably should have had some effect on the-  --       output. in such cases, resorting to byExact is probably the safe-  --       choice.-  return $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of-    Nothing                                   -> t-    Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> case n of-      Exact{} | t == Text.pack "()"      -> t-      _ | any (hasUni AnnBackquote) aks  -> Text.pack "`" <> t <> Text.pack "`"-      _ | any (hasUni AnnCommaTuple) aks -> t-      _ | any (hasUni AnnOpenP) aks      -> Text.pack "(" <> t <> Text.pack ")"-      _ | otherwise                      -> t--lrdrNameToTextAnn-  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)-  => Located RdrName-  -> m Text-lrdrNameToTextAnn = lrdrNameToTextAnnGen id--lrdrNameToTextAnnTypeEqualityIsSpecial-  :: (MonadMultiReader Config m, MonadMultiReader (Map AnnKey Annotation) m)-  => Located RdrName-  -> m Text-lrdrNameToTextAnnTypeEqualityIsSpecial ast = do-  let f x = if x == Text.pack "Data.Type.Equality~"-        then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh-        else x-  lrdrNameToTextAnnGen f ast---- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects--- the annotations for a (parent) node for a tick to be added to the--- literal.--- Excessively long name to reflect on us having to work around such--- excessively obscure special cases in the exactprint API.-lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick-  :: ( Data ast-     , MonadMultiReader Config m-     , MonadMultiReader (Map AnnKey Annotation) m-     )-  => Located ast-  -> Located RdrName-  -> m Text-lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do-  hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote-  x        <- lrdrNameToTextAnn ast2-  let lit = if x == Text.pack "Data.Type.Equality~"-        then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh-        else x-  return $ if hasQuote then Text.cons '\'' lit else lit--askIndent :: (MonadMultiReader Config m) => m Int-askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk---extractAllComments-  :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]-extractAllComments ann =-  ExactPrint.annPriorComments ann ++ extractRestComments ann--extractRestComments-  :: ExactPrint.Annotation -> [(ExactPrint.Comment, ExactPrint.DeltaPos)]-extractRestComments ann =-  ExactPrint.annFollowingComments ann-    ++ (ExactPrint.annsDP ann >>= \case-         (ExactPrint.AnnComment com, dp) -> [(com, dp)]-         _                               -> []-       )--filterAnns :: Data.Data.Data ast => ast -> ExactPrint.Anns -> ExactPrint.Anns-filterAnns ast =-  Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast)---- | True if there are any comments that are--- a) connected to any node below (in AST sense) the given node AND--- b) after (in source code order) the node.-hasAnyCommentsBelow :: Data ast => GHC.Located ast -> ToBriDocM Bool-hasAnyCommentsBelow ast@(L l _) =-  List.any (\(c, _) -> ExactPrint.commentIdentifier c > ExactPrint.Utils.rs l)-    <$> astConnectedComments ast--hasCommentsBetween-  :: Data ast-  => GHC.Located ast-  -> AnnKeywordId-  -> AnnKeywordId-  -> ToBriDocM Bool-hasCommentsBetween ast leftKey rightKey = do-  mAnn <- astAnn ast-  let go1 []         = False-      go1 ((ExactPrint.G kw, _dp) : rest) | kw == leftKey = go2 rest-      go1 (_ : rest) = go1 rest-      go2 []         = False-      go2 ((ExactPrint.AnnComment _, _dp) : _rest) = True-      go2 ((ExactPrint.G kw, _dp) : _rest) | kw == rightKey = False-      go2 (_ : rest) = go2 rest-  case mAnn of-    Nothing  -> pure False-    Just ann -> pure $ go1 $ ExactPrint.annsDP ann---- | True if there are any comments that are connected to any node below (in AST---   sense) the given node-hasAnyCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool-hasAnyCommentsConnected ast = not . null <$> astConnectedComments ast---- | True if there are any regular comments connected to any node below (in AST---   sense) the given node-hasAnyRegularCommentsConnected :: Data ast => GHC.Located ast -> ToBriDocM Bool-hasAnyRegularCommentsConnected ast =-  any isRegularComment <$> astConnectedComments ast---- | Regular comments are comments that are actually "source code comments",--- i.e. things that start with "--" or "{-". In contrast to comment-annotations--- used by ghc-exactprint for capturing symbols (and their exact positioning).------ Only the type instance layouter makes use of this filter currently, but--- it might make sense to apply it more aggressively or make it the default ---- I believe that most of the time we branch on the existence of comments, we--- only care about "regular" comments. We simply did not need the distinction--- because "irregular" comments are not that common outside of type/data decls.-isRegularComment :: (ExactPrint.Comment, ExactPrint.DeltaPos) -> Bool-isRegularComment = (== Nothing) . ExactPrint.Types.commentOrigin . fst--astConnectedComments-  :: Data ast-  => GHC.Located ast-  -> ToBriDocM [(ExactPrint.Types.Comment, ExactPrint.Types.DeltaPos)]-astConnectedComments ast = do-  anns <- filterAnns ast <$> mAsk-  pure $ extractAllComments =<< Map.elems anns--hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool-hasAnyCommentsPrior ast = astAnn ast <&> \case-  Nothing -> False-  Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors--hasAnyRegularCommentsRest :: Data ast => GHC.Located ast -> ToBriDocM Bool-hasAnyRegularCommentsRest ast = astAnn ast <&> \case-  Nothing -> False-  Just ann -> any isRegularComment (extractRestComments ann)--hasAnnKeywordComment-  :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool-hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case-  Nothing  -> False-  Just ann -> any hasK (extractAllComments ann)-  where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst--hasAnnKeyword-  :: (Data a, MonadMultiReader (Map AnnKey Annotation) m)-  => Located a-  -> AnnKeywordId-  -> m Bool-hasAnnKeyword ast annKeyword = astAnn ast <&> \case-  Nothing -> False-  Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks- where-  hasK (ExactPrint.Types.G x, _) = x == annKeyword-  hasK _                         = False--astAnn-  :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m)-  => GHC.Located ast-  -> m (Maybe Annotation)-astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk---- new BriDoc stuff--allocateNode-  :: MonadMultiState NodeAllocIndex m => BriDocFInt -> m BriDocNumbered-allocateNode bd = do-  i <- allocNodeIndex-  return (i, bd)--allocNodeIndex :: MonadMultiState NodeAllocIndex m => m Int-allocNodeIndex = do-  NodeAllocIndex i <- mGet-  mSet $ NodeAllocIndex (i + 1)-  return i---- docEmpty :: MonadMultiState NodeAllocIndex m => m BriDocNumbered--- docEmpty = allocateNode BDFEmpty------ docLit :: MonadMultiState NodeAllocIndex m => Text -> m BriDocNumbered--- docLit t = allocateNode $ BDFLit t------ docExt :: (ExactPrint.Annotate.Annotate ast, MonadMultiState NodeAllocIndex m)---        => Located ast -> ExactPrint.Types.Anns -> Bool -> m BriDocNumbered--- docExt x anns shouldAddComment = allocateNode $ BDFExternal---                   (ExactPrint.Types.mkAnnKey x)---                   (foldedAnnKeys x)---                   shouldAddComment---                   (Text.pack $ ExactPrint.exactPrint x anns)------ docAlt :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered--- docAlt l = allocateNode . BDFAlt =<< sequence l--------- docSeq :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered--- docSeq l = allocateNode . BDFSeq =<< sequence l------ docLines :: MonadMultiState NodeAllocIndex m => [m BriDocNumbered] -> m BriDocNumbered--- docLines l = allocateNode . BDFLines =<< sequence l------ docCols :: MonadMultiState NodeAllocIndex m => ColSig -> [m BriDocNumbered] -> m BriDocNumbered--- docCols sig l = allocateNode . BDFCols sig =<< sequence l------ docAddBaseY :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered--- docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm------ docSetBaseY :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered--- docSetBaseY bdm = allocateNode . BDFSetBaseY =<< bdm------ docSetIndentLevel :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered--- docSetIndentLevel bdm = allocateNode . BDFSetIndentLevel =<< bdm------ docSeparator :: MonadMultiState NodeAllocIndex m => m BriDocNumbered--- docSeparator = allocateNode BDFSeparator------ docAnnotationPrior :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered--- docAnnotationPrior annKey bdm = allocateNode . BDFAnnotationPrior annKey =<< bdm------ docAnnotationPost :: MonadMultiState NodeAllocIndex m => AnnKey -> m BriDocNumbered -> m BriDocNumbered--- docAnnotationPost  annKey bdm = allocateNode . BDFAnnotationPost annKey =<< bdm------ docNonBottomSpacing :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered--- docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm------ appSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered--- appSep x = docSeq [x, docSeparator]------ docCommaSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered--- docCommaSep = appSep $ docLit $ Text.pack ","------ docParenLSep :: MonadMultiState NodeAllocIndex m => m BriDocNumbered--- docParenLSep = appSep $ docLit $ Text.pack "("--------- docPostComment :: (Data.Data.Data ast, MonadMultiState NodeAllocIndex m)---                => Located ast---                -> m BriDocNumbered---                -> m BriDocNumbered--- docPostComment ast bdm = do---   bd <- bdm---   allocateNode $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd------ docWrapNode :: ( Data.Data.Data ast, MonadMultiState NodeAllocIndex m)---             => Located ast---             -> m BriDocNumbered---             -> m BriDocNumbered--- docWrapNode ast bdm = do---   bd <- bdm---   i1 <- allocNodeIndex---   i2 <- allocNodeIndex---   return---     $ (,) i1---     $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)---     $ (,) i2---     $ BDFAnnotationPost (ExactPrint.Types.mkAnnKey ast)---     $ bd------ docPar :: MonadMultiState NodeAllocIndex m---        => m BriDocNumbered---        -> m BriDocNumbered---        -> m BriDocNumbered--- docPar lineM indentedM = do---   line <- lineM---   indented <- indentedM---   allocateNode $ BDFPar BrIndentNone line indented------ docForceSingleline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered--- docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm------ docForceMultiline :: MonadMultiState NodeAllocIndex m => m BriDocNumbered -> m BriDocNumbered--- docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm------ docEnsureIndent :: MonadMultiState NodeAllocIndex m => BrIndent -> m BriDocNumbered -> m BriDocNumbered--- docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd--docEmpty :: ToBriDocM BriDocNumbered-docEmpty = allocateNode BDFEmpty--docLit :: Text -> ToBriDocM BriDocNumbered-docLit t = allocateNode $ BDFLit t--docLitS :: String -> ToBriDocM BriDocNumbered-docLitS s = allocateNode $ BDFLit $ Text.pack s--docExt-  :: (ExactPrint.Annotate.Annotate ast)-  => Located ast-  -> ExactPrint.Types.Anns-  -> Bool-  -> ToBriDocM BriDocNumbered-docExt x anns shouldAddComment = allocateNode $ BDFExternal-  (ExactPrint.Types.mkAnnKey x)-  (foldedAnnKeys x)-  shouldAddComment-  (Text.pack $ ExactPrint.exactPrint x anns)--docAlt :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered-docAlt l = allocateNode . BDFAlt =<< sequence l--newtype CollectAltM a = CollectAltM (Writer.Writer [ToBriDocM BriDocNumbered] a)-  deriving (Functor, Applicative, Monad)--addAlternativeCond :: Bool -> ToBriDocM BriDocNumbered -> CollectAltM ()-addAlternativeCond cond doc =-  when cond (addAlternative doc)--addAlternative :: ToBriDocM BriDocNumbered -> CollectAltM ()-addAlternative =-  CollectAltM . Writer.tell . (: [])--runFilteredAlternative :: CollectAltM () -> ToBriDocM BriDocNumbered-runFilteredAlternative (CollectAltM action) =-  docAlt $ Writer.execWriter action---docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered-docSeq [] = docEmpty-docSeq l = allocateNode . BDFSeq =<< sequence l--docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered-docLines l = allocateNode . BDFLines =<< sequence l--docCols :: ColSig -> [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered-docCols sig l = allocateNode . BDFCols sig =<< sequence l--docAddBaseY :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docAddBaseY ind bdm = allocateNode . BDFAddBaseY ind =<< bdm--docSetBaseY :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docSetBaseY bdm = do-  bd <- bdm-  -- the order here is important so that these two nodes can be treated-  -- properly over at `transformAlts`.-  n1 <- allocateNode $ BDFBaseYPushCur bd-  n2 <- allocateNode $ BDFBaseYPop n1-  return n2--docSetIndentLevel :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docSetIndentLevel bdm = do-  bd <- bdm-  n1 <- allocateNode $ BDFIndentLevelPushCur bd-  n2 <- allocateNode $ BDFIndentLevelPop n1-  return n2--docSetBaseAndIndent :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docSetBaseAndIndent = docSetBaseY . docSetIndentLevel--docSeparator :: ToBriDocM BriDocNumbered-docSeparator = allocateNode BDFSeparator--docAnnotationPrior-  :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docAnnotationPrior annKey bdm =-  allocateNode . BDFAnnotationPrior annKey =<< bdm--docAnnotationKW-  :: AnnKey-  -> Maybe AnnKeywordId-  -> ToBriDocM BriDocNumbered-  -> ToBriDocM BriDocNumbered-docAnnotationKW annKey kw bdm = allocateNode . BDFAnnotationKW annKey kw =<< bdm--docMoveToKWDP-  :: AnnKey-  -> AnnKeywordId-  -> Bool-  -> ToBriDocM BriDocNumbered-  -> ToBriDocM BriDocNumbered-docMoveToKWDP annKey kw shouldRestoreIndent bdm =-  allocateNode . BDFMoveToKWDP annKey kw shouldRestoreIndent =<< bdm--docAnnotationRest-  :: AnnKey -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm--docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm--docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm--docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm--docForceParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docForceParSpacing bdm = allocateNode . BDFForceParSpacing =<< bdm--docDebug :: String -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docDebug s bdm = allocateNode . BDFDebug s =<< bdm--appSep :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-appSep x = docSeq [x, docSeparator]--docCommaSep :: ToBriDocM BriDocNumbered-docCommaSep = appSep $ docLit $ Text.pack ","--docParenLSep :: ToBriDocM BriDocNumbered-docParenLSep = appSep docParenL---- TODO: we don't make consistent use of these (yet). However, I think the--- most readable approach overall might be something else: define--- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`.--- I think those two would make the usage most readable.--- lit "("  and  appSep (lit "(")  are understandable and short without--- introducing a new top-level binding for all types of parentheses.-docParenL :: ToBriDocM BriDocNumbered-docParenL = docLit $ Text.pack "("--docParenR :: ToBriDocM BriDocNumbered-docParenR = docLit $ Text.pack ")"--docParenHashLSep :: ToBriDocM BriDocNumbered-docParenHashLSep =  docSeq [docLit $ Text.pack "(#", docSeparator]--docParenHashRSep :: ToBriDocM BriDocNumbered-docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]--docBracketL :: ToBriDocM BriDocNumbered-docBracketL = docLit $ Text.pack "["--docBracketR :: ToBriDocM BriDocNumbered-docBracketR = docLit $ Text.pack "]"---docTick :: ToBriDocM BriDocNumbered-docTick = docLit $ Text.pack "'"--docNodeAnnKW-  :: Data.Data.Data ast-  => Located ast-  -> Maybe AnnKeywordId-  -> ToBriDocM BriDocNumbered-  -> ToBriDocM BriDocNumbered-docNodeAnnKW ast kw bdm =-  docAnnotationKW (ExactPrint.Types.mkAnnKey ast) kw bdm--docNodeMoveToKWDP-  :: Data.Data.Data ast-  => Located ast-  -> AnnKeywordId-  -> Bool-  -> ToBriDocM BriDocNumbered-  -> ToBriDocM BriDocNumbered-docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =-  docMoveToKWDP (ExactPrint.Types.mkAnnKey ast) kw shouldRestoreIndent bdm--class DocWrapable a where-  docWrapNode :: ( Data.Data.Data ast)-              => Located ast-              -> a-              -> a-  docWrapNodePrior :: ( Data.Data.Data ast)-                   => Located ast-                   -> a-                   -> a-  docWrapNodeRest  :: ( Data.Data.Data ast)-                   => Located ast-                   -> a-                   -> a--instance DocWrapable (ToBriDocM BriDocNumbered) where-  docWrapNode ast bdm = do-    bd <- bdm-    i1 <- allocNodeIndex-    i2 <- allocNodeIndex-    return-      $ (,) i1-      $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)-      $ (,) i2-      $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)-      $ bd-  docWrapNodePrior ast bdm = do-    bd <- bdm-    i1 <- allocNodeIndex-    return-      $ (,) i1-      $ BDFAnnotationPrior (ExactPrint.Types.mkAnnKey ast)-      $ bd-  docWrapNodeRest ast bdm = do-    bd <- bdm-    i2 <- allocNodeIndex-    return-      $ (,) i2-      $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)-      $ bd--instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where-  docWrapNode ast bdms = case bdms of-    [] -> []-    [bd] -> [docWrapNode ast bd]-    (bd1:bdR) | (bdN:bdM) <- reverse bdR ->-      [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN]-    _ -> error "cannot happen (TM)"-  docWrapNodePrior ast bdms = case bdms of-    [] -> []-    [bd] -> [docWrapNodePrior ast bd]-    (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR-  docWrapNodeRest ast bdms = case reverse bdms of-      [] -> []-      (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR--instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where-  docWrapNode ast bdsm = do-    bds <- bdsm-    case bds of-      [] -> return [] -- TODO: this might be bad. maybe. then again, not really. well.-      [bd] -> do-        bd' <- docWrapNode ast (return bd)-        return [bd']-      (bd1:bdR) | (bdN:bdM) <- reverse bdR -> do-        bd1' <- docWrapNodePrior ast (return bd1)-        bdN' <- docWrapNodeRest  ast (return bdN)-        return $ [bd1'] ++ reverse bdM ++ [bdN']-      _ -> error "cannot happen (TM)"-  docWrapNodePrior ast bdsm = do-    bds <- bdsm-    case bds of-      [] -> return []-      (bd1:bdR) -> do-        bd1' <- docWrapNodePrior ast (return bd1)-        return (bd1':bdR)-  docWrapNodeRest ast bdsm = do-    bds <- bdsm-    case reverse bds of-      [] -> return []-      (bdN:bdR) -> do-        bdN' <- docWrapNodeRest ast (return bdN)-        return $ reverse (bdN':bdR)--instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where-  docWrapNode ast bdsm = do-    bds <- bdsm-    case Seq.viewl bds of-      Seq.EmptyL -> return Seq.empty -- TODO: this might be bad. maybe. then again, not really. well.-      bd1 Seq.:< rest -> case Seq.viewr rest of-        Seq.EmptyR -> do-          bd1' <- docWrapNode ast (return bd1)-          return $ Seq.singleton bd1'-        bdM Seq.:> bdN -> do-          bd1' <- docWrapNodePrior ast (return bd1)-          bdN' <- docWrapNodeRest  ast (return bdN)-          return $ (bd1' Seq.<| bdM) Seq.|> bdN'-  docWrapNodePrior ast bdsm = do-    bds <- bdsm-    case Seq.viewl bds of-      Seq.EmptyL -> return Seq.empty-      bd1 Seq.:< bdR -> do-        bd1' <- docWrapNodePrior ast (return bd1)-        return $ bd1' Seq.<| bdR-  docWrapNodeRest ast bdsm = do-    bds <- bdsm-    case Seq.viewr bds of-      Seq.EmptyR -> return Seq.empty-      bdR Seq.:> bdN -> do-        bdN' <- docWrapNodeRest ast (return bdN)-        return $ bdR Seq.|> bdN'--instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where-  docWrapNode ast stuffM = do-    (bds, bd, x) <- stuffM-    if null bds-      then do-        bd' <- docWrapNode ast (return bd)-        return (bds, bd', x)-      else do-        bds' <- docWrapNodePrior ast (return bds)-        bd' <- docWrapNodeRest ast (return bd)-        return (bds', bd', x)-  docWrapNodePrior ast stuffM = do-    (bds, bd, x) <- stuffM-    bds' <- docWrapNodePrior ast (return bds)-    return (bds', bd, x)-  docWrapNodeRest ast stuffM = do-    (bds, bd, x) <- stuffM-    bd' <- docWrapNodeRest ast (return bd)-    return (bds, bd', x)----docPar-  :: ToBriDocM BriDocNumbered-  -> ToBriDocM BriDocNumbered-  -> ToBriDocM BriDocNumbered-docPar lineM indentedM = do-  line     <- lineM-  indented <- indentedM-  allocateNode $ BDFPar BrIndentNone line indented--docForceSingleline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docForceSingleline bdm = allocateNode . BDFForceSingleline =<< bdm--docForceMultiline :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docForceMultiline bdm = allocateNode . BDFForceMultiline =<< bdm--docEnsureIndent-  :: BrIndent -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered-docEnsureIndent ind mbd = mbd >>= \bd -> allocateNode $ BDFEnsureIndent ind bd--unknownNodeError-  :: Data.Data.Data ast-  => String-  -> GenLocated GHC.SrcSpan ast-  -> ToBriDocM BriDocNumbered-unknownNodeError infoStr ast = do-  mTell [ErrorUnknownNode infoStr ast]-  docLit $ Text.pack "{- BRITTANY ERROR UNHANDLED SYNTACTICAL CONSTRUCT -}"--spacifyDocs :: [ToBriDocM BriDocNumbered] -> [ToBriDocM BriDocNumbered]-spacifyDocs [] = []-spacifyDocs ds = fmap appSep (List.init ds) ++ [List.last ds]--briDocMToPPM :: ToBriDocM a -> PPMLocal a-briDocMToPPM m = do-  (x, errs, debugs) <- briDocMToPPMInner m-  mTell debugs-  mTell errs-  return x--briDocMToPPMInner :: ToBriDocM a -> PPMLocal (a, [BrittanyError], Seq String)-briDocMToPPMInner m = do-  readers <- MultiRWSS.mGetRawR-  let ((x, errs), debugs) =-        runIdentity-          $ MultiRWSS.runMultiRWSTNil-          $ MultiRWSS.withMultiStateA (NodeAllocIndex 1)-          $ MultiRWSS.withMultiReaders readers-          $ MultiRWSS.withMultiWriterAW-          $ MultiRWSS.withMultiWriterAW-          $ m-  pure (x, errs, debugs)--docSharedWrapper :: Monad m => (x -> m y) -> x -> m (m y)-docSharedWrapper f x = return <$> f x
− source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs 
@@ -1,437 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Layouters.DataDecl where--import qualified Data.Data-import qualified Data.Semigroup as Semigroup-import qualified Data.Text as Text-import GHC (GenLocated(L), Located)-import qualified GHC-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.Prelude-import Language.Haskell.Brittany.Internal.PreludeUtils-import Language.Haskell.Brittany.Internal.Types----layoutDataDecl-  :: Located (TyClDecl GhcPs)-  -> Located RdrName-  -> LHsQTyVars GhcPs-  -> HsDataDefn GhcPs-  -> ToBriDocM BriDocNumbered-layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of-  -- newtype MyType a b = MyType ..-  HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of-    (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) ->-      docWrapNode ltycl $ do-        nameStr     <- lrdrNameToTextAnn name-        consNameStr <- lrdrNameToTextAnn consName-        tyVarLine   <- return <$> createBndrDoc bndrs-        -- headDoc     <- fmap return $ docSeq-        --   [ appSep $ docLitS "newtype")-        --   , appSep $ docLit nameStr-        --   , appSep tyVarLine-        --   ]-        rhsDoc      <- return <$> createDetailsDoc consNameStr details-        createDerivingPar mDerivs $ docSeq-          [ appSep $ docLitS "newtype"-          , appSep $ docLit nameStr-          , appSep tyVarLine-          , docSeparator-          , docLitS "="-          , docSeparator-          , rhsDoc-          ]-    _ -> briDocByExactNoComment ltycl---  -- data MyData a b-  -- (zero constructors)-  HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->-    docWrapNode ltycl $ do-      lhsContextDoc <- docSharedWrapper createContextDoc lhsContext-      nameStr       <- lrdrNameToTextAnn name-      tyVarLine     <- return <$> createBndrDoc bndrs-      createDerivingPar mDerivs $ docSeq-        [ appSep $ docLitS "data"-        , lhsContextDoc-        , appSep $ docLit nameStr-        , appSep tyVarLine-        ]--  -- data MyData = MyData ..-  -- data MyData = MyData { .. }-  HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->-    case cons of-      (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) ->-        docWrapNode ltycl $ do-          lhsContextDoc <- docSharedWrapper createContextDoc lhsContext-          nameStr       <- lrdrNameToTextAnn name-          consNameStr   <- lrdrNameToTextAnn consName-          tyVarLine     <- return <$> createBndrDoc bndrs-          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-          consDoc <- fmap pure-            $ 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]-          createDerivingPar mDerivs $ docAlt-            [ -- data D = forall a . Show a => D a-              docSeq-              [ docNodeAnnKW ltycl (Just GHC.AnnData)-              $ docSeq-                [ appSep $ docLitS "data"-                , docForceSingleline $ lhsContextDoc-                , appSep $ docLit nameStr-                , appSep tyVarLine-                , docSeparator-                ]-              , 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-              ( docNodeAnnKW ltycl (Just GHC.AnnData)-              $ docSeq-                [ appSep $ docLitS "data"-                , docForceSingleline lhsContextDoc-                , appSep $ docLit nameStr-                , tyVarLine-                ]-              )-              ( docSeq-                [ 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-              ( docNodeAnnKW ltycl (Just GHC.AnnData)-              $ docSeq-                [ appSep $ docLitS "data"-                , docForceSingleline lhsContextDoc-                , appSep $ docLit nameStr-                , tyVarLine-                ]-              )-              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-                , docNodeAnnKW ltycl (Just GHC.AnnData)-                $ docSeq-                  [ appSep $ docLit nameStr-                  , tyVarLine-                  ]-                , consDoc-                ]-              )-            ]-      _ -> briDocByExactNoComment ltycl--  _ -> briDocByExactNoComment ltycl--createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered-createContextDoc [] = docEmpty-createContextDoc [t] =-  docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator]-createContextDoc (t1 : tR) = do-  t1Doc  <- docSharedWrapper layoutType t1-  tRDocs <- tR `forM` docSharedWrapper layoutType-  docAlt-    [ docSeq-      [ docLitS "("-      , docForceSingleline $ docSeq $ List.intersperse docCommaSep-                                                       (t1Doc : tRDocs)-      , docLitS ") =>"-      , docSeparator-      ]-    , docLines $ join-      [ [docSeq [docLitS "(", docSeparator, t1Doc]]-      , tRDocs-        <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc]-      , [docLitS ") =>", docSeparator]-      ]-    ]--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 <- docSharedWrapper layoutType kind-      return $ (lrdrNameToText lrdrName, Just $ d)-  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-createDerivingPar derivs mainDoc = do-  case derivs of-    (L _ []) -> mainDoc-    (L _ types) ->-      docPar mainDoc-        $   docEnsureIndent BrIndentRegular-        $   docLines-        $   docWrapNode derivs-        $   derivingClauseDoc-        <$> types--derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered-derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of-  (L _ []) -> docSeq []-  (L _ ts) ->-    let-      tsLength = length ts-      whenMoreThan1Type val =-        if tsLength > 1 then docLitS val else docLitS ""-      (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy-    in-      docSeq-        [ docDeriving-        , docWrapNodePrior types $ lhsStrategy-        , docSeparator-        , whenMoreThan1Type "("-        , docWrapNodeRest types-          $ docSeq-          $ List.intersperse docCommaSep-          $ ts <&> \case-            HsIB _ t -> layoutType t-        , whenMoreThan1Type ")"-        , rhsStrategy-        ]- where-  strategyLeftRight = \case-    (L _ StockStrategy          ) -> (docLitS " stock", docEmpty)-    (L _ AnyclassStrategy       ) -> (docLitS " anyclass", docEmpty)-    (L _ NewtypeStrategy        ) -> (docLitS " newtype", docEmpty)-    lVia@(L _ (ViaStrategy viaTypes) ) ->-      ( docEmpty-      , case viaTypes of-          HsIB _ext t -> docSeq-            [ docWrapNode lVia $ docLitS " via"-            , docSeparator-            , layoutType t-            ]-      )--docDeriving :: ToBriDocM BriDocNumbered-docDeriving = docLitS "deriving"--createDetailsDoc-  :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered)-createDetailsDoc consNameStr details = case details of-  PrefixCon args -> do-    indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .>  confUnpack-    let-      singleLine = docSeq-        [ docLit consNameStr-        , docSeparator-        , docForceSingleline-          $ docSeq-          $ List.intersperse docSeparator-          $ fmap hsScaledThing args <&> layoutType-        ]-      leftIndented = docSetParSpacing-        . docAddBaseY BrIndentRegular-        . docPar (docLit consNameStr)-        . docLines-        $ layoutType <$> fmap hsScaledThing args-      multiAppended = docSeq-        [ docLit consNameStr-        , docSeparator-        , docSetBaseY $ docLines $ layoutType <$> fmap hsScaledThing args-        ]-      multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar-        (docLit consNameStr)-        (docLines $ layoutType <$> fmap hsScaledThing args)-    case indentPolicy of-      IndentPolicyLeft     -> docAlt [singleLine, leftIndented]-      IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented]-      IndentPolicyFree ->-        docAlt [singleLine, multiAppended, multiIndented, leftIndented]-  RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"]-  RecCon lRec@(L _ fields@(_:_)) -> do-    let ((fName1, fType1) : fDocR) = mkFieldDocs fields-    -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack-    let allowSingleline = False-    docAddBaseY BrIndentRegular-      $ runFilteredAlternative-      $ do-        -- single-line: { i :: Int, b :: Bool }-        addAlternativeCond allowSingleline $ docSeq-          [ docLit consNameStr-          , docSeparator-          , docWrapNodePrior lRec $ docLitS "{"-          , docSeparator-          , docWrapNodeRest lRec-            $ docForceSingleline-            $ docSeq-            $ join-            $ [fName1, docSeparator, docLitS "::", docSeparator, fType1]-              : [ [ docLitS ","-                  , docSeparator-                  , fName-                  , docSeparator-                  , docLitS "::"-                  , docSeparator-                  , fType-                  ]-                | (fName, fType) <- fDocR-                ]-          , docSeparator-          , docLitS "}"-          ]-        addAlternative $ docPar-          (docLit consNameStr)-          (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines-            [ docAlt-              [ docCols ColRecDecl-                [ appSep (docLitS "{")-                , appSep $ docForceSingleline fName1-                , docSeq [docLitS "::", docSeparator]-                , docForceSingleline $ fType1-                ]-              , docSeq-                [ docLitS "{"-                , docSeparator-                , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar-                    fName1-                    (docSeq [docLitS "::", docSeparator, fType1])-                ]-              ]-            , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) ->-                docAlt-                [ docCols ColRecDecl-                  [ docCommaSep-                  , appSep $ docForceSingleline fName-                  , docSeq [docLitS "::", docSeparator]-                  , docForceSingleline fType-                  ]-                , docSeq-                  [ docLitS ","-                  , docSeparator-                  , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar-                      fName-                      (docSeq [docLitS "::", docSeparator, fType])-                  ]-                ]-            , docLitS "}"-            ]-          )-  InfixCon arg1 arg2 -> docSeq-    [ layoutType $ hsScaledThing arg1-    , docSeparator-    , docLit consNameStr-    , docSeparator-    , layoutType $ hsScaledThing arg2-    ]- where-  mkFieldDocs-    :: [LConDeclField GhcPs]-    -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)]-  mkFieldDocs = fmap $ \lField -> case lField of-    L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t--createForallDoc :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)-createForallDoc []            = Nothing-createForallDoc lhsTyVarBndrs = Just $ docSeq-  [docLitS "forall ", createBndrDoc lhsTyVarBndrs]--createNamesAndTypeDoc-  :: Data.Data.Data ast-  => Located ast-  -> [GenLocated t (FieldOcc GhcPs)]-  -> Located (HsType GhcPs)-  -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)-createNamesAndTypeDoc lField names t =-  ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq-    [ docSeq-      $   List.intersperse docCommaSep-      $   names-      <&> \case-        L _ (FieldOcc _ fieldName) ->-            docLit =<< lrdrNameToTextAnn fieldName-    ]-  , docWrapNodeRest lField $ layoutType t-  )
− source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs 
@@ -1,975 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Language.Haskell.Brittany.Internal.Layouters.Decl where--import qualified Data.Data-import qualified Data.Foldable-import qualified Data.Maybe-import qualified Data.Semigroup as Semigroup-import qualified Data.Text as Text-import GHC (AnnKeywordId(..), GenLocated(L))-import GHC.Data.Bag (bagToList, emptyBag)-import qualified GHC.Data.FastString as FastString-import GHC.Hs-import qualified GHC.OldList as List-import GHC.Types.Basic-  ( Activation(..)-  , InlinePragma(..)-  , InlineSpec(..)-  , LexicalFixity(..)-  , RuleMatchInfo(..)-  )-import GHC.Types.SrcLoc (Located, SrcSpan, getLoc, unLoc)-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 Language.Haskell.Brittany.Internal.Layouters.Pattern-import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt-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-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 d@(L loc decl) = case decl of-  SigD _ sig  -> withTransformedAnns d $ layoutSig (L loc sig)-  ValD _ bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case-    Left  ns -> docLines $ return <$> ns-    Right n  -> return n-  TyClD _ tycl           -> withTransformedAnns d $ layoutTyCl (L loc tycl)-  InstD _ (TyFamInstD _ tfid) ->-    withTransformedAnns d $ layoutTyFamInstDecl False d tfid-  InstD _ (ClsInstD _ inst) ->-    withTransformedAnns d $ layoutClsInst (L loc inst)-  _ -> briDocByExactNoComment d------------------------------------------------------------------------------------- Sig-----------------------------------------------------------------------------------layoutSig :: ToBriDoc Sig-layoutSig lsig@(L _loc sig) = case sig of-  TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ-  InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->-    docWrapNode lsig $ do-      nameStr <- lrdrNameToTextAnn name-      specStr <- specStringCompat lsig spec-      let phaseStr = case phaseAct of-            NeverActive      -> "" -- not [] - for NOINLINE NeverActive is-                                   -- in fact the default-            AlwaysActive     -> ""-            ActiveBefore _ i -> "[~" ++ show i ++ "] "-            ActiveAfter  _ i -> "[" ++ show i ++ "] "-            FinalActive      -> error "brittany internal error: FinalActive"-      let conlikeStr = case conlike of-            FunLike -> ""-            ConLike -> "CONLIKE "-      docLit-        $  Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)-        <> nameStr-        <> Text.pack " #-}"-  ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ-  PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ-  _ -> briDocByExactNoComment lsig -- TODO- where-  layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do-    let keyDoc = case mKeyword of-          Just key -> [appSep . docLit $ Text.pack key]-          Nothing -> []-    nameStrs <- names `forM` lrdrNameToTextAnn-    let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs-    typeDoc     <- docSharedWrapper layoutType typ-    hasComments <- hasAnyCommentsBelow lsig-    shouldBeHanging <- mAsk-      <&> _conf_layout-      .>  _lconfig_hangingTypeSignature-      .>  confUnpack-    if shouldBeHanging-      then docSeq $-        [ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr]-        , docSetBaseY $ docLines-          [ docCols-            ColTyOpPrefix-            [ docLit $ Text.pack ":: "-            , docAddBaseY (BrIndentSpecial 3) $ typeDoc-            ]-          ]-        ]-      else layoutLhsAndType-        hasComments-        (appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr])-        "::"-        typeDoc--specStringCompat-  :: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String-specStringCompat ast = \case-  NoUserInline    -> mTell [ErrorUnknownNode "NoUserInline" ast] $> ""-  Inline          -> pure "INLINE "-  Inlinable       -> pure "INLINABLE "-  NoInline        -> pure "NOINLINE "--layoutGuardLStmt :: ToBriDoc' (Stmt GhcPs (LHsExpr GhcPs))-layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of-  BodyStmt _ body _ _      -> layoutExpr body-  BindStmt _ lPat expr -> do-    patDoc <- docSharedWrapper layoutPat lPat-    expDoc <- docSharedWrapper layoutExpr expr-    docCols ColBindStmt-            [ appSep $ colsWrapPat =<< patDoc-            , docSeq [appSep $ docLit $ Text.pack "<-", expDoc]-            ]-  _                        -> unknownNodeError "" lgstmt -- TODO-------------------------------------------------------------------------------------- HsBind-----------------------------------------------------------------------------------layoutBind-  :: ToBriDocC-       (HsBindLR GhcPs GhcPs)-       (Either [BriDocNumbered] BriDocNumbered)-layoutBind lbind@(L _ bind) = case bind of-  FunBind _ fId (MG _ lmatches@(L _ matches) _) [] -> do-    idStr       <- lrdrNameToTextAnn fId-    binderDoc   <- docLit $ Text.pack "="-    funcPatDocs <--      docWrapNode lbind-        $      docWrapNode lmatches-        $      layoutPatternBind (Just idStr) binderDoc-        `mapM` matches-    return $ Left $ funcPatDocs-  PatBind _ pat (GRHSs _ grhss whereBinds) ([], []) -> do-    patDocs    <- colsWrapPat =<< layoutPat pat-    clauseDocs <- layoutGrhs `mapM` grhss-    mWhereDocs <- layoutLocalBinds whereBinds-    let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lbind) -- TODO: is this the right AnnKey?-    binderDoc  <- docLit $ Text.pack "="-    hasComments <- hasAnyCommentsBelow lbind-    fmap Right $ docWrapNode lbind $ layoutPatternBindFinal Nothing-                                                            binderDoc-                                                            (Just patDocs)-                                                            clauseDocs-                                                            mWhereArg-                                                            hasComments-  PatSynBind _ (PSB _ patID lpat rpat dir) -> do-    fmap Right $ docWrapNode lbind $ layoutPatSynBind patID-                                                      lpat-                                                      dir-                                                      rpat-  _ -> Right <$> unknownNodeError "" lbind-layoutIPBind :: ToBriDoc IPBind-layoutIPBind lipbind@(L _ bind) = case bind of-  IPBind _ (Right _) _ -> error "brittany internal error: IPBind Right"-  IPBind _ (Left (L _ (HsIPName name))) expr -> do-    ipName <- docLit $ Text.pack $ '?' : FastString.unpackFS name-    binderDoc <- docLit $ Text.pack "="-    exprDoc <- layoutExpr expr-    hasComments <- hasAnyCommentsBelow lipbind-    layoutPatternBindFinal Nothing binderDoc (Just ipName) [([], exprDoc, expr)] Nothing hasComments---data BagBindOrSig = BagBind (LHsBindLR GhcPs GhcPs)-                  | BagSig (LSig GhcPs)--bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan-bindOrSigtoSrcSpan (BagBind (L l _)) = l-bindOrSigtoSrcSpan (BagSig  (L l _)) = l--layoutLocalBinds-  :: ToBriDocC (HsLocalBindsLR GhcPs GhcPs) (Maybe [BriDocNumbered])-layoutLocalBinds lbinds@(L _ binds) = case binds of-  -- HsValBinds (ValBindsIn lhsBindsLR []) ->-  --   Just . (>>= either id return) . Data.Foldable.toList <$> mapBagM layoutBind lhsBindsLR -- TODO: fix ordering-  -- x@(HsValBinds (ValBindsIn{})) ->-  --   Just . (:[]) <$> unknownNodeError "HsValBinds (ValBindsIn _ (_:_))" x-  HsValBinds _ (ValBinds _ bindlrs sigs) -> do-    let unordered =-          [ BagBind b | b <- Data.Foldable.toList bindlrs ]-            ++ [ BagSig s | s <- sigs ]-        ordered = List.sortOn (ExactPrint.rs . bindOrSigtoSrcSpan) unordered-    docs <- docWrapNode lbinds $ join <$> ordered `forM` \case-      BagBind b -> either id return <$> layoutBind b-      BagSig  s -> return <$> layoutSig s-    return $ Just $ docs---  x@(HsValBinds (ValBindsOut _binds _lsigs)) ->-  HsValBinds _ (XValBindsLR{}) -> error "brittany internal error: XValBindsLR"-  HsIPBinds _ (IPBinds _ bb) ->-    Just <$> mapM layoutIPBind bb-  EmptyLocalBinds{} -> return $ Nothing---- TODO: we don't need the `LHsExpr GhcPs` anymore, now that there is--- parSpacing stuff.B-layoutGrhs-  :: LGRHS GhcPs (LHsExpr GhcPs)-  -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)-layoutGrhs lgrhs@(L _ (GRHS _ guards body)) = do-  guardDocs <- docWrapNode lgrhs $ layoutStmt `mapM` guards-  bodyDoc   <- layoutExpr body-  return (guardDocs, bodyDoc, body)--layoutPatternBind-  :: Maybe Text-  -> BriDocNumbered-  -> LMatch GhcPs (LHsExpr GhcPs)-  -> ToBriDocM BriDocNumbered-layoutPatternBind funId binderDoc lmatch@(L _ match) = do-  let pats                     = m_pats match-  let (GRHSs _ grhss whereBinds) = m_grhss match-  patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p-  let isInfix = isInfixMatch match-  mIdStr <- case match of-    Match _ (FunRhs matchId _ _) _ _ -> Just <$> lrdrNameToTextAnn matchId-    _ -> pure Nothing-  let mIdStr' = fixPatternBindIdentifier match <$> mIdStr-  patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of-    (Just idStr, p1:p2:pr) | isInfix -> if null pr-      then-        docCols ColPatternsFuncInfix-          [ appSep $ docForceSingleline p1-          , appSep $ docLit $ idStr-          , docForceSingleline p2-          ]-      else-        docCols ColPatternsFuncInfix-          (  [docCols ColPatterns-               [ docParenL-               , appSep $ docForceSingleline p1-               , appSep $ docLit $ idStr-               , docForceSingleline p2-               , appSep $ docParenR-               ]-             ]-          ++ (spacifyDocs $ docForceSingleline <$> pr)-          )-    (Just idStr, []) -> docLit idStr-    (Just idStr, ps) ->-      docCols ColPatternsFuncPrefix-        $ appSep (docLit $ idStr)-        : (spacifyDocs $ docForceSingleline <$> ps)-    (Nothing, ps) ->-      docCols ColPatterns-        $ (List.intersperse docSeparator $ docForceSingleline <$> ps)-  clauseDocs <- docWrapNodeRest lmatch $ layoutGrhs `mapM` grhss-  mWhereDocs <- layoutLocalBinds whereBinds-  let mWhereArg = mWhereDocs <&> (,) (mkAnnKey lmatch)-  let alignmentToken = if null pats then Nothing else funId-  hasComments <- hasAnyCommentsBelow lmatch-  layoutPatternBindFinal alignmentToken-                         binderDoc-                         (Just patDoc)-                         clauseDocs-                         mWhereArg-                         hasComments--fixPatternBindIdentifier-  :: Match GhcPs (LHsExpr GhcPs) -> Text -> Text-fixPatternBindIdentifier match idStr = go $ m_ctxt match- where-  go = \case-    (FunRhs _ _ SrcLazy    ) -> Text.cons '~' idStr-    (FunRhs _ _ SrcStrict  ) -> Text.cons '!' idStr-    (FunRhs _ _ NoSrcStrict) -> idStr-    (StmtCtxt ctx1         ) -> goInner ctx1-    _                        -> idStr-  -- I have really no idea if this path ever occurs, but better safe than-  -- risking another "drop bangpatterns" bugs.-  goInner = \case-    (PatGuard      ctx1) -> go ctx1-    (ParStmtCtxt   ctx1) -> goInner ctx1-    (TransStmtCtxt ctx1) -> goInner ctx1-    _                    -> idStr--layoutPatternBindFinal-  :: Maybe Text-  -> BriDocNumbered-  -> Maybe BriDocNumbered-  -> [([BriDocNumbered], BriDocNumbered, LHsExpr GhcPs)]-  -> Maybe (ExactPrint.AnnKey, [BriDocNumbered])-     -- ^ AnnKey for the node that contains the AnnWhere position annotation-  -> Bool-  -> ToBriDocM BriDocNumbered-layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs hasComments = do-  let patPartInline  = case mPatDoc of-        Nothing     -> []-        Just patDoc -> [appSep $ docForceSingleline $ return patDoc]-      patPartParWrap = case mPatDoc of-        Nothing     -> id-        Just patDoc -> docPar (return patDoc)-  whereIndent <- do-    shouldSpecial <- mAsk-      <&> _conf_layout-      .>  _lconfig_indentWhereSpecial-      .>  confUnpack-    regularIndentAmount <- mAsk-      <&> _conf_layout-      .>  _lconfig_indentAmount-      .>  confUnpack-    pure $ if shouldSpecial-      then BrIndentSpecial (max 1 (regularIndentAmount `div` 2))-      else BrIndentRegular-  -- TODO: apart from this, there probably are more nodes below which could-  --       be shared between alternatives.-  wherePartMultiLine :: [ToBriDocM BriDocNumbered] <- case mWhereDocs of-    Nothing  -> return $ []-    Just (annKeyWhere, [w]) -> pure . pure <$> docAlt-      [ docEnsureIndent BrIndentRegular-        $ docSeq-            [ docLit $ Text.pack "where"-            , docSeparator-            , docForceSingleline $ return w-            ]-      , docMoveToKWDP annKeyWhere AnnWhere False-        $ docEnsureIndent whereIndent-        $ docLines-          [ docLit $ Text.pack "where"-          , docEnsureIndent whereIndent-            $ docSetIndentLevel-            $ docNonBottomSpacing-            $ return w-          ]-      ]-    Just (annKeyWhere, ws) ->-      fmap (pure . pure)-        $ docMoveToKWDP annKeyWhere AnnWhere False-        $ docEnsureIndent whereIndent-        $ docLines-          [ docLit $ Text.pack "where"-          , docEnsureIndent whereIndent-            $   docSetIndentLevel-            $   docNonBottomSpacing-            $   docLines-            $   return-            <$> ws-          ]-  let singleLineGuardsDoc guards = appSep $ case guards of-        []  -> docEmpty-        [g] -> docSeq-               [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g]-        gs  -> docSeq-            $  [appSep $ docLit $ Text.pack "|"]-            ++ (List.intersperse docCommaSep-                                 (docForceSingleline . return <$> gs)-               )-      wherePart = case mWhereDocs of-        Nothing  -> Just docEmpty-        Just (_, [w]) -> Just $ docSeq-          [ docSeparator-          , appSep $ docLit $ Text.pack "where"-          , docSetIndentLevel $ docForceSingleline $ return w-          ]-        _        -> Nothing--  indentPolicy <- mAsk-    <&> _conf_layout-    .>  _lconfig_indentPolicy-    .>  confUnpack--  runFilteredAlternative $ do--    case clauseDocs of-      [(guards, body, _bodyRaw)] -> do-        let guardPart = singleLineGuardsDoc guards-        forM_ wherePart $ \wherePart' ->-          -- one-line solution-          addAlternativeCond (not hasComments) $ docCols-            (ColBindingLine alignmentToken)-            [ docSeq (patPartInline ++ [guardPart])-            , docSeq-              [ appSep $ return binderDoc-              , docForceSingleline $ return body-              , wherePart'-              ]-            ]-        -- one-line solution + where in next line(s)-        addAlternativeCond (Data.Maybe.isJust mWhereDocs)-          $ docLines-          $  [ docCols-               (ColBindingLine alignmentToken)-               [ docSeq (patPartInline ++ [guardPart])-               , docSeq-                 [ appSep $ return binderDoc-                 , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body-                 ]-               ]-             ]-          ++ wherePartMultiLine-        -- two-line solution + where in next line(s)-        addAlternative-          $ docLines-          $  [ docForceSingleline-             $ docSeq (patPartInline ++ [guardPart, return binderDoc])-             , docEnsureIndent BrIndentRegular $ docForceSingleline $ return body-             ]-          ++ wherePartMultiLine-        -- pattern and exactly one clause in single line, body as par;-        -- where in following lines-        addAlternative-          $ docLines-          $  [ docCols-               (ColBindingLine alignmentToken)-               [ docSeq (patPartInline ++ [guardPart])-               , docSeq-                 [ appSep $ return binderDoc-                 , docForceParSpacing $ docAddBaseY BrIndentRegular $ return body-                 ]-               ]-             ]-           -- , lineMod $ docAlt-           --   [ docSetBaseY $ return body-           --   , docAddBaseY BrIndentRegular $ return body-           --   ]-          ++ wherePartMultiLine-        -- pattern and exactly one clause in single line, body in new line.-        addAlternative-          $ docLines-          $  [ docSeq (patPartInline ++ [guardPart, return binderDoc])-             , docNonBottomSpacing-             $ docEnsureIndent BrIndentRegular-             $ docAddBaseY BrIndentRegular-             $ return body-             ]-          ++ wherePartMultiLine--      _ -> return () -- no alternatives exclusively when `length clauseDocs /= 1`--    case mPatDoc of-      Nothing     -> return ()-      Just patDoc ->-        -- multiple clauses added in-paragraph, each in a single line-        -- example: foo | bar = baz-        --              | lll = asd-        addAlternativeCond (indentPolicy == IndentPolicyFree)-          $ docLines-          $  [ docSeq-               [ appSep $ docForceSingleline $ return patDoc-               , docSetBaseY-               $   docLines-               $   clauseDocs-               <&> \(guardDocs, bodyDoc, _) -> do-                     let guardPart = singleLineGuardsDoc guardDocs-                     -- the docForceSingleline might seems superflous, but it-                     -- helps the alternative resolving impl.-                     docForceSingleline $ docCols-                       ColGuardedBody-                       [ guardPart-                       , docSeq-                         [ appSep $ return binderDoc-                         , docForceSingleline $ return bodyDoc-                         -- i am not sure if there is a benefit to using-                         -- docForceParSpacing additionally here:-                         -- , docAddBaseY BrIndentRegular $ return bodyDoc-                         ]-                       ]-               ]-             ]-          ++ wherePartMultiLine-    -- multiple clauses, each in a separate, single line-    addAlternative-      $ docLines-      $  [ docAddBaseY BrIndentRegular-           $   patPartParWrap-           $   docLines-           $   map docSetBaseY-           $   clauseDocs-           <&> \(guardDocs, bodyDoc, _) -> do-                 let guardPart = singleLineGuardsDoc guardDocs-                 -- the docForceSingleline might seems superflous, but it-                 -- helps the alternative resolving impl.-                 docForceSingleline $ docCols-                   ColGuardedBody-                   [ guardPart-                   , docSeq-                     [ appSep $ return binderDoc-                     , docForceSingleline $ return bodyDoc-                     -- i am not sure if there is a benefit to using-                     -- docForceParSpacing additionally here:-                     -- , docAddBaseY BrIndentRegular $ return bodyDoc-                     ]-                   ]-         ]-      ++ wherePartMultiLine-    -- multiple clauses, each with the guard(s) in a single line, body-    -- as a paragraph-    addAlternative-      $ docLines-      $  [ docAddBaseY BrIndentRegular-           $   patPartParWrap-           $   docLines-           $   map docSetBaseY-           $   clauseDocs-           <&> \(guardDocs, bodyDoc, _) ->-                 docSeq-                 $ ( case guardDocs of-                     [] -> []-                     [g] ->-                       [ docForceSingleline-                       $ docSeq [appSep $ docLit $ Text.pack "|", return g]-                       ]-                     gs ->-                       [  docForceSingleline-                       $  docSeq-                       $  [appSep $ docLit $ Text.pack "|"]-                       ++ List.intersperse docCommaSep (return <$> gs)-                       ]-                   )-                   ++ [ docSeparator-                      , docCols-                        ColOpPrefix-                        [ appSep $ return binderDoc-                        , docAddBaseY BrIndentRegular-                        $ docForceParSpacing-                        $ return bodyDoc-                        ]-                      ]-         ]-      ++ wherePartMultiLine-    -- multiple clauses, each with the guard(s) in a single line, body-    -- in a new line as a paragraph-    addAlternative-      $ docLines-      $  [ docAddBaseY BrIndentRegular-           $   patPartParWrap-           $   docLines-           $   map docSetBaseY-           $   clauseDocs-           >>= \(guardDocs, bodyDoc, _) ->-                 ( case guardDocs of-                   [] -> []-                   [g] ->-                     [ docForceSingleline-                     $ docSeq [appSep $ docLit $ Text.pack "|", return g]-                     ]-                   gs ->-                     [  docForceSingleline-                     $  docSeq-                     $  [appSep $ docLit $ Text.pack "|"]-                     ++ List.intersperse docCommaSep (return <$> gs)-                     ]-                 )-                 ++ [ docCols-                      ColOpPrefix-                      [ appSep $ return binderDoc-                      , docAddBaseY BrIndentRegular-                      $ docForceParSpacing-                      $ return bodyDoc-                      ]-                    ]-         ]-      ++ wherePartMultiLine-    -- conservative approach: everything starts on the left.-    addAlternative-      $ docLines-      $  [ docAddBaseY BrIndentRegular-           $   patPartParWrap-           $   docLines-           $   map docSetBaseY-           $   clauseDocs-           >>= \(guardDocs, bodyDoc, _) ->-                 ( case guardDocs of-                     [] -> []-                     [g] ->-                       [docSeq [appSep $ docLit $ Text.pack "|", return g]]-                     (g1:gr) ->-                       ( docSeq [appSep $ docLit $ Text.pack "|", return g1]-                       : (   gr-                         <&> \g ->-                               docSeq-                                 [appSep $ docLit $ Text.pack ",", return g]-                         )-                       )-                   )-                   ++ [ docCols-                        ColOpPrefix-                        [ appSep $ return binderDoc-                        , docAddBaseY BrIndentRegular $ return bodyDoc-                        ]-                      ]-         ]-      ++ wherePartMultiLine---- | Layout a pattern synonym binding-layoutPatSynBind-  :: Located (IdP GhcPs)-  -> HsPatSynDetails (Located (IdP GhcPs))-  -> HsPatSynDir GhcPs-  -> LPat GhcPs-  -> ToBriDocM BriDocNumbered-layoutPatSynBind name patSynDetails patDir rpat = do-  let patDoc = docLit $ Text.pack "pattern"-      binderDoc = case patDir of-        ImplicitBidirectional -> docLit $ Text.pack "="-        _ -> docLit $ Text.pack "<-"-      body = colsWrapPat =<< layoutPat rpat-      whereDoc = docLit $ Text.pack "where"-  mWhereDocs <- layoutPatSynWhere patDir-  headDoc <- fmap pure $ docSeq $-    [ patDoc-    , docSeparator-    , layoutLPatSyn name patSynDetails-    , docSeparator-    , binderDoc-    ]-  runFilteredAlternative $ do-    addAlternative $-      -- pattern .. where-      --   ..-      --   ..-      docAddBaseY BrIndentRegular $ docSeq-        (  [headDoc, docSeparator, body]-        ++ case mWhereDocs of-            Just ds -> [docSeparator, docPar whereDoc (docLines ds)]-            Nothing -> []-        )-    addAlternative $-      -- pattern .. =-      --   ..-      -- pattern .. <--      --   .. where-      --   ..-      --   ..-      docAddBaseY BrIndentRegular $ docPar-        headDoc-        (case mWhereDocs of-          Nothing -> body-          Just ds -> docLines ([ docSeq [body, docSeparator, whereDoc] ] ++ ds)-        )---- | Helper method for the left hand side of a pattern synonym-layoutLPatSyn-  :: Located (IdP GhcPs)-  -> HsPatSynDetails (Located (IdP GhcPs))-  -> ToBriDocM BriDocNumbered-layoutLPatSyn name (PrefixCon vars) = do-  docName <- lrdrNameToTextAnn name-  names <- mapM lrdrNameToTextAnn vars-  docSeq . fmap appSep $ docLit docName : (docLit <$> names)-layoutLPatSyn name (InfixCon left right) = do-  leftDoc <- lrdrNameToTextAnn left-  docName <- lrdrNameToTextAnn name-  rightDoc <- lrdrNameToTextAnn right-  docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc]-layoutLPatSyn name (RecCon recArgs) = do-  docName <- lrdrNameToTextAnn name-  args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs-  docSeq . fmap docLit-    $  [docName, Text.pack " { " ]-    <> intersperse (Text.pack ", ") args-    <> [Text.pack " }"]---- | Helper method to get the where clause from of explicitly bidirectional--- pattern synonyms-layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [ToBriDocM BriDocNumbered])-layoutPatSynWhere hs = case hs of-  ExplicitBidirectional (MG _ (L _ lbinds) _) -> do-    binderDoc <- docLit $ Text.pack "="-    Just <$> mapM (docSharedWrapper $ layoutPatternBind Nothing binderDoc) lbinds-  _ -> pure Nothing------------------------------------------------------------------------------------- TyClDecl-----------------------------------------------------------------------------------layoutTyCl :: ToBriDoc TyClDecl-layoutTyCl ltycl@(L _loc tycl) = case tycl of-  SynDecl _ name vars fixity typ -> do-    let isInfix = case fixity of-          Prefix -> False-          Infix  -> True-    -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP-    -- let parenWrapper = if hasTrailingParen-    --       then appSep . docWrapNodeRest ltycl-    --       else id-    let wrapNodeRest = docWrapNodeRest ltycl-    docWrapNodePrior ltycl-      $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ-  DataDecl _ext name tyVars _ dataDefn ->-    layoutDataDecl ltycl name tyVars dataDefn-  _ -> briDocByExactNoComment ltycl--layoutSynDecl-  :: Bool-  -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered)-  -> Located (IdP GhcPs)-  -> [LHsTyVarBndr () GhcPs]-  -> LHsType GhcPs-  -> ToBriDocM BriDocNumbered-layoutSynDecl isInfix wrapNodeRest name vars typ = do-  nameStr <- lrdrNameToTextAnn name-  let-    lhs = appSep . wrapNodeRest $ if isInfix-      then do-        let (a : b : rest) = vars-        hasOwnParens <- hasAnnKeywordComment a AnnOpenP-        -- This isn't quite right, but does give syntactically valid results-        let needsParens = not (null rest) || hasOwnParens-        docSeq-          $  [ docLit $ Text.pack "type"-             , docSeparator-             ]-          ++ [ docParenL | needsParens ]-          ++ [ layoutTyVarBndr False a-             , docSeparator-             , docLit nameStr-             , docSeparator-             , layoutTyVarBndr False b-             ]-          ++ [ docParenR | needsParens ]-          ++ fmap (layoutTyVarBndr True) rest-      else-        docSeq-        $  [ docLit $ Text.pack "type"-           , docSeparator-           , docWrapNode name $ docLit nameStr-           ]-        ++ fmap (layoutTyVarBndr True) vars-  sharedLhs   <- docSharedWrapper id lhs-  typeDoc     <- docSharedWrapper layoutType typ-  hasComments <- hasAnyCommentsConnected typ-  layoutLhsAndType hasComments sharedLhs "=" typeDoc--layoutTyVarBndr :: Bool -> ToBriDoc (HsTyVarBndr ())-layoutTyVarBndr needsSep lbndr@(L _ bndr) = do-  docWrapNodePrior lbndr $ case bndr of-    UserTyVar _ _ name -> do-      nameStr <- lrdrNameToTextAnn name-      docSeq $ [docSeparator | needsSep] ++ [docLit nameStr]-    KindedTyVar _ _ name kind -> do-      nameStr <- lrdrNameToTextAnn name-      docSeq-        $  [ docSeparator | needsSep ]-        ++ [ docLit $ Text.pack "("-           , appSep $ docLit nameStr-           , appSep . docLit $ Text.pack "::"-           , docForceSingleline $ layoutType kind-           , docLit $ Text.pack ")"-           ]-------------------------------------------------------------------------------------- TyFamInstDecl-------------------------------------------------------------------------------------layoutTyFamInstDecl-  :: Data.Data.Data a-  => Bool-  -> Located a-  -> TyFamInstDecl GhcPs-  -> ToBriDocM BriDocNumbered-layoutTyFamInstDecl inClass outerNode tfid = do-  let-    FamEqn _ name bndrsMay pats _fixity typ = hsib_body $ tfid_eqn tfid-    -- bndrsMay isJust e.g. with-    --   type instance forall a . MyType (Maybe a) = Either () a-    innerNode = outerNode-  docWrapNodePrior outerNode $ do-    nameStr   <- lrdrNameToTextAnn name-    needsParens <- hasAnnKeyword outerNode AnnOpenP-    let-      instanceDoc = if inClass-        then docLit $ Text.pack "type"-        else docSeq-          [appSep . docLit $ Text.pack "type", docLit $ Text.pack "instance"]-      makeForallDoc :: [LHsTyVarBndr () GhcPs] -> ToBriDocM BriDocNumbered-      makeForallDoc bndrs = do-        bndrDocs <- layoutTyVarBndrs bndrs-        docSeq-          (  [docLit (Text.pack "forall")]-          ++ processTyVarBndrsSingleline bndrDocs-          )-      lhs =-        docWrapNode innerNode-          .  docSeq-          $  [appSep instanceDoc]-          ++ [ makeForallDoc foralls | Just foralls <- [bndrsMay] ]-          ++ [ docParenL | needsParens ]-          ++ [appSep $ docWrapNode name $ docLit nameStr]-          ++ intersperse docSeparator (layoutHsTyPats pats)-          ++ [ docParenR | needsParens ]-    hasComments <- (||)-      <$> hasAnyRegularCommentsConnected outerNode-      <*> hasAnyRegularCommentsRest innerNode-    typeDoc <- docSharedWrapper layoutType typ-    layoutLhsAndType hasComments lhs "=" typeDoc---layoutHsTyPats :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] -> [ToBriDocM BriDocNumbered]-layoutHsTyPats pats = pats <&> \case-  HsValArg tm     -> layoutType tm-  HsTypeArg _l ty -> docSeq [docLit $ Text.pack "@", layoutType ty]-    -- we ignore the SourceLoc here.. this LPat not being (L _ Pat{}) change-    -- is a bit strange. Hopefully this does not ignore any important-    -- annotations.-  HsArgPar _l     -> error "brittany internal error: HsArgPar{}"------------------------------------------------------------------------------------- ClsInstDecl------------------------------------------------------------------------------------- | Layout an @instance@ declaration------   Layout signatures and bindings using the corresponding layouters from the---   top-level. Layout the instance head, type family instances, and data family---   instances using ExactPrint.-layoutClsInst :: ToBriDoc ClsInstDecl-layoutClsInst lcid@(L _ cid) = docLines-  [ layoutInstanceHead-  , docEnsureIndent BrIndentRegular-  $  docSetIndentLevel-  $  docSortedLines-  $  fmap layoutAndLocateSig          (cid_sigs cid)-  ++ fmap layoutAndLocateBind         (bagToList $ cid_binds cid)-  ++ fmap layoutAndLocateTyFamInsts   (cid_tyfam_insts cid)-  ++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid)-  ]- where-  layoutInstanceHead :: ToBriDocM BriDocNumbered-  layoutInstanceHead =-    briDocByExactNoComment-      $   InstD NoExtField-      .   ClsInstD NoExtField-      .   removeChildren-      <$> lcid--  removeChildren :: ClsInstDecl GhcPs -> ClsInstDecl GhcPs-  removeChildren c = c-    { cid_binds         = emptyBag-    , cid_sigs          = []-    , cid_tyfam_insts   = []-    , cid_datafam_insts = []-    }--  -- | Like 'docLines', but sorts the lines based on location-  docSortedLines-    :: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered-  docSortedLines l =-    allocateNode . BDFLines . fmap unLoc . List.sortOn (ExactPrint.rs . getLoc) =<< sequence l--  layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered)-  layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig--  layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered)-  layoutAndLocateBind lbind@(L loc _) =-    L loc <$> (joinBinds =<< layoutBind lbind)--  joinBinds-    :: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered-  joinBinds = \case-    Left  ns -> docLines $ return <$> ns-    Right n  -> return n--  layoutAndLocateTyFamInsts-    :: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered)-  layoutAndLocateTyFamInsts ltfid@(L loc tfid) =-    L loc <$> layoutTyFamInstDecl True ltfid tfid--  layoutAndLocateDataFamInsts-    :: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered)-  layoutAndLocateDataFamInsts ldfid@(L loc _) =-    L loc <$> layoutDataFamInstDecl ldfid--  -- | Send to ExactPrint then remove unecessary whitespace-  layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl-  layoutDataFamInstDecl ldfid =-    fmap stripWhitespace <$> briDocByExactNoComment ldfid--  -- | ExactPrint adds indentation/newlines to @data@/@type@ declarations-  stripWhitespace :: BriDocF f -> BriDocF f-  stripWhitespace (BDFExternal ann anns b t) =-    BDFExternal ann anns b $ stripWhitespace' t-  stripWhitespace b = b--  -- | This fixes two issues of output coming from Exactprinting-  --   associated (data) type decls. Firstly we place the output into docLines,-  --   so one newline coming from Exactprint is superfluous, so we drop the-  --   first (empty) line. The second issue is Exactprint indents the first-  --   member in a strange fashion:-  ---  --   input:-  ---  --   > instance MyClass Int where-  --   >   -- | This data is very important-  --   >   data MyData = IntData-  --   >     { intData  :: String-  --   >     , intData2 :: Int-  --   >     }-  ---  --   output of just exactprinting the associated data type syntax node-  ---  --   >-  --   >   -- | This data is very important-  --   >   data MyData = IntData-  --   >   { intData  :: String-  --   >   , intData2 :: Int-  --   >   }-  ---  --   To fix this, we strip whitespace from the start of the comments and the-  --   first line of the declaration, stopping when we see "data" or "type" at-  --   the start of a line. I.e., this function yields-  ---  --   > -- | This data is very important-  --   > data MyData = IntData-  --   >   { intData  :: String-  --   >   , intData2 :: Int-  --   >   }-  ---  --   Downside apart from being a hacky and brittle fix is that this removes-  --   possible additional indentation from comments before the first member.-  ---  --   But the whole thing is just a temporary measure until brittany learns-  --   to layout data/type decls.-  stripWhitespace' :: Text -> Text-  stripWhitespace' t =-    Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t-   where-    go []              = []-    go (line1 : lineR) = case Text.stripStart line1 of-      st | isTypeOrData st -> st : lineR-         | otherwise       -> st : go lineR-    isTypeOrData t' =-      (Text.pack "type" `Text.isPrefixOf` t')-        || (Text.pack "newtype" `Text.isPrefixOf` t')-        || (Text.pack "data" `Text.isPrefixOf` t')-------------------------------------------------------------------------------------- Common Helpers-----------------------------------------------------------------------------------layoutLhsAndType-  :: Bool-  -> ToBriDocM BriDocNumbered-  -> String-  -> ToBriDocM BriDocNumbered-  -> ToBriDocM BriDocNumbered-layoutLhsAndType hasComments lhs sep typeDoc = do-  runFilteredAlternative $ do-    -- (separators probably are "=" or "::")-    -- lhs = type-    -- lhs :: type-    addAlternativeCond (not hasComments) $ docSeq-      [lhs, docSeparator, docLitS sep, docSeparator, docForceSingleline typeDoc]-    -- lhs-    --   :: typeA-    --   -> typeB-    -- lhs-    --   =  typeA-    --   -> typeB-    addAlternative $ docAddBaseY BrIndentRegular $ docPar lhs $ docCols-      ColTyOpPrefix-      [ appSep $ docLitS sep-      , docAddBaseY (BrIndentSpecial (length sep + 1)) typeDoc-      ]
− source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs 
@@ -1,1078 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MonadComprehensions #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Layouters.Expr where--import qualified Data.Data-import qualified Data.Semigroup as Semigroup-import qualified Data.Sequence as Seq-import qualified Data.Text as Text-import GHC (AnnKeywordId(..), GenLocated(L), RdrName(..), SrcSpan)-import qualified GHC.Data.FastString as FastString-import GHC.Hs-import qualified GHC.OldList as List-import GHC.Types.Basic-import GHC.Types.Name-import Language.Haskell.Brittany.Internal.Config.Types-import Language.Haskell.Brittany.Internal.LayouterBasics-import Language.Haskell.Brittany.Internal.Layouters.Decl-import Language.Haskell.Brittany.Internal.Layouters.Pattern-import Language.Haskell.Brittany.Internal.Layouters.Stmt-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-import Language.Haskell.Brittany.Internal.Utils----layoutExpr :: ToBriDoc HsExpr-layoutExpr lexpr@(L _ expr) = do-  indentPolicy <- mAsk-    <&> _conf_layout-    .>  _lconfig_indentPolicy-    .>  confUnpack-  let allowFreeIndent = indentPolicy == IndentPolicyFree-  docWrapNode lexpr $ case expr of-    HsVar _ vname -> do-      docLit =<< lrdrNameToTextAnn vname-    HsUnboundVar _ oname ->-      docLit $ Text.pack $ occNameString oname-    HsRecFld{} -> do-      -- TODO-      briDocByExactInlineOnly "HsRecFld" lexpr-    HsOverLabel _ext _reboundFromLabel name ->-      let label = FastString.unpackFS name-      in docLit . Text.pack $ '#' : label-    HsIPVar _ext (HsIPName name) ->-      let label = FastString.unpackFS name-      in docLit . Text.pack $ '?' : label-    HsOverLit _ olit -> do-      allocateNode $ overLitValBriDoc $ ol_val olit-    HsLit _ lit -> do-      allocateNode $ litBriDoc lit-    HsLam _ (MG _ (L _ [lmatch@(L _ match)]) _)-      |  pats                  <- m_pats match-      ,  GRHSs _ [lgrhs] llocals <- m_grhss match-      ,  L _ EmptyLocalBinds {} <- llocals-      ,  L _ (GRHS _ [] body)     <- lgrhs-      -> do-      patDocs <- zip (True : repeat False) pats `forM` \(isFirst, p) ->-        fmap return $ do-          -- this code could be as simple as `colsWrapPat =<< layoutPat p`-          -- if it was not for the following two cases:-          -- \ !x -> x-          -- \ ~x -> x-          -- These make it necessary to special-case an additional separator.-          -- (TODO: we create a BDCols here, but then make it ineffective-          -- by wrapping it in docSeq below. We _could_ add alignments for-          -- stuff like lists-of-lambdas. Nothing terribly important..)-          let shouldPrefixSeparator = case p of-                L _ LazyPat{} -> isFirst-                L _ BangPat{} -> isFirst-                _               -> False-          patDocSeq <- layoutPat p-          fixed <- case Seq.viewl patDocSeq of-            p1 Seq.:< pr | shouldPrefixSeparator -> do-              p1' <- docSeq [docSeparator, pure p1]-              pure (p1' Seq.<| pr)-            _ -> pure patDocSeq-          colsWrapPat fixed-      bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body-      let funcPatternPartLine =-            docCols ColCasePattern-              (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))-      docAlt-        [ -- single line-          docSeq-          [ docLit $ Text.pack "\\"-          , docWrapNode lmatch $ docForceSingleline funcPatternPartLine-          , appSep $ docLit $ Text.pack "->"-          , docWrapNode lgrhs $ docForceSingleline bodyDoc-          ]-          -- double line-        , docSetParSpacing-        $ docAddBaseY BrIndentRegular-        $ docPar-          (docSeq-            [ docLit $ Text.pack "\\"-            , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine-            , docLit $ Text.pack "->"-            ])-          (docWrapNode lgrhs $ docForceSingleline bodyDoc)-          -- wrapped par spacing-        , docSetParSpacing-        $ docSeq-          [ docLit $ Text.pack "\\"-          , docWrapNode lmatch $ docForceSingleline funcPatternPartLine-          , appSep $ docLit $ Text.pack "->"-          , docWrapNode lgrhs $ docForceParSpacing bodyDoc-          ]-          -- conservative-        , docSetParSpacing-        $ docAddBaseY BrIndentRegular-        $ docPar-          (docSeq-            [ docLit $ Text.pack "\\"-            , docWrapNode lmatch $ appSep $ docForceSingleline funcPatternPartLine-            , docLit $ Text.pack "->"-            ])-          (docWrapNode lgrhs $ docNonBottomSpacing bodyDoc)-        ]-    HsLam{} ->-      unknownNodeError "HsLam too complex" lexpr-    HsLamCase _ (MG _ (L _ []) _) -> do-      docSetParSpacing $ docAddBaseY BrIndentRegular $-        (docLit $ Text.pack "\\case {}")-    HsLamCase _ (MG _ lmatches@(L _ matches) _) -> do-      binderDoc   <- docLit $ Text.pack "->"-      funcPatDocs <- docWrapNode lmatches-        $ layoutPatternBind Nothing binderDoc `mapM` matches-      docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar-        (docLit $ Text.pack "\\case")-        (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)-    HsApp _ exp1@(L _ HsApp{}) exp2 -> do-      let gather :: [LHsExpr GhcPs] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs])-          gather list = \case-            L _ (HsApp _ l r) -> gather (r:list) l-            x               -> (x, list)-      let (headE, paramEs) = gather [exp2] exp1-      let colsOrSequence = case headE of-            L _ (HsVar _ (L _ (Unqual occname))) ->-              docCols (ColApp $ Text.pack $ occNameString occname)-            _ -> docSeq-      headDoc <- docSharedWrapper layoutExpr headE-      paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs-      hasComments <- hasAnyCommentsConnected exp2-      runFilteredAlternative $ do-        -- foo x y-        addAlternativeCond (not hasComments)-          $ colsOrSequence-          $ appSep (docForceSingleline headDoc)-          : spacifyDocs (docForceSingleline <$> paramDocs)-        -- foo x-        --     y-        addAlternativeCond allowFreeIndent-          $ docSeq-          [ appSep (docForceSingleline headDoc)-          , docSetBaseY-          $ docAddBaseY BrIndentRegular-          $ docLines-          $ docForceSingleline <$> paramDocs-          ]-        -- foo-        --   x-        --   y-        addAlternative-          $ docSetParSpacing-          $ docAddBaseY BrIndentRegular-          $ docPar-            (docForceSingleline headDoc)-            ( docNonBottomSpacing-            $ docLines paramDocs-            )-        -- ( multi-        --   line-        --   function-        -- )-        --   x-        --   y-        addAlternative-          $ docAddBaseY BrIndentRegular-          $ docPar-            headDoc-            ( docNonBottomSpacing-            $ docLines paramDocs-            )-    HsApp _ exp1 exp2 -> do-      -- TODO: if expDoc1 is some literal, we may want to create a docCols here.-      expDoc1 <- docSharedWrapper layoutExpr exp1-      expDoc2 <- docSharedWrapper layoutExpr exp2-      docAlt-        [ -- func arg-          docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2]-        , -- func argline1-          --   arglines-          -- e.g.-          -- func Abc-          --   { member1 = True-          --   , member2 = 13-          --   }-          docSetParSpacing -- this is most likely superfluous because-                           -- this is a sequence of a one-line and a par-space-                           -- anyways, so it is _always_ par-spaced.-        $ docAddBaseY BrIndentRegular-        $ docSeq-          [ appSep $ docForceSingleline expDoc1-          , docForceParSpacing expDoc2-          ]-        , -- func-          --   arg-          docSetParSpacing-        $ docAddBaseY BrIndentRegular-        $ docPar-          (docForceSingleline expDoc1)-          (docNonBottomSpacing expDoc2)-        , -- fu-          --   nc-          --   ar-          --     gument-          docAddBaseY BrIndentRegular-        $ docPar-          expDoc1-          expDoc2-        ]-    HsAppType _ exp1 (HsWC _ ty1) -> do-      t <- docSharedWrapper layoutType ty1-      e <- docSharedWrapper layoutExpr exp1-      docAlt-        [ docSeq-            [ docForceSingleline e-            , docSeparator-            , docLit $ Text.pack "@"-            , docForceSingleline t-            ]-        , docPar-            e-            (docSeq [docLit $ Text.pack "@", t ])-        ]-    OpApp _ expLeft@(L _ OpApp{}) expOp expRight -> do-      let gather :: [(LHsExpr GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs -> (LHsExpr GhcPs, [(LHsExpr GhcPs, LHsExpr GhcPs)])-          gather opExprList = \case-            (L _ (OpApp _ l1 op1 r1)) -> gather ((op1, r1): opExprList) l1-            final -> (final, opExprList)-          (leftOperand, appList) = gather [] expLeft-      leftOperandDoc <- docSharedWrapper layoutExpr leftOperand-      appListDocs <- appList `forM` \(x,y) -> [ (xD, yD)-                                              | xD <- docSharedWrapper layoutExpr x-                                              , yD <- docSharedWrapper layoutExpr y-                                              ]-      opLastDoc   <- docSharedWrapper layoutExpr expOp-      expLastDoc  <- docSharedWrapper layoutExpr expRight-      allowSinglelinePar <- do-        hasComLeft <- hasAnyCommentsConnected expLeft-        hasComOp   <- hasAnyCommentsConnected expOp-        pure $ not hasComLeft && not hasComOp-      let allowPar = case (expOp, expRight) of-            (L _ (HsVar _ (L _ (Unqual occname))), _)-              | occNameString occname == "$" -> True-            (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False-            _ -> True-      runFilteredAlternative $ do-        -- > one + two + three-        -- or-        -- > one + two + case x of-        -- >   _ -> three-        addAlternativeCond allowSinglelinePar-          $ docSeq-          [ appSep $ docForceSingleline leftOperandDoc-          , docSeq-          $ appListDocs <&> \(od, ed) -> docSeq-              [ appSep $ docForceSingleline od-              , appSep $ docForceSingleline ed-              ]-          , appSep $ docForceSingleline opLastDoc-          , (if allowPar then docForceParSpacing else docForceSingleline)-              expLastDoc-          ]-        -- this case rather leads to some unfortunate layouting than to anything-        -- useful; disabling for now. (it interfers with cols stuff.)-        -- addAlternative-        --   $ docSetBaseY-        --   $ docPar-        --     leftOperandDoc-        --     ( docLines-        --      $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])-        --       ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]-        --     )-        -- > one-        -- >   + two-        -- >   + three-        addAlternative $-          docPar-            leftOperandDoc-            ( docLines-            $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])-              ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]-            )-    OpApp _ expLeft expOp expRight -> do-      expDocLeft  <- docSharedWrapper layoutExpr expLeft-      expDocOp    <- docSharedWrapper layoutExpr expOp-      expDocRight <- docSharedWrapper layoutExpr expRight-      let allowPar = case (expOp, expRight) of-            (L _ (HsVar _ (L _ (Unqual occname))), _)-              | occNameString occname == "$" -> True-            (_, L _ (HsApp _ _ (L _ HsVar{}))) -> False-            _ -> True-      let leftIsDoBlock = case expLeft of-            L _ HsDo{} -> True-            _          -> False-      runFilteredAlternative $ do-        -- one-line-        addAlternative-          $ docSeq-          [ appSep $ docForceSingleline expDocLeft-          , appSep $ docForceSingleline expDocOp-          , docForceSingleline expDocRight-          ]-        -- -- line + freely indented block for right expression-        -- addAlternative-        --   $ docSeq-        --   [ appSep $ docForceSingleline expDocLeft-        --   , appSep $ docForceSingleline expDocOp-        --   , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight-        --   ]-        -- two-line-        addAlternative $ do-          let-            expDocOpAndRight = docForceSingleline-              $ docCols ColOpPrefix [appSep $ expDocOp, docSetBaseY expDocRight]-          if leftIsDoBlock-            then docLines [expDocLeft, expDocOpAndRight]-            else docAddBaseY BrIndentRegular $ docPar expDocLeft expDocOpAndRight-              -- TODO: in both cases, we don't force expDocLeft to be-              -- single-line, which has certain.. interesting consequences.-              -- At least, the "two-line" label is not entirely-              -- accurate.-        -- one-line + par-        addAlternativeCond allowPar-          $ docSeq-          [ appSep $ docForceSingleline expDocLeft-          , appSep $ docForceSingleline expDocOp-          , docForceParSpacing expDocRight-          ]-        -- more lines-        addAlternative $ do-          let expDocOpAndRight =-                docCols ColOpPrefix [appSep expDocOp, docSetBaseY expDocRight]-          if leftIsDoBlock-            then docLines [expDocLeft, expDocOpAndRight]-            else docAddBaseY BrIndentRegular-                   $ docPar expDocLeft expDocOpAndRight-    NegApp _ op _ -> do-      opDoc <- docSharedWrapper layoutExpr op-      docSeq [ docLit $ Text.pack "-"-             , opDoc-             ]-    HsPar _ innerExp -> do-      innerExpDoc <- docSharedWrapper (docWrapNode lexpr . layoutExpr) innerExp-      docAlt-        [ docSeq-          [ docLit $ Text.pack "("-          , docForceSingleline innerExpDoc-          , docLit $ Text.pack ")"-          ]-        , docSetBaseY $ docLines-          [ docCols ColOpPrefix-            [ docLit $ Text.pack "("-            , docAddBaseY (BrIndentSpecial 2) innerExpDoc-            ]-          , docLit $ Text.pack ")"-          ]-        ]-    SectionL _ left op -> do -- TODO: add to testsuite-      leftDoc <- docSharedWrapper layoutExpr left-      opDoc   <- docSharedWrapper layoutExpr op-      docSeq [leftDoc, docSeparator, opDoc]-    SectionR _ op right -> do -- TODO: add to testsuite-      opDoc    <- docSharedWrapper layoutExpr op-      rightDoc <- docSharedWrapper layoutExpr right-      docSeq [opDoc, docSeparator, rightDoc]-    ExplicitTuple _ args boxity -> do-      let argExprs = args <&> \arg -> case arg of-            (L _ (Present _ e)) -> (arg, Just e);-            (L _ (Missing NoExtField)) -> (arg, Nothing)-      argDocs <- forM argExprs-        $ docSharedWrapper-        $ \(arg, exprM) -> docWrapNode arg $ maybe docEmpty layoutExpr exprM-      hasComments <- orM-        ( hasCommentsBetween lexpr  AnnOpenP AnnCloseP-        : map hasAnyCommentsBelow args-        )-      let (openLit, closeLit) = case boxity of-            Boxed   -> (docLit $ Text.pack "(", docLit $ Text.pack ")")-            Unboxed -> (docParenHashLSep, docParenHashRSep)-      case splitFirstLast argDocs of-        FirstLastEmpty -> docSeq-          [ openLit-          , docNodeAnnKW lexpr (Just AnnOpenP) closeLit-          ]-        FirstLastSingleton e -> docAlt-          [ docCols ColTuple-            [ openLit-            , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e-            , closeLit-            ]-          , docSetBaseY $ docLines-            [ docSeq-              [ openLit-              , docNodeAnnKW lexpr (Just AnnOpenP) $ docForceSingleline e-              ]-            , closeLit-            ]-          ]-        FirstLast e1 ems eN -> runFilteredAlternative $ do-          addAlternativeCond (not hasComments)-            $  docCols ColTuple-            $  [docSeq [openLit, docForceSingleline e1]]-            ++ (ems <&> \e -> docSeq [docCommaSep, docForceSingleline e])-            ++ [docSeq [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) (docForceSingleline eN), closeLit]]-          addAlternative $-            let-              start = docCols ColTuples-                        [appSep openLit, e1]-              linesM = ems <&> \d ->-                      docCols ColTuples [docCommaSep, d]-              lineN = docCols ColTuples [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenP) eN]-              end   = closeLit-            in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN, end]-    HsCase _ cExp (MG _ (L _ []) _) -> do-      cExpDoc <- docSharedWrapper layoutExpr cExp-      docAlt-        [ docAddBaseY BrIndentRegular-        $ docSeq-            [ appSep $ docLit $ Text.pack "case"-            , appSep $ docForceSingleline cExpDoc-            , docLit $ Text.pack "of {}"-            ]-        , docPar-            ( docAddBaseY BrIndentRegular-            $ docPar (docLit $ Text.pack "case") cExpDoc-            )-            (docLit $ Text.pack "of {}")-        ]-    HsCase _ cExp (MG _ lmatches@(L _ matches) _) -> do-      cExpDoc <- docSharedWrapper layoutExpr cExp-      binderDoc <- docLit $ Text.pack "->"-      funcPatDocs <- docWrapNode lmatches-        $ layoutPatternBind Nothing binderDoc `mapM` matches-      docAlt-        [ docSetParSpacing-        $ docAddBaseY BrIndentRegular-        $ docPar-          ( docSeq-            [ appSep $ docLit $ Text.pack "case"-            , appSep $ docForceSingleline cExpDoc-            , docLit $ Text.pack "of"-            ])-          (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)-        , docPar-            ( docAddBaseY BrIndentRegular-            $ docPar (docLit $ Text.pack "case") cExpDoc-            )-            ( docAddBaseY BrIndentRegular-            $ docPar (docLit $ Text.pack "of")-              (docSetBaseAndIndent $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)-            )-        ]-    HsIf _ ifExpr thenExpr elseExpr -> do-      ifExprDoc   <- docSharedWrapper layoutExpr ifExpr-      thenExprDoc <- docSharedWrapper layoutExpr thenExpr-      elseExprDoc <- docSharedWrapper layoutExpr elseExpr-      hasComments <- hasAnyCommentsBelow lexpr-      let maySpecialIndent =-            case indentPolicy of-              IndentPolicyLeft -> BrIndentRegular-              IndentPolicyMultiple -> BrIndentRegular-              IndentPolicyFree -> BrIndentSpecial 3-      -- TODO: some of the alternatives (especially last and last-but-one)-      -- overlap.-      docSetIndentLevel $ runFilteredAlternative $ do-        -- if _ then _ else _-        addAlternativeCond (not hasComments)-          $ docSeq-          [ appSep $ docLit $ Text.pack "if"-          , appSep $ docForceSingleline ifExprDoc-          , appSep $ docLit $ Text.pack "then"-          , appSep $ docForceSingleline thenExprDoc-          , appSep $ docLit $ Text.pack "else"-          , docForceSingleline elseExprDoc-          ]-        -- either-        --   if expr-        --   then foo-        --     bar-        --   else foo-        --     bar-        -- or-        --   if expr-        --   then-        --     stuff-        --   else-        --     stuff-        -- note that this has par-spacing-        addAlternative-          $ docSetParSpacing-          $ docAddBaseY BrIndentRegular-          $ docPar-              ( docSeq-                [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"-                , docNodeAnnKW lexpr (Just AnnIf) $ docForceSingleline ifExprDoc-                ])-              (docLines-                [ docAddBaseY BrIndentRegular-                $ docNodeAnnKW lexpr (Just AnnThen)-                $ docNonBottomSpacing $ docAlt-                  [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]-                  , docAddBaseY BrIndentRegular-                  $ docPar (docLit $ Text.pack "then") thenExprDoc-                  ]-                , docAddBaseY BrIndentRegular-                $ docNonBottomSpacing $ docAlt-                  [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]-                  , docAddBaseY BrIndentRegular-                  $ docPar (docLit $ Text.pack "else") elseExprDoc-                  ]-                ])-        -- either-        --   if multi-        --      line-        --      condition-        --   then foo-        --     bar-        --   else foo-        --     bar-        -- or-        --   if multi-        --      line-        --      condition-        --   then-        --     stuff-        --   else-        --     stuff-        -- note that this does _not_ have par-spacing-        addAlternative-          $ docAddBaseY BrIndentRegular-          $ docPar-              ( docAddBaseY maySpecialIndent-              $ docSeq-                [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"-                , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc-                ])-              (docLines-                [ docAddBaseY BrIndentRegular-                $ docNodeAnnKW lexpr (Just AnnThen)-                $ docAlt-                  [ docSeq [appSep $ docLit $ Text.pack "then", docForceParSpacing thenExprDoc]-                  , docAddBaseY BrIndentRegular-                  $ docPar (docLit $ Text.pack "then") thenExprDoc-                  ]-                , docAddBaseY BrIndentRegular-                $ docAlt-                  [ docSeq [appSep $ docLit $ Text.pack "else", docForceParSpacing elseExprDoc]-                  , docAddBaseY BrIndentRegular-                  $ docPar (docLit $ Text.pack "else") elseExprDoc-                  ]-                ])-        addAlternative-          $ docSetBaseY-          $ docLines-            [ docAddBaseY maySpecialIndent-            $ docSeq-              [ docNodeAnnKW lexpr Nothing $ appSep $ docLit $ Text.pack "if"-              , docNodeAnnKW lexpr (Just AnnIf) $ ifExprDoc-              ]-            , docNodeAnnKW lexpr (Just AnnThen)-            $ docAddBaseY BrIndentRegular-            $ docPar (docLit $ Text.pack "then") thenExprDoc-            , docAddBaseY BrIndentRegular-            $ docPar (docLit $ Text.pack "else") elseExprDoc-            ]-    HsMultiIf _ cases -> do-      clauseDocs  <- cases `forM` layoutGrhs-      binderDoc   <- docLit $ Text.pack "->"-      hasComments <- hasAnyCommentsBelow lexpr-      docSetParSpacing $ docAddBaseY BrIndentRegular $ docPar-        (docLit $ Text.pack "if")-        (layoutPatternBindFinal Nothing binderDoc Nothing clauseDocs Nothing hasComments)-    HsLet _ binds exp1 -> do-      expDoc1     <- docSharedWrapper layoutExpr exp1-      -- We jump through some ugly hoops here to ensure proper sharing.-      hasComments <- hasAnyCommentsBelow lexpr-      mBindDocs   <- fmap (fmap pure) <$> layoutLocalBinds binds-      let-        ifIndentFreeElse :: a -> a -> a-        ifIndentFreeElse x y =-          case indentPolicy of-            IndentPolicyLeft -> y-            IndentPolicyMultiple -> y-            IndentPolicyFree -> x-      -- this `docSetBaseAndIndent` might seem out of place (especially the-      -- Indent part; setBase is necessary due to the use of docLines below),-      -- but is here due to ghc-exactprint's DP handling of "let" in-      -- particular.-      -- Just pushing another indentation level is a straightforward approach-      -- 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.-      docSetBaseAndIndent $ case mBindDocs of-        Just [bindDoc] -> runFilteredAlternative $ do-          addAlternativeCond (not hasComments) $ docSeq-            [ appSep $ docLit $ Text.pack "let"-            , docNodeAnnKW lexpr (Just AnnLet)-              $ appSep $ docForceSingleline bindDoc-            , appSep $ docLit $ Text.pack "in"-            , docForceSingleline expDoc1-            ]-          addAlternative $ docLines-            [ docNodeAnnKW lexpr (Just AnnLet)-            $ docAlt-                [ docSeq-                    [ appSep $ docLit $ Text.pack "let"-                    , ifIndentFreeElse docSetBaseAndIndent docForceSingleline-                    $ bindDoc-                    ]-                , docAddBaseY BrIndentRegular-                $ docPar-                  (docLit $ Text.pack "let")-                  (docSetBaseAndIndent bindDoc)-                ]-            , docAlt-                [ docSeq-                    [ appSep $ docLit $ Text.pack $ ifIndentFreeElse "in " "in"-                    , ifIndentFreeElse docSetBaseAndIndent docForceSingleline expDoc1-                    ]-                , docAddBaseY BrIndentRegular-                $ docPar-                  (docLit $ Text.pack "in")-                  (docSetBaseY expDoc1)-                ]-            ]-        Just bindDocs@(_:_) -> runFilteredAlternative $ do-          --either-          --  let-          --    a = b-          --    c = d-          --  in foo-          --    bar-          --    baz-          --or-          --  let-          --    a = b-          --    c = d-          --  in-          --    fooooooooooooooooooo-          let noHangingBinds =-                [ docNonBottomSpacing $ docAddBaseY BrIndentRegular-                $ docPar-                  (docLit $ Text.pack "let")-                  (docSetBaseAndIndent $ docLines bindDocs)-                , docSeq-                  [ docLit $ Text.pack "in "-                  , docAddBaseY BrIndentRegular-                  $ docForceParSpacing expDoc1-                  ]-                ]-          addAlternative $ case indentPolicy of-            IndentPolicyLeft     -> docLines noHangingBinds-            IndentPolicyMultiple -> docLines noHangingBinds-            IndentPolicyFree     -> docLines-              [ docNodeAnnKW lexpr (Just AnnLet)-              $ docSeq-                [ appSep $ docLit $ Text.pack "let"-                , docSetBaseAndIndent $ docLines bindDocs-                ]-              , docSeq-                [ appSep $ docLit $ Text.pack "in "-                , docSetBaseY expDoc1-                ]-              ]-          addAlternative-            $ docLines-            [ docNodeAnnKW lexpr (Just AnnLet)-            $ docAddBaseY BrIndentRegular-            $ docPar-              (docLit $ Text.pack "let")-              (docSetBaseAndIndent $ docLines $ bindDocs)-            , docAddBaseY BrIndentRegular-            $ docPar-              (docLit $ Text.pack "in")-              (docSetBaseY $ expDoc1)-            ]-        _ -> docSeq [appSep $ docLit $ Text.pack "let in", expDoc1]-      -- docSeq [appSep $ docLit "let in", expDoc1]-    HsDo _ stmtCtx (L _ stmts) -> case stmtCtx of-      DoExpr _ -> do-        stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts-        docSetParSpacing-          $ docAddBaseY BrIndentRegular-          $ docPar-              (docLit $ Text.pack "do")-              (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)-      MDoExpr _ -> do-        stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts-        docSetParSpacing-          $ docAddBaseY BrIndentRegular-          $ docPar-              (docLit $ Text.pack "mdo")-              (docSetBaseAndIndent $ docNonBottomSpacing $ docLines stmtDocs)-      x | case x of { ListComp -> True-                    ; MonadComp -> True-                    ; _ -> False } -> do-        stmtDocs    <- docSharedWrapper layoutStmt `mapM` stmts-        hasComments <- hasAnyCommentsBelow lexpr-        runFilteredAlternative $ do-          addAlternativeCond (not hasComments)-            $ docSeq-            [ docNodeAnnKW lexpr Nothing-            $ appSep-            $ docLit-            $ Text.pack "["-            , docNodeAnnKW lexpr (Just AnnOpenS)-            $ appSep-            $ docForceSingleline-            $ List.last stmtDocs-            , appSep $ docLit $ Text.pack "|"-            , docSeq $ List.intersperse docCommaSep-            $ docForceSingleline <$> List.init stmtDocs-            , docLit $ Text.pack " ]"-            ]-          addAlternative $-            let-              start = docCols ColListComp-                        [ docNodeAnnKW lexpr Nothing-                        $ appSep $ docLit $ Text.pack "["-                        , docSetBaseY-                        $ docNodeAnnKW lexpr (Just AnnOpenS)-                        $ List.last stmtDocs-                        ]-              (s1:sM) = List.init stmtDocs-              line1 = docCols ColListComp-                        [appSep $ docLit $ Text.pack "|", s1]-              lineM = sM <&> \d ->-                      docCols ColListComp [docCommaSep, d]-              end   = docLit $ Text.pack "]"-            in docSetBaseY $ docLines $ [start, line1] ++ lineM ++ [end]-      _ -> do-        -- TODO-        unknownNodeError "HsDo{} unknown stmtCtx" lexpr-    ExplicitList _ _ elems@(_:_) -> do-      elemDocs    <- elems `forM` docSharedWrapper layoutExpr-      hasComments <- hasAnyCommentsBelow lexpr-      case splitFirstLast elemDocs of-        FirstLastEmpty -> docSeq-          [ docLit $ Text.pack "["-          , docNodeAnnKW lexpr (Just AnnOpenS) $ docLit $ Text.pack "]"-          ]-        FirstLastSingleton e -> docAlt-          [ docSeq-            [ docLit $ Text.pack "["-            , docNodeAnnKW lexpr (Just AnnOpenS) $ docForceSingleline e-            , docLit $ Text.pack "]"-            ]-          , docSetBaseY $ docLines-            [ docSeq-              [ docLit $ Text.pack "["-              , docSeparator-              , docSetBaseY $ docNodeAnnKW lexpr (Just AnnOpenS) e-              ]-            , docLit $ Text.pack "]"-            ]-          ]-        FirstLast e1 ems eN -> runFilteredAlternative $ do-          addAlternativeCond (not hasComments)-            $  docSeq-            $  [docLit $ Text.pack "["]-            ++ List.intersperse docCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW lexpr (Just AnnOpenS) eN]))-            ++ [docLit $ Text.pack "]"]-          addAlternative $-            let-              start = docCols ColList-                        [appSep $ docLit $ Text.pack "[", e1]-              linesM = ems <&> \d ->-                      docCols ColList [docCommaSep, d]-              lineN = docCols ColList [docCommaSep, docNodeAnnKW lexpr (Just AnnOpenS) eN]-              end   = docLit $ Text.pack "]"-            in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]-    ExplicitList _ _ [] ->-      docLit $ Text.pack "[]"-    RecordCon _ lname fields ->-      case fields of-        HsRecFields fs Nothing -> do-          let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname-          rFs <- fs-            `forM` \lfield@(L _ (HsRecField (L _ fieldOcc) rFExpr pun)) -> do-              let FieldOcc _ lnameF = fieldOcc-              rFExpDoc <- if pun-                then return Nothing-                else Just <$> docSharedWrapper layoutExpr rFExpr-              return $ (lfield, lrdrNameToText lnameF, rFExpDoc)-          recordExpression False indentPolicy lexpr nameDoc rFs-        HsRecFields [] (Just (L _ 0)) -> do-          let t = lrdrNameToText lname-          docWrapNode lname $ docLit $ t <> Text.pack " { .. }"-        HsRecFields fs@(_:_) (Just (L _ dotdoti)) | dotdoti == length fs -> do-          let nameDoc = docWrapNode lname $ docLit $ lrdrNameToText lname-          fieldDocs <- fs `forM` \fieldl@(L _ (HsRecField (L _ fieldOcc) fExpr pun)) -> do-            let FieldOcc _ lnameF = fieldOcc-            fExpDoc <- if pun-              then return Nothing-              else Just <$> docSharedWrapper layoutExpr fExpr-            return (fieldl, lrdrNameToText lnameF, fExpDoc)-          recordExpression True indentPolicy lexpr nameDoc fieldDocs-        _ -> unknownNodeError "RecordCon with puns" lexpr-    RecordUpd _ rExpr fields -> do-      rExprDoc <- docSharedWrapper layoutExpr rExpr-      rFs <- fields-        `forM` \lfield@(L _ (HsRecField (L _ ambName) rFExpr pun)) -> do-          rFExpDoc <- if pun-            then return Nothing-            else Just <$> docSharedWrapper layoutExpr rFExpr-          return $ case ambName of-            Unambiguous _ n -> (lfield, lrdrNameToText n, rFExpDoc)-            Ambiguous   _ n -> (lfield, lrdrNameToText n, rFExpDoc)-      recordExpression False indentPolicy lexpr rExprDoc rFs-    ExprWithTySig _ exp1 (HsWC _ (HsIB _ typ1)) -> do-      expDoc <- docSharedWrapper layoutExpr exp1-      typDoc <- docSharedWrapper layoutType typ1-      docSeq-        [ appSep expDoc-        , appSep $ docLit $ Text.pack "::"-        , typDoc-        ]-    ArithSeq _ Nothing info ->-      case info of-        From e1 -> do-          e1Doc <- docSharedWrapper layoutExpr e1-          docSeq-            [ docLit $ Text.pack "["-            , appSep $ docForceSingleline e1Doc-            , docLit $ Text.pack "..]"-            ]-        FromThen e1 e2 -> do-          e1Doc <- docSharedWrapper layoutExpr e1-          e2Doc <- docSharedWrapper layoutExpr e2-          docSeq-            [ docLit $ Text.pack "["-            , docForceSingleline e1Doc-            , appSep $ docLit $ Text.pack ","-            , appSep $ docForceSingleline e2Doc-            , docLit $ Text.pack "..]"-            ]-        FromTo e1 eN -> do-          e1Doc <- docSharedWrapper layoutExpr e1-          eNDoc <- docSharedWrapper layoutExpr eN-          docSeq-            [ docLit $ Text.pack "["-            , appSep $ docForceSingleline e1Doc-            , appSep $ docLit $ Text.pack ".."-            , docForceSingleline eNDoc-            , docLit $ Text.pack "]"-            ]-        FromThenTo e1 e2 eN -> do-          e1Doc <- docSharedWrapper layoutExpr e1-          e2Doc <- docSharedWrapper layoutExpr e2-          eNDoc <- docSharedWrapper layoutExpr eN-          docSeq-            [ docLit $ Text.pack "["-            , docForceSingleline e1Doc-            , appSep $ docLit $ Text.pack ","-            , appSep $ docForceSingleline e2Doc-            , appSep $ docLit $ Text.pack ".."-            , docForceSingleline eNDoc-            , docLit $ Text.pack "]"-            ]-    ArithSeq{} ->-      briDocByExactInlineOnly "ArithSeq" lexpr-    HsBracket{} -> do-      -- TODO-      briDocByExactInlineOnly "HsBracket{}" lexpr-    HsRnBracketOut{} -> do-      -- TODO-      briDocByExactInlineOnly "HsRnBracketOut{}" lexpr-    HsTcBracketOut{} -> do-      -- TODO-      briDocByExactInlineOnly "HsTcBracketOut{}" lexpr-    HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do-      allocateNode $ BDFPlain-        (Text.pack-          $  "["-          ++ showOutputable quoter-          ++ "|"-          ++ showOutputable content-          ++ "|]")-    HsSpliceE{} -> do-      -- TODO-      briDocByExactInlineOnly "HsSpliceE{}" lexpr-    HsProc{} -> do-      -- TODO-      briDocByExactInlineOnly "HsProc{}" lexpr-    HsStatic{} -> do-      -- TODO-      briDocByExactInlineOnly "HsStatic{}" lexpr-    HsTick{} -> do-      -- TODO-      briDocByExactInlineOnly "HsTick{}" lexpr-    HsBinTick{} -> do-      -- TODO-      briDocByExactInlineOnly "HsBinTick{}" lexpr-    HsConLikeOut{} -> do-      -- TODO-      briDocByExactInlineOnly "HsWrap{}" lexpr-    ExplicitSum{} -> do-      -- TODO-      briDocByExactInlineOnly "ExplicitSum{}" lexpr-    HsPragE{} -> do-      -- TODO-      briDocByExactInlineOnly "HsPragE{}" lexpr--recordExpression-  :: (Data.Data.Data lExpr, Data.Data.Data name)-  => Bool-  -> IndentPolicy-  -> GenLocated SrcSpan lExpr-  -> ToBriDocM BriDocNumbered-  -> [(GenLocated SrcSpan name, Text, Maybe (ToBriDocM BriDocNumbered))]-  -> ToBriDocM BriDocNumbered-recordExpression False _ lexpr nameDoc [] =-  docSeq-    [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"]-    , docLit $ Text.pack "}"-    ]-recordExpression True _ lexpr nameDoc [] =-  docSeq -- this case might still be incomplete, and is probably not used-         -- atm anyway.-    [ docNodeAnnKW lexpr (Just AnnOpenC) $ docSeq [nameDoc, docLit $ Text.pack "{"]-    , docLit $ Text.pack " .. }"-    ]-recordExpression dotdot indentPolicy lexpr nameDoc rFs@(rF1:rFr) = do-  let (rF1f, rF1n, rF1e) = rF1-  runFilteredAlternative $ do-    -- container { fieldA = blub, fieldB = blub }-    addAlternative-      $ docSeq-      [ docNodeAnnKW lexpr Nothing $ appSep $ docForceSingleline nameDoc-      , appSep $ docLit $ Text.pack "{"-      , docSeq $ List.intersperse docCommaSep-              $ rFs <&> \case-                (lfield, fieldStr, Just fieldDoc) ->-                  docWrapNode lfield $ docSeq-                        [ appSep $ docLit fieldStr-                        , appSep $ docLit $ Text.pack "="-                        , docForceSingleline fieldDoc-                        ]-                (lfield, fieldStr, Nothing) ->-                  docWrapNode lfield $ docLit fieldStr-      , if dotdot-          then docSeq [ docCommaSep, docLit $ Text.pack "..", docSeparator]-          else docSeparator-      , docLit $ Text.pack "}"-      ]-    -- hanging single-line fields-    -- container { fieldA = blub-    --           , fieldB = blub-    --           }-    addAlternativeCond (indentPolicy == IndentPolicyFree)-      $ docSeq-      [ docNodeAnnKW lexpr Nothing $ docForceSingleline $ appSep nameDoc-      , docSetBaseY $ docLines $ let-          line1 = docCols ColRec-            [ appSep $ docLit $ Text.pack "{"-            , docWrapNodePrior rF1f $ appSep $ docLit rF1n-            , case rF1e of-                Just x -> docWrapNodeRest rF1f $ docSeq-                                [ appSep $ docLit $ Text.pack "="-                                , docForceSingleline x-                                ]-                Nothing -> docEmpty-            ]-          lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield $ docCols ColRec-            [ docCommaSep-            , appSep $ docLit fText-            , case fDoc of-                Just x ->  docSeq [ appSep $ docLit $ Text.pack "="-                                  , docForceSingleline x-                                  ]-                Nothing -> docEmpty-            ]-          dotdotLine = if dotdot-            then docCols ColRec-                   [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep-                   , docNodeAnnKW lexpr (Just AnnDotdot)-                     $ docLit $ Text.pack ".."-                   ]-            else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty-          lineN = docLit $ Text.pack "}"-          in [line1] ++ lineR ++ [dotdotLine, lineN]-      ]-    -- non-hanging with expressions placed to the right of the names-    -- container-    -- { fieldA = blub-    -- , fieldB = potentially-    --     multiline-    -- }-    addAlternative-      $ docSetParSpacing-      $ docAddBaseY BrIndentRegular-      $ docPar-          (docNodeAnnKW lexpr Nothing nameDoc)-          (docNonBottomSpacing $ docLines $ let-            line1 = docCols ColRec-              [ appSep $ docLit $ Text.pack "{"-              , docWrapNodePrior rF1f $ appSep $ docLit rF1n-              , docWrapNodeRest rF1f $ case rF1e of-                  Just x -> runFilteredAlternative $ do-                    addAlternativeCond (indentPolicy == IndentPolicyFree) $ do-                      docSeq-                        [appSep $ docLit $ Text.pack "=", docSetBaseY x]-                    addAlternative $ do-                      docSeq-                        [appSep $ docLit $ Text.pack "=", docForceParSpacing x]-                    addAlternative $ do-                      docAddBaseY BrIndentRegular-                        $ docPar (docLit $ Text.pack "=") x-                  Nothing -> docEmpty-              ]-            lineR = rFr <&> \(lfield, fText, fDoc) -> docWrapNode lfield-              $ docCols ColRec-              [ docCommaSep-              , appSep $ docLit fText-              , case fDoc of-                  Just x -> runFilteredAlternative $ do-                    addAlternativeCond (indentPolicy == IndentPolicyFree) $ do-                      docSeq-                        [appSep $ docLit $ Text.pack "=", docSetBaseY x]-                    addAlternative $ do-                      docSeq [ appSep $ docLit $ Text.pack "="-                             , docForceParSpacing x-                             ]-                    addAlternative $ do-                      docAddBaseY BrIndentRegular-                        $ docPar (docLit $ Text.pack "=") x-                  Nothing -> docEmpty-              ]-            dotdotLine = if dotdot-              then docCols ColRec-                     [ docNodeAnnKW lexpr (Just AnnOpenC) docCommaSep-                     , docNodeAnnKW lexpr (Just AnnDotdot)-                       $ docLit $ Text.pack ".."-                     ]-              else docNodeAnnKW lexpr (Just AnnOpenC) docEmpty-            lineN = docLit $ Text.pack "}"-            in [line1] ++ lineR ++ [dotdotLine, lineN]-          )--litBriDoc :: HsLit GhcPs -> BriDocFInt-litBriDoc = \case-  HsChar       (SourceText t) _c                         -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']-  HsCharPrim   (SourceText t) _c                         -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']-  HsString     (SourceText t) _fastString                -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString-  HsStringPrim (SourceText t) _byteString                -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString-  HsInt        _              (IL (SourceText t) _ _)    -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i-  HsIntPrim    (SourceText t) _i                         -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i-  HsWordPrim   (SourceText t) _i                         -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i-  HsInt64Prim  (SourceText t) _i                         -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i-  HsWord64Prim (SourceText t) _i                         -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i-  HsInteger (SourceText t) _i                      _type -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i-  HsRat     _              (FL (SourceText t) _ _) _type -> BDFLit $ Text.pack t-  HsFloatPrim  _ (FL (SourceText t) _ _)                 -> BDFLit $ Text.pack t-  HsDoublePrim _ (FL (SourceText t) _ _)                 -> BDFLit $ Text.pack t-  _ -> error "litBriDoc: literal with no SourceText"--overLitValBriDoc :: OverLitVal -> BriDocFInt-overLitValBriDoc = \case-  HsIntegral   (IL (SourceText t) _ _) -> BDFLit $ Text.pack t-  HsFractional (FL (SourceText t) _ _) -> BDFLit $ Text.pack t-  HsIsString (SourceText t) _ -> BDFLit $ Text.pack t-  _ -> error "overLitValBriDoc: literal with no SourceText"
− source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot 
@@ -1,16 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Layouters.Expr where--import GHC.Hs-import Language.Haskell.Brittany.Internal.Types----layoutExpr :: ToBriDoc HsExpr---- layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))--litBriDoc :: HsLit GhcPs -> BriDocFInt--overLitValBriDoc :: OverLitVal -> BriDocFInt
− source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs 
@@ -1,214 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Layouters.IE where--import qualified Data.List.Extra-import qualified Data.Text as Text-import GHC-  ( AnnKeywordId(..)-  , GenLocated(L)-  , Located-  , ModuleName-  , moduleNameString-  , unLoc-  )-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----prepareName :: LIEWrappedName name -> Located name-prepareName = ieLWrappedName--layoutIE :: ToBriDoc IE-layoutIE lie@(L _ ie) = docWrapNode lie $ case ie of-  IEVar _ x -> layoutWrapped lie x-  IEThingAbs _ x -> layoutWrapped lie x-  IEThingAll _ x -> docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]-  IEThingWith _ x (IEWildcard _) _ _ ->-    docSeq [layoutWrapped lie x, docLit $ Text.pack "(..)"]-  IEThingWith _ x _ ns _ -> do-    hasComments <- orM-      ( hasCommentsBetween lie AnnOpenP AnnCloseP-      : hasAnyCommentsBelow x-      : map hasAnyCommentsBelow ns-      )-    let sortedNs = List.sortOn wrappedNameToText ns-    runFilteredAlternative $ do-      addAlternativeCond (not hasComments)-        $  docSeq-        $  [layoutWrapped lie x, docLit $ Text.pack "("]-        ++ intersperse docCommaSep (map nameDoc sortedNs)-        ++ [docParenR]-      addAlternative-        $ docWrapNodeRest lie-        $ docAddBaseY BrIndentRegular-        $ docPar-            (layoutWrapped lie x)-            (layoutItems (splitFirstLast sortedNs))-   where-    nameDoc = docLit <=< lrdrNameToTextAnn . prepareName-    layoutItem n = docSeq [docCommaSep, docWrapNode n $ nameDoc n]-    layoutItems FirstLastEmpty = docSetBaseY $ docLines-      [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) docEmpty], docParenR]-    layoutItems (FirstLastSingleton n) = docSetBaseY $ docLines-      [docSeq [docParenLSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc n], docParenR]-    layoutItems (FirstLast n1 nMs nN) =-      docSetBaseY-        $  docLines-        $  [docSeq [docParenLSep, docWrapNode n1 $ nameDoc n1]]-        ++ map layoutItem nMs-        ++ [docSeq [docCommaSep, docNodeAnnKW lie (Just AnnOpenP) $ nameDoc nN], docParenR]-  IEModuleContents _ n -> docSeq-    [ docLit $ Text.pack "module"-    , docSeparator-    , docLit . Text.pack . moduleNameString $ unLoc n-    ]-  _ -> docEmpty- where-  layoutWrapped _ = \case-    L _ (IEName    n) -> docLit =<< lrdrNameToTextAnn n-    L _ (IEPattern n) -> do-      name <- lrdrNameToTextAnn n-      docLit $ Text.pack "pattern " <> name-    L _ (IEType n) -> do-      name <- lrdrNameToTextAnn n-      docLit $ Text.pack "type " <> name--data SortItemsFlag = ShouldSortItems | KeepItemsUnsorted--- Helper function to deal with Located lists of LIEs.--- In particular this will also associate documentation--- from the located list that actually belongs to the last IE.--- It also adds docCommaSep to all but the first element--- This configuration allows both vertical and horizontal--- handling of the resulting list. Adding parens is--- left to the caller since that is context sensitive-layoutAnnAndSepLLIEs-  :: SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM [ToBriDocM BriDocNumbered]-layoutAnnAndSepLLIEs shouldSort llies@(L _ lies) = do-  let makeIENode ie = docSeq [docCommaSep, ie]-  let sortedLies =-        [ items-        | group <- Data.List.Extra.groupOn lieToText-          $ List.sortOn lieToText lies-        , items <- mergeGroup group-        ]-  let ieDocs = fmap layoutIE $ case shouldSort of-        ShouldSortItems -> sortedLies-        KeepItemsUnsorted -> lies-  ieCommaDocs <--    docWrapNodeRest llies $ sequence $ case splitFirstLast ieDocs of-      FirstLastEmpty        -> []-      FirstLastSingleton ie -> [ie]-      FirstLast ie1 ieMs ieN ->-        [ie1] ++ map makeIENode ieMs ++ [makeIENode ieN]-  pure $ fmap pure ieCommaDocs -- returned shared nodes- where-  mergeGroup :: [LIE GhcPs] -> [LIE GhcPs]-  mergeGroup []        = []-  mergeGroup items@[_] = items-  mergeGroup items     = if-    | all isProperIEThing items -> [List.foldl1' thingFolder items]-    | all isIEVar items         -> [List.foldl1' thingFolder items]-    | otherwise                 -> items-  -- proper means that if it is a ThingWith, it does not contain a wildcard-  -- (because I don't know what a wildcard means if it is not already a-  -- IEThingAll).-  isProperIEThing :: LIE GhcPs -> Bool-  isProperIEThing = \case-    L _ (IEThingAbs _ _wn) -> True-    L _ (IEThingAll _ _wn) -> True-    L _ (IEThingWith _ _wn NoIEWildcard _ _) -> True-    _ -> False-  isIEVar :: LIE GhcPs -> Bool-  isIEVar = \case-    L _ IEVar{} -> True-    _           -> False-  thingFolder :: LIE GhcPs -> LIE GhcPs -> LIE GhcPs-  thingFolder l1@(L _ IEVar{}     ) _                     = l1-  thingFolder l1@(L _ IEThingAll{}) _                     = l1-  thingFolder _                     l2@(L _ IEThingAll{}) = l2-  thingFolder l1                    (   L _ IEThingAbs{}) = l1-  thingFolder (L _ IEThingAbs{})    l2                    = l2-  thingFolder (L l (IEThingWith x wn _ consItems1 fieldLbls1)) (L _ (IEThingWith _ _ _ consItems2 fieldLbls2))-    = L-      l-      (IEThingWith x-                   wn-                   NoIEWildcard-                   (consItems1 ++ consItems2)-                   (fieldLbls1 ++ fieldLbls2)-      )-  thingFolder _ _ =-    error "thingFolder should be exhaustive because we have a guard above"----- Builds a complete layout for the given located--- list of LIEs. The layout provides two alternatives:--- (item, item, ..., item)--- ( item--- , item--- ...--- , item--- )--- If the llies contains comments the list will--- always expand over multiple lines, even when empty:--- () -- no comments--- ( -- a comment--- )-layoutLLIEs :: Bool -> SortItemsFlag -> Located [LIE GhcPs] -> ToBriDocM BriDocNumbered-layoutLLIEs enableSingleline shouldSort llies = do-  ieDs        <- layoutAnnAndSepLLIEs shouldSort llies-  hasComments <- hasAnyCommentsBelow llies-  runFilteredAlternative $ case ieDs of-    [] -> do-      addAlternativeCond (not hasComments) $ docLit $ Text.pack "()"-      addAlternativeCond hasComments $ docPar-        (docSeq [docParenLSep, docWrapNodeRest llies docEmpty])-        docParenR-    (ieDsH : ieDsT) -> do-      addAlternativeCond (not hasComments && enableSingleline)-        $  docSeq-        $  [docLit (Text.pack "(")]-        ++ (docForceSingleline <$> ieDs)-        ++ [docParenR]-      addAlternative-        $  docPar (docSetBaseY $ docSeq [docParenLSep, ieDsH])-        $  docLines-        $  ieDsT-        ++ [docParenR]---- | Returns a "fingerprint string", not a full text representation, nor even--- a source code representation of this syntax node.--- Used for sorting, not for printing the formatter's output source code.-wrappedNameToText :: LIEWrappedName RdrName -> Text-wrappedNameToText = \case-  L _ (IEName    n) -> lrdrNameToText n-  L _ (IEPattern n) -> lrdrNameToText n-  L _ (IEType    n) -> lrdrNameToText n---- | Returns a "fingerprint string", not a full text representation, nor even--- a source code representation of this syntax node.--- Used for sorting, not for printing the formatter's output source code.-lieToText :: LIE GhcPs -> Text-lieToText = \case-  L _ (IEVar      _ wn       ) -> wrappedNameToText wn-  L _ (IEThingAbs _ wn       ) -> wrappedNameToText wn-  L _ (IEThingAll _ wn       ) -> wrappedNameToText wn-  L _ (IEThingWith _ wn _ _ _) -> wrappedNameToText wn-  -- TODO: These _may_ appear in exports!-  -- Need to check, and either put them at the top (for module) or do some-  -- other clever thing.-  L _ (IEModuleContents _ n) -> moduleNameToText n-  L _ IEGroup{}              -> Text.pack "@IEGroup"-  L _ IEDoc{}                -> Text.pack "@IEDoc"-  L _ IEDocNamed{}           -> Text.pack "@IEDocNamed"- where-  moduleNameToText :: Located ModuleName -> Text-  moduleNameToText (L _ name) = Text.pack ("@IEModuleContents" ++ moduleNameString name)
− source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Layouters.Import where--import qualified Data.Semigroup as Semigroup-import qualified Data.Text as Text-import GHC (GenLocated(L), Located, moduleNameString, unLoc)-import GHC.Hs-import GHC.Types.Basic-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 rawN = case rawN of-  SourceText n -> n-  -- This would be odd to encounter and the-  -- result will most certainly be wrong-  NoSourceText -> ""-prepModName :: Located e -> e-prepModName = unLoc--layoutImport :: ImportDecl GhcPs -> ToBriDocM BriDocNumbered-layoutImport importD = case importD of-  ImportDecl _ _ (L _ modName) pkg src safe q False mas mllies -> do-    importCol <- mAsk <&> _conf_layout .> _lconfig_importColumn .> confUnpack-    importAsCol <- mAsk <&> _conf_layout .> _lconfig_importAsColumn .> confUnpack-    indentPolicy <- mAsk <&>  _conf_layout .> _lconfig_indentPolicy .> confUnpack-    let-      compact  = indentPolicy /= IndentPolicyFree-      modNameT = Text.pack $ moduleNameString modName-      pkgNameT = Text.pack . prepPkg . sl_st <$> pkg-      masT     = Text.pack . moduleNameString . prepModName <$> mas-      hiding   = maybe False fst mllies-      minQLength = length "import qualified "-      qLengthReal =-        let qualifiedPart = if q /= NotQualified then length "qualified " else 0-            safePart      = if safe then length "safe " else 0-            pkgPart       = maybe 0 ((+ 1) . Text.length) pkgNameT-            srcPart = case src of { IsBoot -> length "{-# SOURCE #-} "; NotBoot -> 0 }-        in  length "import " + srcPart + safePart + qualifiedPart + pkgPart-      qLength          = max minQLength qLengthReal-      -- Cost in columns of importColumn-      asCost           = length "as "-      hidingParenCost  = if hiding then length "hiding ( " else length "( "-      nameCost         = Text.length modNameT + qLength-      importQualifiers = docSeq-        [ appSep $ docLit $ Text.pack "import"-        , case src of { IsBoot -> appSep $ docLit $ Text.pack "{-# SOURCE #-}"; NotBoot -> docEmpty }-        , if safe then appSep $ docLit $ Text.pack "safe" else docEmpty-        , if q /= NotQualified then appSep $ docLit $ Text.pack "qualified" else docEmpty-        , maybe docEmpty (appSep . docLit) pkgNameT-        ]-      indentName =-        if compact then id else docEnsureIndent (BrIndentSpecial qLength)-      modNameD =-        indentName $ appSep $ docLit modNameT-      hidDocCol = if hiding then importCol - hidingParenCost else importCol - 2-      hidDocColDiff = importCol - 2 - hidDocCol-      hidDoc = if hiding-        then appSep $ docLit $ Text.pack "hiding"-        else docEmpty-      importHead = docSeq [importQualifiers, modNameD]-      bindingsD  = case mllies of-        Nothing -> docEmpty-        Just (_, llies) -> do-          hasComments <- hasAnyCommentsBelow llies-          if compact-          then docAlt-            [ docSeq [hidDoc, docForceSingleline $ layoutLLIEs True ShouldSortItems llies]-            , let makeParIfHiding = if hiding-                    then docAddBaseY BrIndentRegular . docPar hidDoc-                    else id-              in makeParIfHiding (layoutLLIEs True ShouldSortItems llies)-            ]-          else do-            ieDs <- layoutAnnAndSepLLIEs ShouldSortItems llies-            docWrapNodeRest llies-              $ docEnsureIndent (BrIndentSpecial hidDocCol)-              $ case ieDs of-                -- ..[hiding].( )-                [] -> if hasComments-                  then docPar-                    (docSeq [hidDoc, docParenLSep, docWrapNode llies docEmpty])-                    (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)-                  else docSeq [hidDoc, docParenLSep, docSeparator, docParenR]-                -- ..[hiding].( b )-                [ieD] -> runFilteredAlternative $ do-                  addAlternativeCond (not hasComments)-                    $ docSeq-                    [ hidDoc-                    , docParenLSep-                    , docForceSingleline ieD-                    , docSeparator-                    , docParenR-                    ]-                  addAlternative $ docPar-                    (docSeq [hidDoc, docParenLSep, docNonBottomSpacing ieD])-                    (docEnsureIndent (BrIndentSpecial hidDocColDiff) docParenR)-                -- ..[hiding].( b-                --            , b'-                --            )-                (ieD:ieDs') ->-                  docPar-                    (docSeq [hidDoc, docSetBaseY $ docSeq [docParenLSep, ieD]])-                    (  docEnsureIndent (BrIndentSpecial hidDocColDiff)-                    $  docLines-                    $  ieDs'-                    ++ [docParenR]-                    )-      makeAsDoc asT =-        docSeq [appSep $ docLit $ Text.pack "as", appSep $ docLit asT]-    if compact-    then-      let asDoc = maybe docEmpty makeAsDoc masT-      in docAlt-        [ docForceSingleline $ docSeq [importHead, asDoc, bindingsD]-        , docAddBaseY BrIndentRegular $-            docPar (docSeq [importHead, asDoc]) bindingsD-        ]-    else-      case masT of-        Just n -> if enoughRoom-          then docLines-                 [ docSeq [importHead, asDoc], bindingsD]-          else docLines [importHead, asDoc, bindingsD]-         where-          enoughRoom = nameCost < importAsCol - asCost-          asDoc =-            docEnsureIndent (BrIndentSpecial (importAsCol - asCost))-              $ makeAsDoc n-        Nothing -> if enoughRoom-          then docSeq [importHead, bindingsD]-          else docLines [importHead, bindingsD]-          where enoughRoom = nameCost < importCol - hidingParenCost-  _ -> docEmpty
− source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Layouters.Module where--import qualified Data.Maybe-import qualified Data.Semigroup as Semigroup-import qualified Data.Text as Text-import GHC (AnnKeywordId(..), GenLocated(L), moduleNameString, unLoc)-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.IE-import Language.Haskell.Brittany.Internal.Layouters.Import-import Language.Haskell.Brittany.Internal.Prelude-import Language.Haskell.Brittany.Internal.PreludeUtils-import Language.Haskell.Brittany.Internal.Types-import Language.Haskell.GHC.ExactPrint as ExactPrint-import Language.Haskell.GHC.ExactPrint.Types-  (DeltaPos(..), commentContents, deltaRow)----layoutModule :: ToBriDoc' HsModule-layoutModule lmod@(L _ mod') = case mod' of-    -- Implicit module Main-  HsModule _ Nothing  _   imports _ _ _ -> do-    commentedImports <- transformToCommentedImport imports-    -- groupify commentedImports `forM_` tellDebugMessShow-    docLines (commentedImportsToDoc <$> sortCommentedImports commentedImports)-    -- sortedImports <- sortImports imports-    -- docLines $ [layoutImport y i | (y, i) <- sortedImports]-  HsModule _ (Just n) les imports _ _ _ -> do-    commentedImports <- transformToCommentedImport imports-    -- groupify commentedImports `forM_` tellDebugMessShow-    -- sortedImports <- sortImports imports-    let tn = Text.pack $ moduleNameString $ unLoc n-    allowSingleLineExportList <- mAsk-      <&> _conf_layout-      .>  _lconfig_allowSingleLineExportList-      .>  confUnpack-    -- the config should not prevent single-line layout when there is no-    -- export list-    let allowSingleLine = allowSingleLineExportList || Data.Maybe.isNothing les-    docLines-      $ docSeq-          [ docNodeAnnKW lmod Nothing docEmpty-             -- A pseudo node that serves merely to force documentation-             -- before the node-          , docNodeMoveToKWDP lmod AnnModule True $ runFilteredAlternative $ do-            addAlternativeCond allowSingleLine $-              docForceSingleline-                $ docSeq-                [ appSep $ docLit $ Text.pack "module"-                , appSep $ docLit tn-                , docWrapNode lmod $ appSep $ case les of-                  Nothing -> docEmpty-                  Just x  -> layoutLLIEs True KeepItemsUnsorted x-                , docSeparator-                , docLit $ Text.pack "where"-                ]-            addAlternative-              $ docLines-              [ docAddBaseY BrIndentRegular $ docPar-                (docSeq [appSep $ docLit $ Text.pack "module", docLit tn]-                )-                (docSeq [-                          docWrapNode lmod $ case les of-                           Nothing -> docEmpty-                           Just x  -> layoutLLIEs False KeepItemsUnsorted x-                        , docSeparator-                        , docLit $ Text.pack "where"-                        ]-                )-              ]-          ]-      : (commentedImportsToDoc <$> sortCommentedImports commentedImports) -- [layoutImport y i | (y, i) <- sortedImports]--data CommentedImport-  = EmptyLine-  | IndependentComment (Comment, DeltaPos)-  | ImportStatement ImportStatementRecord--instance Show CommentedImport where-  show = \case-    EmptyLine            -> "EmptyLine"-    IndependentComment _ -> "IndependentComment"-    ImportStatement r ->-      "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show-        (length $ commentsAfter r)--data ImportStatementRecord = ImportStatementRecord-  { commentsBefore :: [(Comment, DeltaPos)]-  , commentsAfter :: [(Comment, DeltaPos)]-  , importStatement :: ImportDecl GhcPs-  }--instance Show ImportStatementRecord where-  show r = "ImportStatement " ++ show (length $ commentsBefore r) ++ " " ++ show-        (length $ commentsAfter r)--transformToCommentedImport-  :: [LImportDecl GhcPs] -> ToBriDocM [CommentedImport]-transformToCommentedImport is = do-  nodeWithAnnotations <- is `forM` \i@(L _ rawImport) -> do-    annotionMay <- astAnn i-    pure (annotionMay, rawImport)-  let-    convertComment (c, DP (y, x)) =-      replicate (y - 1) EmptyLine ++ [IndependentComment (c, DP (1, x))]-    accumF-      :: [(Comment, DeltaPos)]-      -> (Maybe Annotation, ImportDecl GhcPs)-      -> ([(Comment, DeltaPos)], [CommentedImport])-    accumF accConnectedComm (annMay, decl) = case annMay of-      Nothing ->-        ( []-        , [ ImportStatement ImportStatementRecord { commentsBefore  = []-                                                  , commentsAfter   = []-                                                  , importStatement = decl-                                                  }-          ]-        )-      Just ann ->-        let-          blanksBeforeImportDecl = deltaRow (annEntryDelta ann) - 1-          (newAccumulator, priorComments') =-            List.span ((== 0) . deltaRow . snd) (annPriorComments ann)-          go-            :: [(Comment, DeltaPos)]-            -> [(Comment, DeltaPos)]-            -> ([CommentedImport], [(Comment, DeltaPos)], Int)-          go acc []                       = ([], acc, 0)-          go acc [c1@(_, DP (y, _))] = ([], c1 : acc, y - 1)-          go acc (c1@(_, DP (1, _)) : xs) = go (c1 : acc) xs-          go acc ((c1, DP (y, x)) : xs) =-            ( (convertComment =<< xs) ++ replicate (y - 1) EmptyLine-            , (c1, DP (1, x)) : acc-            , 0-            )-          (convertedIndependentComments, beforeComments, initialBlanks) =-            if blanksBeforeImportDecl /= 0-              then (convertComment =<< priorComments', [], 0)-              else go [] (reverse priorComments')-        in-          ( newAccumulator-          , convertedIndependentComments-          ++ replicate (blanksBeforeImportDecl + initialBlanks) EmptyLine-          ++ [ ImportStatement ImportStatementRecord-                 { commentsBefore  = beforeComments-                 , commentsAfter   = accConnectedComm-                 , importStatement = decl-                 }-             ]-          )-  let (finalAcc, finalList) = mapAccumR accumF [] nodeWithAnnotations-  pure $ join $ (convertComment =<< finalAcc) : finalList--sortCommentedImports :: [CommentedImport] -> [CommentedImport]-sortCommentedImports =-  unpackImports . mergeGroups . map (fmap (sortGroups)) . groupify- where-  unpackImports :: [CommentedImport] -> [CommentedImport]-  unpackImports xs = xs >>= \case-    l@EmptyLine            -> [l]-    l@IndependentComment{} -> [l]-    ImportStatement r ->-      map IndependentComment (commentsBefore r) ++ [ImportStatement r]-  mergeGroups-    :: [Either CommentedImport [ImportStatementRecord]] -> [CommentedImport]-  mergeGroups xs = xs >>= \case-    Left  x -> [x]-    Right y -> ImportStatement <$> y-  sortGroups :: [ImportStatementRecord] -> [ImportStatementRecord]-  sortGroups =-    List.sortOn (moduleNameString . unLoc . ideclName . importStatement)-  groupify-    :: [CommentedImport] -> [Either CommentedImport [ImportStatementRecord]]-  groupify cs = go [] cs-   where-    go [] = \case-      (l@EmptyLine            : rest) -> Left l : go [] rest-      (l@IndependentComment{} : rest) -> Left l : go [] rest-      (ImportStatement r      : rest) -> go [r] rest-      []                              -> []-    go acc = \case-      (l@EmptyLine : rest) -> Right (reverse acc) : Left l : go [] rest-      (l@IndependentComment{} : rest) ->-        Left l : Right (reverse acc) : go [] rest-      (ImportStatement r : rest) -> go (r : acc) rest-      []                         -> [Right (reverse acc)]--commentedImportsToDoc :: CommentedImport -> ToBriDocM BriDocNumbered-commentedImportsToDoc = \case-  EmptyLine -> docLitS ""-  IndependentComment c -> commentToDoc c-  ImportStatement r ->-    docSeq-      ( layoutImport (importStatement r)-      : map commentToDoc (commentsAfter r)-      )- where-  commentToDoc (c, DP (_y, x)) = docLitS (replicate x ' ' ++ commentContents c)
− source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs 
@@ -1,220 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Layouters.Pattern where--import qualified Data.Foldable as Foldable-import qualified Data.Sequence as Seq-import qualified Data.Text as Text-import GHC (GenLocated(L), ol_val)-import GHC.Hs-import qualified GHC.OldList as List-import GHC.Types.Basic-import Language.Haskell.Brittany.Internal.LayouterBasics-import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr-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--- bindings or do notation). E.g. for input---        > case computation of---        >   (warnings, Success a b) -> ..--- This part  ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by--- 'layoutPat'. Similarly for--- > func abc True 0 = []---        ^^^^^^^^^^ this part--- We will use `case .. of` as the imagined prefix to the examples used in--- the different cases below.-layoutPat :: LPat GhcPs -> ToBriDocM (Seq BriDocNumbered)-layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of-  WildPat _  -> fmap Seq.singleton $ docLit $ Text.pack "_"-    -- _ -> expr-  VarPat _ n ->-    fmap Seq.singleton $ docLit $ lrdrNameToText n-    -- abc -> expr-  LitPat _ lit ->-    fmap Seq.singleton $ allocateNode $ litBriDoc lit-    -- 0 -> expr-  ParPat _ inner -> do-    -- (nestedpat) -> expr-    left  <- docLit $ Text.pack "("-    right <- docLit $ Text.pack ")"-    innerDocs <- colsWrapPat =<< layoutPat inner-    return $ Seq.empty Seq.|> left Seq.|> innerDocs Seq.|> right-    -- return $ (left Seq.<| innerDocs) Seq.|> right-    -- case Seq.viewl innerDocs of-    --   Seq.EmptyL -> fmap return $ docLit $ Text.pack "()" -- this should never occur..-    --   x1 Seq.:< rest -> case Seq.viewr rest of-    --     Seq.EmptyR ->-    --       fmap return $ docSeq-    --       [ docLit $ Text.pack "("-    --       , return x1-    --       , docLit $ Text.pack ")"-    --       ]-    --     middle Seq.:> xN -> do-    --       x1' <- docSeq [docLit $ Text.pack "(", return x1]-    --       xN' <- docSeq [return xN, docLit $ Text.pack ")"]-    --       return $ (x1' Seq.<| middle) Seq.|> xN'-  ConPat _ lname (PrefixCon args) -> do-    -- Abc a b c -> expr-    nameDoc <- lrdrNameToTextAnn lname-    argDocs <- layoutPat `mapM` args-    if null argDocs-      then return <$> docLit nameDoc-      else do-        x1 <- appSep (docLit nameDoc)-        xR <- fmap Seq.fromList-          $ sequence-          $ spacifyDocs-          $ fmap colsWrapPat argDocs-        return $ x1 Seq.<| xR-  ConPat _ lname (InfixCon left right) -> do-    -- a :< b -> expr-    nameDoc <- lrdrNameToTextAnn lname-    leftDoc <- appSep . colsWrapPat =<< layoutPat left-    rightDoc <- colsWrapPat =<< layoutPat right-    middle <- appSep $ docLit nameDoc-    return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc-  ConPat _ lname (RecCon (HsRecFields [] Nothing)) -> do-    -- Abc{} -> expr-    let t = lrdrNameToText lname-    fmap Seq.singleton $ docLit $ t <> Text.pack "{}"-  ConPat _ lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do-    -- Abc { a = locA, b = locB, c = locC } -> expr1-    -- Abc { a, b, c } -> expr2-    let t = lrdrNameToText lname-    fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do-      let FieldOcc _ lnameF = fieldOcc-      fExpDoc <- if pun-        then return Nothing-        else Just <$> docSharedWrapper layoutPat fPat-      return (lrdrNameToText lnameF, fExpDoc)-    Seq.singleton <$> docSeq-      [ appSep $ docLit t-      , appSep $ docLit $ Text.pack "{"-      , docSeq $ List.intersperse docCommaSep-               $ fds <&> \case-          (fieldName, Just fieldDoc) -> docSeq-            [ appSep $ docLit fieldName-            , appSep $ docLit $ Text.pack "="-            , fieldDoc >>= colsWrapPat-            ]-          (fieldName, Nothing) -> docLit fieldName-      , docSeparator-      , docLit $ Text.pack "}"-      ]-  ConPat _ lname (RecCon (HsRecFields [] (Just (L _ 0)))) -> do-    -- Abc { .. } -> expr-    let t = lrdrNameToText lname-    Seq.singleton <$> docSeq-      [ appSep $ docLit t-      , docLit $ Text.pack "{..}"-      ]-  ConPat _ lname (RecCon (HsRecFields fs@(_:_) (Just (L _ dotdoti)))) | dotdoti == length fs -> do-    -- Abc { a = locA, .. }-    let t = lrdrNameToText lname-    fds <- fs `forM` \(L _ (HsRecField (L _ fieldOcc) fPat pun)) -> do-      let FieldOcc _ lnameF = fieldOcc-      fExpDoc <- if pun-        then return Nothing-        else Just <$> docSharedWrapper layoutPat fPat-      return (lrdrNameToText lnameF, fExpDoc)-    Seq.singleton <$> docSeq-      [ appSep $ docLit t-      , appSep $ docLit $ Text.pack "{"-      , docSeq $ fds >>= \case-          (fieldName, Just fieldDoc) ->-            [ appSep $ docLit fieldName-            , appSep $ docLit $ Text.pack "="-            , fieldDoc >>= colsWrapPat-            , docCommaSep-            ]-          (fieldName, Nothing) -> [docLit fieldName, docCommaSep]-      , docLit $ Text.pack "..}"-      ]-  TuplePat _ args boxity -> do-    -- (nestedpat1, nestedpat2, nestedpat3) -> expr-    -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr-    case boxity of-      Boxed   -> wrapPatListy args "()" docParenL docParenR-      Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep-  AsPat _ asName asPat -> do-    -- bind@nestedpat -> expr-    wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")-  SigPat _ pat1 (HsPS _ ty1) -> do-    -- i :: Int -> expr-    patDocs <- layoutPat pat1-    tyDoc <- docSharedWrapper layoutType ty1-    case Seq.viewr patDocs of-      Seq.EmptyR -> error "cannot happen ljoiuxoasdcoviuasd"-      xR Seq.:> xN -> do-        xN' <- -- at the moment, we don't support splitting patterns into-               -- multiple lines. but we cannot enforce pasting everything-               -- into one line either, because the type signature will ignore-               -- this if we overflow sufficiently.-               -- In order to prevent syntactically invalid results in such-               -- cases, we need the AddBaseY here.-               -- This can all change when patterns get multiline support.-               docAddBaseY BrIndentRegular $ docSeq-          [ appSep $ return xN-          , appSep $ docLit $ Text.pack "::"-          , docForceSingleline tyDoc-          ]-        return $ xR Seq.|> xN'-  ListPat _ elems ->-    -- [] -> expr1-    -- [nestedpat1, nestedpat2, nestedpat3] -> expr2-    wrapPatListy elems "[]" docBracketL docBracketR-  BangPat _ pat1 -> do-    -- !nestedpat -> expr-    wrapPatPrepend pat1 (docLit $ Text.pack "!")-  LazyPat _ pat1 -> do-    -- ~nestedpat -> expr-    wrapPatPrepend pat1 (docLit $ Text.pack "~")-  NPat _ llit@(L _ ol) mNegative _ -> do-    -- -13 -> expr-    litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc $ GHC.ol_val ol-    negDoc <- docLit $ Text.pack "-"-    pure $ case mNegative of-      Just{}  -> Seq.fromList [negDoc, litDoc]-      Nothing -> Seq.singleton litDoc--  _ -> return <$> briDocByExactInlineOnly "some unknown pattern" lpat--colsWrapPat :: Seq BriDocNumbered -> ToBriDocM BriDocNumbered-colsWrapPat = docCols ColPatterns . fmap return . Foldable.toList--wrapPatPrepend-  :: LPat GhcPs-  -> ToBriDocM BriDocNumbered-  -> ToBriDocM (Seq BriDocNumbered)-wrapPatPrepend pat prepElem = do-  patDocs <- layoutPat pat-  case Seq.viewl patDocs of-    Seq.EmptyL -> return Seq.empty-    x1 Seq.:< xR -> do-      x1' <- docSeq [prepElem, return x1]-      return $ x1' Seq.<| xR--wrapPatListy-  :: [LPat GhcPs]-  -> String-  -> ToBriDocM BriDocNumbered-  -> ToBriDocM BriDocNumbered-  -> ToBriDocM (Seq BriDocNumbered)-wrapPatListy elems both start end = do-  elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat)-  case Seq.viewl elemDocs of-    Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both-    x1 Seq.:< rest -> do-      sDoc <- start-      eDoc <- end-      rest' <- rest `forM` \bd -> docSeq-        [ docCommaSep-        , return bd-        ]-      return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc
− source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--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.Layouters.Decl-import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr-import Language.Haskell.Brittany.Internal.Layouters.Pattern-import Language.Haskell.Brittany.Internal.Prelude-import Language.Haskell.Brittany.Internal.PreludeUtils-import Language.Haskell.Brittany.Internal.Types----layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))-layoutStmt lstmt@(L _ stmt) = do-  indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack-  indentAmount :: Int <--    mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack-  docWrapNode lstmt $ case stmt of-    LastStmt _ body Nothing _ -> do-      layoutExpr body-    BindStmt _ lPat expr -> do-      patDoc <- fmap return $ colsWrapPat =<< layoutPat lPat-      expDoc <- docSharedWrapper layoutExpr expr-      docAlt-        [ docCols-          ColBindStmt-          [ appSep patDoc-          , docSeq-            [ appSep $ docLit $ Text.pack "<-"-            , docAddBaseY BrIndentRegular $ docForceParSpacing expDoc-            ]-          ]-        , docCols-          ColBindStmt-          [ appSep patDoc-          , docAddBaseY BrIndentRegular-            $ docPar (docLit $ Text.pack "<-") (expDoc)-          ]-        ]-    LetStmt _ binds -> do-      let isFree         = indentPolicy == IndentPolicyFree-      let indentFourPlus = indentAmount >= 4-      layoutLocalBinds binds >>= \case-        Nothing        -> docLit $ Text.pack "let"-          -- i just tested the above, and it is indeed allowed. heh.-        Just []        -> docLit $ Text.pack "let" -- this probably never happens-        Just [bindDoc] -> docAlt-          [ -- let bind = expr-            docCols-            ColDoLet-            [ appSep $ docLit $ Text.pack "let"-            , let-                f = case indentPolicy of-                  IndentPolicyFree -> docSetBaseAndIndent-                  IndentPolicyLeft -> docForceSingleline-                  IndentPolicyMultiple | indentFourPlus -> docSetBaseAndIndent-                                       | otherwise      -> docForceSingleline-              in  f $ return bindDoc-            ]-          , -- let-              --   bind = expr-            docAddBaseY BrIndentRegular $ docPar-            (docLit $ Text.pack "let")-            (docSetBaseAndIndent $ return bindDoc)-          ]-        Just bindDocs -> runFilteredAlternative $ do-          -- let aaa = expra-          --     bbb = exprb-          --     ccc = exprc-          addAlternativeCond (isFree || indentFourPlus) $ docSeq-            [ appSep $ docLit $ Text.pack "let"-            , let f = if indentFourPlus-                    then docEnsureIndent BrIndentRegular-                    else docSetBaseAndIndent-              in  f $ docLines $ return <$> bindDocs-            ]-          -- let-          --   aaa = expra-          --   bbb = exprb-          --   ccc = exprc-          addAlternativeCond (not indentFourPlus)-            $ docAddBaseY BrIndentRegular-            $ docPar (docLit $ Text.pack "let")-                     (docSetBaseAndIndent $ docLines $ return <$> bindDocs)-    RecStmt _ stmts _ _ _ _ _ -> runFilteredAlternative $ do-      -- rec stmt1-      --     stmt2-      --     stmt3-      addAlternativeCond (indentPolicy == IndentPolicyFree) $ docSeq-        [ docLit (Text.pack "rec")-        , docSeparator-        , docSetBaseAndIndent $ docLines $ layoutStmt <$> stmts-        ]-      -- rec-      --   stmt1-      --   stmt2-      --   stmt3-      addAlternative $ docAddBaseY BrIndentRegular $ docPar-        (docLit (Text.pack "rec"))-        (docLines $ layoutStmt <$> stmts)-    BodyStmt _ expr _ _ -> do-      expDoc <- docSharedWrapper layoutExpr expr-      docAddBaseY BrIndentRegular $ expDoc-    _ -> briDocByExactInlineOnly "some unknown statement" lstmt
− source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot 
@@ -1,10 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Layouters.Stmt where--import GHC.Hs-import Language.Haskell.Brittany.Internal.Types----layoutStmt :: ToBriDoc' (StmtLR GhcPs GhcPs (LHsExpr GhcPs))
− source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs 
@@ -1,643 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--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.PreludeUtils-import Language.Haskell.Brittany.Internal.Types-import Language.Haskell.Brittany.Internal.Utils-  (FirstLastView(..), splitFirstLast)----layoutType :: ToBriDoc HsType-layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of-  -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"-  HsTyVar _ promoted name -> do-    t <- lrdrNameToTextAnnTypeEqualityIsSpecial name-    case promoted of-      IsPromoted -> docSeq-        [ docSeparator-        , docTick-        , docWrapNode name $ docLit t-        ]-      NotPromoted -> docWrapNode name $ docLit t-  HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do-    let bndrs = getBinders hsf-    typeDoc <- docSharedWrapper layoutType typ2-    tyVarDocs <- layoutTyVarBndrs bndrs-    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType-    let maybeForceML = case typ2 of-          (L _ HsFunTy{}) -> docForceMultiline-          _               -> id-    let-      tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs-      forallDoc = docAlt-        [ let-            open = docLit $ Text.pack "forall"-            in docSeq ([open]++tyVarDocLineList)-        , docPar-            (docLit (Text.pack "forall"))-            (docLines-            $ tyVarDocs <&> \case-                (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname-                (tname, Just doc) -> docEnsureIndent BrIndentRegular-                  $ docLines-                    [ docCols ColTyOpPrefix-                      [ docParenLSep-                      , docLit tname-                      ]-                    , docCols ColTyOpPrefix-                      [ docLit $ Text.pack ":: "-                      , doc-                      ]-                    , docLit $ Text.pack ")"-                    ])-        ]-      contextDoc = case cntxtDocs of-        [] -> docLit $ Text.pack "()"-        [x] -> x-        _ -> docAlt-          [ let-              open  = docLit $ Text.pack "("-              close = docLit $ Text.pack ")"-              list  = List.intersperse docCommaSep-                    $ docForceSingleline <$> cntxtDocs-              in docSeq ([open]++list++[close])-          , let-              open = docCols ColTyOpPrefix-                      [ docParenLSep-                      , docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs-                      ]-              close = docLit $ Text.pack ")"-              list = List.tail cntxtDocs <&> \cntxtDoc ->-                     docCols ColTyOpPrefix-                      [ docCommaSep-                      , docAddBaseY (BrIndentSpecial 2) cntxtDoc-                      ]-            in docPar open $ docLines $ list ++ [close]-          ]-    docAlt-      -- :: forall a b c . (Foo a b c) => a b -> c-      [ docSeq-        [ if null bndrs-            then docEmpty-            else let-              open = docLit $ Text.pack "forall"-              close = docLit $ Text.pack " . "-              in docSeq ([open, docSeparator]++tyVarDocLineList++[close])-        , docForceSingleline contextDoc-        , docLit $ Text.pack " => "-        , docForceSingleline typeDoc-        ]-      -- :: forall a b c-      --  . (Foo a b c)-      -- => a b-      -- -> c-      , docPar-          forallDoc-          ( docLines-            [ docCols ColTyOpPrefix-              [ docWrapNodeRest ltype $ docLit $ Text.pack " . "-              , docAddBaseY (BrIndentSpecial 3)-              $ contextDoc-              ]-            , docCols ColTyOpPrefix-              [ docLit $ Text.pack "=> "-              , docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc-              ]-            ]-          )-      ]-  HsForAllTy _ hsf typ2 -> do-    let bndrs = getBinders hsf-    typeDoc <- layoutType typ2-    tyVarDocs <- layoutTyVarBndrs bndrs-    let maybeForceML = case typ2 of-          (L _ HsFunTy{}) -> docForceMultiline-          _               -> id-    let tyVarDocLineList = processTyVarBndrsSingleline tyVarDocs-    docAlt-      -- forall x . x-      [ docSeq-        [ if null bndrs-            then docEmpty-            else let-              open = docLit $ Text.pack "forall"-              close = docLit $ Text.pack " . "-              in docSeq ([open]++tyVarDocLineList++[close])-        , docForceSingleline $ return $ typeDoc-        ]-      -- :: forall x-      --  . x-      , docPar-          (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)-          ( docCols ColTyOpPrefix-            [ docWrapNodeRest ltype $ docLit $ Text.pack " . "-            , maybeForceML $ return typeDoc-            ]-          )-      -- :: forall-      --      (x :: *)-      --  . x-      , docPar-          (docLit (Text.pack "forall"))-          (docLines-          $ (tyVarDocs <&> \case-              (tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname-              (tname, Just doc) -> docEnsureIndent BrIndentRegular-                $ docLines-                  [ docCols ColTyOpPrefix-                    [ docParenLSep-                    , docLit tname-                    ]-                  , docCols ColTyOpPrefix-                    [ docLit $ Text.pack ":: "-                    , doc-                    ]-                  , docLit $ Text.pack ")"-                  ]-            )-          ++[ docCols ColTyOpPrefix-              [ docWrapNodeRest ltype $ docLit $ Text.pack " . "-              , maybeForceML $ return typeDoc-              ]-            ]-          )-      ]-  HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do-    typeDoc <- docSharedWrapper layoutType typ1-    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType-    let-      contextDoc = docWrapNode lcntxts $ case cntxtDocs of-        [] -> docLit $ Text.pack "()"-        [x] -> x-        _ -> docAlt-          [ let-              open  = docLit $ Text.pack "("-              close = docLit $ Text.pack ")"-              list  = List.intersperse docCommaSep-                    $ docForceSingleline <$> cntxtDocs-              in docSeq ([open]++list++[close])-          , let-              open = docCols ColTyOpPrefix-                      [ docParenLSep-                      , docAddBaseY (BrIndentSpecial 2)-                      $ head cntxtDocs-                      ]-              close = docLit $ Text.pack ")"-              list = List.tail cntxtDocs <&> \cntxtDoc ->-                     docCols ColTyOpPrefix-                      [ docCommaSep-                      , docAddBaseY (BrIndentSpecial 2)-                      $ cntxtDoc-                      ]-            in docPar open $ docLines $ list ++ [close]-          ]-    let maybeForceML = case typ1 of-          (L _ HsFunTy{}) -> docForceMultiline-          _               -> id-    docAlt-      -- (Foo a b c) => a b -> c-      [ docSeq-        [ docForceSingleline contextDoc-        , docLit $ Text.pack " => "-        , docForceSingleline typeDoc-        ]-      --    (Foo a b c)-      -- => a b-      -- -> c-      , docPar-          (docForceSingleline contextDoc)-          ( docCols ColTyOpPrefix-            [ docLit $ Text.pack "=> "-            , docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc-            ]-          )-      ]-  HsFunTy _ _ typ1 typ2 -> do-    typeDoc1 <- docSharedWrapper layoutType typ1-    typeDoc2 <- docSharedWrapper layoutType typ2-    let maybeForceML = case typ2 of-          (L _ HsFunTy{}) -> docForceMultiline-          _               -> id-    hasComments <- hasAnyCommentsBelow ltype-    docAlt $-      [ docSeq-        [ appSep $ docForceSingleline typeDoc1-        , appSep $ docLit $ Text.pack "->"-        , docForceSingleline typeDoc2-        ]-      | not hasComments-      ] ++-      [ docPar-        (docNodeAnnKW ltype Nothing typeDoc1)-        ( docCols ColTyOpPrefix-          [ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"-          , docAddBaseY (BrIndentSpecial 3)-          $ maybeForceML typeDoc2-          ]-        )-      ]-  HsParTy _ typ1 -> do-    typeDoc1 <- docSharedWrapper layoutType typ1-    docAlt-      [ docSeq-        [ docWrapNodeRest ltype $ docLit $ Text.pack "("-        , docForceSingleline typeDoc1-        , docLit $ Text.pack ")"-        ]-      , docPar-          ( docCols ColTyOpPrefix-            [ docWrapNodeRest ltype $ docParenLSep-            , docAddBaseY (BrIndentSpecial 2) $ typeDoc1-            ])-          (docLit $ Text.pack ")")-      ]-  HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do-    let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])-        gather list = \case-          L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1-          final -> (final, list)-    let (typHead, typRest) = gather [typ2] typ1-    docHead <- docSharedWrapper layoutType typHead-    docRest <- docSharedWrapper layoutType `mapM` typRest-    docAlt-      [ docSeq-      $ docForceSingleline docHead : (docRest >>= \d ->-        [ docSeparator, docForceSingleline d ])-      , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)-      ]-  HsAppTy _ typ1 typ2 -> do-    typeDoc1 <- docSharedWrapper layoutType typ1-    typeDoc2 <- docSharedWrapper layoutType typ2-    docAlt-      [ docSeq-        [ docForceSingleline typeDoc1-        , docSeparator-        , docForceSingleline typeDoc2-        ]-      , docPar-          typeDoc1-          (docEnsureIndent BrIndentRegular typeDoc2)-      ]-  HsListTy _ typ1 -> do-    typeDoc1 <- docSharedWrapper layoutType typ1-    docAlt-      [ docSeq-        [ docWrapNodeRest ltype $ docLit $ Text.pack "["-        , docForceSingleline typeDoc1-        , docLit $ Text.pack "]"-        ]-      , docPar-          ( docCols ColTyOpPrefix-            [ docWrapNodeRest ltype $ docLit $ Text.pack "[ "-            , docAddBaseY (BrIndentSpecial 2) $ typeDoc1-            ])-          (docLit $ Text.pack "]")-      ]-  HsTupleTy _ tupleSort typs -> case tupleSort of-    HsUnboxedTuple           -> unboxed-    HsBoxedTuple             -> simple-    HsConstraintTuple        -> simple-    HsBoxedOrConstraintTuple -> simple-   where-    unboxed = if null typs then error "brittany internal error: unboxed unit"-                           else unboxedL-    simple = if null typs then unitL else simpleL-    unitL = docLit $ Text.pack "()"-    simpleL = do-      docs <- docSharedWrapper layoutType `mapM` typs-      let end = docLit $ Text.pack ")"-          lines = List.tail docs <&> \d ->-            docAddBaseY (BrIndentSpecial 2)-              $ docCols ColTyOpPrefix [docCommaSep, d]-          commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)-      docAlt-        [ docSeq $ [docLit $ Text.pack "("]-               ++ docWrapNodeRest ltype commaDocs-               ++ [end]-        , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]-          in docPar-            (docAddBaseY (BrIndentSpecial 2) $ line1)-            (docLines $ docWrapNodeRest ltype lines ++ [end])-        ]-    unboxedL = do-      docs <- docSharedWrapper layoutType `mapM` typs-      let start = docParenHashLSep-          end   = docParenHashRSep-      docAlt-        [ docSeq $ [start]-                ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)-                ++ [end]-        , let-            line1 = docCols ColTyOpPrefix [start, head docs]-            lines  = List.tail docs <&> \d ->-              docAddBaseY (BrIndentSpecial 2)-                $ docCols ColTyOpPrefix [docCommaSep, d]-          in docPar-            (docAddBaseY (BrIndentSpecial 2) line1)-            (docLines $ lines ++ [end])-        ]-  HsOpTy{} -> -- TODO-    briDocByExactInlineOnly "HsOpTy{}" ltype-  -- HsOpTy typ1 opName typ2 -> do-  --   -- TODO: these need some proper fixing. precedences don't add up.-  --   --       maybe the parser just returns some trivial right recursion-  --   --       parse result for any type level operators.-  --   --       need to check how things are handled on the expression level.-  --   let opStr = lrdrNameToText opName-  --   let opLen = Text.length opStr-  --   layouter1@(Layouter desc1 _ _) <- layoutType typ1-  --   layouter2@(Layouter desc2 _ _) <- layoutType typ2-  --   let line = do -- Maybe-  --         l1 <- _ldesc_line desc1-  --         l2 <- _ldesc_line desc2-  --         let len1 = _lColumns_min l1-  --         let len2 = _lColumns_min l2-  --         let len = 2 + opLen + len1 + len2-  --         return $ LayoutColumns-  --           { _lColumns_key = ColumnKeyUnique-  --           , _lColumns_lengths = [len]-  --           , _lColumns_min = len-  --           }-  --   let block = do -- Maybe-  --         rol1 <- descToBlockStart desc1-  --         (min2, max2) <- descToMinMax (1+opLen) desc2-  --         let (minR, maxR) = case descToBlockMinMax desc1 of-  --               Nothing -> (min2, max2)-  --               Just (min1, max1) -> (max min1 min2, max max1 max2)-  --         return $ BlockDesc-  --           { _bdesc_blockStart = rol1-  --           , _bdesc_min = minR-  --           , _bdesc_max = maxR-  --           , _bdesc_opIndentFloatUp = Just (1+opLen)-  --           }-  --   return $ Layouter-  --     { _layouter_desc = LayoutDesc-  --       { _ldesc_line = line-  --       , _ldesc_block = block-  --       }-  --     , _layouter_func = \params -> do-  --         remaining <- getCurRemaining-  --         let allowSameLine = _params_sepLines params /= SepLineTypeOp-  --         case line of-  --           Just (LayoutColumns _ _ m) | m <= remaining && allowSameLine -> do-  --             applyLayouterRestore layouter1 defaultParams-  --             layoutWriteAppend $ Text.pack " " <> opStr <> Text.pack " "-  --             applyLayouterRestore layouter2 defaultParams-  --           _ -> do-  --             let upIndent   = maybe (1+opLen) (max (1+opLen)) $ _params_opIndent params-  --             let downIndent = maybe upIndent (max upIndent) $ _bdesc_opIndentFloatUp =<< _ldesc_block desc2-  --             layoutWithAddIndentN downIndent $ applyLayouterRestore layouter1 defaultParams-  --             layoutWriteNewline-  --             layoutWriteAppend $ opStr <> Text.pack " "-  --             layoutWriteEnsureBlockPlusN downIndent-  --             applyLayouterRestore layouter2 defaultParams-  --               { _params_sepLines = SepLineTypeOp-  --               , _params_opIndent = Just downIndent-  --               }-  --     , _layouter_ast = ltype-  --     }-  HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do-    typeDoc1 <- docSharedWrapper layoutType typ1-    docAlt-      [ docSeq-        [ docWrapNodeRest ltype-        $ docLit-        $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")-        , docForceSingleline typeDoc1-        ]-      , docPar-          ( docLit-          $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))-          )-          (docCols ColTyOpPrefix-            [ docWrapNodeRest ltype-            $ docLit $ Text.pack ":: "-            , docAddBaseY (BrIndentSpecial 2) typeDoc1-            ])-      ]-  -- TODO: test KindSig-  HsKindSig _ typ1 kind1 -> do-    typeDoc1 <- docSharedWrapper layoutType typ1-    kindDoc1 <- docSharedWrapper layoutType kind1-    hasParens <- hasAnnKeyword ltype AnnOpenP-    docAlt-      [ if hasParens-        then docSeq-          [ docLit $ Text.pack "("-          , docForceSingleline typeDoc1-          , docSeparator-          , docLit $ Text.pack "::"-          , docSeparator-          , docForceSingleline kindDoc1-          , docLit $ Text.pack ")"-          ]-        else docSeq-          [ docForceSingleline typeDoc1-          , docSeparator-          , docLit $ Text.pack "::"-          , docSeparator-          , docForceSingleline kindDoc1-          ]-      , if hasParens-        then docLines-          [ docCols-            ColTyOpPrefix-            [ docWrapNodeRest ltype $ docParenLSep-            , docAddBaseY (BrIndentSpecial 3) $ typeDoc1-            ]-          , docCols-            ColTyOpPrefix-            [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "-            , docAddBaseY (BrIndentSpecial 3) kindDoc1-            ]-          , (docLit $ Text.pack ")")-          ]-        else docPar-          typeDoc1-          ( docCols-            ColTyOpPrefix-            [ docWrapNodeRest ltype $ docLit $ Text.pack ":: "-            , docAddBaseY (BrIndentSpecial 3) kindDoc1-            ]-          )-      ]-  HsBangTy{} -> -- TODO-    briDocByExactInlineOnly "HsBangTy{}" ltype-  -- HsBangTy bang typ1 -> do-  --   let bangStr = case bang of-  --         HsSrcBang _ unpackness strictness ->-  --           (++)-  --             (case unpackness of-  --               SrcUnpack   -> "{-# UNPACK -#} "-  --               SrcNoUnpack -> "{-# NOUNPACK -#} "-  --               NoSrcUnpack -> ""-  --             )-  --             (case strictness of-  --               SrcLazy     -> "~"-  --               SrcStrict   -> "!"-  --               NoSrcStrict -> ""-  --             )-  --   let bangLen = length bangStr-  --   layouter@(Layouter desc _ _) <- layoutType typ1-  --   let line = do -- Maybe-  --         l <- _ldesc_line desc-  --         let len = bangLen + _lColumns_min l-  --         return $ LayoutColumns-  --           { _lColumns_key = ColumnKeyUnique-  --           , _lColumns_lengths = [len]-  --           , _lColumns_min = len-  --           }-  --   let block = do -- Maybe-  --         rol <- descToBlockStart desc-  --         (minR,maxR) <- descToBlockMinMax desc-  --         return $ BlockDesc-  --           { _bdesc_blockStart = rol-  --           , _bdesc_min = minR-  --           , _bdesc_max = maxR-  --           , _bdesc_opIndentFloatUp = Nothing-  --           }-  --   return $ Layouter-  --     { _layouter_desc = LayoutDesc-  --       { _ldesc_line = line-  --       , _ldesc_block = block-  --       }-  --     , _layouter_func = \_params -> do-  --         remaining <- getCurRemaining-  --         case line of-  --           Just (LayoutColumns _ _ m) | m <= remaining -> do-  --             layoutWriteAppend $ Text.pack $ bangStr-  --             applyLayouterRestore layouter defaultParams-  --           _ -> do-  --             layoutWriteAppend $ Text.pack $ bangStr-  --             layoutWritePostCommentsRestore ltype-  --             applyLayouterRestore layouter defaultParams-  --     , _layouter_ast = ltype-  --     }-  HsSpliceTy{} -> -- TODO-    briDocByExactInlineOnly "HsSpliceTy{}" ltype-  HsDocTy{} -> -- TODO-    briDocByExactInlineOnly "HsDocTy{}" ltype-  HsRecTy{} -> -- TODO-    briDocByExactInlineOnly "HsRecTy{}" ltype-  HsExplicitListTy _ _ typs -> do-    typDocs <- docSharedWrapper layoutType `mapM` typs-    hasComments <- hasAnyCommentsBelow ltype-    let specialCommaSep = appSep $ docLit $ Text.pack " ,"-    docAlt-      [ docSeq-      $  [docLit $ Text.pack "'["]-      ++ List.intersperse specialCommaSep (docForceSingleline <$> typDocs)-      ++ [docLit $ Text.pack "]"]-      , case splitFirstLast typDocs of-        FirstLastEmpty -> docSeq-          [ docLit $ Text.pack "'["-          , docNodeAnnKW ltype (Just AnnOpenS) $ docLit $ Text.pack "]"-          ]-        FirstLastSingleton e -> docAlt-          [ docSeq-            [ docLit $ Text.pack "'["-            , docNodeAnnKW ltype (Just AnnOpenS) $ docForceSingleline e-            , docLit $ Text.pack "]"-            ]-          , docSetBaseY $ docLines-            [ docSeq-              [ docLit $ Text.pack "'["-              , docSeparator-              , docSetBaseY $ docNodeAnnKW ltype (Just AnnOpenS) e-              ]-            , docLit $ Text.pack " ]"-            ]-          ]-        FirstLast e1 ems eN -> runFilteredAlternative $ do-          addAlternativeCond (not hasComments)-            $  docSeq-            $  [docLit $ Text.pack "'["]-            ++ List.intersperse specialCommaSep (docForceSingleline <$> (e1:ems ++ [docNodeAnnKW ltype (Just AnnOpenS) eN]))-            ++ [docLit $ Text.pack " ]"]-          addAlternative $-            let-              start = docCols ColList-                        [appSep $ docLit $ Text.pack "'[", e1]-              linesM = ems <&> \d ->-                      docCols ColList [specialCommaSep, d]-              lineN = docCols ColList [specialCommaSep, docNodeAnnKW ltype (Just AnnOpenS) eN]-              end   = docLit $ Text.pack " ]"-            in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]-      ]-  HsExplicitTupleTy{} -> -- TODO-    briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype-  HsTyLit _ lit -> case lit of-    HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext-    HsNumTy NoSourceText _ ->-      error "overLitValBriDoc: literal with no SourceText"-    HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext-    HsStrTy NoSourceText _ ->-      error "overLitValBriDoc: literal with no SourceText"-  HsWildCardTy _ ->-    docLit $ Text.pack "_"-  HsSumTy{} -> -- TODO-    briDocByExactInlineOnly "HsSumTy{}" ltype-  HsStarTy _ isUnicode -> do-    if isUnicode-      then docLit $ Text.pack "\x2605" -- Unicode star-      else docLit $ Text.pack "*"-  XHsType{} -> error "brittany internal error: XHsType"-  HsAppKindTy _ ty kind -> do-    t <- docSharedWrapper layoutType ty-    k <- docSharedWrapper layoutType kind-    docAlt-      [ docSeq-          [ docForceSingleline t-          , docSeparator-          , docLit $ Text.pack "@"-          , docForceSingleline k-          ]-      , docPar-          t-          (docSeq [docLit $ Text.pack "@", k ])-      ]--layoutTyVarBndrs-  :: [LHsTyVarBndr () GhcPs]-  -> ToBriDocM [(Text, Maybe (ToBriDocM BriDocNumbered))]-layoutTyVarBndrs = mapM $ \case-  (L _ (UserTyVar _ _ name)) -> return $ (lrdrNameToText name, Nothing)-  (L _ (KindedTyVar _ _ lrdrName kind)) -> do-    d <- docSharedWrapper layoutType kind-    return $ (lrdrNameToText lrdrName, Just $ d)---- there is no specific reason this returns a list instead of a single--- BriDoc node.-processTyVarBndrsSingleline-  :: [(Text, Maybe (ToBriDocM BriDocNumbered))] -> [ToBriDocM BriDocNumbered]-processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case-  (tname, Nothing) -> [docSeparator, docLit tname]-  (tname, Just doc) ->-    [ docSeparator-    , docLit $ Text.pack "(" <> tname <> Text.pack " :: "-    , docForceSingleline $ doc-    , docLit $ Text.pack ")"-    ]--getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass]-getBinders x = case x of-  HsForAllVis _ b -> b-  HsForAllInvis _ b -> fmap withoutSpecificity b-  XHsForAllTelescope _ -> []--withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass-withoutSpecificity = fmap $ \case-  UserTyVar a _ c -> UserTyVar a () c-  KindedTyVar a _ c d -> KindedTyVar a () c d-  XTyVarBndr a -> XTyVarBndr a
− source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs 
@@ -1,101 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Obfuscation where--import Data.Char-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Text as Text-import qualified GHC.OldList as List-import Language.Haskell.Brittany.Internal.Prelude-import Language.Haskell.Brittany.Internal.PreludeUtils-import System.Random----obfuscate :: Text -> IO Text-obfuscate input = do-  let predi x = isAlphaNum x || x `elem` "_'"-  let groups = List.groupBy (\a b -> predi a && predi b) (Text.unpack input)-  let idents = Set.toList $ Set.fromList $ filter (all predi) groups-  let exceptionFilter x | x `elem` keywords = False-      exceptionFilter x | x `elem` extraKWs = False-      exceptionFilter x                     = not $ null $ drop 1 x-  let filtered = filter exceptionFilter idents-  mappings <- fmap Map.fromList $ filtered `forM` \x -> do-    r <- createAlias x-    pure (x, r)-  let groups' = groups <&> \w -> fromMaybe w (Map.lookup w mappings)-  pure $ Text.concat $ fmap Text.pack groups'--keywords :: [String]-keywords =-  [ "case"-  , "class"-  , "data"-  , "default"-  , "deriving"-  , "do"-  , "mdo"-  , "else"-  , "forall"-  , "if"-  , "import"-  , "in"-  , "infix"-  , "infixl"-  , "infixr"-  , "instance"-  , "let"-  , "module"-  , "newtype"-  , "of"-  , "qualified"-  , "then"-  , "type"-  , "where"-  , "_"-  , "foreign"-  , "ccall"-  , "as"-  , "safe"-  , "unsafe"-  , "hiding"-  , "proc"-  , "rec"-  , "family"-  ]--extraKWs :: [String]-extraKWs = ["return", "pure", "Int", "True", "False", "otherwise"]--createAlias :: String -> IO String-createAlias xs = go NoHint xs- where-  go _hint ""       = pure ""-  go hint (c : cr)  = do-    c' <- case hint of-      VocalHint | isUpper c -> randomFrom $ "AAAEEEOOOIIIUUU" ++ ['A' .. 'Z']-      _ | isUpper c         -> randomFrom ['A' .. 'Z']-      VocalHint | isLower c -> randomFrom $ "aaaeeeoooiiiuuu" ++ ['a' .. 'z']-      _ | isLower c         -> randomFrom ['a' .. 'z']-      _                     -> pure c-    cr' <- go (if c' `elem` "aeuioAEUIO" then NoVocalHint else VocalHint) cr-    pure (c' : cr')--data Hint = NoHint | VocalHint | NoVocalHint--_randomRange :: Random a => a -> a -> IO a-_randomRange lo hi = do-  gen <- getStdGen-  let (x, gen') = randomR (lo, hi) gen-  setStdGen gen'-  pure x--randomFrom :: [a] -> IO a-randomFrom l = do-  let hi = length l - 1-  gen <- getStdGen-  let (x, gen') = randomR (0, hi) gen-  setStdGen gen'-  pure $ l List.!! x
− source/library/Language/Haskell/Brittany/Internal/ParseModule.hs 
@@ -1,500 +0,0 @@-{-# OPTIONS_GHC -Wno-implicit-prelude #-}--module Language.Haskell.Brittany.Internal.ParseModule where--import qualified Control.Monad as Monad-import qualified Control.Monad.IO.Class as IO-import qualified Control.Monad.Trans.Except as Except-import qualified Data.Set as Set-import qualified GHC-import qualified GHC.ByteOrder-import qualified GHC.Data.Bag-import qualified GHC.Data.EnumSet-import qualified GHC.Data.StringBuffer-import qualified GHC.Driver.Session-import qualified GHC.Parser.Header-import qualified GHC.Platform-import qualified GHC.Settings-import qualified GHC.Types.Basic-import qualified GHC.Types.SrcLoc-import qualified GHC.Unit.Module.Name-import qualified GHC.Unit.State-import qualified GHC.Unit.Types-import qualified GHC.Utils.Error-import qualified GHC.Utils.Fingerprint-import qualified GHC.Utils.Misc-import qualified GHC.Utils.Ppr.Colour-import qualified Language.Haskell.GHC.ExactPrint.Parsers as ExactPrint-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint---- | Parses a Haskell module. Although this nominally requires IO, it is--- morally pure. It should have no observable effects.-parseModule-  :: IO.MonadIO io-  => [String]-  -> FilePath-  -> (GHC.Driver.Session.DynFlags -> io (Either String a))-  -> String-  -> io (Either String (ExactPrint.Anns, GHC.ParsedSource, a))-parseModule arguments1 filePath checkDynFlags string = Except.runExceptT $ do-  let-    dynFlags1 = GHC.Driver.Session.gopt_set-      -- It feels like this should be either @Sf_Ignore@ or @Sf_None@, but both-      -- of those modes have trouble parsing safe imports (@import safe ...@).-      -- Neither passing in @"-XUnsafe"@ as a command line argument nor having-      -- @{-# LANGUAGE Unsafe #-}@ in the source file seem to help.-      initialDynFlags-        { GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Unsafe-        }-      GHC.Driver.Session.Opt_KeepRawTokenStream-  (dynFlags2, leftovers1, _) <--    GHC.Driver.Session.parseDynamicFlagsCmdLine dynFlags1-      $ fmap GHC.Types.SrcLoc.noLoc arguments1-  handleLeftovers leftovers1-  let-    stringBuffer = GHC.Data.StringBuffer.stringToStringBuffer string-    arguments2 = GHC.Parser.Header.getOptions dynFlags2 stringBuffer filePath-  (dynFlags3, leftovers2, _) <- GHC.Driver.Session.parseDynamicFilePragma-    dynFlags2-    arguments2-  handleLeftovers leftovers2-  dynFlagsResult <- Except.ExceptT $ checkDynFlags dynFlags3-  let-    parseResult =-      ExactPrint.parseModuleFromStringInternal dynFlags3 filePath string-  case parseResult of-    Left errorMessages -> handleErrorMessages errorMessages-    Right (anns, parsedSource) -> pure (anns, parsedSource, dynFlagsResult)--handleLeftovers-  :: Monad m => [GHC.Types.SrcLoc.Located String] -> Except.ExceptT String m ()-handleLeftovers leftovers =-  Monad.unless (null leftovers) . Except.throwE $ "leftovers: " <> show-    (fmap GHC.Types.SrcLoc.unLoc leftovers)--handleErrorMessages-  :: Monad m => GHC.Utils.Error.ErrorMessages -> Except.ExceptT String m a-handleErrorMessages =-  Except.throwE . mappend "errorMessages: " . show . GHC.Data.Bag.bagToList--initialCfgWeights :: GHC.Driver.Session.CfgWeights-initialCfgWeights = GHC.Driver.Session.CFGWeights-  { GHC.Driver.Session.backEdgeBonus = 0-  , GHC.Driver.Session.callWeight = 0-  , GHC.Driver.Session.condBranchWeight = 0-  , GHC.Driver.Session.infoTablePenalty = 0-  , GHC.Driver.Session.likelyCondWeight = 0-  , GHC.Driver.Session.switchWeight = 0-  , GHC.Driver.Session.uncondWeight = 0-  , GHC.Driver.Session.unlikelyCondWeight = 0-  }--initialDynFlags :: GHC.Driver.Session.DynFlags-initialDynFlags = GHC.Driver.Session.DynFlags-  { GHC.Driver.Session.avx = False-  , GHC.Driver.Session.avx2 = False-  , GHC.Driver.Session.avx512cd = False-  , GHC.Driver.Session.avx512er = False-  , GHC.Driver.Session.avx512f = False-  , GHC.Driver.Session.avx512pf = False-  , GHC.Driver.Session.binBlobThreshold = 0-  , GHC.Driver.Session.bmiVersion = Nothing-  , GHC.Driver.Session.cachedPlugins = []-  , GHC.Driver.Session.canGenerateDynamicToo = error "canGenerateDynamicToo"-  , GHC.Driver.Session.canUseColor = False-  , GHC.Driver.Session.cfgWeightInfo = initialCfgWeights-  , GHC.Driver.Session.cmdlineFrameworks = []-  , GHC.Driver.Session.cmmProcAlignment = Nothing-  , GHC.Driver.Session.colScheme = GHC.Utils.Ppr.Colour.defaultScheme-  , GHC.Driver.Session.debugLevel = 0-  , GHC.Driver.Session.depExcludeMods = []-  , GHC.Driver.Session.depIncludeCppDeps = False-  , GHC.Driver.Session.depIncludePkgDeps = False-  , GHC.Driver.Session.depMakefile = ""-  , GHC.Driver.Session.depSuffixes = []-  , GHC.Driver.Session.dirsToClean = error "dirsToClean"-  , GHC.Driver.Session.dump_action = \_ _ _ _ _ _ -> pure ()-  , GHC.Driver.Session.dumpDir = Nothing-  , GHC.Driver.Session.dumpFlags = GHC.Data.EnumSet.fromList []-  , GHC.Driver.Session.dumpPrefix = Nothing-  , GHC.Driver.Session.dumpPrefixForce = Nothing-  , GHC.Driver.Session.dylibInstallName = Nothing-  , GHC.Driver.Session.dynHiSuf = ""-  , GHC.Driver.Session.dynLibLoader = GHC.Driver.Session.Deployable-  , GHC.Driver.Session.dynObjectSuf = ""-  , GHC.Driver.Session.dynOutputFile = Nothing-  , GHC.Driver.Session.enableTimeStats = False-  , GHC.Driver.Session.extensionFlags = GHC.Data.EnumSet.fromList []-  , GHC.Driver.Session.extensions = []-  , GHC.Driver.Session.fatalWarningFlags = GHC.Data.EnumSet.fromList []-  , GHC.Driver.Session.fileSettings = initialFileSettings-  , GHC.Driver.Session.filesToClean = error "filesToClean"-  , GHC.Driver.Session.floatLamArgs = Nothing-  , GHC.Driver.Session.flushErr = GHC.Driver.Session.defaultFlushErr-  , GHC.Driver.Session.flushOut = GHC.Driver.Session.defaultFlushOut-  , GHC.Driver.Session.frameworkPaths = []-  , GHC.Driver.Session.frontendPluginOpts = []-  , GHC.Driver.Session.generalFlags = GHC.Data.EnumSet.fromList []-  , GHC.Driver.Session.generatedDumps = error "generatedDumps"-  , GHC.Driver.Session.ghcHeapSize = Nothing-  , GHC.Driver.Session.ghciHistSize = 0-  , GHC.Driver.Session.ghciScripts = []-  , GHC.Driver.Session.ghcLink = GHC.Driver.Session.NoLink-  , GHC.Driver.Session.ghcMode = GHC.Driver.Session.OneShot-  , GHC.Driver.Session.ghcNameVersion = initialGhcNameVersion-  , GHC.Driver.Session.ghcVersionFile = Nothing-  , GHC.Driver.Session.haddockOptions = Nothing-  , GHC.Driver.Session.hcSuf = ""-  , GHC.Driver.Session.hiDir = Nothing-  , GHC.Driver.Session.hieDir = Nothing-  , GHC.Driver.Session.hieSuf = ""-  , GHC.Driver.Session.historySize = 0-  , GHC.Driver.Session.hiSuf = ""-  , GHC.Driver.Session.homeUnitId = GHC.Unit.Types.stringToUnitId ""-  , GHC.Driver.Session.homeUnitInstanceOfId = Nothing-  , GHC.Driver.Session.homeUnitInstantiations = []-  , GHC.Driver.Session.hooks = error "hooks"-  , GHC.Driver.Session.hpcDir = ""-  , GHC.Driver.Session.hscTarget = GHC.Driver.Session.HscNothing-  , GHC.Driver.Session.ignorePackageFlags = []-  , GHC.Driver.Session.importPaths = []-  , GHC.Driver.Session.includePaths = initialIncludeSpecs-  , GHC.Driver.Session.incoherentOnLoc = initialSrcSpan-  , GHC.Driver.Session.initialUnique = 0-  , GHC.Driver.Session.inlineCheck = Nothing-  , GHC.Driver.Session.interactivePrint = Nothing-  , GHC.Driver.Session.language = Nothing-  , GHC.Driver.Session.ldInputs = []-  , GHC.Driver.Session.liberateCaseThreshold = Nothing-  , GHC.Driver.Session.libraryPaths = []-  , GHC.Driver.Session.liftLamsKnown = False-  , GHC.Driver.Session.liftLamsNonRecArgs = Nothing-  , GHC.Driver.Session.liftLamsRecArgs = Nothing-  , GHC.Driver.Session.llvmConfig = initialLlvmConfig-  , GHC.Driver.Session.log_action = \_ _ _ _ _ -> pure ()-  , GHC.Driver.Session.mainFunIs = Nothing-  , GHC.Driver.Session.mainModIs = GHC.Unit.Types.mkModule-    (GHC.Unit.Types.stringToUnit "")-    (GHC.Unit.Module.Name.mkModuleName "")-  , GHC.Driver.Session.maxErrors = Nothing-  , GHC.Driver.Session.maxInlineAllocSize = 0-  , GHC.Driver.Session.maxInlineMemcpyInsns = 0-  , GHC.Driver.Session.maxInlineMemsetInsns = 0-  , GHC.Driver.Session.maxPmCheckModels = 0-  , GHC.Driver.Session.maxRefHoleFits = Nothing-  , GHC.Driver.Session.maxRelevantBinds = Nothing-  , GHC.Driver.Session.maxSimplIterations = 0-  , GHC.Driver.Session.maxUncoveredPatterns = 0-  , GHC.Driver.Session.maxValidHoleFits = Nothing-  , GHC.Driver.Session.maxWorkerArgs = 0-  , GHC.Driver.Session.newDerivOnLoc = initialSrcSpan-  , GHC.Driver.Session.nextTempSuffix = error "nextTempSuffix"-  , GHC.Driver.Session.nextWrapperNum = error "nextWrapperNum"-  , GHC.Driver.Session.objectDir = Nothing-  , GHC.Driver.Session.objectSuf = ""-  , GHC.Driver.Session.optLevel = 0-  , GHC.Driver.Session.outputFile = Nothing-  , GHC.Driver.Session.outputHi = Nothing-  , GHC.Driver.Session.overlapInstLoc = initialSrcSpan-  , GHC.Driver.Session.packageDBFlags = []-  , GHC.Driver.Session.packageEnv = Nothing-  , GHC.Driver.Session.packageFlags = []-  , GHC.Driver.Session.parMakeCount = Nothing-  , GHC.Driver.Session.pkgTrustOnLoc = initialSrcSpan-  , GHC.Driver.Session.platformConstants = initialPlatformConstants-  , GHC.Driver.Session.platformMisc = initialPlatformMisc-  , GHC.Driver.Session.pluginModNameOpts = []-  , GHC.Driver.Session.pluginModNames = []-  , GHC.Driver.Session.pluginPackageFlags = []-  , GHC.Driver.Session.pprCols = 80-  , GHC.Driver.Session.pprUserLength = 0-  , GHC.Driver.Session.profAuto = GHC.Driver.Session.NoProfAuto-  , GHC.Driver.Session.rawSettings = []-  , GHC.Driver.Session.reductionDepth = GHC.Types.Basic.mkIntWithInf 0-  , GHC.Driver.Session.refLevelHoleFits = Nothing-  , GHC.Driver.Session.reverseErrors = False-  , GHC.Driver.Session.rtccInfo = error "rtccInfo"-  , GHC.Driver.Session.rtldInfo = error "rtldInfo"-  , GHC.Driver.Session.rtsOpts = Nothing-  , GHC.Driver.Session.rtsOptsEnabled = GHC.Driver.Session.RtsOptsNone-  , GHC.Driver.Session.rtsOptsSuggestions = False-  , GHC.Driver.Session.ruleCheck = Nothing-  , GHC.Driver.Session.safeHaskell = GHC.Driver.Session.Sf_Ignore-  , GHC.Driver.Session.safeInfer = False-  , GHC.Driver.Session.safeInferred = False-  , GHC.Driver.Session.simplPhases = 0-  , GHC.Driver.Session.simplTickFactor = 0-  , GHC.Driver.Session.solverIterations = GHC.Types.Basic.mkIntWithInf 0-  , GHC.Driver.Session.specConstrCount = Nothing-  , GHC.Driver.Session.specConstrRecursive = 0-  , GHC.Driver.Session.specConstrThreshold = Nothing-  , GHC.Driver.Session.splitInfo = Nothing-  , GHC.Driver.Session.sseVersion = Nothing-  , GHC.Driver.Session.staticPlugins = []-  , GHC.Driver.Session.strictnessBefore = []-  , GHC.Driver.Session.stubDir = Nothing-  , GHC.Driver.Session.targetPlatform = initialTargetPlatform-  , GHC.Driver.Session.thOnLoc = initialSrcSpan-  , GHC.Driver.Session.toolSettings = initialToolSettings-  , GHC.Driver.Session.trace_action = \_ _ _ a -> a-  , GHC.Driver.Session.trustFlags = []-  , GHC.Driver.Session.trustworthyOnLoc = initialSrcSpan-  , GHC.Driver.Session.ufCreationThreshold = 0-  , GHC.Driver.Session.ufDearOp = 0-  , GHC.Driver.Session.ufDictDiscount = 0-  , GHC.Driver.Session.ufFunAppDiscount = 0-  , GHC.Driver.Session.ufUseThreshold = 0-  , GHC.Driver.Session.ufVeryAggressive = False-  , GHC.Driver.Session.uniqueIncrement = 0-  , GHC.Driver.Session.unitDatabases = Nothing-  , GHC.Driver.Session.unitState = GHC.Unit.State.emptyUnitState-  , GHC.Driver.Session.useColor = GHC.Utils.Misc.Never-  , GHC.Driver.Session.useUnicode = False-  , GHC.Driver.Session.verbosity = 0-  , GHC.Driver.Session.warningFlags = GHC.Data.EnumSet.fromList []-  , GHC.Driver.Session.warnSafeOnLoc = initialSrcSpan-  , GHC.Driver.Session.warnUnsafeOnLoc = initialSrcSpan-  , GHC.Driver.Session.ways = Set.empty-  }--initialFileSettings :: GHC.Driver.Session.FileSettings-initialFileSettings = GHC.Driver.Session.FileSettings-  { GHC.Driver.Session.fileSettings_ghciUsagePath = ""-  , GHC.Driver.Session.fileSettings_ghcUsagePath = ""-  , GHC.Driver.Session.fileSettings_globalPackageDatabase = ""-  , GHC.Driver.Session.fileSettings_tmpDir = ""-  , GHC.Driver.Session.fileSettings_toolDir = Nothing-  , GHC.Driver.Session.fileSettings_topDir = ""-  }--initialGhcNameVersion :: GHC.Driver.Session.GhcNameVersion-initialGhcNameVersion = GHC.Driver.Session.GhcNameVersion-  { GHC.Driver.Session.ghcNameVersion_programName = ""-  , GHC.Driver.Session.ghcNameVersion_projectVersion = ""-  }--initialIncludeSpecs :: GHC.Driver.Session.IncludeSpecs-initialIncludeSpecs = GHC.Driver.Session.IncludeSpecs-  { GHC.Driver.Session.includePathsGlobal = []-  , GHC.Driver.Session.includePathsQuote = []-  }--initialLlvmConfig :: GHC.Driver.Session.LlvmConfig-initialLlvmConfig = GHC.Driver.Session.LlvmConfig-  { GHC.Driver.Session.llvmPasses = []-  , GHC.Driver.Session.llvmTargets = []-  }--initialPlatformConstants :: GHC.Settings.PlatformConstants-initialPlatformConstants = GHC.Settings.PlatformConstants-  { GHC.Settings.pc_AP_STACK_SPLIM = 0-  , GHC.Settings.pc_BITMAP_BITS_SHIFT = 0-  , GHC.Settings.pc_BLOCK_SIZE = 0-  , GHC.Settings.pc_BLOCKS_PER_MBLOCK = 0-  , GHC.Settings.pc_CINT_SIZE = 0-  , GHC.Settings.pc_CLONG_LONG_SIZE = 0-  , GHC.Settings.pc_CLONG_SIZE = 0-  , GHC.Settings.pc_CONTROL_GROUP_CONST_291 = 0-  , GHC.Settings.pc_DYNAMIC_BY_DEFAULT = False-  , GHC.Settings.pc_ILDV_CREATE_MASK = 0-  , GHC.Settings.pc_ILDV_STATE_CREATE = 0-  , GHC.Settings.pc_ILDV_STATE_USE = 0-  , GHC.Settings.pc_LDV_SHIFT = 0-  , GHC.Settings.pc_MAX_CHARLIKE = 0-  , GHC.Settings.pc_MAX_Double_REG = 0-  , GHC.Settings.pc_MAX_Float_REG = 0-  , GHC.Settings.pc_MAX_INTLIKE = 0-  , GHC.Settings.pc_MAX_Long_REG = 0-  , GHC.Settings.pc_MAX_Real_Double_REG = 0-  , GHC.Settings.pc_MAX_Real_Float_REG = 0-  , GHC.Settings.pc_MAX_Real_Long_REG = 0-  , GHC.Settings.pc_MAX_Real_Vanilla_REG = 0-  , GHC.Settings.pc_MAX_Real_XMM_REG = 0-  , GHC.Settings.pc_MAX_SPEC_AP_SIZE = 0-  , GHC.Settings.pc_MAX_SPEC_SELECTEE_SIZE = 0-  , GHC.Settings.pc_MAX_Vanilla_REG = 0-  , GHC.Settings.pc_MAX_XMM_REG = 0-  , GHC.Settings.pc_MIN_CHARLIKE = 0-  , GHC.Settings.pc_MIN_INTLIKE = 0-  , GHC.Settings.pc_MIN_PAYLOAD_SIZE = 0-  , GHC.Settings.pc_MUT_ARR_PTRS_CARD_BITS = 0-  , GHC.Settings.pc_OFFSET_bdescr_blocks = 0-  , GHC.Settings.pc_OFFSET_bdescr_flags = 0-  , GHC.Settings.pc_OFFSET_bdescr_free = 0-  , GHC.Settings.pc_OFFSET_bdescr_start = 0-  , GHC.Settings.pc_OFFSET_Capability_r = 0-  , GHC.Settings.pc_OFFSET_CostCentreStack_mem_alloc = 0-  , GHC.Settings.pc_OFFSET_CostCentreStack_scc_count = 0-  , GHC.Settings.pc_OFFSET_StgArrBytes_bytes = 0-  , GHC.Settings.pc_OFFSET_stgEagerBlackholeInfo = 0-  , GHC.Settings.pc_OFFSET_StgEntCounter_allocd = 0-  , GHC.Settings.pc_OFFSET_StgEntCounter_allocs = 0-  , GHC.Settings.pc_OFFSET_StgEntCounter_entry_count = 0-  , GHC.Settings.pc_OFFSET_StgEntCounter_link = 0-  , GHC.Settings.pc_OFFSET_StgEntCounter_registeredp = 0-  , GHC.Settings.pc_OFFSET_StgFunInfoExtraFwd_arity = 0-  , GHC.Settings.pc_OFFSET_StgFunInfoExtraRev_arity = 0-  , GHC.Settings.pc_OFFSET_stgGCEnter1 = 0-  , GHC.Settings.pc_OFFSET_stgGCFun = 0-  , GHC.Settings.pc_OFFSET_StgHeader_ccs = 0-  , GHC.Settings.pc_OFFSET_StgHeader_ldvw = 0-  , GHC.Settings.pc_OFFSET_StgMutArrPtrs_ptrs = 0-  , GHC.Settings.pc_OFFSET_StgMutArrPtrs_size = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rCCCS = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentNursery = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rCurrentTSO = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rD1 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rD2 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rD3 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rD4 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rD5 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rD6 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rF1 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rF2 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rF3 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rF4 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rF5 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rF6 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rHp = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rHpAlloc = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rHpLim = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rL1 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR1 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR10 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR2 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR3 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR4 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR5 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR6 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR7 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR8 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rR9 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rSp = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rSpLim = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM1 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM2 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM3 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM4 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM5 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rXMM6 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM1 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM2 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM3 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM4 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM5 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rYMM6 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM1 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM2 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM3 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM4 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM5 = 0-  , GHC.Settings.pc_OFFSET_StgRegTable_rZMM6 = 0-  , GHC.Settings.pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0-  , GHC.Settings.pc_OFFSET_StgStack_sp = 0-  , GHC.Settings.pc_OFFSET_StgStack_stack = 0-  , GHC.Settings.pc_OFFSET_StgTSO_alloc_limit = 0-  , GHC.Settings.pc_OFFSET_StgTSO_cccs = 0-  , GHC.Settings.pc_OFFSET_StgTSO_stackobj = 0-  , GHC.Settings.pc_OFFSET_StgUpdateFrame_updatee = 0-  , GHC.Settings.pc_PROF_HDR_SIZE = 0-  , GHC.Settings.pc_REP_CostCentreStack_mem_alloc = 0-  , GHC.Settings.pc_REP_CostCentreStack_scc_count = 0-  , GHC.Settings.pc_REP_StgEntCounter_allocd = 0-  , GHC.Settings.pc_REP_StgEntCounter_allocs = 0-  , GHC.Settings.pc_REP_StgFunInfoExtraFwd_arity = 0-  , GHC.Settings.pc_REP_StgFunInfoExtraRev_arity = 0-  , GHC.Settings.pc_RESERVED_C_STACK_BYTES = 0-  , GHC.Settings.pc_RESERVED_STACK_WORDS = 0-  , GHC.Settings.pc_SIZEOF_CostCentreStack = 0-  , GHC.Settings.pc_SIZEOF_StgArrBytes_NoHdr = 0-  , GHC.Settings.pc_SIZEOF_StgFunInfoExtraRev = 0-  , GHC.Settings.pc_SIZEOF_StgMutArrPtrs_NoHdr = 0-  , GHC.Settings.pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 0-  , GHC.Settings.pc_SIZEOF_StgSMPThunkHeader = 0-  , GHC.Settings.pc_SIZEOF_StgUpdateFrame_NoHdr = 0-  , GHC.Settings.pc_STD_HDR_SIZE = 0-  , GHC.Settings.pc_TAG_BITS = 0-  , GHC.Settings.pc_TICKY_BIN_COUNT = 0-  , GHC.Settings.pc_WORD_SIZE = 0-  }--initialPlatformMini :: GHC.Settings.PlatformMini-initialPlatformMini = GHC.Settings.PlatformMini-  { GHC.Settings.platformMini_arch = GHC.Platform.ArchX86_64-  , GHC.Settings.platformMini_os = GHC.Platform.OSLinux-  }--initialPlatformMisc :: GHC.Driver.Session.PlatformMisc-initialPlatformMisc = GHC.Driver.Session.PlatformMisc-  { GHC.Driver.Session.platformMisc_ghcDebugged = False-  , GHC.Driver.Session.platformMisc_ghcRTSWays = ""-  , GHC.Driver.Session.platformMisc_ghcRtsWithLibdw = False-  , GHC.Driver.Session.platformMisc_ghcThreaded = False-  , GHC.Driver.Session.platformMisc_ghcWithInterpreter = False-  , GHC.Driver.Session.platformMisc_ghcWithSMP = False-  , GHC.Driver.Session.platformMisc_libFFI = False-  , GHC.Driver.Session.platformMisc_llvmTarget = ""-  , GHC.Driver.Session.platformMisc_targetPlatformString = ""-  }--initialSrcSpan :: GHC.Types.SrcLoc.SrcSpan-initialSrcSpan =-  GHC.Types.SrcLoc.UnhelpfulSpan GHC.Types.SrcLoc.UnhelpfulNoLocationInfo--initialTargetPlatform :: GHC.Settings.Platform-initialTargetPlatform = GHC.Settings.Platform-  { GHC.Settings.platformByteOrder = GHC.ByteOrder.LittleEndian-  , GHC.Settings.platformHasGnuNonexecStack = False-  , GHC.Settings.platformHasIdentDirective = False-  , GHC.Settings.platformHasSubsectionsViaSymbols = False-  , GHC.Settings.platformIsCrossCompiling = False-  , GHC.Settings.platformLeadingUnderscore = False-  , GHC.Settings.platformMini = initialPlatformMini-  , GHC.Settings.platformTablesNextToCode = False-  , GHC.Settings.platformUnregisterised = False-  , GHC.Settings.platformWordSize = GHC.Platform.PW8-  }--initialToolSettings :: GHC.Settings.ToolSettings-initialToolSettings = GHC.Settings.ToolSettings-  { GHC.Settings.toolSettings_ccSupportsNoPie = False-  , GHC.Settings.toolSettings_extraGccViaCFlags = []-  , GHC.Settings.toolSettings_ldIsGnuLd = False-  , GHC.Settings.toolSettings_ldSupportsBuildId = False-  , GHC.Settings.toolSettings_ldSupportsCompactUnwind = False-  , GHC.Settings.toolSettings_ldSupportsFilelist = False-  , GHC.Settings.toolSettings_opt_a = []-  , GHC.Settings.toolSettings_opt_c = []-  , GHC.Settings.toolSettings_opt_cxx = []-  , GHC.Settings.toolSettings_opt_F = []-  , GHC.Settings.toolSettings_opt_i = []-  , GHC.Settings.toolSettings_opt_l = []-  , GHC.Settings.toolSettings_opt_L = []-  , GHC.Settings.toolSettings_opt_lc = []-  , GHC.Settings.toolSettings_opt_lcc = []-  , GHC.Settings.toolSettings_opt_lm = []-  , GHC.Settings.toolSettings_opt_lo = []-  , GHC.Settings.toolSettings_opt_P = []-  , GHC.Settings.toolSettings_opt_P_fingerprint =-    GHC.Utils.Fingerprint.fingerprint0-  , GHC.Settings.toolSettings_opt_windres = []-  , GHC.Settings.toolSettings_pgm_a = ("", [])-  , GHC.Settings.toolSettings_pgm_ar = ""-  , GHC.Settings.toolSettings_pgm_c = ""-  , GHC.Settings.toolSettings_pgm_dll = ("", [])-  , GHC.Settings.toolSettings_pgm_F = ""-  , GHC.Settings.toolSettings_pgm_i = ""-  , GHC.Settings.toolSettings_pgm_install_name_tool = ""-  , GHC.Settings.toolSettings_pgm_l = ("", [])-  , GHC.Settings.toolSettings_pgm_L = ""-  , GHC.Settings.toolSettings_pgm_lc = ("", [])-  , GHC.Settings.toolSettings_pgm_lcc = ("", [])-  , GHC.Settings.toolSettings_pgm_libtool = ""-  , GHC.Settings.toolSettings_pgm_lm = ("", [])-  , GHC.Settings.toolSettings_pgm_lo = ("", [])-  , GHC.Settings.toolSettings_pgm_otool = ""-  , GHC.Settings.toolSettings_pgm_P = ("", [])-  , GHC.Settings.toolSettings_pgm_ranlib = ""-  , GHC.Settings.toolSettings_pgm_T = ""-  , GHC.Settings.toolSettings_pgm_windres = ""-  }
− source/library/Language/Haskell/Brittany/Internal/Prelude.hs 
@@ -1,194 +0,0 @@-module Language.Haskell.Brittany.Internal.Prelude-  ( module E-  ) where--import Control.Applicative as E (Alternative(..), Applicative(..))-import Control.Arrow as E ((&&&), (***), (<<<), (>>>), first, second)-import Control.Concurrent as E (forkIO, forkOS, threadDelay)-import Control.Concurrent.Chan as E (Chan)-import Control.Concurrent.MVar as E-  (MVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, takeMVar)-import Control.Exception as E (assert, bracket, evaluate)-import Control.Monad as E-  ( (<$!>)-  , (<=<)-  , (=<<)-  , (>=>)-  , Functor(..)-  , Monad(..)-  , MonadPlus(..)-  , filterM-  , forM-  , forM_-  , forever-  , guard-  , join-  , liftM-  , liftM2-  , liftM3-  , liftM4-  , liftM5-  , mapM-  , mapM_-  , replicateM-  , replicateM_-  , sequence-  , sequence_-  , unless-  , void-  , when-  )-import Control.Monad.Extra as E-  (allM, andM, anyM, ifM, notM, orM, unlessM, whenM)-import Control.Monad.IO.Class as E (MonadIO(..))-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 Data.Map as E (Map)-import Data.Maybe as E-  (Maybe(..), catMaybes, fromMaybe, listToMaybe, maybe, maybeToList)-import Data.Monoid as E-  ( All(..)-  , Alt(..)-  , Any(..)-  , Endo(..)-  , Monoid(..)-  , Product(..)-  , Sum(..)-  , mconcat-  )-import Data.Ord as E (Down(..), Ordering(..), comparing)-import Data.Proxy as E (Proxy(..))-import Data.Ratio as E ((%), Ratio, Rational, denominator, numerator)-import Data.Semigroup as E ((<>), Semigroup(..))-import Data.Sequence as E (Seq)-import Data.Set as E (Set)-import Data.String as E (String)-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-  , traceM-  , traceShow-  , traceShowId-  , traceShowM-  , traceStack-  )-import Foreign.ForeignPtr as E (ForeignPtr)-import Foreign.Storable as E (Storable)-import GHC.Exts as E (Constraint)-import GHC.Hs.Extension as E (GhcPs)-import GHC.Types.Name.Reader as E (RdrName)-import Prelude as E-  ( ($)-  , ($!)-  , (&&)-  , (++)-  , (.)-  , (<$>)-  , Bounded(..)-  , Double-  , Enum(..)-  , Eq(..)-  , Float-  , Floating(..)-  , Foldable-  , Fractional(..)-  , Integer-  , Integral(..)-  , Num(..)-  , Ord(..)-  , RealFloat(..)-  , RealFrac(..)-  , Show(..)-  , Traversable-  , (^)-  , and-  , any-  , const-  , curry-  , error-  , flip-  , foldl-  , foldr-  , foldr1-  , fromIntegral-  , fst-  , head-  , id-  , map-  , not-  , or-  , otherwise-  , print-  , putStr-  , putStrLn-  , realToFrac-  , reverse-  , seq-  , snd-  , subtract-  , traverse-  , uncurry-  , undefined-  , (||)-  )-import System.IO as E (IO, hFlush, stdout)-import Text.Read as E (readMaybe)
− source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs 
@@ -1,66 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Language.Haskell.Brittany.Internal.PreludeUtils where--import Control.Applicative-import Control.DeepSeq (NFData, force)-import Control.Exception.Base (evaluate)-import Control.Monad-import qualified Data.Strict.Maybe as Strict-import Debug.Trace-import Prelude-import System.IO----instance Applicative Strict.Maybe where-  pure = Strict.Just-  Strict.Just f <*> Strict.Just x = Strict.Just (f x)-  _ <*> _ = Strict.Nothing--instance Monad Strict.Maybe where-  Strict.Nothing >>= _ = Strict.Nothing-  Strict.Just x >>= f = f x--instance Alternative Strict.Maybe where-  empty = Strict.Nothing-  x <|> Strict.Nothing = x-  _ <|> x = x--traceFunctionWith :: String -> (a -> String) -> (b -> String) -> (a -> b) -> (a -> b)-traceFunctionWith name s1 s2 f x = trace traceStr y- where-  y = f x-  traceStr =-    name ++ "\nBEFORE:\n" ++ s1 x ++ "\nAFTER:\n" ++ s2 y--(<&!>) :: Monad m => m a -> (a -> b) -> m b-(<&!>) = flip (<$!>)--putStrErrLn :: String -> IO ()-putStrErrLn s = hPutStrLn stderr s--putStrErr :: String -> IO ()-putStrErr s = hPutStr stderr s--printErr :: Show a => a -> IO ()-printErr = putStrErrLn . show--errorIf :: Bool -> a -> a-errorIf False = id-errorIf True  = error "errorIf"--errorIfNote :: Maybe String -> a -> a-errorIfNote Nothing  = id-errorIfNote (Just x) = error x--(<&>) :: Functor f => f a -> (a -> b) -> f b-(<&>) = flip fmap-infixl 4 <&>--(.>) :: (a -> b) -> (b -> c) -> (a -> c)-f .> g = g . f-infixl 9 .>--evaluateDeep :: NFData a => a -> IO a-evaluateDeep = evaluate . force
− source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs 
@@ -1,907 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MonadComprehensions #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Language.Haskell.Brittany.Internal.Transformations.Alt where--import qualified Control.Monad.Memo as Memo-import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS-import Data.HList.ContainsType-import qualified Data.List.Extra-import qualified Data.Semigroup as Semigroup-import qualified Data.Text as Text-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----data AltCurPos = AltCurPos-  { _acp_line :: Int -- chars in the current line-  , _acp_indent :: Int -- current indentation level-  , _acp_indentPrep :: Int -- indentChange affecting the next Par-  , _acp_forceMLFlag :: AltLineModeState-  }-  deriving (Show)--data AltLineModeState-  = AltLineModeStateNone-  | AltLineModeStateForceML Bool -- true ~ decays on next wrap-  | AltLineModeStateForceSL-  | AltLineModeStateContradiction-  -- i.e. ForceX False -> ForceX True -> None-  deriving (Show)--altLineModeRefresh :: AltLineModeState -> AltLineModeState-altLineModeRefresh AltLineModeStateNone          = AltLineModeStateNone-altLineModeRefresh AltLineModeStateForceML{}     = AltLineModeStateForceML False-altLineModeRefresh AltLineModeStateForceSL       = AltLineModeStateForceSL-altLineModeRefresh AltLineModeStateContradiction = AltLineModeStateContradiction--altLineModeDecay :: AltLineModeState -> AltLineModeState-altLineModeDecay AltLineModeStateNone            = AltLineModeStateNone-altLineModeDecay (AltLineModeStateForceML False) = AltLineModeStateForceML True-altLineModeDecay (AltLineModeStateForceML True ) = AltLineModeStateNone-altLineModeDecay AltLineModeStateForceSL         = AltLineModeStateForceSL-altLineModeDecay AltLineModeStateContradiction   = AltLineModeStateContradiction--mergeLineMode :: AltCurPos -> AltLineModeState -> AltCurPos-mergeLineMode acp s = case (_acp_forceMLFlag acp, s) of-  (AltLineModeStateContradiction, _) -> acp-  (AltLineModeStateNone, x) -> acp { _acp_forceMLFlag = x }-  (AltLineModeStateForceSL, AltLineModeStateForceSL) -> acp-  (AltLineModeStateForceML{}, AltLineModeStateForceML{}) ->-    acp { _acp_forceMLFlag = s }-  _ -> acp { _acp_forceMLFlag = AltLineModeStateContradiction }----- removes any BDAlt's from the BriDoc-transformAlts-  :: forall r w s-   . ( Data.HList.ContainsType.ContainsType Config r-     , Data.HList.ContainsType.ContainsType (Seq String) w-     )-  => BriDocNumbered-  -> MultiRWSS.MultiRWS r w s BriDoc-transformAlts =-  MultiRWSS.withMultiStateA (AltCurPos 0 0 0 AltLineModeStateNone)-    . Memo.startEvalMemoT-    . fmap unwrapBriDocNumbered-    . rec-  where-    -- this function is exponential by nature and cannot be improved in any-    -- way i can think of, and i've tried. (stupid StableNames.)-    -- transWrap :: BriDoc -> BriDocNumbered-    -- transWrap brDc = flip StateS.evalState (1::Int)-    --                $ Memo.startEvalMemoT-    --                $ go brDc-    --   where-    --     incGet = StateS.get >>= \i -> StateS.put (i+1) $> i-    --     go :: BriDoc -> Memo.MemoT BriDoc BriDocNumbered (StateS.State Int) BriDocNumbered-    --     go = Memo.memo $ \bdX -> do-    --       i <- lift $ incGet-    --       fmap (\bd' -> (i,bd')) $ case bdX of-    --         BDEmpty           -> return $ BDFEmpty-    --         BDLit t           -> return $ BDFLit t-    --         BDSeq list        -> BDFSeq <$> go `mapM` list-    --         BDCols sig list   -> BDFCols sig <$> go `mapM` list-    --         BDSeparator       -> return $ BDFSeparator-    --         BDAddBaseY ind bd -> BDFAddBaseY ind <$> go bd-    --         BDSetBaseY bd     -> BDFSetBaseY <$> go bd-    --         BDSetIndentLevel bd     -> BDFSetIndentLevel <$> go bd-    --         BDPar ind line indented -> [ BDFPar ind line' indented'-    --                                    | line' <- go line-    --                                    , indented' <- go indented-    --                                    ]-    --         BDAlt alts              -> BDFAlt <$> go `mapM` alts -- not that this will happen-    --         BDForceMultiline  bd    -> BDFForceMultiline <$> go bd-    --         BDForceSingleline bd    -> BDFForceSingleline <$> go bd-    --         BDForwardLineMode bd    -> BDFForwardLineMode <$> go bd-    --         BDExternal k ks c t         -> return $ BDFExternal k ks c t-    --         BDAnnotationPrior annKey bd -> BDFAnnotationPrior annKey <$> go bd-    --         BDAnnotationPost  annKey bd -> BDFAnnotationRest  annKey <$> go bd-    --         BDLines lines         -> BDFLines <$> go `mapM` lines-    --         BDEnsureIndent ind bd -> BDFEnsureIndent ind <$> go bd-    --         BDProhibitMTEL bd     -> BDFProhibitMTEL <$> go bd----    rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] (MultiRWSS.MultiRWS r w (AltCurPos ': s)) BriDocNumbered-    rec bdX@(brDcId, brDc) = do-      let reWrap = (,) brDcId-      -- debugAcp :: AltCurPos <- mGet-      case brDc of-        -- BDWrapAnnKey annKey bd -> do-        --   acp <- mGet-        --   mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }-        --   BDWrapAnnKey annKey <$> rec bd-        BDFEmpty{}    -> processSpacingSimple bdX $> bdX-        BDFLit{}      -> processSpacingSimple bdX $> bdX-        BDFSeq list      ->-          reWrap . BDFSeq <$> list `forM` rec-        BDFCols sig list ->-          reWrap . BDFCols sig <$> list `forM` rec-        BDFSeparator  -> processSpacingSimple bdX $> bdX-        BDFAddBaseY indent bd -> do-          acp <- mGet-          indAdd <- fixIndentationForMultiple acp indent-          mSet $ acp { _acp_indentPrep = max (_acp_indentPrep acp) indAdd }-          r <- rec bd-          acp' <- mGet-          mSet $ acp' { _acp_indent = _acp_indent acp }-          return $ case indent of-            BrIndentNone -> r-            BrIndentRegular ->   reWrap $ BDFAddBaseY (BrIndentSpecial indAdd) r-            BrIndentSpecial i -> reWrap $ BDFAddBaseY (BrIndentSpecial i) r-        BDFBaseYPushCur bd -> do-          acp <- mGet-          mSet $ acp { _acp_indent = _acp_line acp }-          r <- rec bd-          return $ reWrap $ BDFBaseYPushCur r-        BDFBaseYPop bd -> do-          acp <- mGet-          r <- rec bd-          acp' <- mGet-          mSet $ acp' { _acp_indent = _acp_indentPrep acp }-          return $ reWrap $ BDFBaseYPop r-        BDFIndentLevelPushCur bd -> do-          reWrap . BDFIndentLevelPushCur <$> rec bd-        BDFIndentLevelPop bd -> do-          reWrap . BDFIndentLevelPop <$> rec bd-        BDFPar indent sameLine indented -> do-          indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack-          let indAdd = case indent of-                BrIndentNone -> 0-                BrIndentRegular -> indAmount-                BrIndentSpecial i -> i-          acp <- mGet-          let ind = _acp_indent acp + _acp_indentPrep acp + indAdd-          mSet $ acp-            { _acp_indent = ind-            , _acp_indentPrep = 0-            }-          sameLine' <- rec sameLine-          mModify $ \acp' -> acp'-            { _acp_line   = ind-            , _acp_indent = ind-            }-          indented' <- rec indented-          return $ reWrap $ BDFPar indent sameLine' indented'-        BDFAlt [] -> error "empty BDAlt" -- returning BDEmpty instead is a-                                        -- possibility, but i will prefer a-                                        -- fail-early approach; BDEmpty does not-                                        -- make sense semantically for Alt[].-        BDFAlt alts -> do-          altChooser <- mAsk <&> _conf_layout .> _lconfig_altChooser .> confUnpack-          case altChooser of-            AltChooserSimpleQuick -> do-              rec $ head alts-            AltChooserShallowBest -> do-              spacings <- alts `forM` getSpacing-              acp <- mGet-              let lineCheck LineModeInvalid = False-                  lineCheck (LineModeValid (VerticalSpacing _ p _)) =-                    case _acp_forceMLFlag acp of-                      AltLineModeStateNone      -> True-                      AltLineModeStateForceSL{} -> p == VerticalSpacingParNone-                      AltLineModeStateForceML{} -> p /= VerticalSpacingParNone-                      AltLineModeStateContradiction -> False-                  -- TODO: use COMPLETE pragma instead?-                  lineCheck _ = error "ghc exhaustive check is insufficient"-              lconf <- _conf_layout <$> mAsk-              let options = -- trace ("considering options:" ++ show (length alts, acp)) $-                            (zip spacings alts-                             <&> \(vs, bd) -> -- trace ("spacing=" ++ show vs ++ ",hasSpace=" ++ show (hasSpace lconf acp vs) ++ ",lineCheck=" ++ show (lineCheck vs))-                               ( hasSpace1 lconf acp vs && lineCheck vs, bd))-              rec-                 $ fromMaybe (-- trace ("choosing last") $-                              List.last alts)-                 $ Data.List.Extra.firstJust (\(_i::Int, (b,x)) ->-                     [ -- traceShow ("choosing option " ++ show i) $-                       x-                     | b-                     ])-                 $ zip [1..] options-            AltChooserBoundedSearch limit -> do-              spacings <- alts `forM` getSpacings limit-              acp <- mGet-              let lineCheck (VerticalSpacing _ p _) =-                    case _acp_forceMLFlag acp of-                      AltLineModeStateNone      -> True-                      AltLineModeStateForceSL{} -> p == VerticalSpacingParNone-                      AltLineModeStateForceML{} -> p /= VerticalSpacingParNone-                      AltLineModeStateContradiction -> False-              lconf <- _conf_layout <$> mAsk-              let options = -- trace ("considering options:" ++ show (length alts, acp)) $-                            (zip spacings alts-                             <&> \(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))-              let checkedOptions :: [Maybe (Int, BriDocNumbered)] =-                    zip [1..] options <&> (\(i, (b,x)) -> [ (i, x) | b ])-              rec-                 $ fromMaybe (-- trace ("choosing last") $-                              List.last alts)-                 $ Data.List.Extra.firstJust (fmap snd) checkedOptions-        BDFForceMultiline bd -> do-          acp <- mGet-          x <- do-            mSet $ mergeLineMode acp (AltLineModeStateForceML False)-            rec bd-          acp' <- mGet-          mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }-          return $ x-        BDFForceSingleline bd -> do-          acp <- mGet-          x <- do-            mSet $ mergeLineMode acp AltLineModeStateForceSL-            rec bd-          acp' <- mGet-          mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }-          return $ x-        BDFForwardLineMode bd -> do-          acp <- mGet-          x <- do-            mSet $ acp { _acp_forceMLFlag = altLineModeRefresh $ _acp_forceMLFlag acp }-            rec bd-          acp' <- mGet-          mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }-          return $ x-        BDFExternal{} -> processSpacingSimple bdX $> bdX-        BDFPlain{}    -> processSpacingSimple bdX $> bdX-        BDFAnnotationPrior annKey bd -> do-          acp <- mGet-          mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }-          bd' <- rec bd-          return $ reWrap $ BDFAnnotationPrior annKey bd'-        BDFAnnotationRest annKey bd ->-          reWrap . BDFAnnotationRest annKey <$> rec bd-        BDFAnnotationKW annKey kw bd ->-          reWrap . BDFAnnotationKW annKey kw <$> rec bd-        BDFMoveToKWDP annKey kw b bd ->-          reWrap . BDFMoveToKWDP annKey kw b <$> rec bd-        BDFLines [] -> return $ reWrap BDFEmpty -- evil transformation. or harmless.-        BDFLines (l:lr) -> do-          ind <- _acp_indent <$> mGet-          l' <- rec l-          lr' <- lr `forM` \x -> do-            mModify $ \acp -> acp-              { _acp_line   = ind-              , _acp_indent = ind-              }-            rec x-          return $ reWrap $ BDFLines (l':lr')-        BDFEnsureIndent indent bd -> do-          acp <- mGet-          indAdd <- fixIndentationForMultiple acp indent-          mSet $ acp-            { _acp_indentPrep = 0-              -- TODO: i am not sure this is valid, in general.-            , _acp_indent = _acp_indent acp + indAdd-            , _acp_line = max (_acp_line acp) (_acp_indent acp + indAdd)-              -- we cannot use just _acp_line acp + indAdd because of the case-              -- where there are multiple BDFEnsureIndents in the same line.-              -- Then, the actual indentation is relative to the current-              -- indentation, not the current cursor position.-            }-          r <- rec bd-          acp' <- mGet-          mSet $ acp' { _acp_indent = _acp_indent acp }-          return $ case indent of-            BrIndentNone -> r-            BrIndentRegular ->   reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r-            BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r-        BDFNonBottomSpacing _ bd -> rec bd-        BDFSetParSpacing bd -> rec bd-        BDFForceParSpacing bd -> rec bd-        BDFDebug s bd -> do-          acp :: AltCurPos <- mGet-          tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp-          reWrap . BDFDebug s <$> rec bd-    processSpacingSimple-      :: ( MonadMultiReader Config m-         , MonadMultiState AltCurPos m-         , MonadMultiWriter (Seq String) m-         )-      => BriDocNumbered-      -> m ()-    processSpacingSimple bd = getSpacing bd >>= \case-      LineModeInvalid                           -> error "processSpacingSimple inv"-      LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do-        acp <- mGet-        mSet $ acp { _acp_line = _acp_line acp + i }-      LineModeValid VerticalSpacing{}  -> error "processSpacingSimple par"-      _ -> error "ghc exhaustive check is insufficient"-    hasSpace1 :: LayoutConfig -> AltCurPos -> LineModeValidity VerticalSpacing -> Bool-    hasSpace1 _ _ LineModeInvalid = False-    hasSpace1 lconf acp (LineModeValid vs) = hasSpace2 lconf acp vs-    hasSpace1 _ _ _ = error "ghc exhaustive check is insufficient"-    hasSpace2 :: LayoutConfig -> AltCurPos -> VerticalSpacing -> Bool-    hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParNone _)-      = line + sameLine <= confUnpack (_lconfig_cols lconf)-    hasSpace2 lconf (AltCurPos line indent indentPrep _) (VerticalSpacing sameLine (VerticalSpacingParSome par) _)-      = line + sameLine <= confUnpack (_lconfig_cols lconf)-        && indent + indentPrep + par <= confUnpack (_lconfig_cols lconf)-    hasSpace2 lconf (AltCurPos line _indent _ _) (VerticalSpacing sameLine VerticalSpacingParAlways{} _)-      = line + sameLine <= confUnpack (_lconfig_cols lconf)--getSpacing-  :: forall m-   . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)-  => BriDocNumbered-  -> m (LineModeValidity VerticalSpacing)-getSpacing !bridoc = rec bridoc- where-  rec :: BriDocNumbered -> m (LineModeValidity VerticalSpacing)-  rec (brDcId, brDc) = do-    config <- mAsk-    let colMax = config & _conf_layout & _lconfig_cols & confUnpack-    result <- case brDc of-      -- BDWrapAnnKey _annKey bd -> rec bd-      BDFEmpty ->-        return $ LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False-      BDFLit t ->-        return $ LineModeValid $ VerticalSpacing (Text.length t) VerticalSpacingParNone False-      BDFSeq list ->-        sumVs <$> rec `mapM` list-      BDFCols _sig list -> sumVs <$> rec `mapM` list-      BDFSeparator ->-        return $ LineModeValid $ VerticalSpacing 1 VerticalSpacingParNone False-      BDFAddBaseY indent bd -> do-        mVs <- rec bd-        return $ mVs <&> \vs -> vs-          { _vs_paragraph = case _vs_paragraph vs of-              VerticalSpacingParNone -> VerticalSpacingParNone-              VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of-                BrIndentNone      -> i-                BrIndentRegular   -> i + ( confUnpack-                                         $ _lconfig_indentAmount-                                         $ _conf_layout-                                         $ config-                                         )-                BrIndentSpecial j -> i + j-              VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of-                BrIndentNone      -> i-                BrIndentRegular   -> i + ( confUnpack-                                         $ _lconfig_indentAmount-                                         $ _conf_layout-                                         $ config-                                         )-                BrIndentSpecial j -> i + j-          }-      BDFBaseYPushCur bd -> do-        mVs <- rec bd-        return $ mVs <&> \vs -> vs-          -- We leave par as-is, even though it technically is not-          -- accurate (in general).-          -- the reason is that we really want to _keep_ it Just if it is-          -- just so we properly communicate the is-multiline fact.-          -- An alternative would be setting to (Just 0).-          { _vs_sameLine = max (_vs_sameLine vs)-                               (case _vs_paragraph vs of-                                  VerticalSpacingParNone -> 0-                                  VerticalSpacingParSome i -> i-                                  VerticalSpacingParAlways i -> min colMax i)-          , _vs_paragraph = VerticalSpacingParSome 0-          }-      BDFBaseYPop bd -> rec bd-      BDFIndentLevelPushCur bd -> rec bd-      BDFIndentLevelPop bd -> rec bd-      BDFPar BrIndentNone sameLine indented -> do-        mVs <- rec sameLine-        mIndSp <- rec indented-        return-          $ [ VerticalSpacing lsp pspResult parFlagResult-            | VerticalSpacing lsp mPsp _ <- mVs-            , indSp <- mIndSp-            , lineMax <- getMaxVS $ mIndSp-            , let pspResult = case mPsp of-                    VerticalSpacingParSome psp   -> VerticalSpacingParSome $ max psp lineMax-                    VerticalSpacingParNone       -> VerticalSpacingParSome $ lineMax-                    VerticalSpacingParAlways psp -> VerticalSpacingParAlways $ max psp lineMax-            , let parFlagResult =  mPsp == VerticalSpacingParNone-                                && _vs_paragraph indSp ==  VerticalSpacingParNone-                                && _vs_parFlag indSp-            ]-      BDFPar{} -> error "BDPar with indent in getSpacing"-      BDFAlt [] -> error "empty BDAlt"-      BDFAlt (alt:_) -> rec alt-      BDFForceMultiline  bd -> do-        mVs <- rec bd-        return $ mVs >>= _vs_paragraph .> \case-          VerticalSpacingParNone -> LineModeInvalid-          _  -> mVs-      BDFForceSingleline bd -> do-        mVs <- rec bd-        return $ mVs >>= _vs_paragraph .> \case-          VerticalSpacingParNone -> mVs-          _  -> LineModeInvalid-      BDFForwardLineMode bd -> rec bd-      BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of-        [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False-        _   -> VerticalSpacing 999 VerticalSpacingParNone False-      BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of-        [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False-        _   -> VerticalSpacing 999 VerticalSpacingParNone False-      BDFAnnotationPrior _annKey bd -> rec bd-      BDFAnnotationKW _annKey _kw bd -> rec bd-      BDFAnnotationRest  _annKey bd -> rec bd-      BDFMoveToKWDP _annKey _kw _b bd -> rec bd-      BDFLines [] -> return-        $ LineModeValid-        $ VerticalSpacing 0 VerticalSpacingParNone False-      BDFLines ls@(_:_) -> do-        lSps <- rec `mapM` ls-        let (mVs:_) = lSps -- separated into let to avoid MonadFail-        return $ [ VerticalSpacing lsp (VerticalSpacingParSome $ lineMax) False-                 | VerticalSpacing lsp _ _ <- mVs-                 , lineMax <- getMaxVS $ maxVs $ lSps-                 ]-      BDFEnsureIndent indent bd -> do-        mVs <- rec bd-        let addInd = case indent of-              BrIndentNone      -> 0-              BrIndentRegular   -> confUnpack-                                 $ _lconfig_indentAmount-                                 $ _conf_layout-                                 $ config-              BrIndentSpecial i -> i-        return $ mVs <&> \(VerticalSpacing lsp psp pf) ->-          VerticalSpacing (lsp + addInd) psp pf-      BDFNonBottomSpacing b bd -> do-        mVs <- rec bd-        return-          $   mVs-          <|> LineModeValid-                (VerticalSpacing-                  0-                  (if b then VerticalSpacingParSome 0-                        else VerticalSpacingParAlways colMax-                  )-                  False-                )-      BDFSetParSpacing bd -> do-        mVs <- rec bd-        return $ mVs <&> \vs -> vs { _vs_parFlag = True }-      BDFForceParSpacing bd -> do-        mVs <- rec bd-        return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ]-      BDFDebug s bd -> do-        r <- rec bd-        tellDebugMess $ "getSpacing: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): mVs=" ++ show r-        return r-    return result-  maxVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing-  maxVs = foldl'-    (liftM2 (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->-        VerticalSpacing (max x1 y1) (case (x2, y2) of-          (x, VerticalSpacingParNone) -> x-          (VerticalSpacingParNone, x) -> x-          (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->-            VerticalSpacingParAlways $ max i j-          (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->-            VerticalSpacingParAlways $ max i j-          (VerticalSpacingParSome j, VerticalSpacingParAlways i) ->-            VerticalSpacingParAlways $ max i j-          (VerticalSpacingParSome x, VerticalSpacingParSome y) ->-            VerticalSpacingParSome $ max x y) False))-    (LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone False)-  sumVs :: [LineModeValidity VerticalSpacing] -> LineModeValidity VerticalSpacing-  sumVs sps = foldl' (liftM2 go) initial sps-   where-    go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing-      (x1 + y1)-      (case (x2, y2) of-        (x, VerticalSpacingParNone) -> x-        (VerticalSpacingParNone, x) -> x-        (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->-          VerticalSpacingParAlways $ i+j-        (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->-          VerticalSpacingParAlways $ i+j-        (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->-          VerticalSpacingParAlways $ i+j-        (VerticalSpacingParSome x, VerticalSpacingParSome y) ->-          VerticalSpacingParSome $ x + y)-      x3-    singleline (LineModeValid x) = _vs_paragraph x == VerticalSpacingParNone-    singleline _                 = False-    isPar (LineModeValid x) = _vs_parFlag x-    isPar _                 = False-    parFlag = case sps of-      [] -> True-      _ -> all singleline (List.init sps) && isPar (List.last sps)-    initial = LineModeValid $ VerticalSpacing 0 VerticalSpacingParNone parFlag-  getMaxVS :: LineModeValidity VerticalSpacing -> LineModeValidity Int-  getMaxVS = fmap $ \(VerticalSpacing x1 x2 _) -> x1 `max` case x2 of-    VerticalSpacingParSome i -> i-    VerticalSpacingParNone -> 0-    VerticalSpacingParAlways i -> i--data SpecialCompare = Unequal | Smaller | Bigger--getSpacings-  :: forall m-   . (MonadMultiReader Config m, MonadMultiWriter (Seq String) m)-  => Int-  -> BriDocNumbered-  -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]-getSpacings limit bridoc = preFilterLimit <$> rec bridoc-  where-    -- when we do `take K . filter someCondition` on a list of spacings, we-    -- need to first (also) limit the size of the input list, otherwise a-    -- _large_ input with a similarly _large_ prefix not passing our filtering-    -- process could lead to exponential runtime behaviour.-    -- TODO: 3 is arbitrary.-    preFilterLimit :: [VerticalSpacing] -> [VerticalSpacing]-    preFilterLimit = take (3*limit)-    memoWithKey :: Memo.MonadMemo k v m1 => k -> m1 v -> m1 v-    memoWithKey k v = Memo.memo (const v) k-    rec :: BriDocNumbered -> Memo.MemoT Int [VerticalSpacing] m [VerticalSpacing]-    rec (brDcId, brdc) = memoWithKey brDcId $ do-      config <- mAsk-      let colMax = config & _conf_layout & _lconfig_cols & confUnpack-      let hasOkColCount (VerticalSpacing lsp psp _) =-            lsp <= colMax && case psp of-              VerticalSpacingParNone -> True-              VerticalSpacingParSome i -> i <= colMax-              VerticalSpacingParAlways{} -> True-      let specialCompare vs1 vs2 =-            if (  (_vs_sameLine vs1 == _vs_sameLine vs2)-               && (_vs_parFlag vs1 == _vs_parFlag vs2)-               )-              then case (_vs_paragraph vs1, _vs_paragraph vs2) of-                (VerticalSpacingParAlways i1, VerticalSpacingParAlways i2) ->-                  if i1 < i2 then Smaller else Bigger-                (p1, p2) -> if p1 == p2 then Smaller else Unequal-              else Unequal-      let allowHangingQuasiQuotes =-            config-              & _conf_layout-              & _lconfig_allowHangingQuasiQuotes-              & confUnpack-      let -- this is like List.nub, with one difference: if two elements-          -- are unequal only in _vs_paragraph, with both ParAlways, we-          -- treat them like equals and replace the first occurence with the-          -- smallest member of this "equal group".-          specialNub :: [VerticalSpacing] -> [VerticalSpacing]-          specialNub [] = []-          specialNub (x1 : xr) = case go x1 xr of-            (r, xs') -> r : specialNub xs'-           where-            go y1 []        = (y1, [])-            go y1 (y2 : yr) = case specialCompare y1 y2 of-              Unequal -> let (r, yr') = go y1 yr in (r, y2 : yr')-              Smaller -> go y1 yr-              Bigger  -> go y2 yr-      let -- the standard function used to enforce a constant upper bound-          -- on the number of elements returned for each node. Should be-          -- applied whenever in a parent the combination of spacings from-          -- its children might cause excess of the upper bound.-          filterAndLimit :: [VerticalSpacing] -> [VerticalSpacing]-          filterAndLimit = take limit-                           -- prune so we always consider a constant-                           -- amount of spacings per node of the BriDoc.-                         . specialNub-                           -- In the end we want to know if there is at least-                           -- one valid spacing for any alternative.-                           -- If there are duplicates in the list, then these-                           -- will either all be valid (so having more than the-                           -- first is pointless) or all invalid (in which-                           -- case having any of them is pointless).-                           -- Nonetheless I think the order of spacings should-                           -- be preserved as it provides a deterministic-                           -- choice for which spacings to prune (which is-                           -- an argument against simply using a Set).-                           -- I have also considered `fmap head . group` which-                           -- seems to work similarly well for common cases-                           -- and which might behave even better when it comes-                           -- to determinism of the algorithm. But determinism-                           -- should not be overrated here either - in the end-                           -- this is about deterministic behaviour of the-                           -- pruning we do that potentially results in-                           -- non-optimal layouts, and we'd rather take optimal-                           -- layouts when we can than take non-optimal layouts-                           -- just to be consistent with other cases where-                           -- we'd choose non-optimal layouts.-                         . filter hasOkColCount-                           -- throw out any spacings (i.e. children) that-                           -- already use more columns than available in-                           -- total.-                         . preFilterLimit-      result <- case brdc of-        -- BDWrapAnnKey _annKey bd -> rec bd-        BDFEmpty ->-          return $ [VerticalSpacing 0 VerticalSpacingParNone False]-        BDFLit t ->-          return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]-        BDFSeq list ->-          fmap sumVs . mapM filterAndLimit <$> rec `mapM` list-        BDFCols _sig list ->-          fmap sumVs . mapM filterAndLimit <$> rec `mapM` list-        BDFSeparator ->-          return $ [VerticalSpacing 1 VerticalSpacingParNone False]-        BDFAddBaseY indent bd -> do-          mVs <- rec bd-          return $ mVs <&> \vs -> vs-            { _vs_paragraph = case _vs_paragraph vs of-                VerticalSpacingParNone -> VerticalSpacingParNone-                VerticalSpacingParAlways i -> VerticalSpacingParAlways $ case indent of-                  BrIndentNone      -> i-                  BrIndentRegular   -> i + ( confUnpack-                                           $ _lconfig_indentAmount-                                           $ _conf_layout-                                           $ config-                                           )-                  BrIndentSpecial j -> i + j-                VerticalSpacingParSome i -> VerticalSpacingParSome $ case indent of-                  BrIndentNone      -> i-                  BrIndentRegular   -> i + ( confUnpack-                                           $ _lconfig_indentAmount-                                           $ _conf_layout-                                           $ config-                                           )-                  BrIndentSpecial j -> i + j-            }-        BDFBaseYPushCur bd -> do-          mVs <- rec bd-          return $ mVs <&> \vs -> vs-            -- We leave par as-is, even though it technically is not-            -- accurate (in general).-            -- the reason is that we really want to _keep_ it Just if it is-            -- just so we properly communicate the is-multiline fact.-            -- An alternative would be setting to (Just 0).-            { _vs_sameLine = max (_vs_sameLine vs)-                                 (case _vs_paragraph vs of-                                  VerticalSpacingParNone -> 0-                                  VerticalSpacingParSome i -> i-                                  VerticalSpacingParAlways i -> min colMax i)-            , _vs_paragraph = case _vs_paragraph vs of-                VerticalSpacingParNone -> VerticalSpacingParNone-                VerticalSpacingParSome i -> VerticalSpacingParSome i-                VerticalSpacingParAlways i -> VerticalSpacingParAlways i-            }-        BDFBaseYPop bd -> rec bd-        BDFIndentLevelPushCur bd -> rec bd-        BDFIndentLevelPop bd -> rec bd-        BDFPar BrIndentNone sameLine indented -> do-          mVss   <- filterAndLimit <$> rec sameLine-          indSps <- filterAndLimit <$> rec indented-          let mVsIndSp = take limit-                       $ [ (x,y)-                         | x<-mVss-                         , y<-indSps-                         ]-          return $ mVsIndSp <&>-            \(VerticalSpacing lsp mPsp _, indSp) ->-              VerticalSpacing-                lsp-                (case mPsp of-                  VerticalSpacingParSome psp ->-                    VerticalSpacingParSome $ max psp $ getMaxVS indSp -- TODO-                  VerticalSpacingParNone -> spMakePar indSp-                  VerticalSpacingParAlways psp ->-                    VerticalSpacingParAlways $ max psp $ getMaxVS indSp)-                (  mPsp == VerticalSpacingParNone-                && _vs_paragraph indSp == VerticalSpacingParNone-                && _vs_parFlag indSp-                )--        BDFPar{} -> error "BDPar with indent in getSpacing"-        BDFAlt [] -> error "empty BDAlt"-        -- BDAlt (alt:_) -> rec alt-        BDFAlt alts -> do-          r <- rec `mapM` alts-          return $ filterAndLimit =<< r-        BDFForceMultiline  bd -> do-          mVs <- filterAndLimit <$> rec bd-          return $ filter ((/=VerticalSpacingParNone) . _vs_paragraph) mVs-        BDFForceSingleline bd -> do-          mVs <- filterAndLimit <$> rec bd-          return $ filter ((==VerticalSpacingParNone) . _vs_paragraph) mVs-        BDFForwardLineMode bd -> rec bd-        BDFExternal _ _ _ txt | [t] <- Text.lines txt ->-          return $ [VerticalSpacing (Text.length t) VerticalSpacingParNone False]-        BDFExternal{} ->-          return $ [] -- yes, we just assume that we cannot properly layout-                      -- this.-        BDFPlain t -> return-          [ case Text.lines t of-              []       -> VerticalSpacing 0 VerticalSpacingParNone False-              [t1    ] -> VerticalSpacing-                (Text.length t1)-                VerticalSpacingParNone-                False-              (t1 : _) -> VerticalSpacing-                (Text.length t1)-                (VerticalSpacingParAlways 0)-                True-          | allowHangingQuasiQuotes-          ]-        BDFAnnotationPrior _annKey bd -> rec bd-        BDFAnnotationKW _annKey _kw bd -> rec bd-        BDFAnnotationRest  _annKey bd -> rec bd-        BDFMoveToKWDP _annKey _kw _b bd -> rec bd-        BDFLines [] -> return $ [VerticalSpacing 0 VerticalSpacingParNone False]-        BDFLines ls@(_:_) -> do-          -- 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-          -- paragraph". That most importantly means that Lines should never-          -- be inserted anywhere but at the start of the line. A-          -- counterexample would be anything like Seq[Lit "foo", Lines].-          lSpss <- map filterAndLimit <$> rec `mapM` ls-          let worbled = fmap reverse-                      $ sequence-                      $ reverse-                      $ lSpss-              sumF lSps@(lSp1:_) = VerticalSpacing (_vs_sameLine lSp1)-                                                   (spMakePar $ maxVs lSps)-                                                   False-              sumF [] = error $ "should not happen. if my logic does not fail"-                             ++ "me, this follows from not (null ls)."-          return $ sumF <$> worbled-          -- lSpss@(mVs:_) <- rec `mapM` ls-          -- return $ case Control.Lens.transposeOf traverse lSpss of -- TODO: we currently only-          --                      -- consider the first alternative for the-          --                      -- line's spacings.-          --                      -- also i am not sure if always including-          --                      -- the first line length in the paragraph-          --                      -- length gives the desired results.-          --                      -- it is the safe path though, for now.-          --   []       -> []-          --   (lSps:_) -> mVs <&> \(VerticalSpacing lsp _) ->-          --     VerticalSpacing lsp $ VerticalSpacingParSome $ getMaxVS $ maxVs lSps-        BDFEnsureIndent indent bd -> do-          mVs <- rec bd-          let addInd = case indent of-                BrIndentNone      -> 0-                BrIndentRegular   -> confUnpack-                                   $ _lconfig_indentAmount-                                   $ _conf_layout-                                   $ config-                BrIndentSpecial i -> i-          return $ mVs <&> \(VerticalSpacing lsp psp parFlag) ->-            VerticalSpacing (lsp + addInd) psp parFlag-        BDFNonBottomSpacing b bd -> do-          -- TODO: the `b` flag is an ugly hack, but I was not able to make-          -- all tests work without it. It should be possible to have-          -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this-          -- problem but breaks certain other cases.-          mVs <- rec bd-          return $ if null mVs-            then [VerticalSpacing-                    0-                    (if b then VerticalSpacingParSome 0-                          else VerticalSpacingParAlways colMax-                    )-                    False-                 ]-            else mVs <&> \vs -> vs-              { _vs_sameLine = min colMax (_vs_sameLine vs)-              , _vs_paragraph = case _vs_paragraph vs of-                  VerticalSpacingParNone -> VerticalSpacingParNone-                  VerticalSpacingParAlways i-                    | b         -> VerticalSpacingParSome 0-                    | otherwise -> VerticalSpacingParAlways i-                  VerticalSpacingParSome i-                    | b         -> VerticalSpacingParSome 0-                    | otherwise -> VerticalSpacingParAlways i-              }-            -- the version below is an alternative idea: fold the input-            -- spacings into a single spacing. This was hoped to improve in-            -- certain cases where non-bottom alternatives took up "too much-            -- explored search space"; the downside is that it also cuts-            -- the search-space short in other cases where it is not necessary,-            -- leading to unnecessary new-lines. Disabled for now. A better-            -- solution would require conditionally folding the search-space-            -- only in appropriate locations (i.e. a new BriDoc node type-            -- for this purpose, perhaps "BDFNonBottomSpacing1").-            -- else-            --   [ Foldable.foldl1-            --     (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->-            --       VerticalSpacing-            --         (min x1 y1)-            --         (case (x2, y2) of-            --           (x, VerticalSpacingParNone) -> x-            --           (VerticalSpacingParNone, x) -> x-            --           (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->-            --             VerticalSpacingParAlways $ min i j-            --           (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->-            --             VerticalSpacingParAlways $ min i j-            --           (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->-            --             VerticalSpacingParAlways $ min i j-            --           (VerticalSpacingParSome x, VerticalSpacingParSome y) ->-            --             VerticalSpacingParSome $ min x y)-            --         False)-            --     mVs-            --   ]-        BDFSetParSpacing bd -> do-          mVs <- rec bd-          return $ mVs <&> \vs -> vs { _vs_parFlag = True }-        BDFForceParSpacing bd -> do-          mVs <- preFilterLimit <$> rec bd-          return $ [ vs | vs <- mVs, _vs_parFlag vs || _vs_paragraph vs == VerticalSpacingParNone ]-        BDFDebug s bd -> do-          r <- rec bd-          tellDebugMess $ "getSpacings: BDFDebug " ++ show s ++ " (node-id=" ++ show brDcId ++ "): vs=" ++ show (take 9 r)-          return r-      return result-    maxVs :: [VerticalSpacing] -> VerticalSpacing-    maxVs = foldl'-      (\(VerticalSpacing x1 x2 _) (VerticalSpacing y1 y2 _) ->-          VerticalSpacing-            (max x1 y1)-            (case (x2, y2) of-              (x, VerticalSpacingParNone) -> x-              (VerticalSpacingParNone, x) -> x-              (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->-                VerticalSpacingParAlways $ max i j-              (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->-                VerticalSpacingParAlways $ max i j-              (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->-                VerticalSpacingParAlways $ max i j-              (VerticalSpacingParSome x, VerticalSpacingParSome y) ->-                VerticalSpacingParSome $ max x y)-            False)-      (VerticalSpacing 0 VerticalSpacingParNone False)-    sumVs :: [VerticalSpacing] -> VerticalSpacing-    sumVs sps = foldl' go initial sps-     where-      go (VerticalSpacing x1 x2 x3) (VerticalSpacing y1 y2 _) = VerticalSpacing-        (x1 + y1)-        (case (x2, y2) of-          (x, VerticalSpacingParNone) -> x-          (VerticalSpacingParNone, x) -> x-          (VerticalSpacingParAlways i, VerticalSpacingParAlways j) ->-            VerticalSpacingParAlways $ i+j-          (VerticalSpacingParAlways i, VerticalSpacingParSome j) ->-            VerticalSpacingParAlways $ i+j-          (VerticalSpacingParSome i, VerticalSpacingParAlways j) ->-            VerticalSpacingParAlways $ i+j-          (VerticalSpacingParSome x, VerticalSpacingParSome y) -> VerticalSpacingParSome $ x + y)-        x3-      singleline x = _vs_paragraph x == VerticalSpacingParNone-      isPar      x = _vs_parFlag x-      parFlag = case sps of-        [] -> True-        _ -> all singleline (List.init sps) && isPar (List.last sps)-      initial = VerticalSpacing 0 VerticalSpacingParNone parFlag-    getMaxVS :: VerticalSpacing -> Int-    getMaxVS (VerticalSpacing x1 x2 _) = x1 `max` case x2 of-      VerticalSpacingParSome i -> i-      VerticalSpacingParNone -> 0-      VerticalSpacingParAlways i -> i-    spMakePar :: VerticalSpacing -> VerticalSpacingPar-    spMakePar (VerticalSpacing x1 x2 _) = case x2 of-      VerticalSpacingParSome i -> VerticalSpacingParSome $ x1 `max` i-      VerticalSpacingParNone -> VerticalSpacingParSome $ x1-      VerticalSpacingParAlways i -> VerticalSpacingParAlways $ x1 `max` i--fixIndentationForMultiple-  :: (MonadMultiReader (CConfig Identity) m) => AltCurPos -> BrIndent -> m Int-fixIndentationForMultiple acp indent = do-  indAmount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> confUnpack-  let indAddRaw = case indent of-        BrIndentNone      -> 0-        BrIndentRegular   -> indAmount-        BrIndentSpecial i -> i-  -- for IndentPolicyMultiple, we restrict the amount of added-  -- indentation in such a manner that we end up on a multiple of the-  -- base indentation.-  indPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack-  pure $ if indPolicy == IndentPolicyMultiple-    then-      let indAddMultiple1 =-            indAddRaw - ((_acp_indent acp + indAddRaw) `mod` indAmount)-          indAddMultiple2 = if indAddMultiple1 <= 0-            then indAddMultiple1 + indAmount-            else indAddMultiple1-      in  indAddMultiple2-    else indAddRaw
− source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--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.Types----transformSimplifyColumns :: BriDoc -> BriDoc-transformSimplifyColumns = Uniplate.rewrite $ \case-  -- BDWrapAnnKey annKey bd ->-  --   BDWrapAnnKey annKey $ transformSimplify bd-  BDEmpty -> Nothing-  BDLit{} -> Nothing-  BDSeq list | any (\case BDSeq{} -> True-                          BDEmpty{} -> True-                          _ -> False) list -> Just $ BDSeq $ list >>= \case-                            BDEmpty -> []-                            BDSeq l -> l-                            x -> [x]-  BDSeq (BDCols sig1 cols1@(_:_):rest)-    | all (\case BDSeparator -> True; _ -> False) rest ->-    Just $ BDCols sig1 (List.init cols1 ++ [BDSeq (List.last cols1:rest)])-  BDLines lines | any (\case BDLines{} -> True-                             BDEmpty{} -> True-                             _ -> False) lines ->-    Just $ BDLines $ filter isNotEmpty $ lines >>= \case-      BDLines l -> l-      x -> [x]-  -- prior floating in-  BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->-    Just $ BDSeq (BDAnnotationPrior annKey1 l:lr)-  BDAnnotationPrior annKey1 (BDLines (l:lr)) ->-    Just $ BDLines (BDAnnotationPrior annKey1 l:lr)-  BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->-    Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr)-  -- post floating in-  BDAnnotationRest annKey1 (BDSeq list) ->-    Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]-  BDAnnotationRest annKey1 (BDLines list) ->-    Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]-  BDAnnotationRest annKey1 (BDCols sig cols) ->-    Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]-  BDAnnotationKW annKey1 kw (BDSeq list) ->-    Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]-  BDAnnotationKW annKey1 kw (BDLines list) ->-    Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]-  BDAnnotationKW annKey1 kw (BDCols sig cols) ->-    Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]-  -- ensureIndent float-in-  -- not sure if the following rule is necessary; tests currently are-  -- unaffected.-  -- BDEnsureIndent indent (BDLines lines) ->-  --   Just $ BDLines $ BDEnsureIndent indent <$> lines-  -- matching col special transformation-  BDCols sig1 cols1@(_:_)-    | BDLines lines@(_:_:_) <- List.last cols1-    , BDCols sig2 cols2 <- List.last lines-    , sig1==sig2 ->-        Just $ BDLines-          [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]-          , BDCols sig2 cols2-          ]-  BDCols sig1 cols1@(_:_)-    | BDLines lines@(_:_:_) <- List.last cols1-    , BDEnsureIndent _ (BDCols sig2 cols2) <- List.last lines-    , sig1==sig2 ->-        Just $ BDLines-          [ BDCols sig1 $ List.init cols1 ++ [BDLines $ List.init lines]-          , BDCols sig2 cols2-          ]-  BDPar ind col1@(BDCols sig1 _) col2@(BDCols sig2 _) | sig1==sig2 ->-    Just $ BDAddBaseY ind (BDLines [col1, col2])-  BDPar ind col1@(BDCols sig1 _) (BDLines (col2@(BDCols sig2 _):rest))-    | sig1==sig2 ->-    Just $ BDPar ind (BDLines [col1, col2]) (BDLines rest)-  BDPar ind (BDLines lines1) col2@(BDCols sig2 _)-    | BDCols sig1 _ <- List.last lines1-    , sig1==sig2 ->-    Just $ BDAddBaseY ind (BDLines $ lines1 ++ [col2])-  BDPar ind (BDLines lines1) (BDLines (col2@(BDCols sig2 _):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))-  --   | sig1==sig2 ->-  --       Just $ BDPar-  --         ind1-  --         (BDLines [BDCols sig1 cols1, BDCols sig])-  BDCols sig1 cols | BDPar _ind line (BDCols sig2 cols2) <- List.last cols-                   , sig1==sig2 ->-    Just $ BDLines-      [ BDCols sig1 (List.init cols ++ [line])-      , BDCols sig2 cols2-      ]-  BDCols sig1 cols | BDPar ind line (BDLines lines) <- List.last cols-                   , BDCols sig2 cols2 <- List.last lines-                   , sig1==sig2 ->-    Just $ BDLines-      [ BDCols sig1 $ List.init cols ++ [BDPar ind line (BDLines $ List.init lines)]-      , BDCols sig2 cols2-      ]-  BDLines [x]         -> Just $ x-  BDLines []          -> Just $ BDEmpty-  BDSeq{}             -> Nothing-  BDCols{}            -> Nothing-  BDSeparator         -> Nothing-  BDAddBaseY{}        -> Nothing-  BDBaseYPushCur{}    -> Nothing-  BDBaseYPop{}        -> Nothing-  BDIndentLevelPushCur{} -> Nothing-  BDIndentLevelPop{}  -> Nothing-  BDPar{}             -> Nothing-  BDAlt{}             -> Nothing-  BDForceMultiline{}  -> Nothing-  BDForceSingleline{} -> Nothing-  BDForwardLineMode{} -> Nothing-  BDExternal{}        -> Nothing-  BDPlain{}           -> Nothing-  BDLines{}           -> Nothing-  BDAnnotationPrior{} -> Nothing-  BDAnnotationKW{}    -> Nothing-  BDAnnotationRest{}  -> Nothing-  BDMoveToKWDP{}      -> Nothing-  BDEnsureIndent{}    -> Nothing-  BDSetParSpacing{}   -> Nothing-  BDForceParSpacing{} -> Nothing-  BDDebug{}           -> Nothing-  BDNonBottomSpacing _ x -> Just x
− source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs 
@@ -1,195 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--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.PreludeUtils-import Language.Haskell.Brittany.Internal.Types-import Language.Haskell.Brittany.Internal.Utils------ note that this is not total, and cannot be with that exact signature.-mergeIndents :: BrIndent -> BrIndent -> BrIndent-mergeIndents BrIndentNone        x                   = x-mergeIndents x                   BrIndentNone        = x-mergeIndents (BrIndentSpecial i) (BrIndentSpecial j) = BrIndentSpecial (max i j)-mergeIndents _                   _                   = error "mergeIndents"---transformSimplifyFloating :: BriDoc -> BriDoc-transformSimplifyFloating = stepBO .> stepFull-  -- note that semantically, stepFull is completely sufficient.-  -- but the bottom-up switch-to-top-down-on-match transformation has much-  -- better complexity.-  -- UPDATE: by now, stepBO does more than stepFull; for semantic equivalence-  --         the push/pop cases would need to be copied over-  where-    descendPrior = transformDownMay $ \case-      -- prior floating in-      BDAnnotationPrior annKey1 (BDPar ind line indented) ->-         Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented-      BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->-         Just $ BDSeq (BDAnnotationPrior annKey1 l:lr)-      BDAnnotationPrior annKey1 (BDLines (l:lr)) ->-         Just $ BDLines (BDAnnotationPrior annKey1 l:lr)-      BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->-         Just $ BDCols sig (BDAnnotationPrior annKey1 l:lr)-      BDAnnotationPrior annKey1 (BDAddBaseY indent x) ->-         Just $ BDAddBaseY indent $ BDAnnotationPrior annKey1 x-      BDAnnotationPrior annKey1 (BDDebug s x) ->-         Just $ BDDebug s $ BDAnnotationPrior annKey1 x-      _ -> Nothing-    descendRest = transformDownMay $ \case-      -- post floating in-      BDAnnotationRest annKey1 (BDPar ind line indented) ->-        Just $ BDPar ind line $ BDAnnotationRest annKey1 indented-      BDAnnotationRest annKey1 (BDSeq list) ->-        Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]-      BDAnnotationRest annKey1 (BDLines list) ->-        Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]-      BDAnnotationRest annKey1 (BDCols sig cols) ->-        Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]-      BDAnnotationRest annKey1 (BDAddBaseY indent x) ->-        Just $ BDAddBaseY indent $ BDAnnotationRest annKey1 x-      BDAnnotationRest annKey1 (BDDebug s x) ->-        Just $ BDDebug s $ BDAnnotationRest annKey1 x-      _ -> Nothing-    descendKW = transformDownMay $ \case-      -- post floating in-      BDAnnotationKW annKey1 kw (BDPar ind line indented) ->-        Just $ BDPar ind line $ BDAnnotationKW annKey1 kw indented-      BDAnnotationKW annKey1 kw (BDSeq list) ->-        Just $ BDSeq $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]-      BDAnnotationKW annKey1 kw (BDLines list) ->-        Just $ BDLines $ List.init list ++ [BDAnnotationKW annKey1 kw $ List.last list]-      BDAnnotationKW annKey1 kw (BDCols sig cols) ->-        Just $ BDCols sig $ List.init cols ++ [BDAnnotationKW annKey1 kw $ List.last cols]-      BDAnnotationKW annKey1 kw (BDAddBaseY indent x) ->-        Just $ BDAddBaseY indent $ BDAnnotationKW annKey1 kw x-      BDAnnotationKW annKey1 kw (BDDebug s x) ->-        Just $ BDDebug s $ BDAnnotationKW annKey1 kw x-      _ -> Nothing-    descendBYPush = transformDownMay $ \case-      BDBaseYPushCur (BDCols sig cols@(_:_)) ->-        Just $ BDCols sig (BDBaseYPushCur (List.head cols) : List.tail cols)-      BDBaseYPushCur (BDDebug s x) ->-        Just $ BDDebug s (BDBaseYPushCur x)-      _ -> Nothing-    descendBYPop = transformDownMay $ \case-      BDBaseYPop (BDCols sig cols@(_:_)) ->-        Just $ BDCols sig (List.init cols ++ [BDBaseYPop (List.last cols)])-      BDBaseYPop (BDDebug s x) ->-        Just $ BDDebug s (BDBaseYPop x)-      _ -> Nothing-    descendILPush = transformDownMay $ \case-      BDIndentLevelPushCur (BDCols sig cols@(_:_)) ->-        Just $ BDCols sig (BDIndentLevelPushCur (List.head cols) : List.tail cols)-      BDIndentLevelPushCur (BDDebug s x) ->-        Just $ BDDebug s (BDIndentLevelPushCur x)-      _ -> Nothing-    descendILPop = transformDownMay $ \case-      BDIndentLevelPop (BDCols sig cols@(_:_)) ->-        Just $ BDCols sig (List.init cols ++ [BDIndentLevelPop (List.last cols)])-      BDIndentLevelPop (BDDebug s x) ->-        Just $ BDDebug s (BDIndentLevelPop x)-      _ -> Nothing-    descendAddB = transformDownMay $ \case-      BDAddBaseY BrIndentNone x ->-        Just x-      -- AddIndent floats into Lines.-      BDAddBaseY indent (BDLines lines) ->-        Just $ BDLines $ BDAddBaseY indent <$> lines-      -- AddIndent floats into last column-      BDAddBaseY indent (BDCols sig cols) ->-        Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]-      -- merge AddIndent and Par-      BDAddBaseY ind1 (BDPar ind2 line indented) ->-        Just $ BDPar (mergeIndents ind1 ind2) line indented-      BDAddBaseY ind (BDAnnotationPrior annKey1 x) ->-        Just $ BDAnnotationPrior annKey1 (BDAddBaseY ind x)-      BDAddBaseY ind (BDAnnotationRest annKey1 x) ->-        Just $ BDAnnotationRest annKey1 (BDAddBaseY ind x)-      BDAddBaseY ind (BDAnnotationKW annKey1 kw x) ->-        Just $ BDAnnotationKW annKey1 kw (BDAddBaseY ind x)-      BDAddBaseY ind (BDSeq list) ->-        Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]-      BDAddBaseY _ lit@BDLit{} ->-        Just $ lit-      BDAddBaseY ind (BDBaseYPushCur x) ->-        Just $ BDBaseYPushCur (BDAddBaseY ind x)-      BDAddBaseY ind (BDBaseYPop x) ->-        Just $ BDBaseYPop (BDAddBaseY ind x)-      BDAddBaseY ind (BDDebug s x) ->-        Just $ BDDebug s (BDAddBaseY ind x)-      BDAddBaseY ind (BDIndentLevelPop x) ->-        Just $ BDIndentLevelPop (BDAddBaseY ind x)-      BDAddBaseY ind (BDIndentLevelPushCur x) ->-        Just $ BDIndentLevelPushCur (BDAddBaseY ind x)-      BDAddBaseY ind (BDEnsureIndent ind2 x) ->-        Just $ BDEnsureIndent (mergeIndents ind ind2) x-      _ -> Nothing-    stepBO :: BriDoc -> BriDoc-    stepBO = -- traceFunctionWith "stepBO" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $-             transformUp f-      where-        f = \case-          x@BDAnnotationPrior{}    -> descendPrior x-          x@BDAnnotationKW{}       -> descendKW x-          x@BDAnnotationRest{}     -> descendRest  x-          x@BDAddBaseY{}           -> descendAddB  x-          x@BDBaseYPushCur{}       -> descendBYPush x-          x@BDBaseYPop{}           -> descendBYPop x-          x@BDIndentLevelPushCur{} -> descendILPush x-          x@BDIndentLevelPop{}     -> descendILPop x-          x -> x-    stepFull = -- traceFunctionWith "stepFull" (show . briDocToDocWithAnns) (show . briDocToDocWithAnns) $-               Uniplate.rewrite $ \case-      BDAddBaseY BrIndentNone x ->-        Just $ x-      -- AddIndent floats into Lines.-      BDAddBaseY indent (BDLines lines) ->-        Just $ BDLines $ BDAddBaseY indent <$> lines-      -- AddIndent floats into last column-      BDAddBaseY indent (BDCols sig cols) ->-        Just $ BDCols sig $ List.init cols ++ [BDAddBaseY indent $ List.last cols]-      BDAddBaseY ind (BDSeq list) ->-        Just $ BDSeq $ List.init list ++ [BDAddBaseY ind (List.last list)]-      -- merge AddIndent and Par-      BDAddBaseY ind1 (BDPar ind2 line indented) ->-        Just $ BDPar (mergeIndents ind1 ind2) line indented-      BDAddBaseY _ lit@BDLit{} ->-        Just $ lit-      BDAddBaseY ind (BDBaseYPushCur x) ->-        Just $ BDBaseYPushCur (BDAddBaseY ind x)-      BDAddBaseY ind (BDBaseYPop x) ->-        Just $ BDBaseYPop (BDAddBaseY ind x)-      -- prior floating in-      BDAnnotationPrior annKey1 (BDPar ind line indented) ->-        Just $ BDPar ind (BDAnnotationPrior annKey1 line) indented-      BDAnnotationPrior annKey1 (BDSeq (l:lr)) ->-        Just $ BDSeq ((BDAnnotationPrior annKey1 l):lr)-      BDAnnotationPrior annKey1 (BDLines (l:lr)) ->-        Just $ BDLines ((BDAnnotationPrior annKey1 l):lr)-      BDAnnotationPrior annKey1 (BDCols sig (l:lr)) ->-        Just $ BDCols sig ((BDAnnotationPrior annKey1 l):lr)-      -- EnsureIndent float-in-      -- BDEnsureIndent indent (BDCols sig (col:colr)) ->-      --   Just $ BDCols sig (BDEnsureIndent indent col : (BDAddBaseY indent <$> colr))-      -- not sure if the following rule is necessary; tests currently are-      -- unaffected.-      -- BDEnsureIndent indent (BDLines lines) ->-      --   Just $ BDLines $ BDEnsureIndent indent <$> lines-      -- post floating in-      BDAnnotationRest annKey1 (BDPar ind line indented) ->-        Just $ BDPar ind line $ BDAnnotationRest annKey1 indented-      BDAnnotationRest annKey1 (BDSeq list) ->-        Just $ BDSeq $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]-      BDAnnotationRest annKey1 (BDLines list) ->-        Just $ BDLines $ List.init list ++ [BDAnnotationRest annKey1 $ List.last list]-      BDAnnotationRest annKey1 (BDCols sig cols) ->-        Just $ BDCols sig $ List.init cols ++ [BDAnnotationRest annKey1 $ List.last cols]-      _ -> Nothing
− source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--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.Types------ prepare layouting by translating BDPar's, replacing them with Indents and--- floating those in. This gives a more clear picture of what exactly is--- affected by what amount of indentation.-transformSimplifyIndent :: BriDoc -> BriDoc-transformSimplifyIndent = Uniplate.rewrite $ \case-  BDPar ind (BDLines lines) indented ->-    Just $ BDEnsureIndent ind $ BDLines $ lines ++ [indented]-  BDPar ind (BDCols sig cols) indented ->-    Just $ BDCols sig (List.init cols ++ [BDPar ind (List.last cols) indented])-  BDPar BrIndentNone _ _ -> Nothing-  BDPar ind x indented ->-    Just $ BDPar BrIndentNone (BDAddBaseY ind x) (BDEnsureIndent ind indented)-  -- BDPar ind x indented ->-  --   Just $ BDLines-  --     [ BDAddBaseY ind x-  --     , BDEnsureIndent ind indented-  --     ]-  BDLines lines | any ( \case-                        BDLines{} -> True-                        BDEmpty{} -> True-                        _         -> False-                      )-                      lines ->-    Just $ BDLines $ filter isNotEmpty $ lines >>= \case-      BDLines l -> l-      x         -> [x]-  BDLines [l] -> Just l-  BDAddBaseY i (BDAnnotationPrior k x) ->-    Just $ BDAnnotationPrior k (BDAddBaseY i x)-  BDAddBaseY i (BDAnnotationKW k kw x) ->-    Just $ BDAnnotationKW k kw (BDAddBaseY i x)-  BDAddBaseY i (BDAnnotationRest k x) ->-    Just $ BDAnnotationRest k (BDAddBaseY i x)-  BDAddBaseY i (BDSeq l) ->-    Just $ BDSeq $ List.init l ++ [BDAddBaseY i $ List.last l]-  BDAddBaseY i (BDCols sig l) ->-    Just $ BDCols sig $ List.init l ++ [BDAddBaseY i $ List.last l]-  BDAddBaseY _ lit@BDLit{} -> Just lit--  _                        -> Nothing
− source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Internal.Transformations.Par where--import Language.Haskell.Brittany.Internal.Prelude-import Language.Haskell.Brittany.Internal.Types-import Language.Haskell.Brittany.Internal.Utils----transformSimplifyPar :: BriDoc -> BriDoc-transformSimplifyPar = transformUp $ \case-  -- BDPar BrIndentNone line1 line2 -> Just $ BDLines [line1, line2]-  -- BDPar line indented ->-  --   Just $ BDLines [line, indented]-  -- BDPar ind1 (BDPar ind2 line p1) p2 | ind1==ind2 ->-  --   Just $ BDPar ind1 line (BDLines [p1, p2])-  x@(BDPar _ (BDPar _ BDPar{} _) _) -> x-  BDPar ind1 (BDPar ind2 line p1) (BDLines indenteds) ->-    BDPar ind1 line (BDLines (BDEnsureIndent ind2 p1 : indenteds))-  BDPar ind1 (BDPar ind2 line p1) p2 ->-    BDPar ind1 line (BDLines [BDEnsureIndent ind2 p1, p2])-  BDLines lines | any ( \case-                        BDLines{} -> True-                        BDEmpty{} -> True-                        _         -> False-                      )-                      lines  -> case go lines of-    []  -> BDEmpty-    [x] -> x-    xs  -> BDLines xs-   where-    go = (=<<) $ \case-      BDLines l -> go l-      BDEmpty   -> []-      x         -> [x]-  BDLines []                    -> BDEmpty-  BDLines [x]                   -> x-  -- BDCols sig cols | BDPar ind line indented <- List.last cols ->-  --   Just $ BDPar ind (BDCols sig (List.init cols ++ [line])) indented-  -- BDPar BrIndentNone line indented ->-  --   Just $ BDLines [line, indented]-  BDEnsureIndent BrIndentNone x -> x-  x                             -> x
− source/library/Language/Haskell/Brittany/Internal/Types.hs 
@@ -1,463 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}--module Language.Haskell.Brittany.Internal.Types where--import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS-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.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---data PerItemConfig = PerItemConfig-  { _icd_perBinding :: Map String (CConfig Maybe)-  , _icd_perKey :: Map ExactPrint.Types.AnnKey (CConfig Maybe)-  }-  deriving Data.Data.Data--type PPM = MultiRWSS.MultiRWS-  '[Map ExactPrint.AnnKey ExactPrint.Anns, PerItemConfig, Config, ExactPrint.Anns]-  '[Text.Builder.Builder, [BrittanyError], Seq String]-  '[]--type PPMLocal = MultiRWSS.MultiRWS-  '[Config, ExactPrint.Anns]-  '[Text.Builder.Builder, [BrittanyError], Seq String]-  '[]--newtype TopLevelDeclNameMap = TopLevelDeclNameMap (Map ExactPrint.AnnKey String)--data LayoutState = LayoutState-  { _lstate_baseYs         :: [Int]-     -- ^ stack of number of current indentation columns-     -- (not number of indentations).-  , _lstate_curYOrAddNewline :: Either Int Int-             -- ^ Either:-             -- 1) number of chars in the current line.-             -- 2) number of newlines to be inserted before inserting any-             --    non-space elements.-  , _lstate_indLevels      :: [Int]-    -- ^ stack of current indentation levels. set for-    -- any layout-affected elements such as-    -- let/do/case/where elements.-    -- The main purpose of this member is to-    -- properly align comments, as their-    -- annotation positions are relative to the-    -- current layout indentation level.-  , _lstate_indLevelLinger :: Int -- like a "last" of indLevel. Used for-                                  -- properly treating cases where comments-                                  -- on the first indented element have an-                                  -- annotation offset relative to the last-                                  -- non-indented element, which is confusing.-  , _lstate_comments      :: Anns-  , _lstate_commentCol    :: Maybe Int -- this communicates two things:-                                       -- firstly, that cursor is currently-                                       -- at the end of a comment (so needs-                                       -- newline before any actual content).-                                       -- secondly, the column at which-                                       -- insertion of comments started.-  , _lstate_addSepSpace   :: Maybe Int -- number of spaces to insert if anyone-                                       -- writes (any non-spaces) in the-                                       -- current line.-  -- , _lstate_isNewline     :: NewLineState-  --     -- captures if the layouter currently is in a new line, i.e. if the-  --     -- current line only contains (indentation) spaces.-  -- this is mostly superseeded by curYOrAddNewline, iirc.-  , _lstate_commentNewlines :: Int -- number of newlines inserted due to-                                   -- move-to-DP at a start of a comment.-                                   -- Necessary because some keyword DPs-                                   -- are relative to the last non-comment-                                   -- entity (for some reason).-                                   -- This is not very strictly reset to 0,-                                   -- so we might in some cases get "artifacts"-                                   -- from previous document elements.-                                   -- But the worst effect at the moment would-                                   -- be that we introduce less newlines on-                                   -- moveToKWDP, which seems harmless enough.-  }--lstate_baseY :: LayoutState -> Int-lstate_baseY = Safe.headNote "lstate_baseY" . _lstate_baseYs--lstate_indLevel :: LayoutState -> Int-lstate_indLevel = Safe.headNote "lstate_baseY" . _lstate_indLevels---- evil, incomplete Show instance; only for debugging.-instance Show LayoutState where-  show state =-    "LayoutState"-    ++ "{baseYs=" ++ show (_lstate_baseYs state)-    ++ ",curYOrAddNewline=" ++ show (_lstate_curYOrAddNewline state)-    ++ ",indLevels=" ++ show (_lstate_indLevels state)-    ++ ",indLevelLinger=" ++ 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---                                      -- newline, really. by special-casing---                                      -- this we can appropriately handle it---                                      -- differently at use-site.---                   | NewLineStateYes---                   | NewLineStateNo---   deriving Eq---- data LayoutSettings = LayoutSettings---   { _lsettings_cols :: Int -- the thing that has default 80.---   , _lsettings_indentPolicy :: IndentPolicy---   , _lsettings_indentAmount :: Int---   , _lsettings_indentWhereSpecial :: Bool -- indent where only 1 sometimes (TODO).---   , _lsettings_indentListSpecial  :: Bool -- use some special indentation for ","---                                           -- when creating zero-indentation---                                           -- multi-line list literals.---   , _lsettings_importColumn :: Int---   , _lsettings_initialAnns :: ExactPrint.Anns---   }--data BrittanyError-  = ErrorInput String-    -- ^ parsing failed-  | ErrorUnusedComment String-    -- ^ internal error: some comment went missing-  | ErrorMacroConfig String String-    -- ^ in-source config string parsing error; first argument is the parser-    --   output and second the corresponding, ill-formed input.-  | LayoutWarning String-    -- ^ some warning-  | forall ast . Data.Data.Data ast => ErrorUnknownNode String (GenLocated SrcSpan ast)-    -- ^ internal error: pretty-printing is not implemented for type of node-    --   in the syntax-tree-  | ErrorOutputCheck-    -- ^ checking the output for syntactic validity failed--data BriSpacing = BriSpacing-  { _bs_spacePastLineIndent :: Int -- space in the current,-                                   -- potentially somewhat filled-                                   -- line.-  , _bs_spacePastIndent :: Int     -- space required in properly-                                   -- indented blocks below the-                                   -- current line.-  }--data ColSig-  = ColTyOpPrefix-    -- any prefixed operator/paren/"::"/..-    -- expected to have exactly two colums.-    -- e.g. ":: foo"-    --       111222-    --      "-> bar asd asd"-    --       11122222222222-  | ColPatternsFuncPrefix-    -- pattern-part of the lhs, e.g. "func (foo a b) c _".-    -- Has variable number of columns depending on the number of patterns.-  | ColPatternsFuncInfix-    -- pattern-part of the lhs, e.g. "Foo a <> Foo b".-    -- Has variable number of columns depending on the number of patterns.-  | ColPatterns-  | ColCasePattern-  | ColBindingLine (Maybe Text)-    -- e.g. "func pat pat = expr"-    --       1111111111111222222-    -- or   "pat | stmt -> expr"-    --       111111111112222222-    -- expected to have exactly two columns.-  | ColGuard-    -- e.g. "func pat pat | cond = ..."-    --       11111111111112222222-    -- or   "pat | cond1, cond2 -> ..."-    --       1111222222222222222-    -- expected to have exactly two columns-  | ColGuardedBody-    -- e.g. | foofoo = 1-    --      | bar    = 2-    --      111111111222-    -- expected to have exactly two columns-  | ColBindStmt-  | ColDoLet -- the non-indented variant-  | ColRec-  | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?-  | ColRecDecl-  | ColListComp-  | ColList-  | ColApp Text-  | ColTuple-  | ColTuples-  | ColOpPrefix -- merge with ColList ? other stuff?-  | ColImport--  -- TODO-  deriving (Eq, Ord, Data.Data.Data, Show)--data BrIndent = BrIndentNone-              | BrIndentRegular-              | BrIndentSpecial Int-  deriving (Eq, Ord, Data.Data.Data, Show)--type ToBriDocM = MultiRWSS.MultiRWS-                   '[Config, Anns] -- reader-                   '[[BrittanyError], Seq String] -- writer-                   '[NodeAllocIndex] -- state--type ToBriDoc (sym :: Kind.Type -> Kind.Type) = Located (sym GhcPs) -> ToBriDocM BriDocNumbered-type ToBriDoc' sym            = Located sym         -> ToBriDocM BriDocNumbered-type ToBriDocC sym c          = Located sym         -> ToBriDocM c--data DocMultiLine-  = MultiLineNo-  | MultiLinePossible-  deriving (Eq)---- isomorphic to BriDocF Identity. Provided for ease of use, as we do a lot--- of transformations on `BriDocF Identity`s and it is really annoying to--- `Identity`/`runIdentity` everywhere.-data BriDoc-  = -- BDWrapAnnKey AnnKey BriDoc-    BDEmpty-  | BDLit !Text-  | BDSeq [BriDoc] -- elements other than the last should-                   -- not contains BDPars.-  | BDCols ColSig [BriDoc] -- elements other than the last-                         -- should not contains BDPars-  | BDSeparator -- semantically, space-unless-at-end-of-line.-  | BDAddBaseY BrIndent BriDoc-  | BDBaseYPushCur BriDoc-  | BDBaseYPop BriDoc-  | BDIndentLevelPushCur BriDoc-  | BDIndentLevelPop BriDoc-  | BDPar-    { _bdpar_indent :: BrIndent-    , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars-    , _bdpar_indented :: BriDoc-    }-  -- | BDAddIndent BrIndent (BriDocF f)-  -- | BDNewline-  | BDAlt [BriDoc]-  | BDForwardLineMode BriDoc-  | BDExternal AnnKey-               (Set AnnKey) -- set of annkeys contained within the node-                            -- to be printed via exactprint-               Bool -- should print extra comment ?-               Text-  | BDPlain !Text -- used for QuasiQuotes, content can be multi-line-                  -- (contrast to BDLit)-  | BDAnnotationPrior AnnKey BriDoc-  | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc-  | BDAnnotationRest  AnnKey BriDoc-  | BDMoveToKWDP AnnKey AnnKeywordId Bool BriDoc -- True if should respect x offset-  | BDLines [BriDoc]-  | BDEnsureIndent BrIndent BriDoc-  -- the following constructors are only relevant for the alt transformation-  -- and are removed afterwards. They should never occur in any BriDoc-  -- after the alt transformation.-  | BDForceMultiline BriDoc-  | BDForceSingleline BriDoc-  | BDNonBottomSpacing Bool BriDoc-  | BDSetParSpacing BriDoc-  | BDForceParSpacing BriDoc-  -- pseudo-deprecated-  | BDDebug String BriDoc-  deriving (Data.Data.Data, Eq, Ord)--data BriDocF f-  = -- BDWrapAnnKey AnnKey BriDoc-    BDFEmpty-  | BDFLit !Text-  | BDFSeq [f (BriDocF f)] -- elements other than the last should-                   -- not contains BDPars.-  | BDFCols ColSig [f (BriDocF f)] -- elements other than the last-                         -- should not contains BDPars-  | BDFSeparator -- semantically, space-unless-at-end-of-line.-  | BDFAddBaseY BrIndent (f (BriDocF f))-  | BDFBaseYPushCur (f (BriDocF f))-  | BDFBaseYPop (f (BriDocF f))-  | BDFIndentLevelPushCur (f (BriDocF f))-  | BDFIndentLevelPop (f (BriDocF f))-  | BDFPar-    { _bdfpar_indent :: BrIndent-    , _bdfpar_restOfLine :: f (BriDocF f) -- should not contain other BDPars-    , _bdfpar_indented :: f (BriDocF f)-    }-  -- | BDAddIndent BrIndent (BriDocF f)-  -- | BDNewline-  | BDFAlt [f (BriDocF f)]-  | BDFForwardLineMode (f (BriDocF f))-  | BDFExternal AnnKey-               (Set AnnKey) -- set of annkeys contained within the node-                            -- to be printed via exactprint-               Bool -- should print extra comment ?-               Text-  | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line-                   -- (contrast to BDLit)-  | BDFAnnotationPrior AnnKey (f (BriDocF f))-  | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f))-  | BDFAnnotationRest  AnnKey (f (BriDocF f))-  | BDFMoveToKWDP AnnKey AnnKeywordId Bool (f (BriDocF f)) -- True if should respect x offset-  | BDFLines [(f (BriDocF f))]-  | BDFEnsureIndent BrIndent (f (BriDocF f))-  | BDFForceMultiline (f (BriDocF f))-  | BDFForceSingleline (f (BriDocF f))-  | BDFNonBottomSpacing Bool (f (BriDocF f))-  | BDFSetParSpacing (f (BriDocF f))-  | BDFForceParSpacing (f (BriDocF f))-  | BDFDebug String (f (BriDocF f))---- deriving instance Data.Data.Data (BriDocF Identity)-deriving instance Data.Data.Data (BriDocF ((,) Int))--type BriDocFInt = BriDocF ((,) Int)-type BriDocNumbered = (Int, BriDocFInt)--instance Uniplate.Uniplate BriDoc where-  uniplate x@BDEmpty{}               = plate x-  uniplate x@BDLit{}                 = plate x-  uniplate (BDSeq list     )         = plate BDSeq ||* list-  uniplate (BDCols sig list)         = plate BDCols |- sig ||* list-  uniplate x@BDSeparator             = plate x-  uniplate (BDAddBaseY ind bd      ) = plate BDAddBaseY |- ind |* bd-  uniplate (BDBaseYPushCur       bd) = plate BDBaseYPushCur |* bd-  uniplate (BDBaseYPop           bd) = plate BDBaseYPop |* bd-  uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd-  uniplate (BDIndentLevelPop     bd) = plate BDIndentLevelPop |* bd-  uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented-  uniplate (BDAlt             alts ) = plate BDAlt ||* alts-  uniplate (BDForwardLineMode bd   ) = plate BDForwardLineMode |* bd-  uniplate x@BDExternal{}            = plate x-  uniplate x@BDPlain{}               = plate x-  uniplate (BDAnnotationPrior annKey bd) =-    plate BDAnnotationPrior |- annKey |* bd-  uniplate (BDAnnotationKW annKey kw bd) =-    plate BDAnnotationKW |- annKey |- kw |* bd-  uniplate (BDAnnotationRest annKey bd) =-    plate BDAnnotationRest |- annKey |* bd-  uniplate (BDMoveToKWDP annKey kw b bd) =-    plate BDMoveToKWDP |- annKey |- kw |- b |* bd-  uniplate (BDLines lines          ) = plate BDLines ||* lines-  uniplate (BDEnsureIndent ind bd  ) = plate BDEnsureIndent |- ind |* bd-  uniplate (BDForceMultiline  bd   ) = plate BDForceMultiline |* bd-  uniplate (BDForceSingleline bd   ) = plate BDForceSingleline |* bd-  uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd-  uniplate (BDSetParSpacing   bd   ) = plate BDSetParSpacing |* bd-  uniplate (BDForceParSpacing bd   ) = plate BDForceParSpacing |* bd-  uniplate (BDDebug s bd           ) = plate BDDebug |- s |* bd--newtype NodeAllocIndex = NodeAllocIndex Int---- TODO: rename to "dropLabels" ?-unwrapBriDocNumbered :: BriDocNumbered -> BriDoc-unwrapBriDocNumbered tpl = case snd tpl of-  BDFEmpty                     -> BDEmpty-  BDFLit t                     -> BDLit t-  BDFSeq list                  -> BDSeq $ rec <$> list-  BDFCols sig list             -> BDCols sig $ rec <$> list-  BDFSeparator                 -> BDSeparator-  BDFAddBaseY ind bd           -> BDAddBaseY ind $ rec bd-  BDFBaseYPushCur       bd     -> BDBaseYPushCur $ rec bd-  BDFBaseYPop           bd     -> BDBaseYPop $ rec bd-  BDFIndentLevelPushCur bd     -> BDIndentLevelPushCur $ rec bd-  BDFIndentLevelPop     bd     -> BDIndentLevelPop $ rec bd-  BDFPar ind line indented     -> BDPar ind (rec line) (rec indented)-  BDFAlt             alts      -> BDAlt $ rec <$> alts -- not that this will happen-  BDFForwardLineMode bd        -> BDForwardLineMode $ rec bd-  BDFExternal k ks c t         -> BDExternal k ks c t-  BDFPlain t                   -> BDPlain t-  BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd-  BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd-  BDFAnnotationRest annKey bd  -> BDAnnotationRest annKey $ rec bd-  BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd-  BDFLines lines               -> BDLines $ rec <$> lines-  BDFEnsureIndent ind bd       -> BDEnsureIndent ind $ rec bd-  BDFForceMultiline  bd        -> BDForceMultiline $ rec bd-  BDFForceSingleline bd        -> BDForceSingleline $ rec bd-  BDFNonBottomSpacing b bd     -> BDNonBottomSpacing b $ rec bd-  BDFSetParSpacing   bd        -> BDSetParSpacing $ rec bd-  BDFForceParSpacing bd        -> BDForceParSpacing $ rec bd-  BDFDebug s bd                -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd-  where rec = unwrapBriDocNumbered--isNotEmpty :: BriDoc -> Bool-isNotEmpty BDEmpty = False-isNotEmpty _       = True---- this might not work. is not used anywhere either.-briDocSeqSpine :: BriDoc -> ()-briDocSeqSpine = \case-  BDEmpty                        -> ()-  BDLit _t                       -> ()-  BDSeq list                     -> foldl' ((briDocSeqSpine .) . seq) () list-  BDCols _sig list               -> foldl' ((briDocSeqSpine .) . seq) () list-  BDSeparator                    -> ()-  BDAddBaseY _ind bd             -> briDocSeqSpine bd-  BDBaseYPushCur       bd        -> briDocSeqSpine bd-  BDBaseYPop           bd        -> briDocSeqSpine bd-  BDIndentLevelPushCur bd        -> briDocSeqSpine bd-  BDIndentLevelPop     bd        -> briDocSeqSpine bd-  BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented-  BDAlt             alts         -> foldl' (\() -> briDocSeqSpine) () alts-  BDForwardLineMode bd           -> briDocSeqSpine bd-  BDExternal{}                   -> ()-  BDPlain{}                      -> ()-  BDAnnotationPrior _annKey bd   -> briDocSeqSpine bd-  BDAnnotationKW _annKey _kw bd  -> briDocSeqSpine bd-  BDAnnotationRest _annKey bd    -> briDocSeqSpine bd-  BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd-  BDLines lines                  -> foldl' (\() -> briDocSeqSpine) () lines-  BDEnsureIndent _ind bd         -> briDocSeqSpine bd-  BDForceMultiline  bd           -> briDocSeqSpine bd-  BDForceSingleline bd           -> briDocSeqSpine bd-  BDNonBottomSpacing _ bd        -> briDocSeqSpine bd-  BDSetParSpacing   bd           -> briDocSeqSpine bd-  BDForceParSpacing bd           -> briDocSeqSpine bd-  BDDebug _s bd                  -> briDocSeqSpine bd--briDocForceSpine :: BriDoc -> BriDoc-briDocForceSpine bd = briDocSeqSpine bd `seq` bd---data VerticalSpacingPar-  = VerticalSpacingParNone -- no indented lines-  | VerticalSpacingParSome   Int -- indented lines, requiring this much-                                 -- vertical space at most-  | VerticalSpacingParAlways Int -- indented lines, requiring this much-                                 -- vertical space at most, but should-                                 -- be considered as having space for-                                 -- any spacing validity check.-    -- TODO: it might be wrong not to extend "always" to the none case, i.e.-    -- we might get better properties of spacing operators by having a-    -- product like (Normal|Always, None|Some Int).-  deriving (Eq, Show)--data VerticalSpacing-  = VerticalSpacing-    { _vs_sameLine  :: !Int-    , _vs_paragraph :: !VerticalSpacingPar-    , _vs_parFlag   :: !Bool-    }-  deriving (Eq, Show)--newtype LineModeValidity a = LineModeValidity (Strict.Maybe a)-  deriving (Functor, Applicative, Monad, Show, Alternative)--pattern LineModeValid :: forall t. t -> LineModeValidity t-pattern LineModeValid x = LineModeValidity (Strict.Just x) :: LineModeValidity t-pattern LineModeInvalid :: forall t. LineModeValidity t-pattern LineModeInvalid = LineModeValidity Strict.Nothing :: LineModeValidity t
− source/library/Language/Haskell/Brittany/Internal/Utils.hs 
@@ -1,270 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE ScopedTypeVariables #-}--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.PreludeUtils-import Language.Haskell.Brittany.Internal.Types-import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types-import qualified Language.Haskell.GHC.ExactPrint.Utils as ExactPrint.Utils-import qualified Text.PrettyPrint as PP----parDoc :: String -> PP.Doc-parDoc = PP.fsep . fmap PP.text . List.words--parDocW :: [String] -> PP.Doc-parDocW = PP.fsep . fmap PP.text . List.words . List.unwords---showSDoc_ :: GHC.SDoc -> String-showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags--showOutputable :: (GHC.Outputable a) => a -> String-showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags--fromMaybeIdentity :: Identity a -> Maybe a -> Identity a-fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y--fromOptionIdentity :: Identity a -> Maybe a -> Identity a-fromOptionIdentity x y =-  Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y---- maximum monoid over N+0--- or more than N, because Num is allowed.-newtype Max a = Max { getMax :: a }-  deriving (Eq, Ord, Show, Bounded, Num)--instance (Num a, Ord a) => Semigroup (Max a) where-  (<>) = Data.Coerce.coerce (max :: a -> a -> a)--instance (Num a, Ord a) => Monoid (Max a) where-  mempty  = Max 0-  mappend = (<>)--newtype ShowIsId = ShowIsId String deriving Data--instance Show ShowIsId where show (ShowIsId x) = x--data A x = A ShowIsId x deriving Data--customLayouterF :: ExactPrint.Types.Anns -> LayouterF-customLayouterF anns layoutF =-  DataToLayouter-    $       f-    `extQ`  showIsId-    `extQ`  fastString-    `extQ`  bytestring-    `extQ`  occName-    `extQ`  srcSpan-    `ext2Q` located- where-  DataToLayouter f = defaultLayouterF layoutF-  simpleLayouter :: String -> NodeLayouter-  simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)-  showIsId :: ShowIsId -> NodeLayouter-  showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case-    Left  True -> PP.parens $ PP.text s-    Left  False -> PP.text s-    Right _    -> PP.text s-  fastString =-    simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString-      -> NodeLayouter-  bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter-  occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString-  srcSpan :: GHC.SrcSpan -> NodeLayouter-  srcSpan ss = simpleLayouter-             -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"-                              $ "{" ++ showOutputable ss ++ "}"-  located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter-  located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a-   where-    annStr = case cast ss of-      Just (s :: GHC.SrcSpan) ->-        ShowIsId $ show (ExactPrint.Utils.getAnnotationEP (GHC.L s a) anns)-      Nothing -> ShowIsId "nnnnnnnn"--customLayouterNoAnnsF :: LayouterF-customLayouterNoAnnsF layoutF =-  DataToLayouter-    $       f-    `extQ`  showIsId-    `extQ`  fastString-    `extQ`  bytestring-    `extQ`  occName-    `extQ`  srcSpan-    `ext2Q` located- where-  DataToLayouter f = defaultLayouterF layoutF-  simpleLayouter :: String -> NodeLayouter-  simpleLayouter s = NodeLayouter (length s) False (const $ PP.text s)-  showIsId :: ShowIsId -> NodeLayouter-  showIsId (ShowIsId s) = NodeLayouter (length s + 2) True $ \case-    Left  True -> PP.parens $ PP.text s-    Left  False -> PP.text s-    Right _    -> PP.text s-  fastString =-    simpleLayouter . ("{FastString: "++) . (++"}") . show :: GHC.FastString-      -> NodeLayouter-  bytestring = simpleLayouter . show :: B.ByteString -> NodeLayouter-  occName = simpleLayouter . ("{OccName: "++) . (++"}") . OccName.occNameString-  srcSpan :: GHC.SrcSpan -> NodeLayouter-  srcSpan ss = simpleLayouter $ "{" ++ showSDoc_ (GHC.ppr ss) ++ "}"-  located :: (Data b) => GHC.GenLocated loc b -> NodeLayouter-  located (GHC.L _ss a) = runDataToLayouter layoutF a---- displayBriDocTree :: BriDoc -> PP.Doc--- displayBriDocTree = \case---   BDWrapAnnKey annKey doc -> def "BDWrapAnnKey"---                            $ PP.text (show annKey)---                          $+$ displayBriDocTree doc---   BDEmpty         -> PP.text "BDEmpty"---   BDLit t         -> def "BDLit" $ PP.text (show t)---   BDSeq list      -> def "BDSeq" $ displayList list---   BDCols sig list -> def "BDCols" $ PP.text (show sig)---                                 $+$ displayList list---   BDSeparator     -> PP.text "BDSeparator"---   BDPar rol indent lines -> def "BDPar" $ displayBriDocTree rol---                                       $+$ PP.text (show indent)---                                       $+$ displayList lines---   BDAlt alts      -> def "BDAlt" $ displayList alts---   BDExternal ast _t -> def "BDExternal" (astToDoc ast)---   BDSpecialPostCommentLoc _ -> PP.text "BDSpecialPostCommentLoc"---  where---   def x r = PP.text x $+$ PP.nest 2 r---   displayList :: [BriDoc] -> PP.Doc---   displayList [] = PP.text "[]"---   displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocTree x---                               : [PP.text "," <+> displayBriDocTree t | t<-xr]---                              ++ [PP.text "]"]---- displayBriDocSimpleTree :: BriDocSimple -> PP.Doc--- displayBriDocSimpleTree = \case---   BDSWrapAnnKey annKey doc -> def "BDSWrapAnnKey"---                            $ PP.text (show annKey)---                          $+$ displayBriDocSimpleTree doc---   BDSLit t         -> def "BDSLit" $ PP.text (show t)---   BDSSeq list      -> def "BDSSeq" $ displayList list---   BDSCols sig list -> def "BDSCols" $ PP.text (show sig)---                                 $+$ displayList list---   BDSSeparator     -> PP.text "BDSSeparator"---   BDSPar rol indent lines -> def "BDSPar" $ displayBriDocSimpleTree rol---                                       $+$ PP.text (show indent)---                                       $+$ displayList lines---   BDSExternal annKey _subKeys _t -> def "BDSExternal" (PP.text $ show annKey)---   BDSSpecialPostCommentLoc _ -> PP.text "BDSSpecialPostCommentLoc"---  where---   def x r = PP.text x $+$ PP.nest 2 r---   displayList :: [BriDocSimple] -> PP.Doc---   displayList [] = PP.text "[]"---   displayList (x:xr) = PP.cat $ PP.text "[" <+> displayBriDocSimpleTree x---                               : [PP.text "," <+> displayBriDocSimpleTree t | t<-xr]---                              ++ [PP.text "]"]--traceIfDumpConf-  :: (MonadMultiReader Config m, Show a)-  => String-  -> (DebugConfig -> Identity (Semigroup.Last Bool))-  -> a-  -> m ()-traceIfDumpConf s accessor val = do-  whenM (mAsk <&> _conf_debug .> accessor .> confUnpack) $ do-    trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()--tellDebugMess :: MonadMultiWriter-  (Seq String) m => String -> m ()-tellDebugMess s = mTell $ Seq.singleton s--tellDebugMessShow :: forall a m . (MonadMultiWriter-  (Seq String) m, Show a) => a -> m ()-tellDebugMessShow = tellDebugMess . show---- i should really put that into multistate..-mModify :: MonadMultiState s m => (s -> s) -> m ()-mModify f = mGet >>= mSet . f--astToDoc :: Data ast => ast -> PP.Doc-astToDoc ast = printTreeWithCustom 160 customLayouterNoAnnsF ast--briDocToDoc :: BriDoc -> PP.Doc-briDocToDoc = astToDoc . removeAnnotations- where-  removeAnnotations = Uniplate.transform $ \case-    BDAnnotationPrior _ x -> x-    BDAnnotationKW _ _ x  -> x-    BDAnnotationRest _ x  -> x-    x                     -> x--briDocToDocWithAnns :: BriDoc -> PP.Doc-briDocToDocWithAnns = astToDoc--annsDoc :: ExactPrint.Types.Anns -> PP.Doc-annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)--breakEither :: (a -> Either b c) -> [a] -> ([b], [c])-breakEither _  []      = ([], [])-breakEither fn (a1:aR) = case fn a1 of-  Left  b -> (b : bs, cs)-  Right c -> (bs, c : cs)- where-  (bs, cs) = breakEither fn aR--spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])-spanMaybe f (x1:xR) | Just y <- f x1 = (y : ys, xs)- where-  (ys, xs) = spanMaybe f xR-spanMaybe _ xs                       = ([], xs)--data FirstLastView a-  = FirstLastEmpty-  | FirstLastSingleton a-  | FirstLast a [a] a--splitFirstLast :: [a] -> FirstLastView a-splitFirstLast [] = FirstLastEmpty-splitFirstLast [x] = FirstLastSingleton x-splitFirstLast (x1:xr) = FirstLast x1 (List.init xr) (List.last xr)---- TODO: move to uniplate upstream?--- aka `transform`-transformUp :: Uniplate.Uniplate on => (on -> on) -> (on -> on)-transformUp f = g where g = f . Uniplate.descend g-_transformDown :: Uniplate.Uniplate on => (on -> on) -> (on -> on)-_transformDown f = g where g = Uniplate.descend g . f-transformDownMay :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)-transformDownMay f = g where g x = maybe x (Uniplate.descend g) $ f x-_transformDownRec :: Uniplate.Uniplate on => (on -> Maybe on) -> (on -> on)-_transformDownRec f = g where g x = maybe (Uniplate.descend g x) g $ f x---- | similar to List.lines, but treating the case of final newline character--- in such a manner that this function is the inverse of @intercalate "\n"@.-lines' :: String -> [String]-lines' s = case break (== '\n') s of-  (s1, []) -> [s1]-  (s1, [_]) -> [s1, ""]-  (s1, (_:r)) -> s1 : lines' r--absurdExt :: HsExtension.NoExtCon -> a-absurdExt = HsExtension.noExtCon
− source/library/Language/Haskell/Brittany/Main.hs 
@@ -1,483 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Language.Haskell.Brittany.Main where--import Control.Monad (zipWithM)-import qualified Control.Monad.Trans.Except as ExceptT-import Data.CZipWith-import qualified Data.Either-import qualified Data.List.Extra-import qualified Data.Monoid-import qualified Data.Semigroup as Semigroup-import qualified Data.Text as Text-import qualified Data.Text.IO as Text.IO-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 GHC.Utils.Outputable (Outputable(..), showSDocUnsafe)-import Language.Haskell.Brittany.Internal-import Language.Haskell.Brittany.Internal.Config-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 qualified Language.Haskell.GHC.ExactPrint as ExactPrint-import Paths_brittany-import qualified System.Directory as Directory-import qualified System.Environment as Environment-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 Text.Read (Read(..))-import UI.Butcher.Monadic----data WriteMode = Display | Inplace--instance Read WriteMode where-  readPrec = val "display" Display <|> val "inplace" Inplace-    where val iden v = ReadPrec.lift $ ReadP.string iden >> return v--instance Show WriteMode where-  show Display = "display"-  show Inplace = "inplace"---main :: IO ()-main = do-  progName <- Environment.getProgName-  args <- Environment.getArgs-  mainWith progName args--mainWith :: String -> [String] -> IO ()-mainWith progName args =-  Environment.withProgName progName-    . Environment.withArgs args-    $ mainFromCmdParserWithHelpDesc mainCmdParser--helpDoc :: PP.Doc-helpDoc = PP.vcat $ List.intersperse-  (PP.text "")-  [ parDocW-    [ "Reformats one or more haskell modules."-    , "Currently affects only the module head (imports/exports), type"-    , "signatures and function bindings;"-    , "everything else is left unmodified."-    , "Based on ghc-exactprint, thus (theoretically) supporting all"-    , "that ghc does."-    ]-  , parDoc $ "Example invocations:"-  , PP.hang (PP.text "") 2 $ PP.vcat-    [ PP.text "brittany"-    , PP.nest 2 $ PP.text "read from stdin, output to stdout"-    ]-  , PP.hang (PP.text "") 2 $ PP.vcat-    [ PP.text "brittany --indent=4 --write-mode=inplace *.hs"-    , PP.nest 2 $ PP.vcat-      [ PP.text "run on all modules in current directory (no backup!)"-      , PP.text "4 spaces indentation"-      ]-    ]-  , parDocW-    [ "This program is written carefully and contains safeguards to ensure"-    , "the output is syntactically valid and that no comments are removed."-    , "Nonetheless, this is a young project, and there will always be bugs,"-    , "and ensuring that the transformation never changes semantics of the"-    , "transformed source is currently not possible."-    , "Please do check the output and do not let brittany override your large"-    , "codebase without having backups."-    ]-  , parDoc $ "There is NO WARRANTY, to the extent permitted by law."-  , parDocW-    [ "This program is free software released under the AGPLv3."-    , "For details use the --license flag."-    ]-  , parDoc $ "See https://github.com/lspitzner/brittany"-  , parDoc-  $  "Please report bugs at"-  ++ " https://github.com/lspitzner/brittany/issues"-  ]--licenseDoc :: PP.Doc-licenseDoc = PP.vcat $ List.intersperse-  (PP.text "")-  [ parDoc $ "Copyright (C) 2016-2019 Lennart Spitzner"-  , parDoc $ "Copyright (C) 2019 PRODA LTD"-  , parDocW-    [ "This program is free software: you can redistribute it and/or modify"-    , "it under the terms of the GNU Affero General Public License,"-    , "version 3, as published by the Free Software Foundation."-    ]-  , parDocW-    [ "This program is distributed in the hope that it will be useful,"-    , "but WITHOUT ANY WARRANTY; without even the implied warranty of"-    , "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"-    , "GNU Affero General Public License for more details."-    ]-  , parDocW-    [ "You should have received a copy of the GNU Affero General Public"-    , "License along with this program.  If not, see"-    , "<http://www.gnu.org/licenses/>."-    ]-  ]---mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()-mainCmdParser helpDesc = do-  addCmdSynopsis "haskell source pretty printer"-  addCmdHelp $ helpDoc-  -- addCmd "debugArgs" $ do-  addHelpCommand helpDesc-  addCmd "license" $ addCmdImpl $ print $ licenseDoc-  -- addButcherDebugCommand-  reorderStart-  printHelp    <- addSimpleBoolFlag "h" ["help"] mempty-  printVersion <- addSimpleBoolFlag "" ["version"] mempty-  printLicense <- addSimpleBoolFlag "" ["license"] mempty-  noUserConfig <- addSimpleBoolFlag "" ["no-user-config"] mempty-  configPaths  <- addFlagStringParams ""-                                      ["config-file"]-                                      "PATH"-                                      (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?-  cmdlineConfig  <- cmdlineConfigParser-  suppressOutput <- addSimpleBoolFlag-    ""-    ["suppress-output"]-    (flagHelp $ parDoc-      "suppress the regular output, i.e. the transformed haskell source"-    )-  _verbosity <- addSimpleCountFlag-    "v"-    ["verbose"]-    (flagHelp $ parDoc "[currently without effect; TODO]")-  checkMode <- addSimpleBoolFlag-    "c"-    ["check-mode"]-    (flagHelp-      (PP.vcat-        [ PP.text "check for changes but do not write them out"-        , PP.text "exits with code 0 if no changes necessary, 1 otherwise"-        , PP.text "and print file path(s) of files that have changes to stdout"-        ]-      )-    )-  writeMode <- addFlagReadParam-    ""-    ["write-mode"]-    "(display|inplace)"-    (              flagHelp-        (PP.vcat-          [ PP.text "display: output for any input(s) goes to stdout"-          , PP.text "inplace: override respective input file (without backup!)"-          ]-        )-    Data.Monoid.<> flagDefault Display-    )-  inputParams <- addParamNoFlagStrings-    "PATH"-    (paramHelpStr "paths to input/inout haskell source files")-  reorderStop-  addCmdImpl $ void $ do-    when printLicense $ do-      print licenseDoc-      System.Exit.exitSuccess-    when printVersion $ do-      do-        putStrLn $ "brittany version " ++ showVersion version-        putStrLn $ "Copyright (C) 2016-2019 Lennart Spitzner"-        putStrLn $ "Copyright (C) 2019 PRODA LTD"-        putStrLn $ "There is NO WARRANTY, to the extent permitted by law."-      System.Exit.exitSuccess-    when printHelp $ do-      liftIO-        $ putStrLn-        $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 }-        $ ppHelpShallow helpDesc-      System.Exit.exitSuccess--    let inputPaths =-          if null inputParams then [Nothing] else map Just inputParams-    let outputPaths = case writeMode of-          Display -> repeat Nothing-          Inplace -> inputPaths--    configsToLoad <- liftIO $ if null configPaths-      then-        maybeToList <$> (Directory.getCurrentDirectory >>= findLocalConfigPath)-      else pure configPaths--    config <--      runMaybeT-          (if noUserConfig-            then readConfigs cmdlineConfig configsToLoad-            else readConfigsWithUserConfig cmdlineConfig configsToLoad-          )-        >>= \case-              Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 53)-              Just x  -> return x-    when (config & _conf_debug & _dconf_dump_config & confUnpack)-      $ trace (showConfigYaml config)-      $ return ()--    results <- zipWithM (coreIO putStrErrLn config suppressOutput checkMode)-                        inputPaths-                        outputPaths--    if checkMode-      then when (Changes `elem` (Data.Either.rights results))-        $ System.Exit.exitWith (System.Exit.ExitFailure 1)-      else case results of-        xs | all Data.Either.isRight xs -> pure ()-        [Left x] -> System.Exit.exitWith (System.Exit.ExitFailure x)-        _ -> System.Exit.exitWith (System.Exit.ExitFailure 1)---data ChangeStatus = Changes | NoChanges-  deriving (Eq)---- | The main IO parts for the default mode of operation, and after commandline--- and config stuff is processed.-coreIO-  :: (String -> IO ()) -- ^ error output function. In parallel operation, you-                       -- may want serialize the different outputs and-                       -- consequently not directly print to stderr.-  -> Config -- ^ global program config.-  -> Bool   -- ^ whether to supress output (to stdout). Purely IO flag, so-            -- currently not part of program config.-  -> Bool   -- ^ whether we are (just) in check mode.-  -> Maybe FilePath.FilePath -- ^ input filepath; stdin if Nothing.-  -> Maybe FilePath.FilePath -- ^ output filepath; stdout if Nothing.-  -> IO (Either Int ChangeStatus)      -- ^ Either an errorNo, or the change status.-coreIO putErrorLnIO config suppressOutput checkMode inputPathM outputPathM =-  ExceptT.runExceptT $ do-    let putErrorLn = liftIO . putErrorLnIO :: String -> ExceptT.ExceptT e IO ()-    let ghcOptions = config & _conf_forward & _options_ghc & runIdentity-    -- there is a good of code duplication between the following code and the-    -- `pureModuleTransform` function. Unfortunately, there are also a good-    -- amount of slight differences: This module is a bit more verbose, and-    -- it tries to use the full-blown `parseModule` function which supports-    -- CPP (but requires the input to be a file..).-    let cppMode    = config & _conf_preprocessor & _ppconf_CPPMode & confUnpack-    -- the flag will do the following: insert a marker string-    -- ("-- BRITANY_INCLUDE_HACK ") right before any lines starting with-    -- "#include" before processing (parsing) input; and remove that marker-    -- string from the transformation output.-    -- The flag is intentionally misspelled to prevent clashing with-    -- inline-config stuff.-    let hackAroundIncludes =-          config & _conf_preprocessor & _ppconf_hackAroundIncludes & confUnpack-    let exactprintOnly = viaGlobal || viaDebug-         where-          viaGlobal = config & _conf_roundtrip_exactprint_only & confUnpack-          viaDebug =-            config & _conf_debug & _dconf_roundtrip_exactprint_only & confUnpack--    let cppCheckFunc dynFlags = if GHC.xopt GHC.Cpp dynFlags-          then case cppMode of-            CPPModeAbort -> do-              return $ Left "Encountered -XCPP. Aborting."-            CPPModeWarn -> do-              putErrorLnIO-                $  "Warning: Encountered -XCPP."-                ++ " Be warned that -XCPP is not supported and that"-                ++ " brittany cannot check that its output is syntactically"-                ++ " valid in its presence."-              return $ Right True-            CPPModeNowarn -> return $ Right True-          else return $ Right False-    (parseResult, originalContents) <- case inputPathM of-      Nothing -> do-        -- TODO: refactor this hack to not be mixed into parsing logic-        let hackF s = if "#include" `isPrefixOf` s-              then "-- BRITANY_INCLUDE_HACK " ++ s-              else s-        let hackTransform = if hackAroundIncludes && not exactprintOnly-              then List.intercalate "\n" . fmap hackF . lines'-              else id-        inputString <- liftIO System.IO.getContents-        parseRes <- liftIO $ parseModuleFromString ghcOptions-                                                   "stdin"-                                                   cppCheckFunc-                                                   (hackTransform inputString)-        return (parseRes, Text.pack inputString)-      Just p -> liftIO $ do-        parseRes  <- parseModule ghcOptions p cppCheckFunc-        inputText <- Text.IO.readFile p-        -- The above means we read the file twice, but the-        -- GHC API does not really expose the source it-        -- read. Should be in cache still anyways.-        ---        -- We do not use TextL.IO.readFile because lazy IO is evil.-        -- (not identical -> read is not finished ->-        -- handle still open -> write below crashes - evil.)-        return (parseRes, inputText)-    case parseResult of-      Left left -> do-        putErrorLn "parse error:"-        putErrorLn left-        ExceptT.throwE 60-      Right (anns, parsedSource, hasCPP) -> do-        (inlineConf, perItemConf) <--          case-            extractCommentConfigs anns (getTopLevelDeclNameMap parsedSource)-          of-            Left (err, input) -> do-              putErrorLn $ "Error: parse error in inline configuration:"-              putErrorLn err-              putErrorLn $ "  in the string \"" ++ input ++ "\"."-              ExceptT.throwE 61-            Right c -> -- trace (showTree c) $-              pure c-        let moduleConf = cZipWith fromOptionIdentity config inlineConf-        when (config & _conf_debug & _dconf_dump_ast_full & confUnpack) $ do-          let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource-          trace ("---- ast ----\n" ++ show val) $ return ()-        let disableFormatting =-              moduleConf & _conf_disable_formatting & confUnpack-        (errsWarns, outSText, hasChanges) <- do-          if-            | disableFormatting -> do-              pure ([], originalContents, False)-            | exactprintOnly -> do-              let r = Text.pack $ ExactPrint.exactPrint parsedSource anns-              pure ([], r, r /= originalContents)-            | otherwise -> do-              let omitCheck =-                    moduleConf-                      &  _conf_errorHandling-                      .> _econf_omit_output_valid_check-                      .> confUnpack-              (ews, outRaw) <- if hasCPP || omitCheck-                then return-                  $ pPrintModule moduleConf perItemConf anns parsedSource-                else liftIO $ pPrintModuleAndCheck moduleConf-                                                   perItemConf-                                                   anns-                                                   parsedSource-              let hackF s = fromMaybe s $ TextL.stripPrefix-                    (TextL.pack "-- BRITANY_INCLUDE_HACK ")-                    s-              let out = TextL.toStrict $ if hackAroundIncludes-                    then-                      TextL.intercalate (TextL.pack "\n")-                      $ hackF-                      <$> TextL.splitOn (TextL.pack "\n") outRaw-                    else outRaw-              out' <- if moduleConf & _conf_obfuscate & confUnpack-                then lift $ obfuscate out-                else pure out-              pure $ (ews, out', out' /= originalContents)-        let customErrOrder ErrorInput{}         = 4-            customErrOrder LayoutWarning{}      = -1 :: Int-            customErrOrder ErrorOutputCheck{}   = 1-            customErrOrder ErrorUnusedComment{} = 2-            customErrOrder ErrorUnknownNode{}   = -2 :: Int-            customErrOrder ErrorMacroConfig{}   = 5-        unless (null errsWarns) $ do-          let groupedErrsWarns =-                Data.List.Extra.groupOn customErrOrder-                  $ List.sortOn customErrOrder-                  $ errsWarns-          groupedErrsWarns `forM_` \case-            (ErrorOutputCheck{} : _) -> do-              putErrorLn-                $  "ERROR: brittany pretty printer"-                ++ " returned syntactically invalid result."-            (ErrorInput str : _) -> do-              putErrorLn $ "ERROR: parse error: " ++ str-            uns@(ErrorUnknownNode{} : _) -> do-              putErrorLn-                $ "WARNING: encountered unknown syntactical constructs:"-              uns `forM_` \case-                ErrorUnknownNode str ast@(L loc _) -> do-                  putErrorLn $ "  " <> str <> " at " <> showSDocUnsafe (ppr loc)-                  when-                      ( config-                      & _conf_debug-                      & _dconf_dump_ast_unknown-                      & confUnpack-                      )-                    $ do-                        putErrorLn $ "  " ++ show (astToDoc ast)-                _ -> error "cannot happen (TM)"-              putErrorLn-                "  -> falling back on exactprint for this element of the module"-            warns@(LayoutWarning{} : _) -> do-              putErrorLn $ "WARNINGS:"-              warns `forM_` \case-                LayoutWarning str -> putErrorLn str-                _                 -> error "cannot happen (TM)"-            unused@(ErrorUnusedComment{} : _) -> do-              putErrorLn-                $  "Error: detected unprocessed comments."-                ++ " The transformation output will most likely"-                ++ " not contain some of the comments"-                ++ " present in the input haskell source file."-              putErrorLn $ "Affected are the following comments:"-              unused `forM_` \case-                ErrorUnusedComment str -> putErrorLn str-                _                      -> error "cannot happen (TM)"-            (ErrorMacroConfig err input : _) -> do-              putErrorLn $ "Error: parse error in inline configuration:"-              putErrorLn err-              putErrorLn $ "  in the string \"" ++ input ++ "\"."-            [] -> error "cannot happen"-        -- TODO: don't output anything when there are errors unless user-        -- adds some override?-        let-          hasErrors =-            if config & _conf_errorHandling & _econf_Werror & confUnpack-            then not $ null errsWarns-            else 0 < maximum (-1 : fmap customErrOrder errsWarns)-          outputOnErrs =-            config-              & _conf_errorHandling-              & _econf_produceOutputOnErrors-              & confUnpack-          shouldOutput =-            not suppressOutput-              && not checkMode-              && (not hasErrors || outputOnErrs)--        when shouldOutput-          $ addTraceSep (_conf_debug config)-          $ case outputPathM of-              Nothing -> liftIO $ Text.IO.putStr $ outSText-              Just p  -> liftIO $ do-                let isIdentical = case inputPathM of-                      Nothing -> False-                      Just _  -> not hasChanges-                unless isIdentical $ Text.IO.writeFile p $ outSText--        when (checkMode && hasChanges) $ case inputPathM of-          Nothing -> pure ()-          Just p -> liftIO $ putStrLn $ "formatting would modify: " ++ p--        when hasErrors $ ExceptT.throwE 70-        return (if hasChanges then Changes else NoChanges)- where-  addTraceSep conf =-    if or-         [ confUnpack $ _dconf_dump_annotations conf-         , confUnpack $ _dconf_dump_ast_unknown conf-         , confUnpack $ _dconf_dump_ast_full conf-         , confUnpack $ _dconf_dump_bridoc_raw conf-         , confUnpack $ _dconf_dump_bridoc_simpl_alt conf-         , confUnpack $ _dconf_dump_bridoc_simpl_floating conf-         , confUnpack $ _dconf_dump_bridoc_simpl_columns conf-         , confUnpack $ _dconf_dump_bridoc_simpl_indent conf-         , confUnpack $ _dconf_dump_bridoc_final conf-         ]-      then trace "----"-      else id
source/test-suite/Main.hs view
@@ -1,6 +1,6 @@ import qualified Control.Monad as Monad import qualified Data.List as List-import qualified Language.Haskell.Brittany.Main as Brittany+import qualified Brittany.Main as Brittany import qualified System.Directory as Directory import qualified System.FilePath as FilePath import qualified Test.Hspec as Hspec