{-# LANGUAGE OverloadedStrings #-}

-- | Small evaluator for the System FC subset used by the REPL MVP.
module Aihc.Fc.Eval
  ( EvalError (..),
    Value (..),
    evalProgramBinding,
    evalExpr,
    renderValue,
    renderRawValue,
  )
where

import Aihc.Fc.Lower (lowerPseudoOps)
import Aihc.Fc.Newtype (lowerNewtypes)
import Aihc.Fc.Syntax
import Aihc.Tc.Types (RuntimeRep (..), TcType (..), TyCon (..), Unique, isLiftedType)
import Control.Applicative ((<|>))
import Control.Exception (SomeException, displayException, try)
import Control.Monad (forM, forM_, when, zipWithM, (<=<), (>=>))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, catchE, runExceptT, throwE)
import Data.Bits (countLeadingZeros, countTrailingZeros, popCount, shiftL, shiftR, xor, (.&.), (.|.))
import Data.ByteString qualified as BS
import Data.Char qualified as Char
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Int (Int64)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Word (Word32, Word64, Word8)
import Foreign.C.Types (CInt (..))
import Foreign.LibFFI (Arg, argCInt, argInt64, argPtr, argWord64, callFFI, retCInt, retInt64, retPtr, retVoid, retWord64)
import Foreign.Marshal.Alloc (mallocBytes)
import Foreign.Marshal.Array (newArray0, peekArray, pokeArray, withArray0)
import Foreign.Marshal.Utils (copyBytes, fillBytes)
import Foreign.Ptr (FunPtr, Ptr, alignPtr, castPtr, plusPtr)
import Foreign.Storable (peekByteOff, peekElemOff, pokeElemOff)
import System.IO (Handle, IOMode (..), hClose, hFlush, openBinaryFile, stderr, stdin, stdout)
import System.Mem.StableName qualified as Host
import System.Posix.DynamicLinker (DL (Default), dlsym)

data EvalError
  = EvalUnboundVariable Text
  | EvalMissingBinding Text
  | EvalApplyNonFunction Value
  | EvalNoMatchingAlternative Value [FcAltCon]
  | EvalPrimitiveArity Text Int
  | EvalPrimitiveTypeError Text Value
  | EvalForeignArity Text Int Int
  | EvalForeignTypeError Text Value
  | EvalForeignLookupError Text Text
  | EvalInvalidIOResult Value
  | EvalBlackholedThunk
  | EvalInvalidArrayIndex Text Integer Int
  | EvalInvalidByteArrayRange Text Integer Integer Int
  | EvalBlockedOnMVar Text
  | EvalRaisedException Value
  deriving (Eq, Show)

data Value
  = VLit Literal
  | VAddress !(Ptr ())
  | VClosure Env Var FcExpr
  | VConstructor FcConstructorId [Value]
  | VPrim Text Int [Value]
  | VArray EvalArray
  | VByteArray EvalByteArray
  | VIOError Integer
  | VIOHandle EvalIOHandle
  | VIORequest EvalIORequest
  | VMVar EvalMVar
  | VMutVar EvalMutVar
  | VStableName EvalStableName
  | VStateToken
  | VThunk EvalThunk
  deriving (Eq, Show)

newtype EvalThunk = EvalThunk (IORef EvalThunkState)

instance Eq EvalThunk where
  EvalThunk left == EvalThunk right = left == right

instance Show EvalThunk where
  show _ = "<thunk>"

data EvalThunkState
  = ThunkSuspended !Env !FcExpr
  | ThunkEvaluated !Value
  | ThunkEvaluating

newtype EvalMutVar = EvalMutVar (IORef Value)

newtype EvalStableName = EvalStableName (Host.StableName Value)

instance Eq EvalStableName where
  EvalStableName left == EvalStableName right = Host.eqStableName left right

instance Show EvalStableName where
  show _ = "<stable-name>"

newtype EvalArray = EvalArray (IORef [Value])

instance Eq EvalArray where
  EvalArray left == EvalArray right = left == right

instance Show EvalArray where
  show _ = "<array>"

newtype EvalMVar = EvalMVar (IORef (Maybe Value))

instance Eq EvalMVar where
  EvalMVar left == EvalMVar right = left == right

instance Show EvalMVar where
  show _ = "<mvar>"

instance Eq EvalMutVar where
  EvalMutVar left == EvalMutVar right = left == right

instance Show EvalMutVar where
  show _ = "<mutvar>"

data EvalByteArray = EvalByteArray
  { evalByteArraySize :: !(IORef Int),
    evalByteArrayContents :: !(Ptr ()),
    evalByteArrayPinned :: !Bool,
    evalByteArrayAlignment :: !Int
  }

instance Eq EvalByteArray where
  left == right = evalByteArraySize left == evalByteArraySize right

instance Show EvalByteArray where
  show _ = "<byte-array>"

data EvalIOHandle = EvalIOHandle !Int !Handle

instance Eq EvalIOHandle where
  EvalIOHandle left _ == EvalIOHandle right _ = left == right

instance Show EvalIOHandle where
  show _ = "<io-handle>"

data EvalIOOperation
  = EvalRead !EvalIOHandle !(Ptr ()) !Int !Int
  | EvalWrite !EvalIOHandle !(Ptr ()) !Int !Int
  | EvalOpen !Text !Integer
  deriving (Eq, Show)

data EvalIOResult
  = EvalIOInt !Integer
  | EvalIOOpenResult !(Either Integer EvalIOHandle)
  deriving (Eq, Show)

data EvalIOState
  = EvalIOSubmitted !EvalIOOperation
  | EvalIOCompleted !EvalIOResult
  | EvalIOConsumed
  deriving (Eq, Show)

newtype EvalIORequest = EvalIORequest (IORef EvalIOState)

instance Eq EvalIORequest where
  EvalIORequest left == EvalIORequest right = left == right

instance Show EvalIORequest where
  show _ = "<io-request>"

data Env = Env
  { envLocals :: !(Map Unique Value),
    envGlobals :: !(Map Text Value)
  }
  deriving (Eq, Show)

emptyEnv :: Env
emptyEnv = Env Map.empty Map.empty

globalEnv :: [(Text, Value)] -> Env
globalEnv = Env Map.empty . Map.fromList

unionEnv :: Env -> Env -> Env
unionEnv left right =
  Env
    { envLocals = envLocals left `Map.union` envLocals right,
      envGlobals = envGlobals left `Map.union` envGlobals right
    }

lookupEnvVar :: Var -> Env -> Maybe Value
lookupEnvVar var env =
  Map.lookup (varUnique var) (envLocals env)
    <|> (varResolvedName var >>= (`Map.lookup` envGlobals env) . fcSymbolOriginText)
    <|> Map.lookup (varName var) (envGlobals env)

insertLocal :: Var -> Value -> Env -> Env
insertLocal var value env =
  env {envLocals = Map.insert (varUnique var) value (envLocals env)}

localEnv :: [(Var, Value)] -> Env
localEnv bindings = Env (Map.fromList [(varUnique var, value) | (var, value) <- bindings]) Map.empty

type EvalM = ExceptT EvalError IO

evalProgramBinding :: Text -> FcProgram -> IO (Either EvalError Value)
evalProgramBinding name sourceProgram = runExceptT $ do
  env <- buildProgramEnv program
  case Map.lookup selectedName (envGlobals env) of
    Just value -> do
      forced <- forceValue value
      if selectedName `Map.member` ioBindings
        then runIOValue forced
        else pure forced
    Nothing -> throwE (EvalMissingBinding name)
  where
    program = lowerPseudoOps (lowerNewtypes sourceProgram)
    selectedName =
      case [varName var | FcTopBind bind <- fcTopBinds program, var <- bindersOf bind, sourceName var == name] of
        matched : _ -> matched
        [] -> name
    ioBindings =
      Map.fromList
        [ (varName var, ())
        | FcTopBind bind <- fcTopBinds program,
          var <- bindersOf bind,
          isIOType (varType var)
        ]
    sourceName var = maybe (varName var) fcOriginName (varResolvedName var)

