{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-} module Main ( main ) where #include "prelude.inc" import Test.Hspec import Test.Hspec.Runner ( hspecWith , defaultConfig , configConcurrentJobs ) import qualified Text.Parsec as Parsec import Text.Parsec.Text ( Parser ) import Data.Char ( isSpace ) 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) $ fmap 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 "" , _ <- 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 } }