Squash previous history

.gitignore

@@ -0,0 +1,11 @@
+*.prof
+*.aux
+*.eventlog
+*.hp
+*.ps
+/*.pdf
+dist/
+local/
+.cabal-sandbox/
+.stack-work/
+cabal.sandbox.config

ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for brittany
+
+## 0.1.0.0  -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

brittany.cabal

@@ -0,0 +1,228 @@
+name:                brittany
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+license:             AllRightsReserved
+-- license-file:        LICENSE
+author:              Lennart Spitzner
+maintainer:          lsp@informatik.uni-kiel.de
+-- copyright:           
+category:            Language
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+flag brittany-dev
+  description: dev options
+  default: False
+
+flag brittany-dev-lib
+  description: set buildable false for anything but lib
+  default: False
+
+library {
+  default-language:
+    Haskell2010
+  hs-source-dirs:
+    src
+  exposed-modules: {
+    Language.Haskell.Brittany.Prelude
+    Language.Haskell.Brittany
+    Language.Haskell.Brittany.Types
+    Language.Haskell.Brittany.Utils
+    Language.Haskell.Brittany.Config
+    Language.Haskell.Brittany.Config.Types
+    Language.Haskell.Brittany.LayoutBasics
+    Language.Haskell.Brittany.BriLayouter
+    Language.Haskell.Brittany.Layouters.Type
+    Language.Haskell.Brittany.Layouters.Decl
+    Language.Haskell.Brittany.Layouters.Expr
+    Language.Haskell.Brittany.Layouters.Stmt
+    Language.Haskell.Brittany.Layouters.Pattern
+  }
+  ghc-options: {
+    -Wall
+    -fprof-auto -fprof-cafs -fno-spec-constr
+    -j
+    -fno-warn-unused-imports
+    -fno-warn-orphans
+  }
+  if flag(brittany-dev) {
+    ghc-options: -O0 -Werror -fobject-code
+  }
+  build-depends:
+    { base >=4.9 && <4.10
+    , ghc >=8.0.1 && <8.1
+    , ghc-paths >=0.1.0.9 && <0.2
+    , ghc-exactprint >=0.5.1.1 && <0.6
+    , transformers >=0.5.2.0 && <0.6
+    , containers >=0.5.7.1 && <0.6
+    , mtl >=2.2.1 && <2.3
+    , text >=1.2 && <1.3
+    , multistate >=0.7.1.1 && <0.8
+    , syb >=0.6 && <0.7
+    , neat-interpolation >=0.3.2 && <0.4
+    , data-tree-print
+    , pretty >=1.1.3.3 && <1.2
+    , bytestring >=0.10.8.1 && <0.11
+    , directory >=1.2.6.2 && <1.3
+    , lens
+    , butcher
+    , yaml >=0.8.18 && <0.9
+    , extra >=1.4.10 && <1.5
+    , uniplate >=1.6.12 && <1.7
+    , strict >=0.3.2 && <0.4
+    , monad-memo >=0.4.1 && <0.5
+    , unsafe >=0.0 && <0.1
+    , deepseq >=1.4.2.0 && <1.5
+    }
+  default-extensions: {
+    CPP
+
+    NoImplicitPrelude
+
+    GADTs
+
+    FlexibleContexts
+    FlexibleInstances
+    ScopedTypeVariables
+    MonadComprehensions
+    LambdaCase
+    MultiWayIf
+    KindSignatures
+  }
+  include-dirs:
+    srcinc
+}
+
+executable brittany
+  if flag(brittany-dev-lib) {
+    buildable: False
+  } else {
+    buildable: True
+  }
+  main-is:             Main.hs
+  -- other-modules:       
+  -- other-extensions:    
+  build-depends:
+    { brittany
+    , base >=4.9 && <4.10
+    , ghc
+    , ghc-paths
+    , ghc-exactprint
+    , transformers
+    , containers
+    , mtl
+    , text
+    , multistate
+    , syb
+    , neat-interpolation
+    , hspec
+    , data-tree-print
+    , pretty
+    , bytestring
+    , directory
+    , lens
+    , butcher
+    , yaml
+    , extra
+    , uniplate
+    , strict
+    , monad-memo
+    }
+  hs-source-dirs:      src-brittany
+  default-language:    Haskell2010
+  default-extensions: {
+    CPP
+
+    NoImplicitPrelude
+
+    GADTs
+
+    FlexibleContexts
+    FlexibleInstances
+    ScopedTypeVariables
+    MonadComprehensions
+    LambdaCase
+    MultiWayIf
+    KindSignatures
+  }
+  ghc-options: {
+    -Wall
+    -fprof-auto -fprof-cafs -fno-spec-constr
+    -j
+    -fno-warn-unused-imports
+    -fno-warn-orphans
+    -rtsopts
+    -with-rtsopts "-M2G"
+  }
+  if flag(brittany-dev) {
+    ghc-options: -O0 -Werror -fobject-code
+  }
+
+test-suite unittests
+  if flag(brittany-dev-lib) {
+    buildable: False
+  } else {
+    buildable: True
+  }
+  type:             exitcode-stdio-1.0
+  default-language: Haskell2010
+  build-depends:
+    { brittany
+    , base >=4.9 && <4.10
+    , ghc
+    , ghc-paths
+    , ghc-exactprint
+    , transformers
+    , containers
+    , mtl
+    , text
+    , multistate
+    , syb
+    , neat-interpolation
+    , hspec
+    , data-tree-print
+    , pretty
+    , bytestring
+    , directory
+    , lens
+    , butcher
+    , yaml
+    , extra
+    , uniplate
+    , strict
+    , monad-memo
+    }
+  ghc-options:      -Wall
+  main-is:          TestMain.hs
+  other-modules:    IdentityTests
+                    TestUtils
+                    AsymptoticPerfTests
+  hs-source-dirs:   src-unittests
+  default-extensions: {
+    CPP
+
+    NoImplicitPrelude
+
+    GADTs
+
+    FlexibleContexts
+    FlexibleInstances
+    ScopedTypeVariables
+    MonadComprehensions
+    LambdaCase
+    MultiWayIf
+    KindSignatures
+  }
+  ghc-options: {
+    -Wall
+    -fprof-auto -fprof-cafs -fno-spec-constr
+    -j
+    -fno-warn-unused-imports
+    -fno-warn-orphans
+    -with-rtsopts "-M2G"
+  }
+  if flag(brittany-dev) {
+    ghc-options: -O0 -Werror -fobject-code
+  }

src-brittany/Main.hs

@@ -0,0 +1,206 @@
+{-# LANGUAGE DataKinds #-}
+
+module Main where
+
+
+
+#include "prelude.inc"
+
+import DynFlags ( getDynFlags )
+import GHC ( runGhc, GenLocated(L), moduleNameString )
+import qualified Parser as GHC.Parser
+import RdrName ( RdrName(..) )
+import Control.Monad.IO.Class
+import GHC.Paths (libdir)
+import HsSyn
+import SrcLoc ( SrcSpan, Located )
+-- import Outputable ( ppr, runSDoc )
+-- import DynFlags ( unsafeGlobalDynFlags )
+
+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.Parsers as ExactPrint.Parsers
+import qualified Data.Map as Map
+
+import qualified Data.Text.Lazy.Builder as Text.Builder
+
+import qualified Debug.Trace as Trace
+
+import Language.Haskell.Brittany.Types
+import Language.Haskell.Brittany.LayoutBasics
+import Language.Haskell.Brittany
+import Language.Haskell.Brittany.Config
+import Language.Haskell.Brittany.Config.Types
+import Language.Haskell.Brittany.Utils
+
+import qualified Text.PrettyPrint as PP
+
+import           DataTreePrint
+import           UI.Butcher.Monadic
+
+import qualified System.Exit
+
+import Paths_brittany
+
+
+
+main :: IO ()
+main = mainFromCmdParser mainCmdParser
+
+mainCmdParser :: CmdParser Identity (IO ()) ()
+mainCmdParser = do
+  addCmdSynopsis "haskell source pretty printer"
+  addCmdHelp $ PP.vcat $ List.intersperse (PP.text "")
+    [ parDoc $ "Transforms one haskell module by reformatting"
+            ++ " (parts of) the source code, while preserving the"
+            ++ " parts not transformed."
+            ++ " Especially, comments are preserved completely"
+            ++ " and newlines are in many cases."
+    , parDoc $ "Based on ghc-exactprint, thus supporting all that"
+            ++ " ghc does."
+    ]
+  -- addCmd "debugArgs" $ do
+  addHelpCommand
+  -- addButcherDebugCommand
+  reorderStart
+  printHelp <- addSimpleBoolFlag "" ["help"] mempty
+  printVersion <- addSimpleBoolFlag "" ["version"] mempty
+  inputPaths <- addFlagStringParam "i" ["input"] "PATH" (flagHelpStr "path to input haskell source file")
+  outputPaths <- addFlagStringParam "o" ["output"] "PATH" (flagHelpStr "output file path")
+  configPaths <- addFlagStringParam "" ["config-file"] "PATH" (flagHelpStr "path to config file") -- TODO: allow default on addFlagStringParam ?
+  cmdlineConfig <- configParser
+  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]")
+  reorderStop
+  desc <- peekCmdDesc
+  addCmdImpl $ void $ do
+    when printVersion $ do
+      liftIO $ putStrLn $ "brittany version " ++ showVersion version
+      System.Exit.exitSuccess
+    when printHelp $ do
+      liftIO $ print $ ppHelpShallow desc
+      System.Exit.exitSuccess
+    -- runGhc (Just libdir) $ do
+    --   dynflags <- getDynFlags
+    --   input <- liftIO $ readFile "local/Sample.hs"
+    --   let parseOutput = runParser dynflags parserModule input
+    --   liftIO $ case parseOutput of
+    --     Failure msg strloc -> do
+    --       putStrLn "some failed parse"
+    --       putStrLn msg
+    --       print strloc
+    --     Parsed a -> putStrLn "some successful parse."
+    --     Partial a (x,y) -> do
+    --       putStrLn "some partial parse"
+    --       print x
+    --       print y
+    inputPathM <- case inputPaths of
+      [] -> do
+        return Nothing
+      [x] -> return $ Just x
+      _ -> do
+        liftIO $ putStrErrLn $ "more than one input, aborting"
+        System.Exit.exitWith (System.Exit.ExitFailure 50)
+    outputPath <- case outputPaths of
+      [] -> do
+        return Nothing
+      [x] -> return $ Just x
+      _ -> do
+        liftIO $ putStrErrLn $ "more than one output, aborting"
+        System.Exit.exitWith (System.Exit.ExitFailure 50)
+    let configPath = maybe "brittany.yaml" id $ listToMaybe $ reverse configPaths
+    config <- do
+      may <- runMaybeT $ readMergePersConfig cmdlineConfig configPath
+      case may of
+        Nothing -> System.Exit.exitWith (System.Exit.ExitFailure 50)
+        Just x -> return x
+    when (runIdentity $ _dconf_dump_config $ _conf_debug $ config) $ do
+      trace (showTree config) $ return ()
+    liftIO $ do
+      parseResult <- case inputPathM of
+        Nothing -> ExactPrint.Parsers.parseModuleFromString "stdin"
+                   =<< System.IO.hGetContents System.IO.stdin
+        Just p -> ExactPrint.parseModule p
+      case parseResult of
+        Left left -> do
+          putStrErrLn "parse error:"
+          printErr left
+          System.Exit.exitWith (System.Exit.ExitFailure 60)
+        Right (anns, parsedSource) -> do
+          when (config & _conf_debug .> _dconf_dump_ast_full .> runIdentity) $ do
+            let val = printTreeWithCustom 100 (customLayouterF anns) parsedSource
+            trace ("---- ast ----\n" ++ show val) $ return ()
+          -- mapM_ printErr (Map.toList anns)
+          -- let L _ (HsModule name exports imports decls _ _) = parsedSource
+          -- let someDecls = take 3 decls
+          -- -- let out = ExactPrint.exactPrint parsedSource anns
+          -- let out = do
+          --       decl <- someDecls
+          --       ExactPrint.exactPrint decl anns
+          let (errsWarns, outLText) = pPrintModule config anns parsedSource
+          let customErrOrder LayoutWarning{}            = 0 :: Int
+              customErrOrder LayoutErrorUnusedComment{} = 1
+              customErrOrder LayoutErrorUnknownNode{}   = 2
+          when (not $ null errsWarns) $ do
+            let groupedErrsWarns = Data.List.Extra.groupOn customErrOrder
+                                 $ List.sortOn customErrOrder
+                                 $ errsWarns
+            groupedErrsWarns `forM_` \case
+              uns@(LayoutErrorUnknownNode{}:_) -> do
+                putStrErrLn $ "ERROR: encountered unknown syntactical constructs:"
+                uns `forM_` \case
+                  LayoutErrorUnknownNode str ast -> do
+                    putStrErrLn str
+                    when (config & _conf_debug & _dconf_dump_ast_unknown & runIdentity) $ do
+                      putStrErrLn $ "  " ++ show (astToDoc ast)
+                  _ -> error "cannot happen (TM)"
+              warns@(LayoutWarning{}:_) -> do
+                putStrErrLn $ "WARNINGS:"
+                warns `forM_` \case
+                  LayoutWarning str -> putStrErrLn str
+                  _ -> error "cannot happen (TM)"
+              unused@(LayoutErrorUnusedComment{}:_) -> do
+                putStrErrLn $ "Error: detected unprocessed comments. the transformation "
+                        ++ "output will most likely not contain certain of the comments "
+                        ++ "present in the input haskell source file."
+                putStrErrLn $ "Affected are the following comments:"
+                unused `forM_` \case
+                  LayoutErrorUnusedComment str -> putStrErrLn str
+                  _ -> error "cannot happen (TM)"
+              [] -> error "cannot happen"
+          -- TODO: don't output anything when there are errors unless user
+          -- adds some override?
+          let hasErrors = case config
+                               & _conf_errorHandling
+                               & _econf_Werror
+                               & runIdentity of
+                False -> 0 < maximum (-1 : fmap customErrOrder errsWarns)
+                True  -> not $ null errsWarns
+              outputOnErrs = config
+                           & _conf_errorHandling
+                           & _econf_produceOutputOnErrors
+                           & runIdentity
+          let shouldOutput = not suppressOutput
+                          && (not hasErrors || outputOnErrs)
+
+          when shouldOutput $ addTraceSep (_conf_debug config) $ case outputPath of
+            Nothing -> TextL.IO.putStr     $ outLText
+            Just p -> TextL.IO.writeFile p $ outLText
+
+          when hasErrors $
+            System.Exit.exitWith (System.Exit.ExitFailure 70)
+  where
+    addTraceSep conf = if foldr1 (||)
+        [ runIdentity $ _dconf_dump_annotations conf
+        , runIdentity $ _dconf_dump_ast_unknown conf
+        , runIdentity $ _dconf_dump_ast_full conf
+        , runIdentity $ _dconf_dump_bridoc_raw conf
+        , runIdentity $ _dconf_dump_bridoc_simpl_alt conf
+        , runIdentity $ _dconf_dump_bridoc_simpl_floating conf
+        , runIdentity $ _dconf_dump_bridoc_simpl_columns conf
+        , runIdentity $ _dconf_dump_bridoc_simpl_indent conf
+        , runIdentity $ _dconf_dump_bridoc_final conf
+        ]
+      then trace "----"
+      else id

src-idemtests/.gitignore

@@ -0,0 +1,4 @@
+iterOne/
+iterTwo/
+brittany
+report.txt

src-idemtests/README

@@ -0,0 +1,17 @@
+idempotency testing on real-life examples, i.e. checks that brittany(x) is
+equal to brittany(brittany(x)) for some x's. The idea is that these testcases
+are not yet transformed, i.e. that x is not brittany(x). This can capture
+certain bugs that are not detected by checking that brittany behaves as
+identity on "well-formed" input.
+
+to run:
+
+- put a "brittany" executable into this directory.
+- cd into this directory.
+- ./run.sh
+
+report.txt will contain the results.
+
+note that only the configuration in brittany.yaml is tested, which contains
+the default settings. ideally this would be managed in some other, more
+transparent fashion.

src-idemtests/brittany.yaml

@@ -0,0 +1,25 @@
+_conf_errorHandling:
+  _econf_Werror: false
+  _econf_produceOutputOnErrors: false
+_conf_layout:
+  _lconfig_indentPolicy: IndentPolicyFree
+  _lconfig_cols: 80
+  _lconfig_indentAmount: 2
+  _lconfig_importColumn: 60
+  _lconfig_altChooser:
+    tag: AltChooserBoundedSearch
+    contents: 3
+  _lconfig_indentWhereSpecial: true
+  _lconfig_indentListSpecial: true
+_conf_debug:
+  _dconf_dump_annotations: false
+  _dconf_dump_bridoc_simpl_par: false
+  _dconf_dump_bridoc_simpl_indent: false
+  _dconf_dump_bridoc_simpl_floating: false
+  _dconf_dump_ast_full: false
+  _dconf_dump_bridoc_simpl_columns: false
+  _dconf_dump_ast_unknown: false
+  _dconf_dump_bridoc_simpl_alt: false
+  _dconf_dump_bridoc_final: false
+  _dconf_dump_bridoc_raw: false
+  _dconf_dump_config: false

src-idemtests/cases/LayoutBasics.hs

@@ -0,0 +1,747 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MonadComprehensions #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE KindSignatures #-}
+
+module Language.Haskell.Brittany.LayoutBasics
+  ( processDefault
+  , layoutByExact
+  -- , layoutByExactR
+  , descToBlockStart
+  , descToBlockMinMax
+  , descToMinMax
+  , rdrNameToText
+  , lrdrNameToText
+  , lrdrNameToTextAnn
+  , askIndent
+  , calcLayoutMin
+  , calcLayoutMax
+  , getCurRemaining
+  , layoutWriteAppend
+  , layoutWriteAppendMultiline
+  , layoutWriteNewline
+  , layoutWriteNewlinePlain
+  , layoutWriteEnsureNewline
+  , layoutWriteEnsureBlock
+  , layoutWriteEnsureBlockPlusN
+  , layoutWithAddIndent
+  , layoutWithAddIndentBlock
+  , layoutWithAddIndentN
+  , layoutWithAddIndentNBlock
+  , layoutWithNonParamIndent
+  , layoutWriteEnsureAbsoluteN
+  , layoutAddSepSpace
+  , moveToExactAnn
+  , moveToExactAnn'
+  , setOpIndent
+  , stringLayouter
+  , layoutWritePriorComments
+  , layoutWritePostComments
+  , layoutIndentRestorePostComment
+  , layoutWritePriorCommentsRestore
+  , layoutWritePostCommentsRestore
+  , extractCommentsPrior
+  , extractCommentsPost
+  , applyLayouter
+  , applyLayouterRestore
+  , filterAnns
+  , layouterFToLayouterM
+  , ppmMoveToExactLoc
+  , customLayouterF
+  , docEmpty
+  , docLit
+  , docAlt
+  , docSeq
+  , docPar
+  -- , docCols
+  , docPostComment
+  , docWrapNode
+  , briDocByExact
+  , fromMaybeIdentity
+  , foldedAnnKeys
+  )
+where
+
+
+
+-- more imports here..
+
+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.Utils as ExactPrint.Utils
+
+import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation )
+
+import qualified Data.Text.Lazy.Builder as Text.Builder
+
+import Language.Haskell.Brittany.Config.Types
+import Language.Haskell.Brittany.Types
+import Language.Haskell.Brittany.Utils
+
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import qualified Outputable    as GHC
+import qualified DynFlags      as GHC
+import qualified FastString    as GHC
+import qualified SrcLoc        as GHC
+import           SrcLoc ( SrcSpan )
+import           OccName ( occNameString )
+import           Name ( getOccString )
+import           Module ( moduleName )
+import           ApiAnnotation ( AnnKeywordId(..) )
+
+import           Data.Data
+import           Data.Generics.Schemes
+import           Data.Generics.Aliases
+
+import           DataTreePrint
+
+import qualified Text.PrettyPrint as PP
+
+import           Data.Function ( fix )
+
+
+
+processDefault :: (ExactPrint.Annotate.Annotate ast, MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiReader ExactPrint.Types.Anns m)
+               => GenLocated SrcSpan 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!
+    --test
+  case str of
+    "\n" -> return ()
+    _    -> mTell $ Text.Builder.fromString $ str
+
+
+layoutByExact :: ( MonadMultiReader Config m
+                 , MonadMultiReader (ExactPrint.Types.Anns) m
+                 , ExactPrint.Annotate.Annotate ast
+                  )
+               => GenLocated SrcSpan ast -> m Layouter
+layoutByExact x = do
+  anns <- mAsk
+  trace (showTreeWithCustom (customLayouterF anns) x) $ layoutByExactR x
+  -- trace (ExactPrint.Utils.showAnnData anns 2 x) $ layoutByExactR x
+
+layoutByExactR :: (MonadMultiReader Config m
+                  , MonadMultiReader (ExactPrint.Types.Anns) m
+                  , ExactPrint.Annotate.Annotate ast)
+               => GenLocated SrcSpan ast -> m Layouter
+layoutByExactR x = do
+  indent <- askIndent
+  anns <- mAsk
+  let t = Text.pack $ ExactPrint.exactPrint x anns
+  let tlines = Text.lines $ t <> Text.pack "\n"
+      tlineCount = length tlines
+  let len = indent + maximum (Text.length <$> tlines)
+  return $ Layouter
+    { _layouter_desc = LayoutDesc Nothing $ Just $ BlockDesc AllSameIndent len len Nothing
+    , _layouter_func = \_ -> do
+        -- layoutWriteEnsureBlock
+        layoutWriteAppend $ Text.pack $ "{-" ++ show (ExactPrint.Types.mkAnnKey x, Map.lookup (ExactPrint.Types.mkAnnKey x) anns) ++ "-}"
+        zip [1..] tlines `forM_` \(i, l) -> do
+          layoutWriteAppend $ l
+          unless (i==tlineCount) layoutWriteNewline
+        do
+          let subKeys = foldedAnnKeys x
+          state <- mGet
+          let filterF k _ = not $ k `Set.member` subKeys
+          mSet $ state
+            { _lstate_commentsPrior = Map.filterWithKey filterF
+                                    $ _lstate_commentsPrior state
+            , _lstate_commentsPost  = Map.filterWithKey filterF
+                                    $ _lstate_commentsPost  state
+            }
+    , _layouter_ast = x
+    }
+
+briDocByExact :: (ExactPrint.Annotate.Annotate ast,
+                     MonadMultiReader Config m,
+                     MonadMultiReader ExactPrint.Types.Anns m
+                     ) => GenLocated SrcSpan ast -> m BriDoc
+briDocByExact ast = do
+  anns <- mAsk
+  traceIfDumpConf "ast" _dconf_dump_ast_unknown
+    (printTreeWithCustom 100 (customLayouterF anns) ast)
+  return $ docExt ast anns
+
+descToBlockStart :: LayoutDesc -> Maybe BlockStart
+descToBlockStart (LayoutDesc _ (Just (BlockDesc bs _ _ _))) = Just bs
+descToBlockStart (LayoutDesc (Just line) _)                 = Just $ RestOfLine line
+descToBlockStart _                                          = Nothing
+
+descToBlockMinMax :: LayoutDesc -> Maybe (Int, Int)
+descToBlockMinMax (LayoutDesc _ (Just (BlockDesc _ bmin bmax _))) = Just (bmin, bmax)
+descToBlockMinMax _                                               = Nothing
+
+descToMinMax :: Int -> LayoutDesc -> Maybe (Int, Int)
+descToMinMax p (LayoutDesc _ (Just (BlockDesc start bmin bmax _))) =
+  Just (max rolMin bmin, max rolMin bmax)
+    where
+      rolMin = case start of
+        RestOfLine rol -> p + _lColumns_min rol
+        AllSameIndent -> 0
+
+descToMinMax p (LayoutDesc (Just (LayoutColumns _ _ lmin)) _)    =
+  Just (len, len)
+    where
+      len = p + lmin
+descToMinMax _ _                                                 =
+  Nothing
+
+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
+
+lrdrNameToTextAnn :: ( MonadMultiReader Config m
+                     , MonadMultiReader (Map AnnKey Annotation) m
+                     )
+                  => GenLocated SrcSpan RdrName
+                  -> m Text
+lrdrNameToTextAnn ast@(L _ n) = do
+  anns <- mAsk
+  let t = 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 -> traceShow "Nothing" t
+    Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> if
+        | any (hasUni AnnBackquote) aks -> Text.pack "`" <> t <> Text.pack "`"
+        | any (hasUni AnnOpenP)     aks -> Text.pack "(" <> t <> Text.pack ")"
+        | otherwise -> t
+
+
+askIndent :: (MonadMultiReader Config m) => m Int
+askIndent = runIdentity . _lconfig_indentAmount . _conf_layout <$> mAsk
+
+-- minimum block width, judged from block info or line, whichever is
+-- available.
+-- example: calcLayoutMin doBlock ~~~ atomically $ do
+--                                      foo
+--                                    ##              indent
+--                                    #############   linepre
+--                                    ############### result (in this case)
+calcLayoutMin :: Int -- basic indentation amount
+              -> Int -- currently used width in current line (after indent)
+                     -- used to accurately calc placing of the current-line
+                     -- stuff ("do" in the above example) and its width.
+              -> LayoutDesc
+              -> Int
+calcLayoutMin indent linePre (LayoutDesc line block) = case (line, block) of
+  (_, Just (BlockDesc AllSameIndent m _ _))    -> indent + m
+  (_, Just (BlockDesc (RestOfLine inl) m _ _)) -> max (linePre + _lColumns_min inl) (indent + m)
+  (Just s, _)                                  -> indent + _lColumns_min s
+  _ -> error "bad LayoutDesc mnasdoiucxvlkjasd"
+
+-- see 
+calcLayoutMax :: Int -- basic indentation amount
+              -> Int -- currently used width in current line (after indent)
+                     -- used to accurately calc placing of the current-line
+                     -- stuff ("do" in the above example) and its width.
+              -> LayoutDesc
+              -> Int
+calcLayoutMax indent linePre (LayoutDesc line block) = case (line, block) of
+  (Just s, _)                                  -> linePre + _lColumns_min s
+  (_, Just (BlockDesc AllSameIndent _ m _))    -> indent + m
+  (_, Just (BlockDesc (RestOfLine inl) _ m _)) -> max (linePre + _lColumns_min inl) (indent + m)
+  _ -> error "bad LayoutDesc msdnfgouvadnfoiu"
+
+getCurRemaining :: ( MonadMultiReader Config m
+                  , MonadMultiState LayoutState m
+                  )
+                => m Int
+getCurRemaining = do
+  cols <- mAsk <&> _conf_layout .> _lconfig_cols .> runIdentity
+  clc <- _lstate_curLineCols <$> mGet
+  return $ cols - clc
+
+layoutWriteAppend :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                  => Text
+                  -> m ()
+layoutWriteAppend t = do
+  state <- mGet
+  if _lstate_addSepSpace state
+    then do
+      mSet $ state { _lstate_curLineCols = _lstate_curLineCols state + Text.length t + 1
+                   , _lstate_addSepSpace = False
+                   }
+      mTell $ Text.Builder.fromText $ Text.pack " " <> t
+    else do
+      mSet $ state { _lstate_curLineCols = _lstate_curLineCols state + Text.length t }
+      mTell $ Text.Builder.fromText t
+
+layoutWriteAppendMultiline :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                  => Text
+                  -> m ()
+layoutWriteAppendMultiline t = case Text.lines t of
+  [] -> return ()
+  (l:lr) -> do
+    layoutWriteAppend l
+    lr `forM_` \x -> do
+      layoutWriteNewlinePlain
+      layoutWriteAppend x
+
+-- adds a newline and adds spaces to reach the current indentation level.
+-- TODO: rename newline -> newlineBlock and newlinePlain -> newline
+layoutWriteNewline :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                  => m ()
+layoutWriteNewline = do
+  state <- mGet
+  mSet $ state { _lstate_curLineCols = _lstate_indent state
+                          , _lstate_commentCol = Nothing
+                          , _lstate_addSepSpace = False
+                          }
+  mTell $ Text.Builder.fromString $ "\n" ++ replicate (_lstate_indent state) ' '
+
+-- | does _not_ add spaces to again reach the current indentation levels.
+layoutWriteNewlinePlain :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                  => m ()
+layoutWriteNewlinePlain = do
+  state <- mGet
+  mSet $ state { _lstate_curLineCols = 0
+                          , _lstate_commentCol = Nothing
+                          , _lstate_addSepSpace = False
+                          }
+  mTell $ Text.Builder.fromString $ "\n"
+
+layoutWriteEnsureNewline :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                  => m ()
+layoutWriteEnsureNewline = do
+  state <- mGet
+  when (_lstate_curLineCols state /= _lstate_indent state)
+    $ layoutWriteNewline
+
+layoutWriteEnsureBlock :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                  => m ()
+layoutWriteEnsureBlock = do
+  state <- mGet
+  let diff = _lstate_curLineCols state - _lstate_indent state
+  if diff>0
+    then layoutWriteNewline
+    else if diff<0
+      then do
+        layoutWriteAppend $ Text.pack $ replicate (negate diff) ' '
+        mSet $ state { _lstate_curLineCols = _lstate_indent state
+                     , _lstate_addSepSpace = False
+                     }
+      else return ()
+
+layoutWriteEnsureAbsoluteN :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                  => Int -> m ()
+layoutWriteEnsureAbsoluteN n = do
+  state <- mGet
+  let diff = n - _lstate_curLineCols state
+  if diff>0
+    then do
+      layoutWriteAppend $ Text.pack $ replicate diff ' '
+      mSet $ state { _lstate_curLineCols = n
+                   , _lstate_addSepSpace = False
+                   }
+    else return ()
+
+layoutWriteEnsureBlockPlusN :: (MonadMultiWriter
+                                                           Text.Builder.Builder m,
+                                                         MonadMultiState LayoutState m)
+                            => Int -> m ()
+layoutWriteEnsureBlockPlusN n = do
+  state <- mGet
+  let diff = _lstate_curLineCols state - _lstate_indent state - n
+  if diff>0
+    then layoutWriteNewline
+    else if diff<0
+      then do
+        layoutWriteAppend $ Text.pack $ replicate (negate diff) ' '
+        mSet $ state { _lstate_addSepSpace = False }
+      else return ()
+
+layoutWithAddIndent :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m
+                                               ,MonadMultiReader Config m)
+                  => m ()
+                  -> m ()
+layoutWithAddIndent m = do
+  amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity
+  state <- mGet
+  mSet state { _lstate_indent = _lstate_indent state + amount }
+  m
+  do
+    s <- mGet
+    mSet $ s { _lstate_indent = _lstate_indent state }
+
+layoutWithAddIndentBlock :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m
+                                               ,MonadMultiReader Config m)
+                  => m ()
+                  -> m ()
+layoutWithAddIndentBlock m = do
+  amount <- mAsk <&> _conf_layout .> _lconfig_indentAmount .> runIdentity
+  state <- mGet
+  mSet state { _lstate_indent = _lstate_indent state + amount }
+  layoutWriteEnsureBlock
+  m
+  do
+    s <- mGet
+    mSet $ s { _lstate_indent = _lstate_indent state }
+
+layoutWithAddIndentNBlock :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                  => Int
+                  -> m ()
+                  -> m ()
+layoutWithAddIndentNBlock amount m = do
+  state <- mGet
+  mSet state { _lstate_indent = _lstate_indent state + amount }
+  layoutWriteEnsureBlock
+  m
+  do
+    s <- mGet
+    mSet $ s { _lstate_indent = _lstate_indent state }
+
+layoutWithAddIndentN :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                  => Int
+                  -> m ()
+                  -> m ()
+layoutWithAddIndentN amount m = do
+  state <- mGet
+  mSet state { _lstate_indent = _lstate_indent state + amount }
+  m
+  do
+    s <- mGet
+    mSet $ s { _lstate_indent = _lstate_indent state }
+
+layoutAddSepSpace :: MonadMultiState LayoutState m => m ()
+layoutAddSepSpace = do
+  state <- mGet
+  mSet $ state { _lstate_addSepSpace = True }
+
+moveToExactAnn :: (Data.Data.Data x,
+                    MonadMultiWriter Text.Builder.Builder m,
+                    MonadMultiState LayoutState m,
+                    MonadMultiReader (Map AnnKey Annotation) m) => GenLocated SrcSpan x -> m ()
+moveToExactAnn ast = do
+  anns <- mAsk
+  case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of
+    Nothing -> return ()
+    Just ann -> do
+      let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann
+      replicateM_ x $ layoutWriteNewline
+
+-- 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
+  anns <- mAsk
+  case Map.lookup annKey anns of
+    Nothing -> return ()
+    Just ann -> do
+      -- curY <- mGet <&> _lstate_curLineCols
+      let ExactPrint.Types.DP (x, _y) = ExactPrint.Types.annEntryDelta ann
+      replicateM_ x $ layoutWriteNewline
+      -- when (x/=0) $ do
+      --   replicateM_ x $ layoutWriteNewlinePlain
+      --   mModify $ \s -> s { _lstate_curLineCols = curY }
+      --   mTell $ Text.Builder.fromString $ replicate curY ' '
+
+ppmMoveToExactLoc :: MonadMultiWriter Text.Builder.Builder m
+                  => ExactPrint.Types.DeltaPos
+                  -> m ()
+ppmMoveToExactLoc (ExactPrint.Types.DP (x,y)) = do
+  replicateM_ x $ mTell $ Text.Builder.fromString "\n"
+  replicateM_ y $ mTell $ Text.Builder.fromString " "
+
+layoutWithNonParamIndent :: (MonadMultiWriter
+                                                 Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+    => LayoutFuncParams -> m () -> m ()
+layoutWithNonParamIndent params m = do
+  case _params_opIndent params of
+    Nothing -> m
+    Just x -> layoutWithAddIndentN x m
+
+setOpIndent :: Int -> LayoutDesc -> LayoutFuncParams -> LayoutFuncParams
+setOpIndent i desc p = p
+  { _params_opIndent = Just $ case _bdesc_opIndentFloatUp =<< _ldesc_block desc of
+      Nothing -> i
+      Just j -> max i j
+  }
+
+stringLayouter :: Data.Data.Data ast
+               => GenLocated SrcSpan ast -> Text -> Layouter
+stringLayouter ast t = Layouter
+  { _layouter_desc = LayoutDesc
+    { _ldesc_line = Just $ LayoutColumns
+      { _lColumns_key = ColumnKeyUnique
+      , _lColumns_lengths = [Text.length t]
+      , _lColumns_min = Text.length t
+      }
+    , _ldesc_block = Nothing
+    }
+  , _layouter_func = \_ -> do
+      layoutWritePriorCommentsRestore ast
+      layoutWriteAppend t
+      layoutWritePostComments ast
+  , _layouter_ast = ast
+  }
+
+layoutWritePriorComments :: (Data.Data.Data ast,
+                                               MonadMultiWriter Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                         => GenLocated SrcSpan ast -> m ()
+layoutWritePriorComments ast = do
+  mAnn <- do
+    state <- mGet
+    let key = ExactPrint.Types.mkAnnKey ast
+    let m   = _lstate_commentsPrior state
+    let mAnn = Map.lookup key m
+    mSet $ state { _lstate_commentsPrior = Map.delete key m }
+    return mAnn
+  case mAnn of
+    Nothing -> return ()
+    Just priors -> do
+      when (not $ null priors) $ do
+        state <- mGet
+        mSet $ state { _lstate_commentCol = Just $ _lstate_curLineCols state }
+      priors `forM_` \( ExactPrint.Types.Comment comment _ _
+                      , ExactPrint.Types.DP (x, y)
+                      ) -> do
+        replicateM_ x layoutWriteNewlinePlain
+        layoutWriteAppend $ Text.pack $ replicate y ' '
+        layoutWriteAppendMultiline $ Text.pack $ comment
+
+-- 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)
+                         => GenLocated SrcSpan ast -> m ()
+layoutWritePostComments ast = do
+  mAnn <- do
+    state <- mGet
+    let key = ExactPrint.Types.mkAnnKey ast
+    let m   = _lstate_commentsPost state
+    let mAnn = Map.lookup key m
+    mSet $ state { _lstate_commentsPost = Map.delete key m }
+    return mAnn
+  case mAnn of
+    Nothing -> return ()
+    Just posts -> do
+      when (not $ null posts) $ do
+        state <- mGet
+        mSet $ state { _lstate_commentCol = Just $ _lstate_curLineCols state }
+      posts `forM_` \( ExactPrint.Types.Comment comment _ _
+                      , ExactPrint.Types.DP (x, y)
+                      ) -> do
+        replicateM_ x layoutWriteNewlinePlain
+        layoutWriteAppend $ Text.pack $ replicate y ' '
+        layoutWriteAppendMultiline $ Text.pack $ comment
+
+layoutIndentRestorePostComment :: ( Monad m
+           , MonadMultiState LayoutState m
+           , MonadMultiWriter Text.Builder.Builder m
+           )
+                               => m ()
+layoutIndentRestorePostComment = do
+  mCommentCol <- _lstate_commentCol <$> mGet
+  case mCommentCol of
+    Nothing -> return ()
+    Just commentCol -> do
+      layoutWriteNewlinePlain
+      layoutWriteAppend $ Text.pack $ replicate commentCol ' '
+
+layoutWritePriorCommentsRestore :: (Data.Data.Data ast,
+                                               MonadMultiWriter Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                                => GenLocated SrcSpan ast -> m ()
+layoutWritePriorCommentsRestore x = do
+  layoutWritePriorComments x
+  layoutIndentRestorePostComment
+
+layoutWritePostCommentsRestore :: (Data.Data.Data ast,
+                                               MonadMultiWriter Text.Builder.Builder m,
+                                               MonadMultiState LayoutState m)
+                                => GenLocated SrcSpan ast -> m ()
+layoutWritePostCommentsRestore x = do
+  layoutWritePostComments x
+  layoutIndentRestorePostComment
+
+extractCommentsPrior :: ExactPrint.Types.Anns -> PriorMap
+extractCommentsPrior anns = flip Map.mapMaybe anns $ \ann ->
+  [r | let r = ExactPrint.Types.annPriorComments ann, not (null r)]
+extractCommentsPost  :: ExactPrint.Types.Anns -> PostMap
+extractCommentsPost  anns = flip Map.mapMaybe anns $ \ann ->
+  [r
+  | let
+    r = ExactPrint.Types.annsDP ann
+      >>= \case
+                 (ExactPrint.Types.AnnComment comment, dp) -> [(comment, dp)]
+                 _ -> []
+  , not (null r)
+  ]
+
+
+applyLayouter :: Layouter -> LayoutFuncParams -> LayoutM ()
+applyLayouter l@(Layouter _ _ ast) params = do
+  -- (always) write the prior comments at this point.
+  layoutWritePriorCommentsRestore ast
+  -- run the real stuff.
+  _layouter_func l params
+  -- if the _layouter_func has not done so already at some point
+  -- (there are nodes for which this makes sense),
+  -- write the post comments.
+  -- effect is `return ()` if there are no postComments.
+  layoutWritePostComments ast
+
+applyLayouterRestore :: Layouter -> LayoutFuncParams -> LayoutM ()
+applyLayouterRestore l@(Layouter _ _ ast) params = do
+  -- (always) write the prior comments at this point.
+  layoutWritePriorCommentsRestore ast
+  -- run the real stuff.
+  _layouter_func l params
+  -- if the _layouter_func has not done so already at some point
+  -- (there are nodes for which this makes sense),
+  -- write the post comments.
+  -- effect is `return ()` if there are no postComments.
+  layoutWritePostCommentsRestore ast
+
+foldedAnnKeys :: Data.Data.Data ast
+              => ast
+              -> Set ExactPrint.Types.AnnKey
+foldedAnnKeys ast = everything
+  Set.union
+  (\x -> maybe
+         Set.empty
+         Set.singleton
+         [ gmapQi 1 (\t -> ExactPrint.Types.mkAnnKey $ L l t) x
+         | typeRepTyCon (typeOf (L () ())) == (typeRepTyCon (typeOf x))
+         , l <- gmapQi 0 cast x
+         ]
+  )
+  ast
+
+filterAnns :: Data.Data.Data ast
+           => ast
+           -> ExactPrint.Types.Anns
+           -> ExactPrint.Types.Anns
+filterAnns ast anns =
+  Map.filterWithKey (\k _ -> k `Set.member` foldedAnnKeys ast) anns
+
+layouterFToLayouterM :: MultiReader '[Config, ExactPrint.Types.Anns] a -> LayoutM a
+layouterFToLayouterM m = do
+  settings <- mAsk
+  anns <- mAsk
+  return $ runIdentity
+         $ runMultiReaderTNil
+         $ Control.Monad.Trans.MultiReader.Lazy.withMultiReader anns
+         $ Control.Monad.Trans.MultiReader.Lazy.withMultiReader settings
+         $ m
+
+-- new BriDoc stuff
+
+docEmpty :: BriDoc
+docEmpty = BDEmpty
+
+docLit :: Text -> BriDoc
+docLit t = BDLit t
+
+docExt :: ExactPrint.Annotate.Annotate ast
+       => GenLocated SrcSpan ast -> ExactPrint.Types.Anns -> BriDoc
+docExt x anns = BDExternal
+                  (ExactPrint.Types.mkAnnKey x)
+                  (foldedAnnKeys x)
+                  (Text.pack $ ExactPrint.exactPrint x anns)
+
+docAlt :: [BriDoc] -> BriDoc
+docAlt = BDAlt
+
+
+docSeq :: [BriDoc] -> BriDoc
+docSeq = BDSeq
+
+
+docPostComment :: Data.Data.Data ast
+               => GenLocated SrcSpan ast
+               -> BriDoc
+               -> BriDoc
+docPostComment ast bd = BDAnnotationPost (ExactPrint.Types.mkAnnKey ast) bd
+
+docWrapNode :: Data.Data.Data ast
+            => GenLocated SrcSpan ast
+            -> BriDoc
+            -> BriDoc
+docWrapNode ast bd = BDAnnotationPrior (ExactPrint.Types.mkAnnKey ast)
+                   $ BDAnnotationPost (ExactPrint.Types.mkAnnKey ast)
+                   $ bd
+
+docPar :: BriDoc
+       -> BriDoc
+       -> BriDoc
+docPar line indented = BDPar BrIndentNone line indented
+
+-- docPar :: BriDoc
+--        -> BrIndent
+--        -> [BriDoc]
+--        -> BriDoc
+-- docPar = BDPar
+
+-- docCols :: ColSig
+--         -> [BriDoc]
+--         -> BriDoc
+-- docCols = BDCols
+
+
+fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
+fromMaybeIdentity x y = Data.Coerce.coerce
+                      $ fromMaybe (Data.Coerce.coerce x) y

src-idemtests/run.sh

@@ -0,0 +1,36 @@
+#!/bin/bash
+
+# set -x
+set -e
+
+rm report.txt &> /dev/null || true
+
+mkdir iterOne &> /dev/null || true
+mkdir iterTwo &> /dev/null || true
+
+for FILE in ./cases/*
+do
+  NAME=$(basename "$FILE")
+  ITERNAMEONE="./iterOne/$NAME"
+  ITERNAMETWO="./iterTwo/$NAME"
+  if ! ./brittany -i "$FILE" -o "$ITERNAMEONE"
+  then
+    echo "FAILED step 1 for $FILE" | tee -a report.txt
+    continue
+  fi
+  if ! ./brittany -i "$ITERNAMEONE" -o "$ITERNAMETWO"
+  then
+    echo "FAILED step 2 for $FILE" | tee -a report.txt
+    continue
+  fi
+  if ! diff "$ITERNAMEONE" "$ITERNAMETWO" > diff.temp
+  then
+    echo "FAILED diff for $FILE with diff:" | tee -a report.txt
+    cat diff.temp | tee -a report.txt
+    echo "# meld $(realpath $ITERNAMEONE) $(realpath $ITERNAMETWO)" | tee -a report.txt
+    continue
+  fi
+  echo "success for $FILE" | tee -a report.txt
+done
+
+rm diff.temp &> /dev/null || true

src-unittests/AsymptoticPerfTests.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module AsymptoticPerfTests
+  ( asymptoticPerfTest
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import Test.Hspec
+
+import NeatInterpolation
+
+import Language.Haskell.Brittany
+
+import TestUtils
+
+
+
+asymptoticPerfTest :: Spec
+asymptoticPerfTest = do
+  it "1000 do statements" $ roundTripEqualWithTimeout 1000000 $ 
+    ( Text.pack "func = do\n")
+    <> Text.replicate 1000 (Text.pack "  statement\n")
+  it "1000 do nestings" $ roundTripEqualWithTimeout 4000000 $ 
+    ( Text.pack "func = ")
+    <> mconcat ([0..999] <&> \(i::Int) -> (Text.replicate (2*i) (Text.pack " ") <> Text.pack "do\n"))
+    <> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n"
+    <> Text.replicate 2002 (Text.pack " ") <> Text.pack "()"
+  it "1000 AppOps" $ roundTripEqualWithTimeout 1000000 $ 
+    ( Text.pack "func = expr")
+    <> Text.replicate 200 (Text.pack "\n     . expr") --TODO

src-unittests/IdentityTests.hs

@@ -0,0 +1,554 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module IdentityTests
+  ( identityTests
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import Test.Hspec
+
+import NeatInterpolation
+
+import Language.Haskell.Brittany
+
+import TestUtils
+
+
+
+identityTests :: Spec
+identityTests = do
+  describe "type signatures" $ typeSignatureTests
+  describe "equation" $ do
+    describe "basic"    $ basicEquationTests
+    describe "patterns" $ patternTests
+    describe "guards"   $ guardTests
+  describe "expression" $ do
+    describe "basic"         $ basicExpressionTests
+    describe "do statements" $ doStatementTests
+  describe "alignment" $ alignmentTests
+  describe "regression" $ regressionTests
+
+typeSignatureTests :: Spec
+typeSignatureTests = do
+  it "simple001" $ roundTripEqual $
+    [text|
+    func :: a -> a
+    |]
+  it "long typeVar" $ roundTripEqual $
+    [text|
+    func
+      :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+      -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    |]
+  it "keep linebreak mode" $ roundTripEqual $
+    [text|
+    func
+      :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+      -> lakjsdlkjasldkj
+      -> lakjsdlkjasldkj
+    |]
+  it "simple parens 1" $ roundTripEqual $
+    [text|
+    func :: ((a))
+    |]
+  it "simple parens 2" $ roundTripEqual $
+    [text|
+    func :: (a -> a) -> a
+    |]
+  it "simple parens 3" $ roundTripEqual $
+    [text|
+    func :: a -> (a -> a)
+    |]
+  it "did anyone say parentheses?" $ roundTripEqual $
+    [text|
+    func :: (((((((((())))))))))
+    |]
+  before_ pending $ it "give me more!" $ roundTripEqual $
+    -- current output is.. funny. wonder if that can/needs to be improved..
+    [text|
+    func :: ((((((((((((((((((((((((((((((((((((((((((()))))))))))))))))))))))))))))))))))))))))))
+    |]    
+  it "unit" $ roundTripEqual $
+    [text|
+    func :: ()
+    |]
+  -- ################################################################## --
+  -- ################################################################## --
+  -- ################################################################## --
+  it "paren'd func 1" $ roundTripEqual $
+    [text|
+    func
+      :: (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         -> lakjsdlkjasldkj
+         -> lakjsdlkjasldkj
+         )
+    |]
+  it "paren'd func 2" $ roundTripEqual $
+    [text|
+    func
+      :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+      -> (lakjsdlkjasldkj -> lakjsdlkjasldkj)
+    |]
+  it "paren'd func 3" $ roundTripEqual $
+    [text|
+    func
+      :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj)
+      -> lakjsdlkjasldkj
+    |]
+  it "paren'd func 4" $ roundTripEqual $
+    [text|
+    func
+      :: (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         )
+      -> lakjsdlkjasldkj
+    |]
+  it "paren'd func 5" $ roundTripEqual $
+    [text|
+    func
+      :: ( (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           )
+         )
+    |]
+  -- ################################################################## --
+  -- ################################################################## --
+  -- ################################################################## --
+  it "type application 1" $ roundTripEqual $
+    [text|
+    func :: asd -> Either a b
+    |]
+  it "type application 2" $ roundTripEqual $
+    [text|
+    func
+      :: asd
+      -> Either
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    |]
+  it "type application 3" $ roundTripEqual $
+    [text|
+    func
+      :: asd
+      -> Trither
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    |]
+  it "type application 4" $ roundTripEqual $
+    [text|
+    func
+      :: Trither
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+      -> asd
+    |]
+  it "type application 5" $ roundTripEqual $
+    [text|
+    func
+      :: Trither
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd)
+    |]
+  it "type application 6" $ roundTripEqual $
+    [text|
+    func
+      :: Trither
+           asd
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           )
+    |]
+  it "type application paren 1" $ roundTripEqual $
+    [text|
+    func
+      :: asd
+      -> ( Trither
+             lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+             lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+             lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         )
+    |]
+  it "type application paren 2" $ roundTripEqual $
+    [text|
+    func
+      :: asd
+      -> ( Trither
+             lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+             lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         )
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    |]
+  it "type application paren 3" $ roundTripEqual $
+    [text|
+    func
+      :: ( Trither
+             lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+             lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         )
+           lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+      -> asd
+    |]
+  -- ################################################################## --
+  -- ################################################################## --
+  -- ################################################################## --
+  it "list simple" $ roundTripEqual $
+    [text|
+    func :: [a -> b]
+    |]
+  it "list func" $ roundTripEqual $
+    [text|
+    func
+      :: [  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         ]
+    |]
+  it "list paren" $ roundTripEqual $
+    [text|
+    func
+      :: [ (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           )
+         ]
+    |]
+  -- ################################################################## --
+  -- ################################################################## --
+  -- ################################################################## --    
+  it "tuple type 1" $ roundTripEqual $
+    [text|
+    func :: (a, b, c)
+    |]
+  it "tuple type 2" $ roundTripEqual $
+    [text|
+    func :: ((a, b, c), (a, b, c), (a, b, c))
+    |]
+  it "tuple type long" $ roundTripEqual $
+    [text|
+    func
+      :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         )
+    |]
+  it "tuple type nested" $ roundTripEqual $
+    [text|
+    func
+      :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd)
+           , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           )
+         )
+    |]
+  it "tuple type function" $ roundTripEqual $
+    [text|
+    func
+      :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+           )
+         ]
+    |]
+  -- ################################################################## --
+  -- ################################################################## --
+  -- ################################################################## --
+  before_ pending $ it "type operator stuff" $ roundTripEqual $
+    [text|
+    test050 :: a :+: b
+    test051 ::  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+            :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    test052 ::  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+            ->  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+            :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+            ->  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    |]
+  -- ################################################################## --
+  -- ################################################################## --
+  -- ################################################################## --
+  it "forall oneliner" $ roundTripEqual $
+    [text|
+    {-# LANGUAGE ScopedTypeVariables #-}
+    --this comment is necessary for whatever reason..
+    func :: forall (a :: *) b . a -> b
+    |]
+  it "language pragma issue" $ roundTripEqual $
+    [text|
+    {-# LANGUAGE ScopedTypeVariables #-}
+    func :: forall (a :: *) b . a -> b
+    |]
+  it "comments 1" $ roundTripEqual $
+    [text|
+    func :: a -> b -- comment
+    |]
+  it "comments 2" $ roundTripEqual $
+    [text|
+    funcA :: a -> b -- comment A
+    funcB :: a -> b -- comment B
+    |]
+  before_ pending $ it "comments all" $ roundTripEqual $
+    [text|
+    -- a
+    func -- b
+      :: -- c
+      a -- d
+      -> -- e
+      ( -- f
+      c -- g
+      , -- h
+      d -- i
+      ) -- j
+    -- k
+    |]
+  -- ################################################################## --
+  -- ################################################################## --
+  -- ################################################################## --
+  it "ImplicitParams 1" $ roundTripEqual $
+    [text|
+    {-# LANGUAGE ImplicitParams #-}
+    func :: (?asd::Int) -> ()
+    |]
+  it "ImplicitParams 2" $ roundTripEqual $
+    [text|
+    {-# LANGUAGE ImplicitParams #-}
+    func
+      :: (  ?asd
+         :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         )
+      -> ()
+    |]
+
+
+
+-- some basic testing of different kinds of equations.
+-- some focus on column layouting for multiple-equation definitions.
+-- (that part probably is not implemented in any way yet.)
+basicEquationTests :: Spec
+basicEquationTests = do
+  it "basic 1" $ roundTripEqual $
+    [text|
+    func x = x
+    |]
+  it "infix 1" $ roundTripEqual $
+    [text|
+    x *** y = x
+    |]
+  it "symbol prefix" $ roundTripEqual $
+    [text|
+    (***) x y = x
+    |]
+
+
+
+patternTests :: Spec
+patternTests = do
+  it "wildcard" $ roundTripEqual $
+    [text|
+    func _ = x
+    |]
+  before_ pending $ it "simple long pattern" $ roundTripEqual $
+    [text|
+    func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
+      = x
+    |]
+  before_ pending $ it "simple multiline pattern" $ roundTripEqual $
+    [text|
+    func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
+         reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
+      = x
+    |]
+  before_ pending $ it "another multiline pattern" $ roundTripEqual $
+    [text|
+    func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
+         a
+         b
+      = x
+    |]
+  before_ pending $ it "simple constructor" $ roundTripEqual $
+    [text|
+    func (A a) = a
+    |]
+  before_ pending $ it "list constructor" $ roundTripEqual $
+    [text|
+    func (x:xr) = x
+    |]
+  before_ pending $ it "some other constructor symbol" $ roundTripEqual $
+    [text|
+    func (x:+:xr) = x
+    |]
+
+guardTests :: Spec
+guardTests = do
+  it "simple guard" $ roundTripEqual $
+    [text|
+    func | True = x
+    |]
+
+basicExpressionTests :: Spec
+basicExpressionTests = do
+  it "var" $ roundTripEqual $
+    [text|
+    func = x
+    |]
+  describe "infix op" $ do
+    it "1" $ roundTripEqual $
+      [text|
+      func = x + x
+      |]
+    before_ pending $ it "long" $ roundTripEqual $
+      [text|
+      func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
+           + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
+      |]
+    before_ pending $ it "long keep linemode 1" $ roundTripEqual $
+      [text|
+      func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
+           + mweroiuxlskdfjlksj
+           + mweroiuxlskdfjlksj
+      |]
+    before_ pending $ it "long keep linemode 2" $ roundTripEqual $
+      [text|
+      func = mweroiuxlskdfjlksj
+           + mweroiuxlskdfjlksj
+           + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
+      |]
+  it "literals" $ roundTripEqual $
+    [text|
+    func = 1
+    func = "abc"
+    func = 1.1e5
+    func = 'x'
+    func = 981409823458910394810928414192837123987123987123
+    |]
+  it "lambdacase" $ roundTripEqual $
+    [text|
+    {-# LANGUAGE LambdaCase #-}
+    func = \case
+      FooBar -> x
+      Baz    -> y
+    |]
+
+
+doStatementTests :: Spec
+doStatementTests = do
+  it "simple" $ roundTripEqual $
+    [text|
+    func = do
+      stmt
+      stmt
+    |]
+  it "bind" $ roundTripEqual $
+    [text|
+    func = do
+      x <- stmt
+      stmt x
+    |]
+  it "let" $ roundTripEqual $
+    [text|
+    func = do
+      let x = 13
+      stmt x
+    |]
+  return ()
+
+alignmentTests :: Spec
+alignmentTests = do
+  return ()
+
+regressionTests :: Spec
+regressionTests = do
+  it "newlines-comment" $ do
+    roundTripEqual $
+      [text|
+      func = do
+        abc <- foo
+
+        --abc
+        return ()
+      |]
+  it "parenthesis-around-unit" $ do
+    roundTripEqual $
+      [text|
+      func = (())
+      |]
+  it "let-defs indentation" $ do
+    roundTripEqual $
+      [text|
+      func = do
+        let foo True = True
+            foo _    = False
+        return ()
+      |]
+  it "record update indentation 1" $ do
+    roundTripEqual $
+      [text|
+      func = do
+        s <- mGet
+        mSet $ s { _lstate_indent = _lstate_indent state }
+      |]
+  it "record update indentation 2" $ do
+    roundTripEqual $
+      [text|
+      func = do
+        s <- mGet
+        mSet $ s { _lstate_indent = _lstate_indent state
+                 , _lstate_indent = _lstate_indent state
+                 }
+      |]
+  it "record update indentation 3" $ do
+    roundTripEqual $
+      [text|
+      func = do
+        s <- mGet
+        mSet $ s
+          { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+          , _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+          }
+      |]
+  it "post-indent comment" $ do
+    roundTripEqual $
+      [text|
+      func = do
+      -- abc
+        -- def
+        return ()
+      |]
+  it "post-unindent comment" $ do
+    roundTripEqual $
+      [text|
+      func = do
+        do
+          return ()
+          -- abc
+        -- def
+        return ()
+      |]
+  it "CPP empty comment case" $ do
+    pendingWith "CPP parsing needs fixing for roundTripEqual"
+    roundTripEqual $
+      [text|
+      {-# LANGUAGE CPP #-}
+      module Test where
+      func = do
+      #if FOO
+        let x = 13
+      #endif
+        stmt x
+      |]
+  -- really, the following should be handled by forcing the Alt to multiline
+  -- because there are comments. as long as this is not implemented though,
+  -- we should ensure the trivial solution works.
+  it "comment inline placement (temporary)" $ do
+    roundTripEqual $
+      [text|
+      func :: Int -> -- basic indentation amount
+                     Int -> -- currently used width in current line (after indent)
+                            -- used to accurately calc placing of the current-line
+                            LayoutDesc -> Int
+      |]

src-unittests/TestMain.hs

@@ -0,0 +1,26 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Main where
+
+
+
+#include "prelude.inc"
+
+import Test.Hspec
+
+import NeatInterpolation
+
+import Language.Haskell.Brittany
+
+import IdentityTests
+import AsymptoticPerfTests
+
+
+
+main :: IO ()
+main = hspec $ tests
+
+tests :: Spec
+tests = do
+  describe "identity roundtrips" $ identityTests
+  describe "asymptotic perf roundtrips" $ asymptoticPerfTest

src-unittests/TestUtils.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module TestUtils where
+
+
+
+#include "prelude.inc"
+
+import Test.Hspec
+
+import NeatInterpolation
+
+import Language.Haskell.Brittany
+
+import Language.Haskell.Brittany.Config.Types
+
+import System.Timeout ( timeout )
+
+
+
+roundTripEqual :: Text -> Expectation
+roundTripEqual t = fmap (fmap PPTextWrapper) (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
+    `shouldReturn` Right (PPTextWrapper t)
+
+roundTripEqualWithTimeout :: Int -> Text -> Expectation
+roundTripEqualWithTimeout time t =
+  timeout time (action >>= evaluate) >>= (`shouldSatisfy` Data.Maybe.isJust)
+  where
+    action = fmap (fmap PPTextWrapper)
+                  (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
+
+newtype PPTextWrapper = PPTextWrapper Text
+  deriving Eq
+
+instance Show PPTextWrapper where
+  show (PPTextWrapper t) = "\n" ++ Text.unpack t
+
+defaultTestConfig :: Config
+defaultTestConfig = Config
+    { _conf_debug = _conf_debug staticDefaultConfig
+    , _conf_layout = LayoutConfig
+      { _lconfig_cols               = Identity 80
+      , _lconfig_indentPolicy       = Identity IndentPolicyFree
+      , _lconfig_indentAmount       = Identity 2
+      , _lconfig_indentWhereSpecial = Identity True
+      , _lconfig_indentListSpecial  = Identity True
+      , _lconfig_importColumn       = Identity 60
+      , _lconfig_altChooser         = Identity $ AltChooserBoundedSearch 3
+      }
+    , _conf_errorHandling = _conf_errorHandling staticDefaultConfig
+    }

src/Language/Haskell/Brittany.hs

@@ -0,0 +1,212 @@
+{-# LANGUAGE DataKinds #-}
+
+module Language.Haskell.Brittany
+  ( parsePrintModule
+  , pPrintModule
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import DynFlags ( getDynFlags )
+import GHC ( runGhc, GenLocated(L), moduleNameString )
+import qualified Parser        as GHC
+import qualified ApiAnnotation as GHC
+import qualified DynFlags      as GHC
+import qualified FastString    as GHC
+import qualified GHC           as GHC hiding (parseModule)
+import qualified HeaderInfo    as GHC
+import qualified Lexer         as GHC
+import qualified MonadUtils    as GHC
+import qualified Outputable    as GHC
+import qualified Parser        as GHC
+import qualified SrcLoc        as GHC
+import qualified StringBuffer  as GHC
+import RdrName ( RdrName(..) )
+import Control.Monad.IO.Class
+import GHC.Paths (libdir)
+import HsSyn
+import SrcLoc ( SrcSpan, Located )
+-- import Outputable ( ppr, runSDoc )
+-- import DynFlags ( unsafeGlobalDynFlags )
+
+import           ApiAnnotation ( AnnKeywordId(..) )
+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.Parsers as ExactPrint.Parsers
+import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint.Preprocess
+import qualified Data.Map as Map
+
+import qualified Data.Text.Lazy.Builder as Text.Builder
+
+import qualified Debug.Trace as Trace
+
+import Language.Haskell.Brittany.Types
+import Language.Haskell.Brittany.Config.Types
+import Language.Haskell.Brittany.LayoutBasics
+import           Language.Haskell.Brittany.Layouters.Type
+import           Language.Haskell.Brittany.Layouters.Decl
+import           Language.Haskell.Brittany.Utils
+import           Language.Haskell.Brittany.BriLayouter
+
+
+
+-- LayoutErrors 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
+  -> ExactPrint.Types.Anns
+  -> GHC.ParsedSource
+  -> ([LayoutError], TextL.Text)
+pPrintModule conf anns parsedModule =
+  let ((out, errs), debugStrings)
+        = runIdentity
+        $ MultiRWSS.runMultiRWSTNil
+        $ MultiRWSS.withMultiWriterAW
+        $ MultiRWSS.withMultiWriterAW
+        $ MultiRWSS.withMultiWriterW
+        $ MultiRWSS.withMultiReader anns
+        $ MultiRWSS.withMultiReader conf
+        $ do
+            traceIfDumpConf "bridoc annotations" _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 ()
+
+-- used for testing mostly, currently.
+parsePrintModule
+  :: Config
+  -> String
+  -> Text
+  -> IO (Either String Text)
+parsePrintModule conf filename input = do
+  let inputStr = Text.unpack input
+  parseResult <- ExactPrint.Parsers.parseModuleFromString filename inputStr
+  case parseResult of
+    Left (_, s) -> return $ Left $ "parsing error: " ++ s
+    Right (anns, parsedModule) ->
+      let (errs, ltext) = pPrintModule conf anns parsedModule
+      in return $ if null errs
+        then Right $ TextL.toStrict $ ltext
+        else
+          let errStrs = errs <&> \case
+                LayoutErrorUnusedComment str -> str
+                LayoutWarning str -> str
+                LayoutErrorUnknownNode str _ -> str
+          in Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
+
+-- this approach would for with there was a pure GHC.parseDynamicFilePragma.
+-- Unfortunately that does not exist yet, so we cannot provide a nominally
+-- pure interface.
+
+-- parsePrintModule :: Text -> Either String Text
+-- parsePrintModule 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
+--                 LayoutErrorUnusedComment str -> str
+--           Left $ "pretty printing error(s):\n" ++ List.unlines errStrs
+--         else return $ TextL.toStrict $ Text.Builder.toLazyText out
+
+ppModule :: GenLocated SrcSpan (HsModule RdrName) -> PPM ()
+ppModule lmod@(L loc m@(HsModule _name _exports _imports decls _ _)) = do
+  let emptyModule = L loc m { hsmodDecls = [] }
+  (anns', post) <- do
+    anns <- mAsk
+    -- evil partiality. but rather unlikely.
+    return $ case Map.lookup (ExactPrint.Types.mkAnnKey lmod) anns of
+      Nothing -> (anns, [])
+      Just mAnn ->
+        let
+          modAnnsDp = ExactPrint.Types.annsDP mAnn
+          isWhere (ExactPrint.Types.G AnnWhere) = True
+          isWhere _ = False
+          isEof   (ExactPrint.Types.G 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.Types.annsDP = pre }
+          anns' = Map.insert (ExactPrint.Types.mkAnnKey lmod) mAnn' anns
+        in (anns', post)
+  MultiRWSS.withMultiReader anns' $ processDefault emptyModule
+  decls `forM_` ppDecl
+  let
+    finalComments = filter (fst .> \case ExactPrint.Types.AnnComment{} -> True
+                                         _ -> False)
+                           post
+  post `forM_` \case
+    (ExactPrint.Types.AnnComment (ExactPrint.Types.Comment cmStr _ _), l) -> do
+      ppmMoveToExactLoc l
+      mTell $ Text.Builder.fromString cmStr
+    (ExactPrint.Types.G AnnEofPos, (ExactPrint.Types.DP (eofX,eofY))) ->
+      let cmX = foldl' (\acc (_, ExactPrint.Types.DP (x, _)) -> acc+x) 0 finalComments
+      in ppmMoveToExactLoc $ ExactPrint.Types.DP (eofX - cmX, eofY)
+    _ -> return ()
+
+ppDecl :: LHsDecl RdrName -> PPM ()
+ppDecl d@(L loc decl) = case decl of
+  SigD sig  -> -- trace (_sigHead sig) $
+               do
+    -- runLayouter $ Old.layoutSig (L loc sig)
+    briDoc <- briDocMToPPM $ layoutSig (L loc sig)
+    layoutBriDoc d briDoc
+  ValD bind -> -- trace (_bindHead bind) $
+               do
+    -- Old.layoutBind (L loc bind)
+    briDoc <- briDocMToPPM $ do
+      eitherNode <- layoutBind (L loc bind)
+      case eitherNode of
+        Left ns -> docLines $ return <$> ns
+        Right n -> return n
+    layoutBriDoc d briDoc
+  _         ->
+    briDocMToPPM (briDocByExactNoComment d) >>= layoutBriDoc d
+
+_sigHead :: Sig RdrName -> String
+_sigHead = \case
+  TypeSig names _ -> "TypeSig " ++ intercalate "," (Text.unpack . lrdrNameToText <$> names)
+  _ -> "unknown sig"
+
+_bindHead :: HsBind RdrName -> String
+_bindHead = \case
+  FunBind fId _ _ _ [] -> "FunBind " ++ (Text.unpack $ lrdrNameToText $ fId)
+  PatBind _pat _ _ _ ([], []) -> "PatBind smth"
+  _ -> "unknown bind"

src/Language/Haskell/Brittany/Config.hs

@@ -0,0 +1,164 @@
+module Language.Haskell.Brittany.Config
+  ( ConfigF(..)
+  , DebugConfigF(..)
+  , LayoutConfigF(..)
+  , DebugConfig
+  , LayoutConfig
+  , Config
+  , configParser
+  , staticDefaultConfig
+  , readMergePersConfig
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import DynFlags ( getDynFlags )
+import GHC ( runGhc, GenLocated(L), moduleNameString )
+import qualified Parser        as GHC
+import qualified ApiAnnotation as GHC
+import qualified DynFlags      as GHC
+import qualified FastString    as GHC
+import qualified GHC           as GHC hiding (parseModule)
+import qualified HeaderInfo    as GHC
+import qualified Lexer         as GHC
+import qualified MonadUtils    as GHC
+import qualified Outputable    as GHC
+import qualified Parser        as GHC
+import qualified SrcLoc        as GHC
+import qualified StringBuffer  as GHC
+import RdrName ( RdrName(..) )
+import Control.Monad.IO.Class
+import GHC.Paths (libdir)
+import HsSyn
+import SrcLoc ( SrcSpan, Located )
+-- import Outputable ( ppr, runSDoc )
+-- import DynFlags ( unsafeGlobalDynFlags )
+
+import           ApiAnnotation ( AnnKeywordId(..) )
+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.Parsers as ExactPrint.Parsers
+import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint.Preprocess
+import qualified Data.Map as Map
+
+import qualified Data.Text.Lazy.Builder as Text.Builder
+
+import qualified Debug.Trace as Trace
+
+import Language.Haskell.Brittany.Types
+import Language.Haskell.Brittany.LayoutBasics
+
+-- import Data.Aeson
+import GHC.Generics
+import Control.Lens
+
+import qualified Data.Yaml
+
+import UI.Butcher.Monadic
+
+import Language.Haskell.Brittany.Config.Types
+import Language.Haskell.Brittany.Utils
+
+
+
+configParser :: CmdParser Identity out (ConfigF Maybe)
+configParser = do
+  -- TODO: why does the default not trigger; ind never should be []!!
+  ind <- addFlagReadParam "" ["indent"] "AMOUNT"
+    (flagHelpStr "spaces per indentation level")
+  cols <- addFlagReadParam "" ["columns"] "AMOUNT"
+    (flagHelpStr "target max columns (80 is an old default for this)")
+  importCol <- addFlagReadParam "" ["import-col"] "N"
+    (flagHelpStr "column to align import lists at")
+
+  dumpConfig      <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (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")
+  
+  return $ Config
+    { _conf_debug = DebugConfig
+      { _dconf_dump_config       = falseToNothing dumpConfig
+      , _dconf_dump_annotations  = falseToNothing dumpAnnotations
+      , _dconf_dump_ast_unknown  = falseToNothing dumpUnknownAST
+      , _dconf_dump_ast_full     = falseToNothing dumpCompleteAST
+      , _dconf_dump_bridoc_raw            = falseToNothing dumpBriDocRaw
+      , _dconf_dump_bridoc_simpl_alt      = falseToNothing dumpBriDocAlt
+      , _dconf_dump_bridoc_simpl_par      = falseToNothing dumpBriDocPar
+      , _dconf_dump_bridoc_simpl_floating = falseToNothing dumpBriDocFloating
+      , _dconf_dump_bridoc_simpl_columns  = falseToNothing dumpBriDocColumns
+      , _dconf_dump_bridoc_simpl_indent   = falseToNothing dumpBriDocIndent
+      , _dconf_dump_bridoc_final          = falseToNothing dumpBriDocFinal
+      }
+    , _conf_layout = LayoutConfig
+      { _lconfig_cols               = listLastMaybe cols
+      , _lconfig_indentPolicy       = Nothing
+      , _lconfig_indentAmount       = listLastMaybe ind
+      , _lconfig_indentWhereSpecial = Nothing -- falseToNothing _
+      , _lconfig_indentListSpecial  = Nothing -- falseToNothing _
+      , _lconfig_importColumn       = listLastMaybe importCol
+      , _lconfig_altChooser         = Nothing
+      }
+    , _conf_errorHandling = ErrorHandlingConfig
+      { _econf_produceOutputOnErrors = falseToNothing outputOnErrors
+      , _econf_Werror                = falseToNothing wError
+      }
+    }
+    where falseToNothing = Bool.bool Nothing (Just True)
+          listLastMaybe = listToMaybe . reverse
+
+-- 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
+--   }
+
+readMergePersConfig :: ConfigF Maybe -> System.IO.FilePath -> MaybeT IO Config
+readMergePersConfig conf path = do
+  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 $ putStrLn $ "error reading in brittany config from " ++ path ++ ":"
+          liftIO $ putStrLn e
+          mzero
+        Right x -> return x
+      return $ cZip fromMaybeIdentity staticDefaultConfig
+             $ cZip (<|>) conf fileConf
+    else do
+      liftIO $ ByteString.writeFile path
+             $ Data.Yaml.encode
+             $ cMap (Just . runIdentity) staticDefaultConfig
+      return $ cZip fromMaybeIdentity staticDefaultConfig
+             $ conf

src/Language/Haskell/Brittany/Config/Types.hs

@@ -0,0 +1,225 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Language.Haskell.Brittany.Config.Types
+where
+
+
+
+#include "prelude.inc"
+
+import Data.Yaml
+import GHC.Generics
+import Control.Lens
+
+import Data.Data ( Data )
+
+
+
+data DebugConfigF f = DebugConfig
+  { _dconf_dump_config                :: f Bool
+  , _dconf_dump_annotations           :: f Bool
+  , _dconf_dump_ast_unknown           :: f Bool
+  , _dconf_dump_ast_full              :: f Bool
+  , _dconf_dump_bridoc_raw            :: f Bool
+  , _dconf_dump_bridoc_simpl_alt      :: f Bool
+  , _dconf_dump_bridoc_simpl_floating :: f Bool
+  , _dconf_dump_bridoc_simpl_par      :: f Bool
+  , _dconf_dump_bridoc_simpl_columns  :: f Bool
+  , _dconf_dump_bridoc_simpl_indent   :: f Bool
+  , _dconf_dump_bridoc_final          :: f Bool
+  }
+  deriving (Generic)
+
+data LayoutConfigF f = LayoutConfig
+  { _lconfig_cols :: f Int -- the thing that has default 80.
+  , _lconfig_indentPolicy :: f IndentPolicy
+  , _lconfig_indentAmount :: f Int
+  , _lconfig_indentWhereSpecial :: f Bool -- indent where only 1 sometimes (TODO).
+  , _lconfig_indentListSpecial  :: f Bool -- use some special indentation for ","
+                                          -- when creating zero-indentation
+                                          -- multi-line list literals.
+  , _lconfig_importColumn :: f Int
+  , _lconfig_altChooser :: f AltChooser
+  }
+  deriving (Generic)
+
+data ErrorHandlingConfigF f = ErrorHandlingConfig
+  { _econf_produceOutputOnErrors :: f Bool
+  , _econf_Werror :: f Bool
+  }
+  deriving (Generic)
+
+data ConfigF f = Config
+  { _conf_debug :: DebugConfigF f
+  , _conf_layout :: LayoutConfigF f
+  , _conf_errorHandling :: ErrorHandlingConfigF f
+  }
+  deriving (Generic)
+
+-- i wonder if any Show1 stuff could be leveraged.
+deriving instance Show (DebugConfigF Identity)
+deriving instance Show (LayoutConfigF Identity)
+deriving instance Show (ErrorHandlingConfigF Identity)
+deriving instance Show (ConfigF Identity)
+
+deriving instance Show (DebugConfigF Maybe)
+deriving instance Show (LayoutConfigF Maybe)
+deriving instance Show (ErrorHandlingConfigF Maybe)
+deriving instance Show (ConfigF Maybe)
+
+deriving instance Data (DebugConfigF Identity)
+deriving instance Data (LayoutConfigF Identity)
+deriving instance Data (ErrorHandlingConfigF Identity)
+deriving instance Data (ConfigF Identity)
+
+type Config = ConfigF Identity
+type DebugConfig = DebugConfigF Identity
+type LayoutConfig = LayoutConfigF Identity
+type ErrorHandlingConfig = ErrorHandlingConfigF Identity
+
+instance FromJSON (DebugConfigF Maybe)
+instance ToJSON   (DebugConfigF Maybe)
+
+instance FromJSON IndentPolicy
+instance ToJSON   IndentPolicy
+instance FromJSON AltChooser
+instance ToJSON   AltChooser
+
+instance FromJSON (LayoutConfigF Maybe)
+instance ToJSON   (LayoutConfigF Maybe)
+
+instance FromJSON (ErrorHandlingConfigF Maybe)
+instance ToJSON   (ErrorHandlingConfigF Maybe)
+
+instance FromJSON (ConfigF Maybe)
+instance ToJSON   (ConfigF Maybe)
+
+-- instance Monoid DebugConfig where
+--   mempty = DebugConfig Nothing Nothing
+--   DebugConfig x1 x2 `mappend` DebugConfig y1 y2
+--     = DebugConfig (y1 <|> x1)
+--                   (y2 <|> x2)
+-- 
+-- instance Monoid LayoutConfig where
+--   mempty = LayoutConfig Nothing Nothing Nothing Nothing Nothing Nothing
+--   LayoutConfig x1 x2 x3 x4 x5 x6 `mappend` LayoutConfig y1 y2 y3 y4 y5 y6
+--     = LayoutConfig (y1 <|> x1)
+--                    (y2 <|> x2)
+--                    (y3 <|> x3)
+--                    (y4 <|> x4)
+--                    (y5 <|> x5)
+--                    (y6 <|> x6)
+-- 
+-- instance Monoid Config where
+--   mempty = Config
+--     { _conf_debug = mempty
+--     , _conf_layout = mempty
+--     }
+--   mappend c1 c2 = Config
+--     { _conf_debug = _conf_debug c1 <> _conf_debug c2
+--     , _conf_layout = _conf_layout c1 <> _conf_layout c2
+--     }
+
+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 (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)
+
+staticDefaultConfig :: Config
+staticDefaultConfig = Config
+    { _conf_debug = DebugConfig
+      { _dconf_dump_config           = Identity False
+      , _dconf_dump_annotations      = Identity False
+      , _dconf_dump_ast_unknown      = Identity False
+      , _dconf_dump_ast_full         = Identity False
+      , _dconf_dump_bridoc_raw            = Identity False
+      , _dconf_dump_bridoc_simpl_alt      = Identity False
+      , _dconf_dump_bridoc_simpl_floating = Identity False
+      , _dconf_dump_bridoc_simpl_par      = Identity False
+      , _dconf_dump_bridoc_simpl_columns  = Identity False
+      , _dconf_dump_bridoc_simpl_indent   = Identity False
+      , _dconf_dump_bridoc_final          = Identity False
+      }
+    , _conf_layout = LayoutConfig
+      { _lconfig_cols               = Identity 80
+      , _lconfig_indentPolicy       = Identity IndentPolicyFree
+      , _lconfig_indentAmount       = Identity 2
+      , _lconfig_indentWhereSpecial = Identity True
+      , _lconfig_indentListSpecial  = Identity True
+      , _lconfig_importColumn       = Identity 60
+      , _lconfig_altChooser         = Identity $ AltChooserBoundedSearch 3
+      }
+    , _conf_errorHandling = ErrorHandlingConfig
+      { _econf_produceOutputOnErrors = Identity False
+      , _econf_Werror                = Identity False
+      }
+    }
+
+-- TODO: automate writing instances for this to get
+--       the above Monoid instance for free.
+-- potentially look at http://hackage.haskell.org/package/fieldwise-0.1.0.0/docs/src/Data-Fieldwise.html#deriveFieldwise
+class CZip k where
+  cZip :: (forall a . f a -> g a -> h a) -> k f -> k g -> k h
+
+instance CZip DebugConfigF where
+  cZip f (DebugConfig x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)
+         (DebugConfig y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 y11) = DebugConfig
+    (f x1 y1)
+    (f x2 y2)
+    (f x3 y3)
+    (f x4 y4)
+    (f x5 y5)
+    (f x6 y6)
+    (f x7 y7)
+    (f x8 y8)
+    (f x9 y9)
+    (f x10 y10)
+    (f x11 y11)
+
+instance CZip LayoutConfigF where
+  cZip f (LayoutConfig x1 x2 x3 x4 x5 x6 x7)
+         (LayoutConfig y1 y2 y3 y4 y5 y6 y7) = LayoutConfig
+    (f x1 y1)
+    (f x2 y2)
+    (f x3 y3)
+    (f x4 y4)
+    (f x5 y5)
+    (f x6 y6)
+    (f x7 y7)
+
+instance CZip ErrorHandlingConfigF where
+  cZip f (ErrorHandlingConfig x1 x2)
+         (ErrorHandlingConfig y1 y2) = ErrorHandlingConfig
+    (f x1 y1)
+    (f x2 y2)
+
+instance CZip ConfigF where
+  cZip f (Config x1 x2 x3) (Config y1 y2 y3) = Config
+    (cZip f x1 y1)
+    (cZip f x2 y2)
+    (cZip f x3 y3)
+
+cMap :: CZip k => (forall a . f a -> g a) -> k f -> k g
+cMap f c = cZip (\_ -> f) c c
+
+makeLenses ''DebugConfigF
+makeLenses ''ConfigF
+makeLenses ''LayoutConfigF

src/Language/Haskell/Brittany/Layouters/Decl.hs

@@ -0,0 +1,397 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Language.Haskell.Brittany.Layouters.Decl
+  ( layoutSig
+  , layoutBind
+  , layoutLocalBinds
+  , layoutGuardLStmt
+  , layoutPatternBind
+  , layoutGrhs
+  , layoutPatternBindFinal
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import           Language.Haskell.Brittany.Types
+import           Language.Haskell.Brittany.LayoutBasics
+
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import           SrcLoc ( SrcSpan )
+import           HsSyn
+import           Name
+import           Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
+
+import           Language.Haskell.Brittany.Layouters.Type
+import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr
+import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Stmt
+import           Language.Haskell.Brittany.Layouters.Pattern
+
+import           Bag ( mapBagM )
+
+
+
+layoutSig :: ToBriDoc Sig
+layoutSig lsig@(L _loc sig) = docWrapNode lsig $ case sig of
+  TypeSig names (HsIB _ (HsWC _ _ typ)) -> do
+    nameStrs <- names `forM` lrdrNameToTextAnn
+    let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
+    typeDoc <- docSharedWrapper layoutType typ
+    docAlt
+      [ docSeq
+        [ docPostComment lsig $ docLit nameStr
+        , docLit $ Text.pack " :: "
+        , docForceSingleline typeDoc
+        ]
+      , docAddBaseY BrIndentRegular
+      $ docPar
+        (docPostComment lsig $ docLit nameStr)
+        ( docCols ColTyOpPrefix
+          [ docLit $ Text.pack ":: "
+          , docAddBaseY (BrIndentSpecial 3) $ typeDoc
+          ]
+        )
+      ]
+  _ -> briDocByExact lsig -- TODO: should not be necessary
+
+layoutGuardLStmt :: ToBriDoc' (Stmt RdrName (LHsExpr RdrName))
+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
+      [patDoc, docSeq [docLit $ Text.pack " <- ", expDoc]]
+  _ -> briDocByExact lgstmt -- TODO
+
+layoutBind :: ToBriDocC (HsBindLR RdrName RdrName) (Either [BriDocNumbered] BriDocNumbered)
+layoutBind lbind@(L _ bind) = case bind of
+  FunBind fId (MG lmatches@(L _ matches) _ _ _) _ _ [] -> do
+    -- funcPatDocs :: [BriDocNumbered] <- matches `forM` \(L _ match@(Match _
+    --                                           pats
+    --                                           _mType -- not an actual type sig
+    --                                           (GRHSs grhss whereBinds))) -> do
+    --   let isInfix = isInfixMatch match
+    --   let mId     = fId
+    --   idStr <- lrdrNameToTextAnn mId
+    --   patDocs <- docSharedWrapper layoutPat `mapM` pats
+    --   let funcPatternPartLine = case patDocs of
+    --         (p1:pr) | isInfix -> docCols ColFuncPatternsInfix
+    --           ( [ appSep $ docForceSingleline p1
+    --             , appSep $ docLit idStr
+    --             ]
+    --           ++ (pr <&> (\p -> appSep $ docForceSingleline p))
+    --           )
+    --         ps -> docCols ColFuncPatternsPrefix
+    --           $ appSep (docLit $ idStr)
+    --           : (ps <&> (\p -> docSeq [docForceSingleline p, docSeparator]))
+    --   grhssDocsNoInd :: ToBriDocM BriDocNumbered <- do
+    --     case grhss of
+    --       [grhs1] -> _ grhs1
+    --       (grhs1:grhsr) -> do
+    --         grhsDoc1 <- _ grhs1
+    --         grhsDocr <- _ grhsr
+    --         return $ docLines $ grhsDoc1 : grhsDocr
+    --       [] -> error "layoutBind grhssDocsNoInd"
+    --   let grhssDocs = docAlt [grhssDocsNoInd {-, grhssDocsInd TODO-}]
+    --   layoutLocalBinds whereBinds >>= \case
+    --     Nothing -> grhssDocs
+    --     Just whereDocs -> do
+    --       let defaultWhereDocs = docPar grhssDocs 
+    --                            $ docEnsureIndent BrIndentRegular
+    --                            $ docAddBaseY BrIndentRegular
+    --                            $ docPar (docLit $ Text.pack "where")
+    --                            $ docSetIndentLevel $ docLines $ return <$> whereDocs
+    --       case whereDocs of
+    --         [wd] -> docAlt
+    --           [ docSeq [ appSep $ docForceSingleline grhssDocs
+    --                    , appSep $ docLit $ Text.pack "where"
+    --                    , docForceSingleline $ return wd
+    --                    ]
+    --           , defaultWhereDocs
+    --           ]
+    --         _ -> defaultWhereDocs
+    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
+    patDoc <- layoutPat pat
+    clauseDocs <- layoutGrhs `mapM` grhss
+    mWhereDocs <- layoutLocalBinds whereBinds
+    binderDoc <- docLit $ Text.pack "="
+    fmap Right $ docWrapNode lbind $ layoutPatternBindFinal binderDoc (Just patDoc) clauseDocs mWhereDocs
+    -- grhssDocsNoInd <- do
+    --   case grhss of
+    --     [grhs1] -> docSharedWrapper (layoutGrhs (Just $ appSep patDoc)) grhs1
+    --     (grhs1:grhsr) -> do
+    --       grhsDoc1 <- docSharedWrapper (layoutGrhs (Just $ appSep patDoc)) grhs1
+    --       grhsDocr <- docSharedWrapper (layoutGrhs Nothing) `mapM` grhsr
+    --       return $ docLines $ grhsDoc1 : grhsDocr
+    --     [] -> error "layoutBind grhssDocsNoInd"
+    -- let grhssDocs = docAlt [grhssDocsNoInd {-, grhssDocsInd TODO-}]
+    -- case mWhereDocs of
+    --   Nothing ->
+    --     Right <$> grhssDocs
+    --   Just whereDocs -> do
+    --     let defaultWhereDocs = docAddBaseY BrIndentRegular
+    --                          $ docPar grhssDocs 
+    --                          $ docAddBaseY BrIndentRegular
+    --                          $ docPar (docLit $ Text.pack "where")
+    --                          $ docSetIndentLevel $ docLines $ return <$> whereDocs
+    --     Right <$> case whereDocs of
+    --       [wd] -> docAlt
+    --         [ docSeq [ appSep $ docForceSingleline grhssDocs
+    --                  , appSep $ docLit $ Text.pack "where"
+    --                  , docForceSingleline $ return wd
+    --                  ]
+    --         , defaultWhereDocs
+    --         ]
+    --       _ -> defaultWhereDocs
+  _ -> Right <$> briDocByExact lbind
+
+data BagBindOrSig = BagBind (LHsBindLR RdrName RdrName)
+                  | BagSig (LSig RdrName)
+
+bindOrSigtoSrcSpan :: BagBindOrSig -> SrcSpan
+bindOrSigtoSrcSpan (BagBind (L l _)) = l
+bindOrSigtoSrcSpan (BagSig  (L l _)) = l
+
+layoutLocalBinds :: ToBriDocC (HsLocalBindsLR RdrName RdrName) (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 (ValBindsIn bindlrs sigs) -> do
+    let unordered = [BagBind b | b <- Data.Foldable.toList bindlrs] ++ [BagSig s | s <- sigs]
+        ordered = sortBy (comparing 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)) ->
+    -- i _think_ this case never occurs in non-processed ast
+    Just . (:[]) <$> unknownNodeError "HsValBinds ValBindsOut{}" x
+  x@(HsIPBinds _ipBinds) ->
+    Just . (:[]) <$> unknownNodeError "HsIPBinds" x
+  EmptyLocalBinds     ->
+    return $ Nothing
+
+layoutGrhs :: LGRHS RdrName (LHsExpr RdrName) -> ToBriDocM ([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)
+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 RdrName (LHsExpr RdrName) -> ToBriDocM BriDocNumbered
+layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds)))
+  = do
+    patDocs <- docSharedWrapper layoutPat `mapM` pats
+    let isInfix = isInfixMatch match
+    patDoc <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
+      (Just idStr, p1:pr) | isInfix -> docCols ColPatternsFuncInfix
+        ( [ appSep $ docForceSingleline p1
+          , appSep $ docLit idStr
+          ]
+        ++ (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 <- docWrapNodePost lmatch $ layoutGrhs `mapM` grhss
+    mWhereDocs <- layoutLocalBinds whereBinds
+    layoutPatternBindFinal binderDoc (Just patDoc) clauseDocs mWhereDocs
+
+layoutPatternBindFinal :: BriDocNumbered -> Maybe BriDocNumbered -> [([BriDocNumbered], BriDocNumbered, LHsExpr RdrName)] -> Maybe [BriDocNumbered] -> ToBriDocM BriDocNumbered
+layoutPatternBindFinal binderDoc mPatDoc clauseDocs mWhereDocs = do
+  let patPartInline = case mPatDoc of
+        Nothing -> []
+        Just patDoc -> [appSep $ docForceSingleline $ return patDoc]
+      patPartParWrap = case mPatDoc of
+        Nothing -> id
+        Just patDoc -> docPar (return patDoc)
+  docAlt $
+    -- one-line solution
+    [ docCols ColBindingLine
+      [ docSeq
+        (patPartInline ++ [guardPart])
+      , docSeq
+        [ appSep $ return binderDoc
+        , lineMod $ return body
+        , wherePart
+        ]
+      ]
+    | [(guards, body, bodyRaw)] <- [clauseDocs]
+    , let lineMod = case mWhereDocs of
+            Nothing | isExpressionTypeHeadPar bodyRaw ->
+              docAddBaseY BrIndentRegular
+            _ -> docForceSingleline
+    , let guardPart = case guards of
+            [] -> docEmpty
+            [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g, docSeparator]
+            gs -> docSeq
+              $ [appSep $ docLit $ Text.pack "|"]
+              ++ List.intersperse docCommaSep (return <$> gs)
+              ++ [docSeparator]
+    , wherePart <- case mWhereDocs of
+        Nothing -> pure docEmpty
+        Just [w] -> pure $ docSeq
+          [ docSeparator
+          , appSep $ docLit $ Text.pack "where"
+          , docSetBaseY $ docSetIndentLevel $ return w
+          ]
+        _ -> []
+    ] ++
+    -- pattern and exactly one clause in single line, body and where
+    -- indented if necessary.
+    [ docAddBaseY BrIndentRegular
+    $ docPar
+      ( docCols ColBindingLine
+        [ docSeq
+          (patPartInline ++ [appSep guardPart])
+        , docSeq
+          [ appSep $ return binderDoc
+          , lineMod $ docAddBaseY BrIndentRegular $ return body
+          ]
+        ])
+      wherePart
+    | [(guards, body, bodyRaw)] <- [clauseDocs]
+    , let lineMod = case () of
+            _ | isExpressionTypeHeadPar bodyRaw -> id
+            _ -> docForceSingleline
+    , let guardPart = case guards of
+            [] -> docEmpty
+            [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
+            gs -> docSeq
+              $ [appSep $ docLit $ Text.pack "|"]
+              ++ List.intersperse docCommaSep (return <$> gs)
+    , wherePart <- case mWhereDocs of
+        Nothing -> []
+        Just ws -> pure $ docAddBaseY BrIndentRegular $ docPar
+          (docLit $ Text.pack "where")
+          (docSetIndentLevel $ docLines $ return <$> ws)
+    ] ++
+    -- pattern and exactly one clause in single line, body in new line.
+    [ docAddBaseY BrIndentRegular
+    $ docPar
+      (docSeq (patPartInline ++ [appSep $ guardPart, return binderDoc]))
+      (docLines $ [ return body ] ++ wherePart)
+    | [(guards, body, _)] <- [clauseDocs]
+    , let guardPart = case guards of
+            [] -> docEmpty
+            [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
+            gs -> docSeq
+              $ [appSep $ docLit $ Text.pack "|"]
+              ++ List.intersperse docCommaSep (return <$> gs)
+    , let wherePart = case mWhereDocs of
+            Nothing -> []
+            Just ws -> pure $ docAddBaseY BrIndentRegular $ docPar
+              (docLit $ Text.pack "where")
+              (docSetIndentLevel $ docLines $ return <$> ws)
+    ] ++
+    [ docAddBaseY BrIndentRegular
+    $ patPartParWrap
+    $ docLines $
+        (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]
+            ]
+        ) ++
+        (case mWhereDocs of
+          Nothing -> []
+          Just whereDocs ->
+            [ docAddBaseY BrIndentRegular
+            $ docPar (docLit $ Text.pack "where")
+            $ docSetIndentLevel $ docLines (return <$> whereDocs)
+            ]
+        )
+    ]
+
+-- layoutBind :: LayouterFType' (HsBindLR RdrName RdrName)
+-- layoutBind lbind@(L _ bind) = case bind of
+-- #if MIN_VERSION_ghc(8,0,0)
+--   FunBind fId (MG (L _ matches) _ _ _) _ _ [] -> do
+-- #else
+--   FunBind fId fInfix (MG matches _ _ _) _ _ [] -> do
+-- #endif
+--     return $ Layouter
+--       { _layouter_desc = LayoutDesc
+--         { _ldesc_line  = Nothing -- no parent
+--         , _ldesc_block = Nothing -- no parent
+--         }
+--       , _layouter_func = \_params -> do
+--           layoutWritePriorCommentsRestore lbind
+--           moveToExactAnn lbind
+--           -- remaining <- getCurRemaining
+-- #if MIN_VERSION_ghc(8,0,0)
+--           matches `forM_` \(L _ match@(Match _
+--                                              pats
+--                                              mType
+--                                              (GRHSs grhss (L _ whereBinds)))) -> do
+--             let isInfix = isInfixMatch match
+--             let mId     = fId
+-- #else
+--           matches `forM_` \(L _ (Match mIdInfix
+--                                        pats
+--                                        mType
+--                                        (GRHSs grhss whereBinds))) -> do
+--             let isInfix = maybe fInfix snd mIdInfix
+--             let mId     = maybe fId fst mIdInfix
+-- #endif
+--             idStr <- lrdrNameToTextAnn mId
+--             patLays <- pats `forM` \p -> layouterFToLayouterM $ layoutPat p
+--             case patLays of
+--               (p1:pr) | isInfix -> do
+--                 applyLayouter p1 defaultParams
+--                 layoutWriteAppend $ (Text.pack " ") <> idStr
+--                 pr `forM_` \p -> do
+--                   layoutWriteAppend $ Text.pack " "
+--                   applyLayouter p defaultParams
+--               ps                -> do
+--                 layoutWriteAppend $ idStr
+--                 ps `forM_` \p -> do
+--                   layoutWriteAppend $ Text.pack " "
+--                   applyLayouter p defaultParams
+--             case mType of
+--               Nothing -> return ()
+--               Just t  -> do
+--                 tLay <- layouterFToLayouterM $ layoutType t
+--                 layoutWriteAppend $ Text.pack " :: "
+--                 applyLayouter tLay defaultParams
+--             grhss `forM_` \case
+--               L _ (GRHS [] body) -> do
+--                 layoutWriteAppend $ Text.pack " = "
+--                 l <- layouterFToLayouterM $ layoutExpr body
+--                 layoutWithAddIndent $ do
+--                   applyLayouter l defaultParams
+--               grhs -> do
+--                 l <- layoutByExact grhs
+--                 applyLayouter l defaultParams
+--             case whereBinds of
+--               HsValBinds valBinds -> undefined valBinds -- TODO
+--               HsIPBinds ipBinds   -> undefined ipBinds -- TODO
+--               EmptyLocalBinds     -> return ()
+--           layoutWritePostCommentsRestore lbind
+--       , _layouter_ast = lbind
+--       }
+--   _ -> layoutByExact lbind

src/Language/Haskell/Brittany/Layouters/Expr.hs

@@ -0,0 +1,659 @@
+{-# LANGUAGE DataKinds #-}
+
+module Language.Haskell.Brittany.Layouters.Expr
+  ( layoutExpr
+  , litBriDoc
+  , isExpressionTypeHeadPar
+  , isExpressionTypeHeadPar'
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import           Language.Haskell.Brittany.Types
+import           Language.Haskell.Brittany.LayoutBasics
+
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import           SrcLoc ( SrcSpan )
+import           HsSyn
+import           Name
+import qualified FastString
+import           BasicTypes
+
+import           Language.Haskell.Brittany.Layouters.Pattern
+import           Language.Haskell.Brittany.Layouters.Decl
+import           Language.Haskell.Brittany.Layouters.Stmt
+
+
+
+layoutExpr :: ToBriDoc HsExpr
+layoutExpr lexpr@(L _ expr) = docWrapNode lexpr $ case expr of
+  HsVar vname -> do
+    docLit =<< lrdrNameToTextAnn vname
+  HsUnboundVar var -> case var of
+    OutOfScope oname _ -> docLit $ Text.pack $ occNameString oname
+    TrueExprHole oname -> docLit $ Text.pack $ occNameString oname
+  HsRecFld{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsOverLabel{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsIPVar{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsOverLit (OverLit olit _ _ _) -> do
+    allocateNode $ overLitValBriDoc olit
+  HsLit lit -> do
+    allocateNode $ litBriDoc lit
+  HsLam (MG (L _ [lmatch@(L _ (Match _ pats _ (GRHSs [lgrhs@(L _ (GRHS [] body))] (L _ EmptyLocalBinds))))]) _ _ _) -> do
+    patDocs <- pats `forM` docSharedWrapper layoutPat
+    bodyDoc <- docAddBaseY BrIndentRegular <$> docSharedWrapper layoutExpr body
+    let funcPatternPartLine =
+          docCols ColCasePattern
+            $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))
+    docAlt
+      [ docSeq
+        [ docLit $ Text.pack "\\"
+        , docWrapNode lmatch $ funcPatternPartLine
+        , appSep $ docLit $ Text.pack "->"
+        , docWrapNode lgrhs $ bodyDoc
+        ]
+      -- TODO
+      ]
+  HsLam{} ->
+    unknownNodeError "HsLam too complex" lexpr
+  HsLamCase _ (MG lmatches@(L _ matches) _ _ _) -> do
+    -- funcPatDocs <- matches `forM` \(L _ (Match _
+    --                                     pats
+    --                                     _mType -- not an actual type sig
+    --                                     (GRHSs grhss whereBinds))) -> do
+    --   patDocs <- pats `forM` docSharedWrapper layoutPat
+    --   let funcPatternPartLine = case patDocs of
+    --         ps -> docCols ColFuncPatternsPrefix
+    --           $ (ps <&> (\p -> docSeq [docForceSingleline p, docSeparator]))
+    --   grhssDocsNoInd :: ToBriDocM BriDocNumbered <- do
+    --     case grhss of
+    --       [grhs1] -> docSharedWrapper (layoutGrhsLCase (Just funcPatternPartLine)) grhs1
+    --       (grhs1:grhsr) -> do
+    --         grhsDoc1 <- docSharedWrapper (layoutGrhsLCase (Just funcPatternPartLine)) grhs1
+    --         grhsDocr <- docSharedWrapper (layoutGrhsLCase Nothing) `mapM` grhsr
+    --         return $ docLines $ grhsDoc1 : grhsDocr
+    --       [] -> error "layoutBind grhssDocsNoInd"
+    --   let grhssDocs = docAlt [grhssDocsNoInd {-, grhssDocsInd TODO-}]
+    --   layoutLocalBinds whereBinds >>= \case
+    --     Nothing -> grhssDocs
+    --     Just whereDocs -> docAddBaseY BrIndentRegular
+    --                     $ docPar grhssDocs 
+    --                     $ docAddBaseY BrIndentRegular
+    --                     $ docPar (docLit $ Text.pack "where")
+    --                     $ docSetIndentLevel $ docLines $ return <$> whereDocs
+    binderDoc <- docLit $ Text.pack "->"
+    funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches
+    docAddBaseY BrIndentRegular $ docPar
+      (docLit $ Text.pack "\\case")
+      (docLines $ return <$> funcPatDocs)
+  HsApp exp1@(L _ HsApp{}) exp2 -> do
+    let gather :: [LHsExpr RdrName] -> LHsExpr RdrName -> (LHsExpr RdrName, [LHsExpr RdrName])
+        gather list = \case
+          (L _ (HsApp l r)) -> gather (r:list) l
+          x -> (x, list)
+    let (headE, paramEs) = gather [exp2] exp1
+    headDoc <- docSharedWrapper layoutExpr headE
+    paramDocs <- docSharedWrapper layoutExpr `mapM` paramEs
+    docAlt
+      [ docCols ColApp
+      $ appSep (docForceSingleline headDoc)
+      : spacifyDocs (docForceSingleline <$> paramDocs)
+      , docSeq
+        [ appSep (docForceSingleline headDoc)
+        , docSetBaseY
+        $ docAddBaseY BrIndentRegular
+        $ docLines
+        $ paramDocs
+        ]
+      , 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
+      [ docSeq [appSep $ docForceSingleline expDoc1, docForceSingleline expDoc2]
+      , docAddBaseY BrIndentRegular
+      $ docPar
+        expDoc1
+        expDoc2
+      ]
+  HsAppType{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsAppTypeOut{} -> do
+    -- TODO
+    briDocByExact lexpr
+  OpApp expLeft@(L _ OpApp{}) expOp _ expRight -> do
+    let gather :: [(LHsExpr RdrName, LHsExpr RdrName)] -> LHsExpr RdrName -> (LHsExpr RdrName, [(LHsExpr RdrName, LHsExpr RdrName)])
+        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
+    docAlt
+      [ docSeq
+        [ appSep $ docForceSingleline leftOperandDoc
+        , docSeq
+        $ (appListDocs <&> \(od, ed) -> docSeq
+            [ appSep $ docForceSingleline od
+            , appSep $ docForceSingleline ed
+            ]
+          )
+        , appSep $ docForceSingleline opLastDoc
+        , docForceSingleline expLastDoc
+        ]
+      , docAddBaseY BrIndentRegular
+      $ docPar
+          (docSetBaseY leftOperandDoc)
+          ( docLines
+          $ (appListDocs <&> \(od, ed) -> docCols ColOpPrefix [appSep od, docSetBaseY ed])
+            ++ [docCols ColOpPrefix [appSep opLastDoc, docSetBaseY expLastDoc]]
+          )
+      -- TODO: singleline
+      -- TODO: wrapping on spine nodes
+      ]
+  OpApp expLeft expOp _ expRight -> do
+    expDocLeft  <- docSharedWrapper layoutExpr expLeft
+    expDocOp    <- docSharedWrapper layoutExpr expOp
+    expDocRight <- docSharedWrapper layoutExpr expRight
+    docAlt
+      $   [ docSeq
+            [ appSep $ docForceSingleline expDocLeft
+            , appSep $ docForceSingleline expDocOp
+            , docForceSingleline expDocRight
+            ]
+          ]
+      ++  [ docSeq
+            [ appSep $ docForceSingleline expDocLeft
+            , appSep $ docForceSingleline expDocOp
+            , docForceMultiline expDocRight
+            ]
+          | isExpressionTypeHeadPar expRight
+          ]
+      ++  [ docSeq
+            [ appSep $ docForceSingleline expDocLeft
+            , appSep $ docForceSingleline expDocOp
+            , docSetBaseY $ docAddBaseY BrIndentRegular expDocRight
+            ]
+          , docAddBaseY BrIndentRegular
+          $ docPar
+              expDocLeft
+              -- TODO: turn this into docCols?
+              (docCols ColOpPrefix [appSep $ expDocOp, expDocRight])
+          ]
+  NegApp{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsPar innerExp -> do
+    innerExpDoc <- docSharedWrapper layoutExpr innerExp
+    docAlt
+      [ docSeq
+        [ docLit $ Text.pack "("
+        , docForceSingleline innerExpDoc
+        , docLit $ Text.pack ")"
+        ]
+      -- TODO
+      ]
+  SectionL left op -> do -- TODO: add to testsuite
+    leftDoc <- docSharedWrapper layoutExpr left
+    opDoc   <- docSharedWrapper layoutExpr op
+    docSeq [leftDoc, opDoc]
+  SectionR op right -> do -- TODO: add to testsuite
+    opDoc    <- docSharedWrapper layoutExpr op
+    rightDoc <- docSharedWrapper layoutExpr right
+    docSeq [opDoc, rightDoc]
+  ExplicitTuple args boxity
+    | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do
+    argDocs <- docSharedWrapper layoutExpr `mapM` argExprs
+    case boxity of
+      Boxed -> docAlt
+        [ docSeq
+        $  [ docLit $ Text.pack "(" ]
+        ++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
+        ++ [ docLit $ Text.pack ")"]
+        -- TODO
+        ]
+      Unboxed -> docAlt
+        [ docSeq
+        $  [ docLit $ Text.pack "(#" ]
+        ++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
+        ++ [ docLit $ Text.pack "#)"]
+        -- TODO
+        ]
+  ExplicitTuple{} ->
+    unknownNodeError "ExplicitTuple|.." lexpr 
+  HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do
+    cExpDoc <- docSharedWrapper layoutExpr cExp
+    -- funcPatDocs <- matches `forM` \(L _ (Match _
+    --                                     pats
+    --                                     _mType -- not an actual type sig
+    --                                     (GRHSs grhss whereBinds))) -> do
+    --   patDocs <- pats `forM` docSharedWrapper layoutPat
+    --   let funcPatternPartLine =
+    --         docCols ColCasePattern
+    --           $ (patDocs <&> (\p -> docSeq [docForceSingleline p, docSeparator]))
+    --   grhssDocsNoInd <- do
+    --     case grhss of
+    --       [grhs1] -> docSharedWrapper (layoutGrhsCase (Just funcPatternPartLine)) grhs1
+    --       (grhs1:grhsr) -> do
+    --         grhsDoc1 <- docSharedWrapper (layoutGrhsCase (Just funcPatternPartLine)) grhs1
+    --         grhsDocr <- docSharedWrapper (layoutGrhsCase Nothing) `mapM` grhsr
+    --         return $ docLines $ grhsDoc1 : grhsDocr
+    --       [] -> error "layoutBind grhssDocsNoInd"
+    --   let grhssDocs = docAlt [grhssDocsNoInd {-, grhssDocsInd TODO-}]
+    --   layoutLocalBinds whereBinds >>= \case
+    --     Nothing -> grhssDocs
+    --     Just lhsBindsLRDoc -> docAddBaseY BrIndentRegular
+    --              $ docPar grhssDocs 
+    --              $ docAddBaseY BrIndentRegular
+    --              $ docPar (docLit $ Text.pack "where")
+    --              $ docSetIndentLevel $ docLines $ return <$> lhsBindsLRDoc
+    binderDoc <- docLit $ Text.pack "->"
+    funcPatDocs <- docWrapNode lmatches $ layoutPatternBind Nothing binderDoc `mapM` matches
+    docAlt
+      [ docAddBaseY BrIndentRegular
+      $ docPar
+        ( docSeq
+          [ appSep $ docLit $ Text.pack "case"
+          , appSep $ docForceSingleline cExpDoc
+          , docLit $ Text.pack "of"
+          ])
+        (docSetIndentLevel $ docNonBottomSpacing $ docLines $ return <$> funcPatDocs)
+      , docPar
+          ( docAddBaseY BrIndentRegular
+          $ docPar (docLit $ Text.pack "case") cExpDoc
+          )
+          ( docAddBaseY BrIndentRegular
+          $ docPar (docLit $ Text.pack "of")
+            (docSetIndentLevel $ docLines $ return <$> funcPatDocs)
+          )
+      ]
+  HsIf _ ifExpr thenExpr elseExpr -> do
+    ifExprDoc   <- docSharedWrapper layoutExpr ifExpr
+    thenExprDoc <- docSharedWrapper layoutExpr thenExpr
+    elseExprDoc <- docSharedWrapper layoutExpr elseExpr
+    let thenMod = if isExpressionTypeHeadPar thenExpr
+          then id
+          else docForceSingleline
+        elseMod = if isExpressionTypeHeadPar elseExpr
+          then id
+          else docForceSingleline
+    docAlt
+      [ docSeq
+        [ appSep $ docLit $ Text.pack "if"
+        , appSep $ docForceSingleline ifExprDoc
+        , appSep $ docLit $ Text.pack "then"
+        , appSep $ docForceSingleline thenExprDoc
+        , appSep $ docLit $ Text.pack "else"
+        , docForceSingleline elseExprDoc
+        ]
+      , docAddBaseY BrIndentRegular
+      $ docPar
+          ( docAddBaseY (BrIndentSpecial 3)
+          $ docSeq [appSep $ docLit $ Text.pack "if", ifExprDoc])
+          (docLines
+            [ docAddBaseY BrIndentRegular
+            $ docAlt
+              [ docSeq [appSep $ docLit $ Text.pack "then", thenMod thenExprDoc]
+              , docAddBaseY BrIndentRegular
+              $ docPar (docLit $ Text.pack "then") thenExprDoc
+              ]
+            , docAddBaseY BrIndentRegular
+            $ docAlt
+              [ docSeq [appSep $ docLit $ Text.pack "else", elseMod elseExprDoc]
+              , docAddBaseY BrIndentRegular
+              $ docPar (docLit $ Text.pack "else") elseExprDoc
+              ]
+            ])
+      , docLines
+        [ docAddBaseY (BrIndentSpecial 3)
+        $ docSeq [appSep $ docLit $ Text.pack "if", ifExprDoc]
+        , 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 " ->"
+    docAddBaseY BrIndentRegular $ docPar
+      (docLit $ Text.pack "if")
+      (layoutPatternBindFinal binderDoc Nothing clauseDocs Nothing)
+  HsLet{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsDo DoExpr (L _ stmts) _ -> do
+    stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
+    docAddBaseY BrIndentRegular
+           $ docPar
+               (docLit $ Text.pack "do")
+               (docSetIndentLevel $ docNonBottomSpacing $ docLines stmtDocs)
+  HsDo x  (L _ stmts) _ | case x of { ListComp -> True
+                                    ; MonadComp -> True
+                                    ; _ -> False } -> do
+    stmtDocs <- docSharedWrapper layoutStmt `mapM` stmts
+    docAlt
+      [ docSeq
+        [ appSep $ docLit $ Text.pack "["
+        , appSep $ docForceSingleline $ List.last stmtDocs
+        , appSep $ docLit $ Text.pack "|"
+        , docSeq $ List.intersperse docCommaSep
+                $ fmap docForceSingleline $ List.init stmtDocs
+        , docLit $ Text.pack "]"
+        ]
+      , let
+          start = docCols ColListComp
+                    [appSep $ docLit $ Text.pack "[", 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]
+      ]
+  HsDo{} -> do
+    -- TODO
+    briDocByExact lexpr
+  ExplicitList _ _ elems@(_:_) -> do
+    elemDocs <- elems `forM` docSharedWrapper layoutExpr
+    docAlt
+      [ docSeq
+      $  [docLit $ Text.pack "["]
+      ++ List.intersperse docCommaSep (docForceSingleline <$> elemDocs)
+      ++ [docLit $ Text.pack "]"]
+      , let
+          start = docCols ColList
+                    [appSep $ docLit $ Text.pack "[", List.head elemDocs]
+          lines = List.tail elemDocs <&> \d ->
+                  docCols ColList [docCommaSep, d]
+          end   = docLit $ Text.pack "]"
+        in docSetBaseY $ docLines $ [start] ++ lines ++ [end]
+      ]
+  ExplicitList _ _ [] ->
+    docLit $ Text.pack "[]"
+  ExplicitPArr{} -> do
+    -- TODO
+    briDocByExact lexpr
+  RecordCon lname _ _ (HsRecFields [] Nothing) -> do
+    let t = lrdrNameToText lname
+    docLit $ t <> Text.pack "{}"
+  RecordCon lname _ _ (HsRecFields fs@(_:_) Nothing) -> do
+    let t = lrdrNameToText lname
+    (fd1:fdr) <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fExpr _)) -> do
+      fExpDoc <- docSharedWrapper layoutExpr fExpr
+      return $ (lrdrNameToText lnameF, fExpDoc)
+    docAlt
+      [ docAddBaseY BrIndentRegular
+      $ docPar
+          (docLit t)
+          (docLines $ let
+            line1 = docCols ColRecUpdate
+              [ appSep $ docLit $ Text.pack "{"
+              , appSep $ docLit $ fst fd1
+              , docSeq [ appSep $ docLit $ Text.pack "="
+                      , docAddBaseY BrIndentRegular $ snd fd1
+                      ]
+              ]
+            lineR = fdr <&> \(fText, fDoc) -> docCols ColRecUpdate
+              [ appSep $ docLit $ Text.pack ","
+              , appSep $ docLit $ fText
+              , docSeq [ appSep $ docLit $ Text.pack "="
+                      , docAddBaseY BrIndentRegular fDoc
+                      ]
+              ]
+            lineN = docLit $ Text.pack "}"
+            in [line1] ++ lineR ++ [lineN])
+      -- TODO oneliner (?)
+      ]
+  RecordCon{} ->
+    unknownNodeError "RecordCon with puns" lexpr
+  RecordUpd rExpr [] _ _ _ _ -> do
+    rExprDoc <- docSharedWrapper layoutExpr rExpr
+    docSeq [rExprDoc, docLit $ Text.pack "{}"]
+  RecordUpd rExpr fields@(_:_) _ _ _ _ -> do
+    rExprDoc <- docSharedWrapper layoutExpr rExpr
+    rFs@(rF1:rFr) <- fields `forM` \(L _ (HsRecField (L _ ambName) rFExpr _)) -> do
+      rFExpDoc <- docSharedWrapper layoutExpr rFExpr
+      return $ case ambName of
+        Unambiguous n _ -> (lrdrNameToText n, rFExpDoc)
+        Ambiguous   n _ -> (lrdrNameToText n, rFExpDoc)
+    docAlt
+      -- singleline
+      [ docSeq
+        [ appSep rExprDoc
+        , appSep $ docLit $ Text.pack "{"
+        , appSep $ docSeq $ List.intersperse docCommaSep
+                $ rFs <&> \(fieldStr, fieldDoc) ->
+                    docSeq [ appSep $ docLit fieldStr
+                          , appSep $ docLit $ Text.pack "="
+                          , docForceSingleline fieldDoc
+                          ]
+        , docLit $ Text.pack "}"
+        ]
+      -- wild-indentation block
+      , docSeq
+        [ appSep rExprDoc
+        , docSetBaseY $ docLines $ let
+            line1 = docCols ColRecUpdate
+              [ appSep $ docLit $ Text.pack "{"
+              , appSep $ docLit $ fst rF1
+              , docSeq [ appSep $ docLit $ Text.pack "="
+                      , docForceSingleline $ snd rF1
+                      ]
+              ]
+            lineR = rFr <&> \(fText, fDoc) -> docCols ColRecUpdate
+              [ appSep $ docLit $ Text.pack ","
+              , appSep $ docLit $ fText
+              , docSeq [ appSep $ docLit $ Text.pack "="
+                      , docForceSingleline fDoc
+                      ]
+              ]
+            lineN = docLit $ Text.pack "}"
+            in [line1] ++ lineR ++ [lineN]
+        ]
+      -- strict indentation block
+      , docAddBaseY BrIndentRegular
+      $ docPar
+          rExprDoc
+          (docLines $ let
+            line1 = docCols ColRecUpdate
+              [ appSep $ docLit $ Text.pack "{"
+              , appSep $ docLit $ fst rF1
+              , docSeq [ appSep $ docLit $ Text.pack "="
+                      , docAddBaseY BrIndentRegular $ snd rF1
+                      ]
+              ]
+            lineR = rFr <&> \(fText, fDoc) -> docCols ColRecUpdate
+              [ appSep $ docLit $ Text.pack ","
+              , appSep $ docLit $ fText
+              , docSeq [ appSep $ docLit $ Text.pack "="
+                      , docAddBaseY BrIndentRegular fDoc
+                      ]
+              ]
+            lineN = docLit $ Text.pack "}"
+            in [line1] ++ lineR ++ [lineN])
+      ]
+  ExprWithTySig{} -> do
+    -- TODO
+    briDocByExact lexpr
+  ExprWithTySigOut{} -> do
+    -- TODO
+    briDocByExact lexpr
+  ArithSeq _ Nothing info ->
+    case info of
+      From e1 -> do
+        e1Doc <- docSharedWrapper layoutExpr e1
+        docSeq
+          [ docLit $ Text.pack "["
+          , docForceSingleline e1Doc
+          , docLit $ Text.pack "..]"
+          ]
+      FromThen e1 e2 -> do
+        e1Doc <- docSharedWrapper layoutExpr e1
+        e2Doc <- docSharedWrapper layoutExpr e2
+        docSeq
+          [ docLit $ Text.pack "["
+          , docForceSingleline e1Doc
+          , docLit $ Text.pack ","
+          , docForceSingleline e2Doc
+          , docLit $ Text.pack "..]"
+          ]
+      FromTo e1 eN -> do
+        e1Doc <- docSharedWrapper layoutExpr e1
+        eNDoc <- docSharedWrapper layoutExpr eN
+        docSeq
+          [ docLit $ Text.pack "["
+          , docForceSingleline e1Doc
+          , 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
+          , docLit $ Text.pack ","
+          , docForceSingleline e2Doc
+          , docLit $ Text.pack ".."
+          , docForceSingleline eNDoc
+          , docLit $ Text.pack "]"
+          ]
+  ArithSeq{} ->
+    unknownNodeError "ArithSeq" lexpr
+  PArrSeq{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsSCC{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsCoreAnn{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsBracket{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsRnBracketOut{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsTcBracketOut{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsSpliceE{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsProc{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsStatic{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsArrApp{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsArrForm{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsTick{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsBinTick{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsTickPragma{} -> do
+    -- TODO
+    briDocByExact lexpr
+  EWildPat{} -> do
+    -- TODO
+    briDocByExact lexpr
+  EAsPat{} -> do
+    -- TODO
+    briDocByExact lexpr
+  EViewPat{} -> do
+    -- TODO
+    briDocByExact lexpr
+  ELazyPat{} -> do
+    -- TODO
+    briDocByExact lexpr
+  HsWrap{} -> do
+    -- TODO
+    briDocByExact lexpr
+
+isExpressionTypeHeadPar :: LHsExpr RdrName -> Bool
+isExpressionTypeHeadPar (L _ expr) = case expr of
+  RecordCon{} -> True
+  RecordUpd{} -> True
+  HsDo{} -> True
+  HsIf{} -> True
+  HsCase{} -> True
+  HsLamCase{} -> True
+  -- TODO: these cases might have unfortunate layouts, if for some reason
+  -- the first operand is multiline.
+  OpApp _ _ _ (L _ HsDo{}) -> True
+  OpApp _ _ _ (L _ HsLamCase{}) -> True
+  _ -> False
+
+isExpressionTypeHeadPar' :: LHsExpr RdrName -> Bool
+isExpressionTypeHeadPar' (L _ expr) = case expr of
+  RecordCon{} -> True
+  RecordUpd{} -> True
+  HsDo{} -> True
+  HsIf{} -> True
+  HsCase{} -> True
+  HsLamCase{} -> True
+  -- TODO: these cases might have unfortunate layouts, if for some reason
+  -- the first operand is multiline.
+  OpApp _ _ _ (L _ HsDo{}) -> True
+  OpApp _ _ _ (L _ HsLamCase{}) -> True
+  HsApp (L _ HsVar{}) _ -> True
+  HsApp (L _ (HsApp (L _ HsVar{}) _)) _ -> True
+  HsApp (L _ (HsApp (L _ (HsApp (L _ HsVar{}) _)) _)) _ -> True -- TODO: the obvious
+  _ -> False
+
+litBriDoc :: HsLit -> BriDocFInt
+litBriDoc = \case
+  HsChar       t _c           -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
+  HsCharPrim   t _c           -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ ['\'', c, '\'']
+  HsString     t _fastString  -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ FastString.unpackFS fastString
+  HsStringPrim t _byteString  -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ Data.ByteString.Char8.unpack byteString
+  HsInt        t _i           -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+  HsIntPrim    t _i           -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+  HsWordPrim   t _i           -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+  HsInt64Prim  t _i           -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+  HsWord64Prim t _i           -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+  HsInteger    t _i _type     -> BDFLit $ Text.pack t -- BDFLit $ Text.pack $ show i
+  HsRat        (FL t _) _type -> BDFLit $ Text.pack t
+  HsFloatPrim  (FL t _)       -> BDFLit $ Text.pack t
+  HsDoublePrim (FL t _)       -> BDFLit $ Text.pack t
+
+overLitValBriDoc :: OverLitVal -> BriDocFInt
+overLitValBriDoc = \case
+  HsIntegral t _        -> BDFLit $ Text.pack t
+  HsFractional (FL t _) -> BDFLit $ Text.pack t
+  HsIsString t _        -> BDFLit $ Text.pack t

src/Language/Haskell/Brittany/Layouters/Expr.hs-boot

@@ -0,0 +1,33 @@
+{-# LANGUAGE DataKinds #-}
+
+module Language.Haskell.Brittany.Layouters.Expr
+  ( layoutExpr
+  , litBriDoc
+  , isExpressionTypeHeadPar
+  , isExpressionTypeHeadPar'
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import           Language.Haskell.Brittany.Types
+import           Language.Haskell.Brittany.LayoutBasics
+
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import           SrcLoc ( SrcSpan )
+import           HsSyn
+import           Name
+
+
+
+layoutExpr :: ToBriDoc HsExpr
+
+-- layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))
+
+litBriDoc :: HsLit -> BriDocFInt
+
+isExpressionTypeHeadPar :: LHsExpr RdrName -> Bool
+isExpressionTypeHeadPar' :: LHsExpr RdrName -> Bool

src/Language/Haskell/Brittany/Layouters/Pattern.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE DataKinds #-}
+
+module Language.Haskell.Brittany.Layouters.Pattern
+  ( layoutPat
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import           Language.Haskell.Brittany.Types
+import           Language.Haskell.Brittany.LayoutBasics
+
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import           SrcLoc ( SrcSpan )
+import           HsSyn
+import           Name
+import           BasicTypes
+
+import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr
+import           Language.Haskell.Brittany.Layouters.Type
+
+
+
+layoutPat :: ToBriDoc Pat
+layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
+  WildPat _  -> docLit $ Text.pack "_"
+  VarPat n   -> docLit $ lrdrNameToText n
+  LitPat lit -> allocateNode $ litBriDoc lit
+  ParPat inner -> do
+    innerDoc <- docSharedWrapper layoutPat inner
+    docSeq
+      [ docLit $ Text.pack "("
+      , innerDoc
+      , docLit $ Text.pack ")"
+      ]
+  ConPatIn lname (PrefixCon args) -> do
+    let nameDoc = lrdrNameToText lname
+    argDocs <- docSharedWrapper layoutPat `mapM` args
+    if null argDocs
+      then docLit nameDoc
+      else docSeq
+             $ appSep (docLit nameDoc) : spacifyDocs argDocs
+  ConPatIn lname (InfixCon left right) -> do
+    let nameDoc = lrdrNameToText lname
+    leftDoc  <- docSharedWrapper layoutPat left
+    rightDoc <- docSharedWrapper layoutPat right
+    docSeq [leftDoc, docLit nameDoc, rightDoc]
+  ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do
+    let t = lrdrNameToText lname
+    docLit $ t <> Text.pack "{}"
+  ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do
+    let t = lrdrNameToText lname
+    fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat _)) -> do
+      fExpDoc <- docSharedWrapper layoutPat fPat
+      return $ (lrdrNameToText lnameF, fExpDoc)
+    docSeq
+      [ appSep $ docLit t
+      , appSep $ docLit $ Text.pack "{"
+      , docSeq $ List.intersperse docCommaSep
+               $ fds <&> \(fieldName, fieldDoc) -> docSeq
+          [ appSep $ docLit $ fieldName
+          , appSep $ docLit $ Text.pack "="
+          , fieldDoc
+          ]
+      , docLit $ Text.pack "}"
+      ]
+  TuplePat args boxity _ -> do
+    argDocs <- docSharedWrapper layoutPat `mapM` args
+    case boxity of
+      Boxed -> docAlt
+        [ docSeq
+        $  [ docLit $ Text.pack "(" ]
+        ++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
+        ++ [ docLit $ Text.pack ")"]
+        -- TODO
+        ]
+      Unboxed -> docAlt
+        [ docSeq
+        $  [ docLit $ Text.pack "(#" ]
+        ++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
+        ++ [ docLit $ Text.pack "#)"]
+        -- TODO
+        ]
+  AsPat asName asPat -> do
+    patDoc <- docSharedWrapper layoutPat asPat
+    docSeq
+      [ docLit $ lrdrNameToText asName <> Text.pack "@"
+      , patDoc
+      ]
+  SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do
+    patDoc <- docSharedWrapper layoutPat pat1
+    tyDoc <- docSharedWrapper layoutType ty1
+    docSeq
+      [ appSep $ patDoc
+      , appSep $ docLit $ Text.pack "::"
+      , tyDoc
+      ]
+  ListPat elems _ _ -> do
+    elemDocs <- docSharedWrapper layoutPat `mapM` elems
+    docSeq
+      $  [docLit $ Text.pack "["]
+      ++ List.intersperse docCommaSep (elemDocs)
+      ++ [docLit $ Text.pack "]"]
+  BangPat pat1 -> do
+    patDoc <- docSharedWrapper layoutPat pat1
+    docSeq [docLit $ Text.pack "!", patDoc]
+
+-- #if MIN_VERSION_ghc(8,0,0)
+--   VarPat n -> return $ stringLayouter lpat $ lrdrNameToText n
+-- #else
+--   VarPat n -> return $ stringLayouter lpat $ rdrNameToText n
+-- #endif
+  _ -> briDocByExact lpat

src/Language/Haskell/Brittany/Layouters/Stmt.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE DataKinds #-}
+
+module Language.Haskell.Brittany.Layouters.Stmt
+  ( layoutStmt
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import           Language.Haskell.Brittany.Types
+import           Language.Haskell.Brittany.LayoutBasics
+
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import           SrcLoc ( SrcSpan )
+import           HsSyn
+import           Name
+import qualified FastString
+import           BasicTypes
+
+import           Language.Haskell.Brittany.Layouters.Pattern
+import           Language.Haskell.Brittany.Layouters.Decl
+import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr
+
+
+
+layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))
+layoutStmt lstmt@(L _ stmt) = docWrapNode lstmt $ case stmt of
+  LastStmt body False _ -> do
+    layoutExpr body
+  BindStmt lPat expr _ _ _ -> do
+    patDoc <- docSharedWrapper layoutPat lPat
+    expDoc <- docSharedWrapper layoutExpr expr
+    docCols ColBindStmt
+      [appSep patDoc, docSeq [appSep $ docLit $ Text.pack "<-", expDoc]]
+  LetStmt binds -> layoutLocalBinds binds >>= \case
+    Nothing ->
+      docLit $ Text.pack "let" -- i just tested
+                               -- it, and it is
+                               -- indeed allowed.
+                               -- heh.
+    Just [] ->
+      docLit $ Text.pack "let" -- this probably never happens
+    Just [bindDoc] -> docAlt
+      [ docCols ColDoLet
+        [ appSep $ docLit $ Text.pack "let"
+        , docSetBaseY $ docAddBaseY BrIndentRegular (return bindDoc)
+        ]
+      , docAddBaseY BrIndentRegular $ docPar
+        (docLit $ Text.pack "let")
+        (return bindDoc)
+      ]
+    Just bindDocs@(bindDoc1:bindDocr) -> do
+      docAlt
+        [ docLines
+        $ (docCols ColDoLet
+            [ appSep $ docLit $ Text.pack "let"
+            , docAddBaseY (BrIndentSpecial 6) (return bindDoc1)
+            ])
+        : (bindDocr <&> \bindDoc ->
+           docCols ColDoLet
+            [ appSep $ docEmpty
+            , docAddBaseY (BrIndentSpecial 6) (return bindDoc)
+            ])
+        , docAddBaseY BrIndentRegular
+        $ docPar
+          (docLit $ Text.pack "let")
+          (docLines $ return <$> bindDocs)
+        ]
+  BodyStmt expr _ _ _ -> do
+    expDoc <- docSharedWrapper layoutExpr expr
+    docAddBaseY BrIndentRegular $ expDoc
+  _ -> briDocByExact lstmt

src/Language/Haskell/Brittany/Layouters/Stmt.hs-boot

@@ -0,0 +1,25 @@
+{-# LANGUAGE DataKinds #-}
+
+module Language.Haskell.Brittany.Layouters.Stmt
+  ( layoutStmt
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import           Language.Haskell.Brittany.Types
+import           Language.Haskell.Brittany.LayoutBasics
+
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import           SrcLoc ( SrcSpan )
+import           HsSyn
+import           Name
+import qualified FastString
+import           BasicTypes
+
+
+
+layoutStmt :: ToBriDoc' (StmtLR RdrName RdrName (LHsExpr RdrName))

src/Language/Haskell/Brittany/Layouters/Type.hs

@@ -0,0 +1,648 @@
+{-# LANGUAGE DataKinds #-}
+
+module Language.Haskell.Brittany.Layouters.Type
+  ( layoutType
+  )
+where
+
+
+
+#include "prelude.inc"
+
+import           Language.Haskell.Brittany.Config.Types
+import           Language.Haskell.Brittany.Types
+import           Language.Haskell.Brittany.LayoutBasics
+
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import           Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
+import           SrcLoc ( SrcSpan )
+import           HsSyn
+import           Name
+import           Outputable ( ftext, showSDocUnsafe )
+
+import           DataTreePrint
+
+
+
+layoutType :: ToBriDoc HsType
+layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
+  -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
+  HsTyVar name -> do
+    let t = lrdrNameToText name
+    docLit t
+  HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts@(_:_)) typ2)) -> do
+    typeDoc <- docSharedWrapper layoutType typ2
+    tyVarDocs <- bndrs `forM` \case
+      (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)
+      (L _ (KindedTyVar lrdrName kind)) -> do
+        d <- docSharedWrapper layoutType kind
+        return $ (lrdrNameToText lrdrName, Just $ d)
+    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
+    let
+      tyVarDocLineList = tyVarDocs >>= \case
+        (tname, Nothing) -> [docLit $ Text.pack " " <> tname]
+        (tname, Just doc) -> [ docLit $ Text.pack " ("
+                                    <> tname
+                                    <> Text.pack " :: "
+                             , docForceSingleline $ doc
+                             , docLit $ Text.pack ")"
+                             ]
+      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
+        [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]++tyVarDocLineList++[close])
+        , docForceSingleline contextDoc
+        , docLit $ Text.pack " => "
+        , typeDoc
+        ]
+      -- :: forall a b c
+      --  . (Foo a b c)
+      -- => a b
+      -- -> c
+      , docPar
+          forallDoc
+          ( docLines
+            [ docCols ColTyOpPrefix
+              [ docPostComment ltype $ docLit $ Text.pack " . "
+              , docAddBaseY (BrIndentSpecial 3)
+              $ docForceSingleline contextDoc
+              ]
+            , docCols ColTyOpPrefix
+              [ docLit $ Text.pack "=> "
+              , docAddBaseY (BrIndentSpecial 3) $ docForceMultiline $ typeDoc
+              ]
+            ]
+          )
+      ]
+  HsForAllTy bndrs typ2 -> do
+    typeDoc <- layoutType typ2
+    tyVarDocs <- bndrs `forM` \case
+      (L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)
+      (L _ (KindedTyVar lrdrName kind)) -> do
+        d <- layoutType kind
+        return $ (lrdrNameToText lrdrName, Just $ return d)
+    let
+      tyVarDocLineList = tyVarDocs >>= \case
+        (tname, Nothing) -> [docLit $ Text.pack " " <> tname]
+        (tname, Just doc) -> [ docLit $ Text.pack " ("
+                                    <> tname
+                                    <> Text.pack " :: "
+                             , docForceSingleline doc
+                             , docLit $ Text.pack ")"
+                             ]
+    docAlt
+      [ docSeq
+        [ if null bndrs
+            then docEmpty
+            else let
+              open = docLit $ Text.pack "forall"
+              close = docLit $ Text.pack " . "
+              in docSeq ([open]++tyVarDocLineList++[close])
+        , return typeDoc
+        ]
+      , docPar
+          (docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
+          ( docCols ColTyOpPrefix
+            [ docPostComment ltype $ docLit $ Text.pack ". "
+            , return typeDoc
+            ]
+          )
+      , 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
+              [ docPostComment ltype $ docLit $ Text.pack ". "
+              , return typeDoc
+              ]
+            ]
+          )
+      ]
+  x@(HsQualTy (L _ []) _) ->
+    unknownNodeError "HsQualTy [] _" x
+  HsQualTy (L _ cntxts@(_:_)) typ1 -> do
+    typeDoc <- docSharedWrapper layoutType typ1
+    cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
+    let
+      contextDoc = case cntxtDocs of
+        [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
+      -- (Foo a b c) => a b -> c
+      [ docSeq
+        [ docForceSingleline contextDoc
+        , docLit $ Text.pack " => "
+        , typeDoc
+        ]
+      --    (Foo a b c)
+      -- => a b
+      -- -> c
+      , docPar
+          (docForceSingleline contextDoc)
+          ( docCols ColTyOpPrefix
+            [ docLit $ Text.pack "=> "
+            , docAddBaseY (BrIndentSpecial 3) $ docForceMultiline typeDoc
+            ]
+          )
+      ]
+  -- HsQualTy (L _ cntxts) typ2 -> do
+  --   layouter@(Layouter desc _ _) <- layoutType typ2
+  --   cntxtLayouters <- cntxts `forM` layoutType
+  --   let mLine =
+  --         [ LayoutColumns ColumnKeyUnique [len] len
+  --         | -- (A a, B b) =>
+  --           -- 1   2    6
+  --           constraintLen <- if null cntxts
+  --                 then return 0
+  --                 else ( sequence
+  --                      $ cntxtLayouters <&> _layouter_desc .> _ldesc_line)
+  --                  <&> \cols -> 5
+  --                             + 2 * length cols
+  --                             + sum (_lColumns_min <$> cols)
+  --         , tyLen <- _lColumns_min <$> _ldesc_line desc
+  --         , let len = constraintLen + tyLen
+  --         ]
+  --   let mBlock =
+  --         [ BlockDesc
+  --           { _bdesc_blockStart = AllSameIndent -- this might not be accurate,
+  --                                          -- but it should simply not matter.
+  --                                          -- *lazy*
+  --           , _bdesc_min = minR
+  --           , _bdesc_max = maxR
+  --           , _bdesc_opIndentFloatUp = Nothing
+  --           }
+  --         | (tyMin, tyMax) <- descToMinMax 0 desc
+  --         , constrMinMaxs <- sequence $ cntxtLayouters <&> _layouter_desc .> descToMinMax 0
+  --         , let constrMin = constrMinMaxs <&> fst & maximum
+  --         , let constrMax = constrMinMaxs <&> snd & maximum
+  --         , let minR = 3 + maximum [constrMin, tyMin]
+  --         , let maxR = 3 + maximum [constrMax, tyMax]
+  --         ]
+  --   return $ Layouter
+  --     { _layouter_desc = LayoutDesc
+  --       { _ldesc_line  = mLine
+  --       , _ldesc_block = mBlock
+  --       }
+  --     , _layouter_func = \params -> do
+  --         layoutWritePriorCommentsRestore ltype
+  --         remaining <- getCurRemaining
+  --         case mLine of
+  --           Just (LayoutColumns _ _ m) | m <= remaining -> do
+  --             when (not $ null cntxts) $ do
+  --               layoutWriteAppend $ Text.pack "("
+  --               sequence_ $ intersperse (layoutWriteAppend $ Text.pack ", ")
+  --                         $ cntxtLayouters <&> \lay -> applyLayouterRestore lay defaultParams
+  --               layoutWriteAppend $ Text.pack ") => "
+  --             applyLayouterRestore layouter defaultParams
+  --           _ -> do
+  --             if null cntxts
+  --               then do
+  --                 layoutWriteAppend $ Text.pack "()"
+  --               else do
+  --               layoutWithNonParamIndent params $ do
+  --                 layoutWriteAppend $ Text.pack "( "
+  --                 let iAct = do
+  --                       layoutWriteNewline
+  --                       layoutWriteAppend $ Text.pack ", "
+  --                 sequence_ $ intersperse iAct
+  --                           $ cntxtLayouters <&> \lay -> applyLayouter lay defaultParams
+  --                 layoutWriteNewline
+  --                 layoutWriteAppend $ Text.pack ")"
+  --               layoutWriteNewline
+  --               layoutWriteAppend $ Text.pack "=> "
+  --             applyLayouterRestore layouter defaultParams 
+  --               { _params_opIndent = _params_opIndent params
+  --               }
+  --     , _layouter_ast = ltype
+  --     }
+  HsFunTy typ1 typ2 -> do
+    typeDoc1 <- docSharedWrapper layoutType typ1
+    typeDoc2 <- docSharedWrapper layoutType typ2
+    let shouldForceML = case typ2 of
+          (L _ HsFunTy{}) -> True
+          _ -> False
+    docAlt
+      [ docSeq
+        [ docForceSingleline typeDoc1
+        , docPostComment ltype $ appSep $ docLit $ Text.pack " ->"
+        , docForceSingleline typeDoc2
+        ]
+      , docPar
+        typeDoc1
+        ( docCols ColTyOpPrefix
+          [ docPostComment ltype $ appSep $ docLit $ Text.pack "->"
+          , docAddBaseY (BrIndentSpecial 3)
+          $ if shouldForceML then docForceMultiline typeDoc2
+                             else typeDoc2
+          ]
+        )
+      ]
+  HsParTy typ1 -> do
+    typeDoc1 <- docSharedWrapper layoutType typ1
+    docAlt
+      [ docSeq
+        [ docPostComment ltype $ docLit $ Text.pack "("
+        , docForceSingleline typeDoc1
+        , docLit $ Text.pack ")"
+        ]
+      , docPar
+          ( docCols ColTyOpPrefix
+            [ docPostComment ltype $ docParenLSep
+            , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
+            ])
+          (docLit $ Text.pack ")")
+      ]
+  HsAppTy typ1 typ2 -> do
+    typeDoc1 <- docSharedWrapper layoutType typ1
+    typeDoc2 <- docSharedWrapper layoutType typ2
+    docAlt
+      [ docSeq
+        [ docForceSingleline typeDoc1
+        , docLit $ Text.pack " "
+        , docForceSingleline typeDoc2
+        ]
+      , docPar
+          typeDoc1
+          (docEnsureIndent BrIndentRegular typeDoc2)
+      ]
+  HsAppsTy [] -> error "HsAppsTy []"
+  HsAppsTy [L _ (HsAppPrefix typ1)] -> do
+    typeDoc1 <- docSharedWrapper layoutType typ1
+    typeDoc1
+  HsAppsTy [L l (HsAppInfix name)] -> do
+    -- this redirection is somewhat hacky, but whatever.
+    -- TODO: a general problem when doing deep inspections on
+    --       the type (and this is not the only instance)
+    --       is that we potentially omit annotations on some of
+    --       the middle constructors. i have no idea under which
+    --       circumstances exactly important annotations (comments)
+    --       would be assigned to such constructors.
+    typeDoc1 <- docSharedWrapper layoutType $ (L l $ HsTyVar name)
+    typeDoc1
+  HsAppsTy (L _ (HsAppPrefix typHead):typRestA)
+    | Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t
+                                  _ -> Nothing) typRestA -> do
+    docHead <- docSharedWrapper layoutType typHead
+    docRest <- docSharedWrapper layoutType `mapM` typRest
+    docAlt
+      [ docSeq
+      $ docForceSingleline docHead : (docRest >>= \d ->
+        [ docLit $ Text.pack " ", docForceSingleline d ])
+      , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
+      ]
+  HsAppsTy (typHead:typRest) -> do
+    docHead <- docSharedWrapper layoutAppType typHead
+    docRest <- docSharedWrapper layoutAppType `mapM` typRest
+    docAlt
+      [ docSeq
+      $ docForceSingleline docHead : (docRest >>= \d ->
+        [ docLit $ Text.pack " ", docForceSingleline d ])
+      , docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
+      ]
+    where
+      layoutAppType (L _ (HsAppPrefix t)) = layoutType t
+      layoutAppType (L _ (HsAppInfix t))  = docLit =<< lrdrNameToTextAnn t
+  HsListTy typ1 -> do
+    typeDoc1 <- docSharedWrapper layoutType typ1
+    docAlt
+      [ docSeq
+        [ docPostComment ltype $ docLit $ Text.pack "["
+        , docForceSingleline typeDoc1
+        , docLit $ Text.pack "]"
+        ]
+      , docPar
+          ( docCols ColTyOpPrefix
+            [ docPostComment ltype $ docLit $ Text.pack "[ "
+            , docAddBaseY (BrIndentSpecial 2) $ typeDoc1
+            ])
+          (docLit $ Text.pack "]")
+      ]
+  HsPArrTy typ1 -> do
+    typeDoc1 <- docSharedWrapper layoutType typ1
+    docAlt
+      [ docSeq
+        [ docPostComment ltype $ docLit $ Text.pack "[:"
+        , docForceSingleline typeDoc1
+        , docLit $ Text.pack ":]"
+        ]
+      , docPar
+          ( docCols ColTyOpPrefix
+            [ docPostComment 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 "unboxed unit?" else unboxedL
+    simple = if null typs then unitL else simpleL
+    unitL = docLit $ Text.pack "()"
+    simpleL = do
+      docs <- docSharedWrapper layoutType `mapM` typs
+      docAlt
+        [ docSeq $ [docLit $ Text.pack "("]
+               ++ List.intersperse docCommaSep docs
+               ++ [docLit $ Text.pack ")"]
+        , let
+            start = docCols ColTyOpPrefix [docParenLSep, head docs]
+            lines = List.tail docs <&> \d ->
+                    docCols ColTyOpPrefix [docCommaSep, d]
+            end   = docLit $ Text.pack ")"
+          in docPar
+            (docAddBaseY (BrIndentSpecial 2) $ start)
+            (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])
+        ]
+    unboxedL = do
+      docs <- docSharedWrapper layoutType `mapM` typs
+      docAlt
+        [ docSeq $ [docLit $ Text.pack "(#"]
+               ++ List.intersperse docCommaSep docs
+               ++ [docLit $ Text.pack "#)"]
+        , let
+            start = docCols ColTyOpPrefix [docLit $ Text.pack "(#", head docs]
+            lines = List.tail docs <&> \d ->
+                    docCols ColTyOpPrefix [docCommaSep, d]
+            end   = docLit $ Text.pack "#)"
+          in docPar
+            (docAddBaseY (BrIndentSpecial 2) start)
+            (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])
+        ]
+  HsOpTy{} -> -- TODO
+    briDocByExact 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 (HsIPName ipName) typ1 -> do
+    typeDoc1 <- docSharedWrapper layoutType typ1
+    docAlt
+      [ docSeq
+        [ docPostComment ltype
+        $ docLit
+        $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
+        , docForceSingleline typeDoc1
+        ]
+      , docPar
+          ( docLit
+          $ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))
+          )
+          (docCols ColTyOpPrefix
+            [ docPostComment ltype
+            $ docLit $ Text.pack "::"
+            , docAddBaseY (BrIndentSpecial 2) typeDoc1
+            ])
+      ]
+  HsEqTy typ1 typ2 -> do
+    typeDoc1 <- docSharedWrapper layoutType typ1
+    typeDoc2 <- docSharedWrapper layoutType typ2
+    docAlt
+      [ docSeq
+        [ docForceSingleline typeDoc1
+        , docPostComment ltype
+        $ docLit $ Text.pack " ~ "
+        , docForceSingleline typeDoc2
+        ]
+      , docPar
+          typeDoc1
+          ( docCols ColTyOpPrefix
+              [ docPostComment ltype
+              $ docLit $ Text.pack "~ "
+              , docAddBaseY (BrIndentSpecial 2) typeDoc2
+              ])
+      ]
+  -- TODO: test KindSig
+  HsKindSig typ1 kind1 -> do
+    typeDoc1 <- docSharedWrapper layoutType typ1
+    kindDoc1 <- docSharedWrapper layoutType kind1
+    docAlt
+      [ docSeq
+        [ docForceSingleline typeDoc1
+        , docLit $ Text.pack " :: "
+        , docForceSingleline kindDoc1
+        ]
+      , docPar
+          typeDoc1
+          ( docCols ColTyOpPrefix
+              [ docPostComment ltype
+              $ docLit $ Text.pack ":: "
+              , docAddBaseY (BrIndentSpecial 3) kindDoc1
+              ])
+      ]
+  HsBangTy{} -> -- TODO
+    briDocByExact 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
+    briDocByExact ltype
+  HsDocTy{} -> -- TODO
+    briDocByExact ltype
+  HsRecTy{} -> -- TODO
+    briDocByExact ltype
+  HsExplicitListTy _ typs -> do
+    typDocs <- docSharedWrapper layoutType `mapM` typs
+    docAlt
+      [ docSeq
+      $  [docLit $ Text.pack "'["]
+      ++ List.intersperse docCommaSep typDocs
+      ++ [docLit $ Text.pack "]"]
+      -- TODO
+      ]
+  HsExplicitTupleTy{} -> -- TODO
+    briDocByExact ltype
+  HsTyLit{} -> -- TODO
+    briDocByExact ltype
+  HsCoreTy{} -> -- TODO
+    briDocByExact ltype
+  HsWildCardTy{} -> -- TODO
+    briDocByExact ltype

src/Language/Haskell/Brittany/Prelude.hs

@@ -0,0 +1,67 @@
+module Language.Haskell.Brittany.Prelude
+where
+
+
+
+import Prelude
+import qualified Data.Strict.Maybe as Strict
+import Debug.Trace
+import Control.Monad
+import System.IO
+
+import Control.DeepSeq ( NFData, force )
+import Control.Exception.Base ( evaluate )
+
+import Control.Applicative
+
+
+
+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
+  return = Strict.Just
+  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
+
+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
+
+evaluateDeep :: NFData a => a -> IO a
+evaluateDeep = evaluate . force

src/Language/Haskell/Brittany/Types.hs

@@ -0,0 +1,349 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE BangPatterns #-}
+
+module Language.Haskell.Brittany.Types
+where
+
+
+
+#include "prelude.inc"
+
+import qualified Language.Haskell.GHC.ExactPrint as ExactPrint
+
+import qualified Data.Text.Lazy.Builder as Text.Builder
+
+import           RdrName ( RdrName(..) )
+import           GHC ( runGhc, GenLocated(L), moduleNameString )
+import           SrcLoc ( SrcSpan )
+
+import           Language.Haskell.GHC.ExactPrint ( AnnKey, Comment )
+import           Language.Haskell.GHC.ExactPrint.Types ( Anns, DeltaPos, mkAnnKey )
+
+import           Language.Haskell.Brittany.Config.Types
+
+import           Data.Generics.Uniplate.Direct as Uniplate
+
+
+
+type PPM a = MultiRWSS.MultiRWS '[Config, ExactPrint.Anns] '[Text.Builder.Builder, [LayoutError], Seq String] '[] a
+
+type PriorMap = Map AnnKey [(Comment, DeltaPos)]
+type PostMap  = Map AnnKey [(Comment, DeltaPos)]
+
+data LayoutState = LayoutState
+  { _lstate_baseY         :: Int -- ^ number of current indentation columns
+                                 -- (not number of indentations).
+  , _lstate_curY          :: Int -- ^ number of chars in the current line.
+  , _lstate_indLevel      :: Int -- ^ current indentation level. 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_commentsPrior :: PriorMap -- map of "true" pre-node comments that
+                                      -- really _should_ be included in the
+                                      -- output.
+  , _lstate_commentsPost  :: PostMap  -- similarly, for post-node comments.
+  , _lstate_commentCol    :: Maybe Int
+  , _lstate_addSepSpace   :: Maybe Int -- number of spaces to insert if anyone
+                                       -- writes (any non-spaces) in the
+                                       -- current line.
+  , _lstate_inhibitMTEL   :: Bool
+      -- ^ inhibit move-to-exact-location.
+      -- normally, processing a node's annotation involves moving to the exact
+      -- (vertical) location of the node. this ensures that newlines in the
+      -- input are retained in the output.
+      -- While this flag is on, this behaviour will be disabled.
+      -- The flag is automatically turned off when inserting any kind of
+      -- newline.
+  , _lstate_isNewline     :: NewLineState
+      -- captures if the layouter currently is in a new line, i.e. if the
+      -- current line only contains (indentation) spaces.
+  }
+
+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 LayoutError = LayoutErrorUnusedComment String
+                 | LayoutWarning String
+                 | forall ast . Data.Data.Data ast => LayoutErrorUnknownNode String ast
+
+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
+    -- 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
+  | ColBindStmt
+  | ColDoLet -- the non-indented variant
+  | ColRecUpdate
+  | ColListComp
+  | ColList
+  | ColApp
+  | ColOpPrefix -- merge with ColList ? other stuff?
+
+  -- TODO
+  deriving (Eq, Ord, Data.Data.Data, Show)
+
+data BrIndent = BrIndentNone
+              | BrIndentRegular
+              | BrIndentSpecial Int
+  deriving (Eq, Ord, Typeable, Data.Data.Data, Show)
+
+type ToBriDocM = MultiRWSS.MultiRWS '[Config, Anns] '[[LayoutError], Seq String] '[NodeAllocIndex]
+
+type ToBriDoc (sym :: * -> *) = GenLocated SrcSpan (sym RdrName) -> ToBriDocM BriDocNumbered
+type ToBriDoc' sym            = GenLocated SrcSpan sym           -> ToBriDocM BriDocNumbered
+type ToBriDocC sym c          = GenLocated SrcSpan sym           -> ToBriDocM c
+
+data DocMultiLine
+  = MultiLineNo
+  | MultiLinePossible
+  deriving (Eq, Typeable)
+
+-- 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
+  | BDSetBaseY BriDoc
+  | BDSetIndentLevel BriDoc
+  | BDPar
+    { _bdpar_indent :: BrIndent
+    , _bdpar_restOfLine :: BriDoc -- should not contain other BDPars
+    , _bdpar_indented :: BriDoc
+    }
+  -- | BDAddIndent BrIndent (BriDocF f)
+  -- | BDNewline
+  | BDAlt [BriDoc]
+  | BDForceMultiline BriDoc
+  | BDForceSingleline 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
+  | BDAnnotationPrior AnnKey BriDoc
+  | BDAnnotationPost  AnnKey BriDoc
+  | BDLines [BriDoc]
+  | BDEnsureIndent BrIndent BriDoc
+  | BDNonBottomSpacing BriDoc
+  | BDProhibitMTEL BriDoc -- move to exact location
+                          -- TODO: this constructor is deprecated. should
+                          --       still work, but i should probably completely
+                          --       remove it, as i have no proper usecase for
+                          --       it anymore.
+  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))
+  | BDFSetBaseY (f (BriDocF f))
+  | BDFSetIndentLevel (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)]
+  | BDFForceMultiline (f (BriDocF f))
+  | BDFForceSingleline (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
+  | BDFAnnotationPrior AnnKey (f (BriDocF f))
+  | BDFAnnotationPost  AnnKey (f (BriDocF f))
+  | BDFLines [(f (BriDocF f))]
+  | BDFEnsureIndent BrIndent (f (BriDocF f))
+  | BDFNonBottomSpacing (f (BriDocF f))
+  | BDFProhibitMTEL (f (BriDocF f)) -- move to exact location
+                          -- TODO: this constructor is deprecated. should
+                          --       still work, but i should probably completely
+                          --       remove it, as i have no proper usecase for
+                          --       it anymore.
+
+-- 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 (BDSetBaseY bd)               = plate BDSetBaseY |* bd
+  uniplate (BDSetIndentLevel bd)         = plate BDSetIndentLevel |* bd
+  uniplate (BDPar ind line indented)     = plate BDPar |- ind |* line |* indented
+  uniplate (BDAlt alts)                  = plate BDAlt ||* alts
+  uniplate (BDForceMultiline  bd)        = plate BDForceMultiline |* bd
+  uniplate (BDForceSingleline bd)        = plate BDForceSingleline |* bd
+  uniplate (BDForwardLineMode bd)        = plate BDForwardLineMode |* bd
+  uniplate x@BDExternal{}                = plate x
+  uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd
+  uniplate (BDAnnotationPost  annKey bd) = plate BDAnnotationPost  |- annKey |* bd
+  uniplate (BDLines lines)               = plate BDLines ||* lines
+  uniplate (BDEnsureIndent ind bd)       = plate BDEnsureIndent |- ind |* bd
+  uniplate (BDNonBottomSpacing bd)       = plate BDNonBottomSpacing |* bd
+  uniplate (BDProhibitMTEL bd)           = plate BDProhibitMTEL |* bd
+
+newtype NodeAllocIndex = NodeAllocIndex Int
+
+unwrapBriDocNumbered :: BriDocNumbered -> BriDoc
+unwrapBriDocNumbered = snd .> \case
+  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
+  BDFSetBaseY bd -> BDSetBaseY $ rec bd
+  BDFSetIndentLevel bd -> BDSetIndentLevel $ rec bd
+  BDFPar ind line indented -> BDPar ind (rec line) (rec indented)
+  BDFAlt alts -> BDAlt $ rec <$> alts -- not that this will happen
+  BDFForceMultiline  bd -> BDForceMultiline $ rec bd
+  BDFForceSingleline bd -> BDForceSingleline $ rec bd
+  BDFForwardLineMode bd -> BDForwardLineMode $ rec bd
+  BDFExternal k ks c t -> BDExternal k ks c t
+  BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
+  BDFAnnotationPost  annKey bd -> BDAnnotationPost  annKey $ rec bd
+  BDFLines lines -> BDLines $ rec <$> lines
+  BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
+  BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd
+  BDFProhibitMTEL bd -> BDProhibitMTEL $ rec bd
+ where
+  rec = unwrapBriDocNumbered
+
+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
+  BDSetBaseY bd     -> briDocSeqSpine bd
+  BDSetIndentLevel bd -> briDocSeqSpine bd
+  BDPar _ind line indented -> briDocSeqSpine line `seq` briDocSeqSpine indented
+  BDAlt alts -> foldl' (\(!()) -> briDocSeqSpine) () alts
+  BDForceMultiline  bd -> briDocSeqSpine bd
+  BDForceSingleline bd -> briDocSeqSpine bd
+  BDForwardLineMode bd -> briDocSeqSpine bd
+  BDExternal{} -> ()
+  BDAnnotationPrior _annKey bd -> briDocSeqSpine bd
+  BDAnnotationPost  _annKey bd -> briDocSeqSpine bd
+  BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines
+  BDEnsureIndent _ind bd -> briDocSeqSpine bd
+  BDNonBottomSpacing bd -> briDocSeqSpine bd
+  BDProhibitMTEL 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
+  | VerticalSpacingParNonBottom -- indented lines, with an unknown amount of
+                                -- space required. parents should consider this
+                                -- as a valid option, but provide as much space
+                                -- as possible.
+  deriving (Eq, Show)
+
+data VerticalSpacing
+  = VerticalSpacing
+    { _vs_sameLine  :: !Int
+    , _vs_paragraph :: !VerticalSpacingPar
+    }
+  deriving 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

src/Language/Haskell/Brittany/Utils.hs

@@ -0,0 +1,233 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Language.Haskell.Brittany.Utils
+  ( (.=+)
+  , (%=+)
+  , parDoc
+  , traceIfDumpConf
+  , mModify
+  , customLayouterF
+  , astToDoc
+  , briDocToDoc
+  -- , displayBriDocSimpleTree
+  , annsDoc
+  , Max (..)
+  , tellDebugMess
+  , tellDebugMessShow
+  , briDocToDocWithAnns
+  )
+where
+
+
+
+#include "prelude.inc"
+
+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.Utils as ExactPrint.Utils
+
+import           Data.Data
+import           Data.Generics.Schemes
+import           Data.Generics.Aliases
+
+import qualified Text.PrettyPrint as PP
+import           Text.PrettyPrint ( ($+$), (<+>) )
+
+import qualified Outputable    as GHC
+import qualified DynFlags      as GHC
+import qualified FastString    as GHC
+import qualified SrcLoc        as GHC
+import           OccName ( occNameString )
+import qualified Data.ByteString as B
+
+import           DataTreePrint
+
+import           Language.Haskell.Brittany.Config.Types
+import           Language.Haskell.Brittany.Types
+
+import qualified Control.Lens as Lens
+
+import qualified Data.Generics.Uniplate.Direct as Uniplate
+
+
+
+(.=+) :: MonadMultiState s m
+      => Lens.ASetter s s a b -> b -> m ()
+l .=+ b = mModify $ l Lens..~ b
+
+(%=+) :: MonadMultiState s m
+      => Lens.ASetter s s a b -> (a -> b) -> m ()
+l %=+ f = mModify (l Lens.%~ f)
+
+parDoc :: String -> PP.Doc
+parDoc = PP.fsep . fmap PP.text . List.words
+
+
+showSDoc_ :: GHC.SDoc -> String
+showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
+
+showGhc :: (GHC.Outputable a) => a -> String
+showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags
+
+-- 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) => Monoid (Max a) where
+  mempty  = Max 0
+  mappend = Data.Coerce.coerce (max :: a -> a -> a)
+
+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)++"}"
+               $ "{" ++ showGhc 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 Bool)
+                -> a
+                -> m ()
+traceIfDumpConf s accessor val = do
+  whenM (mAsk <&> _conf_debug .> accessor .> runIdentity) $ do
+    trace ("---- " ++ s ++ " ----\n" ++ show val) $ return ()
+
+tellDebugMess :: MonadMultiWriter
+  (Seq String) m => String -> m ()
+tellDebugMess s = mTell $ Seq.singleton s
+
+tellDebugMessShow :: (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
+    BDAnnotationPost  _ x -> x
+    x -> x
+
+briDocToDocWithAnns :: BriDoc -> PP.Doc
+briDocToDocWithAnns = astToDoc
+
+annsDoc :: ExactPrint.Types.Anns -> PP.Doc
+annsDoc = printTreeWithCustom 100 customLayouterNoAnnsF . fmap (ShowIsId . show)

srcinc/prelude.inc

@@ -0,0 +1,780 @@
+import qualified Data.ByteString
+import qualified Data.ByteString.Builder
+import qualified Data.ByteString.Builder.Extra
+import qualified Data.ByteString.Builder.Prim 
+import qualified Data.ByteString.Char8
+import qualified Data.ByteString.Lazy.Builder
+import qualified Data.ByteString.Lazy.Builder.ASCII
+import qualified Data.ByteString.Lazy.Builder.Extras
+import qualified Data.ByteString.Lazy.Char8
+import qualified Data.ByteString.Lazy
+import qualified Data.ByteString.Short
+import qualified Data.ByteString.Unsafe
+
+import qualified Data.Graph
+import qualified Data.IntMap
+import qualified Data.IntMap.Lazy
+import qualified Data.IntMap.Strict
+import qualified Data.IntSet
+import qualified Data.Map
+import qualified Data.Map.Lazy
+import qualified Data.Map.Strict
+import qualified Data.Sequence
+import qualified Data.Set
+import qualified Data.Tree
+
+import qualified System.Directory
+
+import qualified Control.Concurrent.Extra
+import qualified Control.Exception.Extra
+import qualified Control.Monad.Extra
+import qualified Data.Either.Extra
+import qualified Data.IORef.Extra
+import qualified Data.List.Extra
+import qualified Data.Tuple.Extra
+import qualified Data.Version.Extra
+import qualified Numeric.Extra
+import qualified System.Directory.Extra
+import qualified System.Environment.Extra
+import qualified System.IO.Extra
+import qualified System.Info.Extra
+import qualified System.Process.Extra
+import qualified System.Time.Extra
+
+-- import qualified Control.Exception.Lens
+import qualified Control.Lens
+-- import qualified Control.Lens.At
+-- import qualified Control.Lens.Combinators
+-- import qualified Control.Lens.Cons
+-- import qualified Control.Lens.Each
+-- import qualified Control.Lens.Empty
+-- import qualified Control.Lens.Equality
+-- import qualified Control.Lens.Extras
+-- import qualified Control.Lens.Fold
+-- import qualified Control.Lens.Getter
+-- import qualified Control.Lens.Indexed
+-- import qualified Control.Lens.Internal
+-- import qualified Control.Lens.Internal.Bazaar
+-- import qualified Control.Lens.Internal.ByteString
+-- import qualified Control.Lens.Internal.Coerce
+-- import qualified Control.Lens.Internal.Context
+-- import qualified Control.Lens.Internal.Deque
+-- import qualified Control.Lens.Internal.Exception
+-- import qualified Control.Lens.Internal.FieldTH
+-- import qualified Control.Lens.Internal.Fold
+-- import qualified Control.Lens.Internal.Getter
+-- import qualified Control.Lens.Internal.Indexed
+-- import qualified Control.Lens.Internal.Instances
+-- import qualified Control.Lens.Internal.Iso
+-- import qualified Control.Lens.Internal.Level
+-- import qualified Control.Lens.Internal.List
+-- import qualified Control.Lens.Internal.Magma
+-- import qualified Control.Lens.Internal.Prism
+-- import qualified Control.Lens.Internal.PrismTH
+-- import qualified Control.Lens.Internal.Review
+-- import qualified Control.Lens.Internal.Setter
+-- import qualified Control.Lens.Internal.TH
+-- import qualified Control.Lens.Internal.Zoom
+-- import qualified Control.Lens.Iso
+-- import qualified Control.Lens.Lens
+-- import qualified Control.Lens.Level
+-- import qualified Control.Lens.Operators
+-- import qualified Control.Lens.Plated
+-- import qualified Control.Lens.Prism
+-- import qualified Control.Lens.Reified
+-- import qualified Control.Lens.Review
+-- import qualified Control.Lens.Setter
+-- import qualified Control.Lens.TH
+-- import qualified Control.Lens.Traversal
+-- import qualified Control.Lens.Tuple
+-- import qualified Control.Lens.Type
+-- import qualified Control.Lens.Wrapped
+-- import qualified Control.Lens.Zoom
+-- import qualified Control.Monad.Error.Lens
+-- import qualified Control.Parallel.Strategies.Lens
+-- import qualified Control.Seq.Lens
+-- import qualified Data.Array.Lens
+-- import qualified Data.Bits.Lens
+-- import qualified Data.ByteString.Lazy.Lens
+-- import qualified Data.ByteString.Lens
+-- import qualified Data.ByteString.Strict.Lens
+-- import qualified Data.Complex.Lens
+-- import qualified Data.Data.Lens
+-- import qualified Data.Dynamic.Lens
+-- import qualified Data.HashSet.Lens
+-- import qualified Data.IntSet.Lens
+-- import qualified Data.List.Lens
+-- import qualified Data.Map.Lens
+-- import qualified Data.Sequence.Lens
+-- import qualified Data.Set.Lens
+-- import qualified Data.Text.Lazy.Lens
+-- import qualified Data.Text.Lens
+-- import qualified Data.Text.Strict.Lens
+-- import qualified Data.Tree.Lens
+-- import qualified Data.Typeable.Lens
+-- import qualified Data.Vector.Generic.Lens
+-- import qualified Data.Vector.Lens
+-- import qualified GHC.Generics.Lens
+-- import qualified Generics.Deriving.Lens
+-- import qualified Language.Haskell.TH.Lens
+-- import qualified Numeric.Lens
+-- import qualified System.Exit.Lens
+-- import qualified System.FilePath.Lens
+-- import qualified System.IO.Error.Lens
+
+-- import qualified Control.Monad.Cont
+-- import qualified Control.Monad.Cont.Class
+-- import qualified Control.Monad.Error.Class
+-- import qualified Control.Monad.Except
+-- import qualified Control.Monad.Identity
+-- import qualified Control.Monad.List
+-- import qualified Control.Monad.RWS
+-- import qualified Control.Monad.RWS.Class
+-- import qualified Control.Monad.RWS.Lazy
+-- import qualified Control.Monad.RWS.Strict
+-- import qualified Control.Monad.Reader
+-- import qualified Control.Monad.Reader.Class
+-- import qualified Control.Monad.State
+-- import qualified Control.Monad.State.Class
+-- import qualified Control.Monad.State.Lazy
+-- import qualified Control.Monad.State.Strict
+-- import qualified Control.Monad.Trans
+-- import qualified Control.Monad.Writer
+-- import qualified Control.Monad.Writer.Class
+-- import qualified Control.Monad.Writer.Lazy
+-- import qualified Control.Monad.Writer.Strict
+
+-- import qualified Control.Monad.Trans.MultiRWS
+import qualified Control.Monad.Trans.MultiRWS.Lazy
+import qualified Control.Monad.Trans.MultiRWS.Strict
+import qualified Control.Monad.Trans.MultiReader
+import qualified Control.Monad.Trans.MultiReader.Class
+import qualified Control.Monad.Trans.MultiReader.Lazy
+import qualified Control.Monad.Trans.MultiReader.Strict
+import qualified Control.Monad.Trans.MultiState
+import qualified Control.Monad.Trans.MultiState.Class
+import qualified Control.Monad.Trans.MultiState.Lazy
+import qualified Control.Monad.Trans.MultiState.Strict
+import qualified Control.Monad.Trans.MultiWriter
+import qualified Control.Monad.Trans.MultiWriter.Class
+import qualified Control.Monad.Trans.MultiWriter.Lazy
+import qualified Control.Monad.Trans.MultiWriter.Strict
+
+import qualified Control.Monad.Trans.MultiRWS.Strict as MultiRWSS
+import qualified Control.Monad.Trans.MultiRWS.Lazy as MultiRWSL
+
+import qualified Text.PrettyPrint
+
+import qualified Text.PrettyPrint.Annotated
+import qualified Text.PrettyPrint.Annotated.HughesPJ
+import qualified Text.PrettyPrint.Annotated.HughesPJClass
+
+import qualified Text.PrettyPrint.HughesPJ
+import qualified Text.PrettyPrint.HughesPJClass
+
+-- import qualified Data.Generics
+-- import qualified Data.Generics.Aliases
+-- import qualified Data.Generics.Basics
+-- import qualified Data.Generics.Builders
+-- import qualified Data.Generics.Instances
+-- import qualified Data.Generics.Schemes
+-- import qualified Data.Generics.Text
+-- import qualified Data.Generics.Twins
+-- import qualified Generics.SYB
+-- import qualified Generics.SYB.Aliases
+-- import qualified Generics.SYB.Basics
+-- import qualified Generics.SYB.Builders
+-- import qualified Generics.SYB.Instances
+-- import qualified Generics.SYB.Schemes
+-- import qualified Generics.SYB.Text
+-- import qualified Generics.SYB.Twins
+
+import qualified Data.Text
+import qualified Data.Text.Array
+import qualified Data.Text.Encoding
+import qualified Data.Text.Encoding.Error
+import qualified Data.Text.Foreign
+import qualified Data.Text.IO
+-- import qualified Data.Text.Internal
+-- import qualified Data.Text.Internal.Builder
+-- import qualified Data.Text.Internal.Builder.Functions
+-- import qualified Data.Text.Internal.Builder.Int.Digits
+-- import qualified Data.Text.Internal.Builder.RealFloat.Functions
+-- import qualified Data.Text.Internal.Encoding.Fusion
+-- import qualified Data.Text.Internal.Encoding.Fusion.Common
+-- import qualified Data.Text.Internal.Encoding.Utf16
+-- import qualified Data.Text.Internal.Encoding.Utf32
+-- import qualified Data.Text.Internal.Encoding.Utf8
+-- import qualified Data.Text.Internal.Functions
+-- import qualified Data.Text.Internal.Fusion
+-- import qualified Data.Text.Internal.Fusion.CaseMapping
+-- import qualified Data.Text.Internal.Fusion.Common
+-- import qualified Data.Text.Internal.Fusion.Size
+-- import qualified Data.Text.Internal.Fusion.Types
+-- import qualified Data.Text.Internal.IO
+-- import qualified Data.Text.Internal.Lazy
+-- import qualified Data.Text.Internal.Lazy.Encoding.Fusion
+-- import qualified Data.Text.Internal.Lazy.Fusion
+-- import qualified Data.Text.Internal.Lazy.Search
+-- import qualified Data.Text.Internal.Private
+-- import qualified Data.Text.Internal.Read
+-- import qualified Data.Text.Internal.Search
+-- import qualified Data.Text.Internal.Unsafe
+-- import qualified Data.Text.Internal.Unsafe.Char
+-- import qualified Data.Text.Internal.Unsafe.Shift
+import qualified Data.Text.Lazy
+import qualified Data.Text.Lazy.Builder
+-- import qualified Data.Text.Lazy.Builder.Int
+-- import qualified Data.Text.Lazy.Builder.RealFloat
+-- import qualified Data.Text.Lazy.Encoding
+-- import qualified Data.Text.Lazy.IO
+-- import qualified Data.Text.Lazy.Read
+-- import qualified Data.Text.Read
+-- import qualified Data.Text.Unsafe
+
+-- import qualified Control.Applicative.Backwards
+-- import qualified Control.Applicative.Lift
+-- import qualified Control.Monad.IO.Class
+-- import qualified Control.Monad.Signatures
+-- import qualified Control.Monad.Trans.Class
+-- import qualified Control.Monad.Trans.Cont
+-- import qualified Control.Monad.Trans.Except
+-- import qualified Control.Monad.Trans.Identity
+-- import qualified Control.Monad.Trans.List
+-- import qualified Control.Monad.Trans.Maybe
+-- import qualified Control.Monad.Trans.RWS
+-- import qualified Control.Monad.Trans.RWS.Lazy
+-- import qualified Control.Monad.Trans.RWS.Strict
+-- import qualified Control.Monad.Trans.Reader
+-- import qualified Control.Monad.Trans.State
+-- import qualified Control.Monad.Trans.State.Lazy
+-- import qualified Control.Monad.Trans.State.Strict
+-- import qualified Control.Monad.Trans.Writer
+-- import qualified Control.Monad.Trans.Writer.Lazy
+-- import qualified Control.Monad.Trans.Writer.Strict
+-- import qualified Data.Functor.Classes
+-- import qualified Data.Functor.Compose
+-- import qualified Data.Functor.Constant
+-- import qualified Data.Functor.Product
+-- import qualified Data.Functor.Reverse
+-- import qualified Data.Functor.Sum
+
+-- import qualified Prelude
+-- import qualified Control.Applicative
+-- import qualified Control.Arrow
+-- import qualified Control.Category
+-- import qualified Control.Concurrent
+-- import qualified Control.Concurrent.Chan
+-- import qualified Control.Concurrent.MVar
+-- import qualified Control.Concurrent.QSem
+-- import qualified Control.Concurrent.QSemN
+-- import qualified Control.Exception
+-- import qualified Control.Exception.Base
+-- import qualified Control.Monad
+-- import qualified Control.Monad.Fix
+-- import qualified Control.Monad.ST
+-- import qualified Control.Monad.ST.Lazy
+-- import qualified Control.Monad.ST.Lazy.Unsafe
+-- import qualified Control.Monad.ST.Strict
+-- import qualified Control.Monad.ST.Unsafe
+-- import qualified Control.Monad.Zip
+import qualified Data.Bifunctor
+import qualified Data.Bits
+import qualified Data.Bool
+import qualified Data.Char
+import qualified Data.Coerce
+import qualified Data.Complex
+import qualified Data.Data
+import qualified Data.Dynamic
+import qualified Data.Either
+import qualified Data.Eq
+import qualified Data.Fixed
+import qualified Data.Foldable
+import qualified Data.Function
+import qualified Data.Functor
+import qualified Data.Functor.Identity
+import qualified Data.IORef
+import qualified Data.Int
+import qualified Data.Ix
+import qualified Data.List
+import qualified Data.Maybe
+import qualified Data.Monoid
+import qualified Data.Ord
+import qualified Data.Proxy
+-- import qualified Data.Ratio
+-- import qualified Data.STRef
+-- import qualified Data.STRef.Lazy
+-- import qualified Data.STRef.Strict
+-- import qualified Data.String
+-- import qualified Data.Traversable
+-- import qualified Data.Tuple
+-- import qualified Data.Type.Bool
+-- import qualified Data.Type.Coercion
+-- import qualified Data.Type.Equality
+-- import qualified Data.Typeable
+-- import qualified Data.Typeable.Internal
+-- import qualified Data.Unique
+-- import qualified Data.Version
+-- import qualified Data.Void
+-- import qualified Data.Word
+import qualified Debug.Trace
+-- import qualified Foreign.C
+-- import qualified Foreign.C.Error
+-- import qualified Foreign.C.String
+-- import qualified Foreign.C.Types
+-- import qualified Foreign.Concurrent
+-- import qualified Foreign.ForeignPtr
+-- import qualified Foreign.ForeignPtr.Unsafe
+-- import qualified Foreign.Marshal
+-- import qualified Foreign.Marshal.Alloc
+-- import qualified Foreign.Marshal.Array
+-- import qualified Foreign.Marshal.Error
+-- import qualified Foreign.Marshal.Pool
+-- import qualified Foreign.Marshal.Unsafe
+-- import qualified Foreign.Marshal.Utils
+-- import qualified Foreign.Ptr
+-- import qualified Foreign.StablePtr
+-- import qualified Foreign.Storable
+import qualified Numeric
+import qualified Numeric.Natural
+-- import qualified System.CPUTime
+-- import qualified System.Console.GetOpt
+-- import qualified System.Environment
+-- import qualified System.Exit
+import qualified System.IO
+-- import qualified System.IO.Error
+-- import qualified System.IO.Unsafe
+-- import qualified System.Info
+-- import qualified System.Mem
+-- import qualified System.Mem.StableName
+-- import qualified System.Mem.Weak
+-- import qualified System.Posix.Types
+-- import qualified System.Timeout
+-- import qualified Text.ParserCombinators.ReadP
+-- import qualified Text.ParserCombinators.ReadPrec
+-- import qualified Text.Printf
+-- import qualified Text.Read
+-- import qualified Text.Read.Lex
+-- import qualified Text.Show
+-- import qualified Text.Show.Functions
+import qualified Unsafe.Coerce
+
+-- import qualified Control.Arrow as Arrow
+-- import qualified Control.Category as Category
+-- import qualified Control.Concurrent as Concurrent
+-- import qualified Control.Concurrent.Chan as Chan
+-- import qualified Control.Concurrent.MVar as MVar
+-- import qualified Control.Exception as Exception
+-- import qualified Control.Exception.Base as Exception.Base
+-- import qualified Control.Monad as Monad
+-- import qualified Data.Bits as Bits
+import qualified Data.Bool as Bool
+-- import qualified Data.Char as Char
+-- import qualified Data.Complex as Complex
+-- import qualified Data.Either as Either
+-- import qualified Data.Eq as Eq
+-- import qualified Data.Foldable as Foldable
+-- import qualified Data.Fixed as Fixed
+-- import qualified Data.Functor.Identity as Identity
+-- import qualified Data.IORef as IORef
+-- import qualified Data.Int as Int
+-- import qualified Data.Ix as Ix
+-- import qualified Data.Maybe as Maybe
+-- import qualified Data.Monoid as Monoid
+-- import qualified Data.Ord as Ord
+-- import qualified Data.Proxy as Proxy
+-- import qualified Data.Traversable as Traversable
+-- import qualified Data.Void as Void
+import qualified GHC.OldList as List
+-- import qualified Text.Printf as Printf
+
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Lazy as ByteStringL
+
+import qualified Data.IntMap as IntMap
+-- import qualified Data.IntMap.Lazy as IntMapL
+import qualified Data.IntMap.Strict as IntMapS
+-- import qualified Data.IntSet as IntSet
+import qualified Data.Map as Map
+-- import qualified Data.Map.Lazy as MapL
+-- import qualified Data.Map.Strict as MapS
+import qualified Data.Sequence as Seq
+import qualified Data.Set as Set
+
+import qualified Control.Monad.RWS.Class as RWS.Class
+import qualified Control.Monad.Reader.Class as Reader.Class
+import qualified Control.Monad.State.Class as State.Class
+import qualified Control.Monad.Writer.Class as Writer.Class
+
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text.Encoding
+import qualified Data.Text.IO as Text.IO
+import qualified Data.Text.Lazy as TextL
+import qualified Data.Text.Lazy.Encoding as TextL.Encoding
+import qualified Data.Text.Lazy.IO as TextL.IO
+
+-- import qualified Control.Monad.Trans.Class as Trans.Class
+-- import qualified Control.Monad.Trans.Maybe as Trans.Maybe
+-- import qualified Control.Monad.Trans.RWS as RWS
+-- import qualified Control.Monad.Trans.RWS.Lazy as RWSL
+-- import qualified Control.Monad.Trans.RWS.Strict as RWSS
+-- import qualified Control.Monad.Trans.Reader as Reader
+import qualified Control.Monad.Trans.State as State
+import qualified Control.Monad.Trans.State.Lazy as StateL
+import qualified Control.Monad.Trans.State.Strict as StateS
+-- import qualified Control.Monad.Trans.Writer as Writer
+-- import qualified Control.Monad.Trans.Writer.Lazy as WriterL
+-- import qualified Control.Monad.Trans.Writer.Strict as Writer
+
+import qualified Data.Strict.Maybe as Strict
+
+import Data.Functor.Identity ( Identity(..) )
+import Control.Concurrent.Chan ( Chan )
+import Control.Concurrent.MVar ( MVar )
+import Data.Int ( Int )
+import Data.Word ( Word )
+import Prelude ( Integer, Float, Double )
+import Control.Monad.ST ( ST )
+import Data.Bool ( Bool(..) )
+import Data.Char ( Char )
+import Data.Either ( Either(..) )
+import Data.IORef ( IORef )
+import Data.Maybe ( Maybe(..) )
+import Data.Monoid ( Endo(..), All(..), Any(..), Sum(..), Product(..), First(..), Last(..), Alt(..), )
+import Data.Ord ( Ordering(..), Down(..) )
+import Data.Ratio ( Ratio, Rational )
+import Data.String ( String )
+import Data.Void ( Void )
+import System.IO ( IO )
+import Data.Proxy ( Proxy(..) )
+import Data.Sequence ( Seq )
+
+import Data.Map ( Map )
+import Data.Set ( Set )
+
+import Data.Text ( Text )
+
+import Prelude                            ( Char
+                                          , String
+                                          , Int
+                                          , Integer
+                                          , Float
+                                          , Double
+                                          , Bool (..)
+                                          , undefined
+                                          , Eq (..)
+                                          , Ord (..)
+                                          , Enum (..)
+                                          , Bounded (..)
+                                          , Maybe (..)
+                                          , Either (..)
+                                          , IO
+                                          , (<$>)
+                                          , (.)
+                                          , ($)
+                                          , ($!)
+                                          , Num (..)
+                                          , Integral (..)
+                                          , Fractional (..)
+                                          , Floating (..)
+                                          , RealFrac (..)
+                                          , RealFloat (..)
+                                          , fromIntegral
+                                          , error
+                                          , foldr
+                                          , foldl
+                                          , foldr1
+                                          , id
+                                          , map
+                                          , subtract
+                                          , putStrLn
+                                          , putStr
+                                          , Show (..)
+                                          , print
+                                          , fst
+                                          , snd
+                                          , (++)
+                                          , not
+                                          , (&&)
+                                          , (||)
+                                          , curry
+                                          , uncurry
+                                          , Ordering (..)
+                                          , flip
+                                          , const
+                                          , seq
+                                          , reverse
+                                          , otherwise
+                                          , traverse
+                                          , realToFrac
+                                          , or
+                                          , and
+                                          , head
+                                          , any
+                                          , (^)
+                                          , Foldable
+                                          , Traversable
+                                          )
+
+import Data.Foldable                      ( foldl'
+                                          , foldr'
+                                          , fold
+                                          , asum
+                                          )
+
+import Data.List                          ( partition
+                                          , null
+                                          , elem
+                                          , notElem
+                                          , minimum
+                                          , maximum
+                                          , length
+                                          , all
+                                          , take
+                                          , drop
+                                          , find
+                                          , sum
+                                          , zip
+                                          , zip3
+                                          , zipWith
+                                          , repeat
+                                          , replicate
+                                          , iterate
+                                          , nub
+                                          , filter
+                                          , intersperse
+                                          , intercalate
+                                          , isSuffixOf
+                                          , isPrefixOf
+                                          , dropWhile
+                                          , takeWhile
+                                          , unzip
+                                          , break
+                                          , transpose
+                                          , sortBy
+                                          , mapAccumL
+                                          , mapAccumR
+                                          , uncons
+                                          )
+
+import Data.Tuple                         ( swap
+                                          )
+
+import Data.Char                          ( ord
+                                          , chr
+                                          )
+
+import Data.Maybe                         ( fromMaybe
+                                          , maybe
+                                          , listToMaybe
+                                          , maybeToList
+                                          , catMaybes
+                                          )
+
+import Data.Word                          ( Word32
+                                          )
+
+import Data.Ord                           ( comparing
+                                          , Down (..)
+                                          )
+
+import Data.Either                        ( either
+                                          )
+
+import Data.Ratio                         ( Ratio
+                                          , (%)
+                                          , numerator
+                                          , denominator
+                                          )
+
+import Text.Read                          ( readMaybe
+                                          )
+
+import Control.Monad                      ( Functor (..)
+                                          , Monad (..)
+                                          , MonadPlus (..)
+                                          , mapM
+                                          , mapM_
+                                          , forM
+                                          , forM_
+                                          , sequence
+                                          , sequence_
+                                          , (=<<)
+                                          , (>=>)
+                                          , (<=<)
+                                          , forever
+                                          , void
+                                          , join
+                                          , replicateM
+                                          , replicateM_
+                                          , guard
+                                          , when
+                                          , unless
+                                          , liftM
+                                          , liftM2
+                                          , liftM3
+                                          , liftM4
+                                          , liftM5
+                                          , filterM
+                                          , (<$!>)
+                                          )
+
+import Control.Applicative                ( Applicative (..)
+                                          , Alternative (..)
+                                          )
+
+import Foreign.Storable                   ( Storable )
+import GHC.Exts                           ( Constraint )
+
+import Control.Concurrent                 ( threadDelay
+                                          , forkIO
+                                          , forkOS
+                                          )
+
+import Control.Concurrent.MVar            ( MVar
+                                          , newEmptyMVar
+                                          , newMVar
+                                          , putMVar
+                                          , readMVar
+                                          , takeMVar
+                                          , swapMVar
+                                          )
+
+import Control.Exception                  ( evaluate
+                                          , bracket
+                                          , assert
+                                          )
+
+import Debug.Trace                        ( trace
+                                          , traceId
+                                          , traceShowId
+                                          , traceShow
+                                          , traceStack
+                                          , traceShowId
+                                          , traceIO
+                                          , traceM
+                                          , traceShowM
+                                          )
+
+import Foreign.ForeignPtr                 ( ForeignPtr
+                                          )
+
+import Data.Monoid                        ( (<>)
+                                          , mconcat
+                                          , Monoid (..)
+                                          )
+
+import Data.Bifunctor                     ( bimap )
+import Data.Functor                       ( (<$), ($>) )
+import Data.Function                      ( (&) )
+import System.IO                          ( hFlush
+                                          , stdout
+                                          )
+
+import Data.Typeable                      ( Typeable
+                                          )
+
+import Control.Arrow                      ( first
+                                          , second
+                                          , (***)
+                                          , (&&&)
+                                          , (>>>)
+                                          , (<<<)
+                                          )
+
+import Data.Functor.Identity              ( Identity (..)
+                                          )
+
+import Data.Proxy                         ( Proxy (..)
+                                          )
+
+import Data.Version                       ( showVersion
+                                          )
+
+import Data.List.Extra                    ( nubOrd
+                                          , stripSuffix
+                                          )
+import Control.Monad.Extra                ( whenM
+                                          , unlessM
+                                          , ifM
+                                          , notM
+                                          , orM
+                                          , andM
+                                          , anyM
+                                          , allM
+                                          )
+
+import Data.Tree                          ( Tree(..)
+                                          )
+
+import Control.Monad.Trans.MultiRWS       ( -- MultiRWST (..)
+                                          -- , MultiRWSTNull
+                                          -- , MultiRWS
+                                          -- , 
+                                            MonadMultiReader(..)
+                                          , MonadMultiWriter(..)
+                                          , MonadMultiState(..)
+                                          -- , runMultiRWST
+                                          -- , runMultiRWSTASW
+                                          -- , runMultiRWSTW
+                                          -- , runMultiRWSTAW
+                                          -- , runMultiRWSTSW
+                                          -- , runMultiRWSTNil
+                                          -- , runMultiRWSTNil_
+                                          -- , withMultiReader
+                                          -- , withMultiReader_
+                                          -- , withMultiReaders
+                                          -- , withMultiReaders_
+                                          -- , withMultiWriter
+                                          -- , withMultiWriterAW
+                                          -- , withMultiWriterWA
+                                          -- , withMultiWriterW
+                                          -- , withMultiWriters
+                                          -- , withMultiWritersAW
+                                          -- , withMultiWritersWA
+                                          -- , withMultiWritersW
+                                          -- , withMultiState
+                                          -- , withMultiStateAS
+                                          -- , withMultiStateSA
+                                          -- , withMultiStateA
+                                          -- , withMultiStateS
+                                          -- , withMultiState_
+                                          -- , withMultiStates
+                                          -- , withMultiStatesAS
+                                          -- , withMultiStatesSA
+                                          -- , withMultiStatesA
+                                          -- , withMultiStatesS
+                                          -- , withMultiStates_
+                                          -- , inflateReader
+                                          -- , inflateMultiReader
+                                          -- , inflateWriter
+                                          -- , inflateMultiWriter
+                                          -- , inflateState
+                                          -- , inflateMultiState
+                                          -- , mapMultiRWST
+                                          -- , mGetRawR
+                                          -- , mGetRawW
+                                          -- , mGetRawS
+                                          -- , mPutRawR
+                                          -- , mPutRawW
+                                          -- , mPutRawS
+                                          )
+
+import Control.Monad.Trans.MultiReader    ( runMultiReaderTNil
+                                          , runMultiReaderTNil_
+                                          , MultiReaderT (..)
+                                          , MultiReader
+                                          , MultiReaderTNull
+                                          )
+
+import Data.Text                          ( Text )
+
+import Control.Monad.IO.Class             ( MonadIO (..)
+                                          )
+
+import Control.Monad.Trans.Class          ( lift
+                                          )
+import Control.Monad.Trans.Maybe          ( MaybeT (..)
+                                          )
+
+import Language.Haskell.Brittany.Prelude