buildProgramEnv :: FcProgram -> EvalM Env
buildProgramEnv program = do
  thunkBindings <- mapM allocateTopBinding valueBindings
  let env = globalEnv (directBindings <> [(varName var, VThunk thunk) | (var, _, thunk) <- thunkBindings]) `unionEnv` builtinConstructorEnv
  forM_ thunkBindings $ \(_, expression, EvalThunk ref) ->
    lift (writeIORef ref (ThunkSuspended env expression))
  pure env
  where
    topBinds = fcTopBinds program
    valueBindings = concatMap topValueBindings topBinds
    directBindings = concatMap directTopBindings topBinds

    allocateTopBinding (var, expression) = do
      ref <- lift (newIORef ThunkEvaluating)
      pure (var, expression, EvalThunk ref)

    topValueBindings (FcTopBind (FcNonRec var expression)) = [(var, expression)]
    topValueBindings (FcTopBind (FcRec bindings)) = bindings
    topValueBindings _ = []

    directTopBindings (FcPrimitive var arity) = [(varName var, VPrim (varName var) arity [])]
    directTopBindings (FcData declaration) =
      [ (fcSymbolOriginText (fcConstructorSymbolOrigin (fcDataConOrigin constructor)), VConstructor (fcDataConOrigin constructor) [])
      | constructor <- fcDataConstructors declaration
      ]
    directTopBindings _ = []

evalExpr :: FcExpr -> IO (Either EvalError Value)
evalExpr = runExceptT . evalWithEnv builtinConstructorEnv

builtinConstructorEnv :: Env
builtinConstructorEnv =
  globalEnv
    [ ("C#", VConstructor (FcConstructorId "aihc-prim" "GHC.Types" "C#") []),
      ("[]", VConstructor (FcConstructorId "aihc-prim" "GHC.Types" "[]") []),
      (":", VConstructor (FcConstructorId "aihc-prim" "GHC.Types" ":") []),
      ("(#,#)", VConstructor unboxedTupleOrigin [])
    ]

unboxedTupleOrigin :: FcConstructorId
unboxedTupleOrigin = FcConstructorId "aihc-prim" "GHC.Types" "(#,#)"

unboxedTuple3Origin :: FcConstructorId
unboxedTuple3Origin = FcConstructorId "aihc-prim" "GHC.Types" "(#,,#)"

evalWithEnv :: Env -> FcExpr -> EvalM Value
evalWithEnv env expr =
  case expr of
    FcVar var ->
      case lookupEnvVar var env of
        Just value -> forceValue value
        Nothing -> throwE (EvalUnboundVariable (varName var))
    FcLit lit _ ->
      pure (VLit lit)
    FcApp fun arg -> do
      funValue <- evalWithEnv env fun
      argumentValue <- lazyArgument env arg
      applyValue funValue argumentValue
    FcTyApp inner _ ->
      evalWithEnv env inner
    FcLam var body ->
      pure (VClosure env var body)
    FcTyLam _ body ->
      evalWithEnv env body
    FcLet bind body ->
      extendBind env bind >>= \extended -> evalWithEnv extended body
    FcCase scrut binder alts -> do
      value <- evalWithEnv env scrut >>= forceValue
      matchAlternative (insertLocal binder value env) value alts
    FcCast inner _ ->
      evalWithEnv env inner
    FcCallForeign foreignCall arguments -> do
      values <- mapM (evalWithEnv env >=> forceValue) arguments
      executeForeignCall foreignCall values

lazyArgument :: Env -> FcExpr -> EvalM Value
lazyArgument env expression =
  case expression of
    FcVar var ->
      case lookupEnvVar var env of
        Just value -> pure value
        Nothing -> throwE (EvalUnboundVariable (varName var))
    _ -> VThunk <$> newThunk env expression

newThunk :: Env -> FcExpr -> EvalM EvalThunk
newThunk env expression =
  EvalThunk <$> lift (newIORef (ThunkSuspended env expression))

forceValue :: Value -> EvalM Value
forceValue value =
  case value of
    VThunk (EvalThunk ref) -> do
      state <- lift (readIORef ref)
      case state of
        ThunkEvaluated result -> forceValue result
        ThunkEvaluating -> throwE EvalBlackholedThunk
        ThunkSuspended env expression -> do
          lift (writeIORef ref ThunkEvaluating)
          result <-
            (evalWithEnv env expression >>= forceValue) `catchE` \err -> do
              lift (writeIORef ref state)
              throwE err
          lift (writeIORef ref (ThunkEvaluated result))
          pure result
    VPrim name 0 [] -> evalPrimitive name []
    _ -> pure value

runIOValue :: Value -> EvalM Value
runIOValue action = do
  result <- applyValue action VStateToken >>= forceValue
  case result of
    VConstructor origin [_state, ioResult]
      | origin == unboxedTupleOrigin -> forceValue ioResult
    other -> throwE (EvalInvalidIOResult other)

applyValue :: Value -> Value -> EvalM Value
applyValue value arg = do
  forced <- forceValue value
  case forced of
    VClosure closureEnv var body ->
      evalWithEnv (insertLocal var arg closureEnv) body
    VConstructor name args ->
      pure (VConstructor name (args <> [arg]))
    VPrim name arity args ->
      applyPrimitive name arity (args <> [arg])
    _ ->
      throwE (EvalApplyNonFunction forced)

applyPrimitive :: Text -> Int -> [Value] -> EvalM Value
applyPrimitive name arity args
  | length args < arity = pure (VPrim name arity args)
  | length args == arity = evalPrimitive name args
  | otherwise = throwE (EvalPrimitiveArity name (length args))

evalPrimitive :: Text -> [Value] -> EvalM Value
evalPrimitive "+#" [left, right] =
  evalIntPrim "+#" (+) left right
evalPrimitive "-#" [left, right] =
  evalIntPrim "-#" (-) left right
evalPrimitive "*#" [left, right] =
  evalIntPrim "*#" (*) left right
evalPrimitive "addIntC#" [left, right] = evalIntCarryPrimitive "addIntC#" (+) left right
evalPrimitive "subIntC#" [left, right] = evalIntCarryPrimitive "subIntC#" (-) left right
evalPrimitive "compareInt#" [left, right] =
  evalIntPrim "compareInt#" compareInts left right
evalPrimitive "<#" [left, right] =
  evalIntPrim "<#" (\leftInt rightInt -> if leftInt < rightInt then 1 else 0) left right
evalPrimitive "==#" [left, right] =
  evalIntPrim "==#" (\leftInt rightInt -> if leftInt == rightInt then 1 else 0) left right
evalPrimitive "ord#" [value] = do
  charValue <- forceCharPrimitiveArg "ord#" value
  pure (VLit (LitInt IntRep (fromIntegral (Char.ord charValue))))
evalPrimitive "chr#" [value] = do
  intValue <- forceIntPrimitiveArg "chr#" value
  if intValue >= 0 && intValue <= 0x10ffff
    then pure (VLit (LitChar WordRep (Char.chr (fromIntegral intValue))))
    else throwE (EvalPrimitiveTypeError "chr#" (VLit (LitInt IntRep intValue)))
evalPrimitive "plusWord#" [left, right] = evalWordPrimitive "plusWord#" (+) left right
evalPrimitive "minusWord#" [left, right] = evalWordPrimitive "minusWord#" (-) left right
evalPrimitive "timesWord#" [left, right] = evalWordPrimitive "timesWord#" (*) left right
evalPrimitive "addWordC#" [left, right] = evalWordCarryPrimitive "addWordC#" (+) left right
evalPrimitive "subWordC#" [left, right] = evalWordBorrowPrimitive left right
evalPrimitive "timesWord2#" [left, right] = do
  leftWord <- forceWordPrimitiveArg "timesWord2#" left
  rightWord <- forceWordPrimitiveArg "timesWord2#" right
  let productValue = leftWord * rightWord
  pure (wordPairValue (productValue `quot` wordModulus) (productValue `rem` wordModulus))
evalPrimitive "quotWord#" [left, right] = evalWordPrimitive "quotWord#" quot left right
evalPrimitive "remWord#" [left, right] = evalWordPrimitive "remWord#" rem left right
evalPrimitive "quotRemWord#" [left, right] = do
  leftWord <- forceWordPrimitiveArg "quotRemWord#" left
  rightWord <- forceWordPrimitiveArg "quotRemWord#" right
  let (quotient, remainder) = leftWord `quotRem` rightWord
  pure (wordPairValue quotient remainder)
evalPrimitive "quotRemWord2#" [high, low, divisor] = do
  highWord <- forceWordPrimitiveArg "quotRemWord2#" high
  lowWord <- forceWordPrimitiveArg "quotRemWord2#" low
  divisorWord <- forceWordPrimitiveArg "quotRemWord2#" divisor
  let (quotient, remainder) = (highWord * wordModulus + lowWord) `quotRem` divisorWord
  pure (wordPairValue quotient remainder)
