-- Output contents of a .hsc file to standard output

module WriteHsc where

import Data.Char
import C_BNF
import SplitBounds
import Template
import Text.ParserCombinators.Parsec
import HsfUtils
import System.Exit
import qualified Data.Map as Map
import Data.Maybe
import Data.List
import Control.Monad
import System.IO
import Control.Concurrent
import GHC.Conc

-- Name for the HSFFIG field access class, and module to import

fldclass = "HSFFIG.FieldAccess.FieldAccess"
fldmodule = "HSFFIG.FieldAccess"

-------------------------------------------------------------------------------------------

-- Write the beginning of the hsc code if the header filename
-- is known (Just ...). The beginning consists of
--  * an include statement (with header file name)
--  * module declaration (module name derived form the header file name)
--  * import statements for Foreign modules.

-- If header file name cannot be obtained (gcc -E -P) (mfn == Nothing)
-- then placeholders will be placed instead of header file name and module
-- name declared. This may be useful if something other is desired for
-- module name rather than header filename derivative.
-- Derivation of module name includes stripping file path, uppercasing the header filename
-- and replacing dots with underscores (so most likely module name will end
-- with _H).

ghcopts = "{-# OPTIONS -fglasgow-exts -XForeignFunctionInterface #-}"

writeModHdr mfn = do let fmfn = finalizeModuleName mfn
                     writeTemplate stdout
                     putStrLn $ "#def void _dummy_force_" ++ fmfn ++ "_hsc_c (void) { }"
                     putStrLn $ ghcopts
                     putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfn ++ "\n"
                     putStrLn $ ghcopts
                     putStrLn $ "#include " ++ (finalizeFileName mfn)
                     putStrLn $ "#ifndef __quote__"
                     putStrLn $ "#define __quote__(x...) x"
                     putStrLn $ "#endif"
                     putStrLn $ ""
                     putStrLn $ "module " ++ fmfn ++ "("
                     putStrLn $ "  module " ++ fmfn ++ ","
                     putStrLn $ splitOpen
                     putStrLn $ "  module " ++ fmfn ++ "_C,"
                     putStrLn $ "  module " ++ fmfn ++ "_S,"
                     putStrLn $ "  module " ++ fmfn ++ "_F,"
                     putStrLn $ "  module " ++ fmfn ++ "_E,"
                     putStrLn $ "  module " ++ fmfn ++ "_S_d,"
                     putStrLn $ "  module " ++ fmfn ++ "_S_t,"
                     putStrLn $ "  module " ++ fmfn ++ "_S_n,"
                     putStrLn $ splitClose
                     putStrLn $ "  module " ++ fldmodule ++ ","
                     putStrLn $ "  module Foreign,"
                     putStrLn $ "  module Foreign.C.String,"
                     putStrLn $ "  module Foreign.C.Types) where"
                     putStrLn $ ""
                     putStrLn $ "import Foreign"
                     putStrLn $ "import Foreign.Ptr"
                     putStrLn $ "import Foreign.C.Types"
                     putStrLn $ "import Foreign.C.String"
                     putStrLn $ "import " ++ fldmodule
                     putStrLn $ splitOpen
                     putStrLn $ "import " ++ fmfn ++ "_C"
                     putStrLn $ "import " ++ fmfn ++ "_S"
                     putStrLn $ "import " ++ fmfn ++ "_F"
                     putStrLn $ "import " ++ fmfn ++ "_E"
                     putStrLn $ "import " ++ fmfn ++ "_S_d"
                     putStrLn $ "import " ++ fmfn ++ "_S_t"
                     putStrLn $ "import " ++ fmfn ++ "_S_n"
                     putStrLn $ "import " ++ fldmodule
                     putStrLn $ splitClose
                     putStrLn $ "\n" ++ splitEnd ++ "\n"

writeSplitHeaderX imps rexps mn = do
  putStrLn $ splitOpen
  putStrLn $ ghcopts
  putStrLn $ "module " ++ mn ++ " ("
  mapM (putStrLn . (\s -> "  module " ++ s ++ ",")) rexps
  putStrLn $ "  module " ++ mn
  putStrLn $ ") where\n"
  putStrLn $ "import Foreign"
  putStrLn $ "import Foreign.C.Types"
  mapM (putStrLn . ("import " ++)) imps
  putStrLn $ splitClose
  putStrLn $ ""

writeSplitHeader imps mn = writeSplitHeaderX imps [] mn

--------------------------------------------------------------------------------------

-- For every constant defined in the headers, produce accessor functions
-- using the following pattern:
-- c_CONST = #const CONST i. e. first character of the constant name
-- is lowercased.
-- Not all constants defined in the header file are good for inclusion
-- in the generated bindings code. For each, a short two-liner program
-- will be compiled. If there are no syntax errors, the constant qualifies.
-- This requires knowledge of the header file name. Therefore if it was impossible
-- to determine it, constants will not be included.

writeConstAccess _ _ Nothing = return ()
writeConstAccess tus gcc mbfn@(Just fn) = do
  let    cnsts = Map.keys $ Map.filterWithKey constonly tus
         constonly _ DictDef = True
         constonly _ _ = False
  nsect <- writeConstAccess' 0 cnsts gcc mbfn
  let fmfnc = (finalizeModuleName (Just fn)) ++ "_C"
      cmods = map (((fmfnc ++ "_") ++) . show) [0 .. (nsect - 1)]
  putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfnc ++ "\n"
  writeSplitHeaderX cmods cmods fmfnc
  putStrLn $ "\n" ++ splitEnd ++ "\n"
  return ()

writeConstAccess' n [] _ _ = return n
writeConstAccess' n tusd gcc Nothing = return 0
writeConstAccess' n tusd gcc (Just fn) = 
  do let cnsts = take 100 tusd
         trem = drop 100 tusd
         fmfnc = (finalizeModuleName (Just fn)) ++ "_C_" ++ show n
         finfn = finalizeFileName (Just fn)
     putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfnc ++ "\n"
     writeSplitHeader [] fmfnc
     guess <- guessConsts finfn gcc cnsts >>= return . filter ((/= NoGuess) . fst . snd)
     let vagues = filter ((== Vague) . fst . snd) guess
         ints = filter ((== GuessInt) . fst . snd) guess
         floats = filter ((== GuessFloat) . fst . snd) guess
     mapM (oneconst ExitSuccess) (map fst ints)
     mapM (oneconst ExitSuccess) (map fst floats)
     testsyn (testConst finfn gcc) (map fst vagues)
     putStrLn $ "\n" ++ splitEnd ++ "\n"
     writeConstAccess' (n + 1) trem gcc (Just fn)

testsyn fn [] = return ()

