    -- 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 {
      tiQueryFunction :: String, -- the GTK blah_get_type function
      tiAlternateName :: Maybe String,
      tiNoEqualInst   :: 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 {
      line          :: Int,
      col           :: Int,
      hierObjs      :: ObjectSpec,
      onlyTags      :: [Tag]
      }

    freshParserState :: [Tag] -> ParserState
    freshParserState = ParserState 1 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 ps input = pFL ps input
      where
        pFL ps ('#':rem)            = pFL ps (dropWhile ((/=) '\n') rem)
        pFL ps ('\n':rem)           = pFL (ps {line = line ps+1, col=1}) rem
        pFL ps (' ':rem)            = pFL (ps {col=col ps+1}) rem
        pFL ps ('\t':rem)           = pFL (ps {col=col ps+8}) rem
        pFL ps all@('G':'t':'k':rem)= pGetObject ps all rem
        pFL ps all@('G':'d':'k':rem)= pGetObject ps all rem
        pFL ps all@('G':'s':'t':rem)= pGetObject ps all rem
        pFL ps all@('G':'n':'o':'m':'e':rem)= pGetObject ps all rem
        pFL ps []                   = []
        pFL ps all                  = pGetObject ps all all

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

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

    ss = showString
    sc = showChar

    indent :: Int -> ShowS
    indent c = ss ("\n"++replicate (2*c) ' ')

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

    typeGen :: [String] -> IO String
    typeGen args = do
      let showHelp = not (null (filter ("-h" `isPrefixOf`) args++
                                filter ("--help" `isPrefixOf`) args)) || null args
      if showHelp then usage else do

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

      -----------------------------------------------------------------------------
      -- Parse the contents of the hierarchy file
      --
      let (objs', specialQueries) = unzip $
                                     pFreshLine (freshParserState tags) hierarchy
          objs = map (map snd) objs'
      let showImport ('*':m ) = ss "{#import " .ss m .ss "#}" . indent 0
          showImport m = ss "import " . ss m . indent 0
      -----------------------------------------------------------------------------
      -- return the result after substituting values into the template file
      --
      return $
        templateSubstitute template (\var ->
          case var of
            "MODULE_NAME"    -> ss modName
            "MODULE_EXPORTS" -> generateExports rootObject (map (dropWhile ((==) '*')) forwardNames) objs
            "MODULE_IMPORTS" -> foldl (.) id (map showImport (extraNames++forwardNames))
            "CONTEXT_LIB"    -> ss lib
            "CONTEXT_PREFIX" -> ss prefix
            "DECLARATIONS"   -> generateDeclarations rootObject destrFun prefix objs specialQueries
            "ROOTOBJECT"     -> ss rootObject
            _ -> ss ""
        ) ""

    usage = do
     hPutStr stderr "\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"
     exitWith $ ExitFailure 1

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

    generateExports :: String -> [String] -> [[String]] -> ShowS
    generateExports rootObject forwardNames objs =
      drop 1.
      foldl (\s1 s2 -> s1.ss ",".indent 1.ss "module ".s2) id
        (map ss forwardNames).
      foldl (\s1 s2 -> s1.ss ",".s2) id
        [ indent 1.ss n.ss "(".ss n.ss "), ".ss n.ss "Class,".
          indent 1.ss "to".ss n.ss ", ".
          indent 1.ss "mk".ss n.ss ", un".ss n.sc ','.
          indent 1.ss "castTo".ss n.ss ", gType".ss n
        | (n:_) <- objs
        , n /= rootObject  ]

    generateDeclarations :: String -> String -> String -> [[String]] -> TypeTable -> ShowS
    generateDeclarations rootObject destr prefix objs typeTable =
      foldl (.) id
      [ makeClass rootObject destr prefix typeTable obj
      . makeUpcast rootObject obj
      . makeGType typeTable obj
      | obj <- objs ]

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

    makeGType :: TypeTable -> [String] -> ShowS
    makeGType table [obj] = id -- no GType for root
    makeGType table (obj:_:_) =
      indent 0.ss "gType".ss obj.ss " :: GType".
      indent 0.ss "gType".ss obj.ss " =".
      indent 1.ss "{# call fun unsafe ".
        ss (case lookup obj table of
             (Just TypeInfo { tiAlternateName = Just get_type_func }) ->
               get_type_func
             (Just TypeInfo { tiQueryFunction = cname}) ->
               tail $ c2u True cname++"_get_type").
        ss " #}".
      indent 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 True  (x:xs) | isUpper x = '_':toLower x:c2u False xs
        c2u False (x:xs) | isUpper x = toLower x:c2u True xs
        c2u _     (x:xs) | otherwise = x:c2u True xs
        c2u _     []                 = []

    makeOrd fill []          = id
    makeOrd fill (obj:preds) = indent 1.ss "compare ".ss obj.ss "Tag ".
                               fill obj.ss obj.ss "Tag".fill obj.
                               ss " = EQ".makeGT obj preds
      where
        makeGT obj []       = id
        makeGT obj (pr:eds) = indent 1.ss "compare ".ss obj.ss "Tag ".
                              fill obj.ss pr.ss "Tag".fill pr.
                              ss " = GT".makeGT obj eds

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

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

    makeRootInstance :: String -> String -> ShowS
    makeRootInstance rootObject name =
      indent 0.ss "instance ".ss rootObject.ss "Class ".ss name.ss " where".
      indent 1.ss "to".ss rootObject.ss " = ".ss rootObject.ss" . castForeignPtr . un".ss name.
      indent 1.ss "unsafeCast".ss rootObject.ss " = ".ss name.ss " . castForeignPtr . un".ss rootObject

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