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

Data declaration for newtype and records #259

Merged
eborden merged 24 commits from datadecl into master 2019-12-09 22:46:04 +01:00
Conversation 39 Commits 24 Files Changed 25
25 changed files with 1367 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -13,3 +13,4 @@ cabal.sandbox.config
cabal.project.local cabal.project.local
.ghc.environment.* .ghc.environment.*
result result
.stack-work*

28
Makefile Normal file
View File

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

1
brittany.cabal
View File

@ -77,6 +77,7 @@ library {
Language.Haskell.Brittany.Internal.Layouters.IE Language.Haskell.Brittany.Internal.Layouters.IE
Language.Haskell.Brittany.Internal.Layouters.Import Language.Haskell.Brittany.Internal.Layouters.Import
Language.Haskell.Brittany.Internal.Layouters.Module Language.Haskell.Brittany.Internal.Layouters.Module
Language.Haskell.Brittany.Internal.Layouters.DataDecl
Language.Haskell.Brittany.Internal.Transformations.Alt Language.Haskell.Brittany.Internal.Transformations.Alt
Language.Haskell.Brittany.Internal.Transformations.Floating Language.Haskell.Brittany.Internal.Transformations.Floating
Language.Haskell.Brittany.Internal.Transformations.Par Language.Haskell.Brittany.Internal.Transformations.Par

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

@ -310,6 +310,303 @@ func = f
f = id f = id
###############################################################################
###############################################################################
###############################################################################
#group data type declarations
###############################################################################
###############################################################################
###############################################################################
#test nullary data type
data Foo = Bar {}
data Biz = Baz
#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 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
#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 }
#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
, bars :: Bizzz
}
deriving (Show, Eq, Monad, Functor, Traversable, Foldable)
#test record multiple deriving strategies
#min-ghc 8.2
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)
#test record deriving via
#min-ghc 8.6
data Foo = Bar
{ foo :: Baz
, bars :: Bizzz
}
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
}
#test plain comment simple
-- before
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
, 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
#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
)
#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
Types.Company
[EnterpriseGrantResponse]
#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]
#test normal records on multi line indent policy multiple
-- brittany {lconfig_indentPolicy: IndentPolicyMultiple }
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 ()
}
############################################################################### ###############################################################################
############################################################################### ###############################################################################
############################################################################### ###############################################################################
@ -1093,6 +1390,14 @@ type (a :+: b) = (a, b)
type ((a :+: b) c) = (a, c) type ((a :+: b) c) = (a, c)
#test synonym-tuple-type-many-comments
type Foo
= ( -- t1
A -- t2
, -- t3
B -- t4
) -- t5
############################################################################### ###############################################################################
############################################################################### ###############################################################################

51
src-literatetests/30-tests-context-free.blt
View File

@ -312,6 +312,51 @@ func = f
f = id 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)
############################################################################### ###############################################################################
############################################################################### ###############################################################################
############################################################################### ###############################################################################
@ -1163,6 +1208,12 @@ foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do
liftIO . forkIO . forever $ getLine >>= inputFire liftIO . forkIO . forever $ getLine >>= inputFire
ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent
#test issue 15
-- Test.hs
module Test where
data X = X
#test issue 16 #test issue 16
foldrDesc f z = unSwitchQueue $ \q -> foldrDesc f z = unSwitchQueue $ \q ->
switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q) switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q)

132
src-literatetests/Main.hs
View File

