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

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
                     }
```
eborden/eborden/sum-data
Evan Rutledge Borden 2020-04-10 10:59:00 -05:00
parent 86c25ff315
commit 7c1b731f1e
2 changed files with 129 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
src-literatetests/10-tests.blt
View File

@ -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
}
###############################################################################
###############################################################################
###############################################################################

221
src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
View File

@ -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] =