module CodeGen (
  genModuleBody,
  genTodoItems,
  makeKnownSymbolsMap
  ) where

import Module       (Module(..), Decl(..), DeclBody(..), isAttr)
import qualified Api
import qualified HaddockDocs (Span(..), formatParasFragment, formatSections,
                     formatParas, formatSpans, haddockSection)
import HaddockDocs  (Span(..))
import Marshal      (CSymbol(..), ParameterKind(..), EnumKind(..),
                     KnownSymbols, genMarshalParameter, genMarshalResult,
                     genMarshalOutParameter, genCall, genMarshalProperty,
                     convertSignalType)
import Names        (cParamNameToHsName, cFuncNameToHsName, hsTypeNameToCGetType)
import Utils
import MarshalFixup (maybeNullParameter, maybeNullResult, leafClass,
                     nukeParameterDocumentation)

import Prelude hiding (Enum, lines)
import Data.List    (groupBy, sortBy, partition, intersperse)
import Data.Maybe   (fromMaybe, catMaybes, isNothing)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Version

import Numeric (showHex)
import Data.List (foldl')
import Data.Word (Word16)
import Data.Char (ord)

-------------------------------------------------------------------------------
-- More doc formatting utils
-------------------------------------------------------------------------------

deprecated name comment =
  pragma $ text "DEPRECATED" <+> name <+> doubleQuotes comment

pragma d = text "{-#" <+> d <+> text "#-}"
c2hsHook name d = text "{#" <+> text name <+> d <+> text "#}"

tuple []  = empty
tuple [x] = x
tuple  xs = parens (hsep $ punctuate comma xs)

tuple' xs = parens (hsep $ punctuate comma xs)

-------------------------------------------------------------------------------
-- Now lets actually generate some code fragments based on the api info
-------------------------------------------------------------------------------

genDecl :: KnownSymbols -> Decl -> Doc
genDecl knownSymbols decl =
     --TODO: re-enable hashes and make it work reliably
{-     hashes
  $$-} formattedDocs
  $$ formattedCode
  $$ deprecatedNote

  where
    generatedDocs =
      case decl_doc decl of
        Nothing  -> empty
        Just []  -> comment <+> char '|'
                 $$ comment
        Just doc -> HaddockDocs.formatParas 77 doc
                 $$ comment
    handWrittenDocs = vcat (map text $ decl_user_docs decl)
    generatedDocsHash   = hash generatedDocs
    handWrittenDocsHash = hash handWrittenDocs
    formattedDocs
      | decl_user_docs_hash decl
     == generatedDocsHash = handWrittenDocs
      | otherwise         = generatedDocs

    generatedCode = genDeclCode knownSymbols decl
    handWrittenCode = vcat (map text $ decl_user_code decl)
    generatedCodeHash   = hash generatedCode
    handWrittenCodeHash = hash handWrittenCode
    formattedCode
      | decl_user_code_hash decl
     == generatedCodeHash = handWrittenCode
      | otherwise         = generatedCode

    dhash | generatedDocsHash == handWrittenDocsHash = empty
          | otherwise = text "d:" <> text generatedDocsHash
    chash | generatedCodeHash == handWrittenCodeHash = empty
          | otherwise = text "c:" <> text generatedCodeHash
    hashes | isEmpty chash && isEmpty dhash = empty
           | otherwise = comment <+> text "%hash" <+> chash <+> dhash
--                    $$ comment <+> text "%hash" <+> text "c:" <> text (decl_user_code_hash decl)
--                                                <+> text "d:" <> text (decl_user_docs_hash decl)

    hash :: Doc -> String
    hash = ($[])
         . showHex
         . foldl' (\h c -> h * 33 + (fromIntegral (ord c)))
                  (5381 :: Word16)
         . render

    deprecatedNote
      | decl_deprecated decl
                  = deprecated (text $ decl_name decl)
                               (text $ decl_deprecated_comment decl)
      | otherwise = empty

genDeclCode :: KnownSymbols -> Decl -> Doc
genDeclCode knownSymbols Decl{ decl_body = method@(Method {}) } =
     text functionName <+> text "::" <+> classContext <+> firstLineParamsType
  $$ nest 1 multiLineParamsType
  $$ text functionName <+> formattedParamNames <+> equals
  $$ nest 2 codebody

  where functionName = cFuncNameToHsName (method_cname method)
        (classConstraints, paramTypes', paramMarshalers) =
          unzip3 [ case genMarshalParameter knownSymbols (method_cname method)
                          (changeIllegalNames (cParamNameToHsName (Api.parameter_name p)))
                          (Api.parameter_type p) of
                     (c, ty, m) -> (c, (ty, Api.parameter_name p), m)
                 | p <- method_parameters method ]
        inParamTypes = [ (paramType, lookup name paramDocMap)
                     | (InParam paramType, name) <- paramTypes' ]
        inParamNames = [ changeIllegalNames (cParamNameToHsName (Api.parameter_name p))
                     | ((InParam _, _), p) <- zip paramTypes' (method_parameters method) ]
        outParamTypes = [ (paramType, lookup name paramDocMap)
                        | (OutParam paramType, name) <- paramTypes' ]
        formattedParamNames = hsep $ map text inParamNames
        (returnType', returnMarshaler) =
                genMarshalResult knownSymbols (method_cname method)
                                  (method_is_constructor method) (method_return_type method)
        returnType | null outParamTypes  = ("IO " ++ returnType', lookup "Returns" paramDocMap)
                   | otherwise = case unzip outParamTypes of
                                   (types', docs') ->
                                     let types | returnType' == "()" = types'
                                               | otherwise           = returnType' : types'
                                         docs = mergeParamDocs (lookup "Returns" paramDocMap) docs'
                                      in (case types of
                                            [t] -> "IO " ++ t
                                            _   -> "IO (" ++ concat (intersperse ", " types) ++ ")"
                                         ,docs)
        (outParamMarshalersBefore, outParamMarshalersAfter, returnOutParamFragments) =
             unzip3 [ genMarshalOutParameter outParamType (changeIllegalNames (cParamNameToHsName name))
                    | (OutParam outParamType, name) <- paramTypes' ]
        returnOutParams body | null outParamTypes = body
                             | otherwise = body
                                        $$ text "return" <+> tuple' returnOutParamFragments
        codebody = foldl (\body marshaler -> marshaler body)
                     call (paramMarshalers
                       ++ [ (\body -> frag $$ body) | frag <- reverse outParamMarshalersBefore ]
                       ++ [ (\body -> body $$ frag) | frag <- outParamMarshalersAfter ]
                       ++ [returnMarshaler,returnOutParams])
        call = genCall (fromMaybe (method_cname method) (method_shortcname method))
                       (method_is_unsafe_ffi method)
        docNullsAllFixed = maybeNullResult (method_cname method)
                        || or [ maybeNullParameter (method_cname method) (cParamNameToHsName (Api.parameter_name p))
                              | p <- method_parameters method ]
        paramDocMap = [ (name
                        ,(if name == "Returns"
                           then [SpanText "returns "]
                           else [SpanMonospace [SpanText (Names.cParamNameToHsName name)]
                                ,SpanText " - "]
                         ) ++ paragraph)
                      | (name, paragraph) <- method_param_docs method
                      , not $ nukeParameterDocumentation
                                (method_cname method)
                                (cParamNameToHsName name) ]

        classContext = case catMaybes classConstraints of
                         []  -> empty
                         cs  -> tuple (map text cs) <+> text "=>"

        (firstLineParams, multiLineParams) = span (isNothing.snd) (inParamTypes ++ [returnType])

        firstLineParamsType :: Doc
        firstLineParamsType =
            hsep
          . intersperse (text "->")
          . map (text.fst)
          $ firstLineParams

        multiLineParamsType :: Doc
        multiLineParamsType =
            vcat
          . (\lines ->
             case lines of
               [] -> []
               (l:ls) | null firstLineParams -> nest 3 l : map (text "->" <+>) ls
                      | otherwise -> map (text "->" <+>) lines)
          . map (\(type_, doc) ->
            case doc of
              Nothing  -> text type_
              Just doc -> text type_
                       <> text (replicate (columnIndent - length type_) ' ')
                      <+> HaddockDocs.haddockSection (char '^')
                            (HaddockDocs.formatSpans 3 (80 - columnIndent - 8) doc))
          $ multiLineParams

        columnIndent = maximum [ length parmType | (parmType, Just _) <- multiLineParams ]

genDeclCode knownSymbols decl@(Decl{ decl_body = attr@(AttributeProp { attribute_is_child = False }) }) =
  genAtter decl propertyName classConstraint getterType setterType False (Right body)
  where propertyName = decl_name decl
        (propertyType, gvalueKind, needsGetTypeCCall) =
          genMarshalProperty knownSymbols (attribute_type attr)
        body = text attrType <> text "AttrFrom" <> text gvalueKind <> text "Property"
           <+> doubleQuotes (text (attribute_cname attr))
            $$ if needsGetTypeCCall
                  then let attrType  = attribute_type attr
                           ccall_name = text (hsTypeNameToCGetType attrType)
                        in nest 2 $ c2hsHook "call pure unsafe" ccall_name
                  else empty
          where attrType | not (attribute_constructonly attr)
                        && attribute_readable attr
                        && attribute_writeable attr = "new"
                         | attribute_readable  attr = "read"
                         | attribute_writeable attr = "write"
        getterType | attribute_readable attr  = Just propertyType
                   | otherwise                = Nothing
        (setterType, classConstraint)
                   | attribute_writeable attr
                  && gvalueKind == "Object"
                  && not (attribute_constructonly attr) =
                    if leafClass (attribute_type attr)
                      then (Just propertyType, Nothing)
                      else let typeVar = lowerCaseFirstWord propertyType
                               classConstraint' = propertyType ++ "Class " ++ typeVar
                            in (Just typeVar, Just classConstraint')
                   | not (attribute_constructonly attr)
                  && attribute_writeable attr = (Just propertyType, Nothing)
                   | otherwise                = (Nothing, Nothing)


genDeclCode knownSymbols decl@(Decl{ decl_body = attr@(AttributeProp { attribute_is_child = True }) }) =
  genAtter decl propertyName classConstraint getterType setterType True (Right body)
  where propertyName = decl_name decl
        (propertyType, gvalueKind, needsGetTypeCCall) =
          genMarshalProperty knownSymbols (attribute_type attr)
        body = text attrType <> text "AttrFromContainerChild" <> text gvalueKind <> text "Property"
           <+> doubleQuotes (text (attribute_cname attr))
            $$ if needsGetTypeCCall
                  then let attrType  = attribute_type attr
                           ccall_name = text (hsTypeNameToCGetType attrType)
                        in nest 2 $ c2hsHook "call pure unsafe" ccall_name
                  else empty
          where attrType | not (attribute_constructonly attr)
                        && attribute_readable attr
                        && attribute_writeable attr = "new"
                         | attribute_readable  attr = "read"
                         | attribute_writeable attr = "write"
        getterType | attribute_readable attr  = Just propertyType
                   | otherwise                = Nothing
        (setterType, classConstraint)
                   | attribute_writeable attr
                  && gvalueKind == "Object"
                  && not (attribute_constructonly attr) =
                    if leafClass (attribute_type attr)
                      then (Just propertyType, Nothing)
                      else let typeVar = lowerCaseFirstWord propertyType
                               classConstraint' = propertyType ++ "Class " ++ typeVar ++ ", WidgetClass child"
                            in (Just typeVar, Just classConstraint')
                   | not (attribute_constructonly attr)
                  && attribute_writeable attr = (Just propertyType, Just "WidgetClass child")
                   | otherwise                = (Nothing, Just "WidgetClass child")

genDeclCode knownSymbols decl@(Decl{ decl_body = attr@(AttributeGetSet {}) }) =
  genAtter decl propertyName classConstraint
           (Just getterType) (Just setterType) False
           (Left (text (decl_name getter), text (decl_name setter)))
  where propertyName = decl_name decl
        (getterType, _) = genMarshalResult knownSymbols (method_cname getter_body) False
                              (method_return_type getter_body)
        (classConstraint, setterType) =
          case let param = method_parameters setter_body !! 1
                   paramName = changeIllegalNames (cParamNameToHsName (Api.parameter_name param))
                   paramType = Api.parameter_type param
                in genMarshalParameter knownSymbols (method_cname setter_body) paramName paramType of
            (classConstraint', InParam setterType', _) -> (classConstraint', setterType')
            (_, OutParam _, _)  -> (Nothing, "{- FIXME: should be in param -}")
        getter@Decl { decl_body = getter_body } = attribute_getter attr
        setter@Decl { decl_body = setter_body } = attribute_setter attr

genDeclCode knownSymbols Decl{ decl_module = module_,
                               decl_name = signalName,
                               decl_body = signal@Module.Signal {} }
  | signal_is_old_style signal =
      text signalName <+> text "::" <+> oldSignalType
   $$ text signalName <+> equals <+> text "connect_" <> connectCall <+> signalCName <+> text (show $ signal_is_after signal)

  | otherwise =
      text (lowerCaseFirstWord signalName) <+> text "::" <+> signalType
   $$ text (lowerCaseFirstWord signalName) <+> equals <+> text "Signal" <+> parens (text "connect_" <> connectCall <+> signalCName)

  where connectCall = let paramCategories' = if null paramCategories then [text "NONE"] else map text paramCategories
                       in hcat (punctuate (char '_') paramCategories') <> text "__" <> text returnCategory
        -- strip off the object arg to the signal handler
        params = case Module.signal_parameters signal of
                   (param:params') | Api.parameter_type param
                                  == (module_cname module_) ++ "*" -> params'
                   params' -> params'
        (paramCategories, paramTypes) = unzip [ convertSignalType knownSymbols (Api.parameter_type parameter)
                                              | parameter <- params ]
        (returnCategory, returnType) = convertSignalType knownSymbols (Module.signal_return_type signal)
        signalType = text (module_name module_) <> text "Class self => Signal self" <+> callbackType True
        oldSignalType = text (module_name module_) <> text "Class self => self"
                     $$ nest nestLevel (text "->" <+> callbackType False
                             $$ text "->" <+> text "IO (ConnectId self)")
          where nestLevel = -(length signalName + 3)
        callbackType needsParens
                     | null paramTypes = (if needsParens then parens else id)
                                           (text "IO" <+> text returnType)
                     | otherwise = parens (hsep . intersperse (text "->") . map text $
                                          (paramTypes ++ ["IO " ++ returnType]))
        signalCName = doubleQuotes (text $ Module.signal_cname signal)

genDeclCode _
  Decl { decl_body = Instance { instance_class_name = className,
                                instance_type_name  = typeName }} =
  text "instance" <+> text className <+> text typeName


mergeParamDocs :: Maybe [Span] -> [Maybe [Span]] -> Maybe [Span]
mergeParamDocs doc docs =
  case catMaybes (doc:docs) of
    [] -> Nothing
    [doc'] -> Just doc'
    docs' -> let (varNames, paramDocs) =
                   unzip [ case doc' of
                            (SpanMonospace [SpanText varName] : _)
                               -> (cParamNameToHsName varName, doc')
                            _  -> ("_", doc')
                         | doc' <- docs' ]
                 returnValName = SpanMonospace [SpanText $ "(" ++ concat (intersperse ", " varNames) ++ ")"]
                 fixmeMessage  = SpanText " {FIXME: merge return value docs} "
              in Just $ returnValName : fixmeMessage : concat paramDocs

changeIllegalNames :: String -> String
changeIllegalNames "type" = "type_"   --these are common variable names in C but
changeIllegalNames "where" = "where_" --of course are keywords in Haskell
changeIllegalNames "data" = "data_"
changeIllegalNames other = other

genModuleBody :: KnownSymbols -> Module -> Doc
genModuleBody knownTypes module_ =
     summary
  $$ comment
  $$ (if Module.module_deprecated module_
        then text "module" <+> moduleName
          $$ deprecatedNote <+> lparen
        else text "module" <+> moduleName <+> lparen)
 $+$ documentation
 $+$ exports
  $$ nest 2 (rparen <+> text "where")
 $+$ imports
 $+$ (if module_needs_c2hs module_ then context else empty)
 $+$ decls

  where summary = HaddockDocs.formatParasFragment (module_summary module_)

        moduleName | isEmpty prefix = name
                   | otherwise      = prefix <> char '.' <> name
          where name = text (Module.module_name module_)
                prefix = text (Module.module_prefix module_)

        deprecatedNote | Module.module_deprecated module_ =
          deprecated empty (text "this module should not be used in newly-written code.")
                       | otherwise = empty

        documentation = HaddockDocs.formatSections (module_description module_)

        exports = genExports module_
        imports = genImports module_

        context = c2hsHook "context" $
                    text "lib" <> equals <> doubleQuotes (text $ module_context_lib module_)
                <+> text "prefix" <> equals <> doubleQuotes (text $ module_context_prefix module_)

        decls = genDecls knownTypes module_

genDecls :: KnownSymbols -> Module -> Doc
genDecls knownSymbols module_ =
    doVersionIfDefs vsep
  . map adjustDeprecatedAndSinceVersion
  $  sectionHeader "Interfaces"
     [ (genDecl knownSymbols decl, (since, deprecated))
     | decl@Decl { decl_since = since,
                   decl_deprecated = deprecated,
                   decl_body = Instance { }
       } <- module_decls module_ ]
  ++ sectionHeader "Constructors"
     [ (genDecl knownSymbols decl, (since, deprecated))
     | decl@Decl { decl_since = since,
                   decl_deprecated = deprecated,
                   decl_body = Method { method_is_constructor = True }
       } <- module_decls module_ ]
  ++ sectionHeader "Methods"
     [ (genDecl knownSymbols decl, (since, deprecated))
     | decl@Decl { decl_since = since,
                   decl_deprecated = deprecated,
                   decl_body = Method { method_is_constructor = False }
       } <- module_decls module_ ]
  ++ sectionHeader "Attributes"
     [ (genDecl knownSymbols decl, (since, deprecated))
     | decl@Decl { decl_since = since,
                   decl_deprecated = deprecated
       } <- module_decls module_, isAttr decl ]
  ++ sectionHeader "Child Attributes"
     [ (genDecl knownSymbols decl, (since, deprecated))
     | decl@Decl { decl_since = since,
                   decl_deprecated = deprecated,
                   decl_body = AttributeProp { attribute_is_child = True }
       } <- module_decls module_ ]
  ++ sectionHeader "Signals"
     [ (genDecl knownSymbols decl, (since, deprecated))
     | decl@Decl { decl_since = since,
                   decl_deprecated = deprecated@False,
                   decl_body = Module.Signal {}
       } <- module_decls module_ ]
  ++ sectionHeader "Deprecated Signals"
     [ (genDecl knownSymbols decl, (since, deprecated))
     | decl@Decl { decl_since = since,
                   decl_deprecated = deprecated@True,
                   decl_body = Module.Signal {}
       } <- module_decls module_ ]
  where sectionHeader _    []      = []
        sectionHeader name entries =
          let header = (text "--------------------"
                     $$ comment <+> text name, (Nothing, False))
           in header : entries
        adjustDeprecatedAndSinceVersion (doc, (since, deprecated)) =
          (doc, (module_since module_ `max` since, Module.module_deprecated module_ || deprecated))


genAtter :: Decl -> String
         -> Maybe String -> Maybe String -> Maybe String -> Bool
         -> Either (Doc, Doc) Doc -> Doc
genAtter Decl { decl_module = module_ }
         propertyName classConstraint getterType setterType isChild attrImpl =
    text propertyName <+> text "::" <+> classContext <+> child <+> attrType <+> objectParamType <+> attrArgs
 $$ text propertyName <+> equals <+> body
 $$ nest 2 body'
  where objectType = text (module_name module_)
        objectParamType | leafClass (module_cname module_) = objectType
                        | otherwise                        = text "self"
        classContext = case (leafClass (module_cname module_), classConstraint) of
                         (True,  Nothing)              -> empty
                         (False, Nothing)              ->
                           objectType <> text "Class self =>"
                         (True,  Just classConstraint') ->
                           text classConstraint' <+> text "=>"
                         (False, Just classConstraint') ->
                           parens (objectType <> text "Class self" <> comma
                               <+> text classConstraint') <+> text "=>"
        (attrType, attrConstructor, attrArgs) =
          case (getterType, setterType) of
            (Just gt, Nothing)        -> (text "ReadAttr",     text "readAttr", text gt)
            (Nothing, Just st)        -> (text "WriteAttr",    text "writeAttr", text st)
            (Just gt, Just st)
              | gt == st              -> (text "Attr",          text "newAttr", text gt)
              | length (words st) > 1 -> (text "ReadWriteAttr", text "newAttr", text gt <+> parens (text st))
              | otherwise             -> (text "ReadWriteAttr", text "newAttr", text gt <+> text st)
            _ -> error $ "no getter or setter for " ++ module_name module_ ++ " :: " ++ propertyName
        child | isChild   = text "child" <+> text "->"
              | otherwise = empty
        body  = case attrImpl of
                  Left  _ -> attrConstructor
                  Right b -> b
        body' = case attrImpl of
                  Left (getter, setter) ->
                    case (getterType, setterType) of
                      (Just _, Nothing) -> getter
                      (Nothing, Just _) -> setter
                      (Just _,  Just _) -> getter $$ setter
                  Right _ -> empty

makeKnownSymbolsMap :: Api.API -> KnownSymbols
makeKnownSymbolsMap api =
   (Map.fromListWith (\a b -> b)
  . concat)
  [ [ (Api.enum_cname enum
      ,case Api.enum_variety enum of
        Api.EnumVariety -> SymEnumType EnumKind
        Api.FlagsVariety -> SymEnumType FlagsKind)
    | enum <- Api.namespace_enums namespace ]
 ++ [ (Api.object_cname object, objectKind object)
    | object <- Api.namespace_objects namespace ]
 ++ [ (Api.class_cname class_, SymClassType)
    | class_ <- Api.namespace_classes namespace ]
 ++ [ (Api.boxed_cname boxed, SymBoxedType)
    | boxed <- Api.namespace_boxed namespace ]
 ++ [ (Api.member_cname member, SymEnumValue)
    | enum <- Api.namespace_enums namespace
    , member <- Api.enum_members enum ]
 ++ [ (Api.misc_cname misc, miscToCSymbol misc )
    | misc <- Api.namespace_misc namespace ]
  | namespace <- api ]

        -- find if an object inherits via GtkObject or directly from GObject
  where objectKind :: Api.Object -> CSymbol
        objectKind object | "GObject" `elem` parents
                         || "GInitiallyUnowned" `elem` parents = SymObjectType parents
                          | Api.object_parent object == "GTypeInstance" = SymStructType
                          -- FIXME: These hacks should go elsewhere
                          | otherwise = SymObjectType [Api.object_cname object, "GObject"]
          where parents = objectParents object
        objectParents :: Api.Object -> [String]
        objectParents object = Api.object_cname object :
          case Api.object_parent object `Map.lookup` objectMap of
            Nothing -> [Api.object_parent object]
            Just parent -> objectParents parent
        objectMap :: Map String Api.Object
        objectMap = Map.fromList
                    [ (Api.object_cname object, object)
                    | namespace <- api
                    , object <- Api.namespace_objects namespace ]
        miscToCSymbol (Api.Struct   _ _) = SymStructType
        miscToCSymbol (Api.Alias    _ _) = SymTypeAlias
        miscToCSymbol (Api.Callback _ _) = SymCallbackType

genExports :: Module -> Doc
genExports module_ =
    doVersionIfDefs vcat
  . map adjustDeprecatedAndSinceVersion
  $  sectionHeader False "Types"
     [(text (Module.module_name module_), defaultAttrs)
     ,(text (Module.module_name module_) <> text "Class", defaultAttrs)
     ,(text "castTo" <> text (Module.module_name module_), defaultAttrs)
     ,(text "to"     <> text (Module.module_name module_), defaultAttrs)]
  ++ sectionHeader True "Constructors"
     [ (text name, (since, False))
     | Decl { decl_name = name,
              decl_since = since,
              decl_deprecated = False,
              decl_body = Method { method_is_constructor = True }
       } <- exports ]
  ++ sectionHeader True "Methods"
     [ (text name, (since, False))
     | Decl { decl_name = name,
              decl_since = since,
              decl_deprecated = False,
              decl_body = Method { method_is_constructor = False }
       } <- exports ]
  ++ sectionHeader True "Attributes"
     [ (text name, (since, False))
     | decl@Decl { decl_since = since,
                   decl_deprecated = False,
                   decl_name = name
       } <- module_decls module_
       , isAttr decl ]
  ++ sectionHeader True "Child Attributes"
     [ (text name, (since, False))
     | Decl { decl_name = name,
              decl_since = since,
              decl_deprecated = False,
              decl_body = AttributeProp { attribute_is_child = True }
       } <- module_decls module_ ]
  ++ sectionHeader True "Signals"
     [ (text name, (since, False))
     | Decl { decl_name = name,
              decl_since = since,
              decl_deprecated = False,
              decl_body = Module.Signal { signal_is_old_style = False }
       } <- exports ]
  ++ sectionHeader True "Deprecated"
     [ (text name, (since, True))
     | Decl { decl_name = name,
              decl_since = since,
              decl_deprecated = True
       } <- exports ]

  where defaultAttrs = (Nothing, False)
        sectionHeader _ _    []      = []
        sectionHeader False name entries = (text "-- * " <> text name, defaultAttrs)
                                   : map (\(doc, attrs) -> (nest 2 (doc <> comma), attrs)) entries
        sectionHeader True name entries = (emptyLine, defaultAttrs)
                                   : (text "-- * " <> text name, defaultAttrs)
                                   : map (\(doc, attrs) -> (nest 2 (doc <> comma), attrs)) entries
        adjustDeprecatedAndSinceVersion (doc, (since, deprecated)) =
          (doc, (Module.module_since module_ `max` since, Module.module_deprecated module_ || deprecated))
        exports = sortBy (comparing decl_index_export) (module_decls module_)

genImports :: Module -> Doc
genImports module_ =
  (case [ text importLine
        | (_, importLine) <- stdModules ] of
     []   -> empty
     mods -> vcat mods)
  $+$ vcat [ text importLine
           | (_, importLine) <- extraModules ]
  where (stdModules, extraModules)
          | null (Module.module_imports module_) =
             ([(undefined, "import Control.Monad\t(liftM)")]
             ,[(undefined, "import System.Glib.FFI")
             ,(undefined, "{#import Graphics.UI.Gtk.Types#}")
             ,(undefined, "-- CHECKME: extra imports may be required")])
          | otherwise = partition (\(m, _) -> m `elem` knownStdModules)
                                  (Module.module_imports module_)
        knownStdModules = ["Maybe", "Monad", "Char", "List", "Data.IORef"]

genTodoItems :: Module -> Doc
genTodoItems Module { module_todos = varargsFunctions }
  | null varargsFunctions = empty
  | otherwise =
       comment <+> text "TODO: the following varargs functions were not bound"
    $$ (commentBlock . map ((text "  " <>) . text)) varargsFunctions
    $$ comment

type Deprecated = Bool
type Since = Maybe Version

doVersionIfDefs :: ([Doc] -> Doc) -> [(Doc, (Since, Deprecated))] -> Doc
doVersionIfDefs sep =
    sep
  . layoutChunks True empty
  . makeChunks [Nothing] False
  . map (\group@((_,(since, deprecated)):_) -> (map fst group, since, deprecated))
  . groupBy (equating snd)

  where makeChunks :: [Since] -> Deprecated -> [([Doc], Since, Deprecated)] -> [Chunk]
        makeChunks    sinceStack  True [] = EndChunk : makeChunks sinceStack False []
        makeChunks (_:[])         _    [] = []
        makeChunks (_:sinceStack) _    [] = EndChunk : makeChunks sinceStack False []
        makeChunks sinceStack@(sinceContext:_) prevDeprecated whole@((group, since, deprecated):rest)
          | deprecated < prevDeprecated = EndChunk              : makeChunks sinceStack deprecated whole
          | since < sinceContext        = EndChunk              : makeChunks (tail sinceStack)  prevDeprecated whole
          | deprecated > prevDeprecated = BeginDeprecatedChunk  : makeChunks sinceStack deprecated whole
          | since > sinceContext        = BeginSinceChunk since : makeChunks (since:sinceStack) prevDeprecated whole
          | otherwise                   = SimpleChunk group     : makeChunks sinceStack prevDeprecated rest

        layoutChunks :: Bool -> Doc -> [Chunk] -> [Doc]
        layoutChunks _     doc  []                             = doc : []
        layoutChunks _     doc (EndChunk              :chunks) =       layoutChunks False (doc $$ endif) chunks
        layoutChunks False doc (SimpleChunk group     :chunks) = doc : layoutChunks False (sep group) chunks
        layoutChunks True  doc (SimpleChunk group     :chunks) =       layoutChunks False (doc $$ sep group) chunks
        layoutChunks _     doc (BeginDeprecatedChunk  :chunks) = doc : layoutChunks True ifndefDeprecated chunks
        layoutChunks _     doc (BeginSinceChunk since :chunks) = doc : layoutChunks True (ifSinceVersion since) chunks

        ifSinceVersion (Just Version { versionBranch = [major,minor] }) =
          text "#if GTK_CHECK_VERSION(" <> int major <> comma <> int minor <> text ",0)"
        ifndefDeprecated = text "#ifndef DISABLE_DEPRECATED"
        endif = text "#endif"

data Chunk = SimpleChunk [Doc]
           | BeginDeprecatedChunk
           | BeginSinceChunk Since
           | EndChunk