testsyn fn cs = do
  let nproc = 4
  let h = take nproc cs
      t = drop nproc cs
  let nt = length h
  mvs <- mapM (\_ -> newEmptyMVar) h
  hx <- zipWithM (\c v -> forkOS (do
    x <- fn c
    putMVar v x)) h mvs
  whx <- mapM takeMVar mvs
  zipWithM oneconst whx h
  testsyn fn t


-- No import for #define alloca.

oneconst _ "alloca" = return ()

oneconst rc cnst = 
  case rc of
    ExitSuccess -> (putStrLn $ "c_" ++ cnst ++ " = #const " ++ cnst) >> hFlush stdout
    _ -> return ()

---------------------------------------------------------------------------------------

-- For every enumeration, compute values for implicitly valued variants.
-- Then emit all variants as constants similarly to constants themselves.

writeEnums tus tymap fn =
  do let enums = Map.toList $ Map.filterWithKey enumsonly tymap
         enumsonly _ (DictEnum _) = True
         enumsonly _ _ = False
         enumsof (DictEnum e) = map simplifyenum e
         simplifyenum (Enumerator s Nothing) = (s,"")
         simplifyenum (Enumerator s (Just e)) = (s,show e)
         allvariants = concat $ map (fillenum "0") $ map (enumsof . snd) enums
         fmfne = (finalizeModuleName fn) ++ "_E"
     putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfne ++ "\n"
     writeSplitHeader [] fmfne
     mapM onevariant allvariants
     putStrLn $ "\n" ++ splitEnd ++ "\n"


onevariant (s,e) = 
  putStrLn $ "e_" ++ s ++ " = #const " ++ e

-- Fill an enumeration with explicit variants. Every implicit variant
-- is considered to be its predecessor plus 1. The first implicit variant
-- is 0.

fillenum _ [] = []
fillenum val (ed:eds) = fv : (fillenum (nxtval fv) eds) where
  fv = fixval val ed
  fixval val (s,"") = (s,val)
  fixval _ (s,e) = (s,e)
  nxtval (_,vals) = "(" ++ vals ++ ") + 1"

---------------------------------------------------------------------------------------

-- For every C structure or union, declare a newtype, and field access functions.
-- The type map will be scanned for recorded structures.

-- To access structure fields, special data constructor will be created,
-- containing variants for all field names found in the header.

