{-# 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"
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 = RawValue -> Value a
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 =
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"
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 }|]
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