diff options
Diffstat (limited to 'lib/GSL/Special/auto.hs')
-rw-r--r-- | lib/GSL/Special/auto.hs | 201 |
1 files changed, 201 insertions, 0 deletions
diff --git a/lib/GSL/Special/auto.hs b/lib/GSL/Special/auto.hs new file mode 100644 index 0000000..f047bcb --- /dev/null +++ b/lib/GSL/Special/auto.hs | |||
@@ -0,0 +1,201 @@ | |||
1 | -- automatic generation of wrappers for simple GSL special functions | ||
2 | |||
3 | import Text.ParserCombinators.Parsec | ||
4 | import System | ||
5 | import Data.List(intersperse, isPrefixOf) | ||
6 | import Data.Char(toUpper) | ||
7 | |||
8 | data Type = Normal Ident | Pointer Ident deriving (Eq, Show) | ||
9 | |||
10 | type Ident = String | ||
11 | |||
12 | data Header = Header Type Ident [(Type,Ident)] deriving Show | ||
13 | |||
14 | headers f = case parse parseHeaders "" f of | ||
15 | Right l -> l | ||
16 | Left s -> error (show s) | ||
17 | |||
18 | |||
19 | rep (c,r) [] = [] | ||
20 | rep (c,r) f@(x:xs) | ||
21 | | c `isPrefixOf` f = r ++ rep (c,r) (drop (length c) f) | ||
22 | | otherwise = x:(rep (c,r) xs) | ||
23 | |||
24 | |||
25 | fixlong [] = [] | ||
26 | fixlong "\\" = [] | ||
27 | fixlong ('\\':'\n':xs) = xs | ||
28 | fixlong (x:xs) = x : fixlong xs | ||
29 | |||
30 | |||
31 | safe (Header _ _ args) = all ok args | ||
32 | || all ok (init args) && kn (last args) | ||
33 | where ok ((Normal s),_) | s `elem` ["double","float","int","gsl_mode_t"] = True | ||
34 | ok _ = False | ||
35 | kn ((Pointer "gsl_sf_result"),_) = True | ||
36 | kn _ = False | ||
37 | |||
38 | |||
39 | |||
40 | fixC s = rep ("gsl_mode_t","int") $ rep ("gsl_sf_result","double") $ s | ||
41 | |||
42 | main = do | ||
43 | args <- getArgs | ||
44 | file <- readFile (args!!1) | ||
45 | let name = args!!0 | ||
46 | putStrLn (args!!1) | ||
47 | --mapM_ print (headers $ fixlong file) | ||
48 | let parsed = (headers $ fixlong file) | ||
49 | writeFile (name ++".h") (fixC $ unlines $ map showC parsed) | ||
50 | |||
51 | --putStrLn "" | ||
52 | --mapM (\(Header _ n _) -> putStrLn (drop 7 n ++",")) parsed | ||
53 | --putStrLn "" | ||
54 | --mapM_ (putStrLn.showFull (name ++".h")) parsed | ||
55 | let exports = rep (")",") where") $ rep ("(\n","(\n ") $ rep (",\n",", ") $ unlines $ ["("]++intersperse "," (map (\(Header _ n _) -> drop 7 n) (filter safe parsed))++[")"] | ||
56 | let defs = unlines $ map (showFull (name ++".h")) parsed | ||
57 | let imports = "\nimport Foreign(Ptr)\nimport GSL.Special.Internal\n" | ||
58 | let mod = modhead name ++ "module GSL.Special."++ upperFirst name++exports++imports++defs | ||
59 | writeFile (upperFirst name ++ ".hs") mod | ||
60 | |||
61 | |||
62 | modhead name = replicate 60 '-' ++ "\n" | ||
63 | ++"{- |\n" | ||
64 | ++"Module : GSL.Special."++upperFirst name++"\n" | ||
65 | ++"Copyright : (c) Alberto Ruiz 2006\n" | ||
66 | ++"License : GPL-style\n" | ||
67 | ++"Maintainer : Alberto Ruiz (aruiz at um dot es)\n" | ||
68 | ++"Stability : provisional\n" | ||
69 | ++"Portability : uses ffi\n" | ||
70 | ++"\n\n\n-}\n" | ||
71 | ++ replicate 60 '-' ++ "\n\n" | ||
72 | |||
73 | upperFirst (x:xs) = toUpper x : xs | ||
74 | |||
75 | comment = do | ||
76 | string "/*" | ||
77 | closecomment | ||
78 | spaces | ||
79 | return "comment" | ||
80 | |||
81 | closecomment = try (string "*/") | ||
82 | <|> (do anyChar | ||
83 | closecomment) | ||
84 | |||
85 | ident = do | ||
86 | spaces | ||
87 | id <- many1 (noneOf "()[]* \n\t,;") | ||
88 | spaces | ||
89 | return id | ||
90 | |||
91 | comment' = between (char '(') (char ')') (many $ noneOf ")") | ||
92 | |||
93 | |||
94 | define = do | ||
95 | string "#" | ||
96 | closedefine | ||
97 | spaces | ||
98 | return "define" | ||
99 | |||
100 | closedefine = try (string "\n") | ||
101 | <|> (do anyChar | ||
102 | closedefine) | ||
103 | |||
104 | marks = do | ||
105 | try (string "__BEGIN_DECLS" >> spaces >> return "begin") | ||
106 | <|> | ||
107 | try (string "__END_DECLS" >> spaces >> return "end") | ||
108 | |||
109 | |||
110 | |||
111 | irrelevant = | ||
112 | try comment | ||
113 | <|> | ||
114 | try define | ||
115 | <|> | ||
116 | marks | ||
117 | |||
118 | |||
119 | parseHeaders = many parseHeader | ||
120 | |||
121 | parseHeader = do | ||
122 | spaces | ||
123 | many irrelevant | ||
124 | spaces | ||
125 | (res,name) <- typ | ||
126 | spaces | ||
127 | args <- between (char '(') (char ')') (sepBy typ (char ',')) | ||
128 | spaces | ||
129 | char ';' | ||
130 | spaces | ||
131 | many irrelevant | ||
132 | return $ Header res name args | ||
133 | |||
134 | typ = try t1 <|> t2 | ||
135 | |||
136 | symbol s = spaces >> string s >> spaces | ||
137 | |||
138 | t1 = do | ||
139 | t <- try (symbol "const" >> symbol "unsigned" >> ident) -- aaagh | ||
140 | <|> | ||
141 | try (symbol "const" >> ident) | ||
142 | <|> | ||
143 | try (symbol "unsigned" >> ident) | ||
144 | <|> ident | ||
145 | n <- ident | ||
146 | return (Normal t,n) | ||
147 | |||
148 | t2 = do | ||
149 | t <- ident | ||
150 | spaces | ||
151 | char '*' | ||
152 | spaces | ||
153 | n <- ident | ||
154 | return (Pointer t,n) | ||
155 | |||
156 | pure (Header _ _ args) | fst (last args) == Pointer "gsl_sf_result" = False | ||
157 | | otherwise = True | ||
158 | |||
159 | showC (Header t n args) = showCt t ++ " " ++ n ++ "(" ++ (concat $ intersperse "," $ map showCa args) ++ ");" | ||
160 | |||
161 | showCt (Normal s) = s | ||
162 | showCt (Pointer s) = s ++ "*" | ||
163 | |||
164 | showCa (t, a) = showCt t ++" "++ a | ||
165 | |||
166 | showH hc h@(Header t n args) = "foreign import ccall \""++hc++" "++n++"\" "++n++" :: "++ (concat$intersperse" -> "$map showHa args) ++" -> " ++ t' | ||
167 | where t' | pure h = showHt t | ||
168 | | otherwise = "IO("++showHt t++")" | ||
169 | |||
170 | showHt (Normal (s:ss)) = toUpper s : ss | ||
171 | showHt (Pointer "gsl_sf_result") = "Ptr Double" | ||
172 | showHt (Pointer (s:ss)) = "Ptr "++toUpper s : ss | ||
173 | |||
174 | showHa (t,a) = showHt t | ||
175 | |||
176 | showFull hc h@(Header t n args) = "\n-- | wrapper for "++showC h++"\n"++ boiler h ++"\n" ++showH hc h | ||
177 | |||
178 | fixmd1 = rep ("Gsl_mode_t","Precision") | ||
179 | fixmd2 = rep ("mode"," (precCode mode)") | ||
180 | |||
181 | boiler h@(Header t n args) | fst (last args) == Pointer "gsl_sf_result" = boilerResult h | ||
182 | | any isMode args = boilerMode h | ||
183 | | otherwise = boilerBasic h | ||
184 | |||
185 | isMode (Normal "gsl_mode_t",_) = True | ||
186 | isMode _ = False | ||
187 | |||
188 | |||
189 | boilerResult h@(Header t n args) = | ||
190 | drop 7 n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$ map showHa (init args)) ++" -> " ++ "(Double,Double)\n" ++ | ||
191 | drop 7 n ++ " "++(unwords (map snd (init args)))++ | ||
192 | " = createSFR \""++ drop 7 n ++"\" $ " ++ n ++ " "++(fixmd2 $ unwords (map snd (init args))) | ||
193 | |||
194 | boilerBasic h@(Header t n args) = | ||
195 | drop 7 n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$map showHa args) ++" -> " ++showHt t ++ "\n" ++ | ||
196 | drop 7 n ++ " = " ++fixmd2 n | ||
197 | |||
198 | boilerMode h@(Header t n args) = | ||
199 | drop 7 n++" :: "++ (fixmd1 $ concat $ intersperse" -> "$ map showHa args) ++" -> " ++ showHt t++"\n" ++ | ||
200 | drop 7 n ++ " "++(unwords (map snd args))++ | ||
201 | " = " ++ n ++ " "++(fixmd2 $ unwords (map snd args)) | ||