-- To provide convinient syntax of field access, a class is defined in each
-- module created from a header, e. g. for `example.h':

-- class EXAMPLE_H_fieldaccess a b c | a c -> b where
--   (-->) :: Ptr a -> c -> IO b
--   (<--) :: (Ptr a, c) -> b -> IO ()

-- and for each named field an algebraic data type whose name is derived from
-- the field name:

--  data V_a = V_a 
--  data V_b = V_b
--  data V_c = V_c

-- also similar constructs with X_ and D_ prefixes.

-- The combinator, (-->), is defined to access fields of structures by their
-- derivative names. For example, given a struct STR {int blah;};, and
-- a pointer `ptrstr' returned from some function, the field blah may be
-- accessed as `ptrstr --> V_blah.

-- For the size of the structure, a fictive field, V_sizeof, is defined.

-- Functional dependencies in the class are necessary to eliminate the need
-- to explicitly specify retrieved value's type in the calling function. That is,
-- structure type (a) and field selector type (c) uniquely determine the return type (b).

-- Instance (minimal) of Storable is also provided for each structure
-- to be able to use alloca/malloc when necessary.

data StructInfo = StructInfo {
  strName :: String,				-- structure type name as supplied
  trueName :: String,				-- true name of the structure
  convName :: String,				-- converted name of the structure
  cSyntax :: String				-- C syntax layout of the structure
} deriving (Show)

data FieldInfo = FieldInfo {
  fldName :: String,				-- field name
  fldType :: String,				-- field type
  instType :: String,				-- field type for instance FieldAccess
  fldTypeString :: TypeString,			-- field type string after the TCM state machine
  fldArity :: Int,				-- field arity (0 for non-functions)
  fldDims :: String,				-- dimensions if an array ([] for scalars)
  isDynamic :: Bool,				-- field represents a dynamic import (FunPtr)
  isDirect :: Bool,				-- field represents a direct structure/union
  isVariadic :: Bool,				-- field represents a variadic function
  isBitField :: Bool,				-- bit field
  internId :: String				-- field symbol internal ID
} deriving (Show)

sd2fld (StructDeclarator (Just d) _) = id2name (InitDeclarator d Nothing)
sd2fld _ = ""

collectfields dss = concat $ map collectfields' dss where
  collectfields' (DictStruct su ss) = concat $ map collectfields'' ss where
    collectfields'' (StructDecl _ sds) = map sd2fld sds where

-- Anonymous identifiers (starting with "_@_") will not be processed.

writefields flds fn =
  mapM fldata flds where
    fldata ('_':'@':'_':_) = return ()
    fldata fld = do putStrLn $ "data V_" ++ fld ++ " = V_" ++ fld
                    putStrLn $ "data X_" ++ fld ++ " = X_" ++ fld
                    putStrLn $ "data D_" ++ fld ++ " = D_" ++ fld

writeStructures tus tymap fn = 
  do let structs = Map.filterWithKey structonly tymap
         typedefs = Map.toList $ Map.filterWithKey tdefonly tymap
         typeeqs = Map.toList $ Map.filterWithKey tteqonly tymap
         structonly _ (DictStruct _ _) = True
         structonly _ _ = False
         tdefonly _ (DictDecl _) = True
         tdefonly _ _ = False
         tteqonly _ (DictTypeEq _) = True
         tteqonly _ _ = False
         allfields = nub $ collectfields (Map.elems structs)
         fmfns = (finalizeModuleName fn) ++ "_S"
         strpairs = Map.toList structs
         strnames = map fst strpairs
         submods = map (((fmfns ++ "_") ++) . convname) strnames
     putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfns ++ "\n"
     writeSplitHeaderX submods submods fmfns
     putStrLn $ "\n" ++ splitEnd ++ "\n"
     putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfns ++ "_d\n"
     writeSplitHeader [] $ fmfns ++ "_d"
     writefields ("sizeof" : allfields) fn
     putStrLn $ "\n" ++ splitEnd ++ "\n"
     putStrLn ""
     putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfns ++ "_t\n"
     writeSplitHeader [fmfns ++ "_n"] $ fmfns ++ "_t"
     mapM (tdefalias tymap) (typedefs ++ typeeqs)
     putStrLn $ "\n" ++ splitEnd ++ "\n"
     putStrLn ""
     putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfns ++ "_n\n"
     writeSplitHeader [] $ fmfns ++ "_n"
     mapM structnewtype strnames
     putStrLn $ "\n" ++ splitEnd ++ "\n"
     mapM (onestruct tymap fn) strpairs
     return ()

-- Fill out a strinfo data structure.

mkStrInfo strname strdecl =
  StructInfo {
    strName = strname,
    trueName = if (isAnon strname) then (show strdecl) else (truename strname),
    convName = convname strname,
    cSyntax = show strdecl
  }

-- Fill out a fldinfo data structure.

mkFldInfo tymap xd = 
  let state = (dcl2ts . (connectta tymap) . simplifystructdecl) xd
      sdcl2sd (StructDecl _ s) = head s
      fldn = (sd2fld . sdcl2sd) xd
      stt = state2ts state
      cmap = mapc2hs stt
      stsp = condmonadify cmap
      condmonadify t = if (dyn t) then (monadify "IO" t) else t
      dyn t = case t of
        (PtrF _ _) -> True
        other -> False
      dir = isdirstruct cmap
      sdecl = ts2ts stsp
      bit = '|' `elem` sdecl
      instt =
        (case isarray stt of
           True -> "Ptr ("
           False -> "(" )
          ++ (case dyn stt of
                True  -> unfptr sdecl
                False -> case dir of
                  True  -> "Ptr " ++ (drop 1 sdecl)
                  False -> case bit of
                    True -> drop 1 $ dropWhile (/= '|') sdecl
                    False -> sdecl) ++ ")"
      dims = case isarray stt of
        True -> arrdims stt
        False -> []
      arity tsp = case tsp of
        TApply ts -> (length ts) - 1
        PtrF _ t -> arity t
        other -> 0
      intern = case (Map.lookup ("ID " ++ fldn) tymap) of
        Just (DictId n) -> "___" ++ (show n) ++ "___"
        other -> ""
      isarray tt = case tt of
        TString ts -> isarrt ts
        TString' ts -> isarrt ts
        PtrV _ t -> isarray t
        other -> False
      arrdims tt = case tt of
        TString ts -> (fst . splitarrt) ts
        TString' ts -> (fst . splitarrt) ts
        PtrV _ t -> arrdims t
        other -> []
  in  FieldInfo {
        fldName = fldn,
        fldType = sdecl,
        instType = instt,
        fldTypeString = stsp,
        fldArity = arity stsp,
        fldDims = dims,
        isDynamic = dyn stt,
        isDirect = dir,
        isBitField = bit,
        isVariadic = isvariadic cmap,
        internId = intern
      }

-- Toplevel wrapper to fill out structure and field descriptors.

mkStructsInfo tymap strname strdecl = 
  let xdecls = decls strdecl
      decls (DictStruct su s) = expdecls s
      strinfo = mkStrInfo strname strdecl
      fldinfos = map (mkFldInfo tymap) xdecls
  in  (strinfo, fldinfos)

-- Write complete definition for a single structure/union.

onestruct tymap fn (strname,strdecl) = 
  do let strm = fmfns ++ "_" ++ (convname strname)
         fmfns = (finalizeModuleName fn) ++ "_S"
         (strinfo, fldinfos) = mkStructsInfo tymap strname strdecl
     putStrLn ""
     putStrLn "--"
     putStrLn ""
     putStrLn $ "\n" ++ splitBegin ++ "/" ++ strm ++ "\n"
     writeSplitHeader (fldmodule : (map (fmfns ++) ["_t", "_n", "_d"])) strm
     mapM (structinstance fn strinfo) fldinfos
     when ((length fldinfos) /= 0) $ structinstance fn strinfo FieldInfo {
       fldName = "sizeof",
       fldType = "CInt",
       instType = "CInt",
       fldArity = 0,
       fldTypeString = TString' "CInt",
       fldDims = [],
       isDynamic = False,
       isDirect = False,
       isBitField = False,
       isVariadic = False,
       internId = ""
     }
     putStrLn $ splitEnd

-- Expand declarations so that if there are multiple member declarations
-- of the same type, the same number of one-member declarations will be created.

expdecls sds = concat $ map expdecls' sds where
  expdecls' (StructDecl dss []) = []
  expdecls' (StructDecl dss (sdd:sdds)) = (StructDecl dss [sdd]):(expdecls' (StructDecl dss sdds)) 

-- Convert a structure/union name to Haskell type name.

convname ('s':'t':'r':'u':'c':'t':'@':strname) = "S_" ++ strname
convname ('u':'n':'i':'o':'n':'@':strname) = "U_" ++ strname

-- Restore true structure/union/typedef name for use with hsc2hs.
-- If the structure name ends with a prime, then this is a typedef,
-- and the word struct/union along with the prime must be removed.
-- If it does not end with a prime, @ is replaced with space.

truename strname
  | head (reverse strname) == '\'' = reverse (drop 1 (reverse (drop 2 (convname strname))))
  | otherwise = map at2space strname
      where at2space '@' = ' '
            at2space z = z

-- Write the instance of the field access class for this structure.
-- For direct structures/unions (fldtype starts with '@') a pointer
-- will be retrieved, otherwise a value. For function pointers,
-- a pointer factory will be created and applied, so ready to use
-- function (in Haskell sense) will be returned.
-- For anonymous structures, their C syntax (deparsed) will be used
-- to form the #peek construction.

structinstance fn strinfo fldinfo | take 3 (fldName fldinfo) == "_@_" = return ()

structinstance fn strinfo fldinfo = do
  let icid = (internId fldinfo) ++ (convName strinfo)
      mkfld = icid ++ "___mk"
      wrfld = icid ++ "___wr"
      arglist = intlv (take (fldArity fldinfo) $ map (('_' :) . show) [1..]) " "
      exclimp = case (isDynamic fldinfo, isVariadic fldinfo||isDirect fldinfo) of
                  (False, _)    -> False
                  (True, False) -> False
                  (True, True)  -> True
  instheader fldclass strinfo fldinfo instType "V_"
  case exclimp of
    True -> excludeimport (fldName fldinfo) (isVariadic fldinfo) (isDirect fldinfo)
    False -> case (isBitField fldinfo) of
      True -> bitfield strinfo fldinfo
      False -> do 
        case (isDynamic fldinfo) of
          False -> case (isDirect fldinfo) of
            True  -> ptrfield strinfo (fldName fldinfo)
            False -> case (fldName fldinfo == "sizeof") of
              True  -> sizefield strinfo
              False -> peekfield strinfo (fldName fldinfo)
          True  -> do peekdynfld strinfo (fldName fldinfo) mkfld wrfld
                      makedynfld fldinfo mkfld
                      makewrpfld fldinfo wrfld
                      cbckimport ((convName strinfo) ++ "_" ++ (fldName fldinfo)) 
                                 (fldTypeString fldinfo)
                      when (fldArity fldinfo > 0) $ do
                        instheader fldclass strinfo fldinfo instType "X_"
                        putStrLn $ "  z ==> X_" ++ (fldName fldinfo) ++ " = \\" ++ 
                                   arglist ++ " -> do"
                        putStrLn $ "    x <- z --> V_" ++ (fldName fldinfo) 
                        putStrLn $ "    r <- x " ++ arglist
                        putStrLn $ "    return r"
        when ((length $ fldDims fldinfo) > 0) $ dimfield strinfo fldinfo

-- Output an instance header for the given structure, field, type.

instheader fc si fi ft pfx = 
  putStrLn $ "\ninstance " ++ fc ++ " " ++ (convName si) ++ " (" ++
             (ft fi) ++ ") " ++ pfx ++ (fldName fi) ++ " where"

-- For structures members which are arrays, output 
-- a pseudo-member to access the dimensions

dimfield si fi = do
  instheader fldclass si fi (\_ -> "[Int]") "D_"
  putStrLn $ "  z --> D_" ++ (fldName fi) ++ " = return " ++ (fldDims fi)
  putStrLn $
    "  (z, D_" ++ (fldName fi) ++ ") <-- v = error $ \"dimensions of a field  cannot be set\""

-- Output code to access a bit field.

bitfield si fi = do
  let icid = (internId fi) ++ (convName si)
      getbf = icid ++ "___get___" ++ (fldName fi) ++ "___"
      setbf = icid ++ "___set___" ++ (fldName fi) ++ "___"
      getbfhs = getbf ++ "___hs___"
      setbfhs = setbf ++ "___hs___"
      ctype = map u2sp $ takeWhile (/= '|') (fldType fi)
      u2sp '_' = ' '
      u2sp z = z
  putStrLn $ "  z --> V_" ++ (fldName fi) ++ " = " ++ getbfhs ++ " z"
  putStrLn $ "  (z, V_" ++ (fldName fi) ++ ") <-- v = " ++ setbfhs ++ " z v"
  putStrLn $ ""
  putStrLn $ "foreign import ccall unsafe \"static " ++ getbf ++ "\""
  putStrLn $ "  " ++ getbfhs ++ " :: Ptr " ++ (convName si) ++
             " -> IO " ++ (instType fi)
  putStrLn $ "foreign import ccall unsafe \"static " ++ setbf ++ "\""
  putStrLn $ "  " ++ setbfhs ++ " :: Ptr " ++ (convName si) ++
             " -> " ++ (instType fi) ++ " -> IO ()"
  putStrLn $ ""
  putStrLn $ "#def inline " ++ ctype ++ " " ++ getbf ++ "(void *s) {"
  putStrLn $ "  return ((" ++ (trueName si) ++ " *)s) -> " ++ (fldName fi) ++ ";"
  putStrLn $ "}"
  putStrLn $ ""
  putStrLn $ "#def inline void " ++ setbf ++
             "(void *s, " ++ ctype ++ " v) {"
  putStrLn $ "  ((" ++ (trueName si) ++ " *)s) -> " ++ (fldName fi) ++ " = v;"
  putStrLn $ "}"

ptrfield _ ('_':'@':'_':_) = return ()

ptrfield si fld = do
  putStrLn $ 
    "  z --> V_" ++ fld ++ " = return $ (#ptr __quote__(" ++ (trueName si) ++ "), " ++ fld ++ ") z"
  putStrLn $
    "  (z, V_" ++ fld ++ ") <-- v = error $ \"field " ++ fld ++ " is a structure or an array:" 
                                                      ++ " cannot be set\""

-- Write the V_sizeof field.
-- Also write a instance Storable for the structure. Only sizeOf and alignment
-- are effective. Peek and poke will cause error if used. 

sizefield si = do
  putStrLn $ "  z --> V_sizeof = return $ (#size __quote__(" ++ (trueName si) ++ "))"
  putStrLn $ ""
  putStrLn $ "instance Storable " ++ (convName si) ++ " where"
  putStrLn $ "  sizeOf _ = (#size __quote__(" ++ (trueName si) ++ "))"
  putStrLn $ "  alignment _ = 1"
  putStrLn $ "  peek _ = error $ \"peek and poke cannot be used with " ++ (trueName si) ++ "\""
  putStrLn $ "  poke _ = error $ \"peek and poke cannot be used with " ++ (trueName si) ++ "\""

-- A regular structure member which can be read and set.

peekfield si fld = do
  putStrLn $ "  z --> V_" ++ fld ++ " = (#peek __quote__(" ++ (trueName si) ++ "), " ++ fld ++ ") z"
  putStrLn $ "  (z, V_" ++ fld ++ ") <-- v = (#poke __quote__(" ++ (trueName si) ++ "), " ++ 
             fld ++ ") z v"

-- Output dynamic wrappers for a structure member holding function pointer.

makedynfld fldinfo mkf = do
  putStrLn $ "foreign import ccall \"dynamic\"\n" ++
             "  " ++ mkf ++ " :: (" ++ (fldType fldinfo) ++ ") -> (" ++ (instType fldinfo) ++ ")"

makewrpfld fldinfo wrp  = do
  putStrLn $ "foreign import ccall \"wrapper\"\n" ++
             "  " ++ wrp ++ " :: (" ++ (instType fldinfo) ++ ") -> IO (" ++ (fldType fldinfo) ++ ")"

-- Output code to access a structure member containing a function pointer.

peekdynfld si fld mkf wrp = do
  putStrLn $ "  z --> V_" ++ fld ++ " = (#peek __quote__(" ++ (trueName si) ++ "), " ++ 
             fld ++ ") z" ++
             " >>= (return . " ++ mkf ++ ")"
  putStrLn $ "  (z, V_" ++ fld ++ ") <-- v = (" ++ wrp ++ " v) >>= " ++
             "(#poke __quote__(" ++ (trueName si) ++ "), " ++ fld ++ ") z"


-- Write newtype statements for every structure.

structnewtype strname = do
  putStrLn $ "newtype " ++ (convname strname) ++ " = " ++ (convname strname) ++ " ()"

-- Write type declarations for all type aliases.

tdefalias tymap (tal, DictDecl (Declaration dss [id] _)) = do
  let target = (ts2ts . 
                (monadify "IO") . 
                mapc2hs . 
                state2ts . 
                dcl2ts . 
                (connectta tymap)) (simplifydecl dss id)
      polish ('@':s) = s
      polish z = z
  putStrLn $ "type T_" ++ tal ++ " = " ++ (polish target)

-- Write type equivalencies created during fixing named-within-anonymous struct
-- declarations.

tdefalias tymap (tal, DictTypeEq trg) =
  putStrLn $ "type " ++ tal ++ " = " ++ trg


-- Similarly to Declaration, simplify a structure/union member declaration.

simplifystructdecl (StructDecl dss [sd]) = simplifydecl (fst isd) (snd isd) where
  isd = initdecl dss sd
  initdecl dss (StructDeclarator (Just d) Nothing) = (dss, InitDeclarator d Nothing)
  initdecl _ (StructDeclarator (Just d) (Just c)) = 
    ((DeclSpecType (TypeSpecPrim "$BF$")):dss, InitDeclarator d Nothing)


---------------------------------------------------------------------------------------

-- For every standalone (declared at top level) function or variable
-- (i. e. an unary function), unless it returns a structure.
-- To determine whether a function returns a structure rather than a pointer,
-- its return type alias (if any) is traced back to the original type.
-- If include file name is provided, it will be used in FFI declarations.

inclname (Just fn) = fn
inclname Nothing = ""

writeStandaloneFunctions tus tymap fn = 
  do let imps = map ((finalizeModuleName fn) ++) ["_S", "_C", "_E", "_S_d","_S_t","_S_n"]
         fmfnf = (finalizeModuleName fn) ++ "_F"
     putStrLn $ "#include <stdlib.h>"
     putStrLn $ "\n" ++ splitBegin ++ "/" ++ fmfnf ++ "\n"
     writeSplitHeader imps fmfnf
     mapM (onefunc' tymap (inclname fn)) tus
     putStrLn $ "\n" ++ splitEnd ++ "\n"
     return ()

-- One TransUnitDecl may contain multiple InitDeclarator's.
-- Take care on those assuming they all have the same return
-- type and attributes.

onefunc' tymap ifn (TransUnitDecl (Declaration dss ids ats)) = 
  do mapM (onefunc tymap ifn (typeonly dss) ats) ids
     return ()

onefunc' _ _ _ = return ()

-- Keep only primitive types and type aliases.

typeonly dss = filter typeonly' dss where
  typeonly' (DeclSpecType _) = True
  typeonly' _ = False

-- Retrieve name from an InitDeclarator. This is taken from (Left s)
-- of the last unnested declarator.


dcl2name (Declarator _ (Left s) _) = s
dcl2name (Declarator _ (Right d') _) = dcl2name d'

id2name (InitDeclarator d _) = dcl2name d

-- Retrieve the return type from a declaration as a list of type name
-- strings. Enums are represented as integers.

ds2rtn [] = [] 
ds2rtn (d:ds) = (ds2str d):(ds2rtn ds)
ds2str (DeclSpecType (TypeSpecPrim s)) = s
ds2str (DeclSpecType (TypeSpecAlias s)) = s
ds2str (DeclSpecType (TypeSpecStruct (StructSpec s1 "" _))) = 
  error $ "unfixed declaration of anonymous " ++ s1
ds2str (DeclSpecType (TypeSpecStruct (StructSpec s1 s2 _))) = s1 ++ "_" ++ s2
ds2str (DeclSpecType (TypeSpecEnum (EnumSpec "" _))) = 
  error $ "unfixed declaration of anonymous enum"
ds2str (DeclSpecType (TypeSpecEnum (EnumSpec s _))) = "int"
ds2str z = error $ "ds2str: " ++ (show z)

-- Simplify a Declaration by keeping only type declarations, Declarators
-- without initializers, etc.

data DeclarationS = DeclarationS [String]            -- remains of [DeclSpec]
                                 DeclaratorS         -- remains of InitDeclarator
                                 deriving (Show)

data DeclaratorS = DeclaratorS Int                   -- pointer depth
                               (Maybe DeclaratorS)   -- if "Right Declarator"
                               DeclType              -- remains of CPI
                               deriving (Show)

data DeclType = DeclTypeVar                          -- for variables
              | DeclTypeVariadic                     -- to signal a variadic function
              | DeclTypeFixed [DeclarationS]         -- converted CPIs for regular functions
              | DeclTypeUnknown String               -- not implemented yet
              deriving (Show)

simplifydecl dss id@(InitDeclarator decl mbi) = 
  DeclarationS dsn' (simplifyid $ InitDeclarator decl' mbi) where
    dsn = ds2rtn $ typeonly dss
    (dsn', decl') = convarray (dsn, decl)

-- Convert array types with empty brackets to pointers, i. e. a[][] into int **a.
-- Arrays with nonempty dimension information keep that information in their
-- typestrings.

convarray (tss, d@(Declarator ps esd [])) = (tss, d)

convarray (tss, d@(Declarator ps esd (cpi:cpis))) = 
  case cpi of
    CPICon Nothing -> convarray (tss, Declarator (ps ++ [Pointer []]) esd cpis)
    CPICon (Just con) -> convarray (con2num con : tss, Declarator ps esd cpis)
    other -> (tss, d)

-- When dealing with array dimensions (which may be C constant expressions),
-- wrap them in the #const macro for hsc2hs to process. Replace underscores
-- (_) with backquotes (`) temporarily not to confuse the further processing
-- of the type because underscores serve as separators between parts of the type
-- definition.

