fftw-ffi-0.0: tool/GenerateForeignImport.hs

import System.Environment (getArgs)
import Text.Printf (printf)

import qualified Data.List as List
import Data.Foldable (forM_)
import Data.Char (toLower)


data Safety = Unsafe | Safe deriving (Show)

formatSafety :: Safety -> String
formatSafety s =
   case s of
      Unsafe -> "unsafe"
      Safe -> "safe"

lowerInit :: String -> String
lowerInit (c:cs) = toLower c : cs
lowerInit "" = ""

list :: [(String, Safety, String, [String])]
list =
   ("plan_dft_1d", Safe,
    "PlanDFT1d",
      "C.CInt ->" :
      "Ptr (Complex a) -> Ptr (Complex a) ->" :
      "Sign -> Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_2d", Safe,
    "PlanDFT2d",
      "C.CInt -> C.CInt ->" :
      "Ptr (Complex a) -> Ptr (Complex a) ->" :
      "Sign -> Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_3d", Safe,
    "PlanDFT3d",
      "C.CInt -> C.CInt -> C.CInt ->" :
      "Ptr (Complex a) -> Ptr (Complex a) ->" :
      "Sign -> Flags -> IO (Plan a)" :
      []) :

   ("plan_dft", Safe,
    "PlanDFT",
      "C.CInt -> Ptr C.CInt ->" :
      "Ptr (Complex a) -> Ptr (Complex a) ->" :
      "Sign -> Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_r2c_1d", Safe,
    "PlanDFTr2c1d",
      "C.CInt ->" :
      "Ptr a -> Ptr (Complex a) ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_r2c_2d", Safe,
    "PlanDFTr2c2d",
      "C.CInt -> C.CInt ->" :
      "Ptr a -> Ptr (Complex a) ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_r2c_3d", Safe,
    "PlanDFTr2c3d",
      "C.CInt -> C.CInt -> C.CInt ->" :
      "Ptr a -> Ptr (Complex a) ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_r2c", Safe,
    "PlanDFTr2c",
      "C.CInt -> Ptr C.CInt ->" :
      "Ptr a -> Ptr (Complex a) ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_c2r_1d", Safe,
    "PlanDFTc2r1d",
      "C.CInt ->" :
      "Ptr (Complex a) -> Ptr a ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_c2r_2d", Safe,
    "PlanDFTc2r2d",
      "C.CInt -> C.CInt ->" :
      "Ptr (Complex a) -> Ptr a ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_c2r_3d", Safe,
    "PlanDFTc2r3d",
      "C.CInt -> C.CInt -> C.CInt ->" :
      "Ptr (Complex a) -> Ptr a ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_dft_c2r", Safe,
    "PlanDFTc2r",
      "C.CInt -> Ptr C.CInt ->" :
      "Ptr (Complex a) -> Ptr a ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_r2r_1d", Safe,
    "PlanR2r1d",
      "C.CInt ->" :
      "Ptr a -> Ptr a ->" :
      "Kind -> Flags -> IO (Plan a)" :
      []) :

   ("plan_r2r_2d", Safe,
    "PlanR2r2d",
      "C.CInt -> C.CInt ->" :
      "Ptr a -> Ptr a ->" :
      "Kind -> Kind -> Flags -> IO (Plan a)" :
      []) :

   ("plan_r2r_3d", Safe,
    "PlanR2r3d",
      "C.CInt -> C.CInt -> C.CInt ->" :
      "Ptr a -> Ptr a ->" :
      "Kind -> Kind -> Kind -> Flags -> IO (Plan a)" :
      []) :

   ("plan_r2r", Safe,
    "PlanR2r",
      "C.CInt -> Ptr C.CInt ->" :
      "Ptr a -> Ptr a ->" :
      "Ptr Kind -> Flags -> IO (Plan a)" :
      []) :


   ("plan_many_dft", Safe,
    "PlanManyDFT",
      "C.CInt -> Ptr C.CInt -> C.CInt ->" :
      "Ptr (Complex a) -> Ptr C.CInt ->" :
      "C.CInt -> C.CInt ->" :
      "Ptr (Complex a) -> Ptr C.CInt ->" :
      "C.CInt -> C.CInt ->" :
      "Sign -> Flags -> IO (Plan a)" :
      []) :

   ("plan_many_dft_r2c", Safe,
    "PlanManyDFTr2c",
      "C.CInt -> Ptr C.CInt -> C.CInt ->" :
      "Ptr a -> Ptr C.CInt ->" :
      "C.CInt -> C.CInt ->" :
      "Ptr (Complex a) -> Ptr C.CInt ->" :
      "C.CInt -> C.CInt ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_many_dft_c2r", Safe,
    "PlanManyDFTc2r",
      "C.CInt -> Ptr C.CInt -> C.CInt ->" :
      "Ptr (Complex a) -> Ptr C.CInt ->" :
      "C.CInt -> C.CInt ->" :
      "Ptr a -> Ptr C.CInt ->" :
      "C.CInt -> C.CInt ->" :
      "Flags -> IO (Plan a)" :
      []) :

   ("plan_many_r2r", Safe,
    "PlanManyR2r",
      "C.CInt -> Ptr C.CInt -> C.CInt ->" :
      "Ptr a -> Ptr C.CInt ->" :
      "C.CInt -> C.CInt ->" :
      "Ptr a -> Ptr C.CInt ->" :
      "C.CInt -> C.CInt ->" :
      "Ptr Kind -> Flags -> IO (Plan a)" :
      []) :


   ("plan_guru_dft", Safe,
    "PlanGuruDFT",
      "C.CInt -> Ptr IODim -> C.CInt -> Ptr IODim ->" :
      "Ptr (Complex a) -> Ptr (Complex a) -> Sign -> Flags -> IO (Plan a)" :
      []) :
   ("plan_guru_dft_r2c", Safe,
    "PlanGuruDFTr2c",
      "C.CInt -> Ptr IODim -> C.CInt -> Ptr IODim ->" :
      "Ptr a -> Ptr (Complex a) -> Flags -> IO (Plan a)" :
      []) :
   ("plan_guru_dft_c2r", Safe,
    "PlanGuruDFTc2r",
      "C.CInt -> Ptr IODim -> C.CInt -> Ptr IODim ->" :
      "Ptr (Complex a) -> Ptr a -> Flags -> IO (Plan a)" :
      []) :
   ("plan_guru_r2r", Safe,
    "PlanGuruR2r",
      "C.CInt -> Ptr IODim -> C.CInt -> Ptr IODim ->" :
      "Ptr a -> Ptr a -> Ptr Kind -> Flags -> IO (Plan a)" :
      []) :

   ("plan_guru_split_dft", Safe,
    "PlanGuruSplitDFT",
      "C.CInt -> Ptr IODim -> C.CInt -> Ptr IODim ->" :
      "Ptr a -> Ptr a -> Ptr a -> Ptr a -> Flags -> IO (Plan a)" :
      []) :
   ("plan_guru_split_dft_r2c", Safe,
    "PlanGuruSplitDFTr2c",
      "C.CInt -> Ptr IODim -> C.CInt -> Ptr IODim ->" :
      "Ptr a -> Ptr a -> Ptr a -> Flags -> IO (Plan a)" :
      []) :
   ("plan_guru_split_dft_c2r", Safe,
    "PlanGuruSplitDFTc2r",
      "C.CInt -> Ptr IODim -> C.CInt -> Ptr IODim ->" :
      "Ptr a -> Ptr a -> Ptr a -> Flags -> IO (Plan a)" :
      []) :

   ("destroy_plan", Safe,
    "DestroyPlan",
      "Plan a -> IO ()" :
      []) :

   ("execute", Safe,
    "Execute",
      "Plan a -> IO ()" :
      []) :
   ("execute_dft", Safe,
    "ExecuteDFT",
      "Plan a -> Ptr (Complex a) -> Ptr (Complex a) -> IO ()" :
      []) :
   ("execute_dft_r2c", Safe,
    "ExecuteDFTr2c",
      "Plan a -> Ptr a -> Ptr (Complex a) -> IO ()" :
      []) :
   ("execute_dft_c2r", Safe,
    "ExecuteDFTc2r",
      "Plan a -> Ptr (Complex a) -> Ptr a -> IO ()" :
      []) :
   ("execute_r2r", Safe,
    "ExecuteR2r",
      "Plan a -> Ptr a -> Ptr a -> IO ()" :
      []) :
   ("execute_split_dft", Safe,
    "ExecuteSplitDFT",
      "Plan a -> Ptr a -> Ptr a -> Ptr a -> Ptr a -> IO ()" :
      []) :
   ("execute_split_dft_r2c", Safe,
    "ExecuteSplitDFTr2c",
      "Plan a -> Ptr a -> Ptr a -> Ptr a -> IO ()" :
      []) :
   ("execute_split_dft_c2r", Safe,
    "ExecuteSplitDFTc2r",
      "Plan a -> Ptr a -> Ptr a -> Ptr a -> IO ()" :
      []) :

   ("malloc", Unsafe,
    "Malloc",
      "C.CSize -> IO (Ptr a)" :
      []) :
   ("free", Unsafe,
    "Free",
      "Ptr a -> IO ()" :
      []) :

   ("alloc_real", Unsafe,
    "AllocReal",
      "C.CSize -> IO (Ptr a)" :
      []) :
   ("alloc_complex", Unsafe,
    "AllocComplex",
      "C.CSize -> IO (Ptr (Complex a))" :
      []) :
   ("free", Unsafe,
    "FreeComplex",
      "Ptr (Complex a) -> IO ()" :
      []) :

   []


