{-# 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"
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
unsafeAssertType :: RawValue -> Value a
unsafeAssertType :: forall a. RawValue -> Value a
unsafeAssertType = forall a. RawValue -> Value a
Value
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)
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"
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 }|]
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