llvm-ffi-tools-0.0.2: src/FunctionMangulation.hs

-- ToDo: filter out "const" using regexes
module FunctionMangulation (
   pattern,
   rewrite,
   rewriteFunction,
   ) where

import Text.Regex.Posix ((=~), (=~~))

import Control.Monad (forM)

import qualified Data.List.HT as ListHT
import Data.String.HT (trim)
import Data.Char (toLower)
import Data.List.HT (maybePrefixOf)
import Data.List (intercalate)


pattern :: String
pattern = "^(LLVM_C_ABI +|)([A-Za-z0-9_ ]+ ?\\*?)[ \t\n]*" ++
          "LLVM([A-Za-z0-9_]+)\\(([][a-zA-Z0-9_*, \t\n]+)\\);"

renameType :: String -> String
renameType t =
   case maybePrefixOf "LLVM" t of
      -- ToDo: we need two variants of rename
      Just suffix -> rename suffix
      Nothing -> rename t

rename :: String -> String
rename cname =
   case cname of
      "Bool" -> "LLVM.Bool"
      "int" -> "CInt"
      "unsigned" -> "CUInt"
      "const unsigned" -> "CUInt"
      "long long" -> "CLLong"
      "unsigned long long" -> "CULLong"
      "void" -> "()"
      "const char *" -> "CString"
      "float" -> "CFloat"
      "double" -> "CDouble"
      "char *" -> "CString"
      "size_t" -> "CSize"
      "uint8_t" -> "Word8"
      "uint16_t" -> "Word16"
      "uint32_t" -> "Word32"
      "uint64_t" -> "Word64"
      "const uint64_t []" -> "Ptr Word64"
      _ ->
         case ListHT.viewR cname of
            Just (ps,'*') -> "(Ptr " ++ rename (trim ps) ++ ")"
            _ -> trim cname

dropName :: String -> String
dropName s =
   case s =~ "^((const )?(unsigned long long|[A-Za-z0-9_]+)( \\*+)?) ?[A-Za-z0-9_]*(\\[\\])?$" of
      ((_:typ:_:_:_:"[]":_):_) -> typ ++ " []"
      ((_:typ:_):_) -> typ
      _ -> "{- oops! -} " ++ s

rewriteFunction :: String -> String -> String -> String
rewriteFunction cret cname cparams =
    let ret = "IO " ++ renameType (trim cret)
        renameParam = renameType . dropName . trim
        params = map renameParam . ListHT.chop (==',') $ cparams
        params' = if params == ["()"] then [] else params
        name = let (n:ame) = cname in toLower n : ame
    in "foreign import ccall unsafe \"LLVM" ++ cname ++ "\" " ++ name ++
           "\n    :: " ++ intercalate " -> " (params' ++ [ret])

rewrite :: String -> [[String]]
rewrite s = do
    matches <- s =~~ pattern
    forM matches $ \(_:_cabi:cret:cname:cparams:_) ->
         return (rewriteFunction cret cname cparams)