Improve layout options for newtype-decls

Also re-introduce the config flag to enable/disable
single-line newtype rhs layouting.

source/library/Language/Haskell/Brittany/Internal/Config/Config.hs

@@ -64,6 +64,7 @@ staticDefaultConfig = Config
     , _lconfig_fixityBasedAddAlignParens = coerce False
     , _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep
     , _lconfig_operatorAllowUnqualify = coerce True
+    , _lconfig_allowSinglelineRecord = coerce True
     }
   , _conf_errorHandling = ErrorHandlingConfig
     { _econf_produceOutputOnErrors = coerce False
@@ -163,7 +164,7 @@ cmdlineConfigParser = do
       , _lconfig_allowSingleLineExportList = mempty
       , _lconfig_allowHangingQuasiQuotes = mempty
       , _lconfig_experimentalSemicolonNewlines = mempty
-      -- , _lconfig_allowSinglelineRecord     = mempty
+      , _lconfig_allowSinglelineRecord     = mempty
       , _lconfig_fixityAwareOps = mempty
       , _lconfig_fixityAwareTypeOps = mempty
       , _lconfig_fixityBasedAddAlignParens = mempty

source/library/Language/Haskell/Brittany/Internal/Config/Types.hs

@@ -135,14 +135,14 @@ data CLayoutConfig f = LayoutConfig
     -- The implementation for this is a bit hacky and not tested; it might
     -- break output syntax or not work properly for every kind of brace. So
     -- far I have considered `do` and `case-of`.
-  -- , _lconfig_allowSinglelineRecord :: f (Last Bool)
-  --   -- if true, layouts record data decls as a single line when possible, e.g.
-  --   -- > MyPoint { x :: Double, y :: Double }
-  --   -- if false, always use the multi-line layout
-  --   -- > MyPoint
-  --   -- >   { x :: Double
-  --   -- >   , y :: Double
-  --   -- >   }
+  , _lconfig_allowSinglelineRecord :: f (Last Bool)
+    -- if true, layouts record data decls as a single line when possible, e.g.
+    -- > MyPoint { x :: Double, y :: Double }
+    -- if false, always use the multi-line layout
+    -- > MyPoint
+    -- >   { x :: Double
+    -- >   , y :: Double
+    -- >   }
   , _lconfig_fixityAwareOps :: f (Last Bool)
     -- enables fixity-based layouting, e.g.
     -- > foo =

source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs

@@ -389,6 +389,9 @@ docSeq :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
 docSeq [] = docEmpty
 docSeq l = allocateNode . BDSeq =<< sequence l
 
+docSeqSep :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
+docSeqSep = docSeq . List.intersperse docSeparator
+
 docLines :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered
 docLines l = allocateNode . BDLines =<< sequence l
 

source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs

@@ -35,7 +35,7 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of
           then do
             nameStr <- lrdrNameToTextAnn name
             consNameStr <- lrdrNameToTextAnn consName
-            tyVarLine <- shareDoc $ createBndrDoc bndrs
+            tyVars <- mapM shareDoc $ createBndrDoc bndrs
             patDocs <- mapM shareDoc $ layoutHsTyPats pats
             -- headDoc     <- fmap return $ docSeq
             --   [ appSep $ docLitS "newtype")
@@ -43,15 +43,65 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of
             --   , appSep tyVarLine
             --   ]
             rhsDoc <- return <$> createDetailsDoc consNameStr details