con2num con = "(#const(" ++ map un2bq (show con) ++ "))@" where
  un2bq '_' = '`'
  un2bq z = z

convdims d@(Declarator ps esd []) = d

convdims d@(Declarator ps esd (cpi:cpis)) = 
  case cpi of
    (CPICon Nothing) -> convdims (Declarator (ps ++ [Pointer []]) esd cpis)
    other      -> d

-- simplify InitDeclarator (convert to DeclaratorS).

simplifyid (InitDeclarator dd _) = 
  mkdecls (convdims dd) where
    mkdecls (Declarator ps esd cpis) = 
      DeclaratorS (length ps) (convesd esd) (convcpis cpis)
    convesd (Left _) = Nothing
    convesd (Right dd') = 
      Just (mkdecls (convdims dd'))
    convcpis [] = DeclTypeVar
    convcpis [CPIEmpty] = DeclTypeFixed []
    convcpis [CPIPar _ Variadic] = DeclTypeVariadic
    convcpis [CPIPar pds Fixed] = DeclTypeFixed (map convpdecl pds)
    convcpis z = DeclTypeUnknown (show z)
    convpdecl (ParamDecl pdds mbd) = simplifydecl pdds (mbd2id mbd)
    mbd2id (Just d) = InitDeclarator d Nothing
    mbd2id Nothing = InitDeclarator (Declarator [] (Left "") []) Nothing

-- Connect type aliases to the declarations that use them.

-- Apply connection with type aliases to every function parameter type

ctad tymap (DeclaratorS ps mbds dds) = 
  DeclaratorS ps mbds' dds'
    where mbds' = case mbds of
            Just d -> Just $ ctad tymap d 
            other -> mbds
          dds' = case dds of
            DeclTypeFixed dtds -> DeclTypeFixed $ map (connectta tymap) dtds
            other -> dds

-- Follow the type alias' chain of declarators, and when Nothing is found,
-- connect the target declarator (taken from the target declaration).

cncd tymap (DeclarationS rts decl) dclc = DeclarationS rts (cncd' (ctad tymap decl) dclc) where
  cncd' (DeclaratorS ps (Just d) dt) dclc = DeclaratorS ps (Just (cncd' d dclc)) (tpmap dt)
  cncd' (DeclaratorS ps Nothing dt) dclc = DeclaratorS ps (Just dclc) (tpmap dt)
  tpmap dtt = case dtt of
    DeclTypeFixed dtds -> DeclTypeFixed $ map (connectta tymap) dtds
    other -> dtt

-- When mapping type aliases, take care on possible array dimensions:
-- strip them before mapping (they look like n@ where n is a natural number),
-- and prepend them back after the mapping is done.

connectta tymap (DeclarationS rts decl) = 
  restoredims rtsdims $ connectta' tymap (DeclarationS rts' decl) where
    rtsdims = takeWhile ("@" `isSuffixOf`) rts
    rts' = dropWhile ("@" `isSuffixOf`) rts
    restoredims dms (DeclarationS r d) = DeclarationS (dms ++ r) d
    connectta' tymap (DeclarationS rts decl) = 
      let decl' = ctad tymap decl in
        case (length rts) of
          1 -> case (Map.lookup (head rts) tymap) of
                 Nothing -> DeclarationS rts decl'
                 Just (DictDecl (Declaration adss [aid] at)) -> 
                   cncd tymap (connectta tymap $ simplifydecl adss aid) decl'
                 other -> error $ (head rts) ++ " is not a type alias"
          other -> DeclarationS rts decl'

-- Type conversion state machine. The chain of DeclaratorS's starting at the first
-- DeclarationS is followed. Each DeclaratorS acts as an instruction modifying
-- the state.

data TypeString = TString String
                | TString' String	  -- same as TString but no more type mappings
                | TApply  [TypeString]
                | PtrF    Int TypeString
                | PtrV    Int TypeString
                | Mnd     String TypeString
                deriving (Show)

data TCMState = TCMState TypeString        -- current type string
                         Bool              -- True if function (to produce proper Ptr)
                         deriving (Show)

-- String representation of a TypeString

ts2ts (TString s) = s
ts2ts (TString' s) = s
ts2ts (TApply tss) = intlv (map ts2ts tss) " -> "
ts2ts (PtrV ps ts) = nptrs ps (ts2ts ts) "Ptr"
ts2ts (PtrF ps ts) = nptrs ps (ts2ts ts) "FunPtr"
ts2ts (Mnd  ms (TString ts)) = ms ++ " " ++ ts
ts2ts (Mnd  ms z) = ms ++ " (" ++ ts2ts z ++ ")"

nptrs 0 s _  = s
nptrs n s p = p ++ " (" ++ (nptrs (n - 1) s p) ++ ")"

-- Map C types in the type string to Haskell types (if available).

mapc2hs (TString' z) = TString' z

-- Function application: map type of each parameter and return type.
-- Take arguments-arrays into consideration.

mapc2hs (TApply tss) = TApply $ map mapc2hs_arr tss

-- Special cases.

-- Pointer types: map the target type.
-- Nested pointers: increase pointer depth. 
-- Pointers to void are represented as Ptr CChar.
-- Pointers to variadic functions are represented as pointers to nullary
-- functions.
-- Structures, unions: only pointers are valid.

mapc2hs (PtrF ps ts) = case ts of 
  PtrF ps' ts' -> mapc2hs (PtrF (ps + ps') ts')
  (TApply [TString "@@variadic@@"]) -> PtrF ps (TApply [TString "()"])
  other -> PtrF ps (mapc2hs ts) 

mapc2hs (PtrV ps ts) = case ts of
  PtrV ps' ts' -> mapc2hs (PtrV (ps + ps') ts')
  TString "void" -> mapc2hs (PtrV ps (TString "char"))
  TString ('s':'t':'r':'u':'c':'t':'_':strname) -> PtrV ps (TString ("S_" ++ strname))
  TString ('u':'n':'i':'o':'n':'_':strname) -> PtrV ps (TString ("U_" ++ strname))
  other -> PtrV ps (mapc2hs ts) 

-- Manually hardcoded type mapping, based on Page 32 of the FFI Addendum.

mapc2hs (TString "int") = TString' "CInt"
mapc2hs (TString "signed_int") = TString' "CInt"
mapc2hs (TString "unsigned_int") = TString' "CUInt"
mapc2hs (TString "signed") = TString' "CInt"
mapc2hs (TString "unsigned") = TString' "CUInt"
mapc2hs (TString "short") = TString' "CShort"
mapc2hs (TString "unsigned_short") = TString' "CUShort"
mapc2hs (TString "short_int") = TString' "CShort"
mapc2hs (TString "signed_short") = TString' "CShort"
mapc2hs (TString "signed_short_int") = TString' "CShort"
mapc2hs (TString "unsigned_short_int") = TString' "CUShort"
mapc2hs (TString "char") = TString' "CChar"
mapc2hs (TString "signed_char") = TString' "CSChar"
mapc2hs (TString "unsigned_char") = TString' "CUChar"
mapc2hs (TString "signed_long") = TString' "CLong"
mapc2hs (TString "long") = TString' "CLong"
mapc2hs (TString "unsigned_long") = TString' "CULong"
mapc2hs (TString "long_int") = TString' "CLong"
mapc2hs (TString "unsigned_long_int") = TString' "CULong"
mapc2hs (TString "long_long") = TString' "CLLong"
mapc2hs (TString "unsigned_long_long") = TString' "CULLong"
mapc2hs (TString "long_long_int") = TString' "CLLong" 
mapc2hs (TString "signed_long_long_int") = TString' "CLLong"
mapc2hs (TString "unsigned_long_long_int") = TString' "CULLong"
mapc2hs (TString "float") = TString' "CFloat"
mapc2hs (TString "double") = TString' "CDouble"
mapc2hs (TString "long_double") = TString' "CLDouble"
mapc2hs (TString "@@ptrdiff_t@@") = TString' "CPtrdiff"
mapc2hs (TString "@@size_t@@") = TString' "CSize"
mapc2hs (TString "@@wchar_t@@") = TString' "CWchar"
mapc2hs (TString "@@sig_atomic_t@@") = TString' "CSigAtomic"
mapc2hs (TString "@@clock_t@@") = TString' "CClock"
mapc2hs (TString "@@time_t@@") = TString' "CTime"
mapc2hs (TString "@@FILE@@") = TString' "CFile"
mapc2hs (TString "@@fpos_t@@") = TString' "CFpos"
mapc2hs (TString "@@jmp_buf@@") = TString' "CJmpBuf"
mapc2hs (TString "@@void@@") = TString' "()"
mapc2hs (TString "void") = TString' "()"
mapc2hs (TString "@@variadic@@") = TString' "WrongVariadicFunction"

-- Direct structures/unions: valid in some circumstances, but
-- require special treatment.

mapc2hs (TString ('s':'t':'r':'u':'c':'t':'_':strname)) =
  TString' ("@S_" ++ strname)

mapc2hs (TString ('u':'n':'i':'o':'n':'_':strname)) =
  TString' ("@U_" ++ strname)

-- Special pseudo-type for bit fields.

mapc2hs (TString ('$':'B':'F':'$':'_':s)) = TString' (s ++ "|" ++ ts2ts (mapc2hs (TString s)))

-- Array types: represented as pointers to the type of array element.
-- Array type string starts with a digit and contains @-sign at non-head
-- position.
-- The rest, will be converted into unknown types, and will cause
-- compilation error.

mapc2hs (TString at)
  | isarrt at = mapc2hs (TString $ snd (splitarrt at))
  | otherwise = unmapped at

-- Check whether the typestring represents an array type.

isarrt at = let firstdim = takeWhile (/= '@') at in
            (length firstdim > 0) && ("(#const" `isPrefixOf` firstdim)

-- Special version of the type map function considering conversion of arrays
-- into pointers.

mapc2hs_arr t@(TString at)
  | isarrt at = PtrV 1 (mapc2hs (TString $ snd (splitarrt at)))
  | otherwise = mapc2hs t

mapc2hs_arr z = mapc2hs z

unmapped z = TString' ("Unmapped_C_Type_" ++ z)

-- Split array type string into dimensions ([Int]) and the base type string
-- (String).

splitarrt arts = (dims,basetype)
  where notat = (/= '@')
        basetype = (drop 1 . reverse . takeWhile notat . reverse) arts
        dimtxt = (reverse . dropWhile notat . reverse) arts
        dimpts = parts (== '_') dimtxt
        dims = map bq2un dims'
        bq2un '`' = '_'
        bq2un z = z
        dims' = "[" ++ intlv (reverse $ map (readdim . filter notat) dimpts) ", " ++ "]"
        readdim "*" = "-1"
        readdim s = s
        

-- Monadify the type string. All functions must return
-- monadic (usually IO) types.

monadify m (TApply tss) = 
  TApply (reverse $ (Mnd m (monadify m (head rtss))):(map (monadify m) $ tail rtss))
    where rtss = reverse tss

monadify m (PtrF ps ts) = PtrF ps (monadify m ts)

monadify m (PtrV ps ts) = PtrV ps (monadify m ts)

monadify m z = z

-- Pointer application. First pointer uses the prefix string, the rest
-- just add Ptr to the type string. A pointer of zero depth acts as a pair
-- of parentheses. The prefix string is cleared is at least one pointer was applied.

ptrapply 0 st = st

ptrapply 1 (TCMState curts pfx) = TCMState (ptrapply' curts pfx) False where
  ptrapply' t@(PtrF ps ts)   False = PtrV 1 t
  ptrapply'   (PtrV ps ts)   False = PtrV (ps + 1) ts
  ptrapply' t@(TString ts)   False = PtrV 1 t
  ptrapply' t                True  = PtrF 1 t
  ptrapply' x y = error $ "ptrapply' " ++ show x ++ " " ++ show y

ptrapply ps st = ptrapply (ps - 1) $ clrpfx $ ptrapply 1 st where
  clrpfx (TCMState curts _) = TCMState curts False

-- Parameters application. List of declarations is converted into
-- type strings, and they are interleaved with an arrow. All this
-- is appended along with an arrow to the left of the type string.

parmsapply dcls (TCMState curts _) = 
  TCMState (tsconcat (map dcl2ts' dcls) curts) True where
    dcl2ts' dcl = state2ts $ dcl2ts dcl
    tsconcat [TString "void"] tr = TApply [tr]
    tsconcat tp tr = TApply (tp ++ [tr])

-- Applies a pointer to the current type string.

tcmtrans st (DeclaratorS ps _ DeclTypeVar) = ptrapply ps st

-- Inserts function parameters' type signatures (return type was in DeclarationS)
-- If pc is not zero, applies a pointer ps times to what is in the type string.

tcmtrans st (DeclaratorS ps _ (DeclTypeFixed dcls)) = parmsapply dcls $ ptrapply ps st

-- Variadic functions are not supported. Yet error cannot be declared here
-- as they shouldn't harm others.

tcmtrans st (DeclaratorS _ _ DeclTypeVariadic) = 
  TCMState (TApply [TString "@@variadic@@"]) True

tcmtrans st (DeclaratorS _ _ (DeclTypeUnknown t)) = 
  TCMState (TApply [TString $ "@@unknown" ++ t ++ "@@"]) True

-- Initializes a type string from a DeclarationS

dcl2state (DeclarationS ds _) = TCMState (TString (intlv ds "_")) False

-- Retrieves type string from a state.

state2ts (TCMState ts _) = ts

-- Determines whether the state represents a function.

state2isf (TCMState _ pfx) = pfx

-- Follows the chain of declarators.

dclfollow st d@(DeclaratorS _ mbds _) = 
  let st' = tcmtrans st d in
    case mbds of
      Nothing -> st'
      Just d' -> dclfollow st' d'

-- Converts a declaration into a type string.

dcl2ts d@(DeclarationS ds decl) = dclfollow (dcl2state d) decl

-- Check recursively a TypeString for a predicate. Return True if at least
-- one element of the TypeString satisfies.

checktsrec pred ta@(TApply tss) = (pred ta) || (foldl (||) False (map (checktsrec pred) tss)) 
checktsrec pred pv@(PtrV _ ts) = (pred pv) || (checktsrec pred ts)
checktsrec pred pf@(PtrF _ ts) = (pred pf) || (checktsrec pred ts)
checktsrec pred mn@(Mnd _ ts) = (pred mn) || (checktsrec pred ts)
checktsrec pred z = pred z

-- True if a type is of a variadic function.

isvariadic ts = checktsrec isvr ts where
  isvr (TString  "WrongVariadicFunction") = True
  isvr (TString' "WrongVariadicFunction") = True
  isvr _ = False

-- True if a type is of a function taking/returning direct structures

isdirstruct ts = checktsrec isd ts where
  isd (TString  ('@':_)) = True
  isd (TString' ('@':_)) = True
  isd (TString' "CJmpBuf") = True
  isd _ = False

-- Output a FFI declaration of a function or a variable.
-- There may be following kinds of things declared:
--  - variables (&-import)
--  - regular functions (static import)
--  - pointers to functions: dynamic import for declaration, wrapper import for arguments
--  - pointers to variables
--  - pointers to pointers to functions
-- These things may be declared in two ways:
--  - type/typealias id (variables, functions, pointers)
--  - rettype/retalias id args (functions, function pointers)
-- In the first case, typealias resolution is necessary to determine whether
-- a function or a variable is declared. In the second case, presence of parameters
-- in the declaration shows whether this is a function (maybe nullary) or a variable.

onefunc tymap ifn dss ats id = 
  do let cta = connectta tymap $ simplifydecl dss id
         tcm = dcl2ts cta
         isf = state2isf tcm
         isv = isvariadic tsp
         drs = isdirstruct tsp
         dyn = case (state2ts tcm) of
               PtrF _ _ -> True
               other -> False
         tsp = mapc2hs $ state2ts tcm
         tsi = monadify "IO" tsp
         tsf = ts2ts tsi
         tsg = ts2ts tsp
         sym = id2name id
         intern = case (Map.lookup ("ID " ++ sym) tymap) of
                  Just (DictId n) -> "___" ++ (show n) ++ "___"
                  other -> ""
         arity (TApply ts) = (length ts) - 1
         arity (PtrF _ t) = arity t
         arity _ = 0
     case (isv || drs,isf,dyn) of
       (False,True, False) -> do statimport ifn sym tsf
                                 cbckimport sym tsi
       (_,    True, True)  -> skipimport ifn sym
       (False,False,True)  -> do dynimport  ifn sym tsf (arity tsp) intern
                                 cbckimport sym tsi
       (False,False,False) -> varimport  ifn sym tsg True intern
       (True, _,    _)     -> excludeimport (sym ++ " :: " ++ tsg) isv drs

     putStrLn ""
     putStrLn "--"
     putStrLn ""
     return ()

-- Exclude an import and explain the reason.

excludeimport sym isv drs = do
  putStrLn   "--"
  putStrLn $ "-- import of function/variable/structure member(s) " ++ sym ++ " is not possible"
  putStrLn $ "-- because of the following reason(s):"
  when isv $ putStrLn "-- function is variadic"
  when drs $ putStrLn "-- function takes/returns structure(s) directly"
  putStrLn   "--"
                  

-- Write an import statement for a function. The `alloca' function if not really a function,
-- so import is not written for it.

statimport _ "alloca" _ = return ()

statimport ifn sym tsg = do
  putStrLn $ "foreign import ccall \"static " ++ ifn ++ " " ++ sym ++ "\""
  putStrLn $ "  f_" ++ sym ++ " :: " ++ tsg

-- For a dynamic import, 3 declarations are made: the first for the variable
-- holding a function pointer, the second for the stub factory, and the third
-- is application of the factory to the pointer variable (this one has name
-- of the imported entity.

-- For convenience, the function pointer to call will be imported
-- under the pointer variable's name, such as (for a function pointer
-- double (*pdf)(double,double)):

-- foreign import ccall "example.h &pdf" 
--   pdf' :: Ptr (FunPtr (CDouble -> CDouble -> IO CDouble))
-- foreign import ccall "dynamic"
--   mk_pdf' :: FunPtr (CDouble -> CDouble -> IO CDouble) -> (CDouble -> CDouble -> IO CDouble)
-- pdf _1 _2 = peek pdf' >>= \s -> mk_pdf' s _1 _2

unfptr ('F':'u':'n':'P':'t':'r':' ':s) = s
unfptr z = z

dynimport ifn sym tsg arity intern = do
  let csym = "x_" ++ sym
      vsym = "v_" ++ sym
      ssym = "s_" ++ sym
      msym = intern ++ "mk___"
      wsym = intern ++ "wr___"
      gsym = "peek " ++ intern
      arglist = intlv (take arity $ map (('_' :) . show) [1..]) " "
  varimport ifn sym tsg False intern
  putStrLn $ "foreign import ccall \"dynamic\""
  putStrLn $ "  " ++ msym ++ " :: " ++ tsg ++ " -> " ++ (unfptr tsg)
  putStrLn $ "foreign import ccall \"wrapper\""
  putStrLn $ "  " ++ wsym ++ " :: " ++ (unfptr tsg) ++ " -> " ++ "IO (" ++ tsg ++ ")"
  putStrLn $ csym ++ " " ++ arglist ++ " = " ++ gsym ++ " >>= \\s -> " ++ msym ++ " s " ++ arglist
  putStrLn $ vsym ++ " = " ++ gsym ++ " >>= (return . " ++ msym ++ ")"
  putStrLn $ ssym ++ " = \\s -> " ++ wsym ++ " s >>= poke " ++ intern
  return ()

-- Write a comment about ambiguously defined import entity.

skipimport ifn sym = do
  putStrLn $ "-- Import generation ERROR"
  putStrLn $ "-- Import of " ++ sym ++ " defined in " ++ ifn ++ " is skipped:"
  putStrLn $ "-- it is ambiguously declared as a dynamically imported function"
  putStrLn $ "-- rather than a variable pointing to a function."

-- Write an import statement for a variable. For convenience,
-- for each variable, a function will be defined to access variable's
-- value, such as (for an integer variable `a'):

-- Thus the pointer to the variable is imported under the name composed of
-- variable name and a prime.

varimport ifn sym tsg getset intern = do
  putStrLn $ "foreign import ccall \"" ++ ifn ++ " &" ++ sym ++ "\" "
  putStrLn $ "  " ++ intern ++ " :: Ptr (" ++ tsg ++ ")"
  putStrLn $ "p_" ++ sym ++ " = " ++ intern
  case getset of
    True -> do putStrLn $ "v_" ++ sym ++ " = peek " ++ intern
               putStrLn $ "s_" ++ sym ++ " = poke " ++ intern
    False -> return ()
  return ()

-- Recursively scan the type for funciton pointers passed as arguments
-- and write import statements to define wrappers.


findcbcks (TApply tss) = concat $ map findcbcks (reverse $ tail $ reverse tss)

findcbcks (PtrF 1 ts) = [ts2ts ts] ++ (findcbcks ts)

findcbcks z = []

cbckimport sym tsp = do
  let cbl = zip [1..] (nub $ findcbcks $ ftsg tsp)
      ftsg t@(TApply _) = t
      ftsg (PtrF _ t@(TApply _)) = t
      ftsg _ = TApply []
  mapM (wrapimport sym) cbl
  return ()

-- Write one wrapper import statement. Each wrapper gets a name
-- derived from sym and its position in the list.

wrapimport sym cb = when ((length $ snd cb) > 0) $ do
  putStrLn $ "foreign import ccall \"wrapper\""
  putStrLn $ "  " ++ "w_" ++ sym ++ "_" ++ (show $ fst cb) ++ " :: " 
                  ++ "(" ++ (snd cb) ++ ") -> IO (FunPtr (" ++ (snd cb) ++ "))"
  return ()