-- TypeGen.hs
-- Takes a hierarchical list of all objects in GTK+ and produces
-- Haskell class that reflect this hierarchy.
module TypeGen (typeGen) where

import Data.Char     (isAlpha, isAlphaNum, toLower, toUpper, isUpper)
import Data.List     (isPrefixOf)
import Control.Monad (when)
import System.Exit   (exitWith, ExitCode(..))
import System.IO (stderr, hPutStr)
import Paths_gtk2hs_buildtools (getDataFileName)

-- The current object and its inheritence relationship is defined by all
-- ancestors and their column position.
type ObjectSpec = [(Int,String)]

-- This is a mapping from a type name to a) the type name in Haskell and
-- b) the info on this type 'TypeInfo'.
type TypeQuery  = (String, TypeInfo)

-- The information of on the type.
data TypeInfo = TypeInfo {
  TypeInfo -> String
tiQueryFunction :: String, -- the GTK blah_get_type function
  TypeInfo -> Maybe String
tiAlternateName :: Maybe String,
  TypeInfo -> Bool
tiNoEqualInst   :: Bool,
  TypeInfo -> Bool
tiDefaultDestr  :: Bool
  }

type TypeTable  = [TypeQuery]

-- A Tag is a string restricting the generation of type entries to
-- those lines that have the appropriate "if <tag>" at the end.
type Tag = String

data ParserState = ParserState {
  ParserState -> Int
line          :: Int,
  ParserState -> Int
col           :: Int,
  ParserState -> ObjectSpec
hierObjs      :: ObjectSpec,
  ParserState -> [String]
onlyTags      :: [Tag]
  }

freshParserState :: [Tag] -> ParserState
freshParserState :: [String] -> ParserState
freshParserState = Int -> Int -> ObjectSpec -> [String] -> ParserState
ParserState Int
1 Int
1 []

-- The parser returns a list of ObjectSpec and possibly a special type query
-- function. Each ObjectSpec describes one object with all its parents.

pFreshLine :: ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFreshLine :: ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFreshLine ParserState
ps String
input = ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFL ParserState
ps String
input
  where
    pFL :: ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFL ParserState
ps (Char
'#':String
rem)            = ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFL ParserState
ps (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
(/=) Char
'\n') String
rem)
    pFL ParserState
ps (Char
'\n':String
rem)           = ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFL (ParserState
ps {line :: Int
line = ParserState -> Int
line ParserState
psforall a. Num a => a -> a -> a
+Int
1, col :: Int
col=Int
1}) String
rem
    pFL ParserState
ps (Char
' ':String
rem)            = ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFL (ParserState
ps {col :: Int
col=ParserState -> Int
col ParserState
psforall a. Num a => a -> a -> a
+Int
1}) String
rem
    pFL ParserState
ps (Char
'\t':String
rem)           = ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFL (ParserState
ps {col :: Int
col=ParserState -> Int
col ParserState
psforall a. Num a => a -> a -> a
+Int
8}) String
rem
    pFL ParserState
ps all :: String
all@(Char
'G':Char
't':Char
'k':String
rem)= ParserState -> String -> String -> [(ObjectSpec, TypeQuery)]
pGetObject ParserState
ps String
all String
rem
    pFL ParserState
ps all :: String
all@(Char
'G':Char
'd':Char
'k':String
rem)= ParserState -> String -> String -> [(ObjectSpec, TypeQuery)]
pGetObject ParserState
ps String
all String
rem
    pFL ParserState
ps all :: String
all@(Char
'G':Char
's':Char
't':String
rem)= ParserState -> String -> String -> [(ObjectSpec, TypeQuery)]
pGetObject ParserState
ps String
all String
rem
    pFL ParserState
ps all :: String
all@(Char
'G':Char
'n':Char
'o':Char
'm':Char
'e':String
rem)= ParserState -> String -> String -> [(ObjectSpec, TypeQuery)]
pGetObject ParserState
ps String
all String
rem
    pFL ParserState
ps []                   = []
    pFL ParserState
ps String
all                  = ParserState -> String -> String -> [(ObjectSpec, TypeQuery)]
pGetObject ParserState
ps String
all String
all

