1
1
mirror of https://github.com/github/semantic.git synced 2024-12-22 22:31:36 +03:00
semantic/test/Examples.hs
2018-09-18 15:32:56 -07:00

106 lines
4.6 KiB
Haskell

module Main (main) where
import Control.Exception (displayException)
import Control.Monad
import Control.Monad.Effect
import Control.Monad.Effect.Exception
import qualified Data.ByteString as B
import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as BC
import Data.Either
import Data.Foldable
import Data.List
import Data.Maybe
import Data.Project (file)
import Data.Quieterm
import Data.Typeable (cast)
import Data.Void
import Parsing.Parser
import Rendering.Renderer
import Semantic.Config (Config (..), Options (..), defaultOptions)
import qualified Semantic.IO as IO
import Semantic.Parse
import Semantic.Task
import Semantic.Util (TaskConfig (..))
import System.Directory
import System.Exit (die)
import System.FilePath.Glob
import System.FilePath.Posix
import System.Process
import Test.Hspec
main :: IO ()
main = withOptions opts $ \ config logger statter -> hspec . parallel $ do
let args = TaskConfig config logger statter
runIO setupExampleRepos
for_ languages $ \ lang@LanguageExample{..} -> do
let tsDir = languagesDir </> languageName </> ("vendor/tree-sitter-" <> languageName)
parallel . describe languageName $ parseExamples args lang tsDir
where
parseExamples (TaskConfig config logger statter) LanguageExample{..} tsDir = do
knownFailures <- runIO $ knownFailuresForPath tsDir languageKnownFailuresTxt
files <- runIO $ globDir1 (compile ("**/*" <> languageExtension)) (tsDir </> languageExampleDir)
for_ files $ \file -> it file $ do
res <- runTaskWithConfig config logger statter (parseFilePath file)
case res of
Left (SomeException e) -> case cast e of
-- We have a number of known assignment timeouts, consider these pending specs instead of failing the build.
Just (AssignmentTimedOut _ _) -> pendingWith $ show (displayException e)
-- Other exceptions are true failures
_ -> expectationFailure (show (displayException e))
_ -> if file `elem` knownFailures
then pendingWith $ "Known parse failures " <> show (const "Assignment: OK" <$> res)
else res `shouldSatisfy` isRight
setupExampleRepos = readProcess "script/clone-example-repos" mempty mempty >>= print
opts = defaultOptions { optionsFailOnWarning = True, optionsLogLevel = Nothing }
knownFailuresForPath :: FilePath -> Maybe FilePath -> IO [FilePath]
knownFailuresForPath _ Nothing = pure []
knownFailuresForPath tsDir (Just path) = do
known <- BC.lines <$> B.readFile (tsDir </> path)
pure $ (tsDir </>) . BC.unpack <$> stripComments known
where stripComments = filter (\line -> not (BC.null line) && BC.head line == '#')
data LanguageExample
= LanguageExample
{ languageName :: FilePath
, languageExtension :: FilePath
, languageExampleDir :: FilePath
, languageKnownFailuresTxt :: Maybe FilePath
} deriving (Eq, Show)
le :: FilePath -> FilePath -> FilePath -> Maybe FilePath -> LanguageExample
le = LanguageExample
languages :: [LanguageExample]
languages =
[ le "python" ".py" "examples" (Just "script/known_failures.txt")
, le "go" ".go" "examples" (Just "script/known-failures.txt")
, le "ruby" ".rb" "examples" (Just "script/known_failures.txt")
, le "typescript" ".ts" "examples" (Just "script/known_failures.txt")
, le "typescript" ".js" "examples" Nothing -- parse JavaScript with TypeScript parser.
-- TODO: Java assignment errors need to be investigated
-- , le "java" ".java" "examples/guava" (Just "script/known_failures_guava.txt")
-- , le "java" ".java" "examples/elasticsearch" (Just "script/known_failures_elasticsearch.txt")
-- , le "java" ".java" "examples/RxJava" (Just "script/known_failures_RxJava.txt")
-- TODO: Haskell assignment errors need to be investigated
-- , le "haskell" ".hs" "examples/effects" (Just "script/known-failures-effects.txt")
-- , le "haskell" ".hs" "examples/postgrest" (Just "script/known-failures-postgrest.txt")
-- , le "haskell" ".hs" "examples/ivory" (Just "script/known-failures-ivory.txt")
-- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet
]
parseFilePath :: (Member (Exc SomeException) effs, Member Task effs, Member IO.Files effs) => FilePath -> Eff effs Bool
parseFilePath path = readBlob (file path) >>= runParse' >>= const (pure True)
languagesDir :: FilePath
languagesDir = "vendor/haskell-tree-sitter/languages"