diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for keel + +## 0.1.0.0 -- 2026-08-18 + +* First release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Zhe Zhang + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,32 @@ +# keel + +The umbrella over the keel capability packages +([keel-dyn](https://hackage.haskell.org/package/keel-dyn), +[keel-abi](https://hackage.haskell.org/package/keel-abi), +[keel-linalg](https://hackage.haskell.org/package/keel-linalg), +[keel-onnx](https://hackage.haskell.org/package/keel-onnx)): + +- `keel doctor` — reports exactly which native capabilities resolve on + this machine, which do not, and the one command that fixes each; +- `keel setup ` — checksum-pinned installation of the + native runtimes into the per-user keel directory; +- `Keel.Bridge` — the explicit frame ↔ buffer copy between + [dataframe](https://hackage.haskell.org/package/dataframe-core) + columns and the `Storable` buffers keel-linalg and keel-abi take. + Nulls are refused, not imputed. + +```text +$ keel doctor +[ok] keel-dyn pure Haskell over the OS loader; no native dependency +[ok] keel-abi frozen C ABI structs, hand-laid-out; no native dependency +[ok] keel-linalg OpenBLAS 0.3.30 ... +[ok] keel-onnx ONNX Runtime 1.24.4 ... +``` + +keel is deliberately NOT a dataframe, a schema layer, an estimator +protocol, or a numeric prelude. It is the Windows-first capability and +interop floor for doing data science in Haskell: load native +capability, exchange buffers with the ecosystem, verify the setup. + +Tutorials and the full design rationale live in the +[project repository](https://github.com/skymanbp/keel). diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,47 @@ +-- | The @keel@ executable: @keel doctor@ and @keel setup {blas,onnx}@. +module Main (main) where + +import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + +import Keel.Doctor +import Keel.Setup + +main :: IO () +main = do + args <- getArgs + case args of + [] -> runDoctor + ["doctor"] -> runDoctor + ["setup", "blas"] -> runSetup "OpenBLAS" setupBlas + ["setup", "onnx"] -> runSetup "ONNX Runtime" setupOnnx + _ -> do + hPutStrLn stderr "usage: keel [doctor | setup blas | setup onnx]" + exitFailure + +runDoctor :: IO () +runDoctor = do + reports <- diagnose + putStrLn "keel doctor\n" + putStr (renderReports reports) + if allAvailable reports + then putStrLn "\nall capabilities available" + else do + putStrLn "\nsome capabilities need attention (see fixes above)" + exitFailure + +runSetup :: String -> IO (Either SetupError FilePath) -> IO () +runSetup what act = do + putStrLn ("installing " <> what <> " (official archive, SHA-256 pinned) ...") + r <- act + case r of + Right dir -> do + putStrLn ("installed to " <> dir) + putStrLn "run 'keel doctor' to verify" + Left (UnsupportedPlatform _ guidance) -> do + hPutStrLn stderr ("not available for this platform: " <> guidance) + exitFailure + Left err -> do + hPutStrLn stderr ("setup failed: " <> show err) + exitFailure diff --git a/keel.cabal b/keel.cabal new file mode 100644 --- /dev/null +++ b/keel.cabal @@ -0,0 +1,88 @@ +cabal-version: 3.0 +name: keel +version: 0.1.0.0 +synopsis: Umbrella for the keel capability floor: doctor, setup +description: + The thin seam over the keel capability packages (keel-dyn, keel-abi, + keel-onnx, keel-linalg): + . + * @keel doctor@ — reports exactly which native capabilities resolve + on this machine, which do not, and the one command that fixes + each; + * @keel setup@ — checksum-pinned installation of native runtimes + into the per-user keel directory. + . + keel is deliberately NOT a dataframe, a schema layer, an estimator + protocol, or a numeric prelude — see the project README. +license: MIT +license-file: LICENSE +author: Zhe Zhang +maintainer: Zhe Zhang +category: Data Science +build-type: Simple +homepage: https://github.com/skymanbp/keel +bug-reports: https://github.com/skymanbp/keel/issues +extra-doc-files: + CHANGELOG.md + README.md +tested-with: GHC ==9.10.3 || ==9.12.4 || ==9.14.1 + +source-repository head + type: git + location: https://github.com/skymanbp/keel + +common warnings + ghc-options: -Wall + default-language: GHC2021 + +library + import: warnings + exposed-modules: + Keel.Bridge + Keel.Doctor + Keel.Setup + hs-source-dirs: src + build-depends: + SHA >=1.6 && <1.7, + base >=4.20 && <4.23, + bytestring >=0.11 && <0.13, + dataframe-core >=2.4 && <2.5, + directory >=1.3 && <1.4, + filepath >=1.4 && <1.6, + keel-abi >=0.1 && <0.2, + keel-dyn >=0.1 && <0.2, + keel-linalg >=0.1 && <0.2, + keel-onnx >=0.1 && <0.2, + process >=1.6 && <1.7, + text >=2.0 && <2.2, + vector >=0.13 && <0.14 + +executable keel + import: warnings + main-is: Main.hs + hs-source-dirs: app + ghc-options: -threaded + build-depends: + base, + keel + +test-suite keel-doctor-test + import: warnings + type: exitcode-stdio-1.0 + main-is: DoctorTest.hs + hs-source-dirs: test + build-depends: + base, + keel + +test-suite keel-bridge-test + import: warnings + type: exitcode-stdio-1.0 + main-is: BridgeTest.hs + hs-source-dirs: test + build-depends: + base, + dataframe-core, + keel, + text, + vector diff --git a/src/Keel/Bridge.hs b/src/Keel/Bridge.hs new file mode 100644 --- /dev/null +++ b/src/Keel/Bridge.hs @@ -0,0 +1,90 @@ +-- | The explicit frame ↔ buffer copy: dataframe 'Column's to +-- 'VS.Vector' buffers (ready for keel-linalg \/ keel-abi) and back. +-- +-- This module is keel's ONLY point of contact with the dataframe stack, +-- and it is honest about the cost: every conversion here is an O(n) +-- copy — dataframe's unboxed columns and Storable vectors are different +-- memory representations, exactly the trade numpy↔pandas makes. No API +-- here pretends a zero-copy path exists where the representation cannot +-- provide one. +-- +-- Nulls are refused, not imputed: a column with missing values raises +-- 'ColumnHasNulls' — fill or drop them with dataframe's own operations +-- first, where that decision belongs. +module Keel.Bridge + ( BridgeError (..) + , columnToStorable + , columnsToMatrix + , storableToColumn + ) where + +import Data.Text qualified as T +import Data.Vector qualified as V +import Data.Vector.Generic qualified as VG +import Data.Vector.Storable qualified as VS + +import DataFrame.Internal.Column + ( Column + , columnLength + , fromUnboxedVector + , numElements + , toUnboxedVector + ) +import DataFrame.Internal.DataFrame (DataFrame, getColumn) + +-- | Why a frame ↔ buffer conversion was refused. +data BridgeError + = ColumnNotFound T.Text + -- ^ No column of that name in the frame. + | ColumnHasNulls T.Text Int + -- ^ The column has this many missing values; handle them in + -- dataframe first (fill\/drop) — the bridge never imputes. + | ColumnTypeMismatch T.Text String + -- ^ The column does not hold @Double@s (upstream's own type error + -- is carried verbatim). + | ColumnLengthMismatch T.Text Int Int + -- ^ (column, expected rows, actual rows) while assembling a matrix. + -- Defensive: dataframe pads short columns with nulls on insert, so + -- columns from one frame are always equal-length (a padded column + -- trips 'ColumnHasNulls' first); this guards the invariant anyway. + deriving (Eq, Show) + +-- | O(n) copy of a @Double@ column out of a frame into a Storable +-- buffer. +columnToStorable :: DataFrame -> T.Text -> Either BridgeError (VS.Vector Double) +columnToStorable df name = do + col <- maybe (Left (ColumnNotFound name)) Right (getColumn name df) + let nulls = columnLength col - numElements col + if nulls > 0 + then Left (ColumnHasNulls name nulls) + else case toUnboxedVector col of + Left e -> Left (ColumnTypeMismatch name (show e)) + Right vu -> Right (VG.convert vu) + +-- | O(n·k) copy of @k@ same-length @Double@ columns into one row-major +-- @rows × k@ matrix (the layout every keel-linalg driver takes). +-- Returns the row count alongside the buffer. +columnsToMatrix :: DataFrame -> [T.Text] -> Either BridgeError (Int, VS.Vector Double) +columnsToMatrix df names = do + cols <- traverse (\n -> (,) n <$> columnToStorable df n) names + case cols of + [] -> Right (0, VS.empty) + (_, c0) : rest -> do + let m = VS.length c0 + mapM_ + ( \(n, c) -> + if VS.length c == m + then Right () + else Left (ColumnLengthMismatch n m (VS.length c)) + ) + rest + let k = length cols + -- boxed vector for O(1) column lookup per cell (a list here + -- makes the copy O(n·k²), belying the O(n·k) contract above) + vecs = V.fromList (map snd cols) + Right (m, VS.generate (m * k) (\i -> (vecs V.! (i `mod` k)) VS.! (i `div` k))) + +-- | O(n) copy of a Storable buffer back into a (null-free) dataframe +-- column, e.g. to insert a keel-linalg result as a new column. +storableToColumn :: VS.Vector Double -> Column +storableToColumn = fromUnboxedVector . VG.convert diff --git a/src/Keel/Doctor.hs b/src/Keel/Doctor.hs new file mode 100644 --- /dev/null +++ b/src/Keel/Doctor.hs @@ -0,0 +1,147 @@ +-- | @keel doctor@: probe every keel capability on this machine and say +-- exactly what resolved, what did not, and the one command that fixes +-- each gap. Pure diagnosis — nothing is downloaded or modified. +module Keel.Doctor + ( CapStatus (..) + , CapabilityReport (..) + , diagnose + , renderReports + , allAvailable + ) where + +import Keel.Dyn (capLibrary, libraryPath) +import Keel.Linalg + ( BackendError (..) + , backendConfig + , closeBackend + , openBackend + ) +import Keel.Onnx (OnnxError (..), loadOnnxRuntime, ortVersion) + +-- | Outcome of probing one capability. +data CapStatus + = Available + -- ^ Resolved and answered a version probe. + | Missing + -- ^ Nothing found by the search policy; installable. + | Broken + -- ^ Something was found but is unusable (wrong build, too old, + -- symbols absent). + deriving (Eq, Show) + +-- | One line of the doctor's report. +data CapabilityReport = CapabilityReport + { capName :: String + , capStatus :: CapStatus + , capDetail :: String + -- ^ Version\/config\/path on success; the reason otherwise. + , capFix :: Maybe String + -- ^ The one command that fixes it, when there is one. + } + deriving (Eq, Show) + +-- | Probe everything. Never throws; each probe folds its failure into +-- the report. +diagnose :: IO [CapabilityReport] +diagnose = + sequence + [ pure dynReport + , pure abiReport + , blasReport + , onnxReport + ] + +dynReport :: CapabilityReport +dynReport = + CapabilityReport + "keel-dyn" + Available + "pure Haskell over the OS loader; no native dependency" + Nothing + +abiReport :: CapabilityReport +abiReport = + CapabilityReport + "keel-abi" + Available + "frozen C ABI structs, hand-laid-out; no native dependency" + Nothing + +blasFix :: Maybe String +blasFix = Just "keel setup blas (or point KEEL_OPENBLAS at a stock LP64 libopenblas)" + +blasReport :: IO CapabilityReport +blasReport = do + r <- openBackend + case r of + Right be -> do + let detail = backendConfig be <> " @ " <> libraryPath (capLibrary be) + closeBackend be + pure (CapabilityReport "keel-linalg (OpenBLAS)" Available detail Nothing) + Left err -> + pure $ case err of + BackendNotFound _ -> + CapabilityReport "keel-linalg (OpenBLAS)" Missing + "no OpenBLAS found via KEEL_OPENBLAS, the keel data dir, or the system search path" + blasFix + BackendNotOpenBLAS p -> + CapabilityReport "keel-linalg (OpenBLAS)" Broken + ("library at " <> p <> " exports no openblas_get_config; only OpenBLAS is supported") + blasFix + BackendILP64 cfg -> + CapabilityReport "keel-linalg (OpenBLAS)" Broken + ("ILP64 build refused (would corrupt silently): " <> cfg) + blasFix + BackendMissingSymbol e -> + CapabilityReport "keel-linalg (OpenBLAS)" Broken + ("required symbol absent (symbol-renamed or LAPACKE-less build): " <> show e) + blasFix + +onnxFix :: Maybe String +onnxFix = Just "keel setup onnx (or point KEEL_ONNXRUNTIME at the official onnxruntime library)" + +onnxReport :: IO CapabilityReport +onnxReport = do + r <- loadOnnxRuntime + case r of + -- deliberately not closed: onnxruntime owns thread pools and + -- unloading at process end is the safe path + Right ort -> + pure + ( CapabilityReport "keel-onnx (ONNX Runtime)" Available + ("ONNX Runtime " <> ortVersion ort <> " @ " <> libraryPath (capLibrary ort)) + Nothing + ) + Left err -> + pure $ case err of + OnnxRuntimeNotFound _ -> + CapabilityReport "keel-onnx (ONNX Runtime)" Missing + "no ONNX Runtime found via KEEL_ONNXRUNTIME, the keel data dir, or the system search path" + onnxFix + OnnxApiUnsupported v -> + CapabilityReport "keel-onnx (ONNX Runtime)" Broken + ("a runtime was found but is older than C API version " <> show v + <> " (a stray old onnxruntime on PATH shadows the good one)") + onnxFix + other -> + CapabilityReport "keel-onnx (ONNX Runtime)" Broken (show other) onnxFix + +-- | @True@ when every probed capability is 'Available'. +allAvailable :: [CapabilityReport] -> Bool +allAvailable = all ((== Available) . capStatus) + +-- | Plain-text rendering, one capability per block. +renderReports :: [CapabilityReport] -> String +renderReports reports = unlines (concatMap block reports) + where + block r = + (tag (capStatus r) <> " " <> pad (capName r) <> " " <> capDetail r) + : case (capStatus r, capFix r) of + (Available, _) -> [] + (_, Just fix) -> [" fix: " <> fix] + _ -> [] + tag Available = "[ok] " + tag Missing = "[MISSING]" + tag Broken = "[BROKEN] " + width = maximum (map (length . capName) reports) + pad s = s <> replicate (width - length s) ' ' diff --git a/src/Keel/Setup.hs b/src/Keel/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Keel/Setup.hs @@ -0,0 +1,179 @@ +-- | @keel setup@: install pinned native runtimes into the per-user +-- keel directory ("Keel.Dyn.Locate"'s second search stage). +-- +-- Every artifact is an /official upstream release archive/, pinned by +-- URL and SHA-256 (values computed from the downloaded archives, +-- 2026-08-18). The tools used are deliberately boring: the system's +-- @curl@ and @tar@ (Windows 10+ ships both; the System32 bsdtar also +-- unpacks zip), plus a pure-Haskell SHA-256 — keel's zero-native-deps +-- rule applies to keel itself. +-- +-- Offline\/air-gapped environments skip @keel setup@ entirely: point +-- @KEEL_OPENBLAS@ \/ @KEEL_ONNXRUNTIME@ at an existing library, or drop +-- one into the keel data dir yourself. +module Keel.Setup + ( SetupError (..) + , setupBlas + , setupOnnx + ) where + +import Control.Exception (Exception) +import Control.Monad (filterM, forM_, when) +import Data.ByteString.Lazy qualified as BL +import Data.Digest.Pure.SHA (sha256, showDigest) +import System.Directory + ( copyFile + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getTemporaryDirectory + , listDirectory + , removeDirectoryRecursive + , removeFile + ) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (dropExtension, takeFileName, ()) +import System.Info (arch, os) +import System.Process (proc, readCreateProcessWithExitCode) + +import Keel.Dyn.Locate (keelNativeDir) + +-- | Why an installation could not happen. +data SetupError + = UnsupportedPlatform String String + -- ^ (capability, guidance) — no pinned artifact for this OS\/arch; + -- the guidance says what to do instead. + | DownloadFailed String String + -- ^ (url, tool output). + | ChecksumMismatch String String String + -- ^ (url, expected, got) — the archive is deleted before this is + -- thrown. + | ExtractFailed String String + -- ^ (archive, tool output). + deriving (Eq, Show) + +instance Exception SetupError + +data Artifact = Artifact + { artCapability :: String + -- ^ keel data-dir name ('keelNativeDir' argument). + , artUrl :: String + , artSha256 :: String + -- ^ Lowercase hex, pinned. + , artLibSubdir :: FilePath + -- ^ Directory inside the archive whose files become the payload. + , artAttribution :: String + -- ^ Upstream project + license, recorded next to the payload. + } + +-- | Install OpenBLAS (LP64) for keel-linalg. Pinned artifact exists for +-- Windows x86_64 (upstream publishes binaries only there); on other +-- platforms the package manager is the right tool and 'setupBlas' +-- returns the exact command as 'UnsupportedPlatform' guidance. +setupBlas :: IO (Either SetupError FilePath) +setupBlas = case (os, arch) of + ("mingw32", "x86_64") -> + install + Artifact + { artCapability = "openblas" + , artUrl = "https://github.com/OpenMathLib/OpenBLAS/releases/download/v0.3.30/OpenBLAS-0.3.30-x64.zip" + , artSha256 = "8b04387766efc05c627e26d24797ec0d4ed4c105ec14fa7400aa84a02db22b66" + , artLibSubdir = "bin" + , artAttribution = + "libopenblas.dll from OpenBLAS 0.3.30 (BSD-3-Clause), official release archive:\n\ + \https://github.com/OpenMathLib/OpenBLAS/releases/tag/v0.3.30\n" + } + ("linux", _) -> + pure (Left (UnsupportedPlatform "openblas" + "upstream publishes no Linux binaries; run: sudo apt-get install libopenblas0 (or your distro's equivalent)")) + ("darwin", _) -> + pure (Left (UnsupportedPlatform "openblas" + "upstream publishes no macOS binaries; run: brew install openblas, then set KEEL_OPENBLAS=$(brew --prefix openblas)/lib/libopenblas.dylib")) + _ -> + pure (Left (UnsupportedPlatform "openblas" (os <> "/" <> arch <> " has no pinned artifact"))) + +-- | Install ONNX Runtime for keel-onnx from the official (MIT) release +-- archives: win-x64, linux-x64 and osx-arm64 are pinned. +setupOnnx :: IO (Either SetupError FilePath) +setupOnnx = case (os, arch) of + ("mingw32", "x86_64") -> + install (onnxArtifact "onnxruntime-win-x64-1.24.4.zip" + "d2319fddfb6ea4db99ccc4b60c85c517bcd855721f5daa6a06d40d7cb2ee2357") + ("linux", "x86_64") -> + install (onnxArtifact "onnxruntime-linux-x64-1.24.4.tgz" + "3a211fbea252c1e66290658f1b735b772056149f28321e71c308942cdb54b747") + ("darwin", "aarch64") -> + install (onnxArtifact "onnxruntime-osx-arm64-1.24.4.tgz" + "93787795f47e1eee369182e43ed51b9e5da0878ab0346aecf4258979b8bba989") + _ -> + pure (Left (UnsupportedPlatform "onnxruntime" + (os <> "/" <> arch <> " has no pinned artifact; official archives cover win-x64, linux-x64, osx-arm64"))) + where + onnxArtifact file sha = + Artifact + { artCapability = "onnxruntime" + , artUrl = "https://github.com/microsoft/onnxruntime/releases/download/v1.24.4/" <> file + , artSha256 = sha + , -- archives unpack as /lib/... + artLibSubdir = dropExtension file "lib" + , artAttribution = + "ONNX Runtime 1.24.4 (MIT), official release archive:\n\ + \https://github.com/microsoft/onnxruntime/releases/tag/v1.24.4\n" + } + +-- --------------------------------------------------------------------- + +install :: Artifact -> IO (Either SetupError FilePath) +install art = do + destDir <- keelNativeDir (artCapability art) + createDirectoryIfMissing True destDir + tmp <- getTemporaryDirectory + let archPath = tmp takeFileName (artUrl art) + exDir = tmp (artCapability art <> "-keel-extract") + + (dlCode, _, dlErr) <- + readCreateProcessWithExitCode (proc "curl" ["-fsSL", "-o", archPath, artUrl art]) "" + case dlCode of + ExitFailure _ -> pure (Left (DownloadFailed (artUrl art) dlErr)) + ExitSuccess -> do + got <- showDigest . sha256 <$> BL.readFile archPath + if got /= artSha256 art + then do + removeFile archPath + pure (Left (ChecksumMismatch (artUrl art) (artSha256 art) got)) + else do + exExists <- doesDirectoryExist exDir + when exExists (removeDirectoryRecursive exDir) + createDirectoryIfMissing True exDir + t <- tarExe + (exCode, _, exErr) <- + readCreateProcessWithExitCode (proc t ["-xf", archPath, "-C", exDir]) "" + case exCode of + ExitFailure _ -> do + removeFile archPath + pure (Left (ExtractFailed archPath exErr)) + ExitSuccess -> do + let srcLib = exDir artLibSubdir art + entries <- listDirectory srcLib + files <- filterM (doesFileExist . (srcLib )) entries + if null files + then do + removeFile archPath + removeDirectoryRecursive exDir + pure (Left (ExtractFailed archPath ("no payload files under " <> artLibSubdir art))) + else do + forM_ files $ \f -> copyFile (srcLib f) (destDir f) + writeFile (destDir "ATTRIBUTION.txt") (artAttribution art) + removeFile archPath + removeDirectoryRecursive exDir + pure (Right destDir) + +-- On Windows, PATH often puts GNU tar (MSYS/Git) first, which cannot +-- unpack zip; the System32 bsdtar can, so use it by absolute path. +tarExe :: IO FilePath +tarExe = case os of + "mingw32" -> do + root <- lookupEnv "SystemRoot" + pure (maybe "tar" (\r -> r "System32" "tar.exe") root) + _ -> pure "tar" diff --git a/test/BridgeTest.hs b/test/BridgeTest.hs new file mode 100644 --- /dev/null +++ b/test/BridgeTest.hs @@ -0,0 +1,90 @@ +-- | Bridge invariants: the copy round-trips exactly, every refusal path +-- (missing column, wrong type, nulls, ragged lengths) fires, and the +-- matrix layout is row-major as keel-linalg expects. +module Main (main) where + +import Control.Monad (unless) +import Data.Text qualified as T +import Data.Vector.Storable qualified as VS + +import DataFrame.Internal.Column (Column, columnLength, fromList, fromUnboxedVector, numElements) +import DataFrame.Internal.DataFrame (DataFrame, fromNamedColumns) +import Data.Vector.Unboxed qualified as VU +import Keel.Bridge + +expect :: Bool -> String -> IO () +expect ok msg = unless ok (fail msg) + +col :: [Double] -> Column +col = fromUnboxedVector . VU.fromList + +frame :: DataFrame +frame = + fromNamedColumns + [ (T.pack "x", col [1, 2, 3]) + , (T.pack "y", col [4, 5, 6]) + , (T.pack "short", col [7, 8]) + , (T.pack "ints", fromList [1 :: Int, 2, 3]) + , (T.pack "holey", fromList [Just (1 :: Double), Nothing, Just 3]) + ] + +main :: IO () +main = do + -- sanity: the Maybe column really carries a null per dataframe itself + let holey = fromList [Just (1 :: Double), Nothing, Just 3] + expect (columnLength holey == 3 && numElements holey == 2) + ("null column not represented as expected: length " + <> show (columnLength holey) <> ", elements " <> show (numElements holey)) + + -- round-trip: frame -> buffer -> column -> buffer, exact + x <- either (fail . show) pure (columnToStorable frame (T.pack "x")) + expect (VS.toList x == [1, 2, 3]) ("columnToStorable: " <> show (VS.toList x)) + let back = storableToColumn x + reframe = fromNamedColumns [(T.pack "x2", back)] + x2 <- either (fail . show) pure (columnToStorable reframe (T.pack "x2")) + expect (VS.toList x2 == [1, 2, 3]) ("round-trip: " <> show (VS.toList x2)) + + -- refusals (ColumnLengthMismatch is unreachable through a real frame: + -- dataframe pads short columns with nulls on insert, so the "short" + -- column must surface as ColumnHasNulls instead — assert exactly that) + expect (isLeft (columnToStorable frame (T.pack "nope")) ColumnNotFound') + "missing column not refused" + expect (isLeft (columnToStorable frame (T.pack "ints")) ColumnTypeMismatch') + "Int column not refused for Double extraction" + expect (isLeft (columnToStorable frame (T.pack "holey")) ColumnHasNulls') + "null-bearing column not refused" + expect (isLeft (columnsToMatrix frame [T.pack "x", T.pack "short"]) ColumnHasNulls') + "frame-padded short column not refused as null-bearing" + + -- row-major layout: [x | y] as 3x2 must interleave rows + (m, mat) <- either (fail . show) pure (columnsToMatrix frame [T.pack "x", T.pack "y"]) + expect (m == 3) ("matrix rows: " <> show m) + expect (VS.toList mat == [1, 4, 2, 5, 3, 6]) + ("row-major layout: " <> show (VS.toList mat)) + + -- wide frame: k=100 columns of 5 rows, cell (i,j) holds 100*i + j, + -- which in row-major layout equals its own flat index — checks the + -- per-cell column lookup and the layout at width in one identity + let wideCols = + [ (T.pack ("c" <> show j), col [fromIntegral (100 * i + j) | i <- [0 .. 4 :: Int]]) + | j <- [0 .. 99 :: Int] + ] + (wm, wmat) <- either (fail . show) pure (columnsToMatrix (fromNamedColumns wideCols) (map fst wideCols)) + expect (wm == 5) ("wide matrix rows: " <> show wm) + expect (VS.length wmat == 500) ("wide matrix size: " <> show (VS.length wmat)) + expect (wmat == VS.generate 500 fromIntegral) + "wide matrix cells differ from their flat index" + + putStrLn "keel-bridge-test: round-trip, refusals and layout all verified" + +-- lightweight constructor tags for refusal checks +data ErrTag = ColumnNotFound' | ColumnHasNulls' | ColumnTypeMismatch' | ColumnLengthMismatch' + +isLeft :: Either BridgeError a -> ErrTag -> Bool +isLeft (Left e) tag = case (e, tag) of + (ColumnNotFound _, ColumnNotFound') -> True + (ColumnHasNulls _ _, ColumnHasNulls') -> True + (ColumnTypeMismatch _ _, ColumnTypeMismatch') -> True + (ColumnLengthMismatch {}, ColumnLengthMismatch') -> True + _ -> False +isLeft (Right _) _ = False diff --git a/test/DoctorTest.hs b/test/DoctorTest.hs new file mode 100644 --- /dev/null +++ b/test/DoctorTest.hs @@ -0,0 +1,35 @@ +-- | Doctor sanity: the diagnosis runs to completion on any machine, +-- the two pure capabilities always report Available, and the renderer +-- produces a line (plus fix line where applicable) per capability. +-- Whether BLAS/ONNX are Available depends on the machine, so those +-- statuses are only checked for consistency, not for a fixed value. +module Main (main) where + +import Control.Monad (forM_, unless) + +import Keel.Doctor + +expect :: Bool -> String -> IO () +expect ok msg = unless ok (fail msg) + +main :: IO () +main = do + reports <- diagnose + expect (length reports == 4) ("expected 4 capability reports, got " <> show (length reports)) + + let byName n = filter ((== n) . capName) reports + expect (map capStatus (byName "keel-dyn") == [Available]) "keel-dyn not Available" + expect (map capStatus (byName "keel-abi") == [Available]) "keel-abi not Available" + + forM_ reports $ \r -> do + expect (not (null (capDetail r))) (capName r <> ": empty detail") + case capStatus r of + Available -> pure () + _ -> expect (capFix r /= Nothing) (capName r <> ": non-available without a fix") + + let rendered = renderReports reports + expect (length (lines rendered) >= 4) "renderer lost capability lines" + putStrLn rendered + putStrLn ("keel-doctor-test: diagnosis completed (" + <> show (length (filter ((== Available) . capStatus) reports)) + <> "/4 available on this machine)")