232 lines
8.9 KiB
Haskell
232 lines
8.9 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MonadComprehensions #-}
|
|
|
|
import Language.Haskell.Brittany.Internal.Prelude
|
|
import qualified Data.List.Extra
|
|
import qualified Data.Maybe
|
|
import qualified Data.Semigroup as Semigroup
|
|
import qualified Data.Text as Text
|
|
import qualified GHC.OldList as List
|
|
import qualified System.Directory
|
|
|
|
import Test.Hspec
|
|
|
|
import qualified Text.Parsec as Parsec
|
|
import Text.Parsec.Text ( Parser )
|
|
|
|
import Data.List ( groupBy )
|
|
|
|
import Language.Haskell.Brittany.Internal
|
|
|
|
import Language.Haskell.Brittany.Internal.Config.Types
|
|
import Language.Haskell.Brittany.Internal.Config
|
|
|
|
import Data.Coerce ( coerce )
|
|
|
|
import qualified Data.Text.IO as Text.IO
|
|
import System.FilePath ( (</>) )
|
|
|
|
|
|
|
|
data InputLine
|
|
= GroupLine Text
|
|
| HeaderLine Text
|
|
| GhcVersionGuardLine Text
|
|
| PendingLine
|
|
| NormalLine Text
|
|
| CommentLine
|
|
deriving Show
|
|
|
|
data TestCase = TestCase
|
|
{ testName :: Text
|
|
, isPending :: Bool
|
|
, minGHCVersion :: Maybe Text
|
|
, content :: Text
|
|
}
|
|
|
|
main :: IO ()
|
|
main = do
|
|
files <- System.Directory.listDirectory "src-literatetests/"
|
|
let blts =
|
|
List.sort
|
|
$ filter (\x -> not ("tests-context-free.blt" `isSuffixOf` x))
|
|
$ filter (".blt" `isSuffixOf`) files
|
|
inputs <- blts `forM` \blt -> Text.IO.readFile ("src-literatetests" </> blt)
|
|
let groups = createChunks =<< inputs
|
|
inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt"
|
|
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
|
|
groups `forM_` \(groupname, tests) -> do
|
|
describe (Text.unpack groupname) $ do
|
|
tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do
|
|
(if isPending test then before_ pending else id)
|
|
$ it (Text.unpack $ testName test)
|
|
$ roundTripEqual defaultTestConfig
|
|
$ content test
|
|
groupsCtxFree `forM_` \(groupname, tests) -> do
|
|
describe ("context free: " ++ Text.unpack groupname) $ do
|
|
tests `forM_` \test -> when (checkVersion $ minGHCVersion test) $ do
|
|
(if isPending test then before_ pending else id)
|
|
$ it (Text.unpack $ testName test)
|
|
$ roundTripEqual contextFreeTestConfig
|
|
$ content test
|
|
where
|
|
-- this function might be implemented in a weirdly complex fashion; the
|
|
-- reason being that it was copied from a somewhat more complex variant.
|
|
createChunks :: Text -> [(Text, [TestCase])]
|
|
createChunks input =
|
|
-- fmap (\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
|
|
-- )
|
|
-- $ fmap (groupBy grouperT)
|
|
fmap groupProcessor
|
|
$ groupBy grouperG
|
|
$ filter (not . lineIsSpace)
|
|
$ lineMapper
|
|
<$> Text.lines input
|
|
where
|
|
groupProcessor :: [InputLine] -> (Text, [TestCase])
|
|
groupProcessor = \case
|
|
GroupLine g : grouprest ->
|
|
(,) g
|
|
$ fmap testProcessor
|
|
$ groupBy grouperT
|
|
$ filter (not . lineIsSpace)
|
|
$ grouprest
|
|
l -> error $ "first non-empty line must be a #group\n" ++ show l
|
|
testProcessor :: [InputLine] -> TestCase
|
|
testProcessor = \case
|
|
HeaderLine n : rest ->
|
|
let normalLines = Data.Maybe.mapMaybe extractNormal rest
|
|
in TestCase
|
|
{ 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 _ = Nothing
|
|
extractMinGhc (GhcVersionGuardLine v) = Just v
|
|
extractMinGhc _ = Nothing
|
|
isPendingLine PendingLine{} = True
|
|
isPendingLine _ = False
|
|
specialLineParser :: Parser InputLine
|
|
specialLineParser = Parsec.choice
|
|
[ [ GroupLine $ Text.pack name
|
|
| _ <- Parsec.try $ Parsec.string "#group"
|
|
, _ <- Parsec.many1 $ Parsec.oneOf " \t"
|
|
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
|
|
, _ <- Parsec.eof
|
|
]
|
|
, [ HeaderLine $ Text.pack name
|
|
| _ <- Parsec.try $ Parsec.string "#test"
|
|
, _ <- Parsec.many1 $ Parsec.oneOf " \t"
|
|
, name <- Parsec.many1 $ Parsec.noneOf "\r\n:"
|
|
, _ <- 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
|
|
| _ <- Parsec.try $ Parsec.string "#pending"
|
|
, _ <- Parsec.optional $ many (Parsec.noneOf "\r\n")
|
|
, _ <- Parsec.eof
|
|
]
|
|
, [ CommentLine
|
|
| _ <- Parsec.many $ Parsec.oneOf " \t"
|
|
, _ <- Parsec.optional $ Parsec.string "##" <* many
|
|
(Parsec.noneOf "\r\n")
|
|
, _ <- Parsec.eof
|
|
]
|
|
, [ NormalLine mempty
|
|
| _ <- Parsec.try $ Parsec.string "<BLANKLINE>"
|
|
, _ <- Parsec.eof
|
|
]
|
|
]
|
|
lineMapper :: Text -> InputLine
|
|
lineMapper line = case Parsec.runParser specialLineParser () "" line of
|
|
Left _e -> NormalLine line
|
|
Right l -> l
|
|
lineIsSpace :: InputLine -> Bool
|
|
lineIsSpace CommentLine = True
|
|
lineIsSpace _ = False
|
|
grouperG :: InputLine -> InputLine -> Bool
|
|
grouperG _ GroupLine{} = False
|
|
grouperG _ _ = True
|
|
grouperT :: InputLine -> InputLine -> Bool
|
|
grouperT _ HeaderLine{} = False
|
|
grouperT _ _ = True
|
|
|
|
|
|
--------------------
|
|
-- past this line: copy-pasta from other test (meh..)
|
|
--------------------
|
|
roundTripEqual :: Config -> Text -> Expectation
|
|
roundTripEqual c t =
|
|
fmap (fmap PPTextWrapper) (parsePrintModuleTests c "TestFakeFileName.hs" t)
|
|
`shouldReturn` Right (PPTextWrapper t)
|
|
|
|
newtype PPTextWrapper = PPTextWrapper Text
|
|
deriving Eq
|
|
|
|
instance Show PPTextWrapper where
|
|
show (PPTextWrapper t) = "\n" ++ Text.unpack t
|
|
|
|
-- brittany-next-binding --columns 160
|
|
-- brittany-next-binding { lconfig_indentPolicy: IndentPolicyLeft }
|
|
defaultTestConfig :: Config
|
|
defaultTestConfig = Config
|
|
{ _conf_version = _conf_version staticDefaultConfig
|
|
, _conf_debug = _conf_debug staticDefaultConfig
|
|
, _conf_layout = LayoutConfig
|
|
{ _lconfig_cols = coerce (80 :: Int)
|
|
, _lconfig_indentPolicy = coerce IndentPolicyFree
|
|
, _lconfig_indentAmount = coerce (2 :: Int)
|
|
, _lconfig_indentWhereSpecial = coerce True
|
|
, _lconfig_indentListSpecial = coerce True
|
|
, _lconfig_importColumn = coerce (60 :: Int)
|
|
, _lconfig_importAsColumn = coerce (60 :: Int)
|
|
, _lconfig_altChooser = coerce $ AltChooserBoundedSearch 3
|
|
, _lconfig_columnAlignMode = coerce (ColumnAlignModeMajority 0.7)
|
|
, _lconfig_alignmentLimit = coerce (30 :: Int)
|
|
, _lconfig_alignmentBreakOnMultiline = coerce True
|
|
, _lconfig_hangingTypeSignature = coerce False
|
|
, _lconfig_reformatModulePreamble = coerce True
|
|
, _lconfig_allowSingleLineExportList = coerce True
|
|
, _lconfig_allowHangingQuasiQuotes = coerce True
|
|
, _lconfig_experimentalSemicolonNewlines = coerce False
|
|
-- , _lconfig_allowSinglelineRecord = coerce False
|
|
}
|
|
, _conf_errorHandling = (_conf_errorHandling staticDefaultConfig) { _econf_omit_output_valid_check = coerce True }
|
|
, _conf_preprocessor = _conf_preprocessor staticDefaultConfig
|
|
, _conf_forward = ForwardOptions { _options_ghc = Identity [] }
|
|
, _conf_roundtrip_exactprint_only = coerce False
|
|
, _conf_disable_formatting = coerce False
|
|
, _conf_obfuscate = coerce False
|
|
}
|
|
|
|
contextFreeTestConfig :: Config
|
|
contextFreeTestConfig = defaultTestConfig
|
|
{ _conf_layout = (_conf_layout defaultTestConfig)
|
|
{ _lconfig_indentPolicy = coerce IndentPolicyLeft
|
|
, _lconfig_alignmentLimit = coerce (1 :: Int)
|
|
, _lconfig_columnAlignMode = coerce ColumnAlignModeDisabled
|
|
}
|
|
}
|