1-- TypeGen.hs
2-- Takes a hierarchical list of all objects in GTK+ and produces
3-- Haskell class that reflect this hierarchy.
4module TypeGen (typeGen) where
5
6import Data.Char     (isAlpha, isAlphaNum, toLower, toUpper, isUpper)
7import Data.List     (isPrefixOf)
8import Control.Monad (when)
9import System.Exit   (exitWith, ExitCode(..))
10import System.IO (stderr, hPutStr)
11import Paths_gtk2hs_buildtools (getDataFileName)
12
13-- The current object and its inheritence relationship is defined by all
14-- ancestors and their column position.
15type ObjectSpec = [(Int,String)]
16
17-- This is a mapping from a type name to a) the type name in Haskell and
18-- b) the info on this type 'TypeInfo'.
19type TypeQuery  = (String, TypeInfo)
20
21-- The information of on the type.
22data TypeInfo = TypeInfo {
23  tiQueryFunction :: String, -- the GTK blah_get_type function
24  tiAlternateName :: Maybe String,
25  tiNoEqualInst   :: Bool,
26  tiDefaultDestr  :: Bool
27  }
28
29type TypeTable  = [TypeQuery]
30
31-- A Tag is a string restricting the generation of type entries to
32-- those lines that have the appropriate "if <tag>" at the end.
33type Tag = String
34
35data ParserState = ParserState {
36  line          :: Int,
37  col           :: Int,
38  hierObjs      :: ObjectSpec,
39  onlyTags      :: [Tag]
40  }
41
42freshParserState :: [Tag] -> ParserState
43freshParserState = ParserState 1 1 []
44
45-- The parser returns a list of ObjectSpec and possibly a special type query
46-- function. Each ObjectSpec describes one object with all its parents.
47
48pFreshLine :: ParserState -> String -> [(ObjectSpec, TypeQuery)]
49pFreshLine ps input = pFL ps input
50  where
51    pFL ps ('#':rem)            = pFL ps (dropWhile ((/=) '\n') rem)
52    pFL ps ('\n':rem)           = pFL (ps {line = line ps+1, col=1}) rem
53    pFL ps (' ':rem)            = pFL (ps {col=col ps+1}) rem
54    pFL ps ('\t':rem)           = pFL (ps {col=col ps+8}) rem
55    pFL ps all@('G':'t':'k':rem)= pGetObject ps all rem
56    pFL ps all@('G':'d':'k':rem)= pGetObject ps all rem
57    pFL ps all@('G':'s':'t':rem)= pGetObject ps all rem
58    pFL ps all@('G':'n':'o':'m':'e':rem)= pGetObject ps all rem
59    pFL ps []                   = []
60    pFL ps all                  = pGetObject ps all all
61
62pGetObject :: ParserState -> String -> String -> [(ObjectSpec, TypeQuery)]
63pGetObject ps@ParserState { onlyTags=tags } txt txt' =
64  (if readTag `elem` tags then (:) (spec, specialQuery) else id) $
65  pFreshLine (ps { hierObjs=spec}) (dropWhile ((/=) '\n') rem''')
66  where
67    isBlank     c = c==' ' || c=='\t'
68    isAlphaNum_ c = isAlphaNum c || c=='_'
69    isTagName c = isAlphaNum_ c || c=='-' || c=='.'  --to allow tag 'gtk-2.4'
70    (origCName,rem) = span isAlphaNum txt
71    (origHsName,_) = span isAlphaNum txt'
72    (eqInst,rem') =
73       let r = dropWhile isBlank rem in
74       if "noEq" `isPrefixOf` r then (True, drop 4 r) else (False, r)
75    (defDestr,rem'') =
76       let r = dropWhile isBlank rem' in
77       if "noDestr" `isPrefixOf` r then (True, drop 7 r) else (False, r)
78    (name,specialQuery,rem''') = case (dropWhile isBlank rem'') of
79      ('a':'s':r) ->
80        let (tyName,r') = span isAlphaNum_ (dropWhile isBlank r) in
81          case (dropWhile isBlank r') of
82            (',':r) ->
83              let (tyQuery,r') = span isAlphaNum_ (dropWhile isBlank r) in
84                (tyName, (tyName, TypeInfo origCName (Just tyQuery) eqInst defDestr), r')
85            r -> (tyName, (tyName, TypeInfo origCName Nothing eqInst defDestr), r)
86      r -> (origHsName, (origHsName, TypeInfo origCName Nothing eqInst defDestr), r)
87    parents = dropWhile (\(c,_) -> c>=col ps) (hierObjs ps)
88    spec = (col ps,name):parents
89    (readTag, rem'''') = case (dropWhile isBlank rem''') of
90      ('i':'f':r) -> span isTagName (dropWhile isBlank r)
91      r -> ("default",r)
92
93
94-------------------------------------------------------------------------------
95-- Helper functions
96-------------------------------------------------------------------------------
97
98ss = showString
99sc = showChar
100
101indent :: Int -> ShowS
102indent c = ss ("\n"++replicate (2*c) ' ')
103
104-------------------------------------------------------------------------------
105-- start of code generation
106-------------------------------------------------------------------------------
107
108typeGen :: [String] -> IO String
109typeGen args = do
110  let showHelp = not (null (filter ("-h" `isPrefixOf`) args++
111                            filter ("--help" `isPrefixOf`) args)) || null args
112  if showHelp then usage else do
113
114  -----------------------------------------------------------------------------
115  -- Parse command line parameters
116  --
117  let rem = args
118  let tags = map (drop 6) (filter ("--tag=" `isPrefixOf`)  rem)
119  let lib = case map (drop 6) (filter ("--lib=" `isPrefixOf`)  rem) of
120              [] -> "gtk"
121              (lib:_) -> lib
122  let prefix = case map (drop 9) (filter ("--prefix=" `isPrefixOf`)  rem) of
123                 [] -> "gtk"
124                 (prefix:_) -> prefix
125  let modName = case map (drop 10) (filter ("--modname=" `isPrefixOf`)  rem) of
126                  [] -> "Hierarchy"
127                  (modName:_) -> modName
128        where bareFName = reverse .
129                          takeWhile isAlphaNum .
130                          drop 1 .
131                          dropWhile isAlpha .
132                          reverse
133  let extraNames = map (drop 9) (filter ("--import=" `isPrefixOf`) rem)
134  let rootObject = case map (drop 7) (filter ("--root=" `isPrefixOf`) rem) of
135                     [] -> "GObject"
136                     (rootObject:_) -> rootObject
137  let forwardNames = map (drop 10) (filter ("--forward=" `isPrefixOf`) rem)
138  let destrFun = case map (drop 13) (filter ("--destructor=" `isPrefixOf`) rem) of
139                   [] -> "objectUnref"
140                   (destrFun:_) -> destrFun
141  -----------------------------------------------------------------------------
142  -- Read in the hierarchy and template files
143  --
144  hierFile <- case map (drop 12) (filter ("--hierarchy=" `isPrefixOf`) rem) of
145                [] -> getDataFileName "hierarchyGen/hierarchy.list"
146                (hierFile:_) -> return hierFile
147  hierarchy <- readFile hierFile
148  templateFile <- getDataFileName "hierarchyGen/Hierarchy.chs.template"
149  template <- readFile templateFile
150
151  -----------------------------------------------------------------------------
152  -- Parse the contents of the hierarchy file
153  --
154  let (objs', specialQueries) = unzip $
155                                 pFreshLine (freshParserState tags) hierarchy
156      objs = map (map snd) objs'
157  let showImport ('*':m ) = ss "{#import " .ss m .ss "#}" . indent 0
158      showImport m = ss "import " . ss m . indent 0
159  -----------------------------------------------------------------------------
160  -- return the result after substituting values into the template file
161  --
162  return $
163    templateSubstitute template (\var ->
164      case var of
165        "MODULE_NAME"    -> ss modName
166        "MODULE_EXPORTS" -> generateExports rootObject (map (dropWhile ((==) '*')) forwardNames) objs
167        "MODULE_IMPORTS" -> foldl (.) id (map showImport (extraNames++forwardNames))
168        "CONTEXT_LIB"    -> ss lib
169        "CONTEXT_PREFIX" -> ss prefix
170        "DECLARATIONS"   -> generateDeclarations rootObject destrFun prefix objs specialQueries
171        "ROOTOBJECT"     -> ss rootObject
172        _ -> ss ""
173    ) ""
174
175
176usage = do
177 hPutStr stderr "\nProgram to generate Gtk's object hierarchy in Haskell. Usage:\n\
178        \TypeGenerator {--tag=<tag>} [--lib=<lib>] [--prefix=<prefix>]\n\
179        \              [--modname=<modName>] {--import=<*><importName>}\n\
180        \              {--forward=<*><fwdName>} [--destructor=<destrName>]\n\
181        \              [--hierarchy=<hierName>]\n\
182        \where\n\
183        \  <tag>           generate entries that have the tag <tag>\n\
184        \                  specify `default' for types without tags\n\
185        \  <lib>           set the lib to use in the c2hs {#context #}\n\
186        \                  declaration (the default is \"gtk\")\n\
187        \  <prefix>        set the prefix to use in the c2hs {#context #}\n\
188        \                  declaration (the default is \"gtk\")\n\
189        \  <modName>       specify module name if it does not match the\n\
190        \                  file name, eg a hierarchical module name\n\
191        \  <importName>    additionally import this module without\n\
192        \                  re-exporting it\n\
193        \  <fwdName>       specify a number of modules that are imported\n\
194        \  <*>             use an asterix as prefix if the import should\n\
195        \                  be a .chs import statement\n\
196        \                  as well as exported from the generated module\n\
197        \  <destrName>     specify a non-standard C function pointer that\n\
198        \                  is called to destroy the objects\n\
199        \  <hierName>      the name of the file containing the hierarchy list,\n\
200        \                  defaults to the built-in list\n\
201        \\n\
202        \The resulting Haskell module is written to the standard output.\n"
203 exitWith $ ExitFailure 1
204
205
206
207-------------------------------------------------------------------------------
208-- generate dynamic fragments
209-------------------------------------------------------------------------------
210
211generateExports :: String -> [String] -> [[String]] -> ShowS
212generateExports rootObject forwardNames objs =
213  drop 1.
214  foldl (\s1 s2 -> s1.ss ",".indent 1.ss "module ".s2) id
215    (map ss forwardNames).
216  foldl (\s1 s2 -> s1.ss ",".s2) id
217    [ indent 1.ss n.ss "(".ss n.ss "), ".ss n.ss "Class,".
218      indent 1.ss "to".ss n.ss ", ".
219      indent 1.ss "mk".ss n.ss ", un".ss n.sc ','.
220      indent 1.ss "castTo".ss n.ss ", gType".ss n
221    | (n:_) <- objs
222    , n /= rootObject  ]
223
224generateDeclarations :: String -> String -> String -> [[String]] -> TypeTable -> ShowS
225generateDeclarations rootObject destr prefix objs typeTable =
226  foldl (.) id
227  [ makeClass rootObject destr prefix typeTable obj
228  . makeUpcast rootObject obj
229  . makeGType typeTable obj
230  | obj <- objs ]
231
232makeUpcast :: String -> [String] -> ShowS
233makeUpcast rootObject [obj]        = id -- no casting for root
234makeUpcast rootObject (obj:_:_) =
235  indent 0.ss "castTo".ss obj.ss " :: ".ss rootObject.ss "Class obj => obj -> ".ss obj.
236  indent 0.ss "castTo".ss obj.ss " = castTo gType".ss obj.ss " \"".ss obj.ss "\"".
237  indent 0
238
239makeGType :: TypeTable -> [String] -> ShowS
240makeGType table [obj] = id -- no GType for root
241makeGType table (obj:_:_) =
242  indent 0.ss "gType".ss obj.ss " :: GType".
243  indent 0.ss "gType".ss obj.ss " =".
244  indent 1.ss "{# call fun unsafe ".
245    ss (case lookup obj table of
246         (Just TypeInfo { tiAlternateName = Just get_type_func }) ->
247           get_type_func
248         (Just TypeInfo { tiQueryFunction = cname}) ->
249           tail $ c2u True cname++"_get_type").
250    ss " #}".
251  indent 0
252  where
253    -- case to underscore translation: the boolean arg specifies whether
254    -- the first uppercase letter X is to be replaced by _x (True) or by x.
255    --
256    -- translation:     HButtonBox -> hbutton_box
257    c2u :: Bool -> String -> String
258    c2u True  (x:xs) | isUpper x = '_':toLower x:c2u False xs
259    c2u False (x:xs) | isUpper x = toLower x:c2u True xs
260    c2u _     (x:xs) | otherwise = x:c2u True xs
261    c2u _     []                 = []
262
263makeOrd fill []          = id
264makeOrd fill (obj:preds) = indent 1.ss "compare ".ss obj.ss "Tag ".
265                           fill obj.ss obj.ss "Tag".fill obj.
266                           ss " = EQ".makeGT obj preds
267  where
268    makeGT obj []       = id
269    makeGT obj (pr:eds) = indent 1.ss "compare ".ss obj.ss "Tag ".
270                          fill obj.ss pr.ss "Tag".fill pr.
271                          ss " = GT".makeGT obj eds
272
273makeClass :: String -> String -> String -> TypeTable -> [String] -> ShowS
274makeClass rootObject destr prefix table (name:[])      = id
275makeClass rootObject destr prefix table (name:parents) =
276  indent 0.ss "-- ".ss (replicate (75-length name) '*').sc ' '.ss name.
277  indent 0.
278  indent 0.ss "{#pointer *".
279  (case lookup name table of
280        (Just TypeInfo { tiQueryFunction = cname }) -> ss cname.ss " as ".ss name
281        ).
282  ss " foreign newtype #}".
283  (case lookup name table of
284     (Just (TypeInfo { tiNoEqualInst = False })) -> ss " deriving (Eq,Ord)"
285     _ -> id
286     ).
287  indent 0.
288  indent 0.ss "mk".ss name.ss " = (".ss name.ss ", ".
289    (case lookup name table of Just TypeInfo { tiDefaultDestr = False } -> ss destr
290                               Just TypeInfo { tiDefaultDestr = True } -> ss "objectUnref").ss ")".
291  indent 0.ss "un".ss name.ss " (".ss name.ss " o) = o".
292  indent 0.
293  indent 0.ss "class ".ss (head parents).ss "Class o => ".ss name.ss "Class o".
294  indent 0.ss "to".ss name.ss " :: ".ss name.ss "Class o => o -> ".ss name.
295  indent 0.ss "to".ss name.ss " = unsafeCast".ss rootObject.ss " . to".ss rootObject.
296  indent 0.
297  makeInstance name (name:init parents).
298  makeRootInstance rootObject name.
299  indent 0
300
301makeInstance :: String -> [String] -> ShowS
302makeInstance name [] = id
303makeInstance name (par:ents) =
304  indent 0.ss "instance ".ss par.ss "Class ".ss name.
305  makeInstance name ents
306
307makeRootInstance :: String -> String -> ShowS
308makeRootInstance rootObject name =
309  indent 0.ss "instance ".ss rootObject.ss "Class ".ss name.ss " where".
310  indent 1.ss "to".ss rootObject.ss " = ".ss rootObject.ss" . castForeignPtr . un".ss name.
311  indent 1.ss "unsafeCast".ss rootObject.ss " = ".ss name.ss " . castForeignPtr . un".ss rootObject
312
313templateSubstitute :: String -> (String -> ShowS) -> ShowS
314templateSubstitute template varSubst = doSubst template
315  where doSubst [] = id
316        doSubst ('\\':'@':cs) = sc '@' . doSubst cs
317        doSubst ('@':cs) = let (var,_:cs') = span ('@'/=) cs
318                            in varSubst var . doSubst cs'
319        doSubst (c:cs) = sc c . doSubst cs
320