-- cf. lapack-ffi-tools
insertExportList :: [String] -> String -> String
insertExportList exports modul =
   (\(prefix,suffixes) ->
      map fst prefix ++
      case suffixes of
         [] -> []
         (_,suffix):_ ->
            "(\n" ++ unlines (map (printf "   %s,") exports) ++
            "   ) " ++ suffix) $
   break (List.isPrefixOf "where" . snd) $
   zip modul (List.tails modul)


main :: IO ()
main = do
   args <- getArgs
   case args of
      [] ->
         forM_ list $ \(_,_,funcName,typeExpr) -> do
            printf "\ntype %s a =\n" funcName
            mapM_ (printf "   %s\n") typeExpr

      ["--generic", tmplPath] -> do
         tmpl <- readFile tmplPath
         let export (_,_,funcType,_) =
               printf "FFT.%s, %s" funcType (lowerInit funcType)
         putStr $ insertExportList (map export list) tmpl
         forM_ list $ \(_,_,funcType,_) -> do
            let funcName = lowerInit funcType
            printf "\n"
            printf "newtype %s a =\n" funcType
            printf "   %s {run%s :: FFT.%s a}\n" funcType funcType funcType
            printf "\n"
            printf "%s :: (Class.Real a) => FFT.%s a\n" funcName funcType
            printf "%s =\n" funcName
            printf "   run%s $\n" funcType
            printf "   Class.switchReal\n"
            printf "      (%s FFTF.%s)\n" funcType funcName
            printf "      (%s FFTD.%s)\n" funcType funcName

      [floatName, cPrefix] ->
         forM_ list $ \(cName,safety,funcName,_) -> do
            printf "\nforeign import ccall %s \"fftw3.h %s_%s\"\n"
               (formatSafety safety) cPrefix cName
            printf "   %s :: FFT.%s %s\n"
               (lowerInit funcName) funcName floatName

      _ -> fail "wrong number of arguments"