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

Implement #min-ghc keyword for test script

pull/259/head
Lennart Spitzner 2019-11-07 00:58:38 +01:00 committed by Evan Rutledge Borden
parent 48490a7110
commit 54f34344b3
2 changed files with 121 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -365,6 +365,7 @@ data Foo = Bar
deriving newtype (Traversable, Foldable) deriving newtype (Traversable, Foldable)
#test record deriving via #test record deriving via
#min-ghc 8.6
data Foo = Bar data Foo = Bar
{ foo :: Baz { foo :: Baz
, bars :: Bizzz , bars :: Bizzz
@ -424,13 +425,28 @@ data Foo = Bar
, -- e , -- e
FromJSON --f FromJSON --f
) -- g ) -- g
via -- h
( -- i #test record comments in deriving via
SomeType --j ## maybe we want to switch to a differnt layout when there are such comments.
, -- k ## Don't hesitate to modify this testcase, it clearly is not the ideal layout
ABC --l ## 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
) )
############################################################################### ###############################################################################
############################################################################### ###############################################################################
############################################################################### ###############################################################################

131
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
@ -181,21 +215,18 @@ defaultTestConfig = Config
, _lconfig_allowHangingQuasiQuotes = coerce True , _lconfig_allowHangingQuasiQuotes = coerce True
, _lconfig_experimentalSemicolonNewlines = coerce False , _lconfig_experimentalSemicolonNewlines = 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
} }
} }