@ -1,13 +1,20 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
module Main (main) where module Main
( main
)
where
#include "prelude.inc" #include "prelude.inc"
import Test.Hspec import Test.Hspec
import Test.Hspec.Runner ( hspecWith, defaultConfig, configConcurrentJobs ) import Test.Hspec.Runner ( hspecWith
, defaultConfig
, configConcurrentJobs
)
import NeatInterpolation import NeatInterpolation
@ -32,11 +39,18 @@ import System.FilePath ( (</>) )
data InputLine data InputLine
= GroupLine Text = GroupLine Text
| HeaderLine Text | HeaderLine Text
| GhcVersionGuardLine Text
| PendingLine | PendingLine
| NormalLine Text | NormalLine Text
| CommentLine | CommentLine
deriving Show deriving Show
data TestCase = TestCase
{ testName :: Text
, isPending :: Bool
, minGHCVersion :: Maybe Text
, content :: Text
}
main :: IO () main :: IO ()
main = do main = do
@ -44,28 +58,39 @@ main = do
let blts = let blts =
List.sort List.sort
$ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x)) $ 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) inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" </> blt)
let groups = createChunks =<< inputs let groups = createChunks =<< inputs
inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt" inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt"
let groupsCtxFree = createChunks inputCtxFree 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 hspec $ do
groups `forM_` \(groupname, tests) -> do groups `forM_` \(groupname, tests) -> do
describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do describe (Text.unpack groupname) $ do
(if pend then before_ pending else id) tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do
$ it (Text.unpack name) (if isPending test then before_ pending else id)
$ roundTripEqual defaultTestConfig inp $ it (Text.unpack $ testName test)
$ roundTripEqual defaultTestConfig
$ content test
groupsCtxFree `forM_` \(groupname, tests) -> do groupsCtxFree `forM_` \(groupname, tests) -> do
describe ("context free: " ++ Text.unpack groupname) describe ("context free: " ++ Text.unpack groupname) $ do
$ tests tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do
`forM_` \(name, pend, inp) -> do (if isPending test then before_ pending else id)
(if pend then before_ pending else id) $ it (Text.unpack $ testName test)
$ it (Text.unpack name) $ roundTripEqual contextFreeTestConfig
$ roundTripEqual contextFreeTestConfig inp $ content test
where where
-- this function might be implemented in a weirdly complex fashion; the -- this function might be implemented in a weirdly complex fashion; the
-- reason being that it was copied from a somewhat more complex variant. -- reason being that it was copied from a somewhat more complex variant.
createChunks :: Text -> [(Text, [(Text, Bool, Text)])] createChunks :: Text -> [(Text, [TestCase])]
createChunks input = createChunks input =
-- fmap (\case -- fmap (\case
-- HeaderLine n:PendingLine:rest | Just rlines <- mapM extractNormal rest -> (n, True, Text.unlines rlines) -- 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 -- l -> error $ "first non-empty line must start with #test footest\n" ++ show l
-- ) -- )
-- $ fmap (groupBy grouperT) -- $ fmap (groupBy grouperT)
fmap fmap groupProcessor
( \case $ groupBy grouperG
GroupLine g:grouprest -> $ filter (not . lineIsSpace)
$ fmap lineMapper
$ Text.lines input
where
groupProcessor :: [InputLine] -> (Text, [TestCase])
groupProcessor = \case
GroupLine g : grouprest ->
(,) g (,) g
$ fmap $ fmap testProcessor
( \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 $ groupBy grouperT
$ filter (not . lineIsSpace) $ filter (not . lineIsSpace)
$ grouprest $ grouprest
l -> error $ "first non-empty line must be a #group\n" ++ show l l -> error $ "first non-empty line must be a #group\n" ++ show l
) testProcessor :: [InputLine] -> TestCase
$ groupBy grouperG testProcessor = \case
$ filter (not . lineIsSpace) HeaderLine n : rest ->
$ lineMapper let normalLines = Data.Maybe.mapMaybe extractNormal rest
<$> Text.lines input in TestCase
where { 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 (NormalLine l) = Just l
extractNormal _ = Nothing extractNormal _ = Nothing
extractMinGhc (GhcVersionGuardLine v) = Just v
extractMinGhc _ = Nothing
isPendingLine PendingLine{} = True
isPendingLine _ = False
specialLineParser :: Parser InputLine specialLineParser :: Parser InputLine
specialLineParser = Parsec.choice specialLineParser = Parsec.choice
[ [ GroupLine $ Text.pack name [ [ GroupLine $ Text.pack name
@ -116,6 +145,11 @@ main = do
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:" , name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
, _ <- Parsec.eof , _ <- 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 , [ PendingLine
| _ <- Parsec.try $ Parsec.string "#pending" | _ <- Parsec.try $ Parsec.string "#pending"
, _ <- Parsec.optional $ many (Parsec.noneOf "\r\n") , _ <- Parsec.optional $ many (Parsec.noneOf "\r\n")
@ -123,8 +157,8 @@ main = do
] ]
, [ CommentLine , [ CommentLine
| _ <- Parsec.many $ Parsec.oneOf " \t" | _ <- Parsec.many $ Parsec.oneOf " \t"
, _ <- , _ <- Parsec.optional $ Parsec.string "##" <* many
Parsec.optional $ Parsec.string "##" <* many (Parsec.noneOf "\r\n") (Parsec.noneOf "\r\n")
, _ <- Parsec.eof , _ <- Parsec.eof
] ]
] ]
@ -148,8 +182,7 @@ main = do
-------------------- --------------------
roundTripEqual :: Config -> Text -> Expectation roundTripEqual :: Config -> Text -> Expectation
roundTripEqual c t = roundTripEqual c t =
fmap (fmap PPTextWrapper) fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t)
(parsePrintModuleTests c "TestFakeFileName.hs" t)
`shouldReturn` Right (PPTextWrapper t) `shouldReturn` Right (PPTextWrapper t)
newtype PPTextWrapper = PPTextWrapper Text newtype PPTextWrapper = PPTextWrapper Text
@ -158,7 +191,8 @@ newtype PPTextWrapper = PPTextWrapper Text
instance Show PPTextWrapper where instance Show PPTextWrapper where
show (PPTextWrapper t) = "\n" ++ Text.unpack t show (PPTextWrapper t) = "\n" ++ Text.unpack t
-- brittany-next-binding --columns 160
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
defaultTestConfig :: Config defaultTestConfig :: Config
defaultTestConfig = Config defaultTestConfig = Config
{ _conf_version = _conf_version staticDefaultConfig { _conf_version = _conf_version staticDefaultConfig
@ -180,22 +214,20 @@ defaultTestConfig = Config
, _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowSingleLineExportList = coerce True
, _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False , _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = coerce False
} }
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True }
{ _econf_omit_output_valid_check = coerce True
}
, _conf_preprocessor = _conf_preprocessor staticDefaultConfig , _conf_preprocessor = _conf_preprocessor staticDefaultConfig
, _conf_forward = ForwardOptions {_options_ghc = Identity []} , _conf_forward = ForwardOptions { _options_ghc = Identity [] }
, _conf_roundtrip_exactprint_only = coerce False , _conf_roundtrip_exactprint_only = coerce False
, _conf_obfuscate = coerce False , _conf_obfuscate = coerce False
} }
contextFreeTestConfig :: Config contextFreeTestConfig :: Config
contextFreeTestConfig = contextFreeTestConfig = defaultTestConfig
defaultTestConfig
{ _conf_layout = (_conf_layout defaultTestConfig) { _conf_layout = (_conf_layout defaultTestConfig)
{_lconfig_indentPolicy = coerce IndentPolicyLeft { _lconfig_indentPolicy = coerce IndentPolicyLeft
,_lconfig_alignmentLimit = coerce (1 :: Int) , _lconfig_alignmentLimit = coerce (1 :: Int)
,_lconfig_columnAlignMode = coerce ColumnAlignModeDisabled , _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled
} }
} }

