From 172866755cc43b49ad82521b6b2917bf08016173 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <lsp@informatik.uni-kiel.de>
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
+
--
2.30.2
From 4f827491daa5dd1ea51a49fbd13ba021d7ad22e2 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <lsp@informatik.uni-kiel.de>
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
+ ]
--
2.30.2
From 57ba88a73c389766bf63983b71f159c7a8ee43a2 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <evan@evan-borden.com>
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"
--
2.30.2
From 208a1ceadb0b2b34f3c807b30232db683dd6969a Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2
From d21ecf89e6c31f34f58f7da514e56d6b8167ef8d Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2
From 2f6967b7b8fcb47d5e9ea09efaf7c93860da87dc Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2
From 868b8c61e3a79bddb9ab054073e81cd07591bb85 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
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
--
2.30.2
From dee63517ba7a4468d7c41b99bc5c318d6bd63b84 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
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
--
2.30.2
From 9971e3905d1c7bb1f54bf117650403fcc9100f73 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
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
--
2.30.2
From aeaa043e99d4e4469dac782643695c73c3e99d38 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
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
--
2.30.2
From b2f4262749dbc601f2e66901d2575003271ac683 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
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)
--
2.30.2
From ea9d3bb5b3fad544e59d5d08f5d6d872383c2c55 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
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
--
2.30.2
From 48490a71100eb2b90b83a12c75e30ecd9a9cd2f4 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2
From 54f34344b3ef523a2909176b4aa499fa774e2b74 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
+ }
}
--
2.30.2
From a23ef696e8c63ab7a3f55100faf3504e66e9b6c2 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2
From 9494d6203a16138252c8147c315a03bef540d65d Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
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
--
2.30.2
From c367b1017b390de5b37de25fe8a3cc98b6f13ac8 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2
From 0381b9fe24172bb17b890a276f866d34fb17bb44 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2
From 80f370a8e10690e65718f66dd72de12d6d771f05 Mon Sep 17 00:00:00 2001
From: Evan Rutledge Borden <eborden@frontrowed.com>
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
--
2.30.2
From 5a49277eba71e124fb822706427c157af0f68dff Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
+ )
--
2.30.2
From 6c3d9c57c5fc730673b932b11287412d1cf9fef7 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2
From 3fbbf3d661a0a54096075042d15d8262ca1dfb48 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
]
--
2.30.2
From a1282c3ac670b61e6bbcd50cf7a12612b385b2e5 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2
From 00c6854887f3de22f5e036f652d6f16748a78be4 Mon Sep 17 00:00:00 2001
From: Lennart Spitzner <hexagoxel@hexagoxel.de>
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
--
2.30.2