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