1
src-unittests/TestUtils.hs
View File

@ -61,6 +61,7 @@ defaultTestConfig = Config
, _lconfig_allowSingleLineExportList = coerce True , _lconfig_allowSingleLineExportList = coerce True
, _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False , _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = coerce False
} }
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) , _conf_errorHandling = (_conf_errorHandling staticDefaultConfig)
{ _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever

5
src/Language/Haskell/Brittany/Internal.hs
View File

@ -54,10 +54,12 @@ import Language.Haskell.Brittany.Internal.Transformations.Indent
import qualified GHC as GHC import qualified GHC as GHC
hiding ( parseModule ) hiding ( parseModule )
import ApiAnnotation ( AnnKeywordId(..) ) import ApiAnnotation ( AnnKeywordId(..) )
import GHC ( runGhc import GHC ( Located
, runGhc
, GenLocated(L) , GenLocated(L)
, moduleNameString , moduleNameString
) )
import RdrName ( RdrName(..) )
import SrcLoc ( SrcSpan ) import SrcLoc ( SrcSpan )
import HsSyn import HsSyn
import qualified DynFlags as GHC import qualified DynFlags as GHC
@ -485,7 +487,6 @@ ppModule lmod@(L _loc _m@(HsModule _name _exports _ decls _ _)) = do
in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX) in ppmMoveToExactLoc $ ExactPrint.DP (eofZ - cmY, eofX - cmX)
_ -> return () _ -> return ()
getDeclBindingNames :: LHsDecl GhcPs -> [String] getDeclBindingNames :: LHsDecl GhcPs -> [String]
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */ #if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
getDeclBindingNames (L _ decl) = case decl of getDeclBindingNames (L _ decl) = case decl of

10
src/Language/Haskell/Brittany/Internal/Backend.hs
View File

@ -287,7 +287,7 @@ layoutBriDocM = \case
Just (ExactPrint.Types.DP (y, x)) -> Just (ExactPrint.Types.DP (y, x)) ->
layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0) layoutMoveToCommentPos y (if shouldRestoreIndent then x else 0)
layoutBriDocM bd layoutBriDocM bd
BDNonBottomSpacing bd -> layoutBriDocM bd BDNonBottomSpacing _ bd -> layoutBriDocM bd
BDSetParSpacing bd -> layoutBriDocM bd BDSetParSpacing bd -> layoutBriDocM bd
BDForceParSpacing bd -> layoutBriDocM bd BDForceParSpacing bd -> layoutBriDocM bd
BDDebug s bd -> do BDDebug s bd -> do
@ -321,14 +321,14 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
BDAnnotationKW _ _ bd -> rec bd BDAnnotationKW _ _ bd -> rec bd
BDAnnotationRest _ bd -> rec bd BDAnnotationRest _ bd -> rec bd
BDMoveToKWDP _ _ _ bd -> rec bd BDMoveToKWDP _ _ _ bd -> rec bd
BDLines ls@(_:_) -> do BDLines ls@(_ : _) -> do
x <- StateS.get x <- StateS.get
return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x return $ maximum $ ls <&> \l -> StateS.evalState (rec l) x
BDLines [] -> error "briDocLineLength BDLines []" BDLines [] -> error "briDocLineLength BDLines []"
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd
BDNonBottomSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd BDDebug _ bd -> rec bd
briDocIsMultiLine :: BriDoc -> Bool briDocIsMultiLine :: BriDoc -> Bool
@ -365,7 +365,7 @@ briDocIsMultiLine briDoc = rec briDoc
BDEnsureIndent _ bd -> rec bd BDEnsureIndent _ bd -> rec bd
BDSetParSpacing bd -> rec bd BDSetParSpacing bd -> rec bd
BDForceParSpacing bd -> rec bd BDForceParSpacing bd -> rec bd
BDNonBottomSpacing bd -> rec bd BDNonBottomSpacing _ bd -> rec bd
BDDebug _ bd -> rec bd BDDebug _ bd -> rec bd
-- In theory -- In theory
@ -551,6 +551,8 @@ alignColsLines bridocs = do -- colInfos `forM_` \colInfo -> do
(BDCols ColBindStmt _) -> True (BDCols ColBindStmt _) -> True
(BDCols ColDoLet _) -> True (BDCols ColDoLet _) -> True
(BDCols ColRec _) -> False (BDCols ColRec _) -> False
(BDCols ColRecUpdate _) -> False
(BDCols ColRecDecl _) -> False
(BDCols ColListComp _) -> False (BDCols ColListComp _) -> False
(BDCols ColList _) -> False (BDCols ColList _) -> False
(BDCols ColApp{} _) -> True (BDCols ColApp{} _) -> True

