{-|

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 fname :: String
fname cname :: String
cname ftype :: 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]
++ "'" -- 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 "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'
            _  -> [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 0
  where
    count :: p -> Type -> p
count !p
n = \case
      (AppT (AppT ArrowT _) t :: Type
t) -> p -> Type -> p
count (p
np -> p -> p
forall a. Num a => a -> a -> a
+1) Type
t
      (ForallT _ _ t :: Type
t) -> p -> Type -> p
count p
n Type
t
      (SigT t :: Type
t _)      -> p -> Type -> p
count p
n Type
t
      _               -> p
n

-- | An expression where f is applied to n arguments.
applyTo :: Name -> [Exp] -> Exp
applyTo :: Name -> [Exp] -> Exp
applyTo f :: Name
f [] = Name -> Exp
VarE Name
f
applyTo f :: Name
f es :: [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 :: t Exp -> Exp -> Exp
loop as :: t Exp
as e :: 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 _ t :: Type
t -> do
    Name
m <- String -> Q Name
newName "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
        [Name -> TyVarBndr
plainTVSpecified Name
m]
        [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)
  t :: Type
t -> Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t