Merge branch 'dev'

.travis.yml

@@ -115,7 +115,7 @@ matrix:
   #- env: BUILD=stack ARGS="--resolver lts-7"
   #  compiler: ": #stack 8.0.1"
   #  addons: {apt: {packages: [libgmp-dev]}}
-  - env: BUILD=stack ARGS="--resolver lts-8"
+  - env: BUILD=stack ARGS="--stack-yaml stack-8.0.2.yaml"
     compiler: ": #stack 8.0.2"
     addons: {apt: {packages: [libgmp-dev]}}
 
@@ -178,7 +178,7 @@ before_install:
   #  echo 'jobs: $ncpus' >> $HOME/.cabal/config
   #fi
 - PKGNAME='brittany'
-- JOBS='2'
+- JOBS='1'
 - |
   function better_wait() {
     date
@@ -209,7 +209,7 @@ install:
   set -ex
   case "$BUILD" in
     stack)
-      stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies
+      stack -j$JOBS --no-terminal --install-ghc $ARGS test --bench --only-dependencies
       ;;
     cabal*)
       cabal --version
@@ -250,6 +250,8 @@ install:
       cabal --version
       travis_retry cabal update -v
       echo 'packages: .' > cabal.project
+      echo 'package brittany'        > cabal.project.local
+      echo '  ghc-options: -Werror' >> cabal.project.local
       rm -f cabal.project.freeze
       cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep
       cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep
@@ -262,12 +264,12 @@ script:
   set -ex
   case "$BUILD" in
     stack)
-      better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS"
+      better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror"
       ;;
     cabal)
       if [ -f configure.ac ]; then autoreconf -i; fi
       cabal configure --enable-tests --enable-benchmarks -v  # -v2 provides useful information for debugging
-      better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" # this builds all libraries and executables (including tests/benchmarks)
+      better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks)
       cabal test
       ;;
     cabaldist)

ChangeLog.md

@@ -1,5 +1,21 @@
 # Revision history for brittany
 
