mirror of
https://github.com/zap-proto/haskell.git
synced 2026-10-30 15:05:00 +00:00
Ian Denhardt
8bde687070
This never made it into a release, but I realized it was here and it's been on my TODO list. Release is immanent, so it's time. This was introduced when I moved the invoicing to happen on pointer dereference, rather than on word read. But we still need to make sure we don't endlessly follow far pointers. Per the comment, we should just not do this by naively recursing. One of the tests needed updating due to the increased invoicing.
95 lines
3.5 KiB
Haskell
95 lines
3.5 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
-- | This module defines a test that tries to walk over the
|
|
-- CodeGeneratorRequest in `tests/data/schema-codegenreq`,
|
|
-- failing if any of the data is not as expected.
|
|
module WalkSchemaCodeGenRequest
|
|
(walkSchemaCodeGenRequestTest)
|
|
where
|
|
|
|
import Prelude hiding (length)
|
|
|
|
import Test.Hspec
|
|
|
|
import Control.Monad (when)
|
|
import Control.Monad.Trans.Class (lift)
|
|
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.Vector as V
|
|
|
|
import Capnp.Untyped hiding (index, length)
|
|
|
|
import Capnp.Basics (index, length, textBytes)
|
|
import Capnp.Classes (fromStruct)
|
|
import Capnp.TraversalLimit (LimitT, execLimitT)
|
|
|
|
import qualified Capnp.Gen.Capnp.Schema as Schema
|
|
import qualified Capnp.Message as M
|
|
|
|
nodeNames :: V.Vector BS.ByteString
|
|
nodeNames = V.fromList
|
|
[ "Import"
|
|
, "annotation"
|
|
, "Value"
|
|
, "Type"
|
|
]
|
|
|
|
-- TODO: This contains a bit of copypasta from some of the untyped tests; should
|
|
-- factor that out.
|
|
walkSchemaCodeGenRequestTest :: Spec
|
|
walkSchemaCodeGenRequestTest =
|
|
describe "Various sanity checks on a known schema CodeGeneratorRequest" $
|
|
it "Should match misc. expectations" $ do
|
|
-- TODO: the above description betrays that this test isn't
|
|
-- especially well defined at a granularity that I(zenhack)
|
|
-- know how to tell hspec about, because there are data
|
|
-- dependencies between conceptual tests (we walk over the
|
|
-- data checking various things as we go).
|
|
--
|
|
-- It would be nice if we could mark off individual checks for
|
|
-- hspec's reporting somehow.
|
|
bytes <- BS.readFile "tests/data/schema-codegenreq"
|
|
msg <- M.decode bytes
|
|
endQuota <- execLimitT 4096 (rootPtr msg >>= reader)
|
|
endQuota `shouldBe` 3372
|
|
where
|
|
reader :: Struct 'M.Const -> LimitT IO ()
|
|
reader root = do
|
|
req :: Schema.CodeGeneratorRequest 'M.Const <- fromStruct root
|
|
nodes <- Schema.get_CodeGeneratorRequest'nodes req
|
|
requestedFiles <- Schema.get_CodeGeneratorRequest'requestedFiles req
|
|
lift $ length nodes `shouldBe` 37
|
|
lift $ length requestedFiles `shouldBe` 1
|
|
mapM_ (walkNode nodes) [0,1..36]
|
|
walkNode nodes i = do
|
|
node <- index i nodes
|
|
-- None of the nodes in the schema have parameters:
|
|
False <- Schema.has_Node'parameters node
|
|
-- And none of them are generic:
|
|
False <- Schema.get_Node'isGeneric node
|
|
|
|
nameList <- Schema.get_Node'displayName node
|
|
name <- textBytes nameList
|
|
prefixLen <- Schema.get_Node'displayNamePrefixLength node
|
|
let baseName = BS.drop (fromIntegral prefixLen) name
|
|
|
|
when (i < V.length nodeNames && baseName /= (nodeNames V.! i)) $
|
|
error "Incorrect name."
|
|
|
|
has <- Schema.has_Node'annotations node
|
|
|
|
-- there are two annotations in all of the nodes, at these indicies:
|
|
case (has, i `elem` [4, 9]) of
|
|
(False, False) -> return ()
|
|
(True, True) -> do
|
|
1 <- length <$> Schema.get_Node'annotations node
|
|
return ()
|
|
(False, True) ->
|
|
error $ "Node at index " ++ show i ++ " should have had" ++
|
|
"an annotation."
|
|
(True, False) ->
|
|
error $ "Node at index " ++ show i ++ " should not " ++
|
|
"have had an annotation."
|