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

module Hercules.CNix.Expr.Typed
  ( Value (..),
    NixInt,
    NixFloat,
    NixString,
    NixPath,
    NixAttrs,
    NixList,
    NixFunction,
    NixPrimOp,
    NixPrimOpApp,
    NixExternal,
    unsafeAssertType,
    Match (..),
    match,
    match',
    getBool,
    getInt,
    getStringIgnoreContext,
    hasContext,
    CheckType (..),
    assertType,
    HasRawValueType (..),
  )
where

import Control.Exception (throwIO)
import Hercules.CNix.Expr.Context
import Hercules.CNix.Expr.Raw
import qualified Language.C.Inline.Cpp as C
import Protolude hiding
  ( evalState,
    throwIO,
  )
import Prelude (userError)

C.context context

C.include "<stdio.h>"

C.include "<cstring>"

C.include "<math.h>"

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

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

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

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

C.include "<nix/store-api.hh>"

C.include "<nix/common-eval-args.hh>"

C.include "<nix/get-drvs.hh>"

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

C.include "<nix/globals.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"

-- | Runtime-Typed Value. This implies that it has been forced,
-- because otherwise the type would not be known.
--
-- This is distinct from Nix, which calls its objects @Value@ regardless if
-- they're thunks.
newtype Value a = Value {forall a. Value a -> RawValue
rtValue :: RawValue}

type NixInt = Int64

data NixFloat

data NixString

data NixPath

data NixAttrs

data NixFunction

data NixList

data NixPrimOp

data NixPrimOpApp

data NixExternal

-- TODO: actually encapsulate the constructor
unsafeAssertType :: RawValue -> Value a
unsafeAssertType :: forall a. RawValue -> Value a
unsafeAssertType = forall a. RawValue -> Value a
Value

-- This is useful because you regain exhaustiveness checking.
-- Otherwise a bunch of downcast functions might do.
data Match
  = IsInt (Value NixInt)
  | IsBool (Value Bool)
  | IsString (Value NixString)
  | IsPath (Value NixPath)
  | IsNull (Value ())
  | IsAttrs (Value NixAttrs)
  | IsList (Value NixList)
  | IsFunction (Value NixFunction)
  | IsExternal (Value NixExternal)
  | IsFloat (Value NixFloat)

-- FIXME: errors don't provide any clue here
match :: Ptr EvalState -> RawValue -> IO (Either SomeException Match)
match :: Ptr EvalState -> RawValue -> IO (Either SomeException Match)
match Ptr EvalState
es RawValue
v =
  forall a.
Exception a =>
Ptr EvalState -> RawValue -> IO (Either a ())
forceValue Ptr EvalState
es RawValue
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left SomeException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left SomeException
e)
    Right ()
_ ->
      RawValue -> IO RawValueType
rawValueType RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        RawValueType
Int -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixInt -> Match
IsInt forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Bool -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value Bool -> Match
IsBool forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
String -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixString -> Match
IsString forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Path -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixPath -> Match
IsPath forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Null -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value () -> Match
IsNull forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Attrs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixAttrs -> Match
IsAttrs forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
List -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixList -> Match
IsList forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Thunk -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Could not force Nix thunk" -- FIXME: custom exception?
        RawValueType
App -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Could not force Nix thunk (App)"
        RawValueType
Blackhole ->
          forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Could not force Nix thunk (Blackhole)"
        RawValueType
Lambda -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixFunction -> Match
IsFunction forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
PrimOp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixFunction -> Match
IsFunction forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
PrimOpApp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixFunction -> Match
IsFunction forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
External -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixExternal -> Match
IsExternal forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Float -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value NixFloat -> Match
IsFloat forall a b. (a -> b) -> a -> b
$ forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Other ->
          forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Unknown runtime type in Nix value"

match' :: Ptr EvalState -> RawValue -> IO Match
match' :: Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO (Either SomeException Match)
match Ptr EvalState
es RawValue
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case Left SomeException
e -> forall e a. Exception e => e -> IO a
throwIO SomeException
e; Right Match
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Match
a

getBool :: Value Bool -> IO Bool
getBool :: Value Bool -> IO Bool
getBool (Value (RawValue Ptr Value'
v)) =
  (CInt
0 forall a. Eq a => a -> a -> Bool
/=)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.exp| int { $(Value *v)->boolean ? 1 : 0 }|]

getInt :: Value NixInt -> IO Int64
getInt :: Value NixInt -> IO NixInt
getInt (Value (RawValue Ptr Value'
v)) =
  [C.exp| int64_t { $(Value *v)->integer }|]

