rtk-0.11: test/TestSupport.hs

-- | Helpers shared by the unit and golden test suites: the in-process
-- generation pipeline (the same stages app/main.hs runs) and locale-independent
-- file IO for grammar sources and generated artifacts.
module TestSupport
    ( parseGrammarSource
    , parseGrammarSourceGenerated
    , normalizeGrammarSource
    , normalizeParsedGrammar
    , artifactsFor
    , frontEndDivergentGrammars
    , grammarsDir
    , discoverGrammarFiles
    , readFileUtf8
    , writeFileUtf8
    ) where

import Control.Exception (evaluate)
import Data.List (sort)
import System.Directory (listDirectory)
import System.FilePath ((</>), takeExtension)
import System.IO

import ASTAdapter (parseWithGenerated)
import Diagnostics (Diagnostic)
import GenQ (genQ)
import GenX (genX)
import GenY (genY)
import Lexer (scanTokens)
import Normalize (fillConstructorNames, normalizeTopLevelClauses)
import Parser (parse)
import StringLiterals (normalizeStringLiterals)
import Syntax
import TokenProcessing (processTokens)

-- | Lexing, token post-processing and parsing of a grammar specification.
parseGrammarSource :: String -> Either Diagnostic InitialGrammar
parseGrammarSource src = scanTokens src >>= (parse . processTokens)

-- | The self-hosted front end: the same job as 'parseGrammarSource', done by
-- the lexer/parser RTK generated from grammar.pg plus the AST adapter.
parseGrammarSourceGenerated :: String -> Either Diagnostic InitialGrammar
parseGrammarSourceGenerated = parseWithGenerated

-- | The shared back half of the front-end pipeline: normalization of an
-- already-parsed grammar down to what the code generators consume.
normalizeParsedGrammar :: InitialGrammar -> Either Diagnostic NormalGrammar
normalizeParsedGrammar ig = do
    ng <- normalizeTopLevelClauses (normalizeStringLiterals ig)
    return (fillConstructorNames ng)

-- | The full front-end pipeline, producing the normalized grammar that the
-- code generators consume.
normalizeGrammarSource :: String -> Either Diagnostic NormalGrammar
normalizeGrammarSource src = parseGrammarSource src >>= normalizeParsedGrammar

-- | The three files rtk writes for a grammar, as (file name, content) pairs.
artifactsFor :: NormalGrammar -> Either Diagnostic [(FilePath, String)]
artifactsFor g = do
    x <- genX g
    y <- genY g
    q <- genQ g
    return [ (name ++ "Lexer.x",  x)
           , (name ++ "Parser.y", y)
           , (name ++ "QQ.hs",    q)
           ]
    where name = getNGrammarName g

-- | Grammars whose hand-written-front-end parse the generated front end
-- provably cannot reproduce, with the reason.
--
-- EMPTY since the generated front end became the default: the two historic
-- divergences were resolved by making the reference parser define the same
-- language as grammar.pg (empty alternatives are rejected, redundant
-- parentheses are lifted exactly like grammar.pg's @Clause5 = '(' ,Clause ')'@
-- does) and by rewriting haskell.pg's @Gd = | ExpI ;@ as @Gd = ExpI? ;@. Every
-- grammar in the corpus now passes the strict dual-front-end equivalence.
--
-- Should a new divergence ever have to be tolerated temporarily, pin the
-- grammar here: the golden suite then checks it with the reference front end
-- only, and both suites fail as soon as the grammar stops diverging so the
-- pin gets dropped again.
frontEndDivergentGrammars :: [(String, String)]
frontEndDivergentGrammars = []

grammarsDir :: FilePath
grammarsDir = "test-grammars"

-- | All grammar specifications directly under the given directory, sorted.
discoverGrammarFiles :: FilePath -> IO [FilePath]
discoverGrammarFiles dir = do
    entries <- listDirectory dir
    return [ dir </> e | e <- sort entries, takeExtension e == ".pg" ]

-- Grammar files and generated artifacts are UTF-8. Use an explicit encoding
-- and newline mode so the tests do not depend on the ambient locale.
readFileUtf8 :: FilePath -> IO String
readFileUtf8 path = do
    h <- openFile path ReadMode
    hSetEncoding h utf8
    hSetNewlineMode h noNewlineTranslation
    contents <- hGetContents h
    _ <- evaluate (length contents)
    hClose h
    return contents

writeFileUtf8 :: FilePath -> String -> IO ()
writeFileUtf8 path contents = withFile path WriteMode $ \h -> do
    hSetEncoding h utf8
    hSetNewlineMode h noNewlineTranslation
    hPutStr h contents