[Gtk2hs-commit] gtk2hs/tools/apiGen Docs.hs,NONE,1.1 CodeGen.hs,NONE,1.1

[Duncan C. <dun...@us...>]

Update of /cvsroot/gtk2hs/gtk2hs/tools/apiGen
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31623/tools/apiGen

Added Files:
	Docs.hs CodeGen.hs 
Log Message:
Split ApiGen.hs into several modules to make it easier to manage and understand.


--- NEW FILE: CodeGen.hs ---
module CodeGen (
  genModuleBody,
  genExports,
  genTodoItems,
  makeKnownTypesMap
  ) where

import Api
import Docs
import FormatDocs
import Marshal
import StringUtils

import Prelude hiding (Enum, lines)
import List   (groupBy, sortBy)

import Debug.Trace (trace)

-------------------------------------------------------------------------------
-- Now lets actually generate some code fragments based on the api info
-------------------------------------------------------------------------------
genFunction :: KnownTypes -> Method -> Maybe FuncDoc -> ShowS
genFunction knownTypes method doc =
  formattedDoc.
  ss functionName. ss " :: ". functionType. nl.
  ss functionName. sc ' '. sepBy " " paramNames. ss " =".
  indent 1. body

  where functionName = cFuncNameToHsName (method_cname method)
	(classConstraints', paramTypes', paramMarshalers) =
	  unzip3 [ case genMarshalParameter knownTypes
                          (changeIllegalNames (cParamNameToHsName (parameter_name p)))
	                  (parameter_type p) of
                     (c, ty, m) -> (c, (ty, parameter_name p), m)
		 | p <- method_parameters method ]
	classConstraints = [ c | Just c <- classConstraints' ]
	paramTypes = [ (paramType, lookup name paramDocMap)
                     | (Just paramType, name) <- paramTypes' ]
	paramNames = [ changeIllegalNames (cParamNameToHsName (parameter_name p))
		     | ((Just _, _), p) <- zip paramTypes' (method_parameters method) ]
	(returnType', returnMarshaler) =
		genMarshalResult knownTypes (method_return_type method)
        returnType = (returnType', lookup "Returns" paramDocMap)
	functionType = (case classConstraints of
	                  []  -> id
			  [c] -> ss c. ss " => "
			  cs  -> sc '('. sepBy ", " classConstraints. ss ") => ").
                       formatParamTypes (paramTypes ++ [returnType])
	body = foldl (\body marshaler -> marshaler body)
                     call (paramMarshalers++[returnMarshaler])
	call = ss "{# call ". ss (method_cname method). ss " #}"
        formattedDoc = case doc of
          Nothing  -> ss "-- | \n-- \n"
          Just doc -> ss "-- | ". haddocFormatParas (funcdoc_paragraphs doc). nl.
                      comment. nl
        paramDocMap = case doc of
          Nothing  -> []
          Just doc -> [ (paramdoc_name paramdoc
                        ,(if paramdoc_name paramdoc == "Returns"
                           then [DocText "returns "]
                           else [DocArg (paramdoc_name paramdoc)
                                ,DocText " - "]
                         ) ++ paramdoc_paragraph paramdoc)
                      | paramdoc <- funcdoc_params doc ]
        
        formatParamTypes :: [(String, Maybe [DocParaSpan])] -> ShowS
        formatParamTypes paramTypes = format True False paramTypes
                                             -- True to indicate first elem
                                             -- False to mean previous param had no doc
          where format _    _ []                   = id
                format True _ ((t,Nothing)    :ts) =               ss t.
                                                     format False False ts
                format True _ ((t,Just doc)   :ts) = ss "\n    ". ss t.
                                                     ss (replicate (columnIndent - length t) ' ').
                                                     ss " -- ^ ". formatDoc t doc.
                                                     format False True  ts
                format _ True  ((t, Nothing)  :ts) = ss "\n -> ". ss t.
                                                     format False False ts
                format _ False ((t, Nothing)  :ts) = ss   " -> ". ss t.
                                                     format False False ts
                format _ _     ((t, Just doc) :ts) = ss "\n -> ". ss t.
                                                     ss (replicate (columnIndent - length t) ' ').
                                                     ss " -- ^ ". formatDoc t doc.
                                                     format False True  ts
                formatDoc :: String -> [DocParaSpan] -> ShowS
                formatDoc typeName =
                    sepBy' ("\n" ++ replicate (columnIndent+5) ' ' ++  "-- ")
                  . map (sepBy " ")
                  . wrapText 3 (80 - columnIndent - 8)
                  . words
                  . concatMap haddocFormatSpan
                columnIndent = maximum [ length parmType | (parmType, _) <- paramTypes ]

genModuleBody :: KnownTypes -> Object -> ModuleDoc -> ShowS
genModuleBody knownTypes object apiDoc =
  doVersionIfDefs (sepBy' "\n\n") $
     genConstructors knownTypes object (moduledoc_functions apiDoc)
  ++ genMethods knownTypes object (moduledoc_functions apiDoc)
  ++ genProperties knownTypes object (moduledoc_properties apiDoc)
  ++ genSignals knownTypes object (moduledoc_signals apiDoc)

genMethods :: KnownTypes -> Object -> [FuncDoc] -> [(ShowS, Since)]
genMethods knownTypes object apiDoc = 
  [ (genFunction knownTypes method doc, maybe "" funcdoc_since doc)
  | (method, doc) <- methods object apiDoc ]

methods :: Object -> [FuncDoc] -> [(Method, Maybe FuncDoc)]
methods object docs =
  map snd $
  sortBy (\(i,_) (j,_) -> i `compare` j)
  [ case method_cname method `lookup` docmap of
      Nothing             -> (0,(mungeMethod object method, Nothing))
      (Just (doc, index)) -> (index,(mungeMethod object method, Just doc))
  | method <- object_methods object
  , null [ () | VarArgs <- method_parameters method] ] --exclude VarArgs methods
  where docmap = [ (funcdoc_name doc, (doc,index)) | (doc,index) <- zip docs [1..]]
        

mungeMethod :: Object -> Method -> Method
mungeMethod object method =
  let self = Parameter {
               parameter_type = object_cname object ++ "*",
               parameter_name = "self",
               parameter_isArray = False
             }
   in method {
        method_name = object_name object ++ method_name method,
        method_parameters = self : method_parameters method
      } 

genConstructors :: KnownTypes -> Object -> [FuncDoc] -> [(ShowS, Since)]
genConstructors knownTypes object apiDoc =
  [ (genFunction knownTypes constructor doc, maybe "" funcdoc_since doc)
  | (constructor, doc) <- constructors object apiDoc ]

constructors :: Object -> [FuncDoc] -> [(Method, Maybe FuncDoc)]
constructors object docs =
  [ (mungeConstructor object constructor, constructor_cname constructor `lookup` docmap)
  | constructor <- object_constructors object
  , null [ () | VarArgs <- constructor_parameters constructor] ]
  where docmap = [ (funcdoc_name doc, doc) | doc <- docs ]

mungeConstructor :: Object -> Constructor -> Method
mungeConstructor object constructor =
  Method {
    method_name = cFuncNameToHsName (constructor_cname constructor),
    method_cname = constructor_cname constructor,
    method_return_type = object_cname object ++ "*",
    method_parameters = constructor_parameters constructor
  }  

properties :: Object -> [PropDoc] -> [(Property, Maybe PropDoc)]
properties object docs =
  [ (property, property_cname property `lookup` docmap)
  | property <- object_properties object ]
  where docmap = [ (map dashToUnderscore (propdoc_name doc), doc)
                 | doc <- docs ]
        dashToUnderscore '-' = '_'
        dashToUnderscore  c  =  c

genProperties :: KnownTypes -> Object -> [PropDoc] -> [(ShowS, Since)]
genProperties knownTypes object apiDoc = 
  [ (genProperty knownTypes object property doc, maybe "" propdoc_since doc)
  | (property, doc) <- properties object apiDoc ]

genProperty :: KnownTypes -> Object -> Property -> Maybe PropDoc -> ShowS
genProperty knownTypes object property doc = 
  formattedDoc.
  ss propertyName. ss " :: Attr ". objectType. sc ' '. ss propertyType. nl.
  ss propertyName. ss " = Attr ". 
  indent 1. getter.
  indent 1. setter
  where objectType = ss (object_name object)
        propertyName = cFuncNameToHsName (property_cname property)
        getter = ss "(\\obj -> do ". ss gvalueConstructor. ss " result <- objectGetProperty \"". ss (property_cname property). ss "\"".
                 indent 7. ss "return result"
        setter = ss "(\\obj val -> objectSetProperty obj \"". ss (property_cname property). ss "\" (". ss gvalueConstructor. ss " val))"
        formattedDoc = case doc of
          Nothing  -> ss "-- | \n-- \n"
          Just doc -> ss "-- | ". haddocFormatParas (propdoc_paragraphs doc). nl.
                      comment. nl
        (propertyType, gvalueConstructor) = genMarshalProperty knownTypes (property_type property)

signals :: Object -> [SignalDoc] -> [(Signal, Maybe SignalDoc)]
signals object docs =
  [ (signal, map dashToUnderscore (signal_cname signal) `lookup` docmap)
  | signal <- object_signals object ]
  where docmap = [ (map dashToUnderscore (signaldoc_name doc), doc)
                 | doc <- docs ]
        dashToUnderscore '-' = '_'
        dashToUnderscore  c  =  c

genSignals :: KnownTypes -> Object -> [SignalDoc] -> [(ShowS, Since)]
genSignals knownTypes object apiDoc = 
  [ (genSignal object signal doc, maybe "" signaldoc_since doc)
  | (signal, doc) <- signals object apiDoc ] 

genSignal :: Object -> Signal -> Maybe SignalDoc -> ShowS
genSignal object property doc = 
  formattedDoc.
  ss "on". signalName. ss ", after". signalName. ss " :: ". nl.
  ss "on".    signalName. ss " = connect_{-type-}". connectType. sc ' '. signalCName. ss " False". nl.
  ss "after". signalName. ss " = connect_{-type-}". connectType. sc ' '. signalCName. ss " True". nl

  where connectType = id
        signalName = ss (upperCaseFirstChar (cFuncNameToHsName (signal_cname property)))
        signalCName = sc '"'. ss (signal_cname property). sc '"'
        formattedDoc = case doc of
          Nothing  -> ss "-- | \n-- \n"
          Just doc -> ss "-- | ". haddocFormatParas (signaldoc_paragraphs doc). nl.
                      comment. nl

makeKnownTypesMap :: API -> KnownTypes
makeKnownTypesMap api =
  concat
  [ [ (enum_name enum
      ,case enum_variety enum of
        "enum" -> EnumKind
        "flags" -> FlagsKind)
    | enum <- namespace_enums namespace ]
 ++ [ (object_name object, objectKind object)
    | object <- namespace_objects namespace ]
  | namespace <- api ]

        -- find if an object inherits via GtkObject or directly from GObject
  where objectKind :: Object -> CTypeKind
        objectKind object = lookup (objectParents object)
          where lookup [] = trace ( "Warning: " ++ object_name object
                                 ++ " does not inherit from GObject! "
                                 ++ show (objectParents object)) GObjectKind
                lookup ("GTypeModule":os) = GObjectKind -- GTypeModule is a GObject
                lookup ("GObject":os) = GObjectKind
                lookup ("GtkObject":os) = GtkObjectKind
                lookup (_:os) = lookup os
        objectParents :: Object -> [String]
        objectParents object = object_cname object :
          case object_parent object `lookup` objectMap of
            Nothing -> [object_parent object]
            Just parent -> objectParents parent
        objectMap :: [(String, Object)]
        objectMap = [ (object_cname object, object)
                    | namespace <- api
                    , object <- namespace_objects namespace ]

genExports :: Object -> ModuleDoc -> ShowS
genExports object docs =
  comment.ss "* Types".
  indent 1.ss (object_name object).sc ','.
  indent 1.ss (object_name object).ss "Class,".
  indent 1.ss "castTo".ss (object_name object).sc ','.
  (case [ (ss "  ". ss (cFuncNameToHsName (method_cname constructor)). sc ','
          ,maybe "" funcdoc_since doc)
        | (constructor, doc) <- constructors object (moduledoc_functions docs)] of
     [] -> id
     cs -> nl.nl.comment.ss "* Constructors".nl.
           doVersionIfDefs lines cs).
  (case [ (ss "  ". ss (cFuncNameToHsName (method_cname method)). sc ','
          ,maybe "" funcdoc_since doc)
        | (method, doc) <- methods object (moduledoc_functions docs)] of
     [] -> id
     cs -> nl.nl.comment.ss "* Methods".nl.
           doVersionIfDefs lines cs).
  (case [ (ss "  ". ss (cFuncNameToHsName (property_cname property)). sc ','
          ,maybe "" propdoc_since doc)
        | (property, doc) <- properties object (moduledoc_properties docs)] of
     [] -> id
     cs -> nl.nl.comment.ss "* Properties".nl.
           doVersionIfDefs lines cs).
  (case [ let signalName = (upperCaseFirstChar . cFuncNameToHsName . signal_cname) signal in 
          (ss "  on".    ss signalName. sc ','.nl.
           ss "  after". ss signalName. sc ','
          ,maybe "" signaldoc_since doc)
        | (signal, doc) <- signals object (moduledoc_signals docs)] of
     [] -> id
     cs -> nl.nl.comment.ss "* Signals".nl.
           doVersionIfDefs lines cs)

genTodoItems :: Object -> ShowS
genTodoItems object =
  let varargsFunctions = 
        [ ss (constructor_cname constructor)
        | constructor <- object_constructors object
        , not $ null [ () | VarArgs <- constructor_parameters constructor] ]
       ++
        [ ss (method_cname method)
        | method <- object_methods object
        , not $ null [ () | VarArgs <- method_parameters method] ]
   in if null varargsFunctions
        then id
        else nl. comment. nl. comment.
             ss "TODO: the following varargs functions were not bound\n".
             lines (map (ss "-- * ".) varargsFunctions)

doVersionIfDefs :: ([ShowS] -> ShowS) -> [(ShowS, Since)] -> ShowS
doVersionIfDefs lines =
    lines
  . map (\group -> sinceVersion (snd (head group))
                                (lines (map fst group)))
  . groupBy (\(_,a) (_,b) -> a == b)
 
sinceVersion :: Since -> ShowS -> ShowS
sinceVersion [major,'.',minor] body =
  ss "#if GTK_CHECK_VERSION(". sc major. ss ",". sc minor. ss ",0)\n".
  body.
  ss "\n#endif"
sinceVersion _ body = body

--- NEW FILE: Docs.hs ---
module Docs (
  ApiDoc,
  ModuleDoc(..),
  noModuleDoc,
  DocSection(..),
  Since,
  FuncDoc(..),
  ParamDoc(..),
  PropDoc(..),
  SignalDoc(..),
  DocPara(..),
  DocParaSpan(..),
  extractDocumentation
  ) where

import qualified Text.XML.HaXml as Xml

-------------------------------------------------------------------------------
-- Types representing the content of the documentation XML file
-------------------------------------------------------------------------------
type ApiDoc = [ModuleDoc]

data ModuleDoc = ModuleDoc {
    moduledoc_name :: String,              -- these docs apply to this object
    moduledoc_altname :: String,           -- sometimes a better index entry
    moduledoc_summary :: String,           -- a one line summary
    moduledoc_description :: [DocPara],    -- the main description
    moduledoc_sections :: [DocSection],    -- any additional titled subsections
    moduledoc_hierarchy :: [DocParaSpan],  -- a tree of parent objects (as text)
    moduledoc_functions :: [FuncDoc],      -- documentation for each function
    moduledoc_properties :: [PropDoc],     -- documentation for each property
    moduledoc_signals :: [SignalDoc]       -- documentation for each signal
  }

noModuleDoc = ModuleDoc {
    moduledoc_name = "",
    moduledoc_altname = "",
    moduledoc_summary = "",
    moduledoc_description = [],
    moduledoc_sections = [],
    moduledoc_hierarchy = [],
    moduledoc_functions = [],
    moduledoc_properties = [],
    moduledoc_signals = []
  }

data DocSection = DocSection {
    section_title :: String,
    section_paras :: [DocPara]
  }

type Since = String

data FuncDoc = FuncDoc {
    funcdoc_name :: String,		-- C function name
    funcdoc_paragraphs :: [DocPara],	-- documentation markup
    funcdoc_params :: [ParamDoc],	-- parameter documentation
    funcdoc_since :: Since		-- which version of the api the
  }					-- function is available from, eg "2.4"

data ParamDoc = ParamDoc {
    paramdoc_name :: String,            -- parameter name or "Returns"
    paramdoc_paragraph :: [DocParaSpan] -- a simple paragraph
  }

data PropDoc = PropDoc {
    propdoc_name :: String,		-- property name
    propdoc_paragraphs :: [DocPara],	-- documentation markup
    propdoc_since :: Since		-- which version of the api the
  }					-- function is available from, eg "2.4"

data SignalDoc = SignalDoc {
    signaldoc_name :: String,		-- C signal name
    signaldoc_paragraphs :: [DocPara],	-- documentation markup
    signaldoc_params :: [ParamDoc],	-- parameter documentation
    signaldoc_since :: Since		-- which version of the api the
  }					-- function is available from, eg "2.4"

data DocPara =
    DocParaText [DocParaSpan]           -- an ordinary word-wrapped paragraph
  | DocParaProgram String               -- a verbatum section
  | DocParaTitle String                 -- a title to a subsection eg an example
  | DocParaDefItem [DocParaSpan] [DocParaSpan] -- a definition list item
  | DocParaListItem [DocParaSpan]       -- a itemisted list item

data DocParaSpan = DocText String       -- just simple text
                 | DocFuncXRef String   -- cross reference to a function name
                 | DocTypeXRef String   -- cross reference to a type name
                 | DocOtherXRef String  -- xref format not directly supported
                 | DocEmphasis String   -- emphasised text, usually italic
		 | DocLiteral String    -- some literal like numbers
		 | DocArg  String       -- function argument names


-------------------------------------------------------------------------------
-- extract functions to convert the doc xml file to the internal representation
-------------------------------------------------------------------------------
extractDocumentation :: Xml.Document -> ApiDoc
extractDocumentation (Xml.Document _ _ (Xml.Elem "apidoc" [] modules)) =
  map extractDocModule modules

extractDocModule :: Xml.Content -> ModuleDoc
extractDocModule (Xml.CElem (Xml.Elem "module" [] (moduleinfo:rest))) =
  let functions = [ e | e@(Xml.CElem (Xml.Elem "function" _ _)) <- rest ]
      properties = [ e | e@(Xml.CElem (Xml.Elem "property" _ _)) <- rest ]
      signals = [ e | e@(Xml.CElem (Xml.Elem "signal" _ _)) <- rest ]
  in (extractDocModuleinfo moduleinfo) {
    moduledoc_functions = map extractDocFunc functions,
    moduledoc_properties = map extractDocProp properties,
    moduledoc_signals = map extractDocSignal signals
  }

extractDocModuleinfo :: Xml.Content -> ModuleDoc
extractDocModuleinfo 
  (Xml.CElem (Xml.Elem "module-info" []
    [Xml.CElem (Xml.Elem "name" [] name)
    ,Xml.CElem (Xml.Elem "altname" [] altname)
    ,Xml.CElem (Xml.Elem "summary" [] summary)
    ,Xml.CElem (Xml.Elem "description" [] parasAndSections)
    ,Xml.CElem (Xml.Elem "object-hierarchy" [] objHierSpans)]
  )) = 
  let (paras, sections) = span (\elem ->
        case elem of
          Xml.CElem (Xml.Elem "section" _ _) -> False
          _ -> True) parasAndSections
   in ModuleDoc {
    moduledoc_name = Xml.verbatim name,
    moduledoc_altname = Xml.verbatim altname,
    moduledoc_summary = Xml.verbatim summary,
    moduledoc_description = concatMap extractDocPara paras,
    moduledoc_sections = map extractDocSection sections,
    moduledoc_hierarchy = map extractDocParaSpan objHierSpans,
    moduledoc_functions = undefined,
    moduledoc_properties = undefined,
    moduledoc_signals = undefined
  }

extractDocSection :: Xml.Content -> DocSection
extractDocSection
  (Xml.CElem (Xml.Elem "section" []
    (Xml.CElem (Xml.Elem "title" [] [Xml.CString _ title])
    :paras))) =
  DocSection {
    section_title = title,
    section_paras = concatMap extractDocPara paras
  }
extractDocSection other = error $ "extractDocSection: " ++ Xml.verbatim other

extractDocFunc :: Xml.Content -> FuncDoc
extractDocFunc
  (Xml.CElem (Xml.Elem "function" []
    [Xml.CElem (Xml.Elem "name" [] [Xml.CString _ name])
    ,Xml.CElem (Xml.Elem "since" [] since')
    ,Xml.CElem (Xml.Elem "doc" [] paras)
    ,Xml.CElem (Xml.Elem "params" [] params)]
  )) =
  let since = case since' of
                [] -> ""
		[Xml.CString _ since] -> since
   in FuncDoc {
        funcdoc_name = name,
	funcdoc_paragraphs = concatMap extractDocPara paras,
        funcdoc_params = map extractParamDoc params,
	funcdoc_since = since
      }

extractParamDoc :: Xml.Content -> ParamDoc
extractParamDoc 
  (Xml.CElem (Xml.Elem "param" []
    (Xml.CElem (Xml.Elem "name" [] [Xml.CString _ name])
    :spans))) =
  ParamDoc {
    paramdoc_name = name,
    paramdoc_paragraph = map extractDocParaSpan spans
  }

extractDocProp :: Xml.Content -> PropDoc
extractDocProp
  (Xml.CElem (Xml.Elem "property" []
    [Xml.CElem (Xml.Elem "name" [] [Xml.CString _ name])
    ,Xml.CElem (Xml.Elem "since" [] since')
    ,Xml.CElem (Xml.Elem "doc" [] paras)]
  )) =
  let since = case since' of
                [] -> ""
		[Xml.CString _ since] -> since
   in PropDoc {
        propdoc_name = name,
	propdoc_paragraphs = concatMap extractDocPara paras,
	propdoc_since = since
      }

extractDocSignal :: Xml.Content -> SignalDoc
extractDocSignal
  (Xml.CElem (Xml.Elem "signal" []
    [Xml.CElem (Xml.Elem "name" [] [Xml.CString _ name])
    ,Xml.CElem (Xml.Elem "since" [] since')
    ,Xml.CElem (Xml.Elem "doc" [] paras)
    ,Xml.CElem (Xml.Elem "params" [] params)]
  )) =
  let since = case since' of
                [] -> ""
		[Xml.CString _ since] -> since
   in SignalDoc {
        signaldoc_name = name,
	signaldoc_paragraphs = concatMap extractDocPara paras,
        signaldoc_params = map extractParamDoc params,
	signaldoc_since = since
      }

extractDocPara :: Xml.Content -> [DocPara]
extractDocPara (Xml.CElem elem@(Xml.Elem "para" [] _)) =
  case Xml.xmlUnEscape Xml.stdXmlEscaper elem of
    (Xml.Elem _ [] spans) -> extractDocPara' spans
extractDocPara (Xml.CElem (Xml.Elem "programlisting" _ content)) =
  let listing = concat [ str | (Xml.CString _ str) <- content ] in
  [DocParaProgram listing]
extractDocPara (Xml.CElem (Xml.Elem "example" _
                 (Xml.CElem (Xml.Elem "title" [] [Xml.CString _ title])
                 :content) )) =
  [DocParaTitle title] ++ concatMap extractDocPara content 
extractDocPara other = error $ "extractDocPara: " ++ Xml.verbatim other

extractDocPara' :: [Xml.Content] -> [DocPara]
extractDocPara' = reconstructParas [] . map extractDocParaOrSpan
  where reconstructParas :: [DocParaSpan] -> [Either DocParaSpan DocPara] -> [DocPara]
        reconstructParas []    [] = []
        reconstructParas spans [] = [DocParaText (reverse spans)]
        reconstructParas spans (Left  span:rest) = reconstructParas (span:spans) rest
        reconstructParas []    (Right para:rest) = para : reconstructParas [] rest
        reconstructParas spans (Right para:rest) = DocParaText (reverse spans)
                                                 : para : reconstructParas [] rest

extractDocParaOrSpan :: Xml.Content -> Either DocParaSpan DocPara 
extractDocParaOrSpan (Xml.CElem (Xml.Elem "listitem" [] content)) =
  Right $ DocParaListItem (map extractDocParaSpan content)
extractDocParaOrSpan (Xml.CElem (Xml.Elem "definition" []
                       (Xml.CElem (Xml.Elem "term" [] term)
                       :content))) =
  Right $ DocParaDefItem (map extractDocParaSpan term) (map extractDocParaSpan content)
extractDocParaOrSpan (Xml.CElem (Xml.Elem "programlisting" _ content)) =
  let listing = concat [ str | (Xml.CString _ str) <- content ] in
  Right $ DocParaProgram listing
extractDocParaOrSpan content@(Xml.CElem   _  ) = Left $ extractDocParaSpan content
extractDocParaOrSpan content@(Xml.CString _ _) = Left $ extractDocParaSpan content
extractDocParaOrSpan other = error $ "extractDocParaOrSpan: " ++ Xml.verbatim other

extractDocParaSpan :: Xml.Content -> DocParaSpan
extractDocParaSpan (Xml.CString _ text) = DocText text
extractDocParaSpan (Xml.CElem (Xml.Elem tag [] content)) =
  let text = concat [ str | (Xml.CString _ str) <- content ] in
  case tag of
    "xref-func"  -> DocFuncXRef text
    "xref-type"  -> DocTypeXRef text
    "xref-other" -> DocOtherXRef text
    "emphasis"   -> DocEmphasis text
    "literal"    -> DocLiteral text
    "arg"        -> DocArg text
    other -> error $ "extractDocParaSpan: other tag " ++ tag

extractDocParaSpan other@(Xml.CRef (Xml.RefEntity entity)) = DocText (Xml.verbatim other)
extractDocParaSpan other = error $ "extractDocParaSpan: " ++ Xml.verbatim other