hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Improve layout options for newtype-decls 

Also re-introduce the config flag to enable/disable
single-line newtype rhs layouting.
ghc92
Lennart Spitzner 2023-05-14 12:45:52 +00:00
parent 9c5a490938
commit a9091daeb9
5 changed files with 92 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
source/library/Language/Haskell/Brittany/Internal/Config/Config.hs
View File

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

16
source/library/Language/Haskell/Brittany/Internal/Config/Types.hs
View File

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

3
source/library/Language/Haskell/Brittany/Internal/S3_ToBriDocTools.hs
View File

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

108
source/library/Language/Haskell/Brittany/Internal/ToBriDoc/DataDecl.hs
View File

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

2
source/test-suite/Main.hs
View File

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