{-# 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
liftF :: String -> String -> Q Type -> Q [Dec]
liftF fname cname ftype = do
let f' = mkName $ fname ++ "'"
let f = mkName fname
t' <- ftype
args <- replicateM (countArgs t') $ newName "x"
sigd <- case args of
[] -> ((:[]) . SigD f) `fmap` liftType t'
_ -> 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])
[]
]
]
]
countArgs :: Type -> Int
countArgs = count 0
where
count !n = \case
(AppT (AppT ArrowT _) t) -> count (n+1) t
(ForallT _ _ t) -> count n t
(SigT t _) -> count n t
_ -> n
applyTo :: Name -> [Exp] -> Exp
applyTo f [] = VarE f
applyTo f es = loop (tail es) . AppE (VarE f) $ head es
where
loop as e = foldl AppE e as
liftType :: Type -> Q Type
liftType = \case
AppT _ t -> do
m <- newName "m"
return $
ForallT
[PlainTV m]
[AppT (ConT ''MonadIO) $ VarT m]
(AppT (VarT m) t)
t -> return t