Skip to content
Snippets Groups Projects
Select Git revision
  • 0f9ee0b1533fa28f966fb645216389b569cd33db
  • main default protected
  • GUI
  • christian_test
4 results

mypointsmore.npy

Blame
  • Code owners
    Assign users and groups as approvers for specific file changes. Learn more.
    ReduceCSpec.hs 4.39 KiB
    {-# LANGUAGE BlockArguments #-}
    {-# LANGUAGE LambdaCase #-}
    
    module ReduceCSpec where
    
    import Control.Monad
    
    import System.Directory
    import System.FilePath
    import Test.Hspec
    
    import qualified Data.Text.Lazy as LazyText
    import qualified Data.Text.Lazy.Encoding as LazyText
    
    import Test.Hspec.Glitter
    
    import qualified Language.C as C
    import qualified Text.PrettyPrint as P
    
    import qualified Control.Monad.IRTree as IRTree
    import Control.Monad.RTree (extract, iinputs, probe)
    import Data.Bool
    import Data.Functor
    import Data.RPath
    import Data.String
    import qualified Language.C.System.GCC as C
    import ReduceC
    import System.Directory.Internal.Prelude (tryIOError)
    import System.Process.Typed
    
    spec :: Spec
    spec = do
      specSmallCases
      specLargeCases
    
    specLargeCases :: Spec
    specLargeCases = do
      cases <- runIO (listDirectory "test/cases/large")
    
      forM_ cases \cname -> do
        let cfrom = "test/cases/large" </> cname
    
        describe cfrom do
          c <- runIO $ parse cfrom
    
          let expected = "test/expected" </> dropExtensions cname
          onGlitterWith (expected </> "main.c") (\fp () -> render fp c) do
            it "should be valid" . foldMap $ \cf -> do
              validate cf
    
            it "should be parsed equally" . foldMap $ \cf -> do
              C.parseCFilePre cf >>= \case
                Left err -> fail (show err)
                Right c' -> c' $> () `shouldBe` c $> ()
    
          describe "reduction" do
            it "should extract itself" do
              IRTree.extract (defaultReduceC c) $> () `shouldBe` c $> ()
    
          onGlitterWith
            (expected </> "reduction/")
            ( \a () -> do
                createDirectoryIfMissing True a
                listDirectory a >>= mapM_ \i -> do
                  let idx = fromString (drop 1 (dropExtension i))
                  renderWithChoices
                    (expected </> "reduction" </> i)
                    (probe (defaultReduceC c) idx)
            )
            do
              it "should validate all reductions" . mapM_ $ \a -> do
                when (takeExtension a == ".c") do
                  validate a
    
    specSmallCases :: Spec
    specSmallCases = do
      cases <- runIO (listDirectory "test/cases/small")
    
      forM_ cases \cname -> do
        let cfrom = "test/cases/small" </> cname
    
        describe cfrom do
          c <- runIO $ parse cfrom
    
          let expected = "test/expected" </> dropExtensions cname
          onGlitterWith (expected </> "main.c") (\fp () -> render fp c) do
            it "should be valid" . foldMap $ \cf -> do
              validate cf
    
            it "should be parsed equally" . foldMap $ \cf -> do
              C.parseCFilePre cf >>= \case
                Left err -> fail (show err)
                Right c' -> c' $> () `shouldBe` c $> ()
    
          describe "reduction" do
            it "should extract itself" do
              extract (defaultReduceC c) $> () `shouldBe` c $> ()
    
          onGlitterWith
            (expected </> "reduction/")
            ( \a () -> do
                _ <- tryIOError (removeDirectoryRecursive a)
                createDirectoryIfMissing True a
                forM_ (iinputs (defaultReduceC c)) \(i, _) -> do
                  let rfile = expected </> "reduction" </> "r" <> debugShow i <.> "c"
                  renderWithChoices rfile (probe (defaultReduceC c) i)
            )
            do
              it "should validate all reductions" . mapM_ $ \a -> do
                when (takeExtension a == ".c") do
                  validate a
    
    validate :: FilePath -> IO ()
    validate fp = do
      (ec, _, stderr) <- readProcess (proc "clang" ["-o", "/dev/null", fp])
      case ec of
        ExitFailure _ ->
          expectationFailure $
            "could not validate "
              <> show fp
              <> "\n"
              <> LazyText.unpack (LazyText.decodeUtf8 stderr)
        ExitSuccess -> pure ()
    
    render :: FilePath -> C.CTranslUnit -> IO ()
    render cto c = do
      createDirectoryIfMissing True (takeDirectory cto)
      writeFile cto (P.render (C.pretty c) <> "\n")
    
    renderWithChoices :: FilePath -> (C.CTranslUnit, [(Bool, (String, C.Position))]) -> IO ()
    renderWithChoices file (c, a) = do
      createDirectoryIfMissing True (takeDirectory file)
      writeFile
        file
        ( ( unlines
              . map
                ( \(choice, (reason, pos)) ->
                    "// " <> bool "0" "1" choice <> " " <> reason <> " at " <> show pos
                )
              . reverse
              $ a
          )
            <> "\n"
            <> P.render (C.pretty c)
            <> "\n"
        )
    
    parse :: FilePath -> IO C.CTranslUnit
    parse cfrom = do
      cf <- C.parseCFile (C.newGCC "clang") Nothing [] cfrom
      case cf of
        Left err -> fail (show err)
        Right cf' -> pure cf'