Basel Haskell Compiler

{-# LANGUAGE BHC.StructuredConcurrency #-}
module Server where

-- | Production-grade request handler using BHC's server profile.
-- Structured concurrency ensures all spawned tasks are properly
-- cancelled if the parent scope exits (timeout, error, or completion).

import Control.Concurrent.Scoped
import Control.Concurrent.Deadline
import Control.Concurrent.Trace (withSpan)

-- | Handle an API request with automatic resource management.
-- The Scoped monad tracks all async operations; nothing leaks.
handler :: Request -> Scoped Response
handler req = withSpan "handleRequest" $ do
    -- 5 second timeout for the entire operation.
    -- If exceeded, all child tasks are cancelled automatically.
    withTimeout 5000 $ do
        -- Spawn concurrent database queries within this scope.
        -- These run in parallel, not sequentially.
        userData  <- async $ fetchUser req.userId
        orderData <- async $ fetchOrders req.userId
        inventory <- async $ checkInventory req.items

        -- Await all results. If any task fails or times out,
        -- the others are cancelled and resources are cleaned up.
        user   <- await userData
        orders <- await orderData
        stock  <- await inventory

        -- Observability: spans are auto-nested, traces exported.
        return $ Response user orders stock

{-# LANGUAGE BHC.TensorIR #-}
{-# LANGUAGE BHC.StrictDefault #-}
module Compute where

-- | High-performance matrix operations using BHC's tensor IR.
-- BHC.StrictDefault eliminates thunk buildup in numeric code.
-- BHC.TensorIR enables shape-aware fusion and SIMD lowering.

import BHC.Tensor (Tensor, Matrix)
import qualified BHC.Tensor as T

-- | Matrix multiplication with automatic vectorization.
-- The compiler tracks dimensions and selects optimal block sizes.
matmul :: Matrix Float -> Matrix Float -> Matrix Float
matmul a b = T.contract a b [1] [0]

-- | L2 normalization with guaranteed single-pass fusion.
-- This compiles to: sqrt(sum(x*x)), then x/norm in one loop.
-- No intermediate tensor is allocated for (t * t).
normalize :: Tensor Float -> Tensor Float
normalize t = t / T.sqrt (T.sum (t * t))

-- | Neural network forward pass fragment.
-- The entire pipeline fuses: matmul -> normalize -> sum
-- becomes a single cache-efficient traversal with SIMD.
forward :: Matrix Float -> Matrix Float -> Float
forward input weights = T.sum (normalize (matmul input weights))

-- | Softmax with numeric stability (subtract max first).
-- Three logical passes fuse into two actual traversals.
softmax :: Tensor Float -> Tensor Float
softmax v = T.map (/ total) exps
  where
    maxVal = T.maximum v
    exps   = T.map (\x -> exp (x - maxVal)) v
    total  = T.sum exps

module Lambda where

-- | Serverless function compiled for WebAssembly deployment.
-- The edge profile minimizes runtime size and memory usage,
-- producing small binaries suitable for CDN edge workers.

import Data.List (foldl')

-- | Export function for the WASM host environment to call.
-- This is the entry point invoked by Cloudflare Workers,
-- Fastly Compute, or any WASI-compatible runtime.
foreign export ccall processRequest :: Int -> Int

-- | Main request handler. Pure computation with no IO,
-- allowing aggressive optimization and dead code elimination.
processRequest :: Int -> Int
processRequest n
    | n <= 0    = 0
    | otherwise = fibonacci n + sumRange n

-- | Fibonacci sequence, optimized for small code size.
-- The edge profile favors compact output over raw speed.
fibonacci :: Int -> Int
fibonacci n
    | n <= 1    = n
    | otherwise = fibonacci (n - 1) + fibonacci (n - 2)

-- | Sum integers from 1 to n using strict fold.
-- Minimal allocation: runs in constant stack space.
sumRange :: Int -> Int
sumRange n = foldl' (+) 0 [1..n]

-- | Helper for JSON-like output (no dependencies).
-- Edge profile encourages zero-dependency code.
encodeInt :: Int -> String
encodeInt = show

{-# LANGUAGE BHC.Realtime #-}
module AudioEngine where

-- | Audio processing with hard latency requirements.
-- The realtime profile guarantees bounded GC pauses (<1ms)
-- and provides arena allocators for per-frame allocation.

import BHC.Realtime.Arena (Arena, withArena, alloc)
import BHC.Realtime.Audio (Sample, SampleRate, Buffer)
import Data.Vector.Storable (Vector)
import qualified Data.Vector.Storable as V

-- | Audio callback invoked by the system at regular intervals.
-- Must complete within the buffer period (e.g., 5ms for 48kHz/256 samples).
-- Arena allocation ensures no GC occurs during processing.
processAudio :: Arena -> Buffer Sample -> Buffer Sample -> IO ()
processAudio arena input output = withArena arena $ do
    -- All allocations in this block use the arena.
    -- Memory is freed in bulk when the arena resets (per frame).
    let filtered = applyLowPass 0.3 input
    let amplified = V.map (* 0.8) filtered

    -- Copy result to output buffer (pre-allocated by host).
    V.copy output amplified

-- | Low-pass filter with no heap allocation.
-- Intermediate vectors allocated in arena, not GC heap.
applyLowPass :: Double -> Buffer Sample -> Buffer Sample
applyLowPass cutoff buf = V.zipWith blend buf smoothed
  where
    smoothed = V.scanl' (\acc x -> acc + realToFrac cutoff * (x - acc)) 0 buf
    blend orig filt = 0.7 * orig + 0.3 * filt

-- | Game loop tick with deterministic timing.
-- Realtime profile: GC only runs between frames, never during.
gameTick :: Arena -> GameState -> GameState
gameTick arena state = withArena arena $
    updatePhysics . processInput . updateEntities $ state

{-# LANGUAGE BHC.Embedded #-}
{-# LANGUAGE BHC.NoGC #-}
module Firmware where

-- | Bare-metal firmware for a microcontroller.
-- The embedded profile eliminates the garbage collector entirely.
-- All memory must be statically allocated or stack-based.

import BHC.Embedded.GPIO (Pin, pinMode, digitalWrite, INPUT, OUTPUT)
import BHC.Embedded.Static (StaticArray, staticArray, readAt, writeAt)
import Data.Word (Word8, Word16)

-- | Statically allocated sensor buffer (no heap).
-- Size known at compile time, lives in .data section.
{-# NOINLINE sensorBuffer #-}
sensorBuffer :: StaticArray 64 Word16
sensorBuffer = staticArray 0

-- | Main firmware entry point. Runs forever, no allocation.
-- All computation uses registers and stack only.
foreign export ccall main :: IO ()
main :: IO ()
main = do
    -- Initialize GPIO pins
    pinMode led OUTPUT
    pinMode button INPUT

    -- Event loop: poll, process, actuate
    forever $ do
        reading <- readSensor
        writeAt sensorBuffer 0 reading
        when (reading > threshold) $
            digitalWrite led True

-- | Read ADC value. Pure register access, no allocation.
readSensor :: IO Word16
readSensor = peek sensorRegister

-- | Hardware addresses (memory-mapped IO).
led, button :: Pin
led    = Pin 13
button = Pin 2

threshold :: Word16
threshold = 512

sensorRegister :: Ptr Word16
sensorRegister = wordPtrToPtr 0x40001234