Change config setup(!), Refactor, Update deps

- config now uses foo_bar instead of _foo_bar;
- config now will accept missing keys;
- use latest butcher version;
- improve identity testing by moving into separate file.

brittany.cabal

@@ -1,5 +1,5 @@
 name:                brittany
-version:             0.7.1.0
+version:             0.8.0.0
 -- synopsis:            
 -- description:         
 license:             AllRightsReserved
@@ -50,6 +50,7 @@ library {
     Language.Haskell.Brittany.Transformations.Par
     Language.Haskell.Brittany.Transformations.Columns
     Language.Haskell.Brittany.Transformations.Indent
+    Paths_brittany
   }
   ghc-options: {
     -Wall
@@ -78,9 +79,10 @@ library {
     , bytestring >=0.10.8.1 && <0.11
     , directory >=1.2.6.2 && <1.3
     , lens
-    , butcher >=0.2.0.0 && <0.3
+    , butcher >=1.0.0.0 && <1.1
     , yaml >=0.8.18 && <0.9
-    , extra >=1.4.10 && <1.5
+    , aeson >=1.0.1.0 && <1.3
+    , extra >=1.4.10 && <1.6
     , uniplate >=1.6.12 && <1.7
     , strict >=0.3.2 && <0.4
     , monad-memo >=0.4.1 && <0.5
@@ -217,8 +219,7 @@ test-suite unittests
     }
   ghc-options:      -Wall
   main-is:          TestMain.hs
-  other-modules:    IdentityTests
+  other-modules:    TestUtils
-                    TestUtils
                     AsymptoticPerfTests
   hs-source-dirs:   src-unittests
   default-extensions: {
@@ -247,3 +248,71 @@ test-suite unittests
   if flag(brittany-dev) {
     ghc-options: -O0 -Werror -fobject-code
   }
+
+test-suite littests
+  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
+    , safe
+    , either
+    , parsec
+    }
+  ghc-options:      -Wall
+  main-is:          Main.hs
+  other-modules:    
+  hs-source-dirs:   src-literatetests
+  default-extensions: {
+    CPP
+
+    NoImplicitPrelude
+
+    GADTs
+
+    FlexibleContexts
+    FlexibleInstances
+    ScopedTypeVariables
+    MonadComprehensions
+    LambdaCase
+    MultiWayIf
+    KindSignatures
+  }
+  ghc-options: {
+    -Wall
+    -j
+    -fno-warn-unused-imports
+    -fno-warn-orphans
+    -rtsopts
+    -with-rtsopts "-M2G"
+  }
+  if flag(brittany-dev) {
+    ghc-options: -O0 -Werror -fobject-code
+  }

docs/hcar/Brittany.tex

@@ -0,0 +1,54 @@
+% Brittany-LE.tex
+\begin{hcarentry}[new]{Brittany}
+\report{Lennart Spitzner}%11/16
+\status{work in progress}
+\makeheader
+
+Brittany is a Haskell source code formatting tool. It is based on
+ghc-exactprint and thus uses the ghc parser, in contrast to tools based on
+haskell-src-exts such as hindent or haskell-formatter.
+
+The goals of the project are to:
+
+\begin{compactitem}
+\item
+  support the full ghc-haskell syntax including syntactic extensions;
+\item
+  retain newlines and comments unmodified (to the degree possible when code
+  around them gets reformatted);
+\item
+  be clever about using horizontal space while not overflowing it if it cannot
+  be avoided;
+\item
+  have linear complexity in the size of the input text / the number of
+  syntactic nodes in the input.
+\item
+  support horizontal alignments (e.g. different equations/pattern matches in
+  the some function's definition).
+\end{compactitem}
+
+In contrast to other formatters brittany internally works in two steps: Firstly
+transforming the syntax tree into a document tree representation, similar to
+the document representation in general-purpose pretty-printers such as the
+\emph{pretty} package, but much more specialized for the specific purpose of
+handling a Haskell source code document. Secondly this document representation
+is transformed into the output text document. This approach allows to handle
+many different syntactic constructs in a uniform way, making it possible
+to attain the above goals with a manageable amount of work.
+
+Brittany is work in progress; currently only type signatures and function
+bindings are transformed, and not all syntactic constructs are supported.
+Nonetheless Brittany is safe to try/use as there are checks in place to
+ensure that the output is syntactically valid.
+
+Brittany requires ghc-8, and is not released on hackage yet; for a description
+of how to build it see the repository README.
+
+\FurtherReading
+{\small
+\begin{compactitem}
+  \item
+    \url{https://github.com/lspitzner/brittany}
+\end{compactitem}
+}
+\end{hcarentry}

src-brittany/Main.hs

@@ -39,10 +39,10 @@ import Paths_brittany
 
 
 main :: IO ()
-main = mainFromCmdParser mainCmdParser
+main = mainFromCmdParserWithHelpDesc mainCmdParser
 
-mainCmdParser :: CmdParser Identity (IO ()) ()
+mainCmdParser :: CommandDesc () -> CmdParser Identity (IO ()) ()
-mainCmdParser = do
+mainCmdParser helpDesc = do
   addCmdSynopsis "haskell source pretty printer"
   addCmdHelp $ PP.vcat $ List.intersperse (PP.text "")
     [ parDoc $ "Transforms one haskell module by reformatting"
@@ -60,7 +60,7 @@ mainCmdParser = do
             ++ " https://github.com/lspitzner/brittany/issues"
     ]
   -- addCmd "debugArgs" $ do
-  addHelpCommand
+  addHelpCommand helpDesc
   -- addButcherDebugCommand
   reorderStart
   printHelp <- addSimpleBoolFlag "" ["help"] mempty

src-literatetests/Main.hs

@@ -0,0 +1,152 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Main where
+
+
+
+#include "prelude.inc"
+
+import Test.Hspec
+
+import NeatInterpolation
+
+import qualified Text.Parsec as Parsec
+import Text.Parsec.Text ( Parser )
+
+import Data.Char ( isSpace )
+import Data.List ( groupBy )
+
+import Language.Haskell.Brittany
+
+import Language.Haskell.Brittany.Config.Types
+
+import Data.Coerce ( coerce )
+
+import qualified Data.Text.IO as Text.IO
+
+
+
+data InputLine
+  = GroupLine Text
+  | HeaderLine Text
+  | PendingLine
+  | NormalLine Text
+  | CommentLine
+  deriving Show
+
+
+main :: IO ()
+main = do
+  input <- Text.IO.readFile "src-literatetests/tests.blt"
+  let groups = createChunks input
+  hspec $ groups `forM_` \(groupname, tests) -> do
+    describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do
+      (if pend then before_ pending else id)
+        $ it (Text.unpack name) $ roundTripEqual inp
+
+ where
+  -- this function might be implemented in a weirdly complex fashion; the
+  -- reason being that it was copied from a somewhat more complex variant.
+  createChunks :: Text -> [(Text, [(Text, Bool, Text)])]
+  createChunks input =
+--    fmap (\case
+--        HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines)
+--        HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> (n, False, Text.unlines rlines)
+--        l -> error $ "first non-empty line must start with #test footest\n" ++ show l
+--      )
+--      $   fmap (groupBy grouperT)
+    fmap (\case
+          GroupLine g:grouprest ->
+            (,) g
+            $ fmap (\case
+                HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines)
+                HeaderLine n:rest | Just rlines <- mapM extractNormal rest -> (n, False, Text.unlines rlines)
+                l -> error $ "first non-empty line must start with #test footest\n" ++ show l
+              )
+            $ groupBy grouperT
+            $ filter (not . lineIsSpace)
+            $ grouprest
+          l -> error $ "first non-empty line must be a #group\n" ++ show l
+      )
+      $   groupBy grouperG
+      $   filter (not . lineIsSpace)
+      $   lineMapper
+      <$> Text.lines input
+   where
+    extractNormal (NormalLine l) = Just l
+    extractNormal _ = Nothing
+    specialLineParser :: Parser InputLine
+    specialLineParser = Parsec.choice
+      [ [ GroupLine $ Text.pack name
+        | _      <- Parsec.try $ Parsec.string "#group"
+        , _      <- Parsec.many1 $ Parsec.oneOf " \t"
+        , name   <- Parsec.many1 $ Parsec.noneOf "\r\n:"
+        , _      <- Parsec.eof
+        ]
+      , [ HeaderLine $ Text.pack name
+        | _      <- Parsec.try $ Parsec.string "#test"
+        , _      <- Parsec.many1 $ Parsec.oneOf " \t"
+        , name   <- Parsec.many1 $ Parsec.noneOf "\r\n:"
+        , _      <- Parsec.eof
+        ]
+      , [ PendingLine
+        | _      <- Parsec.try $ Parsec.string "#pending"
+        , _      <- Parsec.optional $ many (Parsec.noneOf "\r\n")
+        , _      <- Parsec.eof
+        ]
+      , [ CommentLine
+        | _ <- Parsec.many $ Parsec.oneOf " \t"
+        , _ <- Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n")
+        , _ <- Parsec.eof
+        ]
+      ]
+    lineMapper :: Text -> InputLine
+    lineMapper line = case Parsec.runParser specialLineParser () "" line of
+      Left  _e -> NormalLine line
+      Right l -> l
+    lineIsSpace :: InputLine -> Bool
+    lineIsSpace CommentLine = True
+    lineIsSpace _ = False
+    grouperG :: InputLine -> InputLine -> Bool
+    grouperG _ GroupLine{} = False
+    grouperG _ _           = True
+    grouperT :: InputLine -> InputLine -> Bool
+    grouperT _ HeaderLine{} = False
+    grouperT _ _            = True
+
+
+--------------------
+-- past this line:  copy-pasta from other test (meh..)
+--------------------
+roundTripEqual :: Text -> Expectation
+roundTripEqual t =
+  fmap (fmap PPTextWrapper)
+       (parsePrintModule defaultTestConfig "TestFakeFileName.hs" t)
+    `shouldReturn` Right (PPTextWrapper 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               = coerce (80 :: Int)
+    , _lconfig_indentPolicy       = coerce IndentPolicyFree
+    , _lconfig_indentAmount       = coerce (2 :: Int)
+    , _lconfig_indentWhereSpecial = coerce True
+    , _lconfig_indentListSpecial  = coerce True
+    , _lconfig_importColumn       = coerce (60 :: Int)
+    , _lconfig_altChooser         = coerce $ AltChooserBoundedSearch 3
+    , _lconfig_columnAlignMode    = coerce (ColumnAlignModeMajority 0.7)
+    }
+  , _conf_errorHandling = _conf_errorHandling staticDefaultConfig
+  , _conf_forward       = ForwardOptions
+    { _options_ghc = Identity []
+    }
+  }
+