+## 0.9.0.1  -- February 2018
+
+* Support `TupleSections` (thanks to Matthew Piziak)
+* Bugfixes:
+    - Fix Shebang handling with stdin input (#92)
+    - Fix bug that effectively deleted strict/lazy matches (BangPatterns) (#116)
+    - Fix infix operator whitespace bug (#101, #114)
+    - Fix help command output and its layouting (#103)
+    - Fix crash when config dir does not exist yet (#115)
+* Layouting changes:
+    - no space after opening non-tuple parenthesis even for multi-line case
+    - use spaces around infix operators (applies to sections and in pattern
+      matches)
+    - Let-in is layouted more flexibly in fewer lines, if possible
+      (thanks to Evan Borden)
+
 ## 0.9.0.0  -- December 2017
 
 * Change default global config path (use XDG spec)

brittany.cabal

@@ -1,5 +1,5 @@
 name:                 brittany
-version:              0.9.0.0
+version:              0.9.0.1
 synopsis:             Haskell source code formatter
 description: {
   See <https://github.com/lspitzner/brittany/blob/master/README.md the README>.
@@ -82,7 +82,7 @@ library {
     { base >=4.9 && <4.11
     , ghc >=8.0.1 && <8.3
     , ghc-paths >=0.1.0.9 && <0.2
-    , ghc-exactprint >=0.5.3.0 && <0.6
+    , ghc-exactprint >=0.5.6.0 && <0.5.7
     , transformers >=0.5.2.0 && <0.6
     , containers >=0.5.7.1 && <0.6
     , mtl >=2.2.1 && <2.3
@@ -94,7 +94,7 @@ library {
     , pretty >=1.1.3.3 && <1.2
     , bytestring >=0.10.8.1 && <0.11
     , directory >=1.2.6.2 && <1.4
-    , butcher >=1.2 && <1.3
+    , butcher >=1.3 && <1.4
     , yaml >=0.8.18 && <0.9
     , aeson >=1.0.1.0 && <1.3
     , extra >=1.4.10 && <1.7

doc-svg-gen/doc-svg-gen.cabal

@@ -5,12 +5,12 @@ extra-source-files:  ChangeLog.md
 cabal-version:       >=1.10
 
 executable doc-svg-gen
-  buildable:           True
+  buildable:           False
   main-is:             Main.hs
   -- other-modules:       
   -- other-extensions:    
   build-depends:
-    { base >=4.9 && <4.10
+    { base >=4.9 && <4.11
     , text
     , graphviz >=2999.19.0.0
     }

src-brittany/Main.hs

@@ -82,9 +82,10 @@ helpDoc = PP.vcat $ List.intersperse
       ]
   , parDocW
     [ "This program is written carefully and contains safeguards to ensure"
-    , "the transformation does not change semantics (or the syntax tree at all)"
+    , "the output is syntactically valid and that no comments are removed."
-    , "and that no comments are removed."
+    , "Nonetheless, this is a young project, and there will always be bugs,"
-    , "Nonetheless, this is a young project, and there will always be bugs."
+    , "and ensuring that the transformation never changes semantics of the"
+    , "transformed source is currently not possible."
     , "Please do check the output and do not let brittany override your large"
     , "codebase without having backups."
     ]
@@ -140,16 +141,16 @@ mainCmdParser helpDesc = do
     ""
     ["write-mode"]
     "(display|inplace)"
-    Flag
+    (  flagHelp
-      { _flag_help    = Just $ PP.vcat
+        ( PP.vcat
           [ PP.text "display: output for any input(s) goes to stdout"
           , PP.text "inplace: override respective input file (without backup!)"
           ]
-      , _flag_default = Just Display
+        )
-      }
+    <> flagDefault Display
-  inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input haskell source files")
+    )
+  inputParams <- addParamNoFlagStrings "PATH" (paramHelpStr "paths to input/inout haskell source files")
   reorderStop
-  desc        <- peekCmdDesc
   addCmdImpl $ void $ do
     when printLicense $ do
       print licenseDoc
@@ -161,7 +162,7 @@ mainCmdParser helpDesc = do
         putStrLn $ "There is NO WARRANTY, to the extent permitted by law."
       System.Exit.exitSuccess
     when printHelp $ do
-      liftIO $ print $ ppHelpShallow desc
+      liftIO $ putStrLn $ PP.renderStyle PP.style { PP.ribbonsPerLine = 1.0 } $ ppHelpShallow helpDesc
       System.Exit.exitSuccess
 
     let inputPaths  = if null inputParams then [Nothing] else map Just inputParams
@@ -281,7 +282,7 @@ coreIO putErrorLnIO config suppressOutput inputPathM outputPathM = ExceptT.runEx
             putErrorLn
               $  "Error: detected unprocessed comments."
               ++ " The transformation output will most likely"
-              ++ " not contain certain of the comments"
+              ++ " not contain some of the comments"
               ++ " present in the input haskell source file."
             putErrorLn $ "Affected are the following comments:"
             unused `forM_` \case
@@ -346,7 +347,7 @@ readConfigs cmdlineConfig configPaths = do
       userConfigXdg    <- readConfig userConfigPathXdg
       let userConfig = userConfigSimple <|> userConfigXdg
       when (Data.Maybe.isNothing userConfig) $ do
-        liftIO $ Directory.createDirectoryIfMissing False userBritPathXdg
+        liftIO $ Directory.createDirectoryIfMissing True userBritPathXdg
         writeDefaultConfig userConfigPathXdg
       -- rightmost has highest priority
       pure $ [userConfig, localConfig]

src-literatetests/10-tests.blt

@@ -355,6 +355,9 @@ func (x:xr) = x
 #pending
 func (x :+: xr) = x
 
+#test normal infix constructor
+func (x `Foo` xr) = x
+
 
 ###############################################################################
 ###############################################################################
@@ -476,9 +479,23 @@ func = (`abc` 1)
 #group tuples
 ###
 
-#test 1
+#test pair
 func = (abc, def)
 
+#test pair section left
+func = (abc, )
+
+#test pair section right
+func = (, abc)
+
+#test quintuple section long
+myTupleSection =
+  ( verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargefirstelement
+  ,
+  , verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargethirdelement
+  ,
+  )
+
 #test 2
 #pending
 func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd

src-literatetests/15-regressions.blt

@@ -513,3 +513,15 @@ cs0 = 0 : [ c / Interval n | c <- cs | n <- [1..] ]
 #test issue 70
 {-# LANGUAGE TemplateHaskell #-}
 deriveFromJSON (unPrefix "assignPost") ''AssignmentPost
+
+#test issue 116
+{-# LANGUAGE BangPatterns #-}
+func = do
+  let !forced = some
+  pure ()
+
+#test let-in-hanging
+spanKey p q = case minViewWithKey q of
+  Just ((k, _), q') | p k ->
+    let (kas, q'') = spanKey p q' in ((k, a) : kas, q'')
+  _ -> ([], q)

src-literatetests/Main.hs

@@ -173,6 +173,7 @@ defaultTestConfig = Config
     , _lconfig_columnAlignMode           = coerce (ColumnAlignModeMajority 0.7)
     , _lconfig_alignmentLimit            = coerce (30 :: Int)
     , _lconfig_alignmentBreakOnMultiline = coerce True
+    , _lconfig_hangingTypeSignature      = coerce False
     }
   , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)
     { _econf_omit_output_valid_check = coerce True

src-literatetests/tests-context-free.blt

@@ -510,6 +510,11 @@ func = (abc, def)
 func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd
   , lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd)
 
+#test let in on single line
+foo =
+  let longIdentifierForShortValue = 1
+  in longIdentifierForShortValue + longIdentifierForShortValue
+
 
 
 ###############################################################################

src-unittests/TestUtils.hs

@@ -55,6 +55,7 @@ defaultTestConfig = Config
     , _lconfig_columnAlignMode           = coerce (ColumnAlignModeMajority 0.7)
     , _lconfig_alignmentLimit            = coerce (30 :: Int)
     , _lconfig_alignmentBreakOnMultiline = coerce True
+    , _lconfig_hangingTypeSignature      = coerce False
     }
   , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)
     { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever

src/Language/Haskell/Brittany/Internal.hs

@@ -61,6 +61,11 @@ import qualified GHC.LanguageExtensions.Type as GHC
 --
 -- Note that this function ignores/resets all config values regarding
 -- debugging, i.e. it will never use `trace`/write to stderr.
+--
+-- Note that the ghc parsing function used internally currently is wrapped in
+-- `mask_`, so cannot be killed easily. If you don't control the input, you
+-- may wish to put some proper upper bound on the input's size as a timeout
+-- won't do.
 parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text)
 parsePrintModule configRaw inputText = runExceptT $ do
   let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig }

src/Language/Haskell/Brittany/Internal/Backend.hs

@@ -352,7 +352,11 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
       -- maxZipper xs [] = xs
       -- maxZipper (x:xr) (y:yr) = max x y : maxZipper xr yr
       colAggregation :: [Int] -> Int
-      colAggregation xs = maximum [ x | x <- xs, x < minimum xs + alignMax ]
+      colAggregation [] = 0 -- this probably cannot happen the way we call
+                            -- this function, because _cbs_map only ever
+                            -- contains nonempty Seqs.
+      colAggregation xs = maximum [ x | x <- xs, x <= minimum xs + alignMax' ]
+        where alignMax' = max 0 alignMax
 
       processedMap :: ColMap2
       processedMap =

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

@@ -63,6 +63,7 @@ staticDefaultConfig = Config
     , _lconfig_columnAlignMode           = coerce (ColumnAlignModeMajority 0.7)
     , _lconfig_alignmentLimit            = coerce (30 :: Int)
     , _lconfig_alignmentBreakOnMultiline = coerce True
+    , _lconfig_hangingTypeSignature      = coerce False
     }
   , _conf_errorHandling = ErrorHandlingConfig
     { _econf_produceOutputOnErrors   = coerce False
@@ -104,7 +105,7 @@ configParser = do
   cols               <- addFlagReadParams "" ["columns"] "AMOUNT" (flagHelpStr "target max columns (80 is an old default for this)")
   importCol          <- addFlagReadParams "" ["import-col"] "N" (flagHelpStr "column to align import lists at")
 
-  dumpConfig         <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (commandline + file + defaults)")
+  dumpConfig         <- addSimpleBoolFlag "" ["dump-config"] (flagHelp $ parDoc "dump the programs full config (merged commandline + file + defaults)")
   dumpAnnotations    <- addSimpleBoolFlag "" ["dump-annotations"] (flagHelp $ parDoc "dump the full annotations returned by ghc-exactprint")
   dumpUnknownAST     <- addSimpleBoolFlag "" ["dump-ast-unknown"] (flagHelp $ parDoc "dump the ast for any nodes not transformed, but copied as-is by brittany")
   dumpCompleteAST    <- addSimpleBoolFlag "" ["dump-ast-full"] (flagHelp $ parDoc "dump the full ast")
@@ -118,9 +119,9 @@ configParser = do
   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")
+  outputOnErrors <- addSimpleBoolFlag "" ["output-on-errors"] (flagHelp $ parDoc "even when there are errors, produce output (or try to to the degree possible)")
   wError            <- addSimpleBoolFlag "" ["werror"] (flagHelp $ parDoc "treat warnings as errors")
-  omitValidCheck    <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid; for dev on brittany")
+  omitValidCheck    <- addSimpleBoolFlag "" ["omit-output-check"] (flagHelp $ parDoc "omit checking if the output is syntactically valid (debugging)")
 
   roundtripOnly    <- addSimpleBoolFlag "" ["exactprint-only"] (flagHelp $ parDoc "do not reformat, but exclusively use exactprint to roundtrip (debugging)")
 
@@ -156,6 +157,7 @@ configParser = do
       , _lconfig_columnAlignMode           = mempty
       , _lconfig_alignmentLimit            = mempty
       , _lconfig_alignmentBreakOnMultiline = mempty
+      , _lconfig_hangingTypeSignature      = mempty
       }
     , _conf_errorHandling = ErrorHandlingConfig
       { _econf_produceOutputOnErrors   = wrapLast $ falseToNothing outputOnErrors

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

@@ -73,6 +73,17 @@ data CLayoutConfig f = LayoutConfig
     --     short <- some more stuff
     --       that requires two lines
     --     loooooooong <- stuff
+  , _lconfig_hangingTypeSignature :: f (Last Bool)
+    -- Do not put "::" in a new line, and use hanging indentation for the
+    -- signature, i.e.:
+    -- func :: SomeLongStuff
+    --      -> SomeLongStuff
+    -- instead of the usual
+    -- func
+    --   :: SomeLongStuff
+    --   -> SomeLongStuff
+    -- As usual for hanging indentation, the result will be
+    -- context-sensitive (in the function name).
   }
   deriving (Generic)
 

src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs

@@ -24,11 +24,17 @@ import qualified DynFlags      as GHC
 import qualified GHC           as GHC hiding (parseModule)
 import qualified Parser        as GHC
 import qualified SrcLoc        as GHC
+import qualified FastString    as GHC
+import qualified GHC           as GHC hiding (parseModule)
+import qualified Lexer         as GHC
+import qualified StringBuffer  as GHC
+import qualified Outputable    as GHC
 import           RdrName ( RdrName(..) )
 import           HsSyn
 import           SrcLoc ( SrcSpan, Located )
 import           RdrName ( RdrName(..) )
 
+
 import qualified Language.Haskell.GHC.ExactPrint            as ExactPrint
 import qualified Language.Haskell.GHC.ExactPrint.Annotate   as ExactPrint
 import qualified Language.Haskell.GHC.ExactPrint.Types      as ExactPrint
@@ -37,6 +43,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint
 import qualified Language.Haskell.GHC.ExactPrint.Delta      as ExactPrint
 
 import qualified Data.Generics as SYB
+
+import           Control.Exception
 -- import           Data.Generics.Schemes
 
 
@@ -85,7 +93,14 @@ parseModuleFromString
   -> String
   -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a))
 parseModuleFromString args fp dynCheck str =
-  ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
+  -- We mask here because otherwise using `throwTo` (i.e. for a timeout) will
+  -- produce nasty looking errors ("ghc panic"). The `mask_` makes it so we
+  -- cannot kill the parsing thread - not very nice. But i'll
+  -- optimistically assume that most of the time brittany uses noticable or
+  -- longer time, the majority of the time is not spend in parsing, but in
+  -- bridoc transformation stuff.
+  -- (reminder to update note on `parsePrintModule` if this changes.)
+  mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do
     dflags0                       <- lift $ ExactPrint.initDynFlagsPure fp str
     (dflags1, leftover, warnings) <- lift
       $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args)
@@ -97,12 +112,12 @@ parseModuleFromString args fp dynCheck str =
       $  ExceptT.throwE
       $  "when parsing ghc flags: encountered warnings: "
       ++ show (warnings <&> \(L _ s) -> s)
-    x <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
+    dynCheckRes <- ExceptT.ExceptT $ liftIO $ dynCheck dflags1
-    either (\(span, err) -> ExceptT.throwE $ show span ++ ": " ++ err)
+    let res = ExactPrint.parseModuleFromStringInternal dflags1 fp str
-           (\(a, m) -> pure (a, m, x))
+    case res of
-      $ ExactPrint.parseWith dflags1 fp GHC.parseModule str
+      Left  (span, err) -> ExceptT.throwE $ show span ++ ": " ++ err
+      Right (a   , m  ) -> pure (a, m, dynCheckRes)
 
------------
 
 commentAnnFixTransformGlob :: SYB.Data ast => ast -> ExactPrint.Transform ()
 commentAnnFixTransformGlob ast = do

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

@@ -52,6 +52,22 @@ layoutSig lsig@(L _loc sig) = case sig of
     let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
     typeDoc     <- docSharedWrapper layoutType typ
     hasComments <- hasAnyCommentsBelow lsig
+    shouldBeHanging <- mAsk
+      <&> _conf_layout
+      .>  _lconfig_hangingTypeSignature
+      .>  confUnpack
+    if shouldBeHanging
+      then docSeq
+        [ appSep $ docWrapNodeRest lsig $ docLit nameStr
+        , docSetBaseY $ docLines
+          [ docCols
+            ColTyOpPrefix
+            [ docLit $ Text.pack ":: "
+            , docAddBaseY (BrIndentSpecial 3) $ typeDoc
+            ]
+          ]
+        ]
+      else
         docAlt
           $  [ docSeq
                [ appSep $ docWrapNodeRest lsig $ docLit nameStr
@@ -176,10 +192,11 @@ layoutPatternBind
   -> BriDocNumbered
   -> LMatch RdrName (LHsExpr RdrName)
   -> ToBriDocM BriDocNumbered
-layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhss whereBinds))) = do
+layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match fixityOrCtx pats _ (GRHSs grhss whereBinds))) = do
   patDocs <- pats `forM` \p -> fmap return $ colsWrapPat =<< layoutPat p
   let isInfix = isInfixMatch match
-  patDoc     <- docWrapNodePrior lmatch $ case (mIdStr, patDocs) of
+  let mIdStr' = fixPatternBindIdentifier fixityOrCtx <$> mIdStr
+  patDoc <- docWrapNodePrior lmatch $ case (mIdStr', patDocs) of
     (Just idStr, p1 : pr) | isInfix -> docCols
       ColPatternsFuncInfix
       (  [appSep $ docForceSingleline p1, appSep $ docLit idStr]
@@ -204,6 +221,28 @@ layoutPatternBind mIdStr binderDoc lmatch@(L _ match@(Match _ pats _ (GRHSs grhs
                          mWhereDocs
                          hasComments
 
+#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
+fixPatternBindIdentifier
+  :: HsMatchContext (NameOrRdrName RdrName) -> Text -> Text
+fixPatternBindIdentifier ctx idStr = case ctx of
+  (FunRhs _ _ SrcLazy    ) -> Text.cons '~' idStr
+  (FunRhs _ _ SrcStrict  ) -> Text.cons '!' idStr
+  (FunRhs _ _ NoSrcStrict) -> idStr
+  (StmtCtxt ctx1         ) -> fixPatternBindIdentifier' ctx1
+  _                        -> idStr
+ where
+  -- I have really no idea if this path ever occurs, but better safe than
+  -- risking another "drop bangpatterns" bugs.
+  fixPatternBindIdentifier' = \case
+    (PatGuard      ctx1) -> fixPatternBindIdentifier ctx1 idStr
+    (ParStmtCtxt   ctx1) -> fixPatternBindIdentifier' ctx1
+    (TransStmtCtxt ctx1) -> fixPatternBindIdentifier' ctx1
+    _                    -> idStr
+#else                      /* ghc-8.0 */
+fixPatternBindIdentifier :: MatchFixity RdrName -> Text -> Text
+fixPatternBindIdentifier _ x = x
+#endif
+
 layoutPatternBindFinal
   :: Maybe Text
   -> BriDocNumbered
@@ -261,10 +300,13 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
       ]
   let singleLineGuardsDoc guards = appSep $ case guards of
         []  -> docEmpty
-        [g] -> docSeq [appSep $ docLit $ Text.pack "|", return g]
+        [g] -> docSeq
+               [appSep $ docLit $ Text.pack "|", docForceSingleline $ return g]
         gs  -> docSeq
             $  [appSep $ docLit $ Text.pack "|"]
-            ++ List.intersperse docCommaSep (return <$> gs)
+            ++ (List.intersperse docCommaSep
+                                 (docForceSingleline . return <$> gs)
+               )
 
   indentPolicy <- mAsk
     <&> _conf_layout

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

@@ -327,7 +327,7 @@ layoutExpr lexpr@(L _ expr) = do
           ]
         , docSetBaseY $ docLines
           [ docCols ColOpPrefix
-            [ docParenLSep
+            [ docLit $ Text.pack "("
             , docAddBaseY (BrIndentSpecial 2) innerExpDoc
             ]
           , docLit $ Text.pack ")"
@@ -341,9 +341,9 @@ layoutExpr lexpr@(L _ expr) = do
       opDoc    <- docSharedWrapper layoutExpr op
       rightDoc <- docSharedWrapper layoutExpr right
       docSeq [opDoc, docSeparator, rightDoc]
-    ExplicitTuple args boxity
+    ExplicitTuple args boxity -> do
-      | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do
+      let argExprs = fmap (\case (L _ (Present e)) -> Just e; (L _ (Missing PlaceHolder)) -> Nothing) args
-      argDocs <- docSharedWrapper layoutExpr `mapM` argExprs
+      argDocs <- docSharedWrapper (maybe docEmpty layoutExpr) `mapM` argExprs
       hasComments <- hasAnyCommentsBelow lexpr
       let (openLit, closeLit) = case boxity of
             Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")")
@@ -385,8 +385,6 @@ layoutExpr lexpr@(L _ expr) = do
                 end   = closeLit
               in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end]
             ]
-    ExplicitTuple{} ->
-      unknownNodeError "ExplicitTuple|.." lexpr 
     HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do
       cExpDoc <- docSharedWrapper layoutExpr cExp
       binderDoc <- docLit $ Text.pack "->"
@@ -533,6 +531,10 @@ layoutExpr lexpr@(L _ expr) = do
     HsLet binds exp1 -> do
       expDoc1 <- docSharedWrapper layoutExpr exp1
       mBindDocs <- layoutLocalBinds binds
+      let
+        ifIndentLeftElse :: a -> a -> a
+        ifIndentLeftElse x y =
+          if indentPolicy == IndentPolicyLeft then x else y
       -- this `docSetIndentLevel` might seem out of place, but is here due to
       -- ghc-exactprint's DP handling of "let" in particular.
       -- Just pushing another indentation level is a straightforward approach
@@ -540,39 +542,36 @@ layoutExpr lexpr@(L _ expr) = do
       -- if "let" is moved horizontally as part of the transformation, as the
       -- comments before the first let item are moved horizontally with it.
       docSetIndentLevel $ case mBindDocs of
-        Just [bindDoc] -> docAltFilter
+        Just [bindDoc] -> docAlt
-          [ ( True
+          [ docSeq
-            , docSeq
               [ appSep $ docLit $ Text.pack "let"
               , appSep $ docForceSingleline $ return bindDoc
               , appSep $ docLit $ Text.pack "in"
               , docForceSingleline $ expDoc1
               ]
-            )
-          , ( indentPolicy /= IndentPolicyLeft
           , docLines
+              [ docAlt
                   [ docSeq
                       [ appSep $ docLit $ Text.pack "let"
-                , docSetBaseAndIndent $ return bindDoc
+                      , ifIndentLeftElse docForceSingleline docSetBaseAndIndent
+                      $ return bindDoc
                       ]
-              , docSeq
-                [ appSep $ docLit $ Text.pack "in "
-                , docSetBaseY $ expDoc1
-                ]
-              ]
-            )
-          , ( True
-            , docLines
-              [ docAddBaseY BrIndentRegular
-              $ docPar
-                (appSep $ docLit $ Text.pack "let")
-                (docSetBaseAndIndent $ return bindDoc)
                   , docAddBaseY BrIndentRegular
                   $ docPar
-                (appSep $ docLit $ Text.pack "in")
+                    (docLit $ Text.pack "let")
+                    (docSetBaseAndIndent $ return bindDoc)
+                  ]
+              , docAlt
+                  [ docSeq
+                      [ appSep $ docLit $ Text.pack $ ifIndentLeftElse "in" "in "
+                      , ifIndentLeftElse docForceSingleline docSetBaseAndIndent expDoc1
+                      ]
+                  , docAddBaseY BrIndentRegular
+                  $ docPar
+                    (docLit $ Text.pack "in")
                     (docSetBaseY $ expDoc1)
                   ]
-            )
+              ]
           ]
         Just bindDocs@(_:_) -> docAltFilter
           --either

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

@@ -24,12 +24,26 @@ import           Language.Haskell.Brittany.Internal.Layouters.Type
 
 
 
+-- | layouts patterns (inside function bindings, case alternatives, let
+-- bindings or do notation). E.g. for input
+--        > case computation of
+--        >   (warnings, Success a b) -> ..
+-- This part  ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by
+-- 'layoutPat'. Similarly for
+-- > func abc True 0 = []
+--        ^^^^^^^^^^ this part
+-- We will use `case .. of` as the imagined prefix to the examples used in
+-- the different cases below.
 layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered)
 layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
   WildPat _  -> fmap Seq.singleton $ docLit $ Text.pack "_"
+    -- _ -> expr
   VarPat n   -> fmap Seq.singleton $ docLit $ lrdrNameToText n
+    -- abc -> expr
   LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit
+    -- 0 -> expr
   ParPat inner -> do
+    -- (nestedpat) -> expr
     left  <- docLit $ Text.pack "("
     right <- docLit $ Text.pack ")"
     innerDocs <- colsWrapPat =<< layoutPat inner
@@ -49,6 +63,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
     --       xN' <- docSeq [return xN, docLit $ Text.pack ")"]
     --       return $ (x1' Seq.<| middle) Seq.|> xN'
   ConPatIn lname (PrefixCon args) -> do
+    -- Abc a b c -> expr
     let nameDoc = lrdrNameToText lname
     argDocs <- layoutPat `mapM` args
     if null argDocs
@@ -61,15 +76,19 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
           $ fmap colsWrapPat argDocs
         return $ x1 Seq.<| xR
   ConPatIn lname (InfixCon left right) -> do
-    let nameDoc = lrdrNameToText lname
+    -- a :< b -> expr
-    leftDoc  <- colsWrapPat =<< layoutPat left
+    nameDoc <- lrdrNameToTextAnn lname
+    leftDoc <- appSep . colsWrapPat =<< layoutPat left
     rightDoc <- colsWrapPat =<< layoutPat right
-    middle <- docLit nameDoc
+    middle <- appSep $ docLit nameDoc
     return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc
   ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do
+    -- Abc{} -> expr
     let t = lrdrNameToText lname
     fmap Seq.singleton $ docLit $ t <> Text.pack "{}"
   ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do
+    -- Abc { a = locA, b = locB, c = locC } -> expr1
+    -- Abc { a, b, c } -> expr2
     let t = lrdrNameToText lname
     fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do
       fExpDoc <- if pun
@@ -91,12 +110,14 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
       , docLit $ Text.pack "}"
       ]
   ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do
+    -- Abc { .. } -> expr
     let t = lrdrNameToText lname
     fmap Seq.singleton $ docSeq
       [ appSep $ docLit t
       , docLit $ Text.pack "{..}"
       ]
   ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do
+    -- Abc { a = locA, .. }
     let t = lrdrNameToText lname
     fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do
       fExpDoc <- if pun
@@ -117,16 +138,20 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
       , docLit $ Text.pack "..}"
       ]
   TuplePat args boxity _ -> do
+    -- (nestedpat1, nestedpat2, nestedpat3) -> expr
+    -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr
     case boxity of
       Boxed   -> wrapPatListy args "(" ")"
       Unboxed -> wrapPatListy args "(#" "#)"
   AsPat asName asPat -> do
+    -- bind@nestedpat -> expr
     wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")
 #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
   SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do
 #else /* ghc-8.0 */
   SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do
 #endif
+    -- i :: Int -> expr
     patDocs <- layoutPat pat1
     tyDoc <- docSharedWrapper layoutType ty1
     case Seq.viewr patDocs of
@@ -146,12 +171,17 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
           ]
         return $ xR Seq.|> xN'
   ListPat elems _ _ ->
+    -- [] -> expr1
+    -- [nestedpat1, nestedpat2, nestedpat3] -> expr2
     wrapPatListy elems "[" "]"
   BangPat pat1 -> do
+    -- !nestedpat -> expr
     wrapPatPrepend pat1 (docLit $ Text.pack "!")
   LazyPat pat1 -> do
+    -- ~nestedpat -> expr
     wrapPatPrepend pat1 (docLit $ Text.pack "~")
   NPat llit@(L _ (OverLit olit _ _ _)) mNegative _ _ -> do
+    -- -13 -> expr
     litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc olit
     negDoc <- docLit $ Text.pack "-"
     pure $ case mNegative of

src/Language/Haskell/Brittany/Internal/PreludeUtils.hs

@@ -46,6 +46,9 @@ traceFunctionWith name s1 s2 f x =
 putStrErrLn :: String -> IO ()
 putStrErrLn s = hPutStrLn stderr s
 
+putStrErr :: String -> IO ()
+putStrErr s = hPutStr stderr s
+
 printErr :: Show a => a -> IO ()
 printErr = putStrErrLn . show
 

stack-8.0.2.yaml

@@ -0,0 +1,12 @@
+resolver: lts-9.0
+
+extra-deps:
+  - monad-memo-0.4.1
+  - czipwith-1.0.0.0
+  - butcher-1.3.0.0
+  - data-tree-print-0.1.0.0
+  - deque-0.2
+  - ghc-exactprint-0.5.6.0
+
+packages:
+  - .

stack.yaml

@@ -1,11 +1,4 @@
-resolver: lts-9.0
+resolver: lts-10.0
-
-extra-deps:
-  - monad-memo-0.4.1
-  - czipwith-1.0.0.0
-  - butcher-1.2.0.0
-  - data-tree-print-0.1.0.0
-  - deque-0.2
 
 packages:
   - .