module FFI.Anything.TH where
import Language.Haskell.TH
import Debug.Trace
parameters :: Type -> [Type] -- Result list are "ground" types
parameters t = case t of
AppT t1 t2 -> parameters t1 ++ parameters t2
ArrowT -> []
ConT name -> [ConT name]
-- TODO handle ListT, TupleT and so on
_ -> error $ "parameters: unhandled Type " ++ show t
-- TODO better use custom data type, tuples are quite finite
argTypesToTuple :: [Type] -> Type
argTypesToTuple types = foldl f (TupleT n) types
where
f a next = AppT a next
n = length types
debug :: (Show a, Monad m) => a -> m ()
debug x = trace ("\n" ++ show x ++ "\n") $ return ()
deriveCallable :: Name -> String -> Q [Dec]
deriveCallable funName exportedName = do
info <- reify funName
case info of
VarI name typ _mDec _fixity -> do
let _nameString = nameBase name
signatureList = parameters typ
paramTypes = init signatureList
returnType = last signatureList
typ' = [ SigD
(mkName exportedName)
(AppT
(AppT
ArrowT
(argTypesToTuple paramTypes)
)
returnType
)
]
debug typ'
debug $ pprint typ'
return []
_ -> error "deriveCallable: can only derive functions"
-- Example:
--
-- VarI
-- -- Name
-- FFI.Anything.f
-- -- Type
-- (AppT (AppT ArrowT (ConT GHC.Types.Int)) (AppT (AppT ArrowT (ConT GHC.Types.Double)) (ConT GHC.Base.String)))
-- -- Maybe Dec
-- Nothing
-- -- Fixity
-- (Fixity 9 InfixL)
--
-- Where the type "f :: Int -> Double -> String" is:
--
-- AppT
-- (AppT ArrowT (ConT GHC.Types.Int))
-- (AppT
-- (AppT ArrowT (ConT GHC.Types.Double))
-- (ConT GHC.Base.String)
-- )
--
--
-- The target is: runQ f_hs :: (Int, Double) -> String
-- so e.g.:
--
-- runQ [d| f_hs :: (Int, Double) -> String; f_hs = f_hs |]
--
-- which is:
--
-- [ SigD -- This is the type
-- f_hs
-- (AppT
-- (AppT
-- ArrowT
-- (AppT
-- (AppT (TupleT 2) (ConT GHC.Types.Int))
-- (ConT GHC.Types.Double)
-- )
-- )
-- (ConT GHC.Base.String)
-- )
-- , ValD -- This is the unimportant `f_hs = f_hs` part needed for the quasiquoter to complile
-- (VarP f_hs_2)
-- (NormalB (VarE f_hs_2))
-- []
-- ]