src-literatetests/tests.blt

@@ -0,0 +1,675 @@
+
+###############################################################################
+###############################################################################
+###############################################################################
+#group type signatures
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test simple001
+func :: a -> a
+
+#test long typeVar
+func
+  :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+  -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+
+#test keep linebreak mode
+func
+  :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+  -> lakjsdlkjasldkj
+  -> lakjsdlkjasldkj
+
+#test simple parens 1
+func :: ((a))
+
+#test simple parens 2
+func :: (a -> a) -> a
+
+#test simple parens 3
+func :: a -> (a -> a)
+
+#test did anyone say parentheses?
+func :: (((((((((())))))))))
+
+-- current output is.. funny. wonder if that can/needs to be improved..
+#test give me more!
+#pending
+func :: ((((((((((((((((((((((((((((((((((((((((((()))))))))))))))))))))))))))))))))))))))))))
+
+#test unit
+func :: ()
+
+
+###############################################################################
+
+#test paren'd func 1
+func
+  :: (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     -> lakjsdlkjasldkj
+     -> lakjsdlkjasldkj
+     )
+
+#test paren'd func 2
+func
+  :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+  -> (lakjsdlkjasldkj -> lakjsdlkjasldkj)
+
+#test paren'd func 3
+func
+  :: (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> lakjsdlkjasldkj)
+  -> lakjsdlkjasldkj
+
+#test paren'd func 4
+func
+  :: (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     )
+  -> lakjsdlkjasldkj
+
+#test paren'd func 5
+func
+  :: ( (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       )
+     )
+
+###############################################################################
+
+#test type application 1
+func :: asd -> Either a b
+
+#test type application 2
+func
+  :: asd
+  -> Either
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+
+#test type application 3
+func
+  :: asd
+  -> Trither
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+
+#test type application 4
+func
+  :: Trither
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+  -> asd
+
+#test type application 5
+func
+  :: Trither
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd -> asd)
+
+#test type application 6
+func
+  :: Trither
+       asd
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       )
+
+#test type application paren 1
+func
+  :: asd
+  -> ( Trither
+         lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     )
+
+#test type application paren 2
+func
+  :: asd
+  -> ( Trither
+         lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     )
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+
+#test type application paren 3
+func
+  :: ( Trither
+         lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+         lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     )
+       lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+  -> asd
+
+###############################################################################
+
+#test list simple
+func :: [a -> b]
+
+#test list func
+func
+  :: [  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     ]
+
+#test list paren
+func
+  :: [ (  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       )
+     ]
+
+################################################################## -- #############
+
+#test tuple type 1
+func :: (a, b, c)
+
+#test tuple type 2
+func :: ((a, b, c), (a, b, c), (a, b, c))
+
+#test tuple type long
+func
+  :: ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     )
+
+#test tuple type nested
+func
+  :: ( ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       , (lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd)
+       , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       )
+     )
+
+#test tuple type function
+func
+  :: [ ( lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       , lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+       )
+     ]
+###############################################################################
+#test type operator stuff
+#pending
+test050 :: a :+: b
+test051 ::  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+        :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+test052 ::  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+        ->  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+        :+: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+        ->  lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+
+###############################################################################
+
+#test forall oneliner
+{-# LANGUAGE ScopedTypeVariables #-}
+--this comment is necessary for whatever reason..
+func :: forall (a :: *) b . a -> b
+
+#test language pragma issue
+{-# LANGUAGE ScopedTypeVariables #-}
+func :: forall (a :: *) b . a -> b
+
+#test comments 1
+func :: a -> b -- comment
+
+#test comments 2
+funcA :: a -> b -- comment A
+funcB :: a -> b -- comment B
+
+#test comments all
+#pending
+-- a
+func -- b
+  :: -- c
+  a -- d
+  -> -- e
+  ( -- f
+  c -- g
+  , -- h
+  d -- i
+  ) -- j
+-- k
+
+###############################################################################
+
+#test ImplicitParams 1
+{-# LANGUAGE ImplicitParams #-}
+func :: (?asd::Int) -> ()
+
+#test ImplicitParams 2
+{-# LANGUAGE ImplicitParams #-}
+func
+  :: (  ?asd
+     :: lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     -> lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+     )
+  -> ()
+
+
+
+###############################################################################
+###############################################################################
+###############################################################################
+#group equation.basic
+###############################################################################
+###############################################################################
+###############################################################################
+## 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.)
+
+#test basic 1
+func x = x
+
+#test infix 1
+x *** y = x
+
+#test symbol prefix
+(***) x y = x
+
+
+###############################################################################
+###############################################################################
+###############################################################################
+#group equation.patterns
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test wildcard
+func _ = x
+
+#test simple long pattern
+#pending
+func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
+  = x
+
+#test simple multiline pattern
+#pending
+func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
+     reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
+  = x
+
+#test another multiline pattern
+#pending
+func reallyreallyreallyreallyreallyreallyreallyreallyreallyreallylongvariable
+     a
+     b
+  = x
+
+#test simple constructor
+func (A a) = a
+
+#test list constructor
+func (x:xr) = x
+
+#test some other constructor symbol
+#pending
+func (x:+:xr) = x
+
+
+###############################################################################
+###############################################################################
+###############################################################################
+#group equation.guards
+###############################################################################
+###############################################################################
+###############################################################################
+#test simple guard
+func | True = x
+
+
+###############################################################################
+###############################################################################
+###############################################################################
+#group expression.basic
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test var
+func = x
+
+describe "infix op" $ do
+#test 1
+func = x + x
+
+#test long
+#pending
+func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
+     + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
+
+#test long keep linemode 1
+#pending
+func = mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
+     + mweroiuxlskdfjlksj
+     + mweroiuxlskdfjlksj
+
+#test long keep linemode 2
+#pending
+func = mweroiuxlskdfjlksj
+     + mweroiuxlskdfjlksj
+     + mweroiuxlskdfjlksjdflkjsdfljksldkjflkjsdflkj
+
+#test literals
+func = 1
+func = "abc"
+func = 1.1e5
+func = 'x'
+func = 981409823458910394810928414192837123987123987123
+
+#test lambdacase
+{-# LANGUAGE LambdaCase #-}
+func = \case
+  FooBar -> x
+  Baz    -> y
+
+#test lambda
+func = \x -> abc
+
+describe "app" $ do
+#test 1
+func = klajsdas klajsdas klajsdas
+
+#test 2
+func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+  lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+  lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+
+#test 3
+func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas
+                                                     lakjsdlajsdljas
+                                                     lakjsdlajsdljas
+
+###
+#group expression.basic.sections
+###
+
+#test left
+func = (1+)
+
+#test right
+func = (+1)
+
+#test left inf
+## TODO: this could be improved..
+func = (1`abc`)
+
+#test right inf
+func = (`abc`1)
+
+###
+#group tuples
+###
+
+#test 1
+func = (abc, def)
+
+#test 2
+#pending
+func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
+  , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd)
+
+
+
+###############################################################################
+###############################################################################
+###############################################################################
+#group expression.do statements
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test simple
+func = do
+  stmt
+  stmt
+
+#test bind
+func = do
+  x <- stmt
+  stmt x
+
+#test let
+func = do
+  let x = 13
+  stmt x
+
+
+###############################################################################
+###############################################################################
+###############################################################################
+#group regression
+###############################################################################
+###############################################################################
+###############################################################################
+
+#test newlines-comment
+func = do
+  abc <- foo
+
+--abc
+return ()
+
+#test parenthesis-around-unit
+func = (())
+
+#test let-defs indentation
+func = do
+  let foo True = True
+      foo _    = False
+  return ()
+
+#test record update indentation 1
+func = do
+  s <- mGet
+  mSet $ s { _lstate_indent = _lstate_indent state }
+
+#test record update indentation 2
+func = do
+  s <- mGet
+  mSet $ s { _lstate_indent = _lstate_indent state
+           , _lstate_indent = _lstate_indent state
+           }
+
+#test record update indentation 3
+func = do
+  s <- mGet
+  mSet $ s
+    { _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    , _lstate_indent = _lstate_indent lkasdlkjalsdjlakjsdlkjasldkjalskdjlkajsd
+    }
+
+#test post-indent comment
+func = do
+-- abc
+  -- def
+  return ()
+
+#test post-unindent comment
+func = do
+  do
+    return ()
+    -- abc
+  -- def
+  return ()
+
+#test CPP empty comment case
+#pending CPP parsing needs fixing for roundTripEqual
+{-# 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.
+#test comment inline placement (temporary)
+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
+
+#test some indentation thingy
+func =
+  ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj
+  $ abc
+  $ def
+  $ ghi
+  $ jkl
+  )
+
+#test parenthesized operator
+buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)
+ where
+  reassoc (v, e, w) = (v, (e, w))
+
+#test record pattern matching stuff
+downloadRepoPackage = case repo of
+  RepoLocal {..}    -> return ()
+  RepoLocal { abc } -> return ()
+  RepoLocal{}       -> return ()
+
+#test do let comment indentation level problem
+func = do
+  let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'
+      (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''
+      -- default local dir target if there's no given target
+      utargets'' = "foo"
+  return ()
+
+#test list comprehension comment placement
+func =
+  [ (thing, take 10 alts) --TODO: select best ones
+  | (thing, _got, alts@(_:_)) <- nosuchFooThing
+  , gast                      <- award
+  ]
+
+#test if-then-else comment placement
+func = if x
+  then if y -- y is important
+    then foo
+    else bar
+  else Nothing
+
+#test qualified infix pattern
+#pending "TODO"
+wrapPatPrepend pat prepElem = do
+  patDocs <- layoutPat pat
+  case Seq.viewl patDocs of
+    Seq.EmptyL -> return $ Seq.empty
+    x1 Seq.:< xR -> do
+      x1' <- docSeq [prepElem, return x1]
+      return $ x1' Seq.<| xR
+
+#test type signature multiline forcing issue
+layoutWriteNewlineBlock
+  :: ( MonadMultiWriter Text.Builder.Builder m
+     , MonadMultiState LayoutState m
+     , MonadMultiWriter (Seq String) m
+     )
+  => m ()
+
+#test multiwayif proper indentation
+#pending "TODO"
+readMergePersConfig path shouldCreate conf = do
+  exists <- liftIO $ System.Directory.doesFileExist path
+  if
+    | exists -> do
+        contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.
+        fileConf <- case Data.Yaml.decodeEither contents of
+          Left e -> do
+            liftIO
+              $ putStrErrLn
+              $ "error reading in brittany config from " ++ path ++ ":"
+            liftIO $ putStrErrLn e
+            mzero
+          Right x -> return x
+        return $ fileConf Semigroup.<> conf
+    | shouldCreate -> do
+        liftIO $ ByteString.writeFile path
+               $ Data.Yaml.encode
+               $ cMap (Option . Just . runIdentity) staticDefaultConfig
+        return $ conf
+    | otherwise -> do
+        return conf
+
+#test nested pattern alignment issue"
+func = BuildReport
+ where
+  convertInstallOutcome = case result of
+    Left  BR.PlanningFailed      -> PlanningFailed
+    Left  (BR.DependentFailed p) -> DependencyFailed p
+    Left  (BR.DownloadFailed  _) -> DownloadFailed
+    Left  (BR.UnpackFailed    _) -> UnpackFailed
+    Left  (BR.ConfigureFailed _) -> ConfigureFailed
+    Left  (BR.BuildFailed     _) -> BuildFailed
+    Left  (BR.TestsFailed     _) -> TestsFailed
+    Left  (BR.InstallFailed   _) -> InstallFailed
+    Right (BR.BuildOk _ _ _    ) -> InstallOk
+
+#test nested pattern alignment issue"
+func = BuildReport
+ where
+  convertInstallOutcome = case result of
+    Left  BR.PlanningFailed      -> PlanningFailed
+    Left  (BR.DependentFailed p) -> DependencyFailed p
+    Left  (BR.DownloadFailed  _) -> DownloadFailed
+    Left  (BR.UnpackFailed    _) -> UnpackFailed
+    Left  (BR.ConfigureFailed _) -> ConfigureFailed
+    Left  (BR.BuildFailed     _) -> BuildFailed
+    Left  (BR.TestsFailed     _) -> TestsFailed
+    Left  (BR.InstallFailed   _) -> InstallFailed
+    Right (BR.BuildOk _ _ _    ) -> InstallOk
+
+#test partially overflowing alignment issue"
+showPackageDetailedInfo pkginfo =
+  renderStyle (style { lineLength = 80, ribbonsPerLine = 1 })
+    $   char '*'
+    $+$ something
+          [ entry "Synopsis" synopsis hideIfNull reflowParagraphs
+          , entry "Versions available"
+                  sourceVersions
+                  (altText null "[ Not available from server ]")
+                  (dispTopVersions 9 (preferredVersions pkginfo))
+          , entry
+            "Versions installed"
+            installedVersions
+            ( altText
+              null
+              (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")
+            )
+            (dispTopVersions 4 (preferredVersions pkginfo))
+          , entry "Homepage"      homepage     orNotSpecified  text
+          , entry "Bug reports"   bugReports   orNotSpecified  text
+          , entry "Description"   description  hideIfNull      reflowParagraphs
+          , entry "Category"      category     hideIfNull      text
+          , entry "License"       license      alwaysShow      disp
+          , entry "Author"        author       hideIfNull      reflowLines
+          , entry "Maintainer"    maintainer   hideIfNull      reflowLines
+          , entry "Source repo"   sourceRepo   orNotSpecified  text
+          , entry "Executables"   executables  hideIfNull      (commaSep text)
+          , entry "Flags" flags hideIfNull (commaSep dispFlag)
+          , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
+          , entry "Documentation" haddockHtml  showIfInstalled text
+          , entry "Cached"        haveTarball  alwaysShow      dispYesNo
+          , if not (hasLib pkginfo)
+          then
+            empty
+          else
+            text "Modules:"
+              $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
+          ]
+

src-unittests/IdentityTests.hs

@@ -1,780 +0,0 @@
-{-# 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
-    |]
-  it "simple constructor" $ roundTripEqual $
-    [text|
-    func (A a) = a
-    |]
-  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
-    |]
-  it "lambda" $ roundTripEqual $
-    [text|
-    func = \x -> abc
-    |]
-  describe "app" $ do
-    it "1" $ roundTripEqual $
-      [text|
-      func = klajsdas klajsdas klajsdas
-      |]
-    it "2" $ roundTripEqual $
-      [text|
-      func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
-        lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
-        lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
-      |]
-    it "3" $ roundTripEqual $
-      [text|
-      func = lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd lakjsdlajsdljas
-                                                           lakjsdlajsdljas
-                                                           lakjsdlajsdljas
-      |]
-  describe "sections" $ do
-    it "left" $ roundTripEqual $
-      [text|
-      func = (1+)
-      |]
-    it "right" $ roundTripEqual $
-      [text|
-      func = (+1)
-      |]
-    it "left inf" $ roundTripEqual $
-      -- TODO: this could be improved..
-      [text|
-      func = (1`abc`)
-      |]
-    it "right inf" $ roundTripEqual $
-      [text|
-      func = (`abc`1)
-      |]
-  describe "tuples" $ do
-    it "1" $ roundTripEqual $
-      [text|
-      func = (abc, def)
-      |]
-    before_ pending $ it "2" $ roundTripEqual $
-      [text|
-      func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
-        , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd)
-      |]
-
-
-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
-      |]
-  it "some indentation thingy" $ do
-    roundTripEqual $
-      [text|
-      func =
-        ( lkjadljasldjalskdjaldjalsdjkalsdjlaksdjlasjdlajsaldskj
-        $ abc
-        $ def
-        $ ghi
-        $ jkl
-        )
-      |]
-  it "parenthesized operator" $ do
-    roundTripEqual $
-      [text|
-      buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0)
-       where
-        reassoc (v, e, w) = (v, (e, w))
-      |]
-  it "record pattern matching stuff" $ do
-    roundTripEqual $
-      [text|
-      downloadRepoPackage = case repo of
-        RepoLocal {..}    -> return ()
-        RepoLocal { abc } -> return ()
-        RepoLocal{}       -> return ()
-      |]
-  it "do let comment indentation level problem" $ do
-    roundTripEqual $
-      [text|
-      func = do
-        let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs'
-            (bproblems, x) = resolveBuildTargets primaryPkg otherPkgs utargets''
-            -- default local dir target if there's no given target
-            utargets'' = "foo"
-        return ()
-      |]
-  it "list comprehension comment placement" $ do
-    roundTripEqual $
-      [text|
-      func =
-        [ (thing, take 10 alts) --TODO: select best ones
-        | (thing, _got, alts@(_:_)) <- nosuchFooThing
-        , gast                      <- award
-        ]
-      |]
-  it "if-then-else comment placement" $ do
-    roundTripEqual $
-      [text|
-      func = if x
-        then if y -- y is important
-          then foo
-          else bar
-        else Nothing
-      |]
-  it "qualified infix pattern" $ do
-    pendingWith "TODO"
-    roundTripEqual $
-      [text|
-      wrapPatPrepend pat prepElem = do
-        patDocs <- layoutPat pat
-        case Seq.viewl patDocs of
-          Seq.EmptyL -> return $ Seq.empty
-          x1 Seq.:< xR -> do
-            x1' <- docSeq [prepElem, return x1]
-            return $ x1' Seq.<| xR
-      |]
-  it "type signature multiline forcing issue" $ do
-    roundTripEqual $
-      [text|
-      layoutWriteNewlineBlock
-        :: ( MonadMultiWriter Text.Builder.Builder m
-           , MonadMultiState LayoutState m
-           , MonadMultiWriter (Seq String) m
-           )
-        => m ()
-      |]
-  it "multiwayif proper indentation" $ do
-    pendingWith "TODO"
-    roundTripEqual $
-      [text|
-      readMergePersConfig path shouldCreate conf = do
-        exists <- liftIO $ System.Directory.doesFileExist path
-        if
-          | exists -> do
-              contents <- liftIO $ ByteString.readFile path -- no lazy IO, tyvm.
-              fileConf <- case Data.Yaml.decodeEither contents of
-                Left e -> do
-                  liftIO
-                    $ putStrErrLn
-                    $ "error reading in brittany config from " ++ path ++ ":"
-                  liftIO $ putStrErrLn e
-                  mzero
-                Right x -> return x
-              return $ fileConf Semigroup.<> conf
-          | shouldCreate -> do
-              liftIO $ ByteString.writeFile path
-                     $ Data.Yaml.encode
-                     $ cMap (Option . Just . runIdentity) staticDefaultConfig
-              return $ conf
-          | otherwise -> do
-              return conf
-      |]
-  it "nested pattern alignment issue" $ do
-    roundTripEqual $
-      [text|
-      func = BuildReport
-       where
-        convertInstallOutcome = case result of
-          Left  BR.PlanningFailed      -> PlanningFailed
-          Left  (BR.DependentFailed p) -> DependencyFailed p
-          Left  (BR.DownloadFailed  _) -> DownloadFailed
-          Left  (BR.UnpackFailed    _) -> UnpackFailed
-          Left  (BR.ConfigureFailed _) -> ConfigureFailed
-          Left  (BR.BuildFailed     _) -> BuildFailed
-          Left  (BR.TestsFailed     _) -> TestsFailed
-          Left  (BR.InstallFailed   _) -> InstallFailed
-          Right (BR.BuildOk _ _ _    ) -> InstallOk
-      |]
-  it "nested pattern alignment issue" $ do
-    roundTripEqual $
-      [text|
-      func = BuildReport
-       where
-        convertInstallOutcome = case result of
-          Left  BR.PlanningFailed      -> PlanningFailed
-          Left  (BR.DependentFailed p) -> DependencyFailed p
-          Left  (BR.DownloadFailed  _) -> DownloadFailed
-          Left  (BR.UnpackFailed    _) -> UnpackFailed
-          Left  (BR.ConfigureFailed _) -> ConfigureFailed
-          Left  (BR.BuildFailed     _) -> BuildFailed
-          Left  (BR.TestsFailed     _) -> TestsFailed
-          Left  (BR.InstallFailed   _) -> InstallFailed
-          Right (BR.BuildOk _ _ _    ) -> InstallOk
-      |]
-  it "partially overflowing alignment issue" $ do
-    roundTripEqual $
-      [text|
-      showPackageDetailedInfo pkginfo =
-        renderStyle (style { lineLength = 80, ribbonsPerLine = 1 })
-          $   char '*'
-          $+$ something
-                [ entry "Synopsis" synopsis hideIfNull reflowParagraphs
-                , entry "Versions available"
-                        sourceVersions
-                        (altText null "[ Not available from server ]")
-                        (dispTopVersions 9 (preferredVersions pkginfo))
-                , entry
-                  "Versions installed"
-                  installedVersions
-                  ( altText
-                    null
-                    (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")
-                  )
-                  (dispTopVersions 4 (preferredVersions pkginfo))
-                , entry "Homepage"      homepage     orNotSpecified  text
-                , entry "Bug reports"   bugReports   orNotSpecified  text
-                , entry "Description"   description  hideIfNull      reflowParagraphs
-                , entry "Category"      category     hideIfNull      text
-                , entry "License"       license      alwaysShow      disp
-                , entry "Author"        author       hideIfNull      reflowLines
-                , entry "Maintainer"    maintainer   hideIfNull      reflowLines
-                , entry "Source repo"   sourceRepo   orNotSpecified  text
-                , entry "Executables"   executables  hideIfNull      (commaSep text)
-                , entry "Flags" flags hideIfNull (commaSep dispFlag)
-                , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
-                , entry "Documentation" haddockHtml  showIfInstalled text
-                , entry "Cached"        haveTarball  alwaysShow      dispYesNo
-                , if not (hasLib pkginfo)
-                then
-                  empty
-                else
-                  text "Modules:"
-                    $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))
-                ]
-      |]

