thrift-compiler-0.1.0.1: test/TestFixtures.hs

{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

{-# LANGUAGE TypeApplications #-}
module TestFixtures (main) where

import Control.Monad (unless, when)
import Data.Aeson.Encode.Pretty
import Data.List
import Data.List.Extra
import qualified Data.Text.Lazy as Text
import qualified Data.Text.Lazy.Encoding as Text
import Data.Typeable
import System.Exit
import System.FilePath
import System.IO.Temp (withSystemTempDirectory)
import System.Process
import Test.HUnit
import TestRunner

import Util

import Thrift.Compiler
import Thrift.Compiler.GenHaskell
import Thrift.Compiler.GenJSON
import Thrift.Compiler.GenJSONLoc
import Thrift.Compiler.Options
import Thrift.Compiler.OptParse

import Language.Haskell.Exts

main :: IO ()
main = withFixtureOptions $ \opts -> do
  fixtures <- mapM genFixtures opts
  testRunner $ TestList $ map checkFixture $ concat fixtures

genFixtures :: SomeOptions -> IO [ThriftModule]
genFixtures (TheseOptions opts@Options{..}) = do
  (headModule, deps) <- typecheckInput opts =<< parseAll opts optsPath
  generator headModule deps
  where
    generator prog deps = case optsGenMode of
      EmitCode
        | Just (hsopts, ps) <- cast (opts, prog : deps) ->
            concat <$> mapM @[] (genHsCode hsopts) ps
      EmitJSON WithoutLoc
        | optsSingleOutput -> return [genJSONThriftModule (Just deps) prog]
        | otherwise -> return $ map (genJSONThriftModule Nothing) $ prog : deps
      EmitJSON WithLoc
        | optsSingleOutput -> return [genJSONLocThriftModule (Just deps) prog]
        | otherwise -> return $ map (genJSONLocThriftModule Nothing)
                              $ prog : deps
      _ -> return []

    prettyJSON = encodePretty' defConfig { confCompare = compare }

    genJSONThriftModule ds prog = ThriftModule
      { tmPath = uncurry (</>) $ getAstPath prog
      , tmContents =
          Text.unpack $ Text.decodeUtf8 $ prettyJSON $ genJSON prog ds
      , tmModuleName = ""
      }
    genJSONLocThriftModule ds prog = ThriftModule
      { tmPath = uncurry (</>) $ getAstPath prog
      , tmContents =
          Text.unpack $ Text.decodeUtf8 $ prettyJSON $ genJSONLoc prog ds
      , tmModuleName = ""
      }

checkFixture :: ThriftModule -> Test
checkFixture ThriftModule{..} = TestLabel mname $ TestCase $ do
  when (canParse tmPath) $ assertParseOk tmPath tmContents exts
  fixture <- readFile tmPath
  assertFileEqual tmPath fixture tmContents
  where
    mname = snd $ breakOnEnd "/test/fixtures/" tmPath
    canParse filename
      | isSuffixOf ".ast" filename = False
      | isSuffixOf "Service.hs" filename = False
      -- Service.hs does not parse due to
      -- https://github.com/haskell-suite/haskell-src-exts/issues/310
      -- (I think)
      | otherwise = True
    exts = map EnableExtension [ConstraintKinds]

assertParseOk :: FilePath -> String -> [Extension] -> IO ()
assertParseOk path contents exts =
  case parseFileContentsWithExts exts contents of
    ParseOk _ -> return ()
    ParseFailed loc str -> do
      putStrLn path
      putStrLn "Contents:"
      putStrLn contents
      assertFailure $ "Parse failed at [" ++ path ++ "] (" ++
        show (srcLine loc) ++ ":" ++ show (srcColumn loc) ++ "): " ++ str

assertFileEqual :: FilePath -> String -> String -> IO ()
assertFileEqual _path expected obtained =
  unless (normalize expected == normalize obtained) $ withSystemTempDirectory "diff" $ \dir -> do
    let expectPath = dir </> "expect"
        obtainPath = dir </> "obtain"
    writeFile expectPath (normalize expected)
    writeFile obtainPath (normalize obtained)
    let cp = proc "diff" ["-U", "10", expectPath, obtainPath]
    (ec, out, _err) <- readCreateProcessWithExitCode cp ""
    unless (ExitSuccess == ec) $ do
      assertFailure out
  where
    -- In dependent-sum > 0.6 the This constructor was renamed to Some
    normalize
      = Text.unpack
      . Text.unlines
      . map fixLine
      . Text.lines
      . Text.pack

    fixLine
      = Text.replace "\"compiler/test/fixtures/"
                     "\"test/fixtures/"
      . Text.replace "\"include_path\": \"compiler\","
                     "\"include_path\": \".\","
    -- TODO: update the fixtures and remove this replace once 8.8 lands
      . Text.replace "Thrift.This" "Thrift.Some"