1 files changed, 244 insertions, 0 deletions

diff --git a/packages/special/lib/Numeric/GSL/Special/auto.hs b/packages/special/lib/Numeric/GSL/Special/auto.hs
new file mode 100644
index 0000000..b46e6c6
--- /dev/null
+++ b/packages/special/lib/Numeric/GSL/Special/auto.hs
@@ -0,0 +1,244 @@
+#!/usr/bin/env runhaskell
+
+-- automatic generation of wrappers for simple GSL special functions
+
+import Text.ParserCombinators.Parsec
+import System
+import Data.List(intersperse, isPrefixOf)
+import Data.Char(toUpper,isUpper,toLower)
+
+data Type = Normal Ident | Pointer Ident deriving (Eq, Show)
+
+type Ident = String
+
+data Header = Header Type Ident [(Type,Ident)] deriving Show
+
+headers f = case parse parseHeaders "" f of
+    Right l -> l
+    Left s -> error (show s)
+
+
+rep (c,r) [] = []
+rep (c,r) f@(x:xs) 
+  | c `isPrefixOf` f = r ++ rep (c,r) (drop (length c) f)
+  | otherwise        = x:(rep (c,r) xs)
+
+
+fixlong [] = []
+fixlong "\\" = []
+fixlong ('\\':'\n':xs) = xs
+fixlong (x:xs) = x : fixlong xs
+
+
+safe (Header _ _ args) =  all ok args 
+                         || all ok (init args) && kn (last args)
+    where ok ((Normal s),_) | s `elem` ["double","float","int","gsl_mode_t"] = True
+          ok _ = False
+          kn ((Pointer "gsl_sf_result"),_) = True
+          kn ((Pointer "gsl_sf_result_e10"),_) = True
+          kn _ = False
+
+
+
+fixC s = rep ("gsl_mode_t","int") $ rep ("gsl_sf_result","double") $ rep ("gsl_sf_result_e10","double") $ s
+
+main = do
+    args <- getArgs
+    let name = args!!0
+        headerfile =
+            case args of
+                [n] -> "/usr/include/gsl/gsl_sf_"++n++".h"
+                [_,f] -> f
+    file <- readFile headerfile
+
+    putStrLn headerfile
+    --mapM_ print (headers $ fixlong file)
+    let parsed = (headers $ fixlong file)
+    -- writeFile (name ++".h") (fixC $ unlines $ map showC parsed) 
+
+    --putStrLn ""
+    --mapM (\(Header _ n _) -> putStrLn (drop 7 n ++",")) parsed
+    --putStrLn ""
+    --mapM_ (putStrLn.showFull (name ++".h")) parsed
+    let exports = rep (")",") where") $ rep ("(\n","(\n  ") $ rep (",\n",", ") $ unlines $ ["("]++intersperse "," (map (\(Header _ n _) -> hName n) (filter safe parsed))++[")"]
+    let defs = unlines $ map (showFull (name ++".h")) parsed
+    let imports = "\nimport Foreign(Ptr)\n"
+                ++"import Foreign.C.Types(CInt)\n"
+                ++"import Numeric.GSL.Special.Internal\n"
+    let mod = modhead name ++ "module Numeric.GSL.Special."++ upperFirst name++exports++imports++defs
+    writeFile (upperFirst name ++ ".hs") mod
+--     appendFile "funs.txt" $ rep ("(\n ","-- * "
+--                                      ++map toUpper name
+--                                 --   ++"\n"++google ( "gsl_sf_"++name++".h")++"\n"
+--                                      ++"\n,") $ rep (") where","") $ exports
+
+
+google name = "<http://www.google.com/search?q="
+               ++name
+               ++"&as_sitesearch=www.gnu.org/software/gsl/manual&btnI=Lucky>"
+
+modhead name = replicate 60 '-' ++ "\n-- |\n"
+             ++"-- Module      :  Numeric.GSL.Special."++upperFirst name++"\n"
+             ++"-- Copyright   :  (c) Alberto Ruiz 2006\n"
+             ++"-- License     :  GPL\n"
+             ++"-- Maintainer  :  Alberto Ruiz (aruiz at um dot es)\n"
+             ++"-- Stability   :  provisional\n"
+             ++"-- Portability :  uses ffi\n"
+             ++"--\n"
+             ++"-- Wrappers for selected functions described at:\n--\n-- "
+             ++ google ( "gsl_sf_"++name++".h")++"\n"
+             ++ replicate 60 '-' ++ "\n\n"
+
+upperFirst (x:xs) = toUpper x : xs
+
+comment = do
+    string "/*"
+    closecomment
+    spaces
+    return "comment"
+
+closecomment = try (string "*/")
+               <|> (do anyChar
+                       closecomment)
+
+ident = do 
+    spaces
+    id <- many1 (noneOf "()[]* \n\t,;")
+    spaces
+    return id
+
+comment' = between (char '(') (char ')') (many $ noneOf ")") 
+
+
+define = do
+    string "#"
+    closedefine
+    spaces
+    return "define"
+
+closedefine = try (string "\n")
+              <|> (do anyChar
+                      closedefine)
+
+marks = do
+    try (string "__BEGIN_DECLS" >> spaces >> return "begin")
+    <|>
+    try (string "__END_DECLS" >> spaces >> return "end")
+
+
+
+irrelevant =
+    try comment
+    <|>
+    try define
+    <|>
+    marks
+
+
+parseHeaders = many parseHeader
+
+parseHeader = do
+    spaces
+    many irrelevant
+    spaces
+    (res,name)  <- typ
+    spaces
+    args <- between (char '(') (char ')') (sepBy typ (char ','))
+    spaces
+    char ';'
+    spaces
+    many irrelevant
+    return $ Header res name args
+
+typ = try t1 <|> t2
+
+symbol s = spaces >> string s >> spaces
+
+t1 = do
+    t <- try (symbol "const" >> symbol "unsigned" >> ident) -- aaagh 
+         <|>
+         try (symbol "const" >> ident)
+         <|>
+         try (symbol "unsigned" >> ident)
+         <|> ident
+    n <- ident
+    return (Normal t,n)
+
+t2 = do
+    t <- ident
+    spaces
+    char '*'
+    spaces
+    n <- ident
+    return (Pointer t,n)
+
+pure (Header _ _ args) | fst (last args) == Pointer "gsl_sf_result" = False
+                       | fst (last args) == Pointer "gsl_sf_result_e10" = False
+                       | otherwise = True
+
+showC (Header t n args) = showCt t ++ " " ++ n ++ "("  ++ (concat $ intersperse "," $ map showCa args) ++ ");"
+
+showCt (Normal s) = s
+showCt (Pointer s) = s ++ "*"
+
+showCa (t, a) = showCt t ++" "++ a
+
+showH hc h@(Header t n args) = "foreign import ccall SAFE_CHEAP \""++n++"\" "++n++" :: "++ (concat$intersperse" -> "$map showHa args) ++" -> " ++ t'
+    where t' | pure h = showHt t
+             | otherwise = "IO "++showHt t
+
+ht "int" = "CInt"
+ht (s:ss) = toUpper s : ss
+
+showHt (Normal t) = ht t
+showHt (Pointer "gsl_sf_result") = "Ptr ()"
+showHt (Pointer "gsl_sf_result_e10") = "Ptr ()"
+showHt (Pointer t) = "Ptr "++ht t
+
+showHa (t,a) = showHt t
+
+showFull hc h@(Header t n args) = -- "\n-- | wrapper for "++showC h
+                                  --   ++"\n--\n--   "++google n ++"\n"++
+                                  -- ++ "\n" ++
+                                  "\n" ++ boiler h ++ 
+                                  "\n" ++ showH hc h
+
+fixmd1 = rep ("Gsl_mode_t","Precision")
+fixmd2 = rep ("mode"," (precCode mode)")
+
+boiler h@(Header t n args) | fst (last args) == Pointer "gsl_sf_result" = boilerResult h
+                           | fst (last args) == Pointer "gsl_sf_result_e10" = boilerResultE10 h
+                           | any isMode args = boilerMode h
+                           | otherwise = boilerBasic h
+
+isMode (Normal "gsl_mode_t",_) = True
+isMode _ = False
+
+hName n = f $ drop 7 n
+    where f (s:ss) = toLower s : ss
+
+
+boilerResult h@(Header t n args) =
+    hName n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$ map showHa (init args)) ++" -> " ++ "(Double,Double)\n" ++
+     hName n ++ " "++ initArgs args ++
+       " = createSFR \""++ hName n ++"\" $ " ++ n ++ " "++ (fixmd2 $ initArgs args)
+
+boilerResultE10 h@(Header t n args) =
+    hName n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$ map showHa (init args)) ++" -> " ++ "(Double,Int,Double)\n" ++
+     hName n ++ " "++ initArgs args ++
+       " = createSFR_E10 \""++ hName n ++"\" $ " ++ n ++ " "++ (fixmd2 $ initArgs args)
+
+boilerBasic h@(Header t n args) = 
+    hName n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$map showHa args) ++" -> " ++showHt t ++ "\n" ++
+      hName n ++ " = " ++fixmd2 n
+
+boilerMode h@(Header t n args) =
+    hName n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$ map showHa args) ++" -> " ++ showHt t++"\n" ++
+     hName n ++ " "++ allArgs args ++
+       " = " ++ n ++ " "++ (fixmd2 $ allArgs args)
+
+cVar (v:vs) | isUpper v = toLower v : v : vs
+            | otherwise = v:vs
+
+allArgs args =  unwords (map (cVar.snd) args)
+initArgs args = unwords (map (cVar.snd) (init args))
\ No newline at end of file