{-|

Module      : SDL.Raw.Helper
Copyright   : (c) 2015 Siniša Biđin
License     : MIT
Stability   : experimental

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.

-}

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

module SDL.Raw.Helper (liftF) where

import Control.Monad           (replicateM)
import Control.Monad.IO.Class  (MonadIO, liftIO)
import Language.Haskell.TH
import Language.Haskell.TH.Datatype.TyVarBndr (plainTVSpecified)

-- | 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 {t}. Num t => t -> Type -> t
count Int
0
  where
    count :: t -> Type -> t
count !t
n = \case
      (AppT (AppT Type
ArrowT Type
_) Type
t) -> t -> Type -> t
count (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) Type
t
      (ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
t) -> t -> Type -> t
count t
n Type
t
      (SigT Type
t Type
_)      -> t -> Type -> t
count t
n Type
t
      Type
_               -> t
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 :: 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
        [plainTVSpecified m]
        [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