-            docHandleComms declEpAnn $ createDerivingPar mDerivs $ docSeq
-              [ appSep $ docLitS "newtype"
-              , appSep $ docLit nameStr
-              , appSep tyVarLine
-              , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
-              , docSeparator
-              , docLitS "="
-              , docSeparator
-              , docHandleComms epAnn $ rhsDoc
+            docHandleComms declEpAnn $ createDerivingPar mDerivs $ docAlt
+              [ -- newtype Tagged s b = Tagged { unTagged :: b }
+                docSeq
+                [ appSep $ docLitS "newtype"
+                , appSep $ docLit nameStr
+                , appSep (docSeqSep tyVars)
+                , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+                , docSeparator
+                , docLitS "="
+                , docSeparator
+                , docForceParSpacing $ docHandleComms epAnn $ rhsDoc
+                ]
+              , -- newtype Tagged s b
+                --   = Tagged { unTagged :: b }
+                -- newtype Tagged s
+                --                b
+                --   = Tagged { unTagged :: b }
+                docAddBaseY BrIndentRegular $ docPar
+                  ( docSeq
+                    [ appSep $ docLitS "newtype"
+                    , appSep $ docLit nameStr
+                    , docAlt
+                      [ docForceSingleline $ docSeq
+                        [ appSep (docSeqSep tyVars)
+                        , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+                        ]
+                      , docSetBaseY $ docLines
+                        $ map docForceSingleline $ tyVars ++ patDocs
+                      ]
+                    ]
+                  )
+                  ( docSeq
+                    [ docLitS "="
+                    , docSeparator
+                    , docHandleComms epAnn $ rhsDoc
+                    ]
+                  )
+              , -- newtype Tagged
+                --   s
+                --   b
+                --   = Tagged { unTagged :: b }
+                docAddBaseY BrIndentRegular $ docPar
+                  ( docSeq
+                    [ appSep $ docLitS "newtype"
+                    , appSep $ docLit nameStr
+                    -- , appSep tyVarLine
+                    -- , docSeq $ [x | p <- patDocs, x <- [p, docSeparator]]
+                    ]
+                  )
+                  ( docLines
+                    $  map (docEnsureIndent BrIndentRegular) tyVars
+                    ++ map (docEnsureIndent BrIndentRegular) patDocs
+                    ++ [ docSeq
+                         [ docLitS "="
+                         , docSeparator
+                         , docHandleComms epAnn $ rhsDoc
+                         ]
+                       ]
+                  )
               ]
           else maybe
             (error
@@ -83,7 +133,7 @@ layoutDataDecl ltycl declEpAnn name (HsQTvs _ bndrs) pats defn = case defn of
       Just (L _ lhsContext) -> shareDoc $ createContextDoc lhsContext
       Nothing -> pure docEmpty
     nameStr <- lrdrNameToTextAnn name
-    tyVarLine <- return <$> createBndrDoc bndrs
+    tyVarLine <- shareDoc $ docSeqSep $ createBndrDoc bndrs
     patDocs <- mapM shareDoc $ layoutHsTyPats pats
     lhsDoc <- shareDoc $ docSeq
       [ -- TOOD92 docNodeAnnKW ltycl (Just GHC.AnnData) $ 
@@ -274,25 +324,24 @@ createContextDoc (t1 : tR) = do
       ]
     ]
 
-createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> ToBriDocM BriDocNumbered
-createBndrDoc bs = do
-  tyVarDocs <- bs `forM` \case
+createBndrDoc :: [LHsTyVarBndr flag GhcPs] -> [ToBriDocM BriDocNumbered]
+createBndrDoc = map $ \x -> do
+  (vname, mKind) <- case x of
     (L _ (UserTyVar _ _ext vname)) -> return $ (lrdrNameToText vname, Nothing)
     (L _ (KindedTyVar _ _ext lrdrName kind)) -> do
       d <- shareDoc $ callLayouter layout_type kind
       return $ (lrdrNameToText lrdrName, Just $ d)
-  docSeq $ List.intersperse docSeparator $ tyVarDocs <&> \(vname, mKind) ->
-    case mKind of
-      Nothing -> docLit vname
-      Just kind -> docSeq
-        [ docLitS "("
-        , docLit vname
-        , docSeparator
-        , docLitS "::"
-        , docSeparator
-        , kind
-        , docLitS ")"
-        ]
+  case mKind of
+    Nothing -> docLit vname
+    Just kind -> docSeq
+      [ docLitS "("
+      , docLit vname
+      , docSeparator
+      , docLitS "::"
+      , docSeparator
+      , kind
+      , docLitS ")"
+      ]
 
 createDerivingPar
   :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
@@ -406,8 +455,7 @@ createDetailsDoc consNameStr details = case details of
     let ((fName1, fType1), fDocR) = case mkFieldDocs fields of
           (doc1:docR) -> (doc1, docR)
           _ -> error "cannot happen (TM)"
-    -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
-    let allowSingleline = False
+    allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack
     docAddBaseY BrIndentRegular $ runFilteredAlternative $ do
         -- single-line: { i :: Int, b :: Bool }
       addAlternativeCond allowSingleline $ docSeq
@@ -433,7 +481,7 @@ createDetailsDoc consNameStr details = case details of
         , docSeparator
         , docHandleComms posClose $ docLitS "}"
         ]
-      addAlternative $ docPar
+      addAlternative $ docSetParSpacing $ docPar
         (docLit consNameStr)
         (docNonBottomSpacingS $ docLines
           [ docAlt
@@ -489,7 +537,7 @@ createForallDoc
   :: [LHsTyVarBndr flag GhcPs] -> Maybe (ToBriDocM BriDocNumbered)
 createForallDoc [] = Nothing
 createForallDoc lhsTyVarBndrs =
-  Just $ docSeq [docLitS "forall ", createBndrDoc lhsTyVarBndrs]
+  Just $ docSeq [docLitS "forall ", docSeqSep $ createBndrDoc lhsTyVarBndrs]
 
 createNamesAndTypeDoc
   :: LConDeclField GhcPs

source/test-suite/Main.hs

@@ -323,7 +323,7 @@ defaultTestConfig = Config
     , _lconfig_allowSingleLineExportList       = coerce True
     , _lconfig_allowHangingQuasiQuotes         = coerce True
     , _lconfig_experimentalSemicolonNewlines   = coerce False
-    -- , _lconfig_allowSinglelineRecord     = coerce False
+    , _lconfig_allowSinglelineRecord           = coerce False
     , _lconfig_fixityAwareOps                  = coerce True
     , _lconfig_fixityAwareTypeOps              = coerce True
     , _lconfig_fixityBasedAddAlignParens       = coerce False