From 57ba88a73c389766bf63983b71f159c7a8ee43a2 Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Sat, 30 Dec 2017 21:28:01 -0500 Subject: [PATCH] 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"