evalPrimitive "and#" [left, right] = evalWordPrimitive "and#" (.&.) left right
evalPrimitive "or#" [left, right] = evalWordPrimitive "or#" (.|.) left right
evalPrimitive "xor#" [left, right] = evalWordPrimitive "xor#" xor left right
evalPrimitive "not#" [value] = do
  word <- forceWordPrimitiveArg "not#" value
  pure (wordValue (wordMask - word))
evalPrimitive "uncheckedShiftL#" [value, count] = evalWordShift "uncheckedShiftL#" shiftL value count
evalPrimitive "uncheckedShiftRL#" [value, count] = evalWordShift "uncheckedShiftRL#" shiftR value count
evalPrimitive "int2Word#" [value] = wordValue . normalizeWord <$> forceIntPrimitiveArg "int2Word#" value
evalPrimitive "word2Int#" [value] = intPrimitiveValue . normalizeInt <$> forceWordPrimitiveArg "word2Int#" value
evalPrimitive "word8ToWord#" [value] = wordValue <$> forceRuntimeRepPrimitiveArg "word8ToWord#" Word8Rep value
evalPrimitive "word32ToWord#" [value] = wordValue <$> forceRuntimeRepPrimitiveArg "word32ToWord#" Word32Rep value
evalPrimitive "word64ToWord#" [value] = wordValue <$> forceRuntimeRepPrimitiveArg "word64ToWord#" Word64Rep value
evalPrimitive "eqWord#" [left, right] = evalWordComparison "eqWord#" (==) left right
evalPrimitive "neWord#" [left, right] = evalWordComparison "neWord#" (/=) left right
evalPrimitive "ltWord#" [left, right] = evalWordComparison "ltWord#" (<) left right
evalPrimitive "leWord#" [left, right] = evalWordComparison "leWord#" (<=) left right
evalPrimitive "gtWord#" [left, right] = evalWordComparison "gtWord#" (>) left right
evalPrimitive "geWord#" [left, right] = evalWordComparison "geWord#" (>=) left right
evalPrimitive "clz#" [value] = evalWordCount "clz#" countLeadingZeros value
evalPrimitive "ctz#" [value] = evalWordCount "ctz#" countTrailingZeros value
evalPrimitive "popCnt#" [value] = evalWordCount "popCnt#" popCount value
evalPrimitive "raise#" [exception] =
  throwE . EvalRaisedException =<< forceValue exception
evalPrimitive "unsafeCoerce#" [value] =
  forceValue value
evalPrimitive "realWorld#" [] =
  pure VStateToken
evalPrimitive "noDuplicate#" [state] =
  pure state
evalPrimitive "makeStableName#" [value, state] = do
  name <- lift (Host.makeStableName value)
  pure (VConstructor unboxedTupleOrigin [state, VStableName (EvalStableName name)])
evalPrimitive "stableNameToInt#" [name] = do
  EvalStableName stableName <- forceStableNamePrimitiveArg "stableNameToInt#" name
  pure (intPrimitiveValue (toInteger (Host.hashStableName stableName)))
evalPrimitive "eqStableName#" [left, right] = do
  EvalStableName leftName <- forceStableNamePrimitiveArg "eqStableName#" left
  EvalStableName rightName <- forceStableNamePrimitiveArg "eqStableName#" right
  pure (intPrimitiveValue (if Host.eqStableName leftName rightName then 1 else 0))
evalPrimitive "catch#" [action, handler, state] =
  applyValue action state `catchE` handleRaised
  where
    handleRaised (EvalRaisedException exception) = do
      handlerWithException <- applyValue handler exception
      applyValue handlerWithException state
    handleRaised err = throwE err
evalPrimitive "newMVar#" [state] = do
  mvar <- lift (newIORef Nothing)
  pure (VConstructor unboxedTupleOrigin [state, VMVar (EvalMVar mvar)])
evalPrimitive "readMVar#" [mvar, state] = do
  EvalMVar ref <- forceMVarPrimitiveArg "readMVar#" mvar
  value <- lift (readIORef ref)
  case value of
    Just contents -> pure (VConstructor unboxedTupleOrigin [state, contents])
    Nothing -> throwE (EvalBlockedOnMVar "readMVar#")
evalPrimitive "takeMVar#" [mvar, state] = do
  EvalMVar ref <- forceMVarPrimitiveArg "takeMVar#" mvar
  value <- lift (readIORef ref)
  case value of
    Just contents -> do
      lift (writeIORef ref Nothing)
      pure (VConstructor unboxedTupleOrigin [state, contents])
    Nothing -> throwE (EvalBlockedOnMVar "takeMVar#")
evalPrimitive "putMVar#" [mvar, value, state] = do
  EvalMVar ref <- forceMVarPrimitiveArg "putMVar#" mvar
  contents <- lift (readIORef ref)
  case contents of
    Nothing -> lift (writeIORef ref (Just value)) >> pure state
    Just _ -> throwE (EvalBlockedOnMVar "putMVar#")
evalPrimitive "newMutVar#" [initialValue, state] = do
  mutVar <- lift (newIORef initialValue)
  pure (VConstructor unboxedTupleOrigin [state, VMutVar (EvalMutVar mutVar)])
evalPrimitive "readMutVar#" [mutVar, state] = do
  EvalMutVar ref <- forceMutVarPrimitiveArg "readMutVar#" mutVar
  value <- lift (readIORef ref)
  pure (VConstructor unboxedTupleOrigin [state, value])
evalPrimitive "writeMutVar#" [mutVar, value, state] = do
  EvalMutVar ref <- forceMutVarPrimitiveArg "writeMutVar#" mutVar
  lift (writeIORef ref value)
  pure state
evalPrimitive "casMutVar#" [mutVar, expected, replacement, state] = do
  EvalMutVar ref <- forceMutVarPrimitiveArg "casMutVar#" mutVar
  current <- lift (readIORef ref)
  let succeeded = current == expected
  when succeeded (lift (writeIORef ref replacement))
  pure
    ( VConstructor
        unboxedTuple3Origin
        [ state,
          intPrimitiveValue (if succeeded then 0 else 1),
          if succeeded then replacement else current
        ]
    )
evalPrimitive "sameMutVar#" [left, right] = do
  leftReference <- forceMutVarPrimitiveArg "sameMutVar#" left
  rightReference <- forceMutVarPrimitiveArg "sameMutVar#" right
  pure (intPrimitiveValue (if leftReference == rightReference then 1 else 0))
evalPrimitive "newArray#" [size, initialValue, state] = do
  count <- checkedArraySize "newArray#" =<< forceIntPrimitiveArg "newArray#" size
  array <- EvalArray <$> lift (newIORef (replicate count initialValue))
  pure (VConstructor unboxedTupleOrigin [state, VArray array])
evalPrimitive "indexArray#" [arrayValue, indexValue] = do
  array <- forceArrayPrimitiveArg "indexArray#" arrayValue
  index <- forceIntPrimitiveArg "indexArray#" indexValue
  readArrayElement "indexArray#" array index
evalPrimitive "readArray#" [arrayValue, indexValue, state] = do
  array <- forceArrayPrimitiveArg "readArray#" arrayValue
  index <- forceIntPrimitiveArg "readArray#" indexValue
  value <- readArrayElement "readArray#" array index
  pure (VConstructor unboxedTupleOrigin [state, value])
evalPrimitive "writeArray#" [arrayValue, indexValue, value, state] = do
  array <- forceArrayPrimitiveArg "writeArray#" arrayValue
  index <- forceIntPrimitiveArg "writeArray#" indexValue
  writeArrayElement "writeArray#" array index value
  pure state
evalPrimitive "unsafeFreezeArray#" [arrayValue, state] = do
  array <- forceArrayPrimitiveArg "unsafeFreezeArray#" arrayValue
  pure (VConstructor unboxedTupleOrigin [state, VArray array])
evalPrimitive "unsafeThawArray#" [arrayValue, state] = do
  array <- forceArrayPrimitiveArg "unsafeThawArray#" arrayValue
  pure (VConstructor unboxedTupleOrigin [state, VArray array])