pGetObject :: ParserState -> String -> String -> [(ObjectSpec, TypeQuery)]
pGetObject :: ParserState -> String -> String -> [(ObjectSpec, TypeQuery)]
pGetObject ps :: ParserState
ps@ParserState { onlyTags :: ParserState -> [String]
onlyTags=[String]
tags } String
txt String
txt' =
  (if String
readTag forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tags then (:) (ObjectSpec
spec, TypeQuery
specialQuery) else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
  ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFreshLine (ParserState
ps { hierObjs :: ObjectSpec
hierObjs=ObjectSpec
spec}) (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
(/=) Char
'\n') String
rem''')
  where
    isBlank :: Char -> Bool
isBlank     Char
c = Char
cforall a. Eq a => a -> a -> Bool
==Char
' ' Bool -> Bool -> Bool
|| Char
cforall a. Eq a => a -> a -> Bool
==Char
'\t'
    isAlphaNum_ :: Char -> Bool
isAlphaNum_ Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
cforall a. Eq a => a -> a -> Bool
==Char
'_'
    isTagName :: Char -> Bool
isTagName Char
c = Char -> Bool
isAlphaNum_ Char
c Bool -> Bool -> Bool
|| Char
cforall a. Eq a => a -> a -> Bool
==Char
'-' Bool -> Bool -> Bool
|| Char
cforall a. Eq a => a -> a -> Bool
==Char
'.'  --to allow tag 'gtk-2.4'
    (String
origCName,String
rem) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlphaNum String
txt
    (String
origHsName,String
_) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlphaNum String
txt'
    (Bool
eqInst,String
rem') =
       let r :: String
r = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isBlank String
rem in
       if String
"noEq" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
r then (Bool
True, forall a. Int -> [a] -> [a]
drop Int
4 String
r) else (Bool
False, String
r)
    (Bool
defDestr,String
rem'') =
       let r :: String
r = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isBlank String
rem' in
       if String
"noDestr" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
r then (Bool
True, forall a. Int -> [a] -> [a]
drop Int
7 String
r) else (Bool
False, String
r)
    (String
name,TypeQuery
specialQuery,String
rem''') = case (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isBlank String
rem'') of
      (Char
'a':Char
's':String
r) ->
        let (String
tyName,String
r') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlphaNum_ (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isBlank String
r) in
          case (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isBlank String
r') of
            (Char
',':String
r) ->
              let (String
tyQuery,String
r') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlphaNum_ (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isBlank String
r) in
                (String
tyName, (String
tyName, String -> Maybe String -> Bool -> Bool -> TypeInfo
TypeInfo String
origCName (forall a. a -> Maybe a
Just String
tyQuery) Bool
eqInst Bool
defDestr), String
r')
            String
r -> (String
tyName, (String
tyName, String -> Maybe String -> Bool -> Bool -> TypeInfo
TypeInfo String
origCName forall a. Maybe a
Nothing Bool
eqInst Bool
defDestr), String
r)
      String
r -> (String
origHsName, (String
origHsName, String -> Maybe String -> Bool -> Bool -> TypeInfo
TypeInfo String
origCName forall a. Maybe a
Nothing Bool
eqInst Bool
defDestr), String
r)
    parents :: ObjectSpec
parents = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(Int
c,String
_) -> Int
cforall a. Ord a => a -> a -> Bool
>=ParserState -> Int
col ParserState
ps) (ParserState -> ObjectSpec
hierObjs ParserState
ps)
    spec :: ObjectSpec
spec = (ParserState -> Int
col ParserState
ps,String
name)forall a. a -> [a] -> [a]
:ObjectSpec
parents
    (String
readTag, String
rem'''') = case (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isBlank String
rem''') of
      (Char
'i':Char
'f':String
r) -> forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isTagName (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isBlank String
r)
      String
r -> (String
"default",String
r)


-------------------------------------------------------------------------------
-- Helper functions
-------------------------------------------------------------------------------

ss :: String -> ShowS
ss = String -> ShowS
showString
sc :: Char -> ShowS
sc = Char -> ShowS
showChar

indent :: Int -> ShowS
indent :: Int -> ShowS
indent Int
c = String -> ShowS
ss (String
"\n"forall a. [a] -> [a] -> [a]
++forall a. Int -> a -> [a]
replicate (Int
2forall a. Num a => a -> a -> a
*Int
c) Char
' ')

-------------------------------------------------------------------------------
-- start of code generation
-------------------------------------------------------------------------------

typeGen :: [String] -> IO String
typeGen :: [String] -> IO String
typeGen [String]
args = do
  let showHelp :: Bool
showHelp = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"-h" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
argsforall a. [a] -> [a] -> [a]
++
                            forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--help" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args)) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args
  if Bool
showHelp then forall {b}. IO b
usage else do

  -----------------------------------------------------------------------------
  -- Parse command line parameters
  --
  let rem :: [String]
rem = [String]
args
  let tags :: [String]
tags = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
6) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--tag=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
rem)
  let lib :: String
lib = case forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
6) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--lib=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
rem) of
              [] -> String
"gtk"
              (String
lib:[String]
_) -> String
lib
  let prefix :: String
