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


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

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

indent :: Int -> ShowS
indent :: Int -> String -> String
indent Int
c = String -> String -> String
ss (String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
2Int -> Int -> Int
forall 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 ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"-h" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                            (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--help" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
args)) Bool -> Bool -> Bool
|| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args
  if Bool
showHelp then IO String
forall b. IO b
usage else do

  -----------------------------------------------------------------------------
  -- Parse command line parameters
  --
  let rem :: [String]
rem = [String]
args
  let tags :: [String]
tags = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
6) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--tag=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
rem)
  let lib :: String
lib = case (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
6) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--lib=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
rem) of
              [] -> String
"gtk"
              (String
lib:[String]
_) -> String
lib
  let prefix :: String
prefix = case (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
9) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--prefix=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
rem) of
                 [] -> String
"gtk"
                 (String
prefix:[String]
_) -> String
prefix
  let modName :: String
modName = case (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
10) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--modname=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)  [String]
rem) of
                  [] -> String
"Hierarchy"
                  (String
modName:[String]
_) -> String
modName
        where bareFName :: String -> String
bareFName = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isAlphaNum (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isAlpha (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          String -> String
forall a. [a] -> [a]
reverse
  let extraNames :: [String]
extraNames = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
9) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--import=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
rem)
  let rootObject :: String
rootObject = case (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
7) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--root=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
rem) of
                     [] -> String
"GObject"
                     (String
rootObject:[String]
_) -> String
rootObject
  let forwardNames :: [String]
forwardNames = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
10) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--forward=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
rem)
  let destrFun :: String
destrFun = case (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
13) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--destructor=" String -> String -> Bool
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 (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
12) ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
"--hierarchy=" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
rem) of
                [] -> String -> IO String
getDataFileName String
"hierarchyGen/hierarchy.list"
                (String
hierFile:[String]
_) -> String -> IO 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) = [(ObjectSpec, TypeQuery)] -> ([ObjectSpec], [TypeQuery])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(ObjectSpec, TypeQuery)] -> ([ObjectSpec], [TypeQuery]))
-> [(ObjectSpec, TypeQuery)] -> ([ObjectSpec], [TypeQuery])
forall a b. (a -> b) -> a -> b
$
                                 ParserState -> String -> [(ObjectSpec, TypeQuery)]
pFreshLine ([String] -> ParserState
freshParserState [String]
tags) String
hierarchy
      objs :: [[String]]
objs = (ObjectSpec -> [String]) -> [ObjectSpec] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (((Int, String) -> String) -> ObjectSpec -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> String
forall a b. (a, b) -> b
snd) [ObjectSpec]
objs'
  let showImport :: String -> String -> String
showImport (Char
'*':String
m ) = String -> String -> String
ss String
"{#import " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String -> String
ss String
m (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String -> String
ss String
"#}" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
indent Int
0
      showImport String
m = String -> String -> String
ss String
"import " (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
ss String
m (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
indent Int
0
  -----------------------------------------------------------------------------
  -- return the result after substituting values into the template file
  --
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
    String -> (String -> String -> String) -> String -> String
templateSubstitute String
template (\String
var ->
      case String
var of
        String
"MODULE_NAME"    -> String -> String -> String
ss String
modName
        String
"MODULE_EXPORTS" -> String -> [String] -> [[String]] -> String -> String
generateExports String
rootObject ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) Char
'*')) [String]
forwardNames) [[String]]
objs
        String
"MODULE_IMPORTS" -> ((String -> String) -> (String -> String) -> String -> String)
-> (String -> String) -> [String -> String] -> String -> String
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) String -> String
forall a. a -> a
id ((String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String -> String
showImport ([String]
extraNames[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++[String]
forwardNames))
        String
"CONTEXT_LIB"    -> String -> String -> String
ss String
lib
        String
"CONTEXT_PREFIX" -> String -> String -> String
ss String
prefix
        String
"DECLARATIONS"   -> String
-> String
-> String
-> [[String]]
-> [TypeQuery]
-> String
-> String
generateDeclarations String
rootObject String
destrFun String
prefix [[String]]
objs [TypeQuery]
specialQueries
        String
"ROOTOBJECT"     -> String -> String -> String
ss String
rootObject
        String
_ -> String -> String -> String
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"
 ExitCode -> IO b
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO b) -> ExitCode -> IO b
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1



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

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

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

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

makeGType :: TypeTable -> [String] -> ShowS
makeGType :: [TypeQuery] -> [String] -> String -> String
makeGType [TypeQuery]
table [String
obj] = String -> String
forall a. a -> a
id -- no GType for root
makeGType [TypeQuery]
table (String
obj:String
_:[String]
_) =
  Int -> String -> String
indent Int
0(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String -> String
ss String
"gType"(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String -> String
ss String
obj(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String -> String
ss String
" :: GType"(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> String -> String
indent Int
0(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String -> String
ss String
"gType"(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String -> String
ss String
obj(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String -> String
ss String
" ="(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> String -> String
indent Int
1(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.String -> String -> String
ss String
"{# call fun unsafe "(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
ss (case String -> [TypeQuery] -> Maybe TypeInfo
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}) ->
           String -> String
forall a. [a] -> [a]
tail (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Bool -> String -> String
c2u Bool
True String
cnameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"_get_type")(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    String -> String -> String
ss String
" #}"(String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Int -> String -> String
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 -> String -> String
c2u Bool
True  (Char
x:String
xs) | Char -> Bool
isUpper Char
x = Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:Char -> Char
toLower Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:Bool -> String -> String
c2u Bool
False String
xs
    c2u Bool
False (Char
x:String
xs) | Char -> Bool
isUpper Char
x = Char -> Char
toLower Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:Bool -> String -> String
c2u Bool
True String
xs
    c2u Bool
_     (Char
x:String
xs) | Bool
otherwise = Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:Bool -> String -> String
c2u Bool
True String
xs
    c2u Bool
_     []                 = []

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

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

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

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

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