summaryrefslogtreecommitdiff
path: root/packages/special/lib/Numeric/GSL/Special/auto.hs
diff options
context:
space:
mode:
Diffstat (limited to 'packages/special/lib/Numeric/GSL/Special/auto.hs')
-rw-r--r--packages/special/lib/Numeric/GSL/Special/auto.hs244
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 @@
1#!/usr/bin/env runhaskell
2
3-- automatic generation of wrappers for simple GSL special functions
4
5import Text.ParserCombinators.Parsec
6import System
7import Data.List(intersperse, isPrefixOf)
8import Data.Char(toUpper,isUpper,toLower)
9
10data Type = Normal Ident | Pointer Ident deriving (Eq, Show)
11
12type Ident = String
13
14data Header = Header Type Ident [(Type,Ident)] deriving Show
15
16headers f = case parse parseHeaders "" f of
17 Right l -> l
18 Left s -> error (show s)
19
20
21rep (c,r) [] = []
22rep (c,r) f@(x:xs)
23 | c `isPrefixOf` f = r ++ rep (c,r) (drop (length c) f)
24 | otherwise = x:(rep (c,r) xs)
25
26
27fixlong [] = []
28fixlong "\\" = []
29fixlong ('\\':'\n':xs) = xs
30fixlong (x:xs) = x : fixlong xs
31
32
33safe (Header _ _ args) = all ok args
34 || all ok (init args) && kn (last args)
35 where ok ((Normal s),_) | s `elem` ["double","float","int","gsl_mode_t"] = True
36 ok _ = False
37 kn ((Pointer "gsl_sf_result"),_) = True
38 kn ((Pointer "gsl_sf_result_e10"),_) = True
39 kn _ = False
40
41
42
43fixC s = rep ("gsl_mode_t","int") $ rep ("gsl_sf_result","double") $ rep ("gsl_sf_result_e10","double") $ s
44
45main = do
46 args <- getArgs
47 let name = args!!0
48 headerfile =
49 case args of
50 [n] -> "/usr/include/gsl/gsl_sf_"++n++".h"
51 [_,f] -> f
52 file <- readFile headerfile
53
54 putStrLn headerfile
55 --mapM_ print (headers $ fixlong file)
56 let parsed = (headers $ fixlong file)
57 -- writeFile (name ++".h") (fixC $ unlines $ map showC parsed)
58
59 --putStrLn ""
60 --mapM (\(Header _ n _) -> putStrLn (drop 7 n ++",")) parsed
61 --putStrLn ""
62 --mapM_ (putStrLn.showFull (name ++".h")) parsed
63 let exports = rep (")",") where") $ rep ("(\n","(\n ") $ rep (",\n",", ") $ unlines $ ["("]++intersperse "," (map (\(Header _ n _) -> hName n) (filter safe parsed))++[")"]
64 let defs = unlines $ map (showFull (name ++".h")) parsed
65 let imports = "\nimport Foreign(Ptr)\n"
66 ++"import Foreign.C.Types(CInt)\n"
67 ++"import Numeric.GSL.Special.Internal\n"
68 let mod = modhead name ++ "module Numeric.GSL.Special."++ upperFirst name++exports++imports++defs
69 writeFile (upperFirst name ++ ".hs") mod
70-- appendFile "funs.txt" $ rep ("(\n ","-- * "
71-- ++map toUpper name
72-- -- ++"\n"++google ( "gsl_sf_"++name++".h")++"\n"
73-- ++"\n,") $ rep (") where","") $ exports
74
75
76google name = "<http://www.google.com/search?q="
77 ++name
78 ++"&as_sitesearch=www.gnu.org/software/gsl/manual&btnI=Lucky>"
79
80modhead name = replicate 60 '-' ++ "\n-- |\n"
81 ++"-- Module : Numeric.GSL.Special."++upperFirst name++"\n"
82 ++"-- Copyright : (c) Alberto Ruiz 2006\n"
83 ++"-- License : GPL\n"
84 ++"-- Maintainer : Alberto Ruiz (aruiz at um dot es)\n"
85 ++"-- Stability : provisional\n"
86 ++"-- Portability : uses ffi\n"
87 ++"--\n"
88 ++"-- Wrappers for selected functions described at:\n--\n-- "
89 ++ google ( "gsl_sf_"++name++".h")++"\n"
90 ++ replicate 60 '-' ++ "\n\n"
91
92upperFirst (x:xs) = toUpper x : xs
93
94comment = do
95 string "/*"
96 closecomment
97 spaces
98 return "comment"
99
100closecomment = try (string "*/")
101 <|> (do anyChar
102 closecomment)
103
104ident = do
105 spaces
106 id <- many1 (noneOf "()[]* \n\t,;")
107 spaces
108 return id
109
110comment' = between (char '(') (char ')') (many $ noneOf ")")
111
112
113define = do
114 string "#"
115 closedefine
116 spaces
117 return "define"
118
119closedefine = try (string "\n")
120 <|> (do anyChar
121 closedefine)
122
123marks = do
124 try (string "__BEGIN_DECLS" >> spaces >> return "begin")
125 <|>
126 try (string "__END_DECLS" >> spaces >> return "end")
127
128
129
130irrelevant =
131 try comment
132 <|>
133 try define
134 <|>
135 marks
136
137
138parseHeaders = many parseHeader
139
140parseHeader = do
141 spaces
142 many irrelevant
143 spaces
144 (res,name) <- typ
145 spaces
146 args <- between (char '(') (char ')') (sepBy typ (char ','))
147 spaces
148 char ';'
149 spaces
150 many irrelevant
151 return $ Header res name args
152
153typ = try t1 <|> t2
154
155symbol s = spaces >> string s >> spaces
156
157t1 = do
158 t <- try (symbol "const" >> symbol "unsigned" >> ident) -- aaagh
159 <|>
160 try (symbol "const" >> ident)
161 <|>
162 try (symbol "unsigned" >> ident)
163 <|> ident
164 n <- ident
165 return (Normal t,n)
166
167t2 = do
168 t <- ident
169 spaces
170 char '*'
171 spaces
172 n <- ident
173 return (Pointer t,n)
174
175pure (Header _ _ args) | fst (last args) == Pointer "gsl_sf_result" = False
176 | fst (last args) == Pointer "gsl_sf_result_e10" = False
177 | otherwise = True
178
179showC (Header t n args) = showCt t ++ " " ++ n ++ "(" ++ (concat $ intersperse "," $ map showCa args) ++ ");"
180
181showCt (Normal s) = s
182showCt (Pointer s) = s ++ "*"
183
184showCa (t, a) = showCt t ++" "++ a
185
186showH hc h@(Header t n args) = "foreign import ccall SAFE_CHEAP \""++n++"\" "++n++" :: "++ (concat$intersperse" -> "$map showHa args) ++" -> " ++ t'
187 where t' | pure h = showHt t
188 | otherwise = "IO "++showHt t
189
190ht "int" = "CInt"
191ht (s:ss) = toUpper s : ss
192
193showHt (Normal t) = ht t
194showHt (Pointer "gsl_sf_result") = "Ptr ()"
195showHt (Pointer "gsl_sf_result_e10") = "Ptr ()"
196showHt (Pointer t) = "Ptr "++ht t
197
198showHa (t,a) = showHt t
199
200showFull hc h@(Header t n args) = -- "\n-- | wrapper for "++showC h
201 -- ++"\n--\n-- "++google n ++"\n"++
202 -- ++ "\n" ++
203 "\n" ++ boiler h ++
204 "\n" ++ showH hc h
205
206fixmd1 = rep ("Gsl_mode_t","Precision")
207fixmd2 = rep ("mode"," (precCode mode)")
208
209boiler h@(Header t n args) | fst (last args) == Pointer "gsl_sf_result" = boilerResult h
210 | fst (last args) == Pointer "gsl_sf_result_e10" = boilerResultE10 h
211 | any isMode args = boilerMode h
212 | otherwise = boilerBasic h
213
214isMode (Normal "gsl_mode_t",_) = True
215isMode _ = False
216
217hName n = f $ drop 7 n
218 where f (s:ss) = toLower s : ss
219
220
221boilerResult h@(Header t n args) =
222 hName n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$ map showHa (init args)) ++" -> " ++ "(Double,Double)\n" ++
223 hName n ++ " "++ initArgs args ++
224 " = createSFR \""++ hName n ++"\" $ " ++ n ++ " "++ (fixmd2 $ initArgs args)
225
226boilerResultE10 h@(Header t n args) =
227 hName n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$ map showHa (init args)) ++" -> " ++ "(Double,Int,Double)\n" ++
228 hName n ++ " "++ initArgs args ++
229 " = createSFR_E10 \""++ hName n ++"\" $ " ++ n ++ " "++ (fixmd2 $ initArgs args)
230
231boilerBasic h@(Header t n args) =
232 hName n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$map showHa args) ++" -> " ++showHt t ++ "\n" ++
233 hName n ++ " = " ++fixmd2 n
234
235boilerMode h@(Header t n args) =
236 hName n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$ map showHa args) ++" -> " ++ showHt t++"\n" ++
237 hName n ++ " "++ allArgs args ++
238 " = " ++ n ++ " "++ (fixmd2 $ allArgs args)
239
240cVar (v:vs) | isUpper v = toLower v : v : vs
241 | otherwise = v:vs
242
243allArgs args = unwords (map (cVar.snd) args)
244initArgs args = unwords (map (cVar.snd) (init args)) \ No newline at end of file