Value.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}

module Language.Ginger.Value
where

import Control.Monad.Except (runExceptT, throwError, MonadError)
import Control.Monad.Reader (MonadReader (..))
import Control.Monad.Trans (MonadTrans, lift)
import Data.Aeson
          ( FromJSON (..)
          , FromJSONKey (..)
          , ToJSON (..)
          , FromJSONKeyFunction (..)
          , ToJSONKey (..)
          )
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Lazy as LBS
import Data.Foldable (fold)
import Data.Int
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Scientific (floatingOrInteger)
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Lazy as LText
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.Word
import GHC.Float (float2Double)
import System.Random (RandomGen (..), SplitGen (..))
import Test.Tasty.QuickCheck (Arbitrary (..))
import qualified Test.Tasty.QuickCheck as QC
import Text.Printf (PrintfArg (..))
import Text.Read (readMaybe)

import Language.Ginger.AST
import Language.Ginger.RuntimeError

data SomePRNG =
  forall g. (SplitGen g) => SomePRNG { unPRNG :: g }

instance RandomGen SomePRNG where
  genWord32 (SomePRNG g) =
    (i, SomePRNG g')
    where
      (i, g') = genWord32 g
  genWord64 (SomePRNG g) =
    (i, SomePRNG g')
    where
      (i, g') = genWord64 g

instance SplitGen SomePRNG where
  splitGen (SomePRNG g) =
    (SomePRNG a, SomePRNG b)
    where
      (a, b) = splitGen g

data Env m =
  Env
    { envVars :: !(Map Identifier (Value m))
    , envRootMay :: Maybe (Env m)
    }
  deriving (Eq, Ord)

envRoot :: Env m -> Env m
envRoot e =
  fromMaybe e $ envRootMay e

emptyEnv :: Env m
emptyEnv = Env mempty Nothing

instance Semigroup (Env m) where
  a <> b = Env
            { envVars = envVars a <> envVars b
            , envRootMay = envRootMay a <> envRootMay b
            }

instance Monoid (Env m) where
  mempty = emptyEnv

type TemplateLoader m = Text -> m (Maybe Text)

type Encoder m = Text -> m Encoded

data Context m =
  Context
    { contextEncode :: Encoder m
    , contextLoadTemplateFile :: TemplateLoader m
    , contextVars :: !(Map Identifier (Value m))
    , contextOutput :: !OutputPolicy
    }

data OutputPolicy
  = Quiet
  | Output
  deriving (Show, Eq, Ord, Enum, Bounded)

instance Semigroup OutputPolicy where
  Quiet <> Quiet = Quiet
  _ <> _ = Output

instance Monoid OutputPolicy where
  mappend = (<>)
  mempty = Quiet

emptyContext :: Applicative m => Context m
emptyContext =
  Context
    { contextEncode = pure . Encoded
    , contextLoadTemplateFile = const $ pure Nothing
    , contextVars = mempty
    , contextOutput = Output
    }

data Scalar
  = NoneScalar
  | BoolScalar !Bool
  | StringScalar !Text
  | EncodedScalar !Encoded
  | BytesScalar !ByteString
  | IntScalar !Integer
  | FloatScalar !Double
  deriving (Show, Eq, Ord)

instance FromJSON Scalar where
  parseJSON JSON.Null =
    pure NoneScalar
  parseJSON (JSON.Bool b) =
    pure $ BoolScalar b
  parseJSON (JSON.String s) =
    pure $ StringScalar s
  parseJSON (JSON.Number i) =
    pure $ either FloatScalar IntScalar $ floatingOrInteger i
  parseJSON x = JSON.unexpected x

instance ToJSON Scalar where
  toJSON NoneScalar = JSON.Null
  toJSON (BoolScalar b) = JSON.Bool b
  toJSON (StringScalar s) = toJSON s
  toJSON (EncodedScalar (Encoded e)) = JSON.String e
  toJSON (BytesScalar bs) =
    JSON.object
      [ ("@type", JSON.String "bytes")
      , ("@data", toJSON (BS.unpack bs))
      ]
  toJSON (IntScalar i) = toJSON i
  toJSON (FloatScalar f) = toJSON f

instance FromJSONKey Scalar where
  fromJSONKey = FromJSONKeyText StringScalar

instance ToJSONKey Scalar where
  toJSONKey = JSON.toJSONKeyText scalarToText

scalarToText :: Scalar -> Text
scalarToText NoneScalar = ""
scalarToText (BoolScalar True) = "true"
scalarToText (BoolScalar False) = "false"
scalarToText (StringScalar str) = str
scalarToText (BytesScalar b) = decodeUtf8 . Base64.encode $ b
scalarToText (EncodedScalar (Encoded e)) = e
scalarToText (IntScalar i) = Text.show i
scalarToText (FloatScalar f) = Text.show f

newtype RefID = RefID { unRefID :: Int }
  deriving (Show, Ord, Eq, Bounded, Enum)

-- | A value, as using by the interpreter.
data Value m
  = ScalarV !Scalar
  | ListV !(Vector (Value m))
  | DictV !(Map Scalar (Value m))
  | NativeV !(NativeObject m)
  | ProcedureV !(Procedure m)
  | TestV !(Test m)
  | FilterV !(Filter m)
  | MutableRefV !RefID
  deriving (Ord)

pattern NoneV :: Value m
pattern NoneV = ScalarV NoneScalar

pattern BoolV :: Bool -> Value m
pattern BoolV b = ScalarV (BoolScalar b)

pattern TrueV :: Value m
pattern TrueV = BoolV True

pattern FalseV :: Value m
pattern FalseV = BoolV False

pattern StringV :: Text -> Value m
pattern StringV v = ScalarV (StringScalar v)

pattern EncodedV :: Encoded -> Value m
pattern EncodedV v = ScalarV (EncodedScalar v)

pattern BytesV :: ByteString -> Value m
pattern BytesV v = ScalarV (BytesScalar v)

pattern IntV :: Integer -> Value m
pattern IntV v = ScalarV (IntScalar v)

pattern FloatV :: Double -> Value m
pattern FloatV v = ScalarV (FloatScalar v)

instance FromJSON (Value m) where
  parseJSON v@JSON.Object {} = DictV <$> parseJSON v
  parseJSON v@JSON.Array {} = ListV <$> parseJSON v
  parseJSON v = ScalarV <$> parseJSON v

instance ToJSON (Value m) where
  toJSON (ScalarV s) = toJSON s
  toJSON (ListV xs) = toJSON xs
  toJSON (DictV d) = toJSON d
  toJSON x = toJSON (show x)

instance Show (Value m) where
  show (ScalarV s) = show s
  show (ListV xs) = "ListV " ++ show xs
  show (DictV m) = "DictV " ++ show (Map.toAscList m)
  show (NativeV {}) = "<<native>>"
  show (ProcedureV (NativeProcedure oid _ _)) = "<<procedure:" ++ Text.unpack (unObjectID oid) ++ ">>"
  show (ProcedureV {}) = "<<procedure>>"
  show (TestV t) =
    "<<test" ++
      Text.unpack (
        maybe ""
          ((":" <>) . procedureDocName)
          (testDoc t)
      ) ++
      ">>"
  show (FilterV f) =
    "<<filter" ++
      Text.unpack (
        maybe ""
          ((":" <>) . procedureDocName)
          (filterDoc f)
      ) ++
      ">>"
  show (MutableRefV i) = show i

instance Eq (Value m) where
  ScalarV a == ScalarV b = a == b
  ListV a == ListV b = a == b
  DictV a == DictV b = a == b
  _ == _ = False

instance PrintfArg (Value m) where
  formatArg (BoolV b) = formatArg (fromEnum b)
  formatArg (IntV i) = formatArg i
  formatArg (FloatV f) = formatArg f
  formatArg (StringV t) = formatArg t
  formatArg (EncodedV (Encoded t)) = formatArg t
  formatArg ScalarV {} = formatArg ("" :: String)
  formatArg (ListV xs) = \fmt x -> foldr (flip formatArg fmt) x xs
  formatArg (DictV xs) = formatArg . ListV . V.fromList . Map.elems $ xs
  formatArg (NativeV {}) = formatArg ("[[object]]" :: String)
  formatArg (ProcedureV {}) = formatArg ("[[procedure]]" :: String)
  formatArg (FilterV {}) = formatArg ("[[filter]]" :: String)
  formatArg (TestV {}) = formatArg ("[[test]]" :: String)
  formatArg (MutableRefV {}) = formatArg ("[[ref]]" :: String)

tagNameOf :: Value m -> Text
tagNameOf ScalarV {} = "scalar"
tagNameOf ListV {} = "list"
tagNameOf DictV {} = "dict"
tagNameOf NativeV {} = "native"
tagNameOf ProcedureV {} = "procedure"
tagNameOf TestV {} = "test"
tagNameOf FilterV {} = "filter"
tagNameOf MutableRefV {} = "mutref"

traverseValue :: Monoid a => (Value m -> a) -> Value m -> a
traverseValue p v@(ListV xs) =
  p v <> fold (fmap (traverseValue p) xs)
traverseValue p v@(DictV m) =
  p v <> mconcat (map (traverseValue p . snd) $ Map.toList m)
traverseValue p v = p v

newtype ObjectID = ObjectID { unObjectID :: Text }
  deriving (Eq, Ord)

instance IsString ObjectID where
  fromString = ObjectID . Text.pack

data TypeDoc
  = TypeDocNone
  | TypeDocAny
  | TypeDocSingle !Text
  | TypeDocAlternatives !(Vector Text)
  deriving (Show, Eq)

instance ToValue TypeDoc m where
  toValue TypeDocNone = StringV "none"
  toValue TypeDocAny = StringV "any"
  toValue (TypeDocSingle t) = StringV t
  toValue (TypeDocAlternatives xs) =
    dictV ["oneof" .= xs]

data ArgumentDoc =
  ArgumentDoc
    { argumentDocName :: !Text
    , argumentDocType :: !(Maybe TypeDoc)
    , argumentDocDefault :: !(Maybe Text)
    , argumentDocDescription :: !Text
    }
    deriving (Show, Eq)

instance ToValue ArgumentDoc m where
  toValue a =
    dictV
      [ "name" .= argumentDocName a
      , "type" .= argumentDocType a
      , "default" .= argumentDocDefault a
      , "description" .= argumentDocDescription a
      ]

data ProcedureDoc =
  ProcedureDoc
    { procedureDocName :: !Text
    , procedureDocArgs :: !(Vector ArgumentDoc)
    , procedureDocReturnType :: !(Maybe TypeDoc)
    , procedureDocDescription :: !Text
    }
    deriving (Show, Eq)

instance Ord ProcedureDoc where
  compare = compareBy procedureDocName

instance ToValue ProcedureDoc m where
  toValue d =
    dictV
      [ "name" .= procedureDocName d
      , "args" .= procedureDocArgs d
      , "returnType" .= procedureDocReturnType d
      , "description" .= procedureDocDescription d
      ]

data Procedure m
  = NativeProcedure
        !ObjectID
        !(Maybe ProcedureDoc)
        !( [(Maybe Identifier, Value m)]
            -> Context m
            -> SomePRNG
            -> m (Either RuntimeError (Value m))
         )
  | GingerProcedure !(Env m) ![(Identifier, Maybe (Value m))] !Expr
  | NamespaceProcedure

namespaceProcedureDoc :: ProcedureDoc
namespaceProcedureDoc =
  ProcedureDoc
    { procedureDocName = "namespace"
    , procedureDocArgs = mempty
    , procedureDocReturnType = Just $ TypeDocSingle "namespace"
    , procedureDocDescription = Text.unlines
        [ "Create a namespace object."
        , "Namespace objects are mutable dictionary-like objects; the main " <>
          "use case for these is to work around the fact that `{% for %}` " <>
          "loops, macros, and other constructs establish local scopes, " <>
          "which means that any `{% set %}` invocations inside those will " <>
          "not propagate to the containing scope."
        , ""
        , "Using a namespace object, this problem can be solved like in this example:"
        , ""
        , "```"
        , "{% set ns = namespace() %}"
        , "{% for x in items %}"
        , "  {{ x.bar }}"
        , "  {% set ns.foo = x.foo %}"
        , "{% endfor %}"
        , "{{ ns.foo }}"
        , "```"
        ]
    }

instance Ord (Procedure m) where
  compare NamespaceProcedure NamespaceProcedure = EQ
  compare NamespaceProcedure _ = GT
  compare _ NamespaceProcedure = LT
  compare (GingerProcedure e1 args1 body1) (GingerProcedure e2 args2 body2) =
    compare (e1, args1, body1) (e2, args2, body2)
  compare GingerProcedure {} _ = GT
  compare _ GingerProcedure {} = LT
  compare (NativeProcedure oid1 _ _) (NativeProcedure oid2 _ _) =
    compare oid1 oid2

instance Eq (Procedure m) where
  NativeProcedure a _ _ == NativeProcedure b _ _ =
    a == b
  GingerProcedure env1 argspec1 body1 == GingerProcedure env2 argspec2 body2 =
    (env1, argspec1, body1) == (env2, argspec2, body2)
  NamespaceProcedure == NamespaceProcedure = True
  _ == _ = False

pureNativeProcedure :: Applicative m
                    => ObjectID
                    -> Maybe ProcedureDoc
                    -> ([(Maybe Identifier, Value m)] -> Either RuntimeError (Value m))
                    -> Procedure m
pureNativeProcedure oid doc f =
  NativeProcedure oid doc $ \args _ _ -> pure (f args)

nativeFunc :: (Monad m)
           => ObjectID
           -> Maybe ProcedureDoc
           -> (Value m -> m (Either RuntimeError (Value m)))
           -> Procedure m
nativeFunc oid doc f =
  NativeProcedure oid doc $ \args _ _ -> case args of
    [] ->
      pure . Left $
        ArgumentError
          "<native function>"
          "<positional argument>"
          "value"
          "end of arguments"
    [(_, x)] ->
      f x
    (_:(name, x):_) ->
      pure . Left $
        ArgumentError
          "<native function>"
          (maybe "<positional argument>" identifierName $ name)
          "end of arguments"
          (tagNameOf $ x)

pureNativeFunc :: (Applicative m)
               => ObjectID
               -> Maybe ProcedureDoc
               -> (Value m -> Either RuntimeError (Value m))
               -> Procedure m
pureNativeFunc oid doc f =
  NativeProcedure oid doc $ \args _ _ -> case args of
    [] ->
      pure . Left $
        ArgumentError
          "<native function>"
          "<positional argument>"
          "value"
          "end of arguments"
    [(_, x)] ->
      pure $ f x
    (_:(name, x):_) ->
      pure . Left $
        ArgumentError
          "<native function>"
          (maybe "<positional argument>" identifierName $ name)
          "end of arguments"
          (tagNameOf $ x)

pureNativeFunc2 :: (Applicative m)
               => ObjectID
               -> Maybe ProcedureDoc
               -> (Value m -> Value m -> Either RuntimeError (Value m))
               -> Procedure m
pureNativeFunc2 oid doc f =
  NativeProcedure oid doc $ \args _ _ -> case args of
    [] ->
      pure . Left $
        ArgumentError
          "<native function>"
          "<positional argument>"
          "value"
          "end of arguments"
    [_] ->
      pure . Left $
        ArgumentError
          "<native function>"
          "<positional argument>"
          "value"
          "end of arguments"
    [(_, x), (_, y)] ->
      pure $ f x y
    (_:_:(name, x):_) ->
      pure . Left $
        ArgumentError
          "<native function>"
          (maybe "<positional argument>" identifierName $ name)
          "end of arguments"
          (tagNameOf $ x)

type MetaFunc m a =
     Expr
  -> [(Maybe Identifier, Value m)]
  -> Context m
  -> Env m
  -> SomePRNG
  -> m (Either RuntimeError a)

type TestFunc m = MetaFunc m Bool

type FilterFunc m = MetaFunc m (Value m)

data Test m =
  NativeTest  
    { testDoc :: !(Maybe ProcedureDoc)
    , runTest :: !(TestFunc m)
    }

instance Eq (Test m) where
  a == b = compare a b == EQ

instance Ord (Test m) where
  compare = compareBy testDoc

data Filter m =
  NativeFilter
    { filterDoc :: !(Maybe ProcedureDoc)
    , runFilter :: !(FilterFunc m)
    }

instance Ord (Filter m) where
  compare = compareBy filterDoc

instance Eq (Filter m) where
  a == b = compare a b == EQ

data NativeObject m =
  NativeObject
    { nativeObjectID :: ObjectID
    , nativeObjectGetFieldNames :: m [Scalar]
    , nativeObjectGetField :: Scalar -> m (Maybe (Value m))
    , nativeObjectGetAttribute :: Identifier -> m (Maybe (Value m))
    , nativeObjectStringified :: m Text
    , nativeObjectEncoded :: Context m -> m Encoded
    , nativeObjectAsList :: m (Maybe (Vector (Value m)))
    , nativeObjectCall :: Maybe
                            (NativeObject m
                              -> [(Maybe Identifier, Value m)]
                              -> m (Either RuntimeError (Value m))
                            )
    , nativeObjectEq :: NativeObject m
                     -> NativeObject m
                     -> m (Either RuntimeError Bool)
    }

instance Eq (NativeObject m) where
  a == b = compare a b == EQ

instance Ord (NativeObject m) where
  compare = compareBy nativeObjectID

compareBy :: Ord b => (a -> b) -> a -> a -> Ordering
compareBy f a b = compare (f a) (f b)

nativeObjectAsDict :: Monad m
                   => NativeObject m
                   -> m (Maybe (Map Scalar (Value m)))
nativeObjectAsDict o = do
  fieldNames <- nativeObjectGetFieldNames o
  case fieldNames of
    [] -> pure Nothing
    keys -> do
      pairs <- mapM makePair keys
      pure . Just $ Map.fromList pairs
  where
    makePair k = (k,) . fromMaybe NoneV <$> nativeObjectGetField o k

(-->) :: obj -> (obj -> obj -> a) -> a
obj --> field = field obj obj

defNativeObject :: Monad m => ObjectID -> NativeObject m
defNativeObject oid =
  NativeObject
    { nativeObjectID = oid
    , nativeObjectGetFieldNames = pure []
    , nativeObjectGetField = \_ -> pure Nothing
    , nativeObjectGetAttribute = \_ -> pure Nothing
    , nativeObjectStringified = pure "<native object>"
    , nativeObjectEncoded = const $ pure (Encoded "[[native object]]")
    , nativeObjectAsList = pure Nothing
    , nativeObjectCall = Nothing
    , nativeObjectEq = \_self _other -> pure . Right $ False
    }

instance IsString Scalar where
  fromString = StringScalar . Text.pack

instance IsString (Value m) where
  fromString = ScalarV . fromString

class ToScalar a where
  toScalar :: a -> Scalar

instance ToScalar Scalar where
  toScalar = id

instance ToScalar () where
  toScalar () = NoneScalar

instance ToScalar Bool where
  toScalar = BoolScalar

instance ToScalar Integer where
  toScalar = IntScalar

toIntScalar :: Integral a => a -> Scalar
toIntScalar = IntScalar . fromIntegral

instance ToScalar Int where
  toScalar = toIntScalar

instance ToScalar Word where
  toScalar = toIntScalar

instance ToScalar Int8 where
  toScalar = toIntScalar

instance ToScalar Int16 where
  toScalar = toIntScalar

instance ToScalar Int32 where
  toScalar = toIntScalar

instance ToScalar Int64 where
  toScalar = toIntScalar

instance ToScalar Word8 where
  toScalar = toIntScalar

instance ToScalar Word16 where
  toScalar = toIntScalar

instance ToScalar Word32 where
  toScalar = toIntScalar

instance ToScalar Word64 where
  toScalar = toIntScalar

instance ToScalar Double where
  toScalar = FloatScalar

instance ToScalar Float where
  toScalar = FloatScalar . float2Double


instance ToScalar Text where
  toScalar = StringScalar

instance ToScalar LText.Text where
  toScalar = StringScalar . LText.toStrict

instance ToScalar ByteString where
  toScalar = BytesScalar

instance ToScalar LBS.ByteString where
  toScalar = BytesScalar . LBS.toStrict

instance ToScalar a => ToScalar (Maybe a) where
  toScalar Nothing = NoneScalar
  toScalar (Just x) = toScalar x

instance (ToScalar a, ToScalar b) => ToScalar (Either a b) where
  toScalar (Left x) = toScalar x
  toScalar (Right x) = toScalar x

instance ToScalar Identifier where
  toScalar = toScalar . identifierName

class FnArgValue a where
  fromArgValue :: Value m -> Either RuntimeError a

--------------------------------------------------------------------------------
-- FromValue
--------------------------------------------------------------------------------

class FromValue a m where
  fromValue :: Value m -> m (Either RuntimeError a)

--------------------------------------------------------------------------------
-- FromValue instances
--------------------------------------------------------------------------------

instance Applicative m => FromValue (Value m) m where
  fromValue = pure . Right

instance Applicative m => FromValue Scalar m where
  fromValue = pure . asScalarVal

instance Applicative m => FromValue Text m where
  fromValue = pure . asTextVal

instance Applicative m => FromValue Identifier m where
  fromValue = pure . fmap Identifier . asTextVal

instance Applicative m => FromValue Integer m where
  fromValue = pure . asIntVal "conversion to int"

instance Applicative m => FromValue Int m where
  fromValue = fmap (fmap fromInteger) . pure . asIntVal "conversion to int"

instance Applicative m => FromValue Double m where
  fromValue = pure . asFloatVal "conversion to float"

instance Applicative m => FromValue Bool m where
  fromValue = pure . asBoolVal "conversion to bool"

instance Applicative m => FromValue () m where
  fromValue NoneV = pure $ Right ()
  fromValue x = pure . Left $ TagError "" "fromValue" (tagNameOf x)

instance (Applicative m, FromValue a m) => FromValue (Maybe a) m where
  fromValue NoneV = pure $ Right Nothing
  fromValue x = fmap (fmap Just) $ fromValue x

instance (Monad m, FromValue l m, FromValue r m) => FromValue (Either l r) m where
  fromValue v = do
    fromValue v >>= \case
      Right r -> pure . Right $ Right r
      _ -> do
        fromValue v >>= \case
          Left e -> pure $ Left e
          Right l -> pure . Right $ Left l

instance (Monad m, FromValue a m) => FromValue [a] m where
  fromValue x = runExceptT $ do
    items :: [Value m] <- eitherExceptM (asListVal x)
    mapM (eitherExceptM . fromValue) items

instance (Monad m, FromValue a m) => FromValue (Vector a) m where
  fromValue x = runExceptT $ do
    items :: Vector (Value m) <- eitherExceptM (asVectorVal x)
    V.mapM (eitherExceptM . fromValue) items

instance (Monad m, FromValue a m) => FromValue (Map Scalar a) m where
  fromValue x = runExceptT $ do
    items :: Map Scalar (Value m) <- eitherExceptM (asDictVal x)
    Map.fromList <$> mapM (\(k, v) -> (k,) <$> eitherExceptM (fromValue v)) (Map.toList items)

--------------------------------------------------------------------------------
-- ToValue
--------------------------------------------------------------------------------

class ToValue a m where
  toValue :: a -> Value m

instance ToValue (Value m) m where
  toValue = id

class FnToValue a m where
  fnToValue :: ObjectID -> Maybe ProcedureDoc -> a -> Value m

--------------------------------------------------------------------------------
-- ToValue Scalar instances
--------------------------------------------------------------------------------

instance ToValue Scalar a where
  toValue = ScalarV

instance ToValue () a where
  toValue = ScalarV . toScalar

instance ToValue Bool a where
  toValue = ScalarV . toScalar

instance ToValue Integer a where
  toValue = ScalarV . toScalar

instance ToValue Int a where
  toValue = ScalarV . toScalar

instance ToValue Int8 a where
  toValue = ScalarV . toScalar

instance ToValue Int16 a where
  toValue = ScalarV . toScalar

instance ToValue Int32 a where
  toValue = ScalarV . toScalar

instance ToValue Int64 a where
  toValue = ScalarV . toScalar

instance ToValue Word a where
  toValue = ScalarV . toScalar

instance ToValue Word8 a where
  toValue = ScalarV . toScalar

instance ToValue Word16 a where
  toValue = ScalarV . toScalar

instance ToValue Word32 a where
  toValue = ScalarV . toScalar

instance ToValue Word64 a where
  toValue = ScalarV . toScalar

instance ToValue Double a where
  toValue = ScalarV . toScalar

instance ToValue Float a where
  toValue = ScalarV . toScalar

instance ToValue Text a where
  toValue = ScalarV . toScalar

instance ToValue LText.Text a where
  toValue = ScalarV . toScalar

instance ToValue ByteString a where
  toValue = ScalarV . toScalar

instance ToValue LBS.ByteString a where
  toValue = ScalarV . toScalar

instance ToValue Identifier a where
  toValue = ScalarV . toScalar

--------------------------------------------------------------------------------
-- Compound / derived instances
--------------------------------------------------------------------------------

instance ToValue a m => ToValue (Maybe a) m where
  toValue Nothing = ScalarV NoneScalar
  toValue (Just x) = toValue x

instance (ToValue a m, ToValue b m) => ToValue (Either a b) m where
  toValue (Left x) = toValue x
  toValue (Right x) = toValue x

instance ToValue a m => ToValue (Vector a) m where
  toValue = ListV . fmap toValue

instance ToValue a m => ToValue [a] m where
  toValue = ListV . V.fromList . map toValue

instance (ToValue a1 m, ToValue a2 m)
         => ToValue (a1, a2) m where
  toValue (x1, x2) =
    ListV $ V.fromList [toValue x1, toValue x2]

instance (ToValue a1 m, ToValue a2 m, ToValue a3 m)
         => ToValue (a1, a2, a3) m where
  toValue (x1, x2, x3) =
    ListV $ V.fromList [toValue x1, toValue x2, toValue x3]

instance (ToValue a1 m, ToValue a2 m, ToValue a3 m, ToValue a4 m)
         => ToValue (a1, a2, a3, a4) m where
  toValue (x1, x2, x3, x4) =
    ListV $ V.fromList [toValue x1, toValue x2, toValue x3, toValue x4]

instance (ToValue a1 m, ToValue a2 m, ToValue a3 m, ToValue a4 m, ToValue a5 m)
         => ToValue (a1, a2, a3, a4, a5) m where
  toValue (x1, x2, x3, x4, x5) =
    ListV $ V.fromList [toValue x1, toValue x2, toValue x3, toValue x4, toValue x5]

instance (ToValue a1 m, ToValue a2 m, ToValue a3 m, ToValue a4 m, ToValue a5 m, ToValue a6 m)
         => ToValue (a1, a2, a3, a4, a5, a6) m where
  toValue (x1, x2, x3, x4, x5, x6) =
    ListV $ V.fromList [toValue x1, toValue x2, toValue x3, toValue x4, toValue x5, toValue x6]

instance (ToValue a1 m, ToValue a2 m, ToValue a3 m, ToValue a4 m, ToValue a5 m, ToValue a6 m, ToValue a7 m)
         => ToValue (a1, a2, a3, a4, a5, a6, a7) m where
  toValue (x1, x2, x3, x4, x5, x6, x7) =
    ListV $ V.fromList [toValue x1, toValue x2, toValue x3, toValue x4, toValue x5, toValue x6, toValue x7]

instance (ToScalar k, ToValue v m) => ToValue (Map k v) m where
  toValue = DictV . Map.mapKeys toScalar . Map.map toValue

instance ToValue v m => ToValue (Map LText.Text v) m where
  toValue = toValue . Map.mapKeys LText.toStrict

instance ToValue v m => ToValue (Map String v) m where
  toValue = toValue . Map.mapKeys Text.pack

--------------------------------------------------------------------------------
-- Function instances
--------------------------------------------------------------------------------

class ToNativeProcedure m a where
  toNativeProcedure :: a
                    -> [(Maybe Identifier, Value m)]
                    -> Context m
                    -> SomePRNG
                    -> m (Either RuntimeError (Value m))

instance Applicative m => ToNativeProcedure m (Value m) where
  toNativeProcedure val [] _ _ =
    pure (Right val)
  toNativeProcedure _ _ _ _ =
    pure . Left $
      ArgumentError "<native function>" "<positional argument>" "end of arguments" "value"

instance Applicative m => ToNativeProcedure m (m (Value m)) where
  toNativeProcedure action [] _ _ =
    Right <$> action
  toNativeProcedure _ _ _ _ =
    pure . Left $
      ArgumentError "<native function>" "<positional argument>" "end of arguments" "value"

instance Applicative m => ToNativeProcedure m (m (Either RuntimeError (Value m))) where
  toNativeProcedure action [] _ _ =
    action
  toNativeProcedure _ _ _ _ =
    pure . Left $
      ArgumentError "<native function>" "<positional argument>" "end of arguments" "value"

instance (Applicative m, ToNativeProcedure m a) => ToNativeProcedure m (Value m -> a) where
  toNativeProcedure _ [] _ _ =
    pure . Left $
      ArgumentError "<native function>" "<positional argument>" "value" "end of arguments"
  toNativeProcedure _ ((Just _, _):_) _ _ =
    pure . Left $
      ArgumentError "<native function>" "<positional argument>" "positional argument" "named argument"
  toNativeProcedure f ((Nothing, v):xs) ctx rng =
    toNativeProcedure (f v) xs ctx rng


instance Applicative m => FnToValue (Value m -> Value m) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> Value m) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> Value m -> Value m) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f


instance Applicative m => FnToValue (Value m -> m (Value m)) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> m (Value m)) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m -> m (Value m)) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> m (Value m)) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> Value m -> m (Value m)) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f


