module Foreign.HacanonLight.FFIToHs where
import Control.Monad.State
import Foreign.HacanonLight.Common
import Foreign.HacanonLight.DIS
import Language.Haskell.TH
import Debug.Trace
processFFIDecl :: String -> FFIDecl -> HsDecl
processFFIDecl name decl =
HsDecl (mkName name)
(ffiUnique decl)
fType
(createHsBody fnName diss retDIS)
(ffiPure decl)
where args = init (ffiType decl)
retType = last (ffiType decl)
retDIS = retType
diss = args
fnName = (ffiUnique decl)
inDIS = filter isInDIS diss
outDIS = filter isOutDIS diss ++ if disOperation retDIS == DISIgnore
then []
else [retDIS]
typesIn = map disType inDIS
typeOut = createTupleType (map disType outDIS)
fType = createArrowType (typesIn++[appT (conT (mkName "IO")) typeOut])
applyArgs :: ExpQ -> [ExpQ] -> ExpQ
applyArgs fn = worker
where worker [] = fn
worker (x:xs) = appE (worker xs) x
bindArgs :: [DIS] -> ([(DIS,Name)] -> ExpQ) -> ExpQ
bindArgs lst handle =
do args <- mapM (const (newName "arg")) inlst
if null inlst
then handle (zipper args lst)
else lamE (map varP args) (handle (zipper args lst))
where zipper [] [] = []
zipper xs (dis:ys)
| isOfOperation [DISOut,DISIgnore] dis = (dis,error "Out/ignore"):zipper xs ys
| otherwise = (dis,head xs):zipper (tail xs) ys
inlst = filter isInDIS lst
marshalArgs :: ([(DIS,Name)] -> ExpQ) -> [(DIS,Name)] -> ExpQ
marshalArgs handle lst = worker [] lst
where worker l [] = handle l
worker l ((dis,arg):xs) =
do sym <- newName "marshaledArg"
let tag = (dis,sym)
case disOperation dis of
DISIgnore-> worker l xs
_ -> [| $(disMarshal dis (varE arg)) $(lambda sym (worker (tag:l) xs)) |]
where lambda sym expr = lamE [varP sym] expr
callFunc :: ([(DIS,Name)] -> ExpQ) -> Name -> DIS -> [(DIS,Name)] -> ExpQ
callFunc handle fnName retDIS lst =
do retArg <- newName "ret"
doE [ bind retArg (applyArgs (varE fnName) (map varE argNames))
, noBindS $ handle (output retArg) ]
where argNames = map snd lst
output retArg
= (reverse $ filter (isOutDIS . fst) lst) ++
case disOperation retDIS of
DISIgnore -> []
_ -> [(retDIS,retArg)]
bind ret = bindS (varP ret)
unmarshalArgs :: [(DIS,Name)] -> ExpQ
unmarshalArgs lst = disUnMarshal dis tupExp
where dis = tuple (map fst lst)
tupExp = tupE (map varE (map snd lst))
createHsBody :: Name -> [DIS] -> DIS -> ExpQ
createHsBody fnName argDISs retDIS =
bindArgs argDISs (marshalArgs (callFunc unmarshalArgs fnName retDIS))