module Foreign.HacanonLight.FFIToHs where


import Control.Monad.State

import Foreign.HacanonLight.Common
import Foreign.HacanonLight.DIS

import Language.Haskell.TH

import Debug.Trace


-- $(bind "haskellName" "cFunc" [arg1, arg2])
-- $(bindOps "haskellName" "cFunc" [arg1, arg2]
--   $ do setPure True
--        setCallConv CCall)
-- $(simpleBind "haskellAndCName" [arg1, arg2])
-- $(simpleBindOps ...)

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))