evalPrimitive "sameMutableArray#" [left, right] = do
  leftArray <- forceArrayPrimitiveArg "sameMutableArray#" left
  rightArray <- forceArrayPrimitiveArg "sameMutableArray#" right
  pure (intPrimitiveValue (if leftArray == rightArray then 1 else 0))
evalPrimitive "newByteArray#" [size, state] = do
  byteArray <- allocateByteArray "newByteArray#" False 8 =<< forceIntPrimitiveArg "newByteArray#" size
  pure (VConstructor unboxedTupleOrigin [state, VByteArray byteArray])
evalPrimitive "newPinnedByteArray#" [size, state] = do
  byteArray <- allocateByteArray "newPinnedByteArray#" True 8 =<< forceIntPrimitiveArg "newPinnedByteArray#" size
  pure (VConstructor unboxedTupleOrigin [state, VByteArray byteArray])
evalPrimitive "newAlignedPinnedByteArray#" [size, alignment, state] = do
  byteCount <- forceIntPrimitiveArg "newAlignedPinnedByteArray#" size
  byteAlignment <- forceIntPrimitiveArg "newAlignedPinnedByteArray#" alignment
  checkedAlignment <- checkedByteArrayAlignment "newAlignedPinnedByteArray#" byteAlignment
  byteArray <- allocateByteArray "newAlignedPinnedByteArray#" True checkedAlignment byteCount
  pure (VConstructor unboxedTupleOrigin [state, VByteArray byteArray])
evalPrimitive "isMutableByteArrayPinned#" [value] = do
  byteArray <- forceByteArrayPrimitiveArg "isMutableByteArrayPinned#" value
  pure (VLit (LitInt IntRep (if evalByteArrayPinned byteArray then 1 else 0)))
evalPrimitive "isByteArrayPinned#" [value] = do
  byteArray <- forceByteArrayPrimitiveArg "isByteArrayPinned#" value
  pure (VLit (LitInt IntRep (if evalByteArrayPinned byteArray then 1 else 0)))
evalPrimitive "byteArrayContents#" [value] = do
  byteArray <- forceByteArrayPrimitiveArg "byteArrayContents#" value
  pure (VAddress (evalByteArrayContents byteArray))
evalPrimitive "mutableByteArrayContents#" [value] = do
  byteArray <- forceByteArrayPrimitiveArg "mutableByteArrayContents#" value
  pure (VAddress (evalByteArrayContents byteArray))
evalPrimitive "shrinkMutableByteArray#" [value, newSize, state] = do
  byteArray <- forceByteArrayPrimitiveArg "shrinkMutableByteArray#" value
  byteCount <- checkedByteArraySize "shrinkMutableByteArray#" =<< forceIntPrimitiveArg "shrinkMutableByteArray#" newSize
  oldSize <- lift (readIORef (evalByteArraySize byteArray))
  if byteCount > oldSize
    then throwE (EvalInvalidByteArrayRange "shrinkMutableByteArray#" 0 (toInteger byteCount) oldSize)
    else lift (writeIORef (evalByteArraySize byteArray) byteCount)
  pure state
evalPrimitive "resizeMutableByteArray#" [value, newSize, state] = do
  byteArray <- forceByteArrayPrimitiveArg "resizeMutableByteArray#" value
  byteCount <- forceIntPrimitiveArg "resizeMutableByteArray#" newSize
  resized <- resizeByteArray "resizeMutableByteArray#" byteArray byteCount
  pure (VConstructor unboxedTupleOrigin [state, VByteArray resized])
evalPrimitive "unsafeFreezeByteArray#" [value, state] = do
  byteArray <- forceByteArrayPrimitiveArg "unsafeFreezeByteArray#" value
  pure (VConstructor unboxedTupleOrigin [state, VByteArray byteArray])
evalPrimitive "unsafeThawByteArray#" [value, state] = do
  byteArray <- forceByteArrayPrimitiveArg "unsafeThawByteArray#" value
  pure (VConstructor unboxedTupleOrigin [state, VByteArray byteArray])
evalPrimitive "sizeofByteArray#" [value] = do
  byteArray <- forceByteArrayPrimitiveArg "sizeofByteArray#" value
  VLit . LitInt IntRep . toInteger <$> lift (readIORef (evalByteArraySize byteArray))
evalPrimitive "getSizeofMutableByteArray#" [value, state] = do
  byteArray <- forceByteArrayPrimitiveArg "getSizeofMutableByteArray#" value
  size <- lift (readIORef (evalByteArraySize byteArray))
  pure (VConstructor unboxedTupleOrigin [state, VLit (LitInt IntRep (toInteger size))])
evalPrimitive "copyAddrToByteArray#" [source, value, offset, byteCount, state] = do
  byteArray <- forceByteArrayPrimitiveArg "copyAddrToByteArray#" value
  checkedOffset <- forceIntPrimitiveArg "copyAddrToByteArray#" offset
  checkedLength <- forceIntPrimitiveArg "copyAddrToByteArray#" byteCount
  (destinationOffset, destinationLength) <- checkedByteArrayRange "copyAddrToByteArray#" byteArray checkedOffset checkedLength
  sourceBytes <- readAddressBytes "copyAddrToByteArray#" destinationLength source
  lift (pokeArray (castPtr (evalByteArrayContents byteArray `plusPtr` destinationOffset)) (BS.unpack sourceBytes))
  pure state
evalPrimitive "indexWord8OffAddr#" [address, index] =
  VLit . LitInt Word8Rep <$> indexAddressPrimitive "indexWord8OffAddr#" 1 readAddressWord8 address index
evalPrimitive "indexWord32OffAddr#" [address, index] =
  VLit . LitInt Word32Rep <$> indexAddressPrimitive "indexWord32OffAddr#" 4 readAddressWord32 address index
evalPrimitive "indexWord64OffAddr#" [address, index] =
  VLit . LitInt Word64Rep <$> indexAddressPrimitive "indexWord64OffAddr#" 8 readAddressWord64 address index
evalPrimitive "indexWordArray#" [value, index] = do
  byteArray <- forceByteArrayPrimitiveArg "indexWordArray#" value
  checkedIndex <- checkedWordArrayIndex "indexWordArray#" byteArray =<< forceIntPrimitiveArg "indexWordArray#" index
  word <- lift (peekElemOff (castPtr (evalByteArrayContents byteArray) :: Ptr Word64) checkedIndex)
  pure (wordValue (toInteger word))
evalPrimitive "readWordArray#" [value, index, state] = do
  byteArray <- forceByteArrayPrimitiveArg "readWordArray#" value
  checkedIndex <- checkedWordArrayIndex "readWordArray#" byteArray =<< forceIntPrimitiveArg "readWordArray#" index
  word <- lift (peekElemOff (castPtr (evalByteArrayContents byteArray) :: Ptr Word64) checkedIndex)
  pure (VConstructor unboxedTupleOrigin [state, wordValue (toInteger word)])