8
src/Language/Haskell/Brittany/Internal/BackendUtils.hs
View File

@ -245,9 +245,10 @@ layoutWriteEnsureAbsoluteN
-> m () -> m ()
layoutWriteEnsureAbsoluteN n = do layoutWriteEnsureAbsoluteN n = do
state <- mGet state <- mGet
let diff = case _lstate_curYOrAddNewline state of let diff = case (_lstate_commentCol state, _lstate_curYOrAddNewline state) of
Left i -> n - i (Just c , _ ) -> n - c
Right{} -> n (Nothing, Left i ) -> n - i
(Nothing, Right{}) -> n
traceLocal ("layoutWriteEnsureAbsoluteN", n, diff) traceLocal ("layoutWriteEnsureAbsoluteN", n, diff)
when (diff > 0) $ do when (diff > 0) $ do
mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to mSet $ state { _lstate_addSepSpace = Just diff -- this always sets to
@ -557,6 +558,7 @@ layoutWritePostComments ast = do
) -> do ) -> do
replicateM_ x layoutWriteNewline replicateM_ x layoutWriteNewline
layoutWriteAppend $ Text.pack $ replicate y ' ' layoutWriteAppend $ Text.pack $ replicate y ' '
mModify $ \s -> s { _lstate_addSepSpace = Nothing }
layoutWriteAppendMultiline $ Text.pack $ comment layoutWriteAppendMultiline $ Text.pack $ comment
layoutIndentRestorePostComment layoutIndentRestorePostComment

2
src/Language/Haskell/Brittany/Internal/Config.hs
View File

@ -77,6 +77,7 @@ staticDefaultConfig = Config
, _lconfig_allowSingleLineExportList = coerce False , _lconfig_allowSingleLineExportList = coerce False
, _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False , _lconfig_experimentalSemicolonNewlines = coerce False
-- , _lconfig_allowSinglelineRecord = coerce False
} }
, _conf_errorHandling = ErrorHandlingConfig , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = coerce False { _econf_produceOutputOnErrors = coerce False
@ -181,6 +182,7 @@ cmdlineConfigParser = do
, _lconfig_allowSingleLineExportList = mempty , _lconfig_allowSingleLineExportList = mempty
, _lconfig_allowHangingQuasiQuotes = mempty , _lconfig_allowHangingQuasiQuotes = mempty
, _lconfig_experimentalSemicolonNewlines = mempty , _lconfig_experimentalSemicolonNewlines = mempty
-- , _lconfig_allowSinglelineRecord = mempty
} }
, _conf_errorHandling = ErrorHandlingConfig , _conf_errorHandling = ErrorHandlingConfig
{ _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors { _econf_produceOutputOnErrors = wrapLast $ falseToNothing outputOnErrors

8
src/Language/Haskell/Brittany/Internal/Config/Types.hs
View File

@ -142,6 +142,14 @@ data CLayoutConfig f = LayoutConfig
-- The implementation for this is a bit hacky and not tested; it might -- 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 -- break output syntax or not work properly for every kind of brace. So
-- far I have considered `do` and `case-of`. -- 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) deriving (Generic)

45
src/Language/Haskell/Brittany/Internal/LayouterBasics.hs
View File

@ -13,6 +13,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
, filterAnns , filterAnns
, docEmpty , docEmpty
, docLit , docLit
, docLitS
, docAlt , docAlt
, CollectAltM , CollectAltM
, addAlternativeCond , addAlternativeCond
@ -39,6 +40,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
, docAnnotationRest , docAnnotationRest
, docMoveToKWDP , docMoveToKWDP
, docNonBottomSpacing , docNonBottomSpacing
, docNonBottomSpacingS
, docSetParSpacing , docSetParSpacing
, docForceParSpacing , docForceParSpacing
, docDebug , docDebug
@ -481,6 +483,9 @@ docEmpty = allocateNode BDFEmpty
docLit :: Text -> ToBriDocM BriDocNumbered docLit :: Text -> ToBriDocM BriDocNumbered
docLit t = allocateNode $ BDFLit t docLit t = allocateNode $ BDFLit t
docLitS :: String -> ToBriDocM BriDocNumbered
docLitS s = allocateNode $ BDFLit $ Text.pack s
docExt docExt
:: (ExactPrint.Annotate.Annotate ast) :: (ExactPrint.Annotate.Annotate ast)
=> Located ast => Located ast
@ -572,7 +577,10 @@ docAnnotationRest
docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm docAnnotationRest annKey bdm = allocateNode . BDFAnnotationRest annKey =<< bdm
docNonBottomSpacing :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered 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 :: ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered
docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm docSetParSpacing bdm = allocateNode . BDFSetParSpacing =<< bdm
@ -642,18 +650,18 @@ docNodeMoveToKWDP ast kw shouldRestoreIndent bdm =
class DocWrapable a where class DocWrapable a where
docWrapNode :: ( Data.Data.Data ast) docWrapNode :: ( Data.Data.Data ast)
=> Located ast => Located ast
-> ToBriDocM a -> a
-> ToBriDocM a -> a
docWrapNodePrior :: ( Data.Data.Data ast) docWrapNodePrior :: ( Data.Data.Data ast)
=> Located ast => Located ast
-> ToBriDocM a -> a
-> ToBriDocM a -> a
docWrapNodeRest :: ( Data.Data.Data ast) docWrapNodeRest :: ( Data.Data.Data ast)
=> Located ast => Located ast
-> ToBriDocM a -> a
-> ToBriDocM a -> a
instance DocWrapable BriDocNumbered where instance DocWrapable (ToBriDocM BriDocNumbered) where
docWrapNode ast bdm = do docWrapNode ast bdm = do
bd <- bdm bd <- bdm
i1 <- allocNodeIndex i1 <- allocNodeIndex
@ -679,7 +687,22 @@ instance DocWrapable BriDocNumbered where
$ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast) $ BDFAnnotationRest (ExactPrint.Types.mkAnnKey ast)
$ bd $ 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 docWrapNode ast bdsm = do
bds <- bdsm bds <- bdsm
case bds of case bds of
@ -707,7 +730,7 @@ instance DocWrapable a => DocWrapable [a] where
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ reverse (bdN':bdR) return $ reverse (bdN':bdR)
instance DocWrapable a => DocWrapable (Seq a) where instance DocWrapable (ToBriDocM a) => DocWrapable (ToBriDocM (Seq a)) where
docWrapNode ast bdsm = do docWrapNode ast bdsm = do
bds <- bdsm bds <- bdsm
case Seq.viewl bds of case Seq.viewl bds of
@ -735,7 +758,7 @@ instance DocWrapable a => DocWrapable (Seq a) where
bdN' <- docWrapNodeRest ast (return bdN) bdN' <- docWrapNodeRest ast (return bdN)
return $ bdR Seq.|> bdN' return $ bdR Seq.|> bdN'
instance DocWrapable ([BriDocNumbered], BriDocNumbered, a) where instance DocWrapable (ToBriDocM ([BriDocNumbered], BriDocNumbered, a)) where
docWrapNode ast stuffM = do docWrapNode ast stuffM = do
(bds, bd, x) <- stuffM (bds, bd, x) <- stuffM
if null bds if null bds

