{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
--
-- Module  : SDL.Raw.Helper
-- License : BSD3
--
-- Exposes a way to automatically generate a foreign import alongside its lifted,
-- inlined MonadIO variant. Use this to simplify the package's SDL.Raw.* modules.
module SDL.Raw.Helper (liftF) where

import Control.Monad (replicateM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Language.Haskell.TH
  ( Body (NormalB),
    Callconv (CCall),
    Clause (Clause),
    Dec (ForeignD, FunD, PragmaD, SigD),
    Exp (AppE, VarE),
    Foreign (ImportF),
    Inline (Inline),
    Name,
    Pat (VarP),
    Phases (AllPhases),
    Pragma (InlineP),
    Q,
    RuleMatch (FunLike),
    Safety (Safe),
    TyVarBndr (PlainTV),
    Type (AppT, ArrowT, ConT, ForallT, SigT, VarT),
    mkName,
    newName,
#if MIN_VERSION_template_haskell(2,17,0)
    Specificity(SpecifiedSpec)
#endif
  )

-- | Given a name @fname@, a name of a C function @cname@ and the desired
-- Haskell type @ftype@, this function generates:
--
-- * A foreign import of @cname@, named as @fname'@.
-- * An always-inline MonadIO version of @fname'@, named @fname@.
liftF :: String -> String -> Q Type -> Q [Dec]
liftF :: String -> String -> Q Type -> Q [Dec]
liftF String
fname String
cname Q Type
ftype = do
  let f' :: Name
f' = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'" -- Direct binding.
  let f :: Name
f = String -> Name
mkName String
fname -- Lifted.
  t' <- Q Type
ftype -- Type of direct binding.

  -- The generated function accepts n arguments.
  args <- replicateM (countArgs t') $ newName "x"

  -- If the function has no arguments, then we just liftIO it directly.
  -- However, this fails to typecheck without an explicit type signature.
  -- Therefore, we include one. TODO: Can we get rid of this?
  sigd <- case args of
    [] -> ((Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: []) (Dec -> [Dec]) -> (Type -> Dec) -> Type -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type -> Dec
SigD Name
f) (Type -> [Dec]) -> Q Type -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Type -> Q Type
liftType Type
t'
    [Name]
_ -> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []

  return $
    concat
      [ [ ForeignD $ ImportF CCall Safe cname f' t',
          PragmaD $ InlineP f Inline FunLike AllPhases
        ],
        sigd,
        [ FunD
            f
            [ Clause
                (map VarP args)
                (NormalB $ 'liftIO `applyTo` [f' `applyTo` map VarE args])
                []
            ]
        ]
      ]

-- | How many arguments does a function of a given type take?
countArgs :: Type -> Int
countArgs :: Type -> Int
countArgs = Int -> Type -> Int
forall p. Num p => p -> Type -> p
count Int
0
  where
    count :: Num p => p -> Type -> p
    count :: forall p. Num p => p -> Type -> p
count !p
n = \case
      (AppT (AppT Type
ArrowT Type
_) Type
t) -> p -> Type -> p
forall p. Num p => p -> Type -> p
count (p
n p -> p -> p
forall a. Num a => a -> a -> a
+ p
1) Type
t
      (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
t) -> p -> Type -> p
forall p. Num p => p -> Type -> p
count p
n Type
t
      (SigT Type
t Type
_) -> p -> Type -> p
forall p. Num p => p -> Type -> p
count p
n Type
t
      Type
_ -> p
n

-- | An expression where f is applied to n arguments.
applyTo :: Name -> [Exp] -> Exp
applyTo :: Name -> [Exp] -> Exp
applyTo Name
f [] = Name -> Exp
VarE Name
f
applyTo Name
f [Exp]
es = [Exp] -> Exp -> Exp
forall (t :: * -> *). Foldable t => t Exp -> Exp -> Exp
loop ([Exp] -> [Exp]
forall a. HasCallStack => [a] -> [a]
tail [Exp]
es) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
f) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
forall a. HasCallStack => [a] -> a
head [Exp]
es
  where
    loop :: Foldable t => t Exp -> Exp -> Exp
    loop :: forall (t :: * -> *). Foldable t => t Exp -> Exp -> Exp
loop t Exp
as Exp
e = (Exp -> Exp -> Exp) -> Exp -> t Exp -> Exp
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE Exp
e t Exp
as

-- | Fuzzily speaking, converts a given IO type into a MonadIO m one.
liftType :: Type -> Q Type
liftType :: Type -> Q Type
liftType = \case
  AppT Type
_ Type
t -> do
    m <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"m"
    return $
      ForallT
#if MIN_VERSION_template_haskell(2,17,0)
        [PlainTV m SpecifiedSpec]
#else
        [PlainTV m]
#endif
        [AppT (ConT ''MonadIO) $ VarT m]
        (AppT (VarT m) t)
  Type
t -> Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t