tricu

PortableTestCompiler.hs (3340B)

---

 -- Small test-only adapter for retained compiler fixtures. Not a module resolver:
 -- imports select published fixture interfaces, and the caller selects definitions
 -- to inspect/pack. No recursive source loading, injected kernels or fallback.
 module PortableTestCompiler (compileFixtureDefinitions, compileFixtureFile) where
 
 import Runtime
 import ReferenceFixtures (compiledLibraries, fixtureExports)
 import SupportFixture (readTestSource)
 import Control.Exception (evaluate)
 import Control.Monad (foldM)
 import Data.List (isPrefixOf)
 import qualified Data.Map as Map
 import System.Timeout (timeout)
 import Text.Read (readMaybe)
 
 -- Preserve lazy definition values (including unused divergent bodies). Only the
 -- Result/list/name spine is validated, under a fixed preparation deadline.
 compileFixtureDefinitions :: Env -> String -> IO Env
 compileFixtureDefinitions external source = do
   prepared <- timeout (30 * 1000000) $ do
     let bindings = ofList [Fork (ofString name) value | (name, value) <- Map.toList external]
         answer = foldl apply (fixtureExports "source.unit" Map.! "compileStableModuleDefinitions")
           [bindings, ofString source]
         decode Leaf env = pure env
         decode (Fork (Fork name value) rest) env = do
           key <- either (fail . ("invalid compiled name: " ++)) pure (toString name)
           if Map.member key env
             then fail ("duplicate compiled definition: " ++ key)
             else decode rest (Map.insert key value env)
         decode _ _ = fail "malformed compiled definition list"
     case answer of
       Fork (Stem Leaf) (Fork definitions Leaf) -> decode definitions Map.empty >>= evaluate
       other -> fail ("portable test compilation failed: " ++ show other)
   maybe (fail "portable test compilation exceeded 30 seconds") pure prepared
 
 compileFixtureFile :: FilePath -> IO Env
 compileFixtureFile path = do
   source <- readTestSource path
   let rows = map words (lines source)
       legacyFor alias = case [legacy | (legacy, mapped, _) <- fst compiledLibraries, mapped == alias] of
         [legacy] -> pure legacy
         _ -> fail ("unknown fixture import: " ++ alias)
       select legacy namespace =
         let exports = fixtureExports legacy
         in pure $ maybe exports (\prefix -> Map.mapKeys ((prefix ++ ".") ++) exports) namespace
       imported row = case row of
         ["!import", encoded, namespace] | Just legacy <- readMaybe encoded ->
           select legacy (if namespace == "!Local" then Nothing else Just namespace)
         ["!import", alias, "*"] -> legacyFor alias >>= \legacy -> select legacy Nothing
         ["!import", alias, "as", namespace] -> legacyFor alias >>= \legacy -> select legacy (Just namespace)
         ["!import", alias] -> legacyFor alias >>= \legacy -> select legacy (Just alias)
         _ -> fail ("unsupported fixture test import: " ++ unwords row)
       merge env row = do
         next <- imported row
         if Map.null (Map.intersection env next)
           then pure (Map.union env next)
           else fail "overlapping fixture test imports"
       body = unlines [line | line <- lines source,
                        not (any (`isPrefixOf` line) ["!import ", "!export ", "!source "])]
   external <- foldM merge Map.empty [row | row@(first : _) <- rows, first == "!import"]
   compileFixtureDefinitions external body