From 172866755cc43b49ad82521b6b2917bf08016173 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 30 Mar 2017 23:23:27 +0200 Subject: [PATCH 01/24] Start impl. layouting for datatypes (#12) Only newtypes work for now; the "interesting" data records are not touched yet. Comment insertion not really considered yet; probably needs work. --- brittany.cabal | 1 + src/Language/Haskell/Brittany/Internal.hs | 8 +- .../Brittany/Internal/Layouters/DataDecl.hs | 134 ++++++++++++++++++ 3 files changed, 140 insertions(+), 3 deletions(-) create mode 100644 src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs diff --git a/brittany.cabal b/brittany.cabal index 3374405..9274ad7 100644 --- a/brittany.cabal +++ b/brittany.cabal @@ -77,6 +77,7 @@ library { Language.Haskell.Brittany.Internal.Layouters.IE Language.Haskell.Brittany.Internal.Layouters.Import Language.Haskell.Brittany.Internal.Layouters.Module + Language.Haskell.Brittany.Internal.Layouters.DataDecl Language.Haskell.Brittany.Internal.Transformations.Alt Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Par diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 9720106..6806f86 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -40,6 +40,7 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Module +import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Backend import Language.Haskell.Brittany.Internal.BackendUtils @@ -51,13 +52,15 @@ import Language.Haskell.Brittany.Internal.Transformations.Par import Language.Haskell.Brittany.Internal.Transformations.Columns import Language.Haskell.Brittany.Internal.Transformations.Indent -import qualified GHC as GHC +import qualified GHC as GHC hiding ( parseModule ) import ApiAnnotation ( AnnKeywordId(..) ) -import GHC ( runGhc +import GHC ( Located + , runGhc , GenLocated(L) , moduleNameString ) +import RdrName ( RdrName(..) ) import SrcLoc ( SrcSpan ) import HsSyn import qualified DynFlags as GHC @@ -485,7 +488,6 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) _ -> return () - getDeclBindingNames :: LHsDecl GhcPs -> [String] #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ getDeclBindingNames (L _ decl) = case decl of diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs new file mode 100644 index 0000000..0102034 --- /dev/null +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE KindSignatures #-} + +module Language.Haskell.Brittany.Internal.Layouters.DataDecl + ( layoutDataDecl + ) +where + + + +#include "prelude.inc" + +import Language.Haskell.Brittany.Internal.Types +import Language.Haskell.Brittany.Internal.LayouterBasics +import Language.Haskell.Brittany.Internal.Config.Types + +import RdrName ( RdrName(..) ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import qualified GHC +import HsSyn +import Name +import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) + +import Language.Haskell.Brittany.Internal.Layouters.Type +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr +import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt +import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Utils + +import Bag ( mapBagM ) + + + +layoutDataDecl + :: Located (HsDecl RdrName) + -> Located RdrName + -> LHsQTyVars RdrName + -> HsDataDefn RdrName + -> ToBriDocM BriDocNumbered +layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of + HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _)) -> + docWrapNode ld $ do + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarDocs <- bndrs `forM` \case + (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + tyVarLine <- + fmap return + $ docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLit (Text.pack "(") + , docLit vname + , docSeparator + , kind + , docLit (Text.pack ")") + ] + headDoc <- fmap return $ docSeq + [ appSep $ docLit (Text.pack "newtype") + , appSep $ docLit nameStr + , appSep tyVarLine + ] + rhsDoc <- fmap return $ case details of + PrefixCon args -> docSeq + [ docLit consNameStr + , docSeparator + , docSeq $ List.intersperse docSeparator $ args <&> layoutType + ] + RecCon (L _ fields) -> docSeq + [ appSep $ docLit $ Text.pack "{" + , docSeq + $ List.intersperse docSeparator + $ fields + <&> \(L _ (ConDeclField names t _)) -> do + docSeq + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \(L _ (FieldOcc fieldName _)) -> + docLit =<< lrdrNameToTextAnn fieldName + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , layoutType t + ] + , docLit $ Text.pack "}" + ] + InfixCon arg1 arg2 -> docSeq + [ layoutType arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType arg2 + ] + let + mainDoc = + docSeq + [ headDoc + , docSeparator + , docLit (Text.pack "=") + , docSeparator + , rhsDoc + ] + case mDerivs of + Nothing -> mainDoc + Just (L _ [(HsIB _ t)]) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [docLit $ Text.pack "deriving", docSeparator, layoutType t] + Just (L _ ts ) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [ docLit $ Text.pack "deriving" + , docSeparator + , docLit $ Text.pack "(" + , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> + layoutType t + , docLit $ Text.pack ")" + ] + _ -> briDocByExactNoComment ld + + -- HsDataDefn DataType _ctxt _ctype Nothing _conss _derivs -> do + -- -- _ name vars ctxt ctype mKindSig conss derivs + -- nameStr <- lrdrNameToTextAnn name + -- docLit nameStr + + _ -> briDocByExactNoComment ld + From 4f827491daa5dd1ea51a49fbd13ba021d7ad22e2 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Tue, 2 May 2017 13:21:18 +0200 Subject: [PATCH 02/24] Work-in-progress commit (deriving clause..) --- src-literatetests/30-tests-context-free.blt | 6 + .../Brittany/Internal/Layouters/DataDecl.hs | 227 ++++++++++++------ 2 files changed, 153 insertions(+), 80 deletions(-) diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index d5c4507..6074d13 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -1163,6 +1163,12 @@ foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do liftIO . forkIO . forever $ getLine >>= inputFire ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent +#test issue 15 +-- Test.hs +module Test where + +data X = X + #test issue 16 foldrDesc f z = unSwitchQueue $ \q -> switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 0102034..8820bda 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -39,96 +39,163 @@ layoutDataDecl -> HsDataDefn RdrName -> ToBriDocM BriDocNumbered layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of + HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _)) -> docWrapNode ld $ do nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName - tyVarDocs <- bndrs `forM` \case - (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) - (L _ (KindedTyVar lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - tyVarLine <- - fmap return - $ docSeq - $ List.intersperse docSeparator - $ tyVarDocs - <&> \(vname, mKind) -> case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLit (Text.pack "(") - , docLit vname - , docSeparator - , kind - , docLit (Text.pack ")") - ] - headDoc <- fmap return $ docSeq + tyVarLine <- fmap return $ createBndrDoc bndrs + -- headDoc <- fmap return $ docSeq + -- [ appSep $ docLit (Text.pack "newtype") + -- , appSep $ docLit nameStr + -- , appSep tyVarLine + -- ] + rhsDoc <- fmap return $ createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq [ appSep $ docLit (Text.pack "newtype") , appSep $ docLit nameStr , appSep tyVarLine + , docSeparator + , docLit (Text.pack "=") + , docSeparator + , rhsDoc ] - rhsDoc <- fmap return $ case details of - PrefixCon args -> docSeq - [ docLit consNameStr - , docSeparator - , docSeq $ List.intersperse docSeparator $ args <&> layoutType - ] - RecCon (L _ fields) -> docSeq - [ appSep $ docLit $ Text.pack "{" - , docSeq - $ List.intersperse docSeparator - $ fields - <&> \(L _ (ConDeclField names t _)) -> do - docSeq - [ docSeq - $ List.intersperse docCommaSep - $ names - <&> \(L _ (FieldOcc fieldName _)) -> - docLit =<< lrdrNameToTextAnn fieldName - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , layoutType t - ] - , docLit $ Text.pack "}" - ] - InfixCon arg1 arg2 -> docSeq - [ layoutType arg1 - , docSeparator - , docLit consNameStr - , docSeparator - , layoutType arg2 - ] - let - mainDoc = - docSeq - [ headDoc - , docSeparator - , docLit (Text.pack "=") - , docSeparator - , rhsDoc - ] - case mDerivs of - Nothing -> mainDoc - Just (L _ [(HsIB _ t)]) -> do - docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq - [docLit $ Text.pack "deriving", docSeparator, layoutType t] - Just (L _ ts ) -> do - docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq - [ docLit $ Text.pack "deriving" - , docSeparator - , docLit $ Text.pack "(" - , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> - layoutType t - , docLit $ Text.pack ")" - ] - _ -> briDocByExactNoComment ld + _ -> briDocByExact ld - -- HsDataDefn DataType _ctxt _ctype Nothing _conss _derivs -> do - -- -- _ name vars ctxt ctype mKindSig conss derivs - -- nameStr <- lrdrNameToTextAnn name - -- docLit nameStr + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> + docWrapNode ld $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + tyVarLine <- fmap return $ createBndrDoc bndrs + createDerivingPar mDerivs $ docSeq + [ appSep $ docLit (Text.pack "data") + , lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + ] + + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> + case cons of + (L _ (ConDeclH98 consName mForall mRhsContext details _)) -> + docWrapNode ld $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + consNameStr <- lrdrNameToTextAnn consName + tyVarLine <- fmap return $ createBndrDoc bndrs + forallDoc <- docSharedWrapper createForallDoc mForall + rhsContextDoc <- case mRhsContext of + Nothing -> return docEmpty + Just (L _ ctxt) -> docSharedWrapper createContextDoc ctxt + rhsDoc <- fmap return $ createDetailsDoc consNameStr details + createDerivingPar mDerivs $ docSeq + [ appSep $ docLit (Text.pack "data") + , lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLit (Text.pack "=") + , docSeparator + , forallDoc + , rhsContextDoc + , rhsDoc + ] + _ -> briDocByExact ld _ -> briDocByExactNoComment ld + where + createContextDoc :: HsContext RdrName -> ToBriDocM BriDocNumbered + createContextDoc [] = docEmpty + createContextDoc [t] = + docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator] + createContextDoc ts = docSeq + [ docLit (Text.pack "(") + , docSeq $ List.intersperse docCommaSep (layoutType <$> ts) + , docLit (Text.pack ") =>") + , docSeparator + ] + createBndrDoc :: [LHsTyVarBndr RdrName] -> ToBriDocM BriDocNumbered + createBndrDoc bs = do + tyVarDocs <- bs `forM` \case + (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLit (Text.pack "(") + , docLit vname + , docSeparator + , docLit (Text.pack "::") + , docSeparator + , kind + , docLit (Text.pack ")") + ] + createDerivingPar + :: HsDeriving RdrName + -> ToBriDocM BriDocNumbered + -> ToBriDocM BriDocNumbered + createDerivingPar mDerivs mainDoc = do + case mDerivs of + Nothing -> docLines [mainDoc] + Just (L _ [(HsIB _ t)]) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [docLit $ Text.pack "deriving", docSeparator, layoutType t] + Just (L _ ts ) -> do + docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq + [ docLit $ Text.pack "deriving" + , docSeparator + , docLit $ Text.pack "(" + , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> + layoutType t + , docLit $ Text.pack ")" + ] + createDetailsDoc + :: Text -> HsConDeclDetails RdrName -> (ToBriDocM BriDocNumbered) + createDetailsDoc consNameStr details = case details of + PrefixCon args -> docSeq + [ docLit consNameStr + , docSeparator + , docSeq $ List.intersperse docSeparator $ args <&> layoutType + ] + RecCon (L _ fields) -> docSeq + [ appSep $ docLit $ Text.pack "{" + , docSeq + $ List.intersperse docSeparator + $ fields + <&> \(L _ (ConDeclField names t _)) -> do + docSeq + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \(L _ (FieldOcc fieldName _)) -> + docLit =<< lrdrNameToTextAnn fieldName + , docSeparator + , docLit $ Text.pack "::" + , docSeparator + , layoutType t + ] + , docLit $ Text.pack "}" + ] + InfixCon arg1 arg2 -> docSeq + [ layoutType arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType arg2 + ] + createForallDoc :: Maybe (LHsQTyVars RdrName) -> ToBriDocM BriDocNumbered + createForallDoc Nothing = docEmpty + createForallDoc (Just (HsQTvs _ bs _)) = do + tDoc <- fmap return $ createBndrDoc bs + docSeq + [ docLit (Text.pack "forall ") + , tDoc + , docLit (Text.pack " .") + , docSeparator + ] From 57ba88a73c389766bf63983b71f159c7a8ee43a2 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sat, 30 Dec 2017 21:28:01 -0500 Subject: [PATCH 03/24] Work-in-progress add record declaration layout Simple records are supports. The tests cover: - single records - multi-field types - columnized alignment - basic deriving - deriving strategies - existential quanitification A few items block merger - retaining comments A few items can be deferred: - normal types - sum types --- src-literatetests/10-tests.blt | 70 +++++ src-literatetests/30-tests-context-free.blt | 41 +++ src/Language/Haskell/Brittany/Internal.hs | 1 - .../Haskell/Brittany/Internal/Backend.hs | 2 + .../Brittany/Internal/Layouters/DataDecl.hs | 278 +++++++++++------- .../Brittany/Internal/Layouters/Decl.hs | 5 +- .../Haskell/Brittany/Internal/Types.hs | 2 + .../Haskell/Brittany/Internal/Utils.hs | 6 + 8 files changed, 292 insertions(+), 113 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 1b152f5..59ffedb 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -310,6 +310,76 @@ func = f f = id +############################################################################### +############################################################################### +############################################################################### +#group data type declarations +############################################################################### +############################################################################### +############################################################################### + +#test single record +data Foo = Bar { foo :: Baz } + +#test record multiple names +data Foo = Bar { foo, bar :: Baz } + +#test record multiple types +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + +#test record multiple types and names +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } + +#test record multiple types deriving +data Foo = Bar + { fooz :: Baz + , bar :: Bizzz + } + deriving Show + +#test record multiple types deriving +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) + +#test record multiple deriving strategies +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + deriving Show + deriving (Eq, Ord) + deriving stock Show + deriving stock (Eq, Ord) + deriving anyclass Show + deriving anyclass (Show, Eq, Monad, Functor) + deriving newtype Show + deriving newtype (Traversable, Foldable) + deriving ToJSON via (SomeType) + deriving (ToJSON, FromJSON) via (SomeType) + +#test single record existential +{-# LANGUAGE ExistentialQuantification #-} + +data Foo = forall a . Show a => Bar { foo :: a } + +#test record multiple types existential +{-# LANGUAGE ExistentialQuantification #-} + +data Foo = forall a b . (Show a, Eq b) => Bar + { foo :: a + , bars :: b + } + + ############################################################################### ############################################################################### ############################################################################### diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 6074d13..9a09fde 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -312,6 +312,47 @@ func = f f = id +############################################################################### +############################################################################### +############################################################################### +#group data type declarations +############################################################################### +############################################################################### +############################################################################### + +#test single record +data Foo = Bar { foo :: Baz } + +#test record multiple names +data Foo = Bar { foo, bar :: Baz } + +#test record multiple types +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + +#test record multiple types and names +data Foo = Bar + { foo, biz :: Baz + , bar :: Bizzz + } + +#test record multiple types deriving +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving Show + +#test record multiple types deriving +data Foo = Bar + { foo :: Baz + , bar :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) + + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 6806f86..b0680a7 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -40,7 +40,6 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Layouters.Type import Language.Haskell.Brittany.Internal.Layouters.Decl import Language.Haskell.Brittany.Internal.Layouters.Module -import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Language.Haskell.Brittany.Internal.Utils import Language.Haskell.Brittany.Internal.Backend import Language.Haskell.Brittany.Internal.BackendUtils diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 8fd7c5d..32c5aba 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -551,6 +551,8 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do (BDCols ColBindStmt _) -> True (BDCols ColDoLet _) -> True (BDCols ColRec _) -> False + (BDCols ColRecUpdate _) -> False + (BDCols ColRecDecl _) -> False (BDCols ColListComp _) -> False (BDCols ColList _) -> False (BDCols ColApp{} _) -> True diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 8820bda..bfbb025 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -16,7 +16,7 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types import RdrName ( RdrName(..) ) -import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString, DerivStrategy(..) ) import qualified GHC import HsSyn import Name @@ -33,16 +33,16 @@ import Bag ( mapBagM ) layoutDataDecl - :: Located (HsDecl RdrName) + :: Located (TyClDecl GhcPs) -> Located RdrName - -> LHsQTyVars RdrName - -> HsDataDefn RdrName + -> LHsQTyVars GhcPs + -> HsDataDefn GhcPs -> ToBriDocM BriDocNumbered -layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of - - HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _)) -> - docWrapNode ld $ do +layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext +layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of + HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> + docWrapNode ltycl $ do nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName tyVarLine <- fmap return $ createBndrDoc bndrs @@ -61,10 +61,10 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of , docSeparator , rhsDoc ] - _ -> briDocByExact ld + _ -> briDocByExact ltycl - HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> - docWrapNode ld $ do + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> + docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name tyVarLine <- fmap return $ createBndrDoc bndrs @@ -75,15 +75,15 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of , appSep tyVarLine ] - HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> case cons of - (L _ (ConDeclH98 consName mForall mRhsContext details _)) -> - docWrapNode ld $ do + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> + docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName tyVarLine <- fmap return $ createBndrDoc bndrs - forallDoc <- docSharedWrapper createForallDoc mForall + forallDoc <- docSharedWrapper createForallDoc qvars rhsContextDoc <- case mRhsContext of Nothing -> return docEmpty Just (L _ ctxt) -> docSharedWrapper createContextDoc ctxt @@ -100,102 +100,158 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of , rhsContextDoc , rhsDoc ] - _ -> briDocByExact ld + _ -> briDocByExact ltycl - _ -> briDocByExactNoComment ld + _ -> briDocByExactNoComment ltycl + +createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered +createContextDoc [] = docEmpty +createContextDoc [t] = + docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator] +createContextDoc ts = docSeq + [ docLit (Text.pack "(") + , docSeq $ List.intersperse docCommaSep (layoutType <$> ts) + , docLit (Text.pack ") =>") + , docSeparator + ] + +createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered +createBndrDoc bs = do + tyVarDocs <- bs `forM` \case + (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar _ext lrdrName kind)) -> do + d <- docSharedWrapper layoutType kind + return $ (lrdrNameToText lrdrName, Just $ d) + (L _ (XTyVarBndr ext)) -> absurdExt ext + docSeq + $ List.intersperse docSeparator + $ tyVarDocs + <&> \(vname, mKind) -> case mKind of + Nothing -> docLit vname + Just kind -> docSeq + [ docLit (Text.pack "(") + , docLit vname + , docSeparator + , docLit (Text.pack "::") + , docSeparator + , kind + , docLit (Text.pack ")") + ] + +createDerivingPar + :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +createDerivingPar derivs mainDoc = do + case derivs of + (L _ []) -> docLines [mainDoc] + (L _ types) -> + docPar mainDoc + $ docEnsureIndent BrIndentRegular + $ docLines + $ derivingClauseDoc + <$> types + +derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered +derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext +derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of + (L _ []) -> docSeq [] + (L _ ts) -> + let + tsLength = length ts + whenMoreThan1Type val = + if tsLength > 1 then docLit (Text.pack val) else docLit (Text.pack "") + (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy + in + docSeq + [ docDeriving + , lhsStrategy + , docSeparator + , whenMoreThan1Type "(" + , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> + layoutType t + , whenMoreThan1Type ")" + , rhsStrategy + ] where - createContextDoc :: HsContext RdrName -> ToBriDocM BriDocNumbered - createContextDoc [] = docEmpty - createContextDoc [t] = - docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator] - createContextDoc ts = docSeq - [ docLit (Text.pack "(") - , docSeq $ List.intersperse docCommaSep (layoutType <$> ts) - , docLit (Text.pack ") =>") + strategyLeftRight = \case + (L _ StockStrategy ) -> (docLit $ Text.pack " stock", docEmpty) + (L _ AnyclassStrategy ) -> (docLit $ Text.pack " anyclass", docEmpty) + (L _ NewtypeStrategy ) -> (docLit $ Text.pack " newtype", docEmpty) + (L _ (ViaStrategy viaTypes) ) -> + ( docEmpty + , case viaTypes of + HsIB _ext t -> docSeq + [ docLit $ Text.pack " via " + , layoutType t + ] + XHsImplicitBndrs ext -> absurdExt ext + ) + +docDeriving :: ToBriDocM BriDocNumbered +docDeriving = docLit $ Text.pack "deriving" + +createDetailsDoc + :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) +createDetailsDoc consNameStr details = case details of + PrefixCon args -> docSeq + [ docLit consNameStr + , docSeparator + , docSeq $ List.intersperse docSeparator $ args <&> layoutType + ] + RecCon (L _ []) -> docEmpty + RecCon (L _ [L _ (ConDeclField _ext names t _)]) -> docSeq + [ docLit consNameStr + , docSeparator + , appSep $ docLit $ Text.pack "{" + , docSeq $ createNamesAndTypeDoc names t + , docSeparator + , docLit $ Text.pack "}" + ] + RecCon (L _ (fstField:fields)) -> + docAddBaseY BrIndentRegular $ docPar + (docLit consNameStr) + (docLines + [ docCols ColRecDecl + $ docLit (Text.pack "{ ") + : let L _ (ConDeclField _ext names t _) = fstField + in createNamesAndTypeDoc names t + , docLines + $ (\(L _ (ConDeclField _ext names t _)) -> + docCols ColRecDecl $ docCommaSep : createNamesAndTypeDoc names t) + <$> fields + , docLit $ Text.pack "}" + ] + ) + InfixCon arg1 arg2 -> docSeq + [ layoutType arg1 + , docSeparator + , docLit consNameStr + , docSeparator + , layoutType arg2 + ] + +createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered +createForallDoc [] = docEmpty +createForallDoc lhsTyVarBndrs = docSeq + [ docLit (Text.pack "forall ") + , createBndrDoc lhsTyVarBndrs + , docLit (Text.pack " .") + , docSeparator + ] + +createNamesAndTypeDoc + :: [GenLocated t (FieldOcc u)] -> Located (HsType GhcPs) -> [ToBriDocM BriDocNumbered] +createNamesAndTypeDoc names t = + [ docSeq + [ docSeq + $ List.intersperse docCommaSep + $ names + <&> \(L _ (FieldOcc _ fieldName)) -> + docLit =<< lrdrNameToTextAnn fieldName , docSeparator ] - createBndrDoc :: [LHsTyVarBndr RdrName] -> ToBriDocM BriDocNumbered - createBndrDoc bs = do - tyVarDocs <- bs `forM` \case - (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) - (L _ (KindedTyVar lrdrName kind)) -> do - d <- docSharedWrapper layoutType kind - return $ (lrdrNameToText lrdrName, Just $ d) - docSeq - $ List.intersperse docSeparator - $ tyVarDocs - <&> \(vname, mKind) -> case mKind of - Nothing -> docLit vname - Just kind -> docSeq - [ docLit (Text.pack "(") - , docLit vname - , docSeparator - , docLit (Text.pack "::") - , docSeparator - , kind - , docLit (Text.pack ")") - ] - createDerivingPar - :: HsDeriving RdrName - -> ToBriDocM BriDocNumbered - -> ToBriDocM BriDocNumbered - createDerivingPar mDerivs mainDoc = do - case mDerivs of - Nothing -> docLines [mainDoc] - Just (L _ [(HsIB _ t)]) -> do - docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq - [docLit $ Text.pack "deriving", docSeparator, layoutType t] - Just (L _ ts ) -> do - docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq - [ docLit $ Text.pack "deriving" - , docSeparator - , docLit $ Text.pack "(" - , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> - layoutType t - , docLit $ Text.pack ")" - ] - createDetailsDoc - :: Text -> HsConDeclDetails RdrName -> (ToBriDocM BriDocNumbered) - createDetailsDoc consNameStr details = case details of - PrefixCon args -> docSeq - [ docLit consNameStr - , docSeparator - , docSeq $ List.intersperse docSeparator $ args <&> layoutType - ] - RecCon (L _ fields) -> docSeq - [ appSep $ docLit $ Text.pack "{" - , docSeq - $ List.intersperse docSeparator - $ fields - <&> \(L _ (ConDeclField names t _)) -> do - docSeq - [ docSeq - $ List.intersperse docCommaSep - $ names - <&> \(L _ (FieldOcc fieldName _)) -> - docLit =<< lrdrNameToTextAnn fieldName - , docSeparator - , docLit $ Text.pack "::" - , docSeparator - , layoutType t - ] - , docLit $ Text.pack "}" - ] - InfixCon arg1 arg2 -> docSeq - [ layoutType arg1 - , docSeparator - , docLit consNameStr - , docSeparator - , layoutType arg2 - ] - createForallDoc :: Maybe (LHsQTyVars RdrName) -> ToBriDocM BriDocNumbered - createForallDoc Nothing = docEmpty - createForallDoc (Just (HsQTvs _ bs _)) = do - tDoc <- fmap return $ createBndrDoc bs - docSeq - [ docLit (Text.pack "forall ") - , tDoc - , docLit (Text.pack " .") - , docSeparator - ] - + , docSeq + [ docLit $ Text.pack "::" + , docSeparator + , layoutType t + ] + ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 6d9a1f5..7b52383 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -53,6 +53,7 @@ import Language.Haskell.Brittany.Internal.Layouters.Type import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern +import Language.Haskell.Brittany.Internal.Layouters.DataDecl import Bag ( mapBagM, bagToList, emptyBag ) import Data.Char (isUpper) @@ -85,7 +86,6 @@ layoutDecl d@(L loc decl) = case decl of _ -> briDocByExactNoComment d #endif - -------------------------------------------------------------------------------- -- Sig -------------------------------------------------------------------------------- @@ -741,6 +741,9 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ + DataDecl _ext name tyVars _ dataDefn -> + docWrapNodePrior ltycl $ + layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl layoutSynDecl diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index 8aad965..e3a5318 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -185,6 +185,8 @@ data ColSig | ColBindStmt | ColDoLet -- the non-indented variant | ColRec + | ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect? + | ColRecDecl | ColListComp | ColList | ColApp Text diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index dfd28c3..ae7bed9 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -25,6 +25,7 @@ module Language.Haskell.Brittany.Internal.Utils , splitFirstLast , lines' , showOutputable + , absurdExt ) where @@ -57,6 +58,7 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate +import HsExtension (NoExt) @@ -293,3 +295,7 @@ lines' s = case break (== '\n') s of (s1, []) -> [s1] (s1, [_]) -> [s1, ""] (s1, (_:r)) -> s1 : lines' r + +-- | A method to dismiss NoExt patterns for total matches +absurdExt :: NoExt -> a +absurdExt = error "cannot construct NoExt" From 208a1ceadb0b2b34f3c807b30232db683dd6969a Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 11 Oct 2019 00:51:13 +0200 Subject: [PATCH 04/24] Start making datadecls work with ghc-8.4 --- .../Brittany/Internal/Layouters/DataDecl.hs | 85 ++++++++++++++++--- .../Brittany/Internal/Layouters/Decl.hs | 4 + .../Haskell/Brittany/Internal/Utils.hs | 9 +- 3 files changed, 82 insertions(+), 16 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index bfbb025..082a5c4 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -16,10 +16,11 @@ import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.Config.Types import RdrName ( RdrName(..) ) -import GHC ( Located, runGhc, GenLocated(L), moduleNameString, DerivStrategy(..) ) +import GHC ( Located, runGhc, GenLocated(L), moduleNameString ) import qualified GHC import HsSyn import Name +import BasicTypes import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) import Language.Haskell.Brittany.Internal.Layouters.Type @@ -38,10 +39,19 @@ layoutDataDecl -> LHsQTyVars GhcPs -> HsDataDefn GhcPs -> ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ layoutDataDecl _ _ (XLHsQTyVars ext) _ = absurdExt ext layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of +#else +layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of +#endif +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> +#else + HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of + (L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _conDoc)) -> +#endif docWrapNode ltycl $ do nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName @@ -61,9 +71,13 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , docSeparator , rhsDoc ] - _ -> briDocByExact ltycl + _ -> briDocByExactNoComment ltycl +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> +#else + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> +#endif docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name @@ -75,9 +89,17 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , appSep tyVarLine ] +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> +#else + HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> +#endif case cons of +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> +#else + (L _ (ConDeclH98 consName (Just (HsQTvs _ qvars _)) mRhsContext details _conDoc)) -> +#endif docWrapNode ltycl $ do lhsContextDoc <- docSharedWrapper createContextDoc lhsContext nameStr <- lrdrNameToTextAnn name @@ -100,7 +122,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of , rhsContextDoc , rhsDoc ] - _ -> briDocByExact ltycl + _ -> briDocByExactNoComment ltycl _ -> briDocByExactNoComment ltycl @@ -118,11 +140,18 @@ createContextDoc ts = docSeq createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered createBndrDoc bs = do tyVarDocs <- bs `forM` \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (UserTyVar _ext vname)) -> return $ (lrdrNameToText vname, Nothing) (L _ (KindedTyVar _ext lrdrName kind)) -> do +#else + (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) + (L _ (KindedTyVar lrdrName kind)) -> do +#endif d <- docSharedWrapper layoutType kind return $ (lrdrNameToText lrdrName, Just $ d) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (XTyVarBndr ext)) -> absurdExt ext +#endif docSeq $ List.intersperse docSeparator $ tyVarDocs @@ -151,8 +180,12 @@ createDerivingPar derivs mainDoc = do <$> types derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of +#else +derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of +#endif (L _ []) -> docSeq [] (L _ ts) -> let @@ -166,8 +199,13 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of , lhsStrategy , docSeparator , whenMoreThan1Type "(" - , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> - layoutType t + , docSeq $ List.intersperse docCommaSep $ ts <&> \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + HsIB _ t -> layoutType t + XHsImplicitBndrs x -> absurdExt x +#else + HsIB _ t _ -> layoutType t +#endif , whenMoreThan1Type ")" , rhsStrategy ] @@ -176,6 +214,7 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of (L _ StockStrategy ) -> (docLit $ Text.pack " stock", docEmpty) (L _ AnyclassStrategy ) -> (docLit $ Text.pack " anyclass", docEmpty) (L _ NewtypeStrategy ) -> (docLit $ Text.pack " newtype", docEmpty) +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ (L _ (ViaStrategy viaTypes) ) -> ( docEmpty , case viaTypes of @@ -185,6 +224,7 @@ derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of ] XHsImplicitBndrs ext -> absurdExt ext ) +#endif docDeriving :: ToBriDocM BriDocNumbered docDeriving = docLit $ Text.pack "deriving" @@ -198,7 +238,11 @@ createDetailsDoc consNameStr details = case details of , docSeq $ List.intersperse docSeparator $ args <&> layoutType ] RecCon (L _ []) -> docEmpty +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecCon (L _ [L _ (ConDeclField _ext names t _)]) -> docSeq +#else + RecCon (L _ [L _ (ConDeclField names t _)]) -> docSeq +#endif [ docLit consNameStr , docSeparator , appSep $ docLit $ Text.pack "{" @@ -206,18 +250,15 @@ createDetailsDoc consNameStr details = case details of , docSeparator , docLit $ Text.pack "}" ] - RecCon (L _ (fstField:fields)) -> + RecCon (L _ fields@(_:_)) -> do + let (fDoc1 : fDocR) = mkFieldDocs fields docAddBaseY BrIndentRegular $ docPar (docLit consNameStr) (docLines [ docCols ColRecDecl $ docLit (Text.pack "{ ") - : let L _ (ConDeclField _ext names t _) = fstField - in createNamesAndTypeDoc names t - , docLines - $ (\(L _ (ConDeclField _ext names t _)) -> - docCols ColRecDecl $ docCommaSep : createNamesAndTypeDoc names t) - <$> fields + : fDoc1 + , docLines $ fDocR <&> \f -> docCols ColRecDecl $ docCommaSep : f , docLit $ Text.pack "}" ] ) @@ -228,6 +269,14 @@ createDetailsDoc consNameStr details = case details of , docSeparator , layoutType arg2 ] + where + mkFieldDocs = fmap $ \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc names t + L _ (XConDeclField x) -> absurdExt x +#else + L _ (ConDeclField names t _) -> createNamesAndTypeDoc names t +#endif createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered createForallDoc [] = docEmpty @@ -239,13 +288,21 @@ createForallDoc lhsTyVarBndrs = docSeq ] createNamesAndTypeDoc - :: [GenLocated t (FieldOcc u)] -> Located (HsType GhcPs) -> [ToBriDocM BriDocNumbered] + :: [GenLocated t (FieldOcc GhcPs)] + -> Located (HsType GhcPs) + -> [ToBriDocM BriDocNumbered] createNamesAndTypeDoc names t = [ docSeq [ docSeq $ List.intersperse docCommaSep $ names - <&> \(L _ (FieldOcc _ fieldName)) -> + <&> \case +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ + L _ (XFieldOcc x) -> absurdExt x + L _ (FieldOcc _ fieldName) -> +#else + L _ (FieldOcc fieldName _) -> +#endif docLit =<< lrdrNameToTextAnn fieldName , docSeparator ] diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 7b52383..153774f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -741,7 +741,11 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of let wrapNodeRest = docWrapNodeRest ltycl docWrapNodePrior ltycl $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ +#if MIN_VERSION_ghc(8,6,0) DataDecl _ext name tyVars _ dataDefn -> +#else + DataDecl name tyVars _ dataDefn _ _ -> +#endif docWrapNodePrior ltycl $ layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index ae7bed9..eee432e 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -58,7 +58,7 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate -import HsExtension (NoExt) +import qualified HsExtension @@ -296,6 +296,11 @@ lines' s = case break (== '\n') s of (s1, [_]) -> [s1, ""] (s1, (_:r)) -> s1 : lines' r +#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ -- | A method to dismiss NoExt patterns for total matches -absurdExt :: NoExt -> a +absurdExt :: HsExtension.NoExt -> a absurdExt = error "cannot construct NoExt" +#else +absurdExt :: () +absurdExt = () +#endif From d21ecf89e6c31f34f58f7da514e56d6b8167ef8d Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 23 Oct 2019 01:32:01 +0200 Subject: [PATCH 05/24] Fix a comment bug in tuple-type layouting --- src-literatetests/10-tests.blt | 8 +++++ .../Brittany/Internal/LayouterBasics.hs | 35 +++++++++++++------ .../Brittany/Internal/Layouters/Type.hs | 15 ++++---- 3 files changed, 42 insertions(+), 16 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 59ffedb..78de0ce 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -1163,6 +1163,14 @@ type (a :+: b) = (a, b) type ((a :+: b) c) = (a, c) +#test synonym-tuple-type-many-comments + +type Foo + = ( -- t1 + A -- t2 + , -- t3 + B -- t4 + ) -- t5 ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index cd5764d..d7acf16 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -642,18 +642,18 @@ docNodeMoveToKWDP ast kw shouldRestoreIndent bdm = class DocWrapable a where docWrapNode :: ( Data.Data.Data ast) => Located ast - -> ToBriDocM a - -> ToBriDocM a + -> a + -> a docWrapNodePrior :: ( Data.Data.Data ast) => Located ast - -> ToBriDocM a - -> ToBriDocM a + -> a + -> a docWrapNodeRest :: ( Data.Data.Data ast) => Located ast - -> ToBriDocM a - -> ToBriDocM a + -> a + -> a -instance DocWrapable BriDocNumbered where +instance DocWrapable (ToBriDocM BriDocNumbered) where docWrapNode ast bdm = do bd <- bdm i1 <- allocNodeIndex @@ -679,7 +679,22 @@ instance DocWrapable BriDocNumbered where $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ bd -instance DocWrapable a => DocWrapable [a] where +instance DocWrapable (ToBriDocM a) => DocWrapable [ToBriDocM a] where + docWrapNode ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNode ast bd] + (bd1:bdR) | (bdN:bdM) <- reverse bdR -> + [docWrapNodePrior ast bd1] ++ reverse bdM ++ [docWrapNodeRest ast bdN] + _ -> error "cannot happen (TM)" + docWrapNodePrior ast bdms = case bdms of + [] -> [] + [bd] -> [docWrapNodePrior ast bd] + (bd1:bdR) -> docWrapNodePrior ast bd1 : bdR + docWrapNodeRest ast bdms = case reverse bdms of + [] -> [] + (bdN:bdR) -> reverse $ docWrapNodeRest ast bdN : bdR + +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM [a]) where docWrapNode ast bdsm = do bds <- bdsm case bds of @@ -707,7 +722,7 @@ instance DocWrapable a => DocWrapable [a] where bdN' <- docWrapNodeRest ast (return bdN) return $ reverse (bdN':bdR) -instance DocWrapable a => DocWrapable (Seq a) where +instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where docWrapNode ast bdsm = do bds <- bdsm case Seq.viewl bds of @@ -735,7 +750,7 @@ instance DocWrapable a => DocWrapable (Seq a) where bdN' <- docWrapNodeRest ast (return bdN) return $ bdR Seq.|> bdN' -instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where +instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where docWrapNode ast stuffM = do (bds, bd, x) <- stuffM if null bds diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index 4902a08..bf5a956 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -444,15 +444,17 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of docs <- docSharedWrapper layoutType `mapM` typs let end = docLit $ Text.pack ")" lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] + commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs) docAlt [ docSeq $ [docLit $ Text.pack "("] - ++ List.intersperse docCommaSep (docForceSingleline <$> docs) + ++ docWrapNodeRest ltype commaDocs ++ [end] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] in docPar (docAddBaseY (BrIndentSpecial 2) $ line1) - (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + (docLines $ docWrapNodeRest ltype lines ++ [end]) ] unboxedL = do docs <- docSharedWrapper layoutType `mapM` typs @@ -460,15 +462,16 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of end = docParenHashRSep docAlt [ docSeq $ [start] - ++ List.intersperse docCommaSep docs + ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs) ++ [end] , let line1 = docCols ColTyOpPrefix [start, head docs] lines = List.tail docs <&> \d -> - docCols ColTyOpPrefix [docCommaSep, d] + docAddBaseY (BrIndentSpecial 2) + $ docCols ColTyOpPrefix [docCommaSep, d] in docPar (docAddBaseY (BrIndentSpecial 2) line1) - (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) + (docLines $ lines ++ [end]) ] HsOpTy{} -> -- TODO briDocByExactInlineOnly "HsOpTy{}" ltype From 2f6967b7b8fcb47d5e9ea09efaf7c93860da87dc Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 23 Oct 2019 01:43:23 +0200 Subject: [PATCH 06/24] Support comments in record data decls --- src-literatetests/10-tests.blt | 40 ++++++++++++++++ .../Brittany/Internal/Layouters/DataDecl.hs | 48 +++++++++++-------- 2 files changed, 69 insertions(+), 19 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 78de0ce..d12ba21 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -379,6 +379,46 @@ data Foo = forall a b . (Show a, Eq b) => Bar , bars :: b } +#test record comments simple +data Foo = Bar -- a + { foo :: Baz -- b + , bars :: Bizzz -- c + } -- d + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) -- e + +#test record comments strange inline +data Foo = Bar + { -- a + foo -- b + :: -- c + Baz -- d + , -- e + bars :: Bizzz + } + deriving (Show, Eq, Monad, Functor, Traversable, Foldable) + +#test record comments in deriving +## maybe we want to switch to a differnt layout when there are such comments. +## Don't hesitate to modify this testcase, it clearly is not the ideal layout +## for this. + +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --b + ( -- c + ToJSON -- d + , -- e + FromJSON --f + ) -- g + via -- h + ( -- i + SomeType --j + , -- k + ABC --l + ) ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 082a5c4..fed333e 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -176,6 +176,7 @@ createDerivingPar derivs mainDoc = do docPar mainDoc $ docEnsureIndent BrIndentRegular $ docLines + $ docWrapNode derivs $ derivingClauseDoc <$> types @@ -196,10 +197,13 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of in docSeq [ docDeriving - , lhsStrategy + , docWrapNodePrior types $ lhsStrategy , docSeparator , whenMoreThan1Type "(" - , docSeq $ List.intersperse docCommaSep $ ts <&> \case + , docWrapNodeRest types + $ docSeq + $ List.intersperse docCommaSep + $ ts <&> \case #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIB _ t -> layoutType t XHsImplicitBndrs x -> absurdExt x @@ -215,11 +219,12 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of (L _ AnyclassStrategy ) -> (docLit $ Text.pack " anyclass", docEmpty) (L _ NewtypeStrategy ) -> (docLit $ Text.pack " newtype", docEmpty) #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - (L _ (ViaStrategy viaTypes) ) -> + lVia@(L _ (ViaStrategy viaTypes) ) -> ( docEmpty , case viaTypes of HsIB _ext t -> docSeq - [ docLit $ Text.pack " via " + [ docWrapNode lVia $ docLit $ Text.pack " via" + , docSeparator , layoutType t ] XHsImplicitBndrs ext -> absurdExt ext @@ -239,26 +244,28 @@ createDetailsDoc consNameStr details = case details of ] RecCon (L _ []) -> docEmpty #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - RecCon (L _ [L _ (ConDeclField _ext names t _)]) -> docSeq + RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> docSeq #else - RecCon (L _ [L _ (ConDeclField names t _)]) -> docSeq + RecCon lRec@(L _ [lField@(L _ (ConDeclField names t _))]) -> docSeq #endif [ docLit consNameStr , docSeparator - , appSep $ docLit $ Text.pack "{" - , docSeq $ createNamesAndTypeDoc names t + , docWrapNodePrior lRec $ docLit $ Text.pack "{" + , docSeparator + , docWrapNodeRest lRec $ docSeq $ createNamesAndTypeDoc lField names t , docSeparator , docLit $ Text.pack "}" ] - RecCon (L _ fields@(_:_)) -> do + RecCon lRec@(L _ fields@(_:_)) -> do let (fDoc1 : fDocR) = mkFieldDocs fields docAddBaseY BrIndentRegular $ docPar (docLit consNameStr) - (docLines + (docWrapNodePrior lRec $ docLines [ docCols ColRecDecl - $ docLit (Text.pack "{ ") + $ appSep (docLit (Text.pack "{")) : fDoc1 - , docLines $ fDocR <&> \f -> docCols ColRecDecl $ docCommaSep : f + , docWrapNodeRest lRec $ docLines $ fDocR <&> \f -> + docCols ColRecDecl $ docCommaSep : f , docLit $ Text.pack "}" ] ) @@ -270,12 +277,13 @@ createDetailsDoc consNameStr details = case details of , layoutType arg2 ] where - mkFieldDocs = fmap $ \case + mkFieldDocs :: [LConDeclField GhcPs] -> [[ToBriDocM BriDocNumbered]] + mkFieldDocs = fmap $ \lField -> case lField of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc names t + L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t L _ (XConDeclField x) -> absurdExt x #else - L _ (ConDeclField names t _) -> createNamesAndTypeDoc names t + L _ (ConDeclField names t _) -> createNamesAndTypeDoc lField names t #endif createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered @@ -288,11 +296,13 @@ createForallDoc lhsTyVarBndrs = docSeq ] createNamesAndTypeDoc - :: [GenLocated t (FieldOcc GhcPs)] + :: Data.Data.Data ast + => Located ast + -> [GenLocated t (FieldOcc GhcPs)] -> Located (HsType GhcPs) -> [ToBriDocM BriDocNumbered] -createNamesAndTypeDoc names t = - [ docSeq +createNamesAndTypeDoc lField names t = + [ docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq [ docSeq $ List.intersperse docCommaSep $ names @@ -306,7 +316,7 @@ createNamesAndTypeDoc names t = docLit =<< lrdrNameToTextAnn fieldName , docSeparator ] - , docSeq + , docWrapNodeRest lField $ docSeq [ docLit $ Text.pack "::" , docSeparator , layoutType t From 868b8c61e3a79bddb9ab054073e81cd07591bb85 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 19:57:06 -0600 Subject: [PATCH 07/24] Add a Makefile for easy testing many version The `Makefile` includes `stack test` configurations to support building versions of `brittany` with supported versions of `ghc`. Each version uses a separate `.stack-work` directory to allow minimal compilation on each change. --- .gitignore | 3 ++- Makefile | 28 ++++++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 1 deletion(-) create mode 100644 Makefile diff --git a/.gitignore b/.gitignore index 4393459..4cdb828 100644 --- a/.gitignore +++ b/.gitignore @@ -12,4 +12,5 @@ local/ cabal.sandbox.config cabal.project.local .ghc.environment.* -result \ No newline at end of file +result +.stack-work* diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..e0213ab --- /dev/null +++ b/Makefile @@ -0,0 +1,28 @@ +.PHONY: test +test: + echo "test" + stack test + +.PHONY: test-all +test-all: + $(MAKE) test test-8.6.5 test-8.4.3 test-8.2.2 test-8.0.2 + +.PHONY: test-8.6.5 +test-8.6.5: + echo "test 8.6.5" + stack test --stack-yaml stack-8.6.5.yaml --work-dir .stack-work-8.6.5 + +.PHONY: test-8.4.3 +test-8.4.3: + echo "test 8.4.3" + stack test --stack-yaml stack-8.4.3.yaml --work-dir .stack-work-8.4.3 + +.PHONY: test-8.2.2 +test-8.2.2: + echo "test 8.2.2" + stack test --stack-yaml stack-8.2.2.yaml --work-dir .stack-work-8.2.2 + +.PHONY: test-8.0.2 +test-8.0.2: + echo "test 8.0.2" + stack test --stack-yaml stack-8.0.2.yaml --work-dir .stack-work-8.0.2 From dee63517ba7a4468d7c41b99bc5c318d6bd63b84 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 19:59:41 -0600 Subject: [PATCH 08/24] Include stack lock files --- stack-8.2.2.yaml.lock | 33 ++++++++++++++++++++++++++++++ stack-8.4.3.yaml.lock | 19 +++++++++++++++++ stack-8.6.5.yaml.lock | 26 ++++++++++++++++++++++++ stack.yaml.lock | 47 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 125 insertions(+) create mode 100644 stack-8.2.2.yaml.lock create mode 100644 stack-8.4.3.yaml.lock create mode 100644 stack-8.6.5.yaml.lock create mode 100644 stack.yaml.lock diff --git a/stack-8.2.2.yaml.lock b/stack-8.2.2.yaml.lock new file mode 100644 index 0000000..8bacbb2 --- /dev/null +++ b/stack-8.2.2.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: czipwith-1.0.1.0@sha256:30751c5a92488304863f20403cd8e9d4fee2b5def0b656a3d979aa3331a09c00,1652 + pantry-tree: + size: 323 + sha256: acd60968c5a1945741204751243f88d1af1c152018c2d9575f62c0805825f44f + original: + hackage: czipwith-1.0.1.0 +- completed: + hackage: butcher-1.3.1.1@sha256:d5734df2e42c28c5a8419eb8251cc531e5f5e6a13794b2ae1dac04abd1c359ad,3242 + pantry-tree: + size: 1197 + sha256: 057b5c8aa0211951337d87cda1f3d4c6f049945314f6fc7883394eebac79be5b + original: + hackage: butcher-1.3.1.1 +- completed: + hackage: ghc-exactprint-0.5.8.0@sha256:71915a08a7d442d39a63cb3b0fbd90b7dacd19bc4b05bac5c53b6e8a0d931b7b,7728 + pantry-tree: + size: 83871 + sha256: 3998143d33f7de29b31e8cf8d1b207c1fb4962f819fc820e209e1eecbf7e5a35 + original: + hackage: ghc-exactprint-0.5.8.0 +snapshots: +- completed: + size: 505335 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/11/1.yaml + sha256: 59c853f993e736f430ad20d03eb5441c715d84359c035de906f970841887a8f8 + original: lts-11.1 diff --git a/stack-8.4.3.yaml.lock b/stack-8.4.3.yaml.lock new file mode 100644 index 0000000..b4a4818 --- /dev/null +++ b/stack-8.4.3.yaml.lock @@ -0,0 +1,19 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: ghc-exactprint-0.5.8.1@sha256:f76eed0976b854ce03928796e9cff97769e304618ca99bc0f6cdccab31e539d0,7728 + pantry-tree: + size: 83871 + sha256: 14febc191ef8b0d1f218d13e8db9ed20395f10a5b3d8aa2c0d45869a037420a2 + original: + hackage: ghc-exactprint-0.5.8.1 +snapshots: +- completed: + size: 504336 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/12.yaml + sha256: 11db5c37144d13fe6b56cd511050b4e6ffe988f6edb8e439c2432fc9fcdf50c3 + original: lts-12.12 diff --git a/stack-8.6.5.yaml.lock b/stack-8.6.5.yaml.lock new file mode 100644 index 0000000..a7d341f --- /dev/null +++ b/stack-8.6.5.yaml.lock @@ -0,0 +1,26 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: butcher-1.3.2.1@sha256:cf479ea83a08f4f59a482e7c023c70714e7c93c1ccd7d53fe076ad3f1a3d2b8d,3115 + pantry-tree: + size: 1197 + sha256: dc4bd6adc5f8bd3589533659b62567da78b6956d7098e561c0523c60fcaa0406 + original: + hackage: butcher-1.3.2.1 +- completed: + hackage: multistate-0.8.0.1@sha256:496ac087a0df3984045d7460b981d5e868a49e160b60a6555f6799e81e58542d,3700 + pantry-tree: + size: 2143 + sha256: 0136d5fcddee0244c3bc73b4ae1b489134a1dd12a8978f437b2be81e98f5d8bd + original: + hackage: multistate-0.8.0.1 +snapshots: +- completed: + size: 498398 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/23.yaml + sha256: 63151ca76f39d5cfbd266ce019236459fdda53fbefd2200aedeb33bcc81f808e + original: lts-13.23 diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..6b3c445 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,47 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: multistate-0.8.0.2@sha256:fbb0d8ade9ef73c8ed92488f5804d0ebe75d3a9c24bf53452bc3a4f32b34cb2e,3713 + pantry-tree: + size: 2143 + sha256: 1753828d37b456e1e0241766d893b29f385ef7769fa79610f507b747935b77cb + original: + hackage: multistate-0.8.0.2 +- completed: + hackage: butcher-1.3.2.3@sha256:1b8040eddb6da2a05426bf9f6c56b078e629228d64d7d61fb3daa88802487e1b,3262 + pantry-tree: + size: 1197 + sha256: 6bf3a318bd8689bd1fa7a8084c0d96372768d2dc3e30d9aa58d07741ed6816e6 + original: + hackage: butcher-1.3.2.3 +- completed: + hackage: deque-0.4.2.3@sha256:7cc8ddfc77df351ff9c16e838ccdb4a89f055c80a3111e27eba8d90e8edde7d0,1853 + pantry-tree: + size: 807 + sha256: 7f584c71e9e912935f829cb4667411ae3c3048fcd8b935170fb5a45188019403 + original: + hackage: deque-0.4.2.3 +- completed: + hackage: strict-list-0.1.4@sha256:0fa869e2c21b710b7133e8628169f120fe6299342628edd3d5087ded299bc941,1631 + pantry-tree: + size: 340 + sha256: bbb22fd014867dc48697ddd8598d4a9fb03fa2d58ef79bed94f208a9b6d94224 + original: + hackage: strict-list-0.1.4 +- completed: + hackage: ghc-exactprint-0.5.8.2@sha256:b078e02ce263db6214f8418c8b6f6be1c8a7ca1499bb2f8936b91b5ed210faa5,7901 + pantry-tree: + size: 83871 + sha256: 1dc1dc7f036dfb8e7642deaeb2845c62731085abc29a1494c22cd6b1b5a18d16 + original: + hackage: ghc-exactprint-0.5.8.2 +snapshots: +- completed: + size: 499461 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/25.yaml + sha256: aed98969628e20615e96b06083c933c7e3354ae56b08b75e607a26569225d6c0 + original: lts-13.25 From 9971e3905d1c7bb1f54bf117650403fcc9100f73 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 20:08:27 -0600 Subject: [PATCH 09/24] Support building DataDecl with 8.2.2 --- src/Language/Haskell/Brittany/Internal/Utils.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs index eee432e..435ad96 100644 --- a/src/Language/Haskell/Brittany/Internal/Utils.hs +++ b/src/Language/Haskell/Brittany/Internal/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -58,7 +59,9 @@ import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Types import qualified Data.Generics.Uniplate.Direct as Uniplate +#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */ import qualified HsExtension +#endif From aeaa043e99d4e4469dac782643695c73c3e99d38 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 21:01:03 -0600 Subject: [PATCH 10/24] Support building DataDecl with 8.0.2 --- .../Brittany/Internal/Layouters/DataDecl.hs | 27 +++++++++++++++++-- .../Brittany/Internal/Layouters/Decl.hs | 4 ++- 2 files changed, 28 insertions(+), 3 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index fed333e..c900156 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE KindSignatures #-} @@ -171,6 +172,7 @@ createDerivingPar :: HsDeriving GhcPs -> ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered createDerivingPar derivs mainDoc = do case derivs of +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ (L _ []) -> docLines [mainDoc] (L _ types) -> docPar mainDoc @@ -179,13 +181,26 @@ createDerivingPar derivs mainDoc = do $ docWrapNode derivs $ derivingClauseDoc <$> types +#else + Nothing -> docLines [mainDoc] + Just types -> + docPar mainDoc + $ docEnsureIndent BrIndentRegular + $ derivingClauseDoc types +#endif +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ derivingClauseDoc :: LHsDerivingClause GhcPs -> ToBriDocM BriDocNumbered +#else +derivingClauseDoc :: Located [LHsSigType GhcPs] -> ToBriDocM BriDocNumbered +#endif #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ derivingClauseDoc (L _ (XHsDerivingClause ext)) = absurdExt ext derivingClauseDoc (L _ (HsDerivingClause _ext mStrategy types)) = case types of -#else +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of +#else +derivingClauseDoc types = case types of #endif (L _ []) -> docSeq [] (L _ ts) -> @@ -193,7 +208,11 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of tsLength = length ts whenMoreThan1Type val = if tsLength > 1 then docLit (Text.pack val) else docLit (Text.pack "") +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy +#else + (lhsStrategy, rhsStrategy) = (docEmpty, docEmpty) +#endif in docSeq [ docDeriving @@ -207,12 +226,15 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsIB _ t -> layoutType t XHsImplicitBndrs x -> absurdExt x -#else +#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ HsIB _ t _ -> layoutType t +#else + HsIB _ t -> layoutType t #endif , whenMoreThan1Type ")" , rhsStrategy ] +#if MIN_VERSION_ghc(8,2,0) /* ghc-8.6 */ where strategyLeftRight = \case (L _ StockStrategy ) -> (docLit $ Text.pack " stock", docEmpty) @@ -230,6 +252,7 @@ derivingClauseDoc (L _ (HsDerivingClause mStrategy types)) = case types of XHsImplicitBndrs ext -> absurdExt ext ) #endif +#endif docDeriving :: ToBriDocM BriDocNumbered docDeriving = docLit $ Text.pack "deriving" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 153774f..5f99020 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -743,8 +743,10 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ #if MIN_VERSION_ghc(8,6,0) DataDecl _ext name tyVars _ dataDefn -> -#else +#elif MIN_VERSION_ghc(8,2,0) DataDecl name tyVars _ dataDefn _ _ -> +#else + DataDecl name tyVars dataDefn _ _ -> #endif docWrapNodePrior ltycl $ layoutDataDecl ltycl name tyVars dataDefn From b2f4262749dbc601f2e66901d2575003271ac683 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 21:04:42 -0600 Subject: [PATCH 11/24] Isolate deriving via test --- src-literatetests/10-tests.blt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index d12ba21..3a188de 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -363,6 +363,12 @@ data Foo = Bar deriving anyclass (Show, Eq, Monad, Functor) deriving newtype Show deriving newtype (Traversable, Foldable) + +#test record deriving via +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } deriving ToJSON via (SomeType) deriving (ToJSON, FromJSON) via (SomeType) From ea9d3bb5b3fad544e59d5d08f5d6d872383c2c55 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sun, 3 Nov 2019 21:05:34 -0600 Subject: [PATCH 12/24] Add stack lock file for 8.0.2 --- stack-8.0.2.yaml.lock | 54 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 stack-8.0.2.yaml.lock diff --git a/stack-8.0.2.yaml.lock b/stack-8.0.2.yaml.lock new file mode 100644 index 0000000..08d3ffb --- /dev/null +++ b/stack-8.0.2.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: monad-memo-0.4.1@sha256:d7575b0c89ad21818ca5746170d10a3b92f01fdf9028fa37d3a370e42b24b38b,3672 + pantry-tree: + size: 1823 + sha256: 8d7bcc8a8bce43804613a160fd7f0fea7869a54e530a9f1b9f9e853ec4e00b57 + original: + hackage: monad-memo-0.4.1 +- completed: + hackage: czipwith-1.0.1.0@sha256:30751c5a92488304863f20403cd8e9d4fee2b5def0b656a3d979aa3331a09c00,1652 + pantry-tree: + size: 323 + sha256: acd60968c5a1945741204751243f88d1af1c152018c2d9575f62c0805825f44f + original: + hackage: czipwith-1.0.1.0 +- completed: + hackage: butcher-1.3.1.1@sha256:d5734df2e42c28c5a8419eb8251cc531e5f5e6a13794b2ae1dac04abd1c359ad,3242 + pantry-tree: + size: 1197 + sha256: 057b5c8aa0211951337d87cda1f3d4c6f049945314f6fc7883394eebac79be5b + original: + hackage: butcher-1.3.1.1 +- completed: + hackage: data-tree-print-0.1.0.0@sha256:6610723626501d3ab65dc2290c0de59de8d042caf72a1db1e0cd01e84d229346,1547 + pantry-tree: + size: 272 + sha256: caa741fd498f754b42d45a16aae455056d5e71df51e960fce1579b8e8b6496ad + original: + hackage: data-tree-print-0.1.0.0 +- completed: + hackage: deque-0.2@sha256:a9736298cd04472924b3b681b3791c99e8b6009a6e5df1ff13dd57457109ad43,877 + pantry-tree: + size: 205 + sha256: c48e1f58dfac107ba9dd8d159d4c033fd72521de678204788e3f01f7a2e17546 + original: + hackage: deque-0.2 +- completed: + hackage: ghc-exactprint-0.5.8.0@sha256:71915a08a7d442d39a63cb3b0fbd90b7dacd19bc4b05bac5c53b6e8a0d931b7b,7728 + pantry-tree: + size: 83871 + sha256: 3998143d33f7de29b31e8cf8d1b207c1fb4962f819fc820e209e1eecbf7e5a35 + original: + hackage: ghc-exactprint-0.5.8.0 +snapshots: +- completed: + size: 533451 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/9/0.yaml + sha256: 27f29b231b39ea68e967a7a4346b2693a49d77c50f41fc0c276e11189a538da7 + original: lts-9.0 From 48490a71100eb2b90b83a12c75e30ecd9a9cd2f4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 31 Oct 2019 13:44:52 +0100 Subject: [PATCH 13/24] Fix handling of comment before data-decl `docWrapNodePrior` caused duplication of offset of `data` keyword and of comments connected to it. --- src-literatetests/10-tests.blt | 5 +++++ .../Haskell/Brittany/Internal/Layouters/DataDecl.hs | 6 ++++++ src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs | 3 +-- 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 3a188de..0217311 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -385,6 +385,11 @@ data Foo = forall a b . (Show a, Eq b) => Bar , bars :: b } +#test plain comment simple +-- before +data MyData = MyData Int +-- after + #test record comments simple data Foo = Bar -- a { foo :: Baz -- b diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index c900156..5dbb8db 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -46,6 +46,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs) defn = case defn of #else layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of #endif + -- newtype MyType a b = MyType .. #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of (L _ (ConDeclH98 _ext consName (L _ False) _qvars (Just (L _ [])) details _conDoc)) -> @@ -74,6 +75,9 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of ] _ -> briDocByExactNoComment ltycl + + -- data MyData a b + -- (zero constructors) #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [] mDerivs -> #else @@ -90,6 +94,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of , appSep tyVarLine ] + -- data MyData = MyData .. + -- data MyData = MyData { .. } #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> #else diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 5f99020..fbbcafd 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -748,8 +748,7 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of #else DataDecl name tyVars dataDefn _ _ -> #endif - docWrapNodePrior ltycl $ - layoutDataDecl ltycl name tyVars dataDefn + layoutDataDecl ltycl name tyVars dataDefn _ -> briDocByExactNoComment ltycl layoutSynDecl From 54f34344b3ef523a2909176b4aa499fa774e2b74 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 7 Nov 2019 00:58:38 +0100 Subject: [PATCH 14/24] Implement #min-ghc keyword for test script --- src-literatetests/10-tests.blt | 28 ++++-- src-literatetests/Main.hs | 167 +++++++++++++++++++-------------- 2 files changed, 121 insertions(+), 74 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 0217311..44e82e0 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -365,6 +365,7 @@ data Foo = Bar deriving newtype (Traversable, Foldable) #test record deriving via +#min-ghc 8.6 data Foo = Bar { foo :: Baz , bars :: Bizzz @@ -424,12 +425,27 @@ data Foo = Bar , -- e FromJSON --f ) -- g - via -- h - ( -- i - SomeType --j - , -- k - ABC --l - ) + +#test record comments in deriving via +## maybe we want to switch to a differnt layout when there are such comments. +## Don't hesitate to modify this testcase, it clearly is not the ideal layout +## for this. +#min-ghc 8.6 + +data Foo = Bar + { foo :: Baz + , bars :: Bizzz + } + -- a + deriving --a + ToJSON --b + via -- c + ( -- d + SomeType --e + , -- f + ABC --g + ) + ############################################################################### ############################################################################### diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 435e328..93ae27a 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -1,42 +1,56 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} -module Main (main) where +module Main + ( main + ) +where #include "prelude.inc" -import Test.Hspec -import Test.Hspec.Runner ( hspecWith, defaultConfig, configConcurrentJobs ) +import Test.Hspec +import Test.Hspec.Runner ( hspecWith + , defaultConfig + , configConcurrentJobs + ) -import NeatInterpolation +import NeatInterpolation -import qualified Text.Parsec as Parsec -import Text.Parsec.Text ( Parser ) +import qualified Text.Parsec as Parsec +import Text.Parsec.Text ( Parser ) -import Data.Char ( isSpace ) -import Data.List ( groupBy ) +import Data.Char ( isSpace ) +import Data.List ( groupBy ) -import Language.Haskell.Brittany.Internal +import Language.Haskell.Brittany.Internal -import Language.Haskell.Brittany.Internal.Config.Types -import Language.Haskell.Brittany.Internal.Config +import Language.Haskell.Brittany.Internal.Config.Types +import Language.Haskell.Brittany.Internal.Config -import Data.Coerce ( coerce ) +import Data.Coerce ( coerce ) -import qualified Data.Text.IO as Text.IO -import System.FilePath ( () ) +import qualified Data.Text.IO as Text.IO +import System.FilePath ( () ) data InputLine = GroupLine Text | HeaderLine Text + | GhcVersionGuardLine Text | PendingLine | NormalLine Text | CommentLine deriving Show +data TestCase = TestCase + { testName :: Text + , isPending :: Bool + , minGHCVersion :: Maybe Text + , content :: Text + } main :: IO () main = do @@ -44,28 +58,39 @@ main = do let blts = List.sort $ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) - $ filter (".blt"`isSuffixOf`) files + $ filter (".blt" `isSuffixOf`) files inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" blt) let groups = createChunks =<< inputs inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" let groupsCtxFree = createChunks inputCtxFree + let parseVersion :: Text -> Maybe [Int] + parseVersion = + mapM (readMaybe . Text.unpack) . Text.splitOn (Text.pack ".") + let ghcVersion = Data.Maybe.fromJust $ parseVersion $ Text.pack VERSION_ghc + let checkVersion = \case + Nothing -> True -- no version constraint + Just s -> case parseVersion s of + Nothing -> error $ "could not parse version " ++ Text.unpack s + Just v -> v <= ghcVersion hspec $ do 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 defaultTestConfig inp + describe (Text.unpack groupname) $ do + tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do + (if isPending test then before_ pending else id) + $ it (Text.unpack $ testName test) + $ roundTripEqual defaultTestConfig + $ content test groupsCtxFree `forM_` \(groupname, tests) -> do - describe ("context free: " ++ Text.unpack groupname) - $ tests - `forM_` \(name, pend, inp) -> do - (if pend then before_ pending else id) - $ it (Text.unpack name) - $ roundTripEqual contextFreeTestConfig inp + describe ("context free: " ++ Text.unpack groupname) $ do + tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do + (if isPending test then before_ pending else id) + $ it (Text.unpack $ testName test) + $ roundTripEqual contextFreeTestConfig + $ content test 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 :: Text -> [(Text, [TestCase])] createChunks input = -- fmap (\case -- HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines) @@ -73,35 +98,39 @@ main = do -- 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 + fmap groupProcessor + $ groupBy grouperG + $ filter (not . lineIsSpace) + $ fmap lineMapper + $ Text.lines input where + groupProcessor :: [InputLine] -> (Text, [TestCase]) + groupProcessor = \case + GroupLine g : grouprest -> + (,) g + $ fmap testProcessor + $ groupBy grouperT + $ filter (not . lineIsSpace) + $ grouprest + l -> error $ "first non-empty line must be a #group\n" ++ show l + testProcessor :: [InputLine] -> TestCase + testProcessor = \case + HeaderLine n : rest -> + let normalLines = Data.Maybe.mapMaybe extractNormal rest + in TestCase + { testName = n + , isPending = any isPendingLine rest + , minGHCVersion = Data.List.Extra.firstJust extractMinGhc rest + , content = Text.unlines normalLines + } + l -> + error $ "first non-empty line must start with #test footest\n" ++ show l extractNormal (NormalLine l) = Just l extractNormal _ = Nothing + extractMinGhc (GhcVersionGuardLine v) = Just v + extractMinGhc _ = Nothing + isPendingLine PendingLine{} = True + isPendingLine _ = False specialLineParser :: Parser InputLine specialLineParser = Parsec.choice [ [ GroupLine $ Text.pack name @@ -116,6 +145,11 @@ main = do , name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , _ <- Parsec.eof ] + , [ GhcVersionGuardLine $ Text.pack version + | _ <- Parsec.try $ Parsec.string "#min-ghc" + , _ <- Parsec.many1 $ Parsec.oneOf " \t" + , version <- Parsec.many1 $ Parsec.noneOf "\r\n:" + ] , [ PendingLine | _ <- Parsec.try $ Parsec.string "#pending" , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") @@ -123,8 +157,8 @@ main = do ] , [ CommentLine | _ <- Parsec.many $ Parsec.oneOf " \t" - , _ <- - Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n") + , _ <- Parsec.optional $ Parsec.string "##" <* many + (Parsec.noneOf "\r\n") , _ <- Parsec.eof ] ] @@ -148,8 +182,7 @@ main = do -------------------- roundTripEqual :: Config -> Text -> Expectation roundTripEqual c t = - fmap (fmap PPTextWrapper) - (parsePrintModuleTests c "TestFakeFileName.hs" t) + fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t) `shouldReturn` Right (PPTextWrapper t) newtype PPTextWrapper = PPTextWrapper Text @@ -158,7 +191,8 @@ newtype PPTextWrapper = PPTextWrapper Text instance Show PPTextWrapper where show (PPTextWrapper t) = "\n" ++ Text.unpack t - +-- brittany-next-binding --columns 160 +-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft } defaultTestConfig :: Config defaultTestConfig = Config { _conf_version = _conf_version staticDefaultConfig @@ -181,21 +215,18 @@ defaultTestConfig = Config , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) - { _econf_omit_output_valid_check = coerce True - } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig - , _conf_forward = ForwardOptions {_options_ghc = Identity []} + , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False - , _conf_obfuscate = coerce False + , _conf_obfuscate = coerce False } contextFreeTestConfig :: Config -contextFreeTestConfig = - defaultTestConfig +contextFreeTestConfig = defaultTestConfig { _conf_layout = (_conf_layout defaultTestConfig) - {_lconfig_indentPolicy = coerce IndentPolicyLeft - ,_lconfig_alignmentLimit = coerce (1 :: Int) - ,_lconfig_columnAlignMode = coerce ColumnAlignModeDisabled - } + { _lconfig_indentPolicy = coerce IndentPolicyLeft + , _lconfig_alignmentLimit = coerce (1 :: Int) + , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled + } } From a23ef696e8c63ab7a3f55100faf3504e66e9b6c2 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Thu, 7 Nov 2019 10:45:44 +0100 Subject: [PATCH 15/24] Fix test failure: DerivingStrategies exists since ghc-8.2 --- src-literatetests/10-tests.blt | 1 + 1 file changed, 1 insertion(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 44e82e0..1701b1d 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -351,6 +351,7 @@ data Foo = Bar deriving (Show, Eq, Monad, Functor, Traversable, Foldable) #test record multiple deriving strategies +#min-ghc 8.2 data Foo = Bar { foo :: Baz , bars :: Bizzz From 9494d6203a16138252c8147c315a03bef540d65d Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Thu, 7 Nov 2019 14:54:42 -0600 Subject: [PATCH 16/24] Allow multi line formatting of normal records Only single line formatting of normal records was being supported. For records with long names we need multi line formatting. This also needs to support both multi and left indentation policies. --- src-literatetests/10-tests.blt | 18 ++++++++++++ .../Brittany/Internal/Layouters/DataDecl.hs | 28 +++++++++++++++---- 2 files changed, 41 insertions(+), 5 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 1701b1d..0c1adfd 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -447,6 +447,24 @@ data Foo = Bar ABC --g ) +#test normal records on multi line indent policy left +-- brittany {lconfig_indentPolicy: IndentPolicyLeft } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] + +#test normal records on multi line indent policy free +-- brittany {lconfig_indentPolicy: IndentPolicyFree } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] + +#test normal records on multi line indent policy multiple +-- brittany {lconfig_indentPolicy: IndentPolicyMultiple } +data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse + Types.Company + [EnterpriseGrantResponse] + ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 5dbb8db..2214478 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -266,11 +266,29 @@ docDeriving = docLit $ Text.pack "deriving" createDetailsDoc :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of - PrefixCon args -> docSeq - [ docLit consNameStr - , docSeparator - , docSeq $ List.intersperse docSeparator $ args <&> layoutType - ] + PrefixCon args -> do + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + let + singleLine = docSeq + [ docLit consNameStr + , docSeparator + , docSeq $ List.intersperse docSeparator $ args <&> layoutType + ] + leftIndented = docSetParSpacing + . docAddBaseY BrIndentRegular + . docPar (docLit consNameStr) + . docLines + $ layoutType <$> args + multiIndented = docSetParSpacing + . docSetBaseAndIndent + . docPar (docLit consNameStr) + . docLines + $ layoutType + <$> args + case indentPolicy of + IndentPolicyLeft -> docAlt [singleLine, leftIndented] + IndentPolicyMultiple -> docAlt [singleLine, multiIndented] + IndentPolicyFree -> docAlt [singleLine, multiIndented] RecCon (L _ []) -> docEmpty #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> docSeq From c367b1017b390de5b37de25fe8a3cc98b6f13ac8 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Nov 2019 12:06:08 +0100 Subject: [PATCH 17/24] Fixup src-literatetests/Main formatting --- src-literatetests/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 93ae27a..82f97cb 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -215,7 +215,7 @@ defaultTestConfig = Config , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False } - , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } + , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_forward = ForwardOptions { _options_ghc = Identity [] } , _conf_roundtrip_exactprint_only = coerce False From 0381b9fe24172bb17b890a276f866d34fb17bb44 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Fri, 8 Nov 2019 12:14:01 +0100 Subject: [PATCH 18/24] Fix record field comment indentation --- src-literatetests/10-tests.blt | 7 ++++++ .../Brittany/Internal/Layouters/DataDecl.hs | 23 ++++++++++--------- 2 files changed, 19 insertions(+), 11 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 0c1adfd..40a8852 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -392,6 +392,13 @@ data Foo = forall a b . (Show a, Eq b) => Bar data MyData = MyData Int -- after +#test record newline comment +data MyRecord = MyRecord + { a :: Int + -- comment + , b :: Int + } + #test record comments simple data Foo = Bar -- a { foo :: Baz -- b diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 2214478..19ec610 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -291,21 +291,22 @@ createDetailsDoc consNameStr details = case details of IndentPolicyFree -> docAlt [singleLine, multiIndented] RecCon (L _ []) -> docEmpty #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> docSeq + RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> #else - RecCon lRec@(L _ [lField@(L _ (ConDeclField names t _))]) -> docSeq + RecCon lRec@(L _ [lField@(L _ (ConDeclField names t _))]) -> #endif - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLit $ Text.pack "{" - , docSeparator - , docWrapNodeRest lRec $ docSeq $ createNamesAndTypeDoc lField names t - , docSeparator - , docLit $ Text.pack "}" - ] + docSetIndentLevel $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLit $ Text.pack "{" + , docSeparator + , docWrapNodeRest lRec $ docSeq $ fmap docForceSingleline $ createNamesAndTypeDoc lField names t + , docSeparator + , docLit $ Text.pack "}" + ] RecCon lRec@(L _ fields@(_:_)) -> do let (fDoc1 : fDocR) = mkFieldDocs fields - docAddBaseY BrIndentRegular $ docPar + docAddBaseY BrIndentRegular $ docSetIndentLevel $ docPar (docLit consNameStr) (docWrapNodePrior lRec $ docLines [ docCols ColRecDecl From 80f370a8e10690e65718f66dd72de12d6d771f05 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Tue, 12 Nov 2019 16:02:14 -0600 Subject: [PATCH 19/24] Support nullary data types Add tests for nullary prefix data types and nullary record data types. --- src-literatetests/10-tests.blt | 5 +++++ src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 40a8852..0a3140b 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -318,6 +318,11 @@ func = f ############################################################################### ############################################################################### +#test nullary data type +data Foo = Bar {} + +data Biz = Baz + #test single record data Foo = Bar { foo :: Baz } diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 19ec610..4bb2a98 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -289,7 +289,7 @@ createDetailsDoc consNameStr details = case details of IndentPolicyLeft -> docAlt [singleLine, leftIndented] IndentPolicyMultiple -> docAlt [singleLine, multiIndented] IndentPolicyFree -> docAlt [singleLine, multiIndented] - RecCon (L _ []) -> docEmpty + RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> #else From 5a49277eba71e124fb822706427c157af0f68dff Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 25 Nov 2019 11:59:25 +0100 Subject: [PATCH 20/24] Improve data decl layouting - Fix bug in BackendUtil/lowest level of brittany about alignment being ignored after a comment, - Properly layout large (more than single-line) types in record fields and in data decl rhs arguments, - Properly layout data decl constructors with large "heads" (forall, constraints), - Add a config flag to control single-line layout of record definition, --- src-literatetests/10-tests.blt | 116 ++++++- src-literatetests/30-tests-context-free.blt | 8 +- src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + .../Haskell/Brittany/Internal/BackendUtils.hs | 8 +- .../Haskell/Brittany/Internal/Config.hs | 2 + .../Haskell/Brittany/Internal/Config/Types.hs | 8 + .../Brittany/Internal/LayouterBasics.hs | 4 + .../Brittany/Internal/Layouters/DataDecl.hs | 327 +++++++++++++----- 9 files changed, 368 insertions(+), 107 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 0a3140b..2e46148 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -324,10 +324,14 @@ data Foo = Bar {} data Biz = Baz #test single record -data Foo = Bar { foo :: Baz } +data Foo = Bar + { foo :: Baz + } #test record multiple names -data Foo = Bar { foo, bar :: Baz } +data Foo = Bar + { foo, bar :: Baz + } #test record multiple types data Foo = Bar @@ -348,6 +352,91 @@ data Foo = Bar } deriving Show +#test record long field names +data MyRecord = MyConstructor + { bar1, bar2 + :: Loooooooooooooooooooooooooooooooong + -> Loooooooooooooooooooooooooooooooong + , foo1, foo2 + :: Loooooooooooooooooooooooooooooooonger + -> Loooooooooooooooooooooooooooooooonger + } + +#test record with DataTypeContexts +{-# LANGUAGE DatatypeContexts #-} +data + ( LooooooooooooooooooooongConstraint a + , LooooooooooooooooooooongConstraint b + ) => + MyRecord a b + = MyConstructor + { foo1, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } + +#test record single line layout +{-# LANGUAGE ScopedTypeVariables #-} +-- brittany { lconfig_allowSinglelineRecord: true } +data MyRecord = forall a . Show a => MyCons { foo :: a -> a, i :: Int } + +#test record no matching single line layout +{-# LANGUAGE ScopedTypeVariables #-} +-- brittany { lconfig_allowSinglelineRecord: true } +data MyRecord = forall a . Show a => Bar + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } + +#test record forall constraint multiline +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a + . LooooooooooooooooooooongConstraint a => + LoooooooooooongConstructor + { foo :: abittoolongbutnotvery -> abittoolongbutnotvery + } + +#test record forall constraint multiline more +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { a :: a + , b :: b + } + +#test plain with forall and constraint +{-# LANGUAGE ScopedTypeVariables #-} +data MyStruct + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) + (ToBriDocM BriDocNumbered) + +#test record with many features +{-# LANGUAGE ScopedTypeVariables #-} +data MyRecord + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor + { foo, foo2 + :: loooooooooooooooooooooooooooooooong + -> loooooooooooooooooooooooooooooooong + , bar :: a + , bazz :: b + } + deriving Show + #test record multiple types deriving data Foo = Bar { foo :: Baz @@ -382,7 +471,9 @@ data Foo = Bar #test single record existential {-# LANGUAGE ExistentialQuantification #-} -data Foo = forall a . Show a => Bar { foo :: a } +data Foo = forall a . Show a => Bar + { foo :: a + } #test record multiple types existential {-# LANGUAGE ExistentialQuantification #-} @@ -415,8 +506,8 @@ data Foo = Bar -- a data Foo = Bar { -- a foo -- b - :: -- c - Baz -- d + :: -- c + Baz -- d , -- e bars :: Bizzz } @@ -467,16 +558,19 @@ data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse #test normal records on multi line indent policy free -- brittany {lconfig_indentPolicy: IndentPolicyFree } +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] + +#test normal records on multi line indent policy free 2 +-- brittany {lconfig_indentPolicy: IndentPolicyFree } data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] + Types.Company + [EnterpriseGrantResponse] #test normal records on multi line indent policy multiple -- brittany {lconfig_indentPolicy: IndentPolicyMultiple } -data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse - Types.Company - [EnterpriseGrantResponse] - +data GrantsForCompanyResp = GrantsForCompanyResp Types.Company + [EnterpriseGrantResponse] ############################################################################### ############################################################################### diff --git a/src-literatetests/30-tests-context-free.blt b/src-literatetests/30-tests-context-free.blt index 9a09fde..ba84a7c 100644 --- a/src-literatetests/30-tests-context-free.blt +++ b/src-literatetests/30-tests-context-free.blt @@ -321,10 +321,14 @@ func = f ############################################################################### #test single record -data Foo = Bar { foo :: Baz } +data Foo = Bar + { foo :: Baz + } #test record multiple names -data Foo = Bar { foo, bar :: Baz } +data Foo = Bar + { foo, bar :: Baz + } #test record multiple types data Foo = Bar diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index 82f97cb..d0b9094 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -214,6 +214,7 @@ defaultTestConfig = Config , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False + , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index d9555cc..f2dc542 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -61,6 +61,7 @@ defaultTestConfig = Config , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False + , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index 508a18c..bf30a4e 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -245,9 +245,10 @@ layoutWriteEnsureAbsoluteN -> m () layoutWriteEnsureAbsoluteN n = do state <- mGet - let diff = case _lstate_curYOrAddNewline state of - Left i -> n - i - Right{} -> n + let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of + (Just c , _ ) -> n - c + (Nothing, Left i ) -> n - i + (Nothing, Right{}) -> n traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) when (diff > 0) $ do mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to @@ -557,6 +558,7 @@ layoutWritePostComments ast = do ) -> do replicateM_ x layoutWriteNewline layoutWriteAppend $ Text.pack $ replicate y ' ' + mModify $ \s -> s { _lstate_addSepSpace = Nothing } layoutWriteAppendMultiline $ Text.pack $ comment layoutIndentRestorePostComment diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 5d220fd..9dac6b7 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -77,6 +77,7 @@ staticDefaultConfig = Config , _lconfig_allowSingleLineExportList = coerce False , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False + , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -181,6 +182,7 @@ cmdlineConfigParser = do , _lconfig_allowSingleLineExportList = mempty , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty + , _lconfig_allowSinglelineRecord = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 29711c5..526afef 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -142,6 +142,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 + -- > } } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d7acf16..d46421e 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -13,6 +13,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , filterAnns , docEmpty , docLit + , docLitS , docAlt , CollectAltM , addAlternativeCond @@ -481,6 +482,9 @@ docEmpty = allocateNode BDFEmpty docLit :: Text -> ToBriDocM BriDocNumbered docLit t = allocateNode $ BDFLit t +docLitS :: String -> ToBriDocM BriDocNumbered +docLitS s = allocateNode $ BDFLit $ Text.pack s + docExt :: (ExactPrint.Annotate.Annotate ast) => Located ast diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 4bb2a98..e11acfa 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -59,17 +59,17 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of consNameStr <- lrdrNameToTextAnn consName tyVarLine <- fmap return $ createBndrDoc bndrs -- headDoc <- fmap return $ docSeq - -- [ appSep $ docLit (Text.pack "newtype") + -- [ appSep $ docLitS "newtype") -- , appSep $ docLit nameStr -- , appSep tyVarLine -- ] rhsDoc <- fmap return $ createDetailsDoc consNameStr details createDerivingPar mDerivs $ docSeq - [ appSep $ docLit (Text.pack "newtype") + [ appSep $ docLitS "newtype" , appSep $ docLit nameStr , appSep tyVarLine , docSeparator - , docLit (Text.pack "=") + , docLitS "=" , docSeparator , rhsDoc ] @@ -88,7 +88,7 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of nameStr <- lrdrNameToTextAnn name tyVarLine <- fmap return $ createBndrDoc bndrs createDerivingPar mDerivs $ docSeq - [ appSep $ docLit (Text.pack "data") + [ appSep $ docLitS "data" , lhsContextDoc , appSep $ docLit nameStr , appSep tyVarLine @@ -112,22 +112,115 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName tyVarLine <- fmap return $ createBndrDoc bndrs - forallDoc <- docSharedWrapper createForallDoc qvars - rhsContextDoc <- case mRhsContext of - Nothing -> return docEmpty - Just (L _ ctxt) -> docSharedWrapper createContextDoc ctxt + forallDocMay <- case createForallDoc qvars of + Nothing -> pure Nothing + Just x -> Just . pure <$> x + rhsContextDocMay <- case mRhsContext of + Nothing -> pure Nothing + Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt rhsDoc <- fmap return $ createDetailsDoc consNameStr details - createDerivingPar mDerivs $ docSeq - [ appSep $ docLit (Text.pack "data") - , lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - , docLit (Text.pack "=") - , docSeparator - , forallDoc - , rhsContextDoc - , rhsDoc + consDoc <- fmap pure + $ docNonBottomSpacing + $ case (forallDocMay, rhsContextDocMay) of + (Just forallDoc, Just rhsContextDoc) -> docLines + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq + [ docLitS "." + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + ] + (Just forallDoc, Nothing) -> docLines + [ docSeq [docLitS "=", docSeparator, docForceSingleline forallDoc] + , docSeq [docLitS ".", docSeparator, rhsDoc] + ] + (Nothing, Just rhsContextDoc) -> docSeq + [ docLitS "=" + , docSeparator + , docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + (Nothing, Nothing) -> docSeq [docLitS "=", docSeparator, rhsDoc] + createDerivingPar mDerivs $ docAlt + [ -- data D = forall a . Show a => D a + docSeq + [ appSep $ docLitS "data" + , docForceSingleline $ lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + , docLitS "=" + , docSeparator + , case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + , -- data D + -- = forall a . Show a => D a + docAddBaseY BrIndentRegular $ docPar + ( docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + ( docSeq + [ docLitS "=" + , docSeparator + , case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] + ) + , -- data D + -- = forall a + -- . Show a => + -- D a + docAddBaseY BrIndentRegular $ docPar + ( docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + consDoc + , -- data + -- Show a => + -- D + -- = forall a + -- . Show a => + -- D a + -- This alternative is only for -XDatatypeContexts. + -- But I think it is rather unlikely this will trigger without + -- -XDataTypeContexts, especially with the `docNonBottomSpacing` + -- above, so while not strictly necessary, this should not + -- hurt. + docAddBaseY BrIndentRegular $ docPar + (docLitS "data") + ( docLines + [ lhsContextDoc + , docSeq + [ appSep $ docLit nameStr + , tyVarLine + ] + , consDoc + ] + ) ] _ -> briDocByExactNoComment ltycl @@ -136,13 +229,25 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered createContextDoc [] = docEmpty createContextDoc [t] = - docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator] -createContextDoc ts = docSeq - [ docLit (Text.pack "(") - , docSeq $ List.intersperse docCommaSep (layoutType <$> ts) - , docLit (Text.pack ") =>") - , docSeparator - ] + docSeq [layoutType t, docSeparator, docLitS "=>", docSeparator] +createContextDoc (t1 : tR) = do + t1Doc <- docSharedWrapper layoutType t1 + tRDocs <- tR `forM` docSharedWrapper layoutType + docAlt + [ docSeq + [ docLitS "(" + , docForceSingleline $ docSeq $ List.intersperse docCommaSep + (t1Doc : tRDocs) + , docLitS ") =>" + , docSeparator + ] + , docLines $ join + [ [docSeq [docLitS "(", docSeparator, t1Doc]] + , tRDocs + <&> \tRDoc -> docSeq [docLitS ",", docSeparator, tRDoc] + , [docLitS ") =>", docSeparator] + ] + ] createBndrDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered createBndrDoc bs = do @@ -165,13 +270,13 @@ createBndrDoc bs = do <&> \(vname, mKind) -> case mKind of Nothing -> docLit vname Just kind -> docSeq - [ docLit (Text.pack "(") + [ docLitS "(" , docLit vname , docSeparator - , docLit (Text.pack "::") + , docLitS "::" , docSeparator , kind - , docLit (Text.pack ")") + , docLitS ")" ] createDerivingPar @@ -179,7 +284,7 @@ createDerivingPar createDerivingPar derivs mainDoc = do case derivs of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ - (L _ []) -> docLines [mainDoc] + (L _ []) -> mainDoc (L _ types) -> docPar mainDoc $ docEnsureIndent BrIndentRegular @@ -188,7 +293,7 @@ createDerivingPar derivs mainDoc = do $ derivingClauseDoc <$> types #else - Nothing -> docLines [mainDoc] + Nothing -> mainDoc Just types -> docPar mainDoc $ docEnsureIndent BrIndentRegular @@ -213,7 +318,7 @@ derivingClauseDoc types = case types of let tsLength = length ts whenMoreThan1Type val = - if tsLength > 1 then docLit (Text.pack val) else docLit (Text.pack "") + if tsLength > 1 then docLitS val else docLitS "" #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ (lhsStrategy, rhsStrategy) = maybe (docEmpty, docEmpty) strategyLeftRight mStrategy #else @@ -243,15 +348,15 @@ derivingClauseDoc types = case types of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.6 */ where strategyLeftRight = \case - (L _ StockStrategy ) -> (docLit $ Text.pack " stock", docEmpty) - (L _ AnyclassStrategy ) -> (docLit $ Text.pack " anyclass", docEmpty) - (L _ NewtypeStrategy ) -> (docLit $ Text.pack " newtype", docEmpty) + (L _ StockStrategy ) -> (docLitS " stock", docEmpty) + (L _ AnyclassStrategy ) -> (docLitS " anyclass", docEmpty) + (L _ NewtypeStrategy ) -> (docLitS " newtype", docEmpty) #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ lVia@(L _ (ViaStrategy viaTypes) ) -> ( docEmpty , case viaTypes of HsIB _ext t -> docSeq - [ docWrapNode lVia $ docLit $ Text.pack " via" + [ docWrapNode lVia $ docLitS " via" , docSeparator , layoutType t ] @@ -261,62 +366,109 @@ derivingClauseDoc types = case types of #endif docDeriving :: ToBriDocM BriDocNumbered -docDeriving = docLit $ Text.pack "deriving" +docDeriving = docLitS "deriving" createDetailsDoc :: Text -> HsConDeclDetails GhcPs -> (ToBriDocM BriDocNumbered) createDetailsDoc consNameStr details = case details of PrefixCon args -> do - indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack + indentPolicy <- mAsk <&> _conf_layout .> _lconfig_indentPolicy .> confUnpack let singleLine = docSeq [ docLit consNameStr , docSeparator - , docSeq $ List.intersperse docSeparator $ args <&> layoutType + , docForceSingleline + $ docSeq + $ List.intersperse docSeparator + $ args <&> layoutType ] leftIndented = docSetParSpacing . docAddBaseY BrIndentRegular . docPar (docLit consNameStr) . docLines $ layoutType <$> args - multiIndented = docSetParSpacing - . docSetBaseAndIndent - . docPar (docLit consNameStr) - . docLines - $ layoutType - <$> args + multiAppended = docSeq + [ docLit consNameStr + , docSeparator + , docSetBaseY $ docLines $ layoutType <$> args + ] + multiIndented = docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + (docLit consNameStr) + (docLines $ layoutType <$> args) case indentPolicy of IndentPolicyLeft -> docAlt [singleLine, leftIndented] - IndentPolicyMultiple -> docAlt [singleLine, multiIndented] - IndentPolicyFree -> docAlt [singleLine, multiIndented] + IndentPolicyMultiple -> docAlt [singleLine, multiAppended, leftIndented] + IndentPolicyFree -> + docAlt [singleLine, multiAppended, multiIndented, leftIndented] RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] -#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - RecCon lRec@(L _ [lField@(L _ (ConDeclField _ext names t _))]) -> -#else - RecCon lRec@(L _ [lField@(L _ (ConDeclField names t _))]) -> -#endif - docSetIndentLevel $ docSeq - [ docLit consNameStr - , docSeparator - , docWrapNodePrior lRec $ docLit $ Text.pack "{" - , docSeparator - , docWrapNodeRest lRec $ docSeq $ fmap docForceSingleline $ createNamesAndTypeDoc lField names t - , docSeparator - , docLit $ Text.pack "}" - ] RecCon lRec@(L _ fields@(_:_)) -> do - let (fDoc1 : fDocR) = mkFieldDocs fields - docAddBaseY BrIndentRegular $ docSetIndentLevel $ docPar - (docLit consNameStr) - (docWrapNodePrior lRec $ docLines - [ docCols ColRecDecl - $ appSep (docLit (Text.pack "{")) - : fDoc1 - , docWrapNodeRest lRec $ docLines $ fDocR <&> \f -> - docCols ColRecDecl $ docCommaSep : f - , docLit $ Text.pack "}" - ] - ) + let ((fName1, fType1) : fDocR) = mkFieldDocs fields + allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack + docAddBaseY BrIndentRegular + $ docSetIndentLevel + $ runFilteredAlternative + $ do + -- single-line: { i :: Int, b :: Bool } + addAlternativeCond allowSingleline $ docSeq + [ docLit consNameStr + , docSeparator + , docWrapNodePrior lRec $ docLitS "{" + , docSeparator + , docWrapNodeRest lRec + $ docForceSingleline + $ docSeq + $ join + $ [fName1, docSeparator, docLitS "::", docSeparator, fType1] + : [ [ docLitS "," + , docSeparator + , fName + , docSeparator + , docLitS "::" + , docSeparator + , fType + ] + | (fName, fType) <- fDocR + ] + , docSeparator + , docLitS "}" + ] + addAlternative $ docPar + (docLit consNameStr) + (docWrapNodePrior lRec $ docLines + [ docAlt + [ docCols ColRecDecl + [ appSep (docLitS "{") + , appSep $ docForceSingleline fName1 + , docSeq [docLitS "::", docSeparator] + , docForceSingleline $ fType1 + ] + , docSeq + [ docLitS "{" + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName1 + (docSeq [docLitS "::", docSeparator, fType1]) + ] + ] + , docWrapNodeRest lRec $ docLines $ fDocR <&> \(fName, fType) -> + docAlt + [ docCols ColRecDecl + [ docCommaSep + , appSep $ docForceSingleline fName + , docSeq [docLitS "::", docSeparator] + , docForceSingleline fType + ] + , docSeq + [ docLitS "," + , docSeparator + , docSetBaseY $ docAddBaseY BrIndentRegular $ docPar + fName + (docSeq [docLitS "::", docSeparator, fType]) + ] + ] + , docLitS "}" + ] + ) InfixCon arg1 arg2 -> docSeq [ layoutType arg1 , docSeparator @@ -325,7 +477,9 @@ createDetailsDoc consNameStr details = case details of , layoutType arg2 ] where - mkFieldDocs :: [LConDeclField GhcPs] -> [[ToBriDocM BriDocNumbered]] + mkFieldDocs + :: [LConDeclField GhcPs] + -> [(ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered)] mkFieldDocs = fmap $ \lField -> case lField of #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ L _ (ConDeclField _ext names t _) -> createNamesAndTypeDoc lField names t @@ -334,23 +488,19 @@ createDetailsDoc consNameStr details = case details of L _ (ConDeclField names t _) -> createNamesAndTypeDoc lField names t #endif -createForallDoc :: [LHsTyVarBndr GhcPs] -> ToBriDocM BriDocNumbered -createForallDoc [] = docEmpty -createForallDoc lhsTyVarBndrs = docSeq - [ docLit (Text.pack "forall ") - , createBndrDoc lhsTyVarBndrs - , docLit (Text.pack " .") - , docSeparator - ] +createForallDoc :: [LHsTyVarBndr GhcPs] -> Maybe (ToBriDocM BriDocNumbered) +createForallDoc [] = Nothing +createForallDoc lhsTyVarBndrs = Just $ docSeq + [docLitS "forall ", createBndrDoc lhsTyVarBndrs] createNamesAndTypeDoc :: Data.Data.Data ast => Located ast -> [GenLocated t (FieldOcc GhcPs)] -> Located (HsType GhcPs) - -> [ToBriDocM BriDocNumbered] + -> (ToBriDocM BriDocNumbered, ToBriDocM BriDocNumbered) createNamesAndTypeDoc lField names t = - [ docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq + ( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq [ docSeq $ List.intersperse docCommaSep $ names @@ -362,11 +512,6 @@ createNamesAndTypeDoc lField names t = L _ (FieldOcc fieldName _) -> #endif docLit =<< lrdrNameToTextAnn fieldName - , docSeparator ] - , docWrapNodeRest lField $ docSeq - [ docLit $ Text.pack "::" - , docSeparator - , layoutType t - ] - ] + , docWrapNodeRest lField $ layoutType t + ) From 6c3d9c57c5fc730673b932b11287412d1cf9fef7 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 27 Nov 2019 21:19:10 +0100 Subject: [PATCH 21/24] Comment the single-line record decl config flag out --- src-literatetests/10-tests.blt | 1 + src-literatetests/Main.hs | 2 +- src-unittests/TestUtils.hs | 2 +- src/Language/Haskell/Brittany/Internal/Config.hs | 4 ++-- .../Haskell/Brittany/Internal/Config/Types.hs | 16 ++++++++-------- .../Brittany/Internal/Layouters/DataDecl.hs | 3 ++- 6 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 2e46148..7dc1e45 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -378,6 +378,7 @@ data } #test record single line layout +#pending config flag is disabled for now {-# LANGUAGE ScopedTypeVariables #-} -- brittany { lconfig_allowSinglelineRecord: true } data MyRecord = forall a . Show a => MyCons { foo :: a -> a, i :: Int } diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs index d0b9094..3595b1f 100644 --- a/src-literatetests/Main.hs +++ b/src-literatetests/Main.hs @@ -214,7 +214,7 @@ defaultTestConfig = Config , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False - , _lconfig_allowSinglelineRecord = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True } , _conf_preprocessor = _conf_preprocessor staticDefaultConfig diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs index f2dc542..3f24266 100644 --- a/src-unittests/TestUtils.hs +++ b/src-unittests/TestUtils.hs @@ -61,7 +61,7 @@ defaultTestConfig = Config , _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False - , _lconfig_allowSinglelineRecord = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs index 9dac6b7..a5bbdbd 100644 --- a/src/Language/Haskell/Brittany/Internal/Config.hs +++ b/src/Language/Haskell/Brittany/Internal/Config.hs @@ -77,7 +77,7 @@ staticDefaultConfig = Config , _lconfig_allowSingleLineExportList = coerce False , _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_experimentalSemicolonNewlines = coerce False - , _lconfig_allowSinglelineRecord = coerce False + -- , _lconfig_allowSinglelineRecord = coerce False } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = coerce False @@ -182,7 +182,7 @@ cmdlineConfigParser = do , _lconfig_allowSingleLineExportList = mempty , _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_experimentalSemicolonNewlines = mempty - , _lconfig_allowSinglelineRecord = mempty + -- , _lconfig_allowSinglelineRecord = mempty } , _conf_errorHandling = ErrorHandlingConfig { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs index 526afef..a244eae 100644 --- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Config/Types.hs @@ -142,14 +142,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 + -- -- > } } deriving (Generic) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index e11acfa..fb4205d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -403,7 +403,8 @@ createDetailsDoc consNameStr details = case details of RecCon (L _ []) -> docSeq [docLit consNameStr, docSeparator, docLit $ Text.pack "{}"] RecCon lRec@(L _ fields@(_:_)) -> do let ((fName1, fType1) : fDocR) = mkFieldDocs fields - allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack + -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack + let allowSingleline = False docAddBaseY BrIndentRegular $ docSetIndentLevel $ runFilteredAlternative From 3fbbf3d661a0a54096075042d15d8262ca1dfb48 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 27 Nov 2019 21:19:36 +0100 Subject: [PATCH 22/24] Fix one misplaced comment bug on data decls --- .../Brittany/Internal/Layouters/DataDecl.hs | 22 ++++++++++++------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index fb4205d..dd3576f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -143,11 +143,14 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of createDerivingPar mDerivs $ docAlt [ -- data D = forall a . Show a => D a docSeq - [ appSep $ docLitS "data" - , docForceSingleline $ lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator + [ docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline $ lhsContextDoc + , appSep $ docLit nameStr + , appSep tyVarLine + , docSeparator + ] , docLitS "=" , docSeparator , case forallDocMay of @@ -164,7 +167,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of , -- data D -- = forall a . Show a => D a docAddBaseY BrIndentRegular $ docPar - ( docSeq + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr @@ -191,7 +195,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of -- . Show a => -- D a docAddBaseY BrIndentRegular $ docPar - ( docSeq + ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLitS "data" , docForceSingleline lhsContextDoc , appSep $ docLit nameStr @@ -214,7 +219,8 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of (docLitS "data") ( docLines [ lhsContextDoc - , docSeq + , docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq [ appSep $ docLit nameStr , tyVarLine ] From a1282c3ac670b61e6bbcd50cf7a12612b385b2e5 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 27 Nov 2019 21:51:33 +0100 Subject: [PATCH 23/24] Add a testcase for the last commit --- src-literatetests/10-tests.blt | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 7dc1e45..684a711 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -551,6 +551,16 @@ data Foo = Bar ABC --g ) +#test comment before equal sign +{-# LANGUAGE ExistentialQuantification #-} +data MyRecord + -- test comment + = forall a b + . ( Loooooooooooooooooooooooooooooooong a + , Loooooooooooooooooooooooooooooooong b + ) => + MyConstructor a b + #test normal records on multi line indent policy left -- brittany {lconfig_indentPolicy: IndentPolicyLeft } data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse From 00c6854887f3de22f5e036f652d6f16748a78be4 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Mon, 9 Dec 2019 22:35:26 +0100 Subject: [PATCH 24/24] Fix two minor data-decl layouting issues --- src-literatetests/10-tests.blt | 24 ++++++ .../Haskell/Brittany/Internal/Backend.hs | 22 ++--- .../Brittany/Internal/LayouterBasics.hs | 6 +- .../Brittany/Internal/Layouters/DataDecl.hs | 47 +++++----- .../Brittany/Internal/Transformations/Alt.hs | 37 ++++++-- .../Internal/Transformations/Columns.hs | 2 +- .../Haskell/Brittany/Internal/Types.hs | 85 ++++++++++--------- 7 files changed, 138 insertions(+), 85 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 684a711..a3d1138 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -583,6 +583,30 @@ data EnterpriseGrantsForCompanyResponse = EnterpriseGrantsForCompanyResponse data GrantsForCompanyResp = GrantsForCompanyResp Types.Company [EnterpriseGrantResponse] +#test large record with a comment +data XIILqcacwiuNiu = XIILqcacwiuNiu + { oyyFtvbepgbOge_pebzVmuftEijwuj :: Jgtoyuh HessJvNlo + , wloQsiskdoxJop_xatiKrwedOxtu :: Jgtoyuh [Inotg] + , mmmJjcqtemyIyo_ovosDoreKeeoyamvove :: Jgtoyuh Eujo + , mbiIatelofxOzr_uluxNngiiMjah :: Jgtoyuh HessJvNlo + , obxIskfcxpkIkb_uuviTuevcSkrgo :: Jgtoyuh Int + , wqrAtuvuecoHwr_ilotNxbuPleo :: Jgtoyuh Ufaxdeq + , lofAfuebdhpLuv_cnekPoyFxmg :: Jgtoyuh Ufaxdeq + , ouoFugtawzvUpk_oupiLzptugy :: Jgtoyuh Eujo + , iqiXjtziwogNsa_uiyvSunaTtgUsf3 :: Jgtoyuh Oaivn + , odbIriaqnojUlz_onotoWuunehIpuy :: Jgtoyuh Eujo + , opjUxtkxzkiKse_luqjuZazt + :: Jgtoyuh [(Eujo, Int, Int, Int, Int, Int, NELUxro)] + -- , jcqRaqznxfhIpa_ywevMezmoYkutuwa :: Jgtoyuh () + , vayOmuasyphOfd_bcsVljmvt :: Jgtoyuh Eujo + , rifArahilooRax_ufikecqdImsv :: Jgtoyuh Oaivn + , raqKtopcpszDwb_oqocubasZuqjcryoDojGkw :: Jgtoyuh Oaivn + , mluJiilpcijUtt_gaisklifVekfeyagRmfbyzz :: Jgtoyuh Oaivn + , oqhPaahjupaSmi_gamwwoovKyxznecvEayluc :: Jgtoyuh Oaivn + , mazFubimwebZpa_itidehDodiDlboz :: Jgtoyuh Vrep + , jeyOcuesexaYoy_vpqn :: Jgtoyuh () + } + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 32c5aba..50522ed 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -287,7 +287,7 @@ layoutBriDocM = \case Just (ExactPrint.Types.DP (y, x)) -> layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) layoutBriDocM bd - BDNonBottomSpacing bd -> layoutBriDocM bd + BDNonBottomSpacing _ bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd BDDebug s bd -> do @@ -321,15 +321,15 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc BDAnnotationKW _ _ bd -> rec bd BDAnnotationRest _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd - BDLines ls@(_:_) -> do + BDLines ls@(_ : _) -> do x <- StateS.get return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x - BDLines [] -> error "briDocLineLength BDLines []" - BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd - BDDebug _ bd -> rec bd + BDLines [] -> error "briDocLineLength BDLines []" + BDEnsureIndent _ bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd + BDDebug _ bd -> rec bd briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine briDoc = rec briDoc @@ -363,9 +363,9 @@ briDocIsMultiLine briDoc = rec briDoc BDLines [_ ] -> False BDLines [] -> error "briDocIsMultiLine BDLines []" BDEnsureIndent _ bd -> rec bd - BDSetParSpacing bd -> rec bd - BDForceParSpacing bd -> rec bd - BDNonBottomSpacing bd -> rec bd + BDSetParSpacing bd -> rec bd + BDForceParSpacing bd -> rec bd + BDNonBottomSpacing _ bd -> rec bd BDDebug _ bd -> rec bd -- In theory diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index d46421e..6263f50 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -40,6 +40,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docAnnotationRest , docMoveToKWDP , docNonBottomSpacing + , docNonBottomSpacingS , docSetParSpacing , docForceParSpacing , docDebug @@ -576,7 +577,10 @@ docAnnotationRest docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered -docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing =<< bdm +docNonBottomSpacing bdm = allocateNode . BDFNonBottomSpacing False =<< bdm + +docNonBottomSpacingS :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered +docNonBottomSpacingS bdm = allocateNode . BDFNonBottomSpacing True =<< bdm docSetParSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index dd3576f..00453b3 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -153,16 +153,18 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of ] , docLitS "=" , docSeparator - , case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] ] , -- data D -- = forall a . Show a => D a @@ -178,16 +180,18 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of ( docSeq [ docLitS "=" , docSeparator - , case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc - , docSeparator - , docLitS "." - , docSeparator - ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc + , docSetIndentLevel $ docSeq + [ case forallDocMay of + Nothing -> docEmpty + Just forallDoc -> docSeq + [ docForceSingleline forallDoc + , docSeparator + , docLitS "." + , docSeparator + ] + , maybe docEmpty docForceSingleline rhsContextDocMay + , rhsDoc + ] ] ) , -- data D @@ -412,7 +416,6 @@ createDetailsDoc consNameStr details = case details of -- allowSingleline <- mAsk <&> _conf_layout .> _lconfig_allowSinglelineRecord .> confUnpack let allowSingleline = False docAddBaseY BrIndentRegular - $ docSetIndentLevel $ runFilteredAlternative $ do -- single-line: { i :: Int, b :: Bool } @@ -441,7 +444,7 @@ createDetailsDoc consNameStr details = case details of ] addAlternative $ docPar (docLit consNameStr) - (docWrapNodePrior lRec $ docLines + (docWrapNodePrior lRec $ docNonBottomSpacingS $ docLines [ docAlt [ docCols ColRecDecl [ appSep (docLitS "{") diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs index 22d0555..6a15eac 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs @@ -331,7 +331,7 @@ transformAlts = BrIndentNone -> r BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r - BDFNonBottomSpacing bd -> rec bd + BDFNonBottomSpacing _ bd -> rec bd BDFSetParSpacing bd -> rec bd BDFForceParSpacing bd -> rec bd BDFDebug s bd -> do @@ -488,13 +488,18 @@ getSpacing !bridoc = rec bridoc BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp pf) -> VerticalSpacing (lsp + addInd) psp pf - BDFNonBottomSpacing bd -> do + BDFNonBottomSpacing b bd -> do mVs <- rec bd return $ mVs - <|> LineModeValid (VerticalSpacing 0 - (VerticalSpacingParAlways colMax) - False) + <|> LineModeValid + (VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ) BDFSetParSpacing bd -> do mVs <- rec bd return $ mVs <&> \vs -> vs { _vs_parFlag = True } @@ -799,16 +804,30 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc BrIndentSpecial i -> i return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> VerticalSpacing (lsp + addInd) psp parFlag - BDFNonBottomSpacing bd -> do + BDFNonBottomSpacing b bd -> do + -- TODO: the `b` flag is an ugly hack, but I was not able to make + -- all tests work without it. It should be possible to have + -- `spMakePar` map VSPAlways{} to VSPSome x1, which fixes this + -- problem but breaks certain other cases. mVs <- rec bd return $ if null mVs - then [VerticalSpacing 0 (VerticalSpacingParAlways colMax) False] + then [VerticalSpacing + 0 + (if b then VerticalSpacingParSome 0 + else VerticalSpacingParAlways colMax + ) + False + ] else mVs <&> \vs -> vs { _vs_sameLine = min colMax (_vs_sameLine vs) , _vs_paragraph = case _vs_paragraph vs of VerticalSpacingParNone -> VerticalSpacingParNone - VerticalSpacingParAlways i -> VerticalSpacingParAlways i - VerticalSpacingParSome i -> VerticalSpacingParAlways i + VerticalSpacingParAlways i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i + VerticalSpacingParSome i + | b -> VerticalSpacingParSome 0 + | otherwise -> VerticalSpacingParAlways i } -- the version below is an alternative idea: fold the input -- spacings into a single spacing. This was hoped to improve in diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs index 31ec86a..d652dda 100644 --- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs +++ b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs @@ -135,4 +135,4 @@ transformSimplifyColumns = Uniplate.rewrite $ \case BDSetParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing BDDebug{} -> Nothing - BDNonBottomSpacing x -> Just x + BDNonBottomSpacing _ x -> Just x diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs index e3a5318..c8e37ff 100644 --- a/src/Language/Haskell/Brittany/Internal/Types.hs +++ b/src/Language/Haskell/Brittany/Internal/Types.hs @@ -258,7 +258,7 @@ data BriDoc -- after the alt transformation. | BDForceMultiline BriDoc | BDForceSingleline BriDoc - | BDNonBottomSpacing BriDoc + | BDNonBottomSpacing Bool BriDoc | BDSetParSpacing BriDoc | BDForceParSpacing BriDoc -- pseudo-deprecated @@ -303,7 +303,7 @@ data BriDocF f | BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f)) | BDFForceSingleline (f (BriDocF f)) - | BDFNonBottomSpacing (f (BriDocF f)) + | BDFNonBottomSpacing Bool (f (BriDocF f)) | BDFSetParSpacing (f (BriDocF f)) | BDFForceParSpacing (f (BriDocF f)) | BDFDebug String (f (BriDocF f)) @@ -315,33 +315,37 @@ type BriDocFInt = BriDocF ((,) Int) type BriDocNumbered = (Int, BriDocFInt) instance Uniplate.Uniplate BriDoc where - uniplate x@BDEmpty{} = plate x - uniplate x@BDLit{} = plate x - uniplate (BDSeq list) = plate BDSeq ||* list - uniplate (BDCols sig list) = plate BDCols |- sig ||* list - uniplate x@BDSeparator = plate x - uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd - uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd - uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd - uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd - uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd - uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented - uniplate (BDAlt alts) = plate BDAlt ||* alts - uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd - uniplate x@BDExternal{} = plate x - uniplate x@BDPlain{} = plate x - uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd - uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd - uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd - uniplate (BDMoveToKWDP annKey kw b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd - uniplate (BDLines lines) = plate BDLines ||* lines - uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd - uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd - uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd - uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd - uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd - uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd - uniplate (BDDebug s bd) = plate BDDebug |- s |* bd + uniplate x@BDEmpty{} = plate x + uniplate x@BDLit{} = plate x + uniplate (BDSeq list ) = plate BDSeq ||* list + uniplate (BDCols sig list) = plate BDCols |- sig ||* list + uniplate x@BDSeparator = plate x + uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd + uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd + uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd + uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd + uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd + uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented + uniplate (BDAlt alts ) = plate BDAlt ||* alts + uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd + uniplate x@BDExternal{} = plate x + uniplate x@BDPlain{} = plate x + uniplate (BDAnnotationPrior annKey bd) = + plate BDAnnotationPrior |- annKey |* bd + uniplate (BDAnnotationKW annKey kw bd) = + plate BDAnnotationKW |- annKey |- kw |* bd + uniplate (BDAnnotationRest annKey bd) = + plate BDAnnotationRest |- annKey |* bd + uniplate (BDMoveToKWDP annKey kw b bd) = + plate BDMoveToKWDP |- annKey |- kw |- b |* bd + uniplate (BDLines lines ) = plate BDLines ||* lines + uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd + uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd + uniplate (BDForceSingleline bd ) = plate BDForceSingleline |* bd + uniplate (BDNonBottomSpacing b bd) = plate BDNonBottomSpacing |- b |* bd + uniplate (BDSetParSpacing bd ) = plate BDSetParSpacing |* bd + uniplate (BDForceParSpacing bd ) = plate BDForceParSpacing |* bd + uniplate (BDDebug s bd ) = plate BDDebug |- s |* bd newtype NodeAllocIndex = NodeAllocIndex Int @@ -369,14 +373,13 @@ unwrapBriDocNumbered tpl = case snd tpl of BDFMoveToKWDP annKey kw b bd -> BDMoveToKWDP annKey kw b $ rec bd BDFLines lines -> BDLines $ rec <$> lines BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd - BDFForceMultiline bd -> BDForceMultiline $ rec bd - BDFForceSingleline bd -> BDForceSingleline $ rec bd - BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd - BDFSetParSpacing bd -> BDSetParSpacing $ rec bd - BDFForceParSpacing bd -> BDForceParSpacing $ rec bd + BDFForceMultiline bd -> BDForceMultiline $ rec bd + BDFForceSingleline bd -> BDForceSingleline $ rec bd + BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd + BDFSetParSpacing bd -> BDSetParSpacing $ rec bd + BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd - where - rec = unwrapBriDocNumbered + where rec = unwrapBriDocNumbered isNotEmpty :: BriDoc -> Bool isNotEmpty BDEmpty = False @@ -406,11 +409,11 @@ briDocSeqSpine = \case BDMoveToKWDP _annKey _kw _b bd -> briDocSeqSpine bd BDLines lines -> foldl' (\(!()) -> briDocSeqSpine) () lines BDEnsureIndent _ind bd -> briDocSeqSpine bd - BDForceMultiline bd -> briDocSeqSpine bd - BDForceSingleline bd -> briDocSeqSpine bd - BDNonBottomSpacing bd -> briDocSeqSpine bd - BDSetParSpacing bd -> briDocSeqSpine bd - BDForceParSpacing bd -> briDocSeqSpine bd + BDForceMultiline bd -> briDocSeqSpine bd + BDForceSingleline bd -> briDocSeqSpine bd + BDNonBottomSpacing _ bd -> briDocSeqSpine bd + BDSetParSpacing bd -> briDocSeqSpine bd + BDForceParSpacing bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd briDocForceSpine :: BriDoc -> BriDoc