527
src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs Normal file
View File

@ -0,0 +1,527 @@
{-# LANGUAGE CPP #-}
{-# 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 BasicTypes
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 (TyClDecl GhcPs)
-> Located RdrName
-> 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
-- 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)) ->
#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
tyVarLine <- fmap return $ createBndrDoc bndrs
-- headDoc <- fmap return $ docSeq
-- [ appSep $ docLitS "newtype")
-- , appSep $ docLit nameStr
-- , appSep tyVarLine
-- ]
rhsDoc <- fmap return $ createDetailsDoc consNameStr details
createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "newtype"
, appSep $ docLit nameStr
, appSep tyVarLine
, docSeparator
, docLitS "="
, docSeparator
, rhsDoc
]
_ -> 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
HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
#endif
docWrapNode ltycl $ do
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
nameStr <- lrdrNameToTextAnn name
tyVarLine <- fmap return $ createBndrDoc bndrs
createDerivingPar mDerivs $ docSeq
[ appSep $ docLitS "data"
, lhsContextDoc
, appSep $ docLit nameStr
, 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
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
consNameStr <- lrdrNameToTextAnn consName
tyVarLine <- fmap return $ createBndrDoc bndrs
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
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
[ 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
, 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
]
)
( 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
]
)
]
_ -> briDocByExactNoComment ltycl
_ -> briDocByExactNoComment ltycl
createContextDoc :: HsContext GhcPs -> ToBriDocM BriDocNumbered
createContextDoc [] = docEmpty
createContextDoc [t] =
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
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
<&> \(vname, mKind) -> case mKind of
Nothing -> docLit vname
Just kind -> docSeq
[ docLitS "("
, docLit vname
, docSeparator
, docLitS "::"
, docSeparator
, kind
, docLitS ")"
]
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 _ []) -> mainDoc
(L _ types) ->
docPar mainDoc
$ docEnsureIndent BrIndentRegular
$ docLines
$ docWrapNode derivs
$ derivingClauseDoc
<$> types
#else
Nothing -> 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
#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) ->
let
tsLength = length ts
whenMoreThan1Type val =
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
(lhsStrategy, rhsStrategy) = (docEmpty, docEmpty)
#endif
in
docSeq
[ docDeriving
, docWrapNodePrior types $ lhsStrategy
, docSeparator
, whenMoreThan1Type "("
, 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
#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 ) -> (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 $ docLitS " via"
, docSeparator
, layoutType t
]
XHsImplicitBndrs ext -> absurdExt ext
)
#endif
#endif
docDeriving :: ToBriDocM BriDocNumbered
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
let
singleLine = docSeq
[ docLit consNameStr
, docSeparator
, docForceSingleline
$ docSeq
$ List.intersperse docSeparator
$ args <&> layoutType
]
leftIndented = docSetParSpacing
. docAddBaseY BrIndentRegular
. 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, multiAppended, leftIndented]
IndentPolicyFree ->
docAlt [singleLine, multiAppended, multiIndented, leftIndented]
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
let allowSingleline = False
docAddBaseY BrIndentRegular
$ 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 $ docNonBottomSpacingS $ 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
, docLit consNameStr
, docSeparator
, layoutType arg2
]
where
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
L _ (XConDeclField x) -> absurdExt x
#else
L _ (ConDeclField names t _) -> createNamesAndTypeDoc lField names t
#endif
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)
createNamesAndTypeDoc lField names t =
( docNodeAnnKW lField Nothing $ docWrapNodePrior lField $ docSeq
[ docSeq
$ List.intersperse docCommaSep
$ names
<&> \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
]
, docWrapNodeRest lField $ layoutType t
)