prefix = case forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
9) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--prefix=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
rem) of
                 [] -> String
"gtk"
                 (String
prefix:[String]
_) -> String
prefix
  let modName :: String
modName = case forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
10) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--modname=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
rem) of
                  [] -> String
"Hierarchy"
                  (String
modName:[String]
_) -> String
modName
        where bareFName :: ShowS
bareFName = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isAlphaNum forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isAlpha forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          forall a. [a] -> [a]
reverse
  let extraNames :: [String]
extraNames = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
9) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--import=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
rem)
  let rootObject :: String
rootObject = case forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
7) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--root=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
rem) of
                     [] -> String
"GObject"
                     (String
rootObject:[String]
_) -> String
rootObject
  let forwardNames :: [String]
forwardNames = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
10) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--forward=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
rem)
  let destrFun :: String
destrFun = case forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
13) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--destructor=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
rem) of
                   [] -> String
"objectUnref"
                   (String
destrFun:[String]
_) -> String
destrFun
  -----------------------------------------------------------------------------
  -- Read in the hierarchy and template files
  --
  String
hierFile <- case forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
12) (forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--hierarchy=" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
rem) of
                [] -> String -> IO String
getDataFileName String
"hierarchyGen/hierarchy.list"
                (String
hierFile:[String]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return String
hierFile
  String
hierarchy <- String -> IO String
readFile String
hierFile
  String
templateFile <- String -> IO String
getDataFileName String
"hierarchyGen/Hierarchy.chs.template"
  String
template <- String -> IO String
readFile String
templateFile

  -----------------------------------------------------------------------------
  -- Parse the contents of the hierarchy file
  --
  let ([ObjectSpec]
objs', [TypeQuery]
specialQueries) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$
                                 ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFreshLine ([String] -> ParserState
freshParserState [String]
tags) String
hierarchy
      objs :: [[String]]
objs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) [ObjectSpec]
objs'
  let showImport :: String -> ShowS
showImport (Char
'*':String
m ) = String -> ShowS
ss String
"{#import " forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
m forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"#}" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
0
      showImport String
m = String -> ShowS
ss String
"import " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
ss String
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
indent Int
0
  -----------------------------------------------------------------------------
  -- return the result after substituting values into the template file
  --
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    String -> (String -> ShowS) -> ShowS
templateSubstitute String
template (\String
var ->
      case String
var of
        String
"MODULE_NAME"    -> String -> ShowS
ss String
modName
        String
"MODULE_EXPORTS" -> String -> [String] -> [[String]] -> ShowS
generateExports String
rootObject (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
(==) Char
'*')) [String]
forwardNames) [[String]]
objs
        String
"MODULE_IMPORTS" -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id (forall a b. (a -> b) -> [a] -> [b]
map String -> ShowS
showImport ([String]
extraNamesforall a. [a] -> [a] -> [a]
++[String]
forwardNames))
        String
"CONTEXT_LIB"    -> String -> ShowS
ss String
lib
        String
"CONTEXT_PREFIX" -> String -> ShowS
ss String
prefix
        String
"DECLARATIONS"   -> String -> String -> String -> [[String]] -> [TypeQuery] -> ShowS
generateDeclarations String
rootObject String
destrFun String
prefix [[String]]
objs [TypeQuery]
specialQueries
        String
"ROOTOBJECT"     -> String -> ShowS
ss String
rootObject
        String
_ -> String -> ShowS
ss String
""
    ) String
""


usage :: IO b
usage = do
 Handle -> String -> IO ()
hPutStr Handle
stderr String
"\nProgram to generate Gtk's object hierarchy in Haskell. Usage:\n\
        \TypeGenerator {--tag=<tag>} [--lib=<lib>] [--prefix=<prefix>]\n\
        \              [--modname=<modName>] {--import=<*><importName>}\n\
        \              {--forward=<*><fwdName>} [--destructor=<destrName>]\n\
        \              [--hierarchy=<hierName>]\n\
        \where\n\
        \  <tag>           generate entries that have the tag <tag>\n\
        \                  specify `default' for types without tags\n\
        \  <lib>           set the lib to use in the c2hs {#context #}\n\
        \                  declaration (the default is \"gtk\")\n\
        \  <prefix>        set the prefix to use in the c2hs {#context #}\n\
        \                  declaration (the default is \"gtk\")\n\
        \  <modName>       specify module name if it does not match the\n\
        \                  file name, eg a hierarchical module name\n\
        \  <importName>    additionally import this module without\n\
        \                  re-exporting it\n\
        \  <fwdName>       specify a number of modules that are imported\n\
        \  <*>             use an asterix as prefix if the import should\n\
        \                  be a .chs import statement\n\
        \                  as well as exported from the generated module\n\
        \  <destrName>     specify a non-standard C function pointer that\n\
        \                  is called to destroy the objects\n\
        \  <hierName>      the name of the file containing the hierarchy list,\n\
        \                  defaults to the built-in list\n\
        \\n\
        \The resulting Haskell module is written to the standard output.\n"
 forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1