evalPrimitive "writeWordArray#" [value, index, word, state] = do
  byteArray <- forceByteArrayPrimitiveArg "writeWordArray#" value
  checkedIndex <- checkedWordArrayIndex "writeWordArray#" byteArray =<< forceIntPrimitiveArg "writeWordArray#" index
  wordValue' <- forceWordPrimitiveArg "writeWordArray#" word
  lift (pokeElemOff (castPtr (evalByteArrayContents byteArray) :: Ptr Word64) checkedIndex (fromInteger wordValue'))
  pure state
evalPrimitive "copyByteArray#" [sourceValue, sourceOffset, destinationValue, destinationOffset, byteCount, state] = do
  source <- forceByteArrayPrimitiveArg "copyByteArray#" sourceValue
  destination <- forceByteArrayPrimitiveArg "copyByteArray#" destinationValue
  checkedSourceOffset <- forceIntPrimitiveArg "copyByteArray#" sourceOffset
  checkedDestinationOffset <- forceIntPrimitiveArg "copyByteArray#" destinationOffset
  checkedLength <- forceIntPrimitiveArg "copyByteArray#" byteCount
  (sourceStart, sourceLength) <- checkedByteArrayRange "copyByteArray#" source checkedSourceOffset checkedLength
  (destinationStart, destinationLength) <- checkedByteArrayRange "copyByteArray#" destination checkedDestinationOffset checkedLength
  lift (copyBytes (evalByteArrayContents destination `plusPtr` destinationStart) (evalByteArrayContents source `plusPtr` sourceStart) (min sourceLength destinationLength))
  pure state
evalPrimitive "awaitIO#" [request, state] = do
  ioRequest <- forceIORequestPrimitiveArg "awaitIO#" request
  completeIORequest ioRequest
  pure state
evalPrimitive name args =
  throwE (EvalPrimitiveArity name (length args))

wordBits :: Int
wordBits = 64

wordModulus :: Integer
wordModulus = 2 ^ wordBits

wordMask :: Integer
wordMask = wordModulus - 1

intMinimum, intMaximum :: Integer
intMinimum = negate (2 ^ (wordBits - 1))
intMaximum = 2 ^ (wordBits - 1) - 1

normalizeWord :: Integer -> Integer
normalizeWord value = value `mod` wordModulus

normalizeInt :: Integer -> Integer
normalizeInt value =
  let word = normalizeWord value
   in if word > intMaximum then word - wordModulus else word

wordValue :: Integer -> Value
wordValue = VLit . LitInt WordRep . normalizeWord

intPrimitiveValue :: Integer -> Value
intPrimitiveValue = VLit . LitInt IntRep . normalizeInt

wordPairValue :: Integer -> Integer -> Value
wordPairValue high low = VConstructor unboxedTupleOrigin [wordValue high, wordValue low]

evalIntCarryPrimitive :: Text -> (Integer -> Integer -> Integer) -> Value -> Value -> EvalM Value
evalIntCarryPrimitive name operation left right = do
  leftInt <- forceIntPrimitiveArg name left
  rightInt <- forceIntPrimitiveArg name right
  let result = operation leftInt rightInt
      overflow = if result < intMinimum || result > intMaximum then 1 else 0
  pure (VConstructor unboxedTupleOrigin [intPrimitiveValue result, intPrimitiveValue overflow])

evalWordPrimitive :: Text -> (Integer -> Integer -> Integer) -> Value -> Value -> EvalM Value
evalWordPrimitive name operation left right = do
  leftWord <- forceWordPrimitiveArg name left
  rightWord <- forceWordPrimitiveArg name right
  pure (wordValue (operation leftWord rightWord))

evalWordCarryPrimitive :: Text -> (Integer -> Integer -> Integer) -> Value -> Value -> EvalM Value
evalWordCarryPrimitive name operation left right = do
  leftWord <- forceWordPrimitiveArg name left
  rightWord <- forceWordPrimitiveArg name right
  let result = operation leftWord rightWord
  pure (VConstructor unboxedTupleOrigin [wordValue result, intPrimitiveValue (if result >= wordModulus then 1 else 0)])

evalWordBorrowPrimitive :: Value -> Value -> EvalM Value
evalWordBorrowPrimitive left right = do
  leftWord <- forceWordPrimitiveArg "subWordC#" left
  rightWord <- forceWordPrimitiveArg "subWordC#" right
  pure (VConstructor unboxedTupleOrigin [wordValue (leftWord - rightWord), intPrimitiveValue (if leftWord < rightWord then 1 else 0)])

evalWordComparison :: Text -> (Integer -> Integer -> Bool) -> Value -> Value -> EvalM Value
evalWordComparison name predicate left right = do
  leftWord <- forceWordPrimitiveArg name left
  rightWord <- forceWordPrimitiveArg name right
  pure (intPrimitiveValue (if predicate leftWord rightWord then 1 else 0))

evalWordShift :: Text -> (Word64 -> Int -> Word64) -> Value -> Value -> EvalM Value
evalWordShift name operation value count = do
  word <- forceWordPrimitiveArg name value
  shiftCount <- forceIntPrimitiveArg name count
  pure (wordValue (toInteger (operation (fromInteger word) (fromInteger shiftCount))))

evalWordCount :: Text -> (Word64 -> Int) -> Value -> EvalM Value
evalWordCount name operation value = do
  word <- forceWordPrimitiveArg name value
  pure (wordValue (toInteger (operation (fromInteger word))))

allocateByteArray :: Text -> Bool -> Int -> Integer -> EvalM EvalByteArray
allocateByteArray symbol pinned alignment requestedSize = do
  size <- checkedByteArraySize symbol requestedSize
  raw <- lift (mallocBytes (max 1 size + alignment - 1))
  let contents = alignPtr raw alignment
  lift (fillBytes contents 0 size)
  sizeReference <- lift (newIORef size)
  pure
    EvalByteArray
      { evalByteArraySize = sizeReference,
        evalByteArrayContents = contents,
        evalByteArrayPinned = pinned,
        evalByteArrayAlignment = alignment
      }

resizeByteArray :: Text -> EvalByteArray -> Integer -> EvalM EvalByteArray
resizeByteArray symbol byteArray requestedSize = do
  resized <- allocateByteArray symbol (evalByteArrayPinned byteArray) (evalByteArrayAlignment byteArray) requestedSize
  oldSize <- lift (readIORef (evalByteArraySize byteArray))
  newSize <- lift (readIORef (evalByteArraySize resized))
  lift (copyBytes (evalByteArrayContents resized) (evalByteArrayContents byteArray) (min oldSize newSize))
  pure resized

checkedByteArraySize :: Text -> Integer -> EvalM Int
checkedByteArraySize symbol size
  | size < 0 || size > toInteger (maxBound :: Int) =
      throwE (EvalInvalidByteArrayRange symbol 0 size 0)
  | otherwise = pure (fromInteger size)

checkedByteArrayAlignment :: Text -> Integer -> EvalM Int
checkedByteArrayAlignment symbol alignment
  | alignment <= 0 || alignment > toInteger (maxBound :: Int) || alignment .&. (alignment - 1) /= 0 =
      throwE (EvalInvalidByteArrayRange symbol 0 alignment 0)
  | otherwise = pure (fromInteger alignment)

forceByteArrayPrimitiveArg :: Text -> Value -> EvalM EvalByteArray
forceByteArrayPrimitiveArg name value = do
  forced <- forceValue value
  case forced of
    VByteArray byteArray -> pure byteArray
    other -> throwE (EvalPrimitiveTypeError name other)

checkedArraySize :: Text -> Integer -> EvalM Int
checkedArraySize name size
  | size < 0 || size > toInteger (maxBound :: Int) =
      throwE (EvalInvalidArrayIndex name size 0)
  | otherwise = pure (fromInteger size)

forceArrayPrimitiveArg :: Text -> Value -> EvalM EvalArray
forceArrayPrimitiveArg name value = do
  forced <- forceValue value
  case forced of
    VArray array -> pure array
    other -> throwE (EvalPrimitiveTypeError name other)

readArrayElement :: Text -> EvalArray -> Integer -> EvalM Value
readArrayElement name (EvalArray reference) index = do
  values <- lift (readIORef reference)
  case listElement index values of
    Just value -> pure value
    Nothing -> throwE (EvalInvalidArrayIndex name index (length values))

writeArrayElement :: Text -> EvalArray -> Integer -> Value -> EvalM ()
writeArrayElement name (EvalArray reference) index value = do
  values <- lift (readIORef reference)
  case replaceListElement index value values of
    Just updated -> lift (writeIORef reference updated)
    Nothing -> throwE (EvalInvalidArrayIndex name index (length values))

listElement :: Integer -> [a] -> Maybe a
listElement index _ | index < 0 = Nothing
listElement _ [] = Nothing
listElement 0 (value : _) = Just value
listElement index (_ : values) = listElement (index - 1) values

replaceListElement :: Integer -> a -> [a] -> Maybe [a]
replaceListElement index _ _ | index < 0 = Nothing
replaceListElement _ _ [] = Nothing
replaceListElement 0 value (_ : values) = Just (value : values)
replaceListElement index value (current : values) =
  (current :) <$> replaceListElement (index - 1) value values

forceMVarPrimitiveArg :: Text -> Value -> EvalM EvalMVar
forceMVarPrimitiveArg name value = do
  forced <- forceValue value
  case forced of
    VMVar mvar -> pure mvar
    other -> throwE (EvalPrimitiveTypeError name other)

checkedByteArrayRange :: Text -> EvalByteArray -> Integer -> Integer -> EvalM (Int, Int)
checkedByteArrayRange symbol byteArray offset byteCount = do
  size <- lift (readIORef (evalByteArraySize byteArray))
  if offset < 0 || byteCount < 0 || offset > toInteger size || byteCount > toInteger size - offset
    then throwE (EvalInvalidByteArrayRange symbol offset byteCount size)
    else pure (fromInteger offset, fromInteger byteCount)

checkedWordArrayIndex :: Text -> EvalByteArray -> Integer -> EvalM Int
checkedWordArrayIndex symbol byteArray index = do
  size <- lift (readIORef (evalByteArraySize byteArray))
  let byteOffset = index * 8
  if index < 0 || byteOffset > toInteger size - 8
    then throwE (EvalInvalidByteArrayRange symbol byteOffset 8 size)
    else pure (fromInteger index)

compareInts :: Integer -> Integer -> Integer
compareInts left right =
  case compare left right of
    LT -> -1
    EQ -> 0
    GT -> 1

evalIntPrim :: Text -> (Integer -> Integer -> Integer) -> Value -> Value -> EvalM Value
evalIntPrim name op left right = do
  leftInt <- forceIntPrimitiveArg name left
  rightInt <- forceIntPrimitiveArg name right
  pure (VLit (LitInt IntRep (op leftInt rightInt)))

forceIntPrimitiveArg :: Text -> Value -> EvalM Integer
forceIntPrimitiveArg name value = do
  forced <- forceValue value
  case forced of
    VLit (LitInt _ intValue) -> pure intValue
    other -> throwE (EvalPrimitiveTypeError name other)

forceWordPrimitiveArg :: Text -> Value -> EvalM Integer
forceWordPrimitiveArg name value = normalizeWord <$> forceIntPrimitiveArg name value

forceRuntimeRepPrimitiveArg :: Text -> RuntimeRep -> Value -> EvalM Integer
forceRuntimeRepPrimitiveArg name expectedRep value = do
  forced <- forceValue value
  case forced of
    VLit (LitInt actualRep intValue)
      | actualRep == expectedRep -> pure intValue
    other -> throwE (EvalPrimitiveTypeError name other)

forceMutVarPrimitiveArg :: Text -> Value -> EvalM EvalMutVar
forceMutVarPrimitiveArg name value = do
  forced <- forceValue value
  case forced of
    VMutVar mutVar -> pure mutVar
    other -> throwE (EvalPrimitiveTypeError name other)

forceStableNamePrimitiveArg :: Text -> Value -> EvalM EvalStableName
forceStableNamePrimitiveArg name value = do
  forced <- forceValue value
  case forced of
    VStableName stableName -> pure stableName
    other -> throwE (EvalPrimitiveTypeError name other)

forceIORequestPrimitiveArg :: Text -> Value -> EvalM EvalIORequest
forceIORequestPrimitiveArg name value = do
  forced <- forceValue value
  case forced of
    VIORequest request -> pure request
    other -> throwE (EvalPrimitiveTypeError name other)

completeIORequest :: EvalIORequest -> EvalM ()
completeIORequest (EvalIORequest reference) = do
  state <- lift (readIORef reference)
  case state of
    EvalIOSubmitted operation -> do
      result <- performIOOperation operation
      lift (writeIORef reference (EvalIOCompleted result))
    EvalIOCompleted {} -> pure ()
    EvalIOConsumed -> throwE (EvalPrimitiveTypeError "awaitIO#" (VIORequest (EvalIORequest reference)))

performIOOperation :: EvalIOOperation -> EvalM EvalIOResult
performIOOperation operation =
  case operation of
    EvalRead (EvalIOHandle _ handle) buffer offset byteCount -> do
      result <- lift (tryForeign (BS.hGet handle byteCount))
      case result of
        Left _ -> pure (EvalIOInt (-6))
        Right input -> do
          lift (pokeArray (castPtr (buffer `plusPtr` offset)) (BS.unpack input))
          pure (EvalIOInt (toInteger (BS.length input)))
    EvalWrite (EvalIOHandle _ handle) buffer offset byteCount -> do
      bytes <- lift (BS.pack <$> peekArray byteCount (castPtr (buffer `plusPtr` offset)))
      result <- lift (tryForeign (BS.hPut handle bytes >> hFlush handle))
      case result of
        Left _ -> pure (EvalIOInt (-6))
        Right () -> pure (EvalIOInt (toInteger byteCount))
    EvalOpen path modeNumber -> do
      result <- lift (tryForeign (openBinaryFile (T.unpack path) (hostIOMode modeNumber)))
      pure
        ( EvalIOOpenResult
            ( case result of
                Left _ -> Left 5
                Right handle -> Right (EvalIOHandle 3 handle)
            )
        )

executeForeignCall :: FcForeignCall -> [Value] -> EvalM Value
executeForeignCall foreignCall arguments
  | actualArity /= expectedArity = throwE (EvalForeignArity name expectedArity actualArity)
  | otherwise =
      case fcForeignEffect signature of
        FcForeignPure -> callForeign foreignCall arguments
        FcForeignRealWorld ->
          case reverse arguments of
            state : reversedAbiArguments -> do
              result <- callForeign foreignCall (reverse reversedAbiArguments)
              pure (VConstructor unboxedTupleOrigin [state, result])
            [] -> throwE (EvalForeignArity name expectedArity actualArity)
  where
    name = fcForeignCallName foreignCall
    signature = fcForeignCallSignature foreignCall
    actualArity = length arguments
    expectedArity = length (fcForeignOperandTypes signature)

callForeign :: FcForeignCall -> [Value] -> EvalM Value
callForeign foreignCall args
  | symbol == "aihc_io_stdin",
    [] <- args =
      pure (VIOHandle (EvalIOHandle 0 stdin))
  | symbol == "aihc_io_stdout",
    [] <- args =
      pure (VIOHandle (EvalIOHandle 1 stdout))
  | symbol == "aihc_io_stderr",
    [] <- args =
      pure (VIOHandle (EvalIOHandle 2 stderr))
  | symbol == "aihc_memory_write_byte",
    [bufferValue, offsetValue, byteValue] <- args = do
      buffer <- forceAddressForeignArg symbol bufferValue
      offset <- forceForeignInt symbol offsetValue
      byte <- forceForeignInt symbol byteValue
      if offset < 0 || offset > toInteger (maxBound :: Int) || byte < 0 || byte > 255
        then pure (VLit (LitInt IntRep (-23)))
        else do
          lift (pokeArray (castPtr (buffer `plusPtr` fromInteger offset)) [fromInteger byte :: Word8])
          pure (VLit (LitInt IntRep 0))
  | symbol == "aihc_io_submit_open",
    [pathValue, lengthValue, modeValue] <- args = do
      pathLength <- forceForeignInt symbol lengthValue
      modeNumber <- forceForeignInt symbol modeValue
      if pathLength < 0 || pathLength > toInteger (maxBound :: Int)
        then completedOpenRequest (Left 22)
        else do
          bytes <- readAddressBytes symbol (fromInteger pathLength) pathValue
          case TE.decodeUtf8' bytes of
            Left _ -> completedOpenRequest (Left 84)
            Right path ->
              VIORequest . EvalIORequest
                <$> lift (newIORef (EvalIOSubmitted (EvalOpen path modeNumber)))
  | symbol == "aihc_io_open_result_error",
    [openResult] <- args =
      case openResult of
        VIOError errorNumber -> pure (VLit (LitInt IntRep errorNumber))
        VIOHandle {} -> pure (VLit (LitInt IntRep 0))
        _ -> throwE (EvalForeignTypeError symbol openResult)
  | symbol == "aihc_io_close",
    [handleValue] <- args = do
      EvalIOHandle _ handle <- forceIOHandleForeignArg symbol handleValue
      result <- lift (tryForeign (hClose handle))
      case result of
        Left _ -> pure (VLit (LitInt IntRep (-6)))
        Right () -> pure (VLit (LitInt IntRep 0))
  | symbol == "aihc_io_raise_error",
    [errorValue] <- args = do
      errorNumber <- forceForeignInt symbol errorValue
      throwE (EvalRaisedException (VLit (LitInt IntRep errorNumber)))
  | symbol == "aihc_io_submit_read",
    [handleValue, bufferValue, offsetValue, lengthValue] <- args = do
      handle <- forceIOHandleForeignArg symbol handleValue
      buffer <- forceAddressForeignArg symbol bufferValue
      offset <- forceForeignInt symbol offsetValue
      byteCount <- forceForeignInt symbol lengthValue
      (checkedOffset, checkedLength) <- checkedAddressRange symbol offset byteCount
      VIORequest . EvalIORequest <$> lift (newIORef (EvalIOSubmitted (EvalRead handle buffer checkedOffset checkedLength)))
  | symbol == "aihc_io_submit_write",
    [handleValue, bufferValue, offsetValue, lengthValue] <- args = do
      handle <- forceIOHandleForeignArg symbol handleValue
      buffer <- forceAddressForeignArg symbol bufferValue
      offset <- forceForeignInt symbol offsetValue
      byteCount <- forceForeignInt symbol lengthValue
      (checkedOffset, checkedLength) <- checkedAddressRange symbol offset byteCount
      VIORequest . EvalIORequest <$> lift (newIORef (EvalIOSubmitted (EvalWrite handle buffer checkedOffset checkedLength)))
  | symbol == "aihc_io_take_result",
    [request] <- args =
      takeIOResult symbol request
  | symbol == "aihc_io_take_open_result",
    [request] <- args =
      takeOpenIOResult symbol request
  | otherwise = do
      marshalledArgs <-
        zipWithM
          (marshalForeignArgument (fcForeignCallSymbol foreignCall))
          (fcForeignArgumentTypes (fcForeignCallSignature foreignCall))
          args
      functionPointer <- lookupForeignFunction foreignCall
      case fcForeignResultType (fcForeignCallSignature foreignCall) of
        FcForeignInt -> do
          result <- lift (callFFI functionPointer retInt64 marshalledArgs)
          pure (VLit (LitInt IntRep (toInteger result)))
        FcForeignInt32 -> do
          CInt result <- lift (callFFI functionPointer retCInt marshalledArgs)
          pure (VLit (LitInt Int32Rep (toInteger result)))
        FcForeignWord64 -> do
          result <- lift (callFFI functionPointer retWord64 marshalledArgs)
          pure (VLit (LitInt Word64Rep (toInteger result)))
        FcForeignAddr ->
          VAddress <$> lift (callFFI functionPointer (retPtr retVoid) marshalledArgs)
  where
    symbol = fcForeignCallSymbol foreignCall

forceIOHandleForeignArg :: Text -> Value -> EvalM EvalIOHandle
forceIOHandleForeignArg symbol value = do
  forced <- forceValue value
  case forced of
    VIOHandle handle -> pure handle
    _ -> throwE (EvalForeignTypeError symbol forced)

hostIOMode :: Integer -> IOMode
hostIOMode mode =
  case mode of
    0 -> ReadMode
    1 -> WriteMode
    2 -> AppendMode
    _ -> ReadWriteMode

forceAddressForeignArg :: Text -> Value -> EvalM (Ptr ())
forceAddressForeignArg symbol value = do
  forced <- forceValue value
  case forced of
    VAddress address -> pure address
    _ -> throwE (EvalForeignTypeError symbol forced)

checkedAddressRange :: Text -> Integer -> Integer -> EvalM (Int, Int)
checkedAddressRange symbol offset byteCount =
  if offset < 0 || byteCount < 0 || offset > intLimit || byteCount > intLimit - offset
    then throwE (EvalInvalidByteArrayRange symbol offset byteCount 0)
    else pure (fromInteger offset, fromInteger byteCount)
  where
    intLimit = toInteger (maxBound :: Int)

indexAddressPrimitive :: Text -> Int -> (Ptr () -> Int -> IO Integer) -> Value -> Value -> EvalM Integer
indexAddressPrimitive symbol elementSize readElement address indexValue = do
  index <- forceIntPrimitiveArg symbol indexValue
  (byteOffset, _) <- checkedAddressRange symbol (index * toInteger elementSize) (toInteger elementSize)
  forcedAddress <- forceValue address
  case forcedAddress of
    VLit (LitAddr bytes)
      | byteOffset + elementSize <= BS.length bytes ->
          lift (BS.useAsCString bytes (\pointer -> readElement (castPtr pointer) byteOffset))
      | otherwise ->
          throwE (EvalInvalidByteArrayRange symbol (toInteger byteOffset) (toInteger elementSize) (BS.length bytes))
    VAddress pointer -> lift (readElement pointer byteOffset)
    other -> throwE (EvalPrimitiveTypeError symbol other)

readAddressWord8 :: Ptr () -> Int -> IO Integer
readAddressWord8 pointer offset = toInteger <$> (peekByteOff pointer offset :: IO Word8)

readAddressWord32 :: Ptr () -> Int -> IO Integer
readAddressWord32 pointer offset = toInteger <$> (peekByteOff pointer offset :: IO Word32)

readAddressWord64 :: Ptr () -> Int -> IO Integer
readAddressWord64 pointer offset = toInteger <$> (peekByteOff pointer offset :: IO Word64)

readAddressBytes :: Text -> Int -> Value -> EvalM BS.ByteString
readAddressBytes symbol byteCount value = do
  forced <- forceValue value
  case forced of
    VLit (LitAddr bytes) ->
      lift (withArray0 0 (BS.unpack bytes) (fmap BS.pack . peekArray byteCount))
    VAddress pointer -> lift (BS.pack <$> peekArray byteCount (castPtr pointer))
    other -> throwE (EvalForeignTypeError symbol other)

takeIOResult :: Text -> Value -> EvalM Value
takeIOResult symbol value = do
  forced <- forceValue value
  case forced of
    VIORequest (EvalIORequest reference) -> do
      state <- lift (readIORef reference)
      case state of
        EvalIOCompleted (EvalIOInt result) -> do
          lift (writeIORef reference EvalIOConsumed)
          pure (VLit (LitInt IntRep result))
        _ -> throwE (EvalForeignTypeError symbol forced)
    _ -> throwE (EvalForeignTypeError symbol forced)

takeOpenIOResult :: Text -> Value -> EvalM Value
takeOpenIOResult symbol value = do
  forced <- forceValue value
  case forced of
    VIORequest (EvalIORequest reference) -> do
      state <- lift (readIORef reference)
      case state of
        EvalIOCompleted (EvalIOOpenResult result) -> do
          lift (writeIORef reference EvalIOConsumed)
          pure (either VIOError VIOHandle result)
        _ -> throwE (EvalForeignTypeError symbol forced)
    _ -> throwE (EvalForeignTypeError symbol forced)

completedOpenRequest :: Either Integer EvalIOHandle -> EvalM Value
completedOpenRequest result =
  VIORequest . EvalIORequest
    <$> lift (newIORef (EvalIOCompleted (EvalIOOpenResult result)))

marshalForeignArgument :: Text -> FcForeignType -> Value -> EvalM Arg
marshalForeignArgument symbol FcForeignInt argument = do
  argumentValue <- forceForeignInt symbol argument
  pure (argInt64 (fromInteger argumentValue :: Int64))
marshalForeignArgument symbol FcForeignInt32 argument = do
  argumentValue <- forceInt32 symbol argument
  pure (argCInt (CInt (fromInteger argumentValue)))
marshalForeignArgument symbol FcForeignWord64 argument = do
  argumentValue <- forceWord64 symbol argument
  pure (argWord64 (fromInteger argumentValue :: Word64))
marshalForeignArgument symbol FcForeignAddr argument = do
  forced <- forceValue argument
  case forced of
    VLit (LitAddr value) -> do
      pointer <- lift (newArray0 0 (BS.unpack value))
      pure (argPtr pointer)
    VAddress pointer -> pure (argPtr pointer)
    other -> throwE (EvalForeignTypeError symbol other)

lookupForeignFunction :: FcForeignCall -> EvalM (FunPtr ())
lookupForeignFunction foreignCall = do
  lookupResult <- lift (tryForeign (dlsym Default (T.unpack (fcForeignCallSymbol foreignCall))))
  case lookupResult of
    Left err ->
      throwE
        ( EvalForeignLookupError
            (fcForeignCallSymbol foreignCall)
            (T.pack (displayException err))
        )
    Right pointer -> pure pointer

tryForeign :: IO a -> IO (Either SomeException a)
tryForeign = try

forceForeignInt :: Text -> Value -> EvalM Integer
forceForeignInt symbol value = do
  forced <- forceValue value
  case forced of
    VLit (LitInt IntRep intValue) -> pure intValue
    other -> throwE (EvalForeignTypeError symbol other)

forceInt32 :: Text -> Value -> EvalM Integer
forceInt32 symbol value = do
  forced <- forceValue value
  case forced of
    VLit (LitInt Int32Rep intValue) -> pure intValue
    other -> throwE (EvalForeignTypeError symbol other)

forceWord64 :: Text -> Value -> EvalM Integer
forceWord64 symbol value = do
  forced <- forceValue value
  case forced of
    VLit (LitInt Word64Rep intValue) -> pure intValue
    other -> throwE (EvalForeignTypeError symbol other)

bindersOf :: FcBind -> [Var]
bindersOf bind =
  case bind of
    FcNonRec var _ -> [var]
    FcRec bindings -> map fst bindings

isIOType :: TcType -> Bool
isIOType ty =
  case ty of
    TcTyCon (TyCon "IO" 1) [_] -> True
    TcForAllTy _ body -> isIOType body
    TcQualTy _ body -> isIOType body
    _ -> False

forceCharPrimitiveArg :: Text -> Value -> EvalM Char
forceCharPrimitiveArg name value = do
  forced <- forceValue value
  case forced of
    VLit (LitChar _ charValue) -> pure charValue
    other -> throwE (EvalPrimitiveTypeError name other)

extendBind :: Env -> FcBind -> EvalM Env
extendBind env bind =
  case bind of
    FcNonRec var expr
      | isLiftedType (varType var) -> do
          thunk <- newThunk env expr
          pure (insertLocal var (VThunk thunk) env)
      | otherwise -> do
          value <- evalWithEnv env expr >>= forceValue
          pure (insertLocal var value env)
    FcRec bindings -> do
      allocated <- forM bindings $ \(var, expression) -> do
        ref <- lift (newIORef ThunkEvaluating)
        pure (var, expression, EvalThunk ref)
      let recEnv = foldr (\(var, _, thunk) -> insertLocal var (VThunk thunk)) env allocated
      forM_ allocated $ \(_, expression, EvalThunk ref) ->
        lift (writeIORef ref (ThunkSuspended recEnv expression))
      pure recEnv

matchAlternative :: Env -> Value -> [FcAlt] -> EvalM Value
matchAlternative env value alternatives =
  go alternatives
  where
    expected = map altCon alternatives
    go [] = throwE (EvalNoMatchingAlternative value expected)
    go (alt : rest) =
      case matchAlt value alt of
        Just bindings -> evalWithEnv (bindings `unionEnv` env) (altRhs alt)
        Nothing -> go rest

matchAlt :: Value -> FcAlt -> Maybe Env
matchAlt value alt =
  case (altCon alt, value) of
    (DefaultAlt, _) ->
      Just (localEnv [(var, value) | var <- altBinders alt])
    (LitAlt expected _, VLit actual)
      | expected == actual ->
          Just emptyEnv
    (DataAlt expected, VConstructor actual args)
      | expected == actual,
        length args == length (altBinders alt) ->
          Just (localEnv (zip (altBinders alt) args))
    _ ->
      Nothing

renderValue :: Value -> IO (Either EvalError Text)
renderValue = runExceptT . renderValueM

renderValueM :: Value -> EvalM Text
renderValueM value = do
  forced <- forceValue value
  stringValue <- collectString forced
  case stringValue of
    Just text -> pure (T.pack (show (T.unpack text)))
    Nothing -> renderForcedValue forced

renderForcedValue :: Value -> EvalM Text
renderForcedValue value =
  case value of
    VLit lit -> pure (renderLiteral lit)
    VAddress address -> pure (T.pack (show address))
    VConstructor origin [char]
      | fcConstructorName origin == "C#" -> renderBoxedChar char
    VConstructor origin [] -> pure (fcConstructorName origin)
    VConstructor origin _
      | fcConstructorName origin == ":" -> do
          listValue <- collectList value
          case listValue of
            Just elems -> do
              renderedElems <- mapM (renderValueM <=< forceValue) elems
              pure ("[" <> T.intercalate ", " renderedElems <> "]")
            Nothing -> renderConstructor value
    VConstructor origin args -> do
      renderedArgs <- mapM (renderValueM <=< forceValue) args
      pure (T.unwords (fcConstructorName origin : renderedArgs))
    VClosure {} -> pure "<function>"
    VPrim {} -> pure "<function>"
    VArray {} -> pure "<array>"
    VIOError {} -> pure "<io-error>"
    VIOHandle {} -> pure "<io-handle>"
    VByteArray {} -> pure "<byte-array>"
    VIORequest {} -> pure "<io-request>"
    VMVar {} -> pure "<mvar>"
    VMutVar {} -> pure "<mutvar>"
    VStableName {} -> pure "<stable-name>"
    VStateToken -> pure "<state>"
    VThunk {} -> renderValueM value
  where
    renderConstructor (VConstructor origin args) = do
      renderedArgs <- mapM (renderValueM <=< forceValue) args
      pure (T.unwords (fcConstructorName origin : renderedArgs))
    renderConstructor other = renderForcedValue other

collectString :: Value -> EvalM (Maybe Text)
collectString value = do
  listValue <- collectList value
  case listValue of
    Nothing -> pure Nothing
    Just values -> do
      chars <- traverse charValue values
      pure (T.pack <$> sequence chars)
  where
    charValue item = do
      forced <- forceValue item
      case forced of
        VConstructor origin [char]
          | fcConstructorName origin == "C#" -> do
              forcedChar <- forceValue char
              pure $
                case forcedChar of
                  VLit (LitChar _ c) -> Just c
                  _ -> Nothing
        _ -> pure Nothing

collectList :: Value -> EvalM (Maybe [Value])
collectList value = do
  forced <- forceValue value
  case forced of
    VConstructor origin []
      | fcConstructorName origin == "[]" -> pure (Just [])
    VConstructor origin [headValue, tailValue]
      | fcConstructorName origin == ":" -> do
          tailValues <- collectList tailValue
          pure ((headValue :) <$> tailValues)
    _ -> pure Nothing

renderLiteral :: Literal -> Text
renderLiteral lit =
  case lit of
    LitInt _ i -> T.pack (show i)
    LitChar _ c -> T.pack (show c) <> "#"
    LitString s -> T.pack (show (T.unpack s))
    LitAddr s -> T.pack (show (map (Char.chr . fromIntegral) (BS.unpack s))) <> "#"

renderBoxedChar :: Value -> EvalM Text
renderBoxedChar value = do
  forced <- forceValue value
  case forced of
    VLit (LitChar _ c) -> pure (T.pack (show c))
    other -> throwE (EvalPrimitiveTypeError "C#" other)

renderRawValue :: Value -> IO (Either EvalError Text)
renderRawValue = runExceptT . renderRawValueM

renderRawValueM :: Value -> EvalM Text
renderRawValueM value = do
  forced <- forceValue value
  case forced of
    VLit lit -> pure (renderLiteral lit)
    VAddress address -> pure (T.pack (show address))
    VConstructor origin [char]
      | fcConstructorName origin == "C#" -> renderBoxedChar char
    VConstructor origin [] -> pure (fcConstructorName origin)
    VConstructor origin args | isTupleConstructor (fcConstructorName origin) (length args) -> do
      renderedArgs <- mapM renderRawArg args
      pure ("(" <> T.intercalate "," renderedArgs <> ")")
    VConstructor origin args -> do
      renderedArgs <- mapM renderRawArg args
      pure (T.unwords (fcConstructorName origin : renderedArgs))
    VClosure {} -> pure "<function>"
    VPrim {} -> pure "<function>"
    VArray {} -> pure "<array>"
    VIOError {} -> pure "<io-error>"
    VIOHandle {} -> pure "<io-handle>"
    VByteArray {} -> pure "<byte-array>"
    VIORequest {} -> pure "<io-request>"
    VMVar {} -> pure "<mvar>"
    VMutVar {} -> pure "<mutvar>"
    VStableName {} -> pure "<stable-name>"
    VStateToken -> pure "<state>"
    VThunk {} -> renderRawValueM forced

renderRawArg :: Value -> EvalM Text
renderRawArg value = do
  forced <- forceValue value
  rendered <- renderRawValueM forced
  pure $
    case forced of
      VConstructor origin args | isTupleConstructor (fcConstructorName origin) (length args) -> rendered
      VConstructor origin [_] | fcConstructorName origin == "C#" -> rendered
      VConstructor _ (_ : _) -> "(" <> rendered <> ")"
      _ -> rendered

isTupleConstructor :: Text -> Int -> Bool
isTupleConstructor name arity =
  arity >= 2
    && ( name == "(" <> T.replicate (arity - 1) "," <> ")"
           || name == "(#" <> T.replicate (arity - 1) "," <> "#)"
       )
