Lookup.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Windll
-- Copyright   :  (c) Tamar Christina 2009 - 2010
-- License     :  BSD3
-- 
-- Maintainer  :  tamar@zhox.com
-- Stability   :  experimental
-- Portability :  portable
--
-- This module contains the lookup functions to convert Haskell to
-- C import types
--
-----------------------------------------------------------------------------

module WinDll.CodeGen.Lookup where

import WinDll.Structs.MShow.MShow
import WinDll.Structs.Structures
import WinDll.Structs.Folds.HaskellSrcExts
import WinDll.Session.Hs2lib
import WinDll.Lib.Native

import Data.List
import Data.Maybe
import Data.Generics (everywhere,mkT)

import qualified Language.Haskell.Exts as Exts

type LookupType = TypeNames -> Type -> Type

-- | Lookup the correct C type of the given value
lookupC :: Defs -> TypeNames -> Type -> Type
lookupC clist vars = lookupType vars (\x->if "CBF" `isPrefixOf` x then "_t" else "_t*") id clist

-- | Lookup the correct C# type of the given value
lookupCs :: (Bool -> Defs) -> Bool -> TypeNames -> Type -> Type
lookupCs cslist struct vars = lookupType vars (\x->if "CBF" `isPrefixOf` x then "" else "*") cbf (cslist struct)
  where cbf x = if "CBF" `isPrefixOf` x then "IntPtr" else x
       
-- | A general lookup function for types
-- .
-- NOTE: This needs to be rewritten to support Applied types in datastructures
-- .
-- e.g.:  data Foo = Foo (Maybe Int)       
lookupType :: TypeNames -> (String -> String) -> (String -> String) -> [(String,String)] -> Type -> Type
lookupType vars prefix test list 
  = let f = \x->fromMaybe (if x `elem` vars
                              then "void*" 
                              else "" ++ x ++ prefix x)  
                          (lookup (test x) list)
    in everywhere (mkT (inner f))
      where
          inner :: (String -> String) -> Exts.Name -> Exts.Name
          inner f (Exts.Ident  s) = Exts.Ident (f s)
          inner f (Exts.Symbol s) = Exts.Symbol (f s)
      
-- | Break up a Haskell type into it's losely coupled components, then convert them to c types.
-- .
-- When type applications are found, they're concatinated to match their specialized variants
-- .  e.g. Maybe Int -> Maybe_int      
genAndLookupC :: Defs -> Type -> TypeNames
genAndLookupC clist t = map lookup' (collectTypes t)
    where lookup' x = case lookup x clist of
                        Nothing -> intercalate "," (words x) ++ (if "CBF" `isPrefixOf` x 
                                                                    then "_t" else "_t*")
                        Just x' -> x'
            
-- | Lookup the C type's size in the lookup table \c_sizes\, this is needed when __stdcall is used.            
lookupSize :: [(String, Int)] -> String -> Int 
lookupSize c_sizes x = maybe defaultPointerSize id (lookup x c_sizes)

-- | Generate the appropriate C types from the given Haskell type
createCType :: Defs -> Type -> TypeNames
createCType clist 
   = foldType( const . const id
             , (++)
             , (\_ b   -> return ("Tuple"++show (length b)++"_t*"))
             , (\a     -> map (\t -> if "CBF" `isPrefixOf` t then t ++ "_t" else t ++ "*") a)
             , (\a b   ->  process a b)
             , (\a     ->maybe [mkRet a] (:[]) (lookup a clist)) . mshow
             , (\a     ->maybe [mkRet a] (:[]) (lookup a clist)) . mshow
             , id -- (\a     -> map (\t -> "(" ++ t ++ ")") a) -- C types can't have braces around them
             , (\_ b _ -> return (mkRet $ mshow b))
             , (\a _   -> a)
             )
        where stripBrace ('(':xs) = init xs
              stripBrace x        = x         

              process a b = if "IO_t*" `elem` a  -- We want to ignore IO, we assume all the functions preserve ref. transparency. in the case of FFI
                               then b'
                               else if "Ptr_t*" `elem` a -- We would want to transform the explicit Ptr type to a C pointer *
                                       then map (++"*") b'
                                       else a
                   where b' = map stripBrace b 
              
              mkRet x = if "CBF" `isPrefixOf` x 
                           then x ++ "_t"
                           else x ++ "_t*"
                                    
-- | Convert C/C++ types to C# types
convertCType :: Defs -> TypeName -> TypeName
convertCType c2cslist n = maybe (strip n) id (lookup n c2cslist)
  where strip n = if "_t" `isSuffixOf` n
                     then take (length n - 2) n
                     else if "_t*" `isSuffixOf` n
                             then take (length n - 3) n
                             else n
                             
-- | Some types when used in lists cannot use their managed counterparts.
--   like [String] needs to become char** in C# and not String*. Since
--   you cannot take the pointer of a managed structure.
swapList :: TypeName -> TypeName
swapList nm = maybe nm id (lookup nm swaplst)
  where swaplst :: [(String     , String    )]
        swaplst =  [("String"   , "char*"   )]

-- | Generate the appropriate C types from the given Haskell type
createCsType :: (Bool -> Defs) -> Type -> TypeNames
createCsType cslist
    = foldType( const . const id
              , (++)
              , (\_ b   -> return ("Tuples.Tuple"++show (length b)++"*"))
              , (\a     -> map ((\t -> if "CBF" `isPrefixOf` t then t ++ "" else t ++ "*") . swapList) a)
              , (\a b   -> process a b) -- We want to ignore IO, we assume all the functions preserve ref. transparency. in the case of FFI
              , (\a     ->maybe [mkRet a] (:[]) (lookup a cslist')) . mshow
              , (\a     ->maybe [mkRet a] (:[]) (lookup a cslist')) . mshow
              , id -- (\a     -> map (\t -> "(" ++ t ++ ")") a) -- The braces are irrelevant
              , (\_ b  _ -> return (mkRet $ mshow b))
              , (\a _   -> a)
              )
         where stripBrace ('(':xs) = init xs
               stripBrace x        = x
               
               cslist' = cslist False
               
               process a b = if "IO*" `elem` a  -- We want to ignore IO, we assume all the functions preserve ref. transparency. in the case of FFI
                                then b'
                                else if "Ptr*" `elem` a -- We would want to transform the explicit Ptr type to a C pointer *
                                        then map (++"*") b'
                                        else a
                    where b' = map stripBrace b 
               
               mkRet x = if "CBF" `isPrefixOf` x 
                            then x ++ ""
                            else x ++ "*"