mirror of
https://github.com/github/semantic.git
synced 2024-11-28 10:15:55 +03:00
109 lines
3.7 KiB
Haskell
109 lines
3.7 KiB
Haskell
{-# LANGUAGE TypeApplications, TypeOperators #-}
|
|
|
|
-- | FileCheck-style directives for testing Core compilers.
|
|
module Directive ( Directive (..)
|
|
, readDirectivesFromFile
|
|
, describe
|
|
) where
|
|
|
|
import Analysis.Concrete (Concrete (..))
|
|
import Control.Algebra
|
|
import Control.Monad
|
|
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
|
|
import Core.Core (Core)
|
|
import qualified Core.Core as Core
|
|
import Core.Name (Name)
|
|
import qualified Core.Parser
|
|
import qualified Core.Pretty
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Char8 as ByteString
|
|
import qualified Data.ByteString.Streaming.Char8 as ByteStream
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import qualified Source.Span as Source
|
|
import qualified Streaming.Prelude as Stream
|
|
import Syntax.Term (Term)
|
|
import qualified System.Path as Path
|
|
import qualified System.Path.PartClass as Path.Class
|
|
import qualified Text.Parser.Token.Style as Style
|
|
import Text.Trifecta (CharParsing, TokenParsing (..))
|
|
import qualified Text.Trifecta as Trifecta
|
|
|
|
{- |
|
|
|
|
Directives are parsed from magic comments in test files and
|
|
describe to the test suite how to query the results of a given test
|
|
case. A directive that looks like this:
|
|
|
|
@
|
|
# CHECK-RESULT: key: value
|
|
@
|
|
|
|
would test that the value for @key@ in the result evaluates to the given
|
|
concrete value.
|
|
|
|
This syntax was inspired by LLVM's
|
|
[FileCheck](https://llvm.org/docs/CommandGuide/FileCheck.html). This
|
|
approach is less direct than tests that pattern-match over an AST, but
|
|
enable us to keep the text of test cases in close proximity to the
|
|
assertions we want to make, which improves maintainability
|
|
significantly and has been a successful strategy for the LLVM and Rust
|
|
projects.
|
|
|
|
-}
|
|
data Directive = Tree (Term Core Name) -- | @# CHECK-TREE: core@
|
|
| Result Text (Concrete (Term (Core.Ann Source.Span :+: Core))) -- | @# CHECK-RESULT key: expected
|
|
| Fails -- | @# CHECK-FAILS@ fails unless translation fails.
|
|
deriving (Eq, Show)
|
|
|
|
-- | Extract all directives from a file.
|
|
readDirectivesFromFile :: Path.Class.AbsRel ar => Path.File ar -> IO [Directive]
|
|
readDirectivesFromFile
|
|
= runResourceT
|
|
. Stream.toList_
|
|
. Stream.mapM (either perish pure . parseDirective)
|
|
. Stream.takeWhile isComment
|
|
. Stream.mapped ByteStream.toStrict
|
|
. ByteStream.lines
|
|
. ByteStream.readFile @(ResourceT IO)
|
|
. Path.toString
|
|
where
|
|
perish s = fail ("Directive parsing error: " <> s)
|
|
isComment = (== Just '#') . fmap fst . ByteString.uncons
|
|
|
|
|
|
describe :: Directive -> String
|
|
describe Fails = "<expect failure>"
|
|
describe (Tree t) = Core.Pretty.showCore t
|
|
describe (Result t e) = T.unpack t <> ": " <> show e
|
|
|
|
fails :: CharParsing m => m Directive
|
|
fails = Fails <$ Trifecta.string "# CHECK-FAILS"
|
|
|
|
tree :: (Monad m, TokenParsing m) => m Directive
|
|
tree = do
|
|
void $ Trifecta.string "# CHECK-TREE: "
|
|
Tree <$> Core.Parser.core
|
|
|
|
result :: (Monad m, TokenParsing m) => m Directive
|
|
result = do
|
|
void $ Trifecta.string "# CHECK-RESULT "
|
|
key <- Trifecta.ident Style.haskellIdents
|
|
void $ Trifecta.symbolic ':'
|
|
Result key <$> concrete
|
|
|
|
concrete :: TokenParsing m => m (Concrete term)
|
|
concrete = Trifecta.choice
|
|
[ String <$> Trifecta.stringLiteral
|
|
, Bool True <$ Trifecta.symbol "#true"
|
|
, Bool False <$ Trifecta.symbol "#false"
|
|
, Unit <$ Trifecta.symbol "#unit"
|
|
]
|
|
|
|
directive :: (Monad m, TokenParsing m) => m Directive
|
|
directive = Trifecta.choice [ fails, result, tree ]
|
|
|
|
parseDirective :: ByteString -> Either String Directive
|
|
parseDirective = Trifecta.foldResult (Left . show) Right
|
|
. Trifecta.parseByteString (directive <* Trifecta.eof) mempty
|