-------------------------------------------------------------------------------
-- generate dynamic fragments
-------------------------------------------------------------------------------

generateExports :: String -> [String] -> [[String]] -> ShowS
generateExports :: String -> [String] -> [[String]] -> ShowS
generateExports String
rootObject [String]
forwardNames [[String]]
objs =
  forall a. Int -> [a] -> [a]
drop Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ShowS
s1 ShowS
s2 -> ShowS
s1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
","forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"module "forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
s2) forall a. a -> a
id
    (forall a b. (a -> b) -> [a] -> [b]
map String -> ShowS
ss [String]
forwardNames)forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ShowS
s1 ShowS
s2 -> ShowS
s1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
","forall b c a. (b -> c) -> (a -> b) -> a -> c
.ShowS
s2) forall a. a -> a
id
    [ Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"("forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"), "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Class,"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"to"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
", "forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"mk"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
", un"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
','forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"castTo"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
", gType"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
n
    | (String
n:[String]
_) <- [[String]]
objs
    , String
n forall a. Eq a => a -> a -> Bool
/= String
rootObject  ]

generateDeclarations :: String -> String -> String -> [[String]] -> TypeTable -> ShowS
generateDeclarations :: String -> String -> String -> [[String]] -> [TypeQuery] -> ShowS
generateDeclarations String
rootObject String
destr String
prefix [[String]]
objs [TypeQuery]
typeTable =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id
  [ String -> String -> String -> [TypeQuery] -> [String] -> ShowS
makeClass String
rootObject String
destr String
prefix [TypeQuery]
typeTable [String]
obj
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> ShowS
makeUpcast String
rootObject [String]
obj
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeQuery] -> [String] -> ShowS
makeGType [TypeQuery]
typeTable [String]
obj
  | [String]
obj <- [[String]]
objs ]

makeUpcast :: String -> [String] -> ShowS
makeUpcast :: String -> [String] -> ShowS
makeUpcast String
rootObject [String
obj]        = forall a. a -> a
id -- no casting for root
makeUpcast String
rootObject (String
obj:String
_:[String]
_) =
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"castTo"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" :: "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
rootObjectforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Class obj => obj -> "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"castTo"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" = castTo gType"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" \""forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"\""forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0

makeGType :: TypeTable -> [String] -> ShowS
makeGType :: [TypeQuery] -> [String] -> ShowS
makeGType [TypeQuery]
table [String
obj] = forall a. a -> a
id -- no GType for root
makeGType [TypeQuery]
table (String
obj:String
_:[String]
_) =
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"gType"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" :: GType"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"gType"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" ="forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"{# call fun unsafe "forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> ShowS
ss (case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
obj [TypeQuery]
table of
         (Just TypeInfo { tiAlternateName :: TypeInfo -> Maybe String
tiAlternateName = Just String
get_type_func }) ->
           String
get_type_func
         (Just TypeInfo { tiQueryFunction :: TypeInfo -> String
tiQueryFunction = String
cname}) ->
           forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ Bool -> ShowS
c2u Bool
True String
cnameforall a. [a] -> [a] -> [a]
++String
"_get_type")forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> ShowS
ss String
" #}"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0
  where
    -- case to underscore translation: the boolean arg specifies whether
    -- the first uppercase letter X is to be replaced by _x (True) or by x.
    --
    -- translation:     HButtonBox -> hbutton_box
    c2u :: Bool -> String -> String
    c2u :: Bool -> ShowS
c2u Bool
True  (Char
x:String
xs) | Char -> Bool
isUpper Char
x = Char
'_'forall a. a -> [a] -> [a]
:Char -> Char
toLower Char
xforall a. a -> [a] -> [a]
:Bool -> ShowS
c2u Bool
False String
xs
    c2u Bool
False (Char
x:String
xs) | Char -> Bool
isUpper Char
x = Char -> Char
toLower Char
xforall a. a -> [a] -> [a]
:Bool -> ShowS
c2u Bool
True String
xs
    c2u Bool
_     (Char
x:String
xs) | Bool
otherwise = Char
xforall a. a -> [a] -> [a]
:Bool -> ShowS
c2u Bool
True String
xs
    c2u Bool
_     []                 = []