instance Applicative m => FnToValue (Value m -> m (Either RuntimeError (Value m))) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> m (Either RuntimeError (Value m))) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m -> m (Either RuntimeError (Value m))) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> m (Either RuntimeError (Value m))) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

instance Applicative m => FnToValue (Value m -> Value m -> Value m -> Value m -> Value m -> m (Either RuntimeError (Value m))) m where
  fnToValue oid doc f = ProcedureV . NativeProcedure oid doc . toNativeProcedure $ f

--------------------------------------------------------------------------------
-- Procedure helpers
--------------------------------------------------------------------------------

eitherExcept :: (Monad m, MonadError e (t m))
             => Either e a -> t m a
eitherExcept = either throwError pure

eitherExceptM :: (Monad m, MonadError e (t m), MonadTrans t)
              => m (Either e a) -> t m a
eitherExceptM = (>>= eitherExcept) . lift

resolveArgs :: Text
            -> [(Identifier, Maybe (Value m))]
            -> [(Maybe Identifier, Value m)]
            -> Either RuntimeError (Map Identifier (Value m))
resolveArgs context specs args =
  let kwargs0 = Map.fromList [(k, v) | (Just k, v) <- args]
      varargs0 = [v | (Nothing, v) <- args]
  in go specs kwargs0 varargs0
  where
    go ((argName, defVal):xs) kwargs varargs =
      case Map.lookup argName kwargs of
        Nothing ->
          -- positional argument
          case varargs of
            [] ->
              -- No more arguments passed, look for default value
              maybe
                -- No default, argument required
                (Left $
                  ArgumentError
                    context
                    (identifierName argName)
                    "argument"
                    "end of arguments"
                )
                -- Default exists, use it.
                (\val ->
                  Map.insert argName val <$> go xs kwargs varargs
                )
                defVal
            (v:varargs') ->
              -- Argument passed, use it.
              Map.insert argName v <$> go xs kwargs varargs'
        Just v ->
          -- Keyword argument found.
          Map.insert argName v <$> go xs (Map.delete argName kwargs) varargs

    go [] kwargs varargs =
        -- Map remaining arguments to @varargs@ and @kwargs@.
        Right $ Map.fromList
          [ ("varargs", ListV $ V.fromList varargs)
          , ("kwargs", DictV (Map.mapKeys (toScalar . identifierName) kwargs))
          ]

leftNaN :: Double -> Either RuntimeError Double
leftNaN c | isNaN c = Left $ NumericError "<unknown>" "not a number"
leftNaN c | isInfinite c = Left $ NumericError "<unknown>" "infinity"
leftNaN c = Right c

numericFunc :: Monad m
             => (Integer -> Integer)
             -> (Double -> Double)
             -> Value m
             -> Either RuntimeError (Value m)
numericFunc f g =
  numericFuncCatch f' g'
  where
    f' x = Right (f x)
    g' x = Right (g x)

numericFuncCatch :: Monad m
                  => (Integer -> Either RuntimeError Integer)
                  -> (Double -> Either RuntimeError Double)
                  -> Value m
                  -> Either RuntimeError (Value m)
numericFuncCatch f _ (IntV a) = IntV <$> f a
numericFuncCatch _ f (FloatV a) = FloatV <$> (leftNaN =<< f a)
numericFuncCatch _ _ a = Left (TagError "<unknown>" "number" (tagNameOf a))

asOptionalVal :: (Value m -> Either RuntimeError a) -> Value m -> Either RuntimeError (Maybe a)
asOptionalVal _ NoneV = Right Nothing
asOptionalVal asVal x = Just <$> asVal x

asIntVal :: Text -> Value m -> Either RuntimeError Integer
asIntVal _ (IntV a) = Right a
asIntVal context x = Left $ TagError context "int" (tagNameOf x)

asFloatVal :: Text -> Value m -> Either RuntimeError Double
asFloatVal _ (FloatV a) = Right a
asFloatVal _ (IntV a) = Right (fromInteger a)
asFloatVal context x = Left $ TagError context "float" (tagNameOf x)

asFloatValLenient :: Double -> Value m -> Double
asFloatValLenient _ (FloatV a) = a
asFloatValLenient _ (IntV a) = fromInteger a
asFloatValLenient def (StringV a) = fromMaybe def $ readMaybe (Text.unpack a)
asFloatValLenient def _ = def

asBoolVal :: Text -> Value m -> Either RuntimeError Bool
asBoolVal _ (BoolV a) = Right a
asBoolVal _ NoneV = Right False
asBoolVal context x = Left $ TagError context "bool" (tagNameOf x)

-- | Lenient version of 'asBoolVal', will also work on strings, numbers, lists,
-- and dicts.
asTruthVal :: Text -> Value m -> Either RuntimeError Bool
asTruthVal _ (BoolV a) = Right a
asTruthVal _ NoneV = Right False
asTruthVal _ (StringV t) = Right . not . Text.null $ t
asTruthVal _ (BytesV t) = Right . not . BS.null $ t
asTruthVal _ (EncodedV (Encoded t)) = Right . not . Text.null $ t
asTruthVal _ (IntV i) = Right (i /= 0)
asTruthVal _ (FloatV i) = Right (i /= 0)
asTruthVal _ (ListV xs) = Right . not . V.null $ xs
asTruthVal _ (DictV xs) = Right . not . Map.null $ xs
asTruthVal context x = Left $ TagError context"bool" (tagNameOf x)

asVectorVal :: Monad m => Value m -> m (Either RuntimeError (Vector (Value m)))
asVectorVal (ListV a) = pure . Right $ a
asVectorVal (NativeV n) =
  maybe
    (Left $ TagError "conversion to list" "list" "non-list native object")
    Right <$>
    nativeObjectAsList n
asVectorVal x = pure . Left $ TagError "conversion to list" "list" (tagNameOf x)

asListVal :: Monad m => Value m -> m (Either RuntimeError [Value m])
asListVal (ListV a) = pure . Right $ V.toList a
asListVal (NativeV n) =
  maybe
    (Left $ TagError "conversion to list" "list" "non-list native object")
    (Right . V.toList) <$>
    nativeObjectAsList n
asListVal x = pure . Left $ TagError "conversion to list" "list" (tagNameOf x)

asDictVal :: Monad m => Value m -> m (Either RuntimeError (Map Scalar (Value m)))
asDictVal (DictV a) = pure $ Right a
asDictVal (NativeV n) =
  maybe
    (Left $ TagError "conversion to dict" "dict" "non-dict native object")
    Right <$>
    nativeObjectAsDict n
asDictVal x = pure . Left $ TagError "conversion to dict" "dict" (tagNameOf x)

asTextVal :: Value m -> Either RuntimeError Text
asTextVal (StringV a) = Right a
asTextVal (EncodedV (Encoded a)) = Right a
asTextVal (IntV a) = Right (Text.show a)
asTextVal (FloatV a) = Right (Text.show a)
asTextVal NoneV = Right ""
asTextVal x = Left $ TagError "conversion to string" "string" (tagNameOf x)

asScalarVal :: Value m -> Either RuntimeError Scalar
asScalarVal (ScalarV a) = Right a
asScalarVal x = Left $ TagError "conversion to scalar" "scalar" (tagNameOf x)

intFunc :: (Monad m, ToValue a m)
         => (Integer -> Either RuntimeError a)
         -> Value m
         -> Either RuntimeError (Value m)
intFunc f a = toValue <$> (asIntVal "conversion to int" a >>= f)

floatFunc :: (Monad m, ToValue a m)
         => (Double -> Either RuntimeError a)
         -> Value m
         -> Either RuntimeError (Value m)
floatFunc f a = toValue <$> (asFloatVal "conversion to float" a >>= f)

boolFunc :: (Monad m, ToValue a m)
         => (Bool -> a)
         -> Value m
         -> Either RuntimeError (Value m)
boolFunc f (BoolV a) = pure . toValue $ f a
boolFunc _ a = Left (TagError "bool function" "bool" (tagNameOf a))

textFunc :: (Monad m, ToValue a m)
         => (Text -> Either RuntimeError a)
         -> Value m
         -> Either RuntimeError (Value m)
textFunc f (StringV a) = toValue <$> f a
textFunc f (EncodedV (Encoded a)) = toValue <$> f a
textFunc f (IntV a) = toValue <$> f (Text.show a)
textFunc f (FloatV a) = toValue <$> f (Text.show a)
textFunc f NoneV = toValue <$> f ""
textFunc _ a = Left (TagError "text function" "int" (tagNameOf a))

dictFunc :: (Monad m, ToValue a m)
         => (Map Scalar (Value m) -> Either RuntimeError a)
         -> Value m
         -> Either RuntimeError (Value m)
dictFunc f (DictV a) = toValue <$> f a
dictFunc _ a = Left (TagError "dict function" "dict" (tagNameOf a))

numericFunc2 :: Monad m
             => (Integer -> Integer -> Integer)
             -> (Double -> Double -> Double)
             -> Value m
             -> Value m
             -> Either RuntimeError (Value m)
numericFunc2 f g =
  numericFunc2Catch f' g'
  where
    f' x y = Right (f x y)
    g' x y = Right (g x y)

numericFunc2Catch :: Monad m
                  => (Integer -> Integer -> Either RuntimeError Integer)
                  -> (Double -> Double -> Either RuntimeError Double)
                  -> Value m
                  -> Value m
                  -> Either RuntimeError (Value m)
numericFunc2Catch f _ (IntV a) (IntV b) = IntV <$> (a `f` b)
numericFunc2Catch _ f (FloatV a) (FloatV b) = FloatV <$> (leftNaN =<< a `f` b)
numericFunc2Catch _ f (IntV a) (FloatV b) = FloatV <$> (leftNaN =<< fromInteger a `f` b)
numericFunc2Catch _ f (FloatV a) (IntV b) = FloatV <$> (leftNaN =<< a `f` fromInteger b)
numericFunc2Catch _ _ (FloatV _) b = Left (TagError "numeric function" "number" (tagNameOf b))
numericFunc2Catch _ _ (IntV _) b = Left (TagError "numeric function" "number" (tagNameOf b))
numericFunc2Catch _ _ b _ = Left (TagError "numeric function" "number" (tagNameOf b))

intFunc2 :: Monad m
         => (Integer -> Integer -> Either RuntimeError Integer)
         -> Value m
         -> Value m
         -> Either RuntimeError (Value m)
intFunc2 f a b = do
  x <- asIntVal "argument conversion to int" a
  y <- asIntVal "argument conversion to int" b
  IntV <$> f x y

floatFunc2 :: Monad m
         => (Double -> Double -> Either RuntimeError Double)
         -> Value m
         -> Value m
         -> Either RuntimeError (Value m)
floatFunc2 f (IntV a) b = floatFunc2 f (FloatV $ fromIntegral a) b
floatFunc2 f (FloatV a) (IntV b) = floatFunc2 f (FloatV a) (FloatV $ fromIntegral b)
floatFunc2 f (FloatV a) (FloatV b) = FloatV <$> (a `f` b)
floatFunc2 _ (FloatV _) b = Left (TagError "floating-point function" "float" (tagNameOf b))
floatFunc2 _ b _ = Left (TagError "floating-point function" "float" (tagNameOf b))

boolFunc2 :: Monad m
         => (Bool -> Bool -> Bool)
         -> Value m
         -> Value m
         -> Either RuntimeError (Value m)
boolFunc2 f a b = BoolV <$> (f <$> asBoolVal "conversion to bool" a <*> asBoolVal "conversion to bool" b)

native :: (Monad m, MonadTrans t, MonadError RuntimeError (t m))
       => m (Either RuntimeError a)
       -> t m a
native action =
  lift action >>= either throwError pure

encodeText :: ( Monad m
              , MonadError RuntimeError (t m)
              , MonadTrans t
              , MonadReader (Context m) (t m)
              )
           => Text
           -> t m Encoded
encodeText str = do
  ctx <- ask
  encodeTextWith ctx str

encodeTextWith :: ( Monad m
              , MonadError RuntimeError (t m)
              , MonadTrans t
              )
           => Context m
           -> Text
           -> t m Encoded
encodeTextWith ctx str = do
  let encoder = contextEncode ctx
  native (Right <$> encoder str)

encode :: ( Monad m
          , MonadError RuntimeError (t m)
          , MonadTrans t
          , MonadReader (Context m) (t m)
          )
       => Value m
       -> t m Encoded
encode v = do
  ctx <- ask
  encodeWith ctx v

encodeWith :: ( Monad m
          , MonadError RuntimeError (t m)
          , MonadTrans t
          )
       => Context m
       -> Value m
       -> t m Encoded
encodeWith _ (EncodedV e) = pure e
encodeWith ctx (NativeV n) = native (Right <$> nativeObjectEncoded n ctx)
encodeWith _ (ProcedureV _) = pure $ Encoded "[[procedure]]"
encodeWith ctx v = encodeTextWith ctx =<< stringify v

--------------------------------------------------------------------------------
-- String / Encoding helpers
--------------------------------------------------------------------------------

stringify :: ( Monad m
             , MonadError RuntimeError (t m)
             , MonadTrans t
             )
          => Value m
          -> t m Text
stringify NoneV = pure ""
stringify TrueV = pure "true"
stringify FalseV = pure ""
stringify (StringV str) = pure str
stringify (BytesV b) =
  pure . decodeUtf8 . Base64.encode $ b
stringify (EncodedV (Encoded e)) =
  pure e
stringify (IntV i) = pure $ Text.show i
stringify (FloatV f) = pure $ Text.show f
stringify (ScalarV s) = pure . Text.show $ s
stringify (ListV xs) = do
  elems <- V.mapM stringify xs
  pure $ Text.intercalate ", " $ V.toList elems
stringify (DictV m) = do
  elems <- mapM stringifyKV $ Map.toAscList m
  pure $ Text.intercalate ", " elems
stringify (NativeV n) =
  native (Right <$> nativeObjectStringified n)
stringify (ProcedureV {}) =
  pure $ "[[procedure]]"
stringify (TestV _) =
  pure "[[test]]"
stringify (FilterV _) =
  pure "[[filter]]"
stringify (MutableRefV ref) =
  pure $ "[[ref#]]" <> Text.show (unRefID ref)

stringifyKV :: ( Monad m
               , MonadError RuntimeError (t m)
               , MonadTrans t
               )
            => (Scalar, Value m)
            -> t m Text
stringifyKV (k, v) = do
  kStr <- stringify (ScalarV k)
  vStr <- stringify v
  pure $ kStr <> ": " <> vStr


--------------------------------------------------------------------------------
-- Dictionary helpers
--------------------------------------------------------------------------------

dictV :: [(Scalar, Value m)] -> Value m
dictV items = DictV $ Map.fromList items

infixr 8 .=

(.=) :: (ToValue v m) => Scalar -> v -> (Scalar, Value m)
k .= v = (k, toValue v)

--------------------------------------------------------------------------------
-- Arbitrary instances
--------------------------------------------------------------------------------

instance Arbitrary Scalar where
  arbitrary =
    QC.oneof
      [ pure NoneScalar
      , BoolScalar <$> arbitrary
      , StringScalar . Text.pack <$> QC.listOf arbitrary
      , EncodedScalar . Encoded . Text.pack <$> QC.listOf arbitrary
      , BytesScalar . BS.pack <$> QC.listOf arbitrary
      , IntScalar <$> arbitrary
      , FloatScalar <$> arbitrary
      ]

  shrink = \case
    BoolScalar True -> [BoolScalar False]
    StringScalar str | Text.null str -> []
    StringScalar str -> [StringScalar $ Text.init str]
    EncodedScalar (Encoded str) | Text.null str -> []
    EncodedScalar (Encoded str) -> [EncodedScalar . Encoded $ Text.init str]
    BytesScalar str | BS.null str -> []
    BytesScalar str -> [BytesScalar $ BS.init str]
    IntScalar i -> NoneScalar : (IntScalar <$> shrink i)
    FloatScalar f -> NoneScalar : (FloatScalar <$> shrink f)
    NoneScalar -> []
    _ -> [NoneScalar]

instance Monad m => Arbitrary (Value m) where
  arbitrary =
    QC.oneof
      [ pure NoneV
      , ScalarV <$> arbitrary
      , ListV . V.fromList <$> fuelledList arbitrary
      , DictV . Map.fromList <$> fuelledList arbitrary
      , NativeV <$> arbitraryNative
      , ProcedureV <$> arbitraryNativeProcedure
      ]

arbitraryNativeProcedure :: Monad m => QC.Gen (Procedure m)
arbitraryNativeProcedure = do
  retval <- QC.scale (`div` 2) arbitrary
  oid <- ObjectID . ("arbitrary:" <>) . identifierName <$> arbitrary
  pure $ NativeProcedure oid Nothing (\_ _ _ -> pure (Right retval))

arbitraryNative :: Monad m => QC.Gen (NativeObject m)
arbitraryNative = do
  objectID <- ObjectID . identifierName <$> arbitrary
  pure (defNativeObject objectID)
    { nativeObjectGetFieldNames = pure ["id"]
    , nativeObjectGetField = \case
        "id" -> pure . Just . toValue . unObjectID $ objectID
        _ -> pure Nothing
    , nativeObjectStringified = pure $ unObjectID objectID
    , nativeObjectEq = \self other -> do
        otherID <- nativeObjectGetField other "id"
        selfID <- nativeObjectGetField self "id"
        pure . Right $ otherID == selfID
    }