{-# OPTIONS -Wall -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Unused LANGUAGE pragma" #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections #-}

-- | Template Haskell functions used internally
module Raylib.Internal.TH (genLenses, genNative) where

import Control.Lens (makeLensesFor)
import Control.Monad (zipWithM)

#ifdef WEB_FFI

import Language.Haskell.TH
  ( Body (NormalB),
    Clause (Clause),
    Con (RecC),
    Dec (DataD, FunD, SigD),
    DecsQ,
    Exp (AppE, LitE, VarE),
    Info (TyConI),
    Lit (StringL),
    Name,
    TypeQ,
    mkName,
    nameBase,
    reify,
  )
import Raylib.Internal.Web.Native (callRaylibFunction)

#else

import Language.Haskell.TH
  ( Con (RecC),
    Dec (DataD, ForeignD),
    DecsQ,
    Info (TyConI),
    Name,
    TypeQ,
    mkName,
    nameBase,
    reify, Foreign (ImportF), Callconv (CCall), Safety (Safe, Unsafe),
  )

#endif

-- | Creates lenses with an underscore before field names; e.g. @vector2'x@
--   becomes the lens @_vector2'x@
genLenses :: [Name] -> DecsQ
genLenses :: [Name] -> DecsQ
genLenses [Name]
names = do
  [Info]
infos <- (Name -> Q Info) -> [Name] -> Q [Info]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> Q Info
reify [Name]
names
  [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> Info -> DecsQ) -> [Name] -> [Info] -> Q [[Dec]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Name -> Info -> DecsQ
genLensesForType [Name]
names [Info]
infos
  where
    genLensesForType :: Name -> Info -> DecsQ
genLensesForType Name
name (TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [RecC Name
_ [VarBangType]
ctors] [DerivClause]
_)) =
      [(String, String)] -> Name -> DecsQ
makeLensesFor [(String, String)]
mapping Name
name
      where
        mapping :: [(String, String)]
mapping = (VarBangType -> (String, String))
-> [VarBangType] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
a, Bang
_, Kind
_) -> let fName :: String
fName = Name -> String
nameBase Name
a in (String
fName, Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: String
fName)) [VarBangType]
ctors
    genLensesForType Name
_ Info
_ = String -> DecsQ
forall a. HasCallStack => String -> a
error String
"(genLenses) Received a name that does not refer to a valid type!"

-- | Generates native code for the given functions. On non-web platforms, this
--   means @foreign import@ statements. On web platforms, this means
--   `callRaylibFunction` calls.
genNative ::
  -- | (@hsName@, @cName@, @cFile@, @funType@, @isSafe@)
  [(String, String, String, TypeQ, Bool)] ->
  DecsQ
genNative :: [(String, String, String, TypeQ, Bool)] -> DecsQ
genNative [(String, String, String, TypeQ, Bool)]
funs = do
  [(String, String, String, Kind, Bool)]
funs' <- ((String, String, String, TypeQ, Bool)
 -> Q (String, String, String, Kind, Bool))
-> [(String, String, String, TypeQ, Bool)]
-> Q [(String, String, String, Kind, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(String
a, String
b, String
c, TypeQ
d, Bool
e) -> (String
a,String
b,String
c,,Bool
e) (Kind -> (String, String, String, Kind, Bool))
-> TypeQ -> Q (String, String, String, Kind, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ
d) [(String, String, String, TypeQ, Bool)]
funs
  [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(String, String, String, Kind, Bool)] -> [Dec]
genNative' [(String, String, String, Kind, Bool)]
funs')
  where
    genNative' :: [(String, String, String, Kind, Bool)] -> [Dec]
genNative' [] = []
#ifdef WEB_FFI
    genNative' ((hsName, cName, _, funType, _) : xs) =
      [ -- hsName :: funType
        SigD name funType,
        -- hsName = callRaylibFunction "_cName"
        FunD
          name
          [Clause [] (NormalB (AppE (VarE 'callRaylibFunction) (LitE (StringL ('_' : cName))))) []]
      ] ++ genNative' xs
      where
        name = mkName hsName
#else
    genNative' ((String
hsName, String
cName, String
cFile, Kind
funType, Bool
isSafe) : [(String, String, String, Kind, Bool)]
xs) =
      -- foreign import ccall safe/unsafe "cFile cName" hsName :: funType
      Foreign -> Dec
ForeignD (Callconv -> Safety -> String -> Name -> Kind -> Foreign
ImportF Callconv
CCall (if Bool
isSafe then Safety
Safe else Safety
Unsafe) (String
cFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cName) (String -> Name
mkName String
hsName) Kind
funType) Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [(String, String, String, Kind, Bool)] -> [Dec]
genNative' [(String, String, String, Kind, Bool)]
xs
#endif