{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Hercules.CNix.Expr.Raw
  ( RawValue (..),
    mkRawValue,
    RawValueType (..),
    rawValueType,
    forceValue,
    canonicalRawType,
  )
where

import Hercules.CNix.Expr.Context
import qualified Language.C.Inline.Cpp as C
import qualified Language.C.Inline.Cpp.Exception as C
import Protolude hiding (evalState)
import Prelude ()

C.context context

C.include "<nix/config.h>"

C.include "<nix/eval.hh>"

C.include "<nix/eval-inline.hh>"

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

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

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

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

C.using "namespace nix"

-- | A heap object.
--
-- Nix doesn't store all its objects on the heap, but we do.
--
-- Also, Nix calls them @Value@s but it includes thunks, which are not values
-- and some may never produce values, such as @throw "msg"@.
newtype RawValue = RawValue (Ptr Value')

-- | Takes ownership of the value.
mkRawValue :: Ptr Value' -> IO RawValue
mkRawValue :: Ptr Value' -> IO RawValue
mkRawValue Ptr Value'
p = RawValue -> IO RawValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawValue -> IO RawValue) -> RawValue -> IO RawValue
forall a b. (a -> b) -> a -> b
$ Ptr Value' -> RawValue
RawValue Ptr Value'
p

-- | Similar to Nix's Value->type but conflates the List variations
data RawValueType
  = Int
  | Bool
  | String
  | Path
  | Null
  | Attrs
  | List
  | Thunk
  | App
  | Lambda
  | Blackhole
  | PrimOp
  | PrimOpApp
  | External
  | Float
  | Other
  deriving ((forall x. RawValueType -> Rep RawValueType x)
-> (forall x. Rep RawValueType x -> RawValueType)
-> Generic RawValueType
forall x. Rep RawValueType x -> RawValueType
forall x. RawValueType -> Rep RawValueType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawValueType x -> RawValueType
$cfrom :: forall x. RawValueType -> Rep RawValueType x
Generic, Int -> RawValueType -> ShowS
[RawValueType] -> ShowS
RawValueType -> String
(Int -> RawValueType -> ShowS)
-> (RawValueType -> String)
-> ([RawValueType] -> ShowS)
-> Show RawValueType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawValueType] -> ShowS
$cshowList :: [RawValueType] -> ShowS
show :: RawValueType -> String
$cshow :: RawValueType -> String
showsPrec :: Int -> RawValueType -> ShowS
$cshowsPrec :: Int -> RawValueType -> ShowS
Show, RawValueType -> RawValueType -> Bool
(RawValueType -> RawValueType -> Bool)
-> (RawValueType -> RawValueType -> Bool) -> Eq RawValueType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawValueType -> RawValueType -> Bool
$c/= :: RawValueType -> RawValueType -> Bool
== :: RawValueType -> RawValueType -> Bool
$c== :: RawValueType -> RawValueType -> Bool
Eq, Eq RawValueType
Eq RawValueType
-> (RawValueType -> RawValueType -> Ordering)
-> (RawValueType -> RawValueType -> Bool)
-> (RawValueType -> RawValueType -> Bool)
-> (RawValueType -> RawValueType -> Bool)
-> (RawValueType -> RawValueType -> Bool)
-> (RawValueType -> RawValueType -> RawValueType)
-> (RawValueType -> RawValueType -> RawValueType)
-> Ord RawValueType
RawValueType -> RawValueType -> Bool
RawValueType -> RawValueType -> Ordering
RawValueType -> RawValueType -> RawValueType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawValueType -> RawValueType -> RawValueType
$cmin :: RawValueType -> RawValueType -> RawValueType
max :: RawValueType -> RawValueType -> RawValueType
$cmax :: RawValueType -> RawValueType -> RawValueType
>= :: RawValueType -> RawValueType -> Bool
$c>= :: RawValueType -> RawValueType -> Bool
> :: RawValueType -> RawValueType -> Bool
$c> :: RawValueType -> RawValueType -> Bool
<= :: RawValueType -> RawValueType -> Bool
$c<= :: RawValueType -> RawValueType -> Bool
< :: RawValueType -> RawValueType -> Bool
$c< :: RawValueType -> RawValueType -> Bool
compare :: RawValueType -> RawValueType -> Ordering
$ccompare :: RawValueType -> RawValueType -> Ordering
Ord)

-- | You may need to 'forceValue' first.
rawValueType :: RawValue -> IO RawValueType
rawValueType :: RawValue -> IO RawValueType
rawValueType (RawValue Ptr Value'
v) =
  CInt -> RawValueType
forall {a}. (Eq a, Num a) => a -> RawValueType
f
    (CInt -> RawValueType) -> IO CInt -> IO RawValueType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.block| int {
      switch ($(Value* v)->type()) {
        case nInt:         return 1;
        case nBool:        return 2;
        case nString:      return 3;
        case nPath:        return 4;
        case nNull:        return 5;
        case nAttrs:       return 6;
        case nList:        return 7;
        case nFunction:    return 8;
        case nExternal:    return 9;
        case nFloat:       return 10;
        case nThunk:       return 11;
        default: return 0;
      }
    }|]
  where
    f :: a -> RawValueType
f a
1 = RawValueType
Int
    f a
2 = RawValueType
Bool
    f a
3 = RawValueType
String
    f a
4 = RawValueType
Path
    f a
5 = RawValueType
Null
    f a
6 = RawValueType
Attrs
    f a
7 = RawValueType
List
    f a
8 = RawValueType
Lambda
    f a
9 = RawValueType
External
    f a
10 = RawValueType
Float
    f a
11 = RawValueType
Thunk
    f a
_ = RawValueType
Other

forceValue :: Exception a => Ptr EvalState -> RawValue -> IO (Either a ())
forceValue :: forall a.
Exception a =>
Ptr EvalState -> RawValue -> IO (Either a ())
forceValue Ptr EvalState
evalState (RawValue Ptr Value'
v) =
  IO () -> IO (Either a ())
forall e a. Exception e => IO a -> IO (Either e a)
try
    [C.catchBlock|  {
      Value *v = $(Value *v);
      if (v == NULL) throw std::invalid_argument("forceValue value must be non-null");
      $(EvalState *evalState)->forceValue(*v, nix::noPos);
    }|]

-- | Brings RawValueType closer to the 2.4 ValueType.
--
-- This function won't be necessary when support for 2.3 is dropped and we
-- switch entirely to the Haskell equivalent of C++ ValueType.
canonicalRawType :: RawValueType -> RawValueType
canonicalRawType :: RawValueType -> RawValueType
canonicalRawType = \case
  RawValueType
App -> RawValueType
Thunk
  RawValueType
Blackhole -> RawValueType
Thunk
  RawValueType
PrimOp -> RawValueType
Lambda
  RawValueType
PrimOpApp -> RawValueType
Lambda
  RawValueType
x -> RawValueType
x