src-unittests/TestMain.hs

@@ -12,7 +12,6 @@ import NeatInterpolation
 
 import Language.Haskell.Brittany
 
-import IdentityTests
 import AsymptoticPerfTests
 
 
@@ -22,5 +21,4 @@ main = hspec $ tests
 
 tests :: Spec
 tests = do
-  describe "identity roundtrips" $ identityTests
   describe "asymptotic perf roundtrips" $ asymptoticPerfTest

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

@@ -12,6 +12,7 @@ where
 #include "prelude.inc"
 
 import Data.Yaml
+import qualified Data.Aeson.Types as Aeson
 import GHC.Generics
 import Control.Lens
 
@@ -77,6 +78,13 @@ data ConfigF f = Config
   }
   deriving (Generic)
 
+data ErrorHandlingConfigFMaybe = ErrorHandlingConfigMaybe
+  { _econfm_produceOutputOnErrors :: Maybe (Semigroup.Last Bool)
+  , _econfm_Werror                :: Maybe (Semigroup.Last Bool)
+  , _econfm_CPPMode               :: Maybe (Semigroup.Last CPPMode)
+  }
+  deriving (Generic)
+
 -- i wonder if any Show1 stuff could be leveraged.
 deriving instance Show (DebugConfigF Identity)
 deriving instance Show (LayoutConfigF Identity)
