{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- redundant-constraints: False positive in default signature for `toRawValue`
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

#ifdef __GHCIDE__
# define NIX_IS_AT_LEAST(mm,m,p) 1
#endif

module Hercules.CNix.Expr
  ( init,
    setTalkative,
    setDebug,
    setGlobalOption,
    setOption,
    setExtraStackOverflowHandlerToSleep,
    initThread,
    allowThreads,
    runGcRegisteredThread,
    logInfo,
    withEvalState,
    withEvalStateConduit,
    addAllowedPath,
    addInternalAllowedPaths,
    evalFile,
    newStrings,
    appendString,
    autoCallFunction,
    isDerivation,
    isFunctor,
    getRecurseForDerivations,
    getAttr,
    mkNullableRawValue,
    getAttrs,
    getDrvFile,
    getAttrBool,
    getList,
    getAttrList,
    valueFromExpressionString,
    callFunction,
    apply,
    mkPath,
    getFlakeFromFlakeRef,
    getLocalFlake,
    getFlakeFromGit,
    getFlakeFromArchiveUrl,
    ToRawValue (..),
    ToValue (..),
    FromValue (..),
    ViaJSON (..),

    -- * Re-exports
    RawValue,
    rawValueType,
    module Hercules.CNix.Store,
    module Hercules.CNix.Expr.Typed,
    type EvalState,
  )
where

-- TODO: No more Ptr EvalState
-- TODO: No more NixStore when EvalState is already there
-- TODO: Map Nix-specific C++ exceptions to a CNix exception type

import Conduit
import qualified Data.Aeson as A
import Data.Aeson.KeyMap (toMapText)
import qualified Data.ByteString.Unsafe as BS
import Data.Coerce (coerce)
import qualified Data.HashMap.Lazy as H
import qualified Data.Map as M
import qualified Data.Scientific as Sci
import Data.Vector (Vector)
import qualified Data.Vector as V
import Foreign (nullPtr)
import qualified Foreign.C.String
import qualified Hercules.CNix as CNix
import Hercules.CNix.Encapsulation (moveToForeignPtrWrapper)
import Hercules.CNix.Expr.Context
import Hercules.CNix.Expr.Raw
import Hercules.CNix.Expr.Typed
import Hercules.CNix.Store
import Hercules.CNix.Store.Context
import qualified Language.C.Inline.Cpp as C
import qualified Language.C.Inline.Cpp.Exception as C
import Protolude hiding (evalState)
import System.Directory (makeAbsolute)

C.context (Hercules.CNix.Store.Context.context <> Hercules.CNix.Expr.Context.evalContext)

C.verbatim "#define GC_THREADS 1"

C.include "<stdio.h>"

C.include "<cstring>"

C.include "<math.h>"

C.include "<nix/util/config-global.hh>"
C.include "<nix/store/store-api.hh>"
C.include "<nix/store/globals.hh>"
C.include "<nix/expr/eval.hh>"
C.include "<nix/expr/eval-inline.hh>"
C.include "<nix/expr/get-drvs.hh>"
C.include "<nix/flake/flake.hh>"
C.include "<nix/flake/flakeref.hh>"
C.include "<nix/flake/settings.hh>"
C.include "<nix/fetchers/fetch-settings.hh>"
C.include "<nix/main/shared.hh>"

C.include "hercules-ci-cnix/expr.hxx"

C.include "hercules-ci-cnix/string.hxx"

C.include "<gc/gc.h>"

C.include "<gc/gc_cpp.h>"

C.include "<gc/gc_allocator.h>"

C.using "namespace nix"

C.using "namespace hercules_ci_cnix"

C.verbatim "\nGC_API void GC_CALL GC_throw_bad_alloc() { throw std::bad_alloc(); }\n"

C.verbatim "nix::flake::Settings flakeSettings;"
C.verbatim "nix::fetchers::Settings fetchSettings;"
C.verbatim "static bool readOnlyMode = false;"
C.verbatim "nix::EvalSettings evalSettings(readOnlyMode);"

init :: IO ()
init = do
  [C.throwBlock| void {
    { auto _ = GlobalConfig::Register(&flakeSettings); }
    { auto _ = GlobalConfig::Register(&fetchSettings); }
    { auto _ = GlobalConfig::Register(&evalSettings); }
  }|]
  CNix.init
  [C.throwBlock| void {
    nix::initGC();
    globalConfig.set("extra-experimental-features", "flakes");
    flakeSettings.configureEvalSettings(evalSettings);
  }|]

-- | Initialize the current (main) thread for stack overflow detection.
initThread :: IO ()
initThread =
  void
    [C.throwBlock| void {
      nix::detectStackOverflow();
    }|]

-- | Configure the garbage collector to support threads.
--
-- This is not needed when all evaluation happens on the main thread.
allowThreads :: IO ()
allowThreads =
  void
    [C.block| void {
      GC_allow_register_threads();
    }|]

-- | Run in a thread from which GC may be triggered safely.
--
-- This also installs the stack overflow handler.
--
-- NOTE: Before using this, you must call 'allowThreads' once.
runGcRegisteredThread :: IO a -> IO a
runGcRegisteredThread io =
  runInBoundThread do
    bracket
      start
      (const end)
      (const io)
  where
    start =
      do
        initThread
        [C.block| void {
          struct GC_stack_base sb;
          int r = GC_get_stack_base(&sb);
          assert(r == GC_SUCCESS);
          GC_register_my_thread(&sb);
        }|]
        pass
    end =
      do
        [C.block| void {
          GC_unregister_my_thread();
        }|]
        pass

-- | Configure the stack overflow handler to sleep before returning, allowing
--  other threads to continue for a bit.
--
--  No-op before Nix 2.12
setExtraStackOverflowHandlerToSleep :: IO ()
setExtraStackOverflowHandlerToSleep =
  void
    [C.throwBlock| void {
      nix::stackOverflowHandler = [](siginfo_t *info, void *ctx) {
        Error error("stack overflow");
        logError(error.info());

        // This is risky for a signal handler.
        // Note that the original thread is now in a permanently blocked state
        // so we can easily create a deadlock.
        // Allow the rest of the process to continue for a bit.
        sleep(1);
        _exit(1);
        };
    }|]

setTalkative :: IO ()
setTalkative =
  [C.throwBlock| void {
    nix::verbosity = nix::lvlTalkative;
  } |]

setDebug :: IO ()
setDebug =
  [C.throwBlock| void {
    nix::verbosity = nix::lvlVomit;
  } |]

setGlobalOption :: Text -> Text -> IO ()
setGlobalOption opt value = do
  let optionStr = encodeUtf8 opt
      valueStr = encodeUtf8 value
  [C.throwBlock| void {
    globalConfig.set($bs-cstr:optionStr, $bs-cstr:valueStr);
  }|]

setOption :: Text -> Text -> IO ()
setOption opt value = do
  let optionStr = encodeUtf8 opt
      valueStr = encodeUtf8 value
  [C.throwBlock| void {
    settings.set($bs-cstr:optionStr, $bs-cstr:valueStr);
  }|]

logInfo :: Text -> IO ()
logInfo t = do
  let bstr = encodeUtf8 t
  [C.throwBlock| void {
    printInfo($bs-cstr:bstr);
  }|]

-- | (private) Make an EvalState and leak it.
newEvalState :: (MonadIO m) => Store -> m (Ptr EvalState)
newEvalState (Store store) =
  liftIO
    [C.throwBlock| EvalState* {
      nix::LookupPath emptyLookupPath;
      return new EvalState(emptyLookupPath, *$(refStore* store), fetchSettings, evalSettings);
  } |]

-- | (private) Don't leak it.
deleteEvalState :: (MonadIO m) => (Ptr EvalState) -> m ()
deleteEvalState st = liftIO [C.throwBlock| void { delete $(EvalState* st); } |]

withEvalState ::
  Store ->
  (Ptr EvalState -> IO a) ->
  IO a
withEvalState store = bracket (newEvalState store) deleteEvalState

withEvalStateConduit ::
  (MonadResource m) =>
  Store ->
  (Ptr EvalState -> ConduitT i o m r) ->
  ConduitT i o m r
withEvalStateConduit store = bracketP (newEvalState store) deleteEvalState

-- | Insert an allowed path. Only has an effect when in restricted or pure mode.
addAllowedPath :: Ptr EvalState -> ByteString -> IO ()
addAllowedPath evalState path =
  [C.throwBlock| void {
    std::string path = std::string($bs-ptr:path, $bs-len:path);
    EvalState &evalState = *$(EvalState *evalState);
    evalState.allowPath(path);
  }|]

addInternalAllowedPaths :: Ptr EvalState -> IO ()
addInternalAllowedPaths _evalState = do
  pass

evalFile :: Ptr EvalState -> FilePath -> IO RawValue
evalFile evalState filename = do
  filename' <- Foreign.C.String.newCString filename
  mkRawValue
    =<< [C.throwBlock| Value* {
      EvalState & state = *$(EvalState *evalState);
      Value value;
      auto cstr = $(const char *filename');
      SourcePath path {state.rootPath(CanonPath(cstr))};
      state.evalFile(path, value);
      return new (NoGC) Value(value);
    }|]

-- leaks
newStrings :: IO (Ptr Strings)
newStrings = [C.exp| Strings* { new (NoGC) Strings() }|]

appendString :: Ptr Strings -> ByteString -> IO ()
appendString ss s =
  [C.block| void {
    $(Strings *ss)->push_back(std::string($bs-ptr:s, $bs-len:s));
  }|]

autoCallFunction :: Ptr EvalState -> RawValue -> Value NixAttrs -> IO RawValue
autoCallFunction evalState (RawValue fun) (Value (RawValue autoArgs)) =
  mkRawValue
    =<< [C.throwBlock| Value* {
          Value result;
          $(EvalState *evalState)->autoCallFunction(
                  const_cast<Bindings &>(*$(Value *autoArgs)->attrs()),
                  *$(Value *fun),
                  result);
          return new (NoGC) Value (result);
        }|]

isDerivation :: Ptr EvalState -> RawValue -> IO Bool
isDerivation evalState (RawValue v) =
  (0 /=)
    <$> [C.throwBlock| int {
          if ($(Value *v) == NULL) { throw std::invalid_argument("forceValue value must be non-null"); }
          $(EvalState *evalState)->forceValue(*$(Value *v), nix::noPos);
          return $(EvalState *evalState)->isDerivation(*$(Value *v));
        }|]

isFunctor :: Ptr EvalState -> RawValue -> IO Bool
isFunctor evalState (RawValue v) =
  (0 /=)
    <$> [C.throwBlock| int {
          if ($(Value *v) == NULL) { throw std::invalid_argument("forceValue value must be non-null"); }
          return $(EvalState *evalState)->isFunctor(*$(Value *v));
        }|]

getRecurseForDerivations :: Ptr EvalState -> Value NixAttrs -> IO Bool
getRecurseForDerivations evalState (Value (RawValue v)) =
  (0 /=)
    <$> [C.throwBlock| int {
          Value *v = $(Value *v);
          EvalState &evalState = *$(EvalState *evalState);
          auto attrs = v->attrs();
          // Bindings::const_iterator iter; // 2.24
          auto iter = attrs->find(evalState.sRecurseForDerivations);
          if (iter == attrs->end()) {
            return 0;
          } else {
            // Previously this bool was unpacked manually and included a special
            // case to return true when it is not a bool. That logic was added
            // because an empty attrset was found here, observed in
            // nixpkgs master 67e2de195a4aa0a50ffb1e1ba0b4fb531dca67dc
            return evalState.forceBool(*iter->value, iter->pos, "while evaluating whether to traverse into an attribute set to find more derivations");
          }
        } |]

getAttr :: Ptr EvalState -> Value NixAttrs -> ByteString -> IO (Maybe RawValue)
getAttr evalState (Value (RawValue v)) k =
  mkNullableRawValue
    =<< [C.throwBlock| Value *{
      Value &v = *$(Value *v);
      EvalState &evalState = *$(EvalState *evalState);
      Symbol k = evalState.symbols.create($bs-cstr:k);
      auto attrs = v.attrs();
      // Bindings::const_iterator iter; // 2.24
      auto iter = attrs->find(k);
      if (iter == attrs->end()) {
        return nullptr;
      } else {
        return iter->value;
      }
    }|]

-- | Converts 'nullPtr' to 'Nothing'; actual values to @Just (a :: 'RawValue')@
mkNullableRawValue :: Ptr Value' -> IO (Maybe RawValue)
mkNullableRawValue p | p == nullPtr = pure Nothing
mkNullableRawValue p = Just <$> mkRawValue p

getAttrs :: Ptr EvalState -> Value NixAttrs -> IO (Map ByteString RawValue)
getAttrs evalState (Value (RawValue v)) = do
  begin <- [C.exp| const Attr *{ $(Value *v)->attrs()->begin() }|]
  end <- [C.exp| const Attr *{ $(Value *v)->attrs()->end() }|]
  let gather :: Map ByteString RawValue -> Ptr Attr' -> IO (Map ByteString RawValue)
      gather acc i | i == end = pure acc
      gather acc i = do
        name <-
          BS.unsafePackMallocCString
            =<< [C.block| const char *{
              EvalState &evalState = *$(EvalState *evalState);
              SymbolStr str = evalState.symbols[$(Attr *i)->name];
              return stringdup(static_cast<std::string>(str));
            }|]
        value <- mkRawValue =<< [C.exp| Value *{ new (NoGC) Value(*$(Attr *i)->value) } |]
        let acc' = M.insert name value acc
        seq acc' pass
        gather acc' =<< [C.exp| Attr *{ &$(Attr *i)[1] }|]
  gather mempty begin

getDrvFile :: (MonadIO m) => Ptr EvalState -> RawValue -> m StorePath
getDrvFile evalState (RawValue v) = liftIO do
  moveToForeignPtrWrapper
    =<< [C.throwBlock| nix::StorePath *{
      EvalState &state = *$(EvalState *evalState);
      auto drvInfo = getDerivation(state, *$(Value *v), false);
      if (!drvInfo)
        throw EvalError(state, "Not a valid derivation");

      StorePath storePath = drvInfo->requireDrvPath();

      // write it (?)
      auto drv = state.store->derivationFromPath(storePath);

      return new StorePath(storePath);
    }|]

getAttrBool :: Ptr EvalState -> Value NixAttrs -> ByteString -> IO (Either SomeException (Maybe Bool))
getAttrBool evalState attrset attrName = do
  attrMaybe <- getAttr evalState attrset attrName
  attrMaybe & maybe (pure (Right Nothing)) \attr -> do
    match evalState attr >>= \case
      Left e -> do
        pure $ Left e
      Right (IsBool r) -> do
        b <- getBool r
        pure $ Right (Just b)
      Right _ -> do
        pure $ Right Nothing

#if NIX_IS_AT_LEAST(2, 30, 0)
getList :: Value NixList -> IO [RawValue]
getList (Value (RawValue nixList)) = do
  len <- [C.exp| int { $(Value *nixList)->listSize() }|]
  bracket
    [C.exp| ListViewType * { new ListViewType($(Value *nixList)->listView()) }|]
    (\listView -> [C.exp| void { delete $(ListViewType *listView) }|])
    (\listView -> do
      let getElem i = mkRawValue =<< [C.exp| Value * { (*$(ListViewType *listView))[$(int i)] }|]
      for [0 .. (len - 1)] \i -> do
        getElem i
    )
#else
getList :: Value NixList -> IO [RawValue]
getList (Value (RawValue nixList)) = do
  len <- [C.exp| int { $(Value *nixList)->listSize() }|]
  let getElem i = mkRawValue =<< [C.exp| Value * { $(Value *nixList)->listElems()[$(int i)] }|]
  for [0 .. (len - 1)] \i -> do
    getElem i
#endif

getAttrList :: Ptr EvalState -> Value NixAttrs -> ByteString -> IO (Either SomeException (Maybe [RawValue]))
getAttrList evalState attrset attrName = do
  attrMaybe <- getAttr evalState attrset attrName
  attrMaybe & maybe (pure (Right Nothing)) \attr -> do
    match evalState attr >>= \case
      Left e -> do
        pure $ Left e
      Right (IsList r) -> do
        b <- getList r
        pure $ Right (Just b)
      Right _ -> do
        pure $ Right Nothing

-- | Parse a string and eval it.
valueFromExpressionString ::
  Ptr EvalState ->
  -- | The string to parse
  ByteString ->
  -- | Base path for path exprs
  ByteString ->
  IO RawValue
valueFromExpressionString evalState s basePath = do
  mkRawValue
    =<< [C.throwBlock| Value *{
      EvalState &evalState = *$(EvalState *evalState);
      std::string basePathStr = std::string($bs-ptr:basePath, $bs-len:basePath);
      SourcePath basePath {evalState.rootPath(CanonPath(basePathStr))};
      Expr *expr = evalState.parseExprFromString(std::string($bs-ptr:s, $bs-len:s), basePath);
      Value *r = new (NoGC) Value();
      evalState.eval(expr, *r);
      return r;
  }|]

-- | 'apply' but strict.
callFunction :: Ptr EvalState -> RawValue -> RawValue -> IO RawValue
callFunction evalState (RawValue f) (RawValue a) = do
  mkRawValue
    =<< [C.throwBlock| Value *{
      EvalState &evalState = *$(EvalState *evalState);
      Value *r = new (NoGC) Value();
      evalState.callFunction(*$(Value *f), *$(Value *a), *r, noPos);
      return r;
  }|]

apply :: RawValue -> RawValue -> IO RawValue
apply (RawValue f) (RawValue a) = do
  mkRawValue
    =<< [C.throwBlock| Value *{
      Value *r = new (NoGC) Value();
      r->mkApp($(Value *f), $(Value *a));
      return r;
    }|]

mkPath :: Ptr EvalState -> ByteString -> IO (Value NixPath)
mkPath evalState path =
  Value
    <$> ( mkRawValue
            =<< [C.throwBlock| Value *{
              Value *r = new (NoGC) Value();
              std::string s($bs-ptr:path, $bs-len:path);
              EvalState & state = *$(EvalState *evalState);
              r->mkPath(state.rootPath(CanonPath(s)));
              return r;
          }|]
        )

getFlakeFromFlakeRef :: Ptr EvalState -> ByteString -> IO RawValue
getFlakeFromFlakeRef evalState flakeRef = do
  [C.throwBlock| Value *{
    EvalState &evalState = *$(EvalState *evalState);
    Value *r = new (NoGC) Value();
    std::string flakeRefStr($bs-ptr:flakeRef, $bs-len:flakeRef);
    auto flakeRef = nix::parseFlakeRef(
      fetchSettings,
      flakeRefStr,
      {},
      true);
    nix::flake::callFlake(evalState,
      nix::flake::lockFlake(
        flakeSettings,
        evalState,
        flakeRef,
        nix::flake::LockFlags {
          .updateLockFile = false,
          .useRegistries = false,
          .allowUnlocked = false,
        }),
      *r);
    return r;
  }|]
    >>= mkRawValue

getLocalFlake :: Ptr EvalState -> Text -> IO RawValue
getLocalFlake evalState path = do
  absPath <- encodeUtf8 . toS <$> makeAbsolute (toS path)
  mkRawValue
    =<< [C.throwBlock| Value *{
      EvalState &evalState = *$(EvalState *evalState);
      Value *r = new (NoGC) Value();
      std::string path($bs-ptr:absPath, $bs-len:absPath);
      auto flakeRef = nix::parseFlakeRef(
        fetchSettings,
        path,
        {},
        true);
      nix::flake::callFlake(evalState,
        nix::flake::lockFlake(
          flakeSettings,
          evalState,
          flakeRef,
          nix::flake::LockFlags {
            .updateLockFile = false,
            .useRegistries = false,
            .allowUnlocked = false,
          }),
        *r);
      return r;
    }|]

getFlakeFromGit :: Ptr EvalState -> Text -> Text -> Text -> IO RawValue
getFlakeFromGit evalState url ref rev =
  let urlb = encodeUtf8 url
      refb = encodeUtf8 ref
      revb = encodeUtf8 rev
   in [C.throwBlock| Value *{
    EvalState &evalState = *$(EvalState *evalState);
    Value *r = new (NoGC) Value();
    std::string url($bs-ptr:urlb, $bs-len:urlb);
    std::string ref($bs-ptr:refb, $bs-len:refb);
    std::string rev($bs-ptr:revb, $bs-len:revb);

    fetchers::Attrs attrs;
    attrs.emplace("type", "git");
    attrs.emplace("url", url);
    attrs.emplace("ref", ref);
    attrs.emplace("rev", rev);

    auto flakeRef = nix::FlakeRef::fromAttrs(
      fetchSettings,
      attrs);
    nix::flake::callFlake(evalState,
      nix::flake::lockFlake(
        flakeSettings,
        evalState,
        flakeRef,
        nix::flake::LockFlags {
          .updateLockFile = false,
          .useRegistries = false,
          .allowUnlocked = false,
        }),
      *r);
    return r;
  }|]
        >>= mkRawValue

getFlakeFromArchiveUrl :: Ptr EvalState -> Text -> IO RawValue
getFlakeFromArchiveUrl evalState url = do
  srcArgs <-
    toRawValue evalState $
      ("url" :: ByteString) =: url
  fn <- valueFromExpressionString evalState "builtins.fetchTarball" "/"
  pValue <- apply fn srcArgs
  p <- assertType evalState pValue
  p' <- getStringIgnoreContext p
  getFlakeFromFlakeRef evalState p'

traverseWithKey_ :: (Applicative f) => (k -> a -> f ()) -> Map k a -> f ()
traverseWithKey_ f = M.foldrWithKey (\k a more -> f k a *> more) (pure ())

class ToRawValue a where
  toRawValue :: Ptr EvalState -> a -> IO RawValue
  default toRawValue :: (ToValue a) => Ptr EvalState -> a -> IO RawValue
  toRawValue evalState a = rtValue <$> toValue evalState a

class (ToRawValue a) => ToValue a where
  type NixTypeFor a :: Type
  toValue :: Ptr EvalState -> a -> IO (Value (NixTypeFor a))

-- | Marshall values from Nix into Haskell. Instances must satisfy the
-- requirements that:
--
--  - Only a single Nix value type is acceptable for the Haskell type.
--  - Marshalling does not fail, as the Nix runtime type has already been checked.
class FromValue n a | a -> n where
  fromValue :: Value n -> IO a

instance FromValue Bool Bool where
  fromValue = getBool

instance FromValue NixList [RawValue] where
  fromValue = getList

instance FromValue NixInt Int64 where
  fromValue = getInt

-- | Identity
instance ToRawValue RawValue where
  toRawValue _ = pure

-- | Upcast
instance forall (a :: Type). ToRawValue (Value a)

-- | Identity
instance forall (a :: Type). ToValue (Value a) where
  type NixTypeFor (Value a) = a
  toValue _ = pure

instance ToRawValue C.CBool

instance ToValue C.CBool where
  type NixTypeFor C.CBool = Bool
  toValue _ b =
    coerce
      <$> [C.block| Value *{
        Value *r = new (NoGC) Value();
        r->mkBool($(bool b));
        return r;
      }|]

instance ToRawValue Bool

instance ToValue Bool where
  type NixTypeFor Bool = Bool
  toValue es False = toValue es (0 :: C.CBool)
  toValue es True = toValue es (1 :: C.CBool)

-- | The native Nix integer type
instance ToRawValue Int64

-- | The native Nix integer type
instance ToValue Int64 where
  type NixTypeFor Int64 = NixInt
  toValue _ i =
    coerce
      <$> [C.block| Value *{
        Value *r = new (NoGC) Value();
        r->mkInt($(int64_t i));
        return r;
      }|]

instance ToRawValue Int

instance ToValue Int where
  type NixTypeFor Int = NixInt
  toValue es i = toValue es (fromIntegral i :: Int64)

instance ToRawValue C.CDouble

instance ToValue C.CDouble where
  type NixTypeFor C.CDouble = NixFloat
  toValue _ f =
    coerce
      <$> [C.block| Value *{
          Value *r = new (NoGC) Value();
          r->mkFloat($(double f));
          return r;
        }|]

instance ToRawValue Double

instance ToValue Double where
  type NixTypeFor Double = NixFloat
  toValue es f = toValue es (fromRational (toRational f) :: C.CDouble)

-- | Nix String
instance ToValue ByteString where
  type NixTypeFor ByteString = NixString
  toValue _ s =
    -- TODO simplify when r->mkString(string_view) is safe in all supported Nix versions
    coerce
      <$> [C.block| Value *{
        Value *r = new (NoGC) Value();
        std::string_view s($bs-ptr:s, $bs-len:s);
        // If empty, the pointer may be invalid; don't use it.
        if (s.size() == 0) {
          r->mkString("");
        }
        else {
          r->mkString(GC_STRNDUP(s.data(), s.size()));
        }
        return r;
      }|]

-- | Nix String
instance ToRawValue ByteString

-- | UTF-8
instance ToRawValue Text

-- | UTF-8
instance ToValue Text where
  type NixTypeFor Text = NixString
  toValue es s = toValue es (encodeUtf8 s)

instance (ToRawValue a) => ToRawValue (Map ByteString a)

withBindingsBuilder :: (Integral n) => Ptr EvalState -> n -> (Ptr BindingsBuilder' -> IO ()) -> IO (Value NixAttrs)
withBindingsBuilder evalState n f = do
  withBindingsBuilder' evalState n \bb -> do
    f bb
    v <-
      [C.block| Value* {
        auto v = new (NoGC) Value();
        v->mkAttrs(*$(BindingsBuilder *bb));
        return v;
      }|]
    Value <$> mkRawValue v

withBindingsBuilder' :: (Integral n) => Ptr EvalState -> n -> (Ptr BindingsBuilder' -> IO a) -> IO a
withBindingsBuilder' evalState n =
  let l :: C.CInt
      l = fromIntegral n
   in bracket
        [C.block| BindingsBuilder* {
          auto &evalState = *$(EvalState *evalState);
          return new BindingsBuilder(evalState, evalState.allocBindings($(int l)));
        }|]
        \bb -> [C.block| void { delete $(BindingsBuilder *bb); }|]

instance (ToRawValue a) => ToValue (Map ByteString a) where
  type NixTypeFor (Map ByteString a) = NixAttrs

  toValue evalState attrs = withBindingsBuilder evalState (length attrs) \bb -> do
    attrs & traverseWithKey_ \k a -> do
      RawValue aRaw <- toRawValue evalState a
      [C.block| void {
        EvalState &evalState = *$(EvalState *evalState);
        std::string k($bs-ptr:k, $bs-len:k);
        Value &a = *$(Value *aRaw);
        $(BindingsBuilder *bb)->alloc(evalState.symbols.create(k)) = a;
      }|]

instance (ToRawValue a) => ToRawValue (Map Text a)

instance (ToRawValue a) => ToValue (Map Text a) where
  type NixTypeFor (Map Text a) = NixAttrs
  toValue evalState attrs = toValue evalState (M.mapKeys encodeUtf8 attrs)

mkNull :: IO RawValue
mkNull =
  coerce
    <$> [C.block| Value* {
          Value *v = new (NoGC) Value();
          v->mkNull();
          return v;
        }|]

instance ToRawValue A.Value where
  toRawValue es (A.Bool b) = toRawValue es b
  toRawValue es (A.String s) = toRawValue es s
  toRawValue es (A.Object fs) = toRawValue es $ toMapText fs
  toRawValue _es A.Null = mkNull
  toRawValue es (A.Number n) | Just i <- Sci.toBoundedInteger n = toRawValue es (i :: Int64)
  toRawValue es (A.Number f) = toRawValue es (Sci.toRealFloat f :: Double)
  toRawValue es (A.Array a) = toRawValue es a

-- | For deriving-via of 'ToRawValue' using 'ToJSON'.
newtype ViaJSON a = ViaJSON {fromViaJSON :: a}
  deriving newtype (Eq, Ord, Read, Show)

instance (A.ToJSON a) => ToRawValue (ViaJSON a) where
  toRawValue es (ViaJSON a) = toRawValue es (A.toJSON a)

hmTraverseWithKey_ :: (Applicative f) => (k -> a -> f ()) -> H.HashMap k a -> f ()
hmTraverseWithKey_ f = H.foldrWithKey (\k a more -> f k a *> more) (pure ())

instance (ToRawValue a) => ToRawValue (H.HashMap Text a)

instance (ToRawValue a) => ToValue (H.HashMap Text a) where
  type NixTypeFor (H.HashMap Text a) = NixAttrs

  toValue evalState attrs = withBindingsBuilder evalState (length attrs) \bb -> do
    attrs & hmTraverseWithKey_ \k' a -> do
      RawValue aRaw <- toRawValue evalState a
      let k = encodeUtf8 k'
      [C.block| void {
        EvalState &evalState = *$(EvalState *evalState);
        std::string k($bs-ptr:k, $bs-len:k);
        Value &a = *$(Value *aRaw);
        $(BindingsBuilder *bb)->alloc(evalState.symbols.create(k)) = a;
      }|]

instance (ToRawValue a) => ToRawValue (Vector a)

instance (ToRawValue a) => ToValue (Vector a) where
  type NixTypeFor (Vector a) = NixList
  toValue evalState vec =
    coerce <$> do
      let l :: C.CInt
          l = fromIntegral (length vec)
      b <-
        [C.block| ListBuilder* {
          EvalState &evalState = *$(EvalState *evalState);
          return new (NoGC) ListBuilder(evalState, $(int l));
        }|]
      vec & V.imapM_ \i a -> do
        RawValue aRaw <- toRawValue evalState a
        let ix = fromIntegral i
        [C.block| void {
          ListBuilder &b = *$(ListBuilder *b);
          b[$(int ix)] = $(Value *aRaw);
        }|]
      v <-
        [C.block| Value* {
          Value * v = new (NoGC) Value();
          v->mkList(*$(ListBuilder *b));
          return v;
        }|]
      Value <$> mkRawValue v

instance (ToRawValue a) => ToRawValue [a]

instance (ToRawValue a) => ToValue [a] where
  type NixTypeFor [a] = NixList
  toValue es l = toValue es (V.fromList l)