10
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

@ -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.Expr
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
import Language.Haskell.Brittany.Internal.Layouters.Pattern import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Language.Haskell.Brittany.Internal.Layouters.DataDecl
import Bag ( mapBagM, bagToList, emptyBag ) import Bag ( mapBagM, bagToList, emptyBag )
import Data.Char (isUpper) import Data.Char (isUpper)
@ -85,7 +86,6 @@ layoutDecl d@(L loc decl) = case decl of
_ -> briDocByExactNoComment d _ -> briDocByExactNoComment d
#endif #endif
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Sig -- Sig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -741,6 +741,14 @@ layoutTyCl ltycl@(L _loc tycl) = case tycl of
let wrapNodeRest = docWrapNodeRest ltycl let wrapNodeRest = docWrapNodeRest ltycl
docWrapNodePrior ltycl docWrapNodePrior ltycl
$ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ
#if MIN_VERSION_ghc(8,6,0)
DataDecl _ext name tyVars _ dataDefn ->
#elif MIN_VERSION_ghc(8,2,0)
DataDecl name tyVars _ dataDefn _ _ ->
#else
DataDecl name tyVars dataDefn _ _ ->
#endif
layoutDataDecl ltycl name tyVars dataDefn
_ -> briDocByExactNoComment ltycl _ -> briDocByExactNoComment ltycl
layoutSynDecl layoutSynDecl

15
src/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View File

@ -444,15 +444,17 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
let end = docLit $ Text.pack ")" let end = docLit $ Text.pack ")"
lines = List.tail docs <&> \d -> lines = List.tail docs <&> \d ->
docCols ColTyOpPrefix [docCommaSep, d] docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
commaDocs = List.intersperse docCommaSep (docForceSingleline <$> docs)
docAlt docAlt
[ docSeq $ [docLit $ Text.pack "("] [ docSeq $ [docLit $ Text.pack "("]
++ List.intersperse docCommaSep (docForceSingleline <$> docs) ++ docWrapNodeRest ltype commaDocs
++ [end] ++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs] , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in docPar in docPar
(docAddBaseY (BrIndentSpecial 2) $ line1) (docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) (docLines $ docWrapNodeRest ltype lines ++ [end])
] ]
unboxedL = do unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs docs <- docSharedWrapper layoutType `mapM` typs
@ -460,15 +462,16 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
end = docParenHashRSep end = docParenHashRSep
docAlt docAlt
[ docSeq $ [start] [ docSeq $ [start]
++ List.intersperse docCommaSep docs ++ docWrapNodeRest ltype (List.intersperse docCommaSep docs)
++ [end] ++ [end]
, let , let
line1 = docCols ColTyOpPrefix [start, head docs] line1 = docCols ColTyOpPrefix [start, head docs]
lines = List.tail docs <&> \d -> lines = List.tail docs <&> \d ->
docCols ColTyOpPrefix [docCommaSep, d] docAddBaseY (BrIndentSpecial 2)
$ docCols ColTyOpPrefix [docCommaSep, d]
in docPar in docPar
(docAddBaseY (BrIndentSpecial 2) line1) (docAddBaseY (BrIndentSpecial 2) line1)
(docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end]) (docLines $ lines ++ [end])
] ]
HsOpTy{} -> -- TODO HsOpTy{} -> -- TODO
briDocByExactInlineOnly "HsOpTy{}" ltype briDocByExactInlineOnly "HsOpTy{}" ltype

37
src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
View File