@@ -112,43 +120,88 @@ type DebugConfig = DebugConfigF Identity
 type LayoutConfig = LayoutConfigF Identity
 type ErrorHandlingConfig = ErrorHandlingConfigF Identity
 
-instance FromJSON a => FromJSON (Semigroup.Last a) where
+aesonDecodeOptionsBrittany :: Aeson.Options
-  parseJSON obj = Semigroup.Last <$> parseJSON obj
+aesonDecodeOptionsBrittany = Aeson.defaultOptions
-  {-# INLINE parseJSON #-}
+  { Aeson.omitNothingFields = True
-instance ToJSON a => ToJSON (Semigroup.Last a) where
+  , Aeson.fieldLabelModifier = dropWhile (=='_')
-  toJSON (Semigroup.Last x) = toJSON x
+  }
-  {-# INLINE toJSON #-}
 
-instance FromJSON a => FromJSON (Option a) where
+-- instance FromJSON a => FromJSON (Semigroup.Last a) where
-  parseJSON obj = Option <$> parseJSON obj
+--   parseJSON obj = Semigroup.Last <$> parseJSON obj
-  {-# INLINE parseJSON #-}
+--   {-# INLINE parseJSON #-}
-instance ToJSON a => ToJSON (Option a) where
+-- instance ToJSON a => ToJSON (Semigroup.Last a) where
-  toJSON (Option x) = toJSON x
+--   toJSON (Semigroup.Last x) = toJSON x
-  {-# INLINE toJSON #-}
+--   {-# INLINE toJSON #-}
+--
+-- instance FromJSON a => FromJSON (Option a) where
+--   parseJSON obj = Option <$> parseJSON obj
+--   {-# INLINE parseJSON #-}
+-- instance ToJSON a => ToJSON (Option a) where
+--   toJSON (Option x) = toJSON x
+--   {-# INLINE toJSON #-}
 
-instance FromJSON (DebugConfigF Option)
+#define makeFromJSON(type)\
-instance ToJSON   (DebugConfigF Option)
+  instance FromJSON (type) where\
+    parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany
+#define makeToJSON(type)\
+  instance ToJSON (type) where\
+    toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
 
-instance FromJSON IndentPolicy
+#define makeFromJSONMaybe(type)\
-instance ToJSON   IndentPolicy
+  instance FromJSON (type Maybe) where\
-instance FromJSON AltChooser
+    parseJSON = Aeson.genericParseJSON aesonDecodeOptionsBrittany
-instance ToJSON   AltChooser
+#define makeFromJSONOption(type)\
-instance FromJSON ColumnAlignMode
+  instance FromJSON (type Option) where\
-instance ToJSON   ColumnAlignMode
+    parseJSON = fmap (cMap Option) . parseJSON
-instance FromJSON CPPMode
+#define makeToJSONMaybe(type)\
-instance ToJSON   CPPMode
+  instance ToJSON (type Maybe) where\
+    toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
+#define makeToJSONOption(type)\
+  instance ToJSON (type Option) where\
+    toEncoding = toEncoding . cMap getOption
 
-instance FromJSON (LayoutConfigF Option)
+makeFromJSON(ErrorHandlingConfigFMaybe)
-instance ToJSON   (LayoutConfigF Option)
+makeToJSON  (ErrorHandlingConfigFMaybe)
+deriving instance Show (ErrorHandlingConfigFMaybe)
 
-instance FromJSON (ErrorHandlingConfigF Option)
-instance ToJSON   (ErrorHandlingConfigF Option)
 
-instance FromJSON (ForwardOptionsF Option)
+makeFromJSONOption (DebugConfigF)
-instance ToJSON   (ForwardOptionsF Option)
+makeFromJSONMaybe  (DebugConfigF)
+makeToJSONOption   (DebugConfigF)
+makeToJSONMaybe    (DebugConfigF)
+-- instance FromJSON (DebugConfigF Option) where
+--   parseJSON = genericParseJSON aesonDecodeOptionsBrittany
+-- instance ToJSON   (DebugConfigF Option) where
+--   toEncoding = Aeson.genericToEncoding aesonDecodeOptionsBrittany
 
-instance FromJSON (ConfigF Option)
+makeFromJSON (IndentPolicy)
-instance ToJSON   (ConfigF Option)
+makeToJSON   (IndentPolicy)
+makeFromJSON (AltChooser)
+makeToJSON   (AltChooser)
+makeFromJSON (ColumnAlignMode)
+makeToJSON   (ColumnAlignMode)
+makeFromJSON (CPPMode)
+makeToJSON   (CPPMode)
+
+makeFromJSONOption (LayoutConfigF)
+makeFromJSONMaybe  (LayoutConfigF)
+makeToJSONOption   (LayoutConfigF)
+makeToJSONMaybe    (LayoutConfigF)
+
+makeFromJSONOption (ErrorHandlingConfigF)
+makeFromJSONMaybe  (ErrorHandlingConfigF)
+makeToJSONOption   (ErrorHandlingConfigF)
+makeToJSONMaybe    (ErrorHandlingConfigF)
+
+makeFromJSONOption (ForwardOptionsF)
+makeFromJSONMaybe  (ForwardOptionsF)
+makeToJSONOption   (ForwardOptionsF)
+makeToJSONMaybe    (ForwardOptionsF)
+
+makeFromJSONOption (ConfigF)
+makeFromJSONMaybe  (ConfigF)
+makeToJSONOption   (ConfigF)
+makeToJSONMaybe    (ConfigF)
 
 -- instance Monoid DebugConfig where
 --   mempty = DebugConfig Nothing Nothing

stack.yaml

@@ -7,7 +7,7 @@ packages:
 - .
 - extra-dep: true
   location:
-    commit: 8b721f7e17a20a338432f1d31ef55db5e50b8e8d
+    commit: b15f1ae585341ea312f712e63f29a0c57fa5f637
     git: https://github.com/lspitzner/butcher.git
 - extra-dep: true
   location:
@@ -17,4 +17,4 @@ packages:
   location:
     commit: 85af8e4f34ff013575c9acd9675b495ee7f10180
     git: https://github.com/lspitzner/ghc-exactprint.git
-resolver: nightly-2016-09-04
+resolver: nightly-2016-12-04