quebex

  1-- SPDX-FileCopyrightText: 2026 Sören Tempel <soeren+git@soeren-tempel.net>
  2--
  3-- SPDX-License-Identifier: GPL-3.0-only
  4
  5module Data.KTest
  6  ( KTest (..),
  7    KTestObj (..),
  8    fromAssign,
  9  )
 10where
 11
 12import Control.Monad (forM_, void, when)
 13import Data.Binary (Binary (get, put))
 14import Data.Binary.Get (getLazyByteString, getWord32be)
 15import Data.Binary.Put (putLazyByteString, putWord32be)
 16import Data.ByteString.Lazy qualified as BL
 17import Data.Map qualified as Map
 18import Data.String (fromString)
 19import Data.Word (Word32)
 20import Language.QBE.Backend.Store (Assign)
 21import Language.QBE.Simulator.Default.Expression qualified as DE
 22import Language.QBE.Simulator.Memory (toBytes)
 23
 24newtype KTestString
 25  = KTestString BL.ByteString
 26  deriving (Show, Eq)
 27
 28instance Binary KTestString where
 29  put (KTestString bs) =
 30    putWord32be (fromIntegral $ BL.length bs) >> putLazyByteString bs
 31
 32  get = do
 33    len <- getWord32be
 34    str <- getLazyByteString (fromIntegral len)
 35    pure $ KTestString str
 36
 37------------------------------------------------------------------------
 38
 39data KTestObj
 40  = KTestObj
 41  { objName :: BL.ByteString,
 42    objBytes :: BL.ByteString
 43  }
 44  deriving (Show, Eq)
 45
 46instance Binary KTestObj where
 47  put (KTestObj name bytes) = do
 48    put (KTestString name)
 49    put (KTestString bytes)
 50
 51  get = do
 52    (KTestString name) <- get
 53    (KTestString bytes) <- get
 54    pure $ KTestObj name bytes
 55
 56fromAssign :: Assign -> [KTestObj]
 57fromAssign assign = map go $ Map.toList assign
 58  where
 59    go :: (String, DE.RegVal) -> KTestObj
 60    go (name, value) =
 61      KTestObj (fromString name) (BL.pack $ toBytes value)
 62
 63------------------------------------------------------------------------
 64
 65data KTest
 66  = KTest
 67  { ktArgs :: [BL.ByteString],
 68    ktObjs :: [KTestObj]
 69  }
 70  deriving (Show, Eq)
 71
 72header :: BL.ByteString
 73header = fromString "KTEST"
 74
 75legacyHeader :: BL.ByteString
 76legacyHeader = fromString "BOUT\n"
 77
 78version :: Word32
 79version = 3
 80
 81instance Binary KTest where
 82  get = do
 83    hdr <- getLazyByteString (BL.length header)
 84    when (hdr /= header && hdr /= legacyHeader) $
 85      fail "invalid ktest header"
 86    ver <- getWord32be
 87    when (ver > version) $
 88      fail "unsupported ktest version"
 89
 90    numArgs <- getWord32be
 91    strs <-
 92      mapM
 93        ( \_ -> do
 94            (KTestString s) <- get
 95            pure s
 96        )
 97        [1 .. numArgs]
 98
 99    when (ver >= 2) $
100      -- XXX: Skip symArgvs and symArgvLen for now.
101      void (getWord32be >> getWord32be)
102
103    numObjs <- getWord32be
104    objs <- mapM (const get) [1 .. numObjs]
105
106    pure $ KTest strs objs
107
108  put (KTest args objs) = do
109    putLazyByteString header
110    putWord32be version
111
112    putWord32be (fromIntegral $ length args)
113    forM_ args (put . KTestString)
114
115    -- XXX: Skip symArgvs and symArgvLen for now.
116    putWord32be 0
117    putWord32be 0
118
119    putWord32be (fromIntegral $ length objs)
120    forM_ objs put