-- NOT coerceToString
getStringIgnoreContext :: Value NixString -> IO ByteString
getStringIgnoreContext :: Value NixString -> IO ByteString
getStringIgnoreContext (Value (RawValue Ptr Value'
v)) =
  forall (m :: * -> *). MonadIO m => IO CString -> m ByteString
unsafeMallocBS
    [C.exp| const char *{
    strdup($(Value *v)->string.s)
  }|]

hasContext :: Value NixString -> IO Bool
hasContext :: Value NixString -> IO Bool
hasContext (Value (RawValue Ptr Value'
v)) =
  (CInt
0 forall a. Eq a => a -> a -> Bool
/=)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.exp| int { $(Value *v)->string.context ? 1 : 0 }|]

class CheckType a where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value a))

instance CheckType Int64 where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value NixInt))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsInt Value NixInt
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixInt
x; Match
_ -> forall a. Maybe a
Nothing

instance CheckType Bool where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value Bool))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsBool Value Bool
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value Bool
x; Match
_ -> forall a. Maybe a
Nothing

instance CheckType NixString where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value NixString))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsString Value NixString
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixString
x; Match
_ -> forall a. Maybe a
Nothing

instance CheckType NixPath where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value NixPath))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsPath Value NixPath
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixPath
x; Match
_ -> forall a. Maybe a
Nothing

instance CheckType () where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value ()))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsNull Value ()
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value ()
x; Match
_ -> forall a. Maybe a
Nothing

instance CheckType NixAttrs where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value NixAttrs))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsAttrs Value NixAttrs
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixAttrs
x; Match
_ -> forall a. Maybe a
Nothing

instance CheckType NixList where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value NixList))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsList Value NixList
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixList
x; Match
_ -> forall a. Maybe a
Nothing

instance CheckType NixFunction where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value NixFunction))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsFunction Value NixFunction
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixFunction
f; Match
_ -> forall a. Maybe a
Nothing

instance CheckType NixExternal where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value NixExternal))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsExternal Value NixExternal
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixExternal
x; Match
_ -> forall a. Maybe a
Nothing

instance CheckType NixFloat where
  checkType :: Ptr EvalState -> RawValue -> IO (Maybe (Value NixFloat))
checkType Ptr EvalState
es RawValue
v = Ptr EvalState -> RawValue -> IO Match
match' Ptr EvalState
es RawValue
v forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsFloat Value NixFloat
f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixFloat
f; Match
_ -> forall a. Maybe a
Nothing

assertType :: (HasCallStack, MonadIO m, CheckType t) => Ptr EvalState -> RawValue -> m (Value t)
assertType :: forall (m :: * -> *) t.
(HasCallStack, MonadIO m, CheckType t) =>
Ptr EvalState -> RawValue -> m (Value t)
assertType Ptr EvalState
es RawValue
v = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a.
CheckType a =>
Ptr EvalState -> RawValue -> IO (Maybe (Value a))
checkType Ptr EvalState
es RawValue
v) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Value t)
Nothing -> forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall a. HasCallStack => Text -> a
panic Text
"Unexpected type")
    Just Value t
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value t
x

class HasRawValueType s where
  getRawValueType :: Proxy s -> RawValueType

instance HasRawValueType NixString where
  getRawValueType :: Proxy NixString -> RawValueType
getRawValueType Proxy NixString
_ = RawValueType
String

instance HasRawValueType Int64 where
  getRawValueType :: Proxy NixInt -> RawValueType
getRawValueType Proxy NixInt
_ = RawValueType
Int

instance HasRawValueType Bool where
  getRawValueType :: Proxy Bool -> RawValueType
getRawValueType Proxy Bool
_ = RawValueType
Bool

instance HasRawValueType NixFloat where
  getRawValueType :: Proxy NixFloat -> RawValueType
getRawValueType Proxy NixFloat
_ = RawValueType
Float

instance HasRawValueType NixPath where
  getRawValueType :: Proxy NixPath -> RawValueType
getRawValueType Proxy NixPath
_ = RawValueType
Path

instance HasRawValueType NixAttrs where
  getRawValueType :: Proxy NixAttrs -> RawValueType
getRawValueType Proxy NixAttrs
_ = RawValueType
Attrs

instance HasRawValueType NixFunction where
  getRawValueType :: Proxy NixFunction -> RawValueType
getRawValueType Proxy NixFunction
_ = RawValueType
Lambda

instance HasRawValueType NixList where
  getRawValueType :: Proxy NixList -> RawValueType
getRawValueType Proxy NixList
_ = RawValueType
List

instance HasRawValueType () where
  getRawValueType :: Proxy () -> RawValueType
getRawValueType Proxy ()
_ = RawValueType
Null