content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE RecursiveDo #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE AllowAmbiguousTypes #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE LambdaCase #-}
  module Godot.Nativescript
    ( ClassName
    , GFunc
    , GdnativeHandle
    , NativeScript(..)
    , ClassMethod(..)
    , ClassProperty(..)
    , ClassSignal(..)
    , RPC(..)
    , Registerer(..)
    , PropertyAttributes(..)
    , SignalArgument(..)
    , deriveBase
    , func
    , method
    , method0
    , method1
    , method2
    , method3
    , method4
    , method5
    , nameOf
    , registerClass
    , registerProperty
    , registerSignal
    , registerMethod
    , signal
    , tryCast
    , tryCast'
    , tryObjectCast
    , asNativeScript
    , convertClassName
    , unConvertClassName
    , getNode
    , getNodeNativeScript
    , new
    , newNativeScript
    , getSingleton
    , getEngine
    , copyVariant
    , scriptDesc
    , defaultExports
    , await
    , WrapperStablePtr(..)
    , createMVarProperty
    , guardError
    , getError
    , GodotError(..)
    )
  where
  
  import           Control.Monad
  
  import           Data.Typeable
  import           Data.Text                                ( Text )
  import qualified Data.Text                     as T
  import           Data.Vector                              ( Vector )
  import qualified Data.Vector                   as Vec
  import qualified Data.Vector                   as V
  import           Data.Function                            ( (&) )
  
  import qualified Data.Set                      as S
  import           Control.Concurrent.MVar
  
  import           Foreign                           hiding (void,new)
  import           Foreign.C                         hiding (new)
  
  import           System.Environment
  import           System.IO.Unsafe
  
  import qualified Godot.Gdnative.Internal as GNI
  import           Godot.Gdnative
  import           Godot.Internal.Dispatch
  import           Data.Maybe                               ( fromMaybe )
  import qualified Foreign.Marshal as F
  import qualified Foreign.Marshal.Utils as F
  import qualified Foreign.C                     as Foreign
  
  import qualified Godot.Api                     as Api
  import qualified Data.Map.Strict as M
  import           Data.Coerce
  import qualified Godot.Core.NativeScript as NativeScript
  import           Godot.Core.GlobalConstants
  import           Godot.Core.ClassDB
  import           Godot.Core.Engine
  import           Godot.Core.Node
  import           Godot.Core.Object as Object
  import           Godot.Core.Reference
  import           Data.IORef
  import           Foreign.StablePtr
  import           Control.Monad.Extra
  import           Control.Exception
  import           Data.Maybe
  
  type GdnativeHandle = Ptr ()
  
  data GodotError = GFailed -- ^ Generic error.
                  | GUnavailable -- ^ Unavailable error.
                  | GUnconfigured -- ^ Unconfigured error.
                  | GUnauthorized -- ^ Unauthorized error.
                  | GParameterRangeError -- ^ Parameter range error.
                  | GOutOfMemory -- ^ Out of memory (OOM) error.
                  | GFileNotFound -- ^ File: Not found error.
                  | GFileBadDrive -- ^ File: Bad drive error.
                  | GFileBadPath -- ^ File: Bad path error.
                  | GFileNoPermission -- ^ File: No permission error.
                  | GFileAlreadyInUse -- ^ File: Already in use error.
                  | GFileCantOpen -- ^ File: Can't open error.
                  | GFileCantWrite -- ^ File: Can't write error.
                  | GFileCantRead -- ^ File: Can't read error.
                  | GFileUnrecognized -- ^ File: Unrecognized error.
                  | GFileCorrupt -- ^ File: Corrupt error.
                  | GFileMissingDependencies -- ^ File: Missing dependencies error.
                  | GFileEof -- ^ File: End of file (EOF) error.
                  | GCantOpen -- ^ Can't open error.
                  | GCantCreate -- ^ Can't create error.
                  | GQueryFailed -- ^ Query failed error.
                  | GAlreadyInUse -- ^ Already in use error.
                  | GLocked -- ^ Locked error.
                  | GTimeout -- ^ Timeout error.
                  | GCantConnect -- ^ Can't connect error.
                  | GCantResolve -- ^ Can't resolve error.
                  | GConnectionError -- ^ Connection error.
                  | GCantAcquireResource -- ^ Can't acquire resource error.
                  | GCantFork -- ^ Can't fork process error.
                  | GInvalidData -- ^ Invalid data error.
                  | GInvalidParameter -- ^ Invalid parameter error.
                  | GAlreadyExists -- ^ Already exists error.
                  | GDoesNotExist -- ^ Does not exist error.
                  | GDatabaseCantRead -- ^ Database: Read error.
                  | GDatabaseCantWrite -- ^ Database: Write error.
                  | GCompilationFailed -- ^ Compilation failed error.
                  | GMethodNotFound -- ^ Method not found error.
                  | GLinkFailed -- ^ Linking failed error.
                  | GScriptFailed -- ^ Script failed error.
                  | GCyclicLink -- ^ Cycling link (import cycle) error.
                  | GInvalidDeclaration -- ^ Invalid declaration error.
                  | GDuplicateSymbol -- ^ Duplicate symbol error.
                  | GParseError -- ^ Parse error.
                  | GBusy -- ^ Busy error.
                  | GSkip -- ^ Skip error.
                  | GHelp -- ^ Help error.
                  | GBug -- ^ Bug error.
                  | GPrinterOnFire -- ^ Printer on fire error. (This is an easter egg, no engine methods return this error code.)
                  deriving (Show, Eq, Typeable)
  
  instance Exception GodotError
  
  getError :: Int -> Maybe GodotError
  getError e | e == _OK                             = Nothing
             | e == _FAILED                         = Just GFailed                   
             | e == _ERR_UNAVAILABLE                = Just GUnavailable              
             | e == _ERR_UNCONFIGURED               = Just GUnconfigured             
             | e == _ERR_UNAUTHORIZED               = Just GUnauthorized             
             | e == _ERR_PARAMETER_RANGE_ERROR      = Just GParameterRangeError      
             | e == _ERR_OUT_OF_MEMORY              = Just GOutOfMemory              
             | e == _ERR_FILE_NOT_FOUND             = Just GFileNotFound             
             | e == _ERR_FILE_BAD_DRIVE             = Just GFileBadDrive             
             | e == _ERR_FILE_BAD_PATH              = Just GFileBadPath              
             | e == _ERR_FILE_NO_PERMISSION         = Just GFileNoPermission         
             | e == _ERR_FILE_ALREADY_IN_USE        = Just GFileAlreadyInUse         
             | e == _ERR_FILE_CANT_OPEN             = Just GFileCantOpen             
             | e == _ERR_FILE_CANT_WRITE            = Just GFileCantWrite            
             | e == _ERR_FILE_CANT_READ             = Just GFileCantRead             
             | e == _ERR_FILE_UNRECOGNIZED          = Just GFileUnrecognized         
             | e == _ERR_FILE_CORRUPT               = Just GFileCorrupt              
             | e == _ERR_FILE_MISSING_DEPENDENCIES  = Just GFileMissingDependencies  
             | e == _ERR_FILE_EOF                   = Just GFileEof                  
             | e == _ERR_CANT_OPEN                  = Just GCantOpen                 
             | e == _ERR_CANT_CREATE                = Just GCantCreate               
             | e == _ERR_QUERY_FAILED               = Just GQueryFailed              
             | e == _ERR_ALREADY_IN_USE             = Just GAlreadyInUse             
             | e == _ERR_LOCKED                     = Just GLocked                   
             | e == _ERR_TIMEOUT                    = Just GTimeout                  
             | e == _ERR_CANT_CONNECT               = Just GCantConnect              
             | e == _ERR_CANT_RESOLVE               = Just GCantResolve              
             | e == _ERR_CONNECTION_ERROR           = Just GConnectionError          
             | e == _ERR_CANT_ACQUIRE_RESOURCE      = Just GCantAcquireResource      
             | e == _ERR_CANT_FORK                  = Just GCantFork                 
             | e == _ERR_INVALID_DATA               = Just GInvalidData              
             | e == _ERR_INVALID_PARAMETER          = Just GInvalidParameter         
             | e == _ERR_ALREADY_EXISTS             = Just GAlreadyExists            
             | e == _ERR_DOES_NOT_EXIST             = Just GDoesNotExist             
             | e == _ERR_DATABASE_CANT_READ         = Just GDatabaseCantRead         
             | e == _ERR_DATABASE_CANT_WRITE        = Just GDatabaseCantWrite        
             | e == _ERR_COMPILATION_FAILED         = Just GCompilationFailed        
             | e == _ERR_METHOD_NOT_FOUND           = Just GMethodNotFound           
             | e == _ERR_LINK_FAILED                = Just GLinkFailed               
             | e == _ERR_SCRIPT_FAILED              = Just GScriptFailed             
             | e == _ERR_CYCLIC_LINK                = Just GCyclicLink               
             | e == _ERR_INVALID_DECLARATION        = Just GInvalidDeclaration       
             | e == _ERR_DUPLICATE_SYMBOL           = Just GDuplicateSymbol          
             | e == _ERR_PARSE_ERROR                = Just GParseError               
             | e == _ERR_BUSY                       = Just GBusy                     
             | e == _ERR_SKIP                       = Just GSkip                     
             | e == _ERR_HELP                       = Just GHelp                     
             | e == _ERR_BUG                        = Just GBug                      
             | e == _ERR_PRINTER_ON_FIRE            = Just GPrinterOnFire            
             | otherwise                            = error $ "Unknown Godot error; this is a bug in the Haskell bindings: " ++ show e
  
  guardError :: Int -> ()
  guardError = maybe () throw . getError
  
  {-| 'NativeScript' defines a new Godot class.
  First you must create an instance of 'HasBaseClass' for inheritance and
  upcasting to parent class. Then you'll need an instance of 'NativeScript'.
  Finally, the splice 'deriveBase' handles creating all the parent-child
  relationships. To actually use your class, you'll need to register it with
  'registerClass'.
  
  TODO Check that this example still works
  
  Example usage:
  
  @
  data MyClass1 = MyClass1
    { _mc1Obj :: Node
    , _mc1Time :: MVar Float
    }
  
  instance HasBaseClass MyClass1 where
    type BaseClass MyClass1 = Node
    super (MyClass1 p _) = p
  instance NativeScript MyClass1 where
    classInit p = MyClass1 p <$> newMVar 0
    classMethods =
      [ func NoRPC "_ready" $ \self [] -> do
          sigName <- toLowLevel "on_MyClass1_ready" :: IO GodotString
          msg     <- toLowLevel ("MyClass1 is ready" :: Text) :: IO GodotString
          let msgVt = toVariant msg
          G.emit_signal (upcast self :: Object) sigName [msgVt]
      , func NoRPC "_process" $ \self [deltaVt] -> do
          delta <- fromVariant deltaVt
          atomically $ modifyMVar' (_mc1Time self) $ \t -> t + delta
      ]
    classSignals =
      [ signal "on_MyClass1_ready" [("msg", VariantTypeString)]
      ]
  deriveBase ''Myclass1
  @
  -}
  class (HasBaseClass cls, Typeable cls, Typeable (BaseClass cls), Object :< cls)
    => NativeScript cls where
    classInit :: BaseClass cls -> IO cls
    className :: ClassName cls
    className = nameOf @cls
    classMethods :: [ClassMethod cls]
    classSignals :: [ClassSignal]
    classSignals = []
    classProperties :: [ClassProperty cls]
    classProperties = []
    asObj :: cls -> Object
    asObj = upcast
  
  type ClassSignal = (Text, [SignalArgument])
  
  type ClassName a = Text
  nameOf :: forall a . Typeable a => ClassName a
  nameOf = T.pack
      $ convertClassName
      $ show
      $ typeRep
      $ Proxy @a
  
  
  type GFunc cls = cls -> Vector GodotVariant -> IO GodotVariant
  
  data ClassMethod cls where
    ClassMethod
      :: { methodRPCMode :: RPC
         , methodName :: Text
         , methodFunc :: GFunc cls
         }
      -> ClassMethod cls
  
  
  data RPC
    = NoRPC
    | Remote
    | Sync
    | Master
    | Slave
  
  
  data RegTy
    = GClass
    | GMethod
    | GSignal
    | GProperty
  
  data family Registerer (x :: RegTy) cls
  
  data instance Registerer 'GClass cls = NativeScript cls =>
    RegClass
      GdnativeHandle
      (BaseClass cls -> IO cls)
  
  data instance Registerer 'GMethod cls = NativeScript cls =>
    RegMethod
      GdnativeHandle
      (ClassMethod cls)
  
  data instance Registerer 'GSignal cls = NativeScript cls =>
    RegSignal
      GdnativeHandle
      (Text, [SignalArgument])
  
  data instance Registerer 'GProperty cls = NativeScript cls =>
    RegProperty
      GdnativeHandle
      (ClassProperty cls)
  
  
  -- | Convenient way of registering a class with all its methods.
  -- Used like: @registerClass $ RegClass desc $ classInit \\@MyClass@
  registerClass
    :: forall a
     . (NativeScript a, Typeable (BaseClass a), AsVariant (BaseClass a))
    => Registerer 'GClass a
    -> IO ()
  registerClass (RegClass desc constr) = do
    regClass desc (nameOf @(BaseClass a)) clsInit $ \_ _ -> return ()
    forM_ (classMethods @a) regMtd
    forM_ (classSignals @a) regSignal
    forM_ (classProperties @a) regProperty
   where
    clsInit :: Object -> IO a
    clsInit obj = tryObjectCast obj >>= \(Just a) -> constr (a :: BaseClass a)
    clsName = className @a
  
    regMtd mtd@ClassMethod {..} = do
      registerMethod (RegMethod desc mtd :: Registerer 'GMethod a)
      d <- isJust <$> lookupEnv "HS_GODOT_DEBUG"
      when d $ putStrLn $ T.unpack $ T.unwords
        ["Registering method", methodName, "to class", clsName]
  
    regSignal sgn@(signalName, _) = do
      registerSignal (RegSignal desc sgn :: Registerer 'GSignal a)
      d <- isJust <$> lookupEnv "HS_GODOT_DEBUG"
      when d $ putStrLn $ T.unpack $ T.unwords
        ["Registering signal", signalName, "to class", clsName]
  
    regProperty prp = do
      registerProperty (RegProperty desc prp :: Registerer 'GProperty a)
      d <- isJust <$> lookupEnv "HS_GODOT_DEBUG"
      when d $ putStrLn $ T.unpack $ T.unwords
        ["Registering property", propertyName prp, "to class", clsName]
  
    regClass pHandle base create destroy = do
      createFun <- mkInstanceCreateFunPtr
        $ \ins _ -> create ins >>= newStablePtr >>= (return . castStablePtrToPtr)
      destroyFun <- mkInstanceDestroyFunPtr $ \ins _ objPtr -> do
        let stPtr = castPtrToStablePtr objPtr
        obj <- deRefStablePtr stPtr
        freeStablePtr stPtr
        destroy ins obj
      rec createFreeFun <- mkInstanceFreeFunPtr $ \_ ->
            freeHaskellFunPtr createFun >> freeHaskellFunPtr createFreeFun
          destroyFreeFun <- mkInstanceFreeFunPtr $ \_ ->
            freeHaskellFunPtr destroyFun >> freeHaskellFunPtr destroyFreeFun
  
      let createFunObj = InstanceCreateFunc createFun nullPtr createFreeFun
      let destroyFunObj =
            InstanceDestroyFunc destroyFun nullPtr destroyFreeFun
  
      let tyFingerprint = typeRepFingerprint $ typeRep (Proxy @a)
      tyPtr <- F.new tyFingerprint
  
      d <- isJust <$> lookupEnv "HS_GODOT_DEBUG"
      when d $ putStrLn $ T.unpack $ T.unwords ["Registering class", clsName]
      withCString (T.unpack clsName)
        $ \namePtr -> withCString (T.unpack base) $ \basePtr -> do
            godot_nativescript_register_class pHandle
                                              namePtr
                                              basePtr
                                              createFunObj
                                              destroyFunObj
            godot_nativescript_set_type_tag pHandle
                                            namePtr
                                            (castPtr tyPtr)
  
  tryCast
    :: forall b a. (Object :< a, a :< b, Typeable b, AsVariant b) => a -> IO (Maybe b)
  tryCast = tryObjectCast . upcast
  
  tryCast' :: forall out x. (Typeable out, AsVariant out, Object :< x, x :< out) => x -> IO out
  tryCast' o = fromJust <$> tryCast o
  
  convertClassName name =
    case name of
      -- TODO Derive these automatically. Don't think we store if a
      -- class is a singleton anywhere.
      "ClassDB" -> "_ClassDB"
      "Marshalls" -> "_Marshalls"
      "VisualScriptEditor" -> "_VisualScriptEditor"
      "OS" -> "_OS"
      "Engine" -> "_Engine"
      "Geometry" -> "_Geometry"
      "JSON" -> "_JSON"
      "ResourceLoader" -> "_ResourceLoader"
      "ResourceSaver" -> "_ResourceSaver"
      x -> x
  
  unConvertClassName name =
    case name of
      -- TODO Derive these automatically. Don't think we store if a
      -- class is a singleton anywhere.
      "_ClassDB" -> "ClassDB"
      "_Marshalls" -> "Marshalls"
      "_VisualScriptEditor" -> "VisualScriptEditor"
      "_OS" -> "OS"
      "_Engine" -> "Engine"
      "_Geometry" -> "Geometry"
      "_JSON" -> "JSON"
      "_ResourceLoader" -> "ResourceLoader"
      "_ResourceSaver" -> "ResourceSaver"
      x -> x
  
  singletonTable :: MVar (M.Map Text Object)
  singletonTable = unsafePerformIO $ newMVar M.empty
  
  -- | Godot exposes some functionality through singletons. You'll often need to
  -- talk to the GodotInput singeton for example. Use this as 'getSingleton @GodotInput'.
  getSingleton
    :: forall a . (Typeable a, AsVariant a, Object :< a) => IO (Maybe a)
  getSingleton = do
    let name = unConvertClassName $ nameOf @a
    table <- readMVar singletonTable
    case M.lookup name table of
      Just o -> tryCast o
      Nothing -> do
        ge <- getEngine
        -- FIXME ANDREI I don't understand what convertClassName is doing here? It seems wrong.
        -- o <- get_singleton ge =<< toLowLevel (convertClassName name)
        o <- get_singleton ge =<< toLowLevel name
        modifyMVar_ singletonTable (\m -> pure (M.insert name o m))
        tryCast o
  
  getEngine :: IO Api.Engine
  getEngine =
    GNI.godot_global_get_singleton
      &   Foreign.withCString "Engine"
      >>= \o -> tryCast o >>= \case
            Just ge -> return ge
            Nothing ->
              (get_class o :: IO GodotString)
                >>= fromLowLevel
                >>= error
                .   ("Couldn't get Engine singleton :( got: " ++)
                .   T.unpack
    
  tryObjectCast :: forall a . (Typeable a, AsVariant a) => Object -> IO (Maybe a)
  tryObjectCast obj = do
    isCls <- Object.is_class obj =<< toLowLevel (nameOf @a)
    if isCls
      then do
        asGVt <- toLowLevel $ toVariant obj :: IO GodotVariant
        Just <$> fromGodotVariant asGVt
      else return Nothing
  
  
  asNativeScript :: forall a . NativeScript a => Object -> IO (Maybe a)
  asNativeScript obj = do
    tyPtr <- godot_nativescript_get_type_tag obj
    tyFingerprint <- peek (castPtr tyPtr)
    if tyFingerprint == typeRepFingerprint (typeRep (Proxy @a)) then
      Just <$> (godot_nativescript_get_userdata obj
                 >>= (deRefStablePtr . castPtrToStablePtr))
      else
      pure Nothing
  
  copyVariant
    :: Ptr GodotVariant -- ^ destination
    -> Ptr GodotVariant -- ^ source
    -> IO ()
  copyVariant dest src = copyBytes dest src (opaqueSizeOf @GodotVariant)
  
  
  {-| This makes defining class member methods much easier and similar to GDScript.
  Without dependent types we can't enforce that the right number of arguments are
  passed. The pattern-match below is non-total for syntactic simplicity.
  
  Example usage:
  @
  func NoRPC "_unhandled_input" $ \self [evObj] ->
    (fromVariant evObj :: IO Object)
      >>= asClass InputEventKey "InputEventKey"
      >>= flip whenJust (handleInputKey self)
  @
  -}
  func
    :: (NativeScript cls, AsVariant a)
    => RPC
    -> Text
    -> (cls -> [GodotVariant] -> IO a)
    -> ClassMethod cls
  func rpc mthdName fn = ClassMethod rpc mthdName
    $ \self args -> toLowLevel . toVariant =<< fn self (Vec.toList args)
  
  -- | Quick shortcut to make a new local method with arguments passed as
  -- 'Variant's in a list.
  method :: (NativeScript cls, AsVariant a)
         => Text -> (cls -> [GodotVariant] -> IO a) -> ClassMethod cls
  method = func NoRPC
  
  -- | Quick shortcut to make a new local method with no argumnets.
  method0 :: (NativeScript cls, AsVariant a)
         => Text -> (cls -> IO a) -> ClassMethod cls
  method0 name fn = func NoRPC name (\s [] -> fn s)
  
  -- | Quick shortcut to make a new local method that takes 1 argument, 'Variant's
  -- are unwrapped into their types before being passed in.
  method1 :: (NativeScript cls, AsVariant a, AsVariant o1, Typeable o1)
          => Text -> (cls -> o1 -> IO a) -> ClassMethod cls
  method1 name fn = func NoRPC name (\s [o1] -> do
                                        a1 <- fromGodotVariant o1
                                        fn s a1)
  
  -- | Quick shortcut to make a new local method that takes 2 arguments, 'Variant's
  -- are unwrapped into their types before being passed in.
  method2 :: (NativeScript cls, AsVariant a, AsVariant o1, Typeable o1, AsVariant o2, Typeable o2)
          => Text -> (cls -> o1 -> o2 -> IO a) -> ClassMethod cls
  method2 name fn = func NoRPC name (\s [o1,o2] -> do
                                        a1 <- fromGodotVariant o1
                                        a2 <- fromGodotVariant o2
                                        fn s a1 a2)
  
  -- | Quick shortcut to make a new local method that takes 3 arguments, 'Variant's
  -- are unwrapped into their types before being passed in.
  method3 :: (NativeScript cls, AsVariant a, AsVariant o1, Typeable o1, AsVariant o2, Typeable o2, AsVariant o3, Typeable o3)
          => Text -> (cls -> o1 -> o2 -> o3 -> IO a) -> ClassMethod cls
  method3 name fn = func NoRPC name (\s [o1,o2,o3] -> do
                                        a1 <- fromGodotVariant o1
                                        a2 <- fromGodotVariant o2
                                        a3 <- fromGodotVariant o3
                                        fn s a1 a2 a3)
  
  -- | Quick shortcut to make a new local method that takes 4 arguments, 'Variant's
  -- are unwrapped into their types before being passed in.
  method4 :: (NativeScript cls, AsVariant a, AsVariant o1, Typeable o1, AsVariant o2, Typeable o2
            , AsVariant o3, Typeable o3, AsVariant o4, Typeable o4)
          => Text -> (cls -> o1 -> o2 -> o3 -> o4 -> IO a) -> ClassMethod cls
  method4 name fn = func NoRPC name (\s [o1,o2,o3,o4] -> do
                                        a1 <- fromGodotVariant o1
                                        a2 <- fromGodotVariant o2
                                        a3 <- fromGodotVariant o3
                                        a4 <- fromGodotVariant o4
                                        fn s a1 a2 a3 a4)
  
  -- | Quick shortcut to make a new local method that takes 5 arguments, 'Variant's
  -- are unwrapped into their types before being passed in.
  method5 :: (NativeScript cls, AsVariant a, AsVariant o1, Typeable o1, AsVariant o2, Typeable o2
            , AsVariant o3, Typeable o3, AsVariant o4, Typeable o4, AsVariant o5, Typeable o5)
          => Text -> (cls -> o1 -> o2 -> o3 -> o4 -> o5 -> IO a) -> ClassMethod cls
  method5 name fn = func NoRPC name (\s [o1,o2,o3,o4,o5] -> do
                                        a1 <- fromGodotVariant o1
                                        a2 <- fromGodotVariant o2
                                        a3 <- fromGodotVariant o3
                                        a4 <- fromGodotVariant o4
                                        a5 <- fromGodotVariant o5
                                        fn s a1 a2 a3 a4 a5)
  
  
  registerMethod :: forall a . NativeScript a => Registerer 'GMethod a -> IO ()
  registerMethod (RegMethod desc ClassMethod {..}) = do
    methodFun <-
      mkInstanceMethodFunPtr $ \outPtr _ins _ objPtr numArgs argsPtr -> do
        obj  <- deRefStablePtr $ castPtrToStablePtr objPtr
        ptrs <- V.fromList <$> peekArray (fromIntegral numArgs) argsPtr
        args <- V.forM ptrs $ \ptr -> do
          oldVar <- GodotVariant <$> newForeignPtr_ ptr
          godot_variant_new_copy oldVar
        res <- methodFunc obj args
        withGodotVariant res $ copyVariant outPtr
        return outPtr
  
    rec methodFreeFun <- mkInstanceFreeFunPtr
          $ \_ -> freeHaskellFunPtr methodFun >> freeHaskellFunPtr methodFreeFun
  
    let methodObj = InstanceMethod methodFun nullPtr methodFreeFun
    withCString (T.unpack $ nameOf @a) $ \clsNamePtr ->
      withCString (T.unpack methodName)
        $ \mtdNamePtr -> godot_nativescript_register_method
            desc
            clsNamePtr
            mtdNamePtr
            (MethodAttributes rpcMode)
            methodObj
   where
    rpcMode = case methodRPCMode of
      NoRPC  -> MethodRpcModeDisabled
      Remote -> MethodRpcModeRemote
      Sync   -> MethodRpcModeSync
      Master -> MethodRpcModeMaster
      Slave  -> MethodRpcModeSlave
  
  asPropertyAttributes :: PropertyAttributes -> IO GNI.PropertyAttributes
  asPropertyAttributes PropertyAttributes {..} = do
    hintStr <- toLowLevel propertyHintString
    def     <- toLowLevel propertyDefaultValue
    return $ GNI.PropertyAttributes
      { godotPropertyAttributesRsetType     = propertySetType
      , godotPropertyAttributesType         = fromIntegral $ fromEnum propertyType
      , godotPropertyAttributesHint         = propertyHint
      , godotPropertyAttributesHintString   = hintStr
      , godotPropertyAttributesUsage        = propertyUsage
      , godotPropertyAttributesDefaultValue = def
      }
  
  registerProperty :: forall a . NativeScript a => Registerer 'GProperty a -> IO ()
  registerProperty (RegProperty desc (ClassProperty path attr setter getter)) = do
    setFun <- mkPropertySetFunPtr $ \ins _ objPtr valPtr -> do
      obj <- deRefStablePtr $ castPtrToStablePtr objPtr
      val <- newForeignPtr_ valPtr
      setter ins obj (GodotVariant val)
    getFun <- mkPropertyGetFunPtr $ \outPtr ins _ objPtr -> do
      obj <- deRefStablePtr $ castPtrToStablePtr objPtr
      res <- getter ins obj
      withGodotVariant res $ copyVariant outPtr
      return outPtr
    rec setFreeFun <- mkInstanceFreeFunPtr
          $ \_ -> freeHaskellFunPtr setFun >> freeHaskellFunPtr setFreeFun
        getFreeFun <- mkInstanceFreeFunPtr
          $ \_ -> freeHaskellFunPtr getFun >> freeHaskellFunPtr getFreeFun
    godotAttr <- asPropertyAttributes attr
    withCString (T.unpack $ nameOf @a) $ \clsNamePtr ->
      withCString (T.unpack path) $ \pathPtr -> godot_nativescript_register_property
        desc
        clsNamePtr
        pathPtr
        godotAttr
        (PropertySetFunc setFun nullPtr setFreeFun)
        (PropertyGetFunc getFun nullPtr getFreeFun)
  
  createMVarProperty :: (Typeable v, AsVariant v) =>
       Text
       -> (t -> MVar v)
       -- ^ We typically can't do IO (for initialisation) when calling this, in
       -- which case we need to annotate the type without providing a value.
       -> Either VariantType v
       -> ClassProperty t
  createMVarProperty name fieldName tyOrVal = ClassProperty
    { propertyName = name
    , propertyAttrs = PropertyAttributes
        MethodRpcModeDisabled
        (fst vTyVt)
        PropertyHintNone
        ""
        godotPropertyUsageDefault
        (snd vTyVt)
    , propertySetter = \_ c (var :: GodotVariant) -> do
          variant <- fromLowLevel var
          -- TODO This is required to avoid memory corruption. Haskell cannot hold
          -- pointers to Godot objects unless the runtime already has a live
          -- reference to that object. It will otherwise be freed at some point!
          --
          -- This solution works, but only for most Godot Objects. We could add
          -- more cases here, but a much better way would be to implement a Ref
          -- type to hold such objects. Coming soon to stores near you.
          case variant of
            VariantObject o -> onRefObj reference o
            _ -> pure False
          obj <- fromGodotVariant var
          let mvar = fieldName c
          isEmpty <- isEmptyMVar mvar
          if isEmpty
            then putMVar mvar obj
            else toVariant <$> swapMVar mvar obj >>= \case
              VariantObject oldObj@(Object ptr) -> do
                unreffed <- onRefObj unreference oldObj -- lazy evaluation ftw
                when (nullPtr /= ptr && unreffed) $
                  Object.free oldObj
              _ -> pure ()
    , propertyGetter = \_ c -> toLowLevel . toVariant =<< readMVar (fieldName c)
    }
   where
     onRefObj :: (Api.Reference -> IO a) -> Object -> IO a
     onRefObj f o = tryObjectCast @Api.Reference o >>= \case
        Just ref -> f ref
        Nothing -> error "Variant object not a reference"
     vTyVt :: (VariantType, Variant 'GodotTy)
     vTyVt = case tyOrVal of
       Left VariantTypeObject -> (VariantTypeObject, VariantObject (Object nullPtr))
       Left vTy -> (vTy, VariantNil)
       Right val -> (variantType val, toVariant val)
  
  data SignalArgument = SignalArgument
    { signalArgumentName :: !Text
    , signalArgumentType :: !VariantType
    , signalArgumentHint :: !PropertyHint
    , signalArgumentHintString :: !Text
    , signalArgumentUsage :: !PropertyUsageFlags
    , signalArgumentDefaultValue :: !(Variant 'GodotTy)
    }
  
  asSignalArgument :: SignalArgument -> IO GNI.SignalArgument
  asSignalArgument SignalArgument {..} = do
    name <- toLowLevel signalArgumentName
    let ty = fromIntegral $ fromEnum signalArgumentType
    hintStr <- toLowLevel signalArgumentHintString
    def     <- toLowLevel signalArgumentDefaultValue
    return $ GNI.SignalArgument name
                                 ty
                                 signalArgumentHint
                                 hintStr
                                 signalArgumentUsage
                                 def
  
  
  -- | Example usage:
  -- @
  -- signal "on_pulse" [("source", VariantTypeVector3), ("affected", VariantTypeObject)]
  -- @
  signal :: Text -> [(Text, VariantType)] -> (Text, [SignalArgument])
  signal sigName sigArgs = (sigName, uncurry toSigArg <$> sigArgs)
   where
    toSigArg :: Text -> VariantType -> SignalArgument
    toSigArg argName ty = do
      SignalArgument
        { signalArgumentName         = argName
        , signalArgumentType         = ty
        , signalArgumentHint         = PropertyHintNone
        , signalArgumentHintString   = T.pack ""
        , signalArgumentUsage        = godotPropertyUsageDefault
        , signalArgumentDefaultValue = VariantNil
        }
  
  -- TODO: Also allow hints and default args?
  registerSignal :: forall a . NativeScript a => Registerer 'GSignal a -> IO ()
  registerSignal (RegSignal desc (signalName, signalArgs)) = do
    gdArgs <- mapM asSignalArgument signalArgs
    let defaultArgs = []
    withArrayLen gdArgs $ \gdArgsLen gdArgsPtr ->
      withVariantArray' defaultArgs $ \(defArgsPtr, defArgsLen) ->
        withCString (T.unpack $ nameOf @a) $ \clsNamePtr -> do
          gdSigName <- toLowLevel signalName
          godot_nativescript_register_signal desc clsNamePtr $ GNI.Signal
            gdSigName
            (fromIntegral gdArgsLen)
            gdArgsPtr
            (fromIntegral defArgsLen)
            defArgsPtr
   where
    withVariantArray'
      :: [Variant 'GodotTy] -> ((Ptr GodotVariant, CInt) -> IO b) -> IO b
    withVariantArray' vars mtd =
      allocaBytes (opaqueSizeOf @GodotVariant * length vars)
        $ \arrPtr -> withVars vars 0 arrPtr mtd
  
    withVars (x : xs) n arrPtr mtd = do
      vt <- toLowLevel x
      withGodotVariant vt $ \vtPtr -> do
        copyVariant (arrPtr `plusPtr` (n * opaqueSizeOf @GodotVariant)) vtPtr
        withVars xs (n + 1) arrPtr mtd
    withVars [] n arrPtr mtd = mtd (arrPtr, fromIntegral n)
  
  foreign import ccall "dynamic"
    call_godot_class_constructor_ :: FunPtr (IO (Object)) -> IO (Object)
  
  -- | Instantiate an object
  new :: forall o. (Object :< o, Typeable o, AsVariant o) => IO (Maybe o)
  new = do
    con <- Foreign.withCString (T.unpack $ nameOf @o) godot_get_class_constructor
    if con == nullFunPtr then
      pure Nothing else
      tryCast =<< call_godot_class_constructor_ con
  
  newNativeScript :: forall a. NativeScript a => IO (Maybe a)
  newNativeScript = do
    let name = nameOf @a
    Just nativescript <- new @Api.NativeScript
    Just gdnlib <- tryCast @Api.GDNativeLibrary =<< readIORef gdnativeLibraryRef
    NativeScript.set_library nativescript gdnlib
    NativeScript.set_class_name nativescript =<< toLowLevel name
    no <- fromGodotVariant =<< NativeScript.new nativescript []
    asNativeScript no
  
  getNode :: forall b cls. (Object :< cls, Api.Node :< cls,
                      Api.Node :< b, Typeable b, AsVariant b)
          => cls -> Text -> IO b
  getNode self name = do
    n :: Api.Node <- get_node_or_null self =<< toLowLevel name
    x <- tryCast n
    case x of
      Just r -> pure r
      _ -> error "Error, getNode failed"
  
  getNodeNativeScript :: forall b child. (NativeScript b, Api.Node :< child, Object :< child)
           => child -> Text -> IO b
  getNodeNativeScript self name = do
    n <- get_node self =<< toLowLevel name
    x <- asNativeScript $ upcast @Object n
    case x of
      Just r -> pure r
      _ -> error "Error, getNode' failed"
  
  -- | The descriptor, Godot file resource path, of the current script. Some
  -- GNative API functions need access to this.
  scriptDesc :: MVar GodotString
  {-# NOINLINE scriptDesc #-}
  scriptDesc = unsafePerformIO newEmptyMVar
  
  -- | Called for you in the setup code.
  defaultExports :: GdnativeHandle -> IO ()
  defaultExports desc = do
    desc' <- newForeignPtr_ desc
    cpy <- godot_string_new_copy (coerce desc' :: GodotString)
    putMVar scriptDesc cpy
    registerClass $ RegClass desc $ classInit @WrapperStablePtr
    pure ()
  
  -- | Ask an object to wait for a signal on a target. When the signal is trigged call the given function
  -- For example, to get a callback when a timer fires you could do something like
  -- @ await self timer "timeout" (\self -> print "Timer fired!") @
  await :: forall cls source target a. (NativeScript cls, Object :< cls, Object :< target, AsVariant a)
        => cls -> target -> Text -> (cls -> IO a) -> IO ()
  await self target signal fn = do
    desc <- readMVar scriptDesc
    (Just w) <- newNativeScript @WrapperStablePtr
    unlessM (has_method self =<< toLowLevel "__script_callback") $ do
      withForeignPtr (coerce desc)
        (\rawDesc ->
         registerMethod
          (RegMethod (coerce rawDesc)
           (method1 "__script_callback"
            (\self o -> do
                (Just w) <- asNativeScript @WrapperStablePtr o
                sptr <- takeMVar $ _wrapperStablePtr w
                fn :: (cls -> IO a) <- deRefStablePtr (castPtrToStablePtr (castStablePtrToPtr sptr))
                fn self
                freeStablePtr sptr))))
    fnptr <- newStablePtr fn
    putMVar (_wrapperStablePtr w) (castPtrToStablePtr (castStablePtrToPtr fnptr))
    fnBind <- toGodotVariant (upcast @Object w)
    guardError <$> (join $ connect target
      <$> toLowLevel signal
      <*> pure (upcast self)
      <*> toLowLevel "__script_callback"
      <*> (Just <$> toLowLevel (V.singleton fnBind))
      <*> pure (Just _CONNECT_ONESHOT))
  
  -- | Sometimes we really have to pass in a Haskell pointer to Godot,
  -- particularly for callbacks.
  data WrapperStablePtr = WrapperStablePtr { _wrapperStablePtrBase :: Object
                                  , _wrapperStablePtr :: MVar (StablePtr ()) }
  instance HasBaseClass WrapperStablePtr where
    type BaseClass WrapperStablePtr = Object
    super = _wrapperStablePtrBase
  instance NativeScript WrapperStablePtr where
    classInit base = WrapperStablePtr base <$> newEmptyMVar
    classMethods = []
  deriveBase ''WrapperStablePtr
  