{-# 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,
    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 = RawValue -> Value a
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 =
  Ptr EvalState -> RawValue -> IO (Either SomeException ())
forall a.
Exception a =>
Ptr EvalState -> RawValue -> IO (Either a ())
forceValue Ptr EvalState
es RawValue
v IO (Either SomeException ())
-> (Either SomeException () -> IO (Either SomeException Match))
-> IO (Either SomeException Match)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left SomeException
e -> Either SomeException Match -> IO (Either SomeException Match)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeException -> Either SomeException Match
forall a b. a -> Either a b
Left SomeException
e)
    Right ()
_ ->
      RawValue -> IO RawValueType
rawValueType RawValue
v IO RawValueType
-> (RawValueType -> Either SomeException Match)
-> IO (Either SomeException Match)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        RawValueType
Int -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixInt -> Match
IsInt (Value NixInt -> Match) -> Value NixInt -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixInt
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Bool -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value Bool -> Match
IsBool (Value Bool -> Match) -> Value Bool -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value Bool
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
String -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixString -> Match
IsString (Value NixString -> Match) -> Value NixString -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixString
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Path -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixPath -> Match
IsPath (Value NixPath -> Match) -> Value NixPath -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixPath
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Null -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value () -> Match
IsNull (Value () -> Match) -> Value () -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value ()
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Attrs -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixAttrs -> Match
IsAttrs (Value NixAttrs -> Match) -> Value NixAttrs -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixAttrs
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
List -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixList -> Match
IsList (Value NixList -> Match) -> Value NixList -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixList
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Thunk -> SomeException -> Either SomeException Match
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Match)
-> SomeException -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
SomeException (IOError -> SomeException) -> IOError -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Could not force Nix thunk" -- FIXME: custom exception?
        RawValueType
App -> SomeException -> Either SomeException Match
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Match)
-> SomeException -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
SomeException (IOError -> SomeException) -> IOError -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Could not force Nix thunk (App)"
        RawValueType
Blackhole ->
          SomeException -> Either SomeException Match
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Match)
-> SomeException -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
SomeException (IOError -> SomeException) -> IOError -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"Could not force Nix thunk (Blackhole)"
        RawValueType
Lambda -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixFunction -> Match
IsFunction (Value NixFunction -> Match) -> Value NixFunction -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixFunction
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
PrimOp -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixFunction -> Match
IsFunction (Value NixFunction -> Match) -> Value NixFunction -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixFunction
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
PrimOpApp -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixFunction -> Match
IsFunction (Value NixFunction -> Match) -> Value NixFunction -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixFunction
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
External -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixExternal -> Match
IsExternal (Value NixExternal -> Match) -> Value NixExternal -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixExternal
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Float -> Match -> Either SomeException Match
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Match -> Either SomeException Match)
-> Match -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ Value NixFloat -> Match
IsFloat (Value NixFloat -> Match) -> Value NixFloat -> Match
forall a b. (a -> b) -> a -> b
$ RawValue -> Value NixFloat
forall a. RawValue -> Value a
unsafeAssertType RawValue
v
        RawValueType
Other ->
          SomeException -> Either SomeException Match
forall a b. a -> Either a b
Left (SomeException -> Either SomeException Match)
-> SomeException -> Either SomeException Match
forall a b. (a -> b) -> a -> b
$ IOError -> SomeException
forall e. Exception e => e -> SomeException
SomeException (IOError -> SomeException) -> IOError -> 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 IO (Either SomeException Match)
-> (Either SomeException Match -> IO Match) -> IO Match
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case Left SomeException
e -> SomeException -> IO Match
forall e a. Exception e => e -> IO a
throwIO SomeException
e; Right Match
a -> Match -> IO Match
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 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/=)
    (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.exp| int { $(Value *v)->boolean ? 1 : 0 }|]

-- NOT coerceToString
getStringIgnoreContext :: Value NixString -> IO ByteString
getStringIgnoreContext :: Value NixString -> IO ByteString
getStringIgnoreContext (Value (RawValue Ptr Value'
v)) =
  IO CString -> IO ByteString
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 CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/=)
    (CInt -> Bool) -> IO CInt -> IO 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 IO Match
-> (Match -> Maybe (Value NixInt)) -> IO (Maybe (Value NixInt))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsInt Value NixInt
x -> Value NixInt -> Maybe (Value NixInt)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixInt
x; Match
_ -> Maybe (Value NixInt)
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 IO Match
-> (Match -> Maybe (Value Bool)) -> IO (Maybe (Value Bool))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsBool Value Bool
x -> Value Bool -> Maybe (Value Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value Bool
x; Match
_ -> Maybe (Value Bool)
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 IO Match
-> (Match -> Maybe (Value NixString))
-> IO (Maybe (Value NixString))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsString Value NixString
x -> Value NixString -> Maybe (Value NixString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixString
x; Match
_ -> Maybe (Value NixString)
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 IO Match
-> (Match -> Maybe (Value NixPath)) -> IO (Maybe (Value NixPath))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsPath Value NixPath
x -> Value NixPath -> Maybe (Value NixPath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixPath
x; Match
_ -> Maybe (Value NixPath)
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 IO Match -> (Match -> Maybe (Value ())) -> IO (Maybe (Value ()))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsNull Value ()
x -> Value () -> Maybe (Value ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value ()
x; Match
_ -> Maybe (Value ())
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 IO Match
-> (Match -> Maybe (Value NixAttrs)) -> IO (Maybe (Value NixAttrs))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsAttrs Value NixAttrs
x -> Value NixAttrs -> Maybe (Value NixAttrs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixAttrs
x; Match
_ -> Maybe (Value NixAttrs)
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 IO Match
-> (Match -> Maybe (Value NixList)) -> IO (Maybe (Value NixList))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsList Value NixList
x -> Value NixList -> Maybe (Value NixList)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixList
x; Match
_ -> Maybe (Value NixList)
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 IO Match
-> (Match -> Maybe (Value NixFunction))
-> IO (Maybe (Value NixFunction))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsFunction Value NixFunction
f -> Value NixFunction -> Maybe (Value NixFunction)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixFunction
f; Match
_ -> Maybe (Value NixFunction)
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 IO Match
-> (Match -> Maybe (Value NixExternal))
-> IO (Maybe (Value NixExternal))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsExternal Value NixExternal
x -> Value NixExternal -> Maybe (Value NixExternal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixExternal
x; Match
_ -> Maybe (Value NixExternal)
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 IO Match
-> (Match -> Maybe (Value NixFloat)) -> IO (Maybe (Value NixFloat))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case IsFloat Value NixFloat
f -> Value NixFloat -> Maybe (Value NixFloat)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value NixFloat
f; Match
_ -> Maybe (Value NixFloat)
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
  IO (Maybe (Value t)) -> m (Maybe (Value t))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr EvalState -> RawValue -> IO (Maybe (Value t))
forall a.
CheckType a =>
Ptr EvalState -> RawValue -> IO (Maybe (Value a))
checkType Ptr EvalState
es RawValue
v) m (Maybe (Value t))
-> (Maybe (Value t) -> m (Value t)) -> m (Value t)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Value t)
Nothing -> (HasCallStack => m (Value t)) -> m (Value t)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (Text -> m (Value t)
forall a. HasCallStack => Text -> a
panic Text
"Unexpected type")
    Just Value t
x -> Value t -> m (Value t)
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