{-# 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 Test.HUnit (assertEqual)
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)
import qualified Data.List.Extra
import qualified System.Console.ANSI as ANSI
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
| HeaderLineGolden Text
| PendingLine
| HeaderLineGoldenOutput
| NormalLine Text
| CommentLine
deriving Show
data TestCase = TestCase
{ testName :: Text
, isPending :: Bool
, content :: Text
, expectedOutput :: Maybe Text -- Nothing if input is expected not to change
}
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)
$ case expectedOutput test of
Nothing -> roundTripEqual conf (content test)
Just expctd -> goldenTest conf (content test) expctd
)
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
, expectedOutput = Nothing
}
HeaderLineGolden n : rest ->
case Data.List.Extra.wordsBy isGoldenOutputLine rest of
[inputLines, outputLines] ->
let
inputs = Data.Maybe.mapMaybe extractNormal inputLines
outputs = Data.Maybe.mapMaybe extractNormal outputLines
in TestCase
{ testName = n
, isPending = any isPendingLine rest
, content = Text.unlines inputs
, expectedOutput = Just (Text.unlines outputs)
}
_ -> error $ "malformed golden test at " ++ show n
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
isGoldenOutputLine = \case
HeaderLineGoldenOutput -> True
_ -> 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
]
, [ HeaderLineGolden $ Text.pack name
| _ <- Parsec.try $ Parsec.string "#golden"
, _ <- 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
]
, [ HeaderLineGoldenOutput
| _ <- Parsec.try $ Parsec.string "#expected"
, _ <- Parsec.eof
]
, [ NormalLine mempty
| _ <- Parsec.many $ Parsec.oneOf " \t"
, _ <- Parsec.try $ Parsec.string "<BLANKLINE>"
, _ <- Parsec.eof
]
, [ CommentLine
| _ <- Parsec.many $ Parsec.oneOf " \t"
, _ <- Parsec.optional $ Parsec.string "##" <* many
(Parsec.noneOf "\r\n")
, _ <- 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 _ HeaderLineGolden{} = 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)
goldenTest :: Config -> Text -> Text -> Expectation
goldenTest c input expected = do
result <- parsePrintModuleTests c "TestFakeFileName.hs" input
assertEqual
( ANSI.setSGRCode [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
++ "golden input: see test source!"
++ ANSI.setSGRCode [ANSI.Reset]
)
(Right (PPTextWrapper expected))
(fmap PPTextWrapper result)
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
, _lconfig_fixityAwareOps = coerce True
, _lconfig_fixityAwareTypeOps = coerce True
, _lconfig_unknownFixityHandling = coerce UFHSafeWarn
, _lconfig_fixityBasedAddAlignParens = coerce False
, _lconfig_operatorParenthesisRefactorMode = coerce PRMKeep
, _lconfig_operatorAllowUnqualify = coerce True
}
, _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
}
}