{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE ScopedTypeVariables #-} import Data.Coerce (coerce) import Data.List (groupBy) import qualified Data.Maybe import qualified Data.Semigroup as Semigroup import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified GHC.OldList as List import qualified Data.Map.Strict as Map import Data.These import Language.Haskell.Brittany.Internal import Language.Haskell.Brittany.Internal.Config.Config import Language.Haskell.Brittany.Internal.Config.Types import Language.Haskell.Brittany.Internal.Prelude import qualified System.Directory import System.FilePath (()) import System.Timeout (timeout) import Test.Hspec import qualified Text.Parsec as Parsec import Text.Parsec.Text (Parser) hush :: Either a b -> Maybe b hush = either (const Nothing) Just asymptoticPerfTest :: Spec asymptoticPerfTest = do it "10 do statements" $ roundTripEqualWithTimeout 1500000 $ (Text.pack "func = do\n") <> Text.replicate 10 (Text.pack " statement\n") it "10 do nestings" $ roundTripEqualWithTimeout 4000000 $ (Text.pack "func = ") <> mconcat ( [1 .. 10] <&> \(i :: Int) -> (Text.replicate (2 * i) (Text.pack " ") <> Text.pack "do\n") ) <> Text.replicate 2000 (Text.pack " ") <> Text.pack "return\n" <> Text.replicate 2002 (Text.pack " ") <> Text.pack "()" it "10 AppOps" $ roundTripEqualWithTimeout 1000000 $ (Text.pack "func = expr") <> Text.replicate 10 (Text.pack "\n . expr") --TODO roundTripEqualWithTimeout :: Int -> Text -> Expectation roundTripEqualWithTimeout time t = timeout time (action >>= evaluate) >>= (`shouldSatisfy`Data.Maybe.isJust) where action = fmap (fmap PPTextWrapper) (parsePrintModuleTests defaultTestConfig "TestFakeFileName.hs" t) data InputLine = GroupLine Text | HeaderLine Text | PendingLine | NormalLine Text | CommentLine deriving Show data TestCase = TestCase { testName :: Text , isPending :: Bool , content :: Text } main :: IO () main = do let getFiles :: FilePath -> IO [FilePath] getFiles path = do candidates <- System.Directory.listDirectory path fmap join $ sequence $ [ do isDir <- System.Directory.doesDirectoryExist (path c) if | isDir -> getFiles (path c) | ".blt" `isSuffixOf` c -> pure [path c] | otherwise -> pure [] | c <- candidates ] blts <- getFiles "data/" inputs <- sequence [ Text.IO.readFile (blt) | blt <- blts , not ("tests-context-free.blt" `isSuffixOf` blt) ] let groups = createChunks =<< inputs inputCtxFree <- sequence [ Text.IO.readFile (blt) | blt <- blts , "tests-context-free.blt" `isSuffixOf` blt ] let groupsCtxFree = createChunks =<< inputCtxFree hspec $ do describe "asymptotic perf roundtrips" $ asymptoticPerfTest describe "library interface basic functionality" $ do it "gives properly formatted result for valid input" $ do let input = Text.pack $ unlines ["func = [00000000000000000000000, 00000000000000000000000, 00000000000000000000000, 00000000000000000000000]"] let expected = Text.pack $ unlines [ "func =" , " [ 00000000000000000000000" , " , 00000000000000000000000" , " , 00000000000000000000000" , " , 00000000000000000000000" , " ]" ] output <- liftIO $ parsePrintModule (TraceFunc $ \_ -> pure ()) staticDefaultConfig input hush output `shouldBe` Just expected let runWithConfig grps conf = do -- This is a quick-and-dirty solution for merging groups, because hspec -- isn't clever enough to merge "describe foo (item x); describe (item y)" -- into "describe foo (item; item y)". -- This is a messy solution that works for the first two layers only. -- TODO: Ideally we'd have some proper data-structure to represent -- something similar in shape to a nested directory/file structure. -- e.g. data Dir a = Map String (Either (Dir a) a) let groupTree = Map.unionsWith (Map.unionWith $ Map.unionWith (++)) [ case splitGroups of (a:b:rs) -> Map.singleton a (Map.singleton (Just b) $ Map.singleton rs tests) [a] -> Map.singleton a (Map.singleton Nothing (Map.singleton [] tests)) [] -> error "empty test group name, should not happen" | (groupname, tests) <- grps, let splitGroups = Text.splitOn (Text.pack "/") groupname] Map.toList groupTree `forM_` \(k, m2) -> describe (Text.unpack k) $ Map.toList m2 `forM_` \(k2, m3) -> (case k2 of Nothing -> id Just grp -> describe (Text.unpack grp)) (Map.toList m3 `forM_` \(ks, tests) -> foldr (\grp -> describe (Text.unpack grp)) (tests `forM_` \test -> do (if isPending test then before_ pending else id) $ it (Text.unpack $ testName test) $ roundTripEqual conf $ content test ) ks ) runWithConfig groups defaultTestConfig runWithConfig groupsCtxFree contextFreeTestConfig 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 , 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 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 ] , [ 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 } }