@ -331,7 +331,7 @@ transformAlts =
BrIndentNone -> r BrIndentNone -> r
BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r BrIndentRegular -> reWrap $ BDFEnsureIndent (BrIndentSpecial indAdd) r
BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r BrIndentSpecial i -> reWrap $ BDFEnsureIndent (BrIndentSpecial i) r
BDFNonBottomSpacing bd -> rec bd BDFNonBottomSpacing _ bd -> rec bd
BDFSetParSpacing bd -> rec bd BDFSetParSpacing bd -> rec bd
BDFForceParSpacing bd -> rec bd BDFForceParSpacing bd -> rec bd
BDFDebug s bd -> do BDFDebug s bd -> do
@ -488,13 +488,18 @@ getSpacing !bridoc = rec bridoc
BrIndentSpecial i -> i BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp pf) -> return $ mVs <&> \(VerticalSpacing lsp psp pf) ->
VerticalSpacing (lsp + addInd) psp pf VerticalSpacing (lsp + addInd) psp pf
BDFNonBottomSpacing bd -> do BDFNonBottomSpacing b bd -> do
mVs <- rec bd mVs <- rec bd
return return
$ mVs $ mVs
<|> LineModeValid (VerticalSpacing 0 <|> LineModeValid
(VerticalSpacingParAlways colMax) (VerticalSpacing
False) 0
(if b then VerticalSpacingParSome 0
else VerticalSpacingParAlways colMax
)
False
)
BDFSetParSpacing bd -> do BDFSetParSpacing bd -> do
mVs <- rec bd mVs <- rec bd
return $ mVs <&> \vs -> vs { _vs_parFlag = True } return $ mVs <&> \vs -> vs { _vs_parFlag = True }
@ -799,16 +804,30 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
BrIndentSpecial i -> i BrIndentSpecial i -> i
return $ mVs <&> \(VerticalSpacing lsp psp parFlag) -> return $ mVs <&> \(VerticalSpacing lsp psp parFlag) ->
VerticalSpacing (lsp + addInd) 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 mVs <- rec bd
return $ if null mVs 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 else mVs <&> \vs -> vs
{ _vs_sameLine = min colMax (_vs_sameLine vs) { _vs_sameLine = min colMax (_vs_sameLine vs)
, _vs_paragraph = case _vs_paragraph vs of , _vs_paragraph = case _vs_paragraph vs of
VerticalSpacingParNone -> VerticalSpacingParNone VerticalSpacingParNone -> VerticalSpacingParNone
VerticalSpacingParAlways i -> VerticalSpacingParAlways i VerticalSpacingParAlways i
VerticalSpacingParSome 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 -- the version below is an alternative idea: fold the input
-- spacings into a single spacing. This was hoped to improve in -- spacings into a single spacing. This was hoped to improve in

2
src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs
View File

@ -135,4 +135,4 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
BDSetParSpacing{} -> Nothing BDSetParSpacing{} -> Nothing
BDForceParSpacing{} -> Nothing BDForceParSpacing{} -> Nothing
BDDebug{} -> Nothing BDDebug{} -> Nothing
BDNonBottomSpacing x -> Just x BDNonBottomSpacing _ x -> Just x

47
src/Language/Haskell/Brittany/Internal/Types.hs
View File

@ -185,6 +185,8 @@ data ColSig
| ColBindStmt | ColBindStmt
| ColDoLet -- the non-indented variant | ColDoLet -- the non-indented variant
| ColRec | ColRec
| ColRecUpdate -- used for both RecCon and RecUpd. TODO: refactor to reflect?
tfausak commented 2019-09-10 00:58:58 +02:00 (Migrated from github.com)
Review

What would be the benefit of differentiating between record construction and record update? I thought they were always formatted the same.

What would be the benefit of differentiating between record construction and record update? I thought they were always formatted the same.
| ColRecDecl
| ColListComp | ColListComp
| ColList | ColList
| ColApp Text | ColApp Text
@ -256,7 +258,7 @@ data BriDoc
-- after the alt transformation. -- after the alt transformation.
| BDForceMultiline BriDoc | BDForceMultiline BriDoc
| BDForceSingleline BriDoc | BDForceSingleline BriDoc
| BDNonBottomSpacing BriDoc | BDNonBottomSpacing Bool BriDoc
| BDSetParSpacing BriDoc | BDSetParSpacing BriDoc
| BDForceParSpacing BriDoc | BDForceParSpacing BriDoc
-- pseudo-deprecated -- pseudo-deprecated
@ -301,7 +303,7 @@ data BriDocF f
| BDFEnsureIndent BrIndent (f (BriDocF f)) | BDFEnsureIndent BrIndent (f (BriDocF f))
| BDFForceMultiline (f (BriDocF f)) | BDFForceMultiline (f (BriDocF f))
| BDFForceSingleline (f (BriDocF f)) | BDFForceSingleline (f (BriDocF f))
| BDFNonBottomSpacing (f (BriDocF f)) | BDFNonBottomSpacing Bool (f (BriDocF f))
| BDFSetParSpacing (f (BriDocF f)) | BDFSetParSpacing (f (BriDocF f))
| BDFForceParSpacing (f (BriDocF f)) | BDFForceParSpacing (f (BriDocF f))
| BDFDebug String (f (BriDocF f)) | BDFDebug String (f (BriDocF f))
@ -315,31 +317,35 @@ type BriDocNumbered = (Int, BriDocFInt)
instance Uniplate.Uniplate BriDoc where instance Uniplate.Uniplate BriDoc where
uniplate x@BDEmpty{} = plate x uniplate x@BDEmpty{} = plate x
uniplate x@BDLit{} = plate x uniplate x@BDLit{} = plate x
uniplate (BDSeq list) = plate BDSeq ||* list uniplate (BDSeq list ) = plate BDSeq ||* list
uniplate (BDCols sig list) = plate BDCols |- sig ||* list uniplate (BDCols sig list) = plate BDCols |- sig ||* list
uniplate x@BDSeparator = plate x uniplate x@BDSeparator = plate x
uniplate (BDAddBaseY ind bd) = plate BDAddBaseY |- ind |* bd uniplate (BDAddBaseY ind bd ) = plate BDAddBaseY |- ind |* bd
uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd uniplate (BDBaseYPushCur bd) = plate BDBaseYPushCur |* bd
uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd uniplate (BDBaseYPop bd) = plate BDBaseYPop |* bd
uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd uniplate (BDIndentLevelPushCur bd) = plate BDIndentLevelPushCur |* bd
uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd uniplate (BDIndentLevelPop bd) = plate BDIndentLevelPop |* bd
uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented uniplate (BDPar ind line indented) = plate BDPar |- ind |* line |* indented
uniplate (BDAlt alts) = plate BDAlt ||* alts uniplate (BDAlt alts ) = plate BDAlt ||* alts
uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd uniplate (BDForwardLineMode bd ) = plate BDForwardLineMode |* bd
uniplate x@BDExternal{} = plate x uniplate x@BDExternal{} = plate x
uniplate x@BDPlain{} = plate x uniplate x@BDPlain{} = plate x
uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd uniplate (BDAnnotationPrior annKey bd) =
uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd plate BDAnnotationPrior |- annKey |* bd
uniplate (BDAnnotationRest annKey bd) = plate BDAnnotationRest |- annKey |* bd uniplate (BDAnnotationKW annKey kw bd) =
uniplate (BDMoveToKWDP annKey kw b bd) = plate BDMoveToKWDP |- annKey |- kw |- b |* bd plate BDAnnotationKW |- annKey |- kw |* bd
uniplate (BDLines lines) = plate BDLines ||* lines uniplate (BDAnnotationRest annKey bd) =
uniplate (BDEnsureIndent ind bd) = plate BDEnsureIndent |- ind |* bd plate BDAnnotationRest |- annKey |* bd
uniplate (BDForceMultiline bd) = plate BDForceMultiline |* bd uniplate (BDMoveToKWDP annKey kw b bd) =
uniplate (BDForceSingleline bd) = plate BDForceSingleline |* bd plate BDMoveToKWDP |- annKey |- kw |- b |* bd
uniplate (BDNonBottomSpacing bd) = plate BDNonBottomSpacing |* bd uniplate (BDLines lines ) = plate BDLines ||* lines
uniplate (BDSetParSpacing bd) = plate BDSetParSpacing |* bd uniplate (BDEnsureIndent ind bd ) = plate BDEnsureIndent |- ind |* bd
uniplate (BDForceParSpacing bd) = plate BDForceParSpacing |* bd uniplate (BDForceMultiline bd ) = plate BDForceMultiline |* bd
uniplate (BDDebug s bd) = plate BDDebug |- s |* 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 newtype NodeAllocIndex = NodeAllocIndex Int
@ -369,12 +375,11 @@ unwrapBriDocNumbered tpl = case snd tpl of
BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd BDFEnsureIndent ind bd -> BDEnsureIndent ind $ rec bd
BDFForceMultiline bd -> BDForceMultiline $ rec bd BDFForceMultiline bd -> BDForceMultiline $ rec bd
BDFForceSingleline bd -> BDForceSingleline $ rec bd BDFForceSingleline bd -> BDForceSingleline $ rec bd
BDFNonBottomSpacing bd -> BDNonBottomSpacing $ rec bd BDFNonBottomSpacing b bd -> BDNonBottomSpacing b $ rec bd
BDFSetParSpacing bd -> BDSetParSpacing $ rec bd BDFSetParSpacing bd -> BDSetParSpacing $ rec bd
BDFForceParSpacing bd -> BDForceParSpacing $ rec bd BDFForceParSpacing bd -> BDForceParSpacing $ rec bd
BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd BDFDebug s bd -> BDDebug (s ++ "@" ++ show (fst tpl)) $ rec bd
where where rec = unwrapBriDocNumbered
rec = unwrapBriDocNumbered
isNotEmpty :: BriDoc -> Bool isNotEmpty :: BriDoc -> Bool
isNotEmpty BDEmpty = False isNotEmpty BDEmpty = False
@ -406,7 +411,7 @@ briDocSeqSpine = \case
BDEnsureIndent _ind bd -> briDocSeqSpine bd BDEnsureIndent _ind bd -> briDocSeqSpine bd
BDForceMultiline bd -> briDocSeqSpine bd BDForceMultiline bd -> briDocSeqSpine bd
BDForceSingleline bd -> briDocSeqSpine bd BDForceSingleline bd -> briDocSeqSpine bd
BDNonBottomSpacing bd -> briDocSeqSpine bd BDNonBottomSpacing _ bd -> briDocSeqSpine bd
BDSetParSpacing bd -> briDocSeqSpine bd BDSetParSpacing bd -> briDocSeqSpine bd
BDForceParSpacing bd -> briDocSeqSpine bd BDForceParSpacing bd -> briDocSeqSpine bd
BDDebug _s bd -> briDocSeqSpine bd BDDebug _s bd -> briDocSeqSpine bd

14
src/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@ -25,6 +26,7 @@ module Language.Haskell.Brittany.Internal.Utils
, splitFirstLast , splitFirstLast
, lines' , lines'
, showOutputable , showOutputable
, absurdExt
) )
where where
@ -57,6 +59,9 @@ import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types import Language.Haskell.Brittany.Internal.Types
import qualified Data.Generics.Uniplate.Direct as Uniplate import qualified Data.Generics.Uniplate.Direct as Uniplate
#if MIN_VERSION_ghc(8,4,0) /* ghc-8.4 */
import qualified HsExtension
#endif
@ -293,3 +298,12 @@ lines' s = case break (== '\n') s of
(s1, []) -> [s1] (s1, []) -> [s1]
(s1, [_]) -> [s1, ""] (s1, [_]) -> [s1, ""]
(s1, (_:r)) -> s1 : lines' r (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 :: HsExtension.NoExt -> a
absurdExt = error "cannot construct NoExt"
#else
absurdExt :: ()
absurdExt = ()
#endif

54
stack-8.0.2.yaml.lock Normal file
View File

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

33
stack-8.2.2.yaml.lock Normal file
View File

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

19
stack-8.4.3.yaml.lock Normal file
View File

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

26
stack-8.6.5.yaml.lock Normal file
View File

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

47
stack.yaml.lock Normal file
View File

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