{-# 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.
  Type
t' <- Q Type
ftype -- Type of direct binding.

  -- The generated function accepts n arguments.
  [Name]
args <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Type -> Int
countArgs Type
t') (Q Name -> Q [Name]) -> Q Name -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName String
"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?
  [Dec]
sigd <- case [Name]
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Type -> Q Type
liftType Type
t'
    [Name]
_ -> [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []

  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
    [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ Foreign -> Dec
ForeignD (Foreign -> Dec) -> Foreign -> Dec
forall a b. (a -> b) -> a -> b
$ Callconv -> Safety -> String -> Name -> Type -> Foreign
ImportF Callconv
CCall Safety
Safe String
cname Name
f' Type
t',
          Pragma -> Dec
PragmaD (Pragma -> Dec) -> Pragma -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
f Inline
Inline RuleMatch
FunLike Phases
AllPhases
        ],
        [Dec]
sigd,
        [ Name -> [Clause] -> Dec
FunD
            Name
f
            [ [Pat] -> Body -> [Dec] -> Clause
Clause
                ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
args)
                (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ 'liftIO Name -> [Exp] -> Exp
`applyTo` [Name
f' Name -> [Exp] -> Exp
`applyTo` (Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
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 :: 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]
_ 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. [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. [a] -> a
head [Exp]
es
  where
    loop :: Foldable t => t Exp -> Exp -> Exp
    loop :: t Exp -> Exp -> Exp
loop t Exp
as Exp
e = (Exp -> Exp -> Exp) -> Exp -> t Exp -> Exp
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
    Name
m <- String -> Q Name
newName String
"m"
    Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$
      [TyVarBndr] -> Cxt -> Type -> Type
ForallT
#if MIN_VERSION_template_haskell(2,17,0)
        [PlainTV m SpecifiedSpec]
#else
        [Name -> TyVarBndr
PlainTV Name
m]
#endif
        [Type -> Type -> Type
AppT (Name -> Type
ConT ''MonadIO) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
VarT Name
m]
        (Type -> Type -> Type
AppT (Name -> Type
VarT Name
m) Type
t)
  Type
t -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t