makeOrd :: (String -> ShowS) -> [String] -> ShowS
makeOrd String -> ShowS
fill []          = forall a. a -> a
id
makeOrd String -> ShowS
fill (String
obj:[String]
preds) = Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"compare "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Tag "forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           String -> ShowS
fill String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Tag"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
fill String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.
                           String -> ShowS
ss String
" = EQ"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> [String] -> ShowS
makeGT String
obj [String]
preds
  where
    makeGT :: String -> [String] -> ShowS
makeGT String
obj []       = forall a. a -> a
id
    makeGT String
obj (String
pr:[String]
eds) = Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"compare "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Tag "forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          String -> ShowS
fill String
objforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
prforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Tag"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
fill String
prforall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          String -> ShowS
ss String
" = GT"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> [String] -> ShowS
makeGT String
obj [String]
eds

makeClass :: String -> String -> String -> TypeTable -> [String] -> ShowS
makeClass :: String -> String -> String -> [TypeQuery] -> [String] -> ShowS
makeClass String
rootObject String
destr String
prefix [TypeQuery]
table (String
name:[])      = forall a. a -> a
id
makeClass String
rootObject String
destr String
prefix [TypeQuery]
table (String
name:[String]
parents) =
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"-- "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss (forall a. Int -> a -> [a]
replicate (Int
75forall a. Num a => a -> a -> a
-forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name) Char
'*')forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ShowS
sc Char
' 'forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"{#pointer *"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [TypeQuery]
table of
        (Just TypeInfo { tiQueryFunction :: TypeInfo -> String
tiQueryFunction = String
cname }) -> String -> ShowS
ss String
cnameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" as "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
name
        )forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> ShowS
ss String
" foreign newtype #}"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [TypeQuery]
table of
     (Just (TypeInfo { tiNoEqualInst :: TypeInfo -> Bool
tiNoEqualInst = Bool
False })) -> String -> ShowS
ss String
" deriving (Eq,Ord)"
     Maybe TypeInfo
_ -> forall a. a -> a
id
     )forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"mk"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" = ("forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
", "forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
name [TypeQuery]
table of Just TypeInfo { tiDefaultDestr :: TypeInfo -> Bool
tiDefaultDestr = Bool
False } -> String -> ShowS
ss String
destr
                               Just TypeInfo { tiDefaultDestr :: TypeInfo -> Bool
tiDefaultDestr = Bool
True } -> String -> ShowS
ss String
"objectUnref")forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
")"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"un"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" ("forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" o) = o"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"class "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss (forall a. [a] -> a
head [String]
parents)forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Class o => "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Class o"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"to"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" :: "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Class o => o -> "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"to"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" = unsafeCast"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
rootObjectforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" . to"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
rootObjectforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> [String] -> ShowS
makeInstance String
name (String
nameforall a. a -> [a] -> [a]
:forall a. [a] -> [a]
init [String]
parents)forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> String -> ShowS
makeRootInstance String
rootObject String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
0

makeInstance :: String -> [String] -> ShowS
makeInstance :: String -> [String] -> ShowS
makeInstance String
name [] = forall a. a -> a
id
makeInstance String
name (String
par:[String]
ents) =
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"instance "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
parforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Class "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  String -> [String] -> ShowS
makeInstance String
name [String]
ents

makeRootInstance :: String -> String -> ShowS
makeRootInstance :: String -> String -> ShowS
makeRootInstance String
rootObject String
name =
  Int -> ShowS
indent Int
0forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"instance "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
rootObjectforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"Class "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" where"forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"to"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
rootObjectforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" = "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
rootObjectforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ssString
" . castForeignPtr . un"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> ShowS
indent Int
1forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
"unsafeCast"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
rootObjectforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" = "forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
nameforall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
" . castForeignPtr . un"forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> ShowS
ss String
rootObject

templateSubstitute :: String -> (String -> ShowS) -> ShowS
templateSubstitute :: String -> (String -> ShowS) -> ShowS
templateSubstitute String
template String -> ShowS
varSubst = String -> ShowS
doSubst String
template
  where doSubst :: String -> ShowS
doSubst [] = forall a. a -> a
id
        doSubst (Char
'\\':Char
'@':String
cs) = Char -> ShowS
sc Char
'@' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
doSubst String
cs
        doSubst (Char
'@':String
cs) = let (String
var,Char
_:String
cs') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char
'@'forall a. Eq a => a -> a -> Bool
/=) String
cs
                            in String -> ShowS
varSubst String
var forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
doSubst String
cs'
        doSubst (Char
c:String
cs) = Char -> ShowS
sc Char
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
doSubst String
cs