From 7c1b731f1e7ad1c3f505b87488ed2f7cb727d1eb Mon Sep 17 00:00:00 2001 From: Evan Rutledge Borden Date: Fri, 10 Apr 2020 10:59:00 -0500 Subject: [PATCH] First pass at sum types This is a naive first pass at sum type support. This currently breaks 11 tests, some from comment misplacement, others in more exotic forms that previously required high levels of context to be correctly laid out. The solution for comment misplacement is probably trivial, but the highly contextualized forms may need a bit more alchemy. ``` 1) data type declarations record no matching single line layout expected: Right {-# LANGUAGE ScopedTypeVariables #-} -- brittany { lconfig_allowSinglelineRecord: true } data MyRecord = forall a . Show a => Bar { foo :: abittoolongbutnotvery -> abittoolongbutnotvery } but got: Right {-# LANGUAGE ScopedTypeVariables #-} -- brittany { lconfig_allowSinglelineRecord: true } data MyRecord = forall a . Show a => Bar { foo :: abittoolongbutnotvery -> abittoolongbutnotvery } 2) data type declarations record forall constraint multiline expected: Right {-# LANGUAGE ScopedTypeVariables #-} data MyRecord = forall a . LooooooooooooooooooooongConstraint a => LoooooooooooongConstructor { foo :: abittoolongbutnotvery -> abittoolongbutnotvery } but got: Right {-# LANGUAGE ScopedTypeVariables #-} data MyRecord = forall a . LooooooooooooooooooooongConstraint a => LoooooooooooongConstructor { foo :: abittoolongbutnotvery -> abittoolongbutnotvery } 3) data type declarations record forall constraint multiline more expected: Right {-# LANGUAGE ScopedTypeVariables #-} data MyRecord = forall a b . ( Loooooooooooooooooooooooooooooooong a , Loooooooooooooooooooooooooooooooong b ) => MyConstructor { a :: a , b :: b } but got: Right {-# LANGUAGE ScopedTypeVariables #-} data MyRecord = forall a b . ( Loooooooooooooooooooooooooooooooong a , Loooooooooooooooooooooooooooooooong b ) => MyConstructor { a :: a , b :: b } 4) data type declarations plain with forall and constraint expected: Right {-# LANGUAGE ScopedTypeVariables #-} data MyStruct = forall a b . ( Loooooooooooooooooooooooooooooooong a , Loooooooooooooooooooooooooooooooong b ) => MyConstructor (ToBriDocM BriDocNumbered) (ToBriDocM BriDocNumbered) (ToBriDocM BriDocNumbered) but got: Right {-# LANGUAGE ScopedTypeVariables #-} data MyStruct = forall a b . ( Loooooooooooooooooooooooooooooooong a , Loooooooooooooooooooooooooooooooong b ) => MyConstructor (ToBriDocM BriDocNumbered) (ToBriDocM BriDocNumbered) (ToBriDocM BriDocNumbered) 5) data type declarations record with many features expected: Right {-# LANGUAGE ScopedTypeVariables #-} data MyRecord = forall a b . ( Loooooooooooooooooooooooooooooooong a , Loooooooooooooooooooooooooooooooong b ) => MyConstructor { foo, foo2 :: loooooooooooooooooooooooooooooooong -> loooooooooooooooooooooooooooooooong , bar :: a , bazz :: b } deriving Show but got: Right {-# LANGUAGE ScopedTypeVariables #-} data MyRecord = forall a b . ( Loooooooooooooooooooooooooooooooong a , Loooooooooooooooooooooooooooooooong b ) => MyConstructor { foo, foo2 :: loooooooooooooooooooooooooooooooong -> loooooooooooooooooooooooooooooooong , bar :: a , bazz :: b } deriving Show 6) data type declarations single record existential expected: Right {-# LANGUAGE ExistentialQuantification #-} data Foo = forall a . Show a => Bar { foo :: a } but got: Right {-# LANGUAGE ExistentialQuantification #-} data Foo = forall a . Show a => Bar { foo :: a } 7) data type declarations record multiple types existential expected: Right {-# LANGUAGE ExistentialQuantification #-} data Foo = forall a b . (Show a, Eq b) => Bar { foo :: a , bars :: b } but got: Right {-# LANGUAGE ExistentialQuantification #-} data Foo = forall a b . (Show a, Eq b) => Bar { foo :: a , bars :: b } 8) data type declarations record newline comment expected: Right data MyRecord = MyRecord { a :: Int -- comment , b :: Int } but got: Right data MyRecord = MyRecord { a :: Int -- comment , b :: Int } 9) data type declarations comment before equal sign expected: Right {-# LANGUAGE ExistentialQuantification #-} data MyRecord -- test comment = forall a b . ( Loooooooooooooooooooooooooooooooong a , Loooooooooooooooooooooooooooooooong b ) => MyConstructor a b but got: Right {-# LANGUAGE ExistentialQuantification #-} data MyRecord -- test comment = forall a b . ( Loooooooooooooooooooooooooooooooong a , Loooooooooooooooooooooooooooooooong b ) => MyConstructor a b 10) data type declarations large record with a comment expected: Right 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 () } but got: Right 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 () } 11) data type declarations records in sum expected: Right -- brittany {lconfig_indentPolicy: IndentPolicyLeft } data Foo = Bar { foo :: Int -- hello , bar :: Foo -- how are you } | Baz | Biz { foo :: Int , bar :: Foo } but got: Right -- brittany {lconfig_indentPolicy: IndentPolicyLeft } data Foo = Bar { foo :: Int -- hello , bar :: Foo -- how are you } | Baz | Biz { foo :: Int , bar :: Foo } ``` --- src-literatetests/10-tests.blt | 21 ++ .../Brittany/Internal/Layouters/DataDecl.hs | 221 +++++++++--------- 2 files changed, 129 insertions(+), 113 deletions(-) diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 88f3598..4591f41 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -607,6 +607,27 @@ data XIILqcacwiuNiu = XIILqcacwiuNiu , jeyOcuesexaYoy_vpqn :: Jgtoyuh () } +#test normal data types in sum +-- brittany {lconfig_indentPolicy: IndentPolicyLeft } +data Foo + = Bar + | Baz + | Biz + +#test records in sum +-- brittany {lconfig_indentPolicy: IndentPolicyLeft } +data Foo + = Bar + { foo :: Int -- hello + , bar :: Foo + -- how are you + } + | Baz + | Biz + { foo :: Int + , bar :: Foo + } + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs index 00453b3..c50a4e1 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs @@ -23,6 +23,7 @@ import HsSyn import Name import BasicTypes import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) +import Data.Traversable (for) import Language.Haskell.Brittany.Internal.Layouters.Type import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr @@ -97,21 +98,21 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of -- 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 -> + HsDataDefn _ext DataType (L _ lhsContext) _ctype Nothing conss mDerivs -> #else - HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs -> + HsDataDefn DataType (L _ lhsContext) _ctype Nothing conss mDerivs -> #endif - case cons of + docWrapNode ltycl $ do + lhsContextDoc <- docSharedWrapper createContextDoc lhsContext + nameStr <- lrdrNameToTextAnn name + tyVarLine <- fmap return $ createBndrDoc bndrs + consDocs <- for (filter (not . isGadt) conss) $ \case #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ - (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> + (L _ (ConDeclH98 _ext consName (L _ _hasExt) qvars mRhsContext details _conDoc)) -> do #else - (L _ (ConDeclH98 consName (Just (HsQTvs _ qvars _)) mRhsContext details _conDoc)) -> + (L _ (ConDeclH98 consName (Just (HsQTvs _ qvars _)) mRhsContext details _conDoc)) -> do #endif - docWrapNode ltycl $ do - lhsContextDoc <- docSharedWrapper createContextDoc lhsContext - nameStr <- lrdrNameToTextAnn name consNameStr <- lrdrNameToTextAnn consName - tyVarLine <- fmap return $ createBndrDoc bndrs forallDocMay <- case createForallDoc qvars of Nothing -> pure Nothing Just x -> Just . pure <$> x @@ -119,123 +120,117 @@ layoutDataDecl ltycl name (HsQTvs _ bndrs _) defn = case defn of Nothing -> pure Nothing Just (L _ ctxt) -> Just . pure <$> createContextDoc ctxt rhsDoc <- fmap return $ createDetailsDoc consNameStr details - consDoc <- fmap pure + 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, Just rhsContextDoc) -> docAlt + [ docLines + [ docSeq [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 - [ docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline $ lhsContextDoc - , appSep $ docLit nameStr - , appSep tyVarLine - , docSeparator - ] - , docLitS "=" - , docSeparator - , docSetIndentLevel $ docSeq - [ case forallDocMay of - Nothing -> docEmpty - Just forallDoc -> docSeq - [ docForceSingleline forallDoc + , docSeq + [ forallDoc , docSeparator , docLitS "." , docSeparator + , rhsContextDoc + , rhsDoc ] - , maybe docEmpty docForceSingleline rhsContextDocMay - , rhsDoc + ] + (Just forallDoc, Nothing) -> docLines + [ docSeq [docForceSingleline forallDoc] + , docSeq [docLitS ".", docSeparator, rhsDoc] + ] + (Nothing, Just rhsContextDoc) -> docSeq + [ docSetBaseY $ docLines [rhsContextDoc, docSetBaseY rhsDoc] + ] + (Nothing, Nothing) -> docSeq [rhsDoc] + createDerivingPar mDerivs $ docAlt + [ -- data D = forall a . Show a => D a + docAddBaseY BrIndentRegular + $ docSeq + [ docNodeAnnKW ltycl (Just GHC.AnnData) $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine ] + , parConstructors consDocs ] - , -- data D - -- = forall a . Show a => D a - docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLitS "data" - , docForceSingleline lhsContextDoc - , appSep $ docLit nameStr - , tyVarLine - ] - ) - ( docSeq - [ docLitS "=" - , docSeparator - , 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 - docAddBaseY BrIndentRegular $ docPar - ( docNodeAnnKW ltycl (Just GHC.AnnData) - $ 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 - , docNodeAnnKW ltycl (Just GHC.AnnData) - $ docSeq - [ appSep $ docLit nameStr - , tyVarLine - ] - , consDoc - ] - ) + , -- data D + -- = forall a + -- . Show a => + -- D a + docAddBaseY BrIndentRegular + $ docPar ( docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLitS "data" + , docForceSingleline lhsContextDoc + , appSep $ docLit nameStr + , tyVarLine + ] + ) + (parConstructors consDocs) + , -- 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 + , docNodeAnnKW ltycl (Just GHC.AnnData) + $ docSeq + [ appSep $ docLit nameStr + , tyVarLine + ] + , parConstructors consDocs ] - _ -> briDocByExactNoComment ltycl + ) + ] _ -> briDocByExactNoComment ltycl +isGadt :: Located (ConDecl pass) -> Bool +isGadt (L _ ConDeclGADT{}) = True +isGadt (L _ ConDeclH98{}) = False +isGadt (L _ XConDecl{}) = False + +parConstructors :: [ToBriDocM BriDocNumbered] -> ToBriDocM BriDocNumbered +parConstructors [] = docEmpty +parConstructors [cons] = docAlt + [ docSeq + [ docSeparator + , docLit (Text.pack "=") + , docSeparator + , cons + ] + , docPar docEmpty + $ docSeq + [ docLit (Text.pack "=") + , docSeparator + , cons + ] + ] +parConstructors (cons:additional) = + docPar docEmpty + $ docLines + $ docSeq [docLit (Text.pack "=") , docSeparator , cons] + : toSum additional + where + toSum = map (\x -> docSeq [docLit (Text.pack "|"), docSeparator, x]) + createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered createContextDoc [] = docEmpty createContextDoc [t] = -- 2.30.2