From a9091daeb9f6d59b0a89092aaf0bd8ed8ef0ac9c Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Sun, 14 May 2023 12:45:52 +0000 Subject: [PATCH] Improve layout options for newtype-decls Also re-introduce the config flag to enable/disable single-line newtype rhs layouting. --- .../Brittany/Internal/Config/Config.hs | 3 +- .../Haskell/Brittany/Internal/Config/Types.hs | 16 +-- .../Brittany/Internal/S3_ToBriDocTools.hs | 3 + .../Brittany/Internal/ToBriDoc/DataDecl.hs | 108 +++++++++++++----- source/test-suite/Main.hs | 2 +- 5 files changed, 92 insertions(+), 40 deletions(-) diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs index ff72577..03b95cf 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Config.hs +++ b/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 diff --git a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs b/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs index 8a2969d..4ed4735 100644 --- a/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/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 = diff --git a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs b/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs index 6f9c9d4..fc43352 100644 --- a/source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs +++ b/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 diff --git a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs b/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs index 59f81fb..e07e96e 100644 --- a/source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs +++ b/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 diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs index 051fa17..19c9d1c 100644 --- a/source/test-suite/Main.hs +++ b/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