Ticket #215: submission_20120929_ghc-7.4.1.patch

(a) /dev/null vs. (b) b/.gitignore

@@ +1 @@
+dist
+*~
+.*.sw?
+.viminfo

(a) /dev/null vs. (b) b/haddock-rebuild-vimhelp.sh

@@ +1 @@
+#! /bin/bash 
+
+# Script to rebuild the vimhelp from the list of installed packages
+
+workDir="$PWD/temp"
+HADDOCK="$PWD/haddock/dist/build/haddock/haddock"
+
+
+# set the language to US english, UTF-8, to handle unicode correctly
+export LANG=en_US.UTF-8
+
+# Check for the required tools
+test_for_program() {
+  prgName=$1
+  command -v $prgName > /dev/null 2>&1
+  [ $? -ne 0 ] || return 0
+  echo "Required program $prgName not found"
+  exit 1
+}
+
+test_for_program 'ghc-pkg'
+test_for_program 'cabal'
+test_for_program 'vim'
+
+# Get the list of installed packages
+instPkg=`ghc-pkg list --simple-output --names-only`
+
+# Process the packages
+workList=''
+for pkg in $instPkg; do
+  # Get the latest version of package
+  latestPkg=`ghc-pkg latest $pkg`
+
+  # Check for hidden packages
+  isExposed=`ghc-pkg field $latestPkg exposed | cut -d ' ' -f 2 | head -1`
+  # if [ $isExposed == 'True' ]; then
+    echo -n "Checking for package $latestPkg ... "
+
+    # Download the package using cabal
+    cabal fetch --no-dependencies $latestPkg > /dev/null 2>&1
+
+    if [ $? -eq 0 ] ; then
+      workList="$workList $pkg"
+      echo "OK"
+    else
+      echo "ignored"
+    fi
+  # else
+  #   echo "Package $pkg is hidden"
+  # fi
+done
+
+# workList='digest ghc-paths ghc-paths base64-bytestring extensible-exceptions zip-archive transformers array blaze-builder citeproc-hs syb utf8-string containers blaze-html json highlighting-kate hpc binary zlib texmath bytestring text tagsoup regex-compat regex-base regex-pcre-builtin regex-posix old-locale random old-time html pretty haskell-src process directory haskell98 deepseq temporary filepath time HUnit xml pandoc-types pandoc Cabal hscolour mtl GLUT stm OpenGL network QuickCheck unix template-haskell haddock parallel parsec base hs-bibutils fgl xhtml xhtml cgi HTTP'
+
+workList=`(for w in $workList; do echo $w; done) | sort -u`
+
+versionList=`(for w in $workList; do ghc-pkg latest $w; done)`
+
+# Unpack all the packages
+rm -Rf $workDir
+cabal unpack --destdir=$workDir/src $versionList
+
+# For each package, run haddock and make it generate the vimhelp info
+docDir="/home/lars/.vim/doc"
+mkdir -p $docDir
+for pkg in $workList; do
+  versionPkg=`ghc-pkg latest $pkg`
+
+  # Generating the docs
+  (
+    cd $workDir/src/$versionPkg
+    cabal configure
+    cabal haddock --with-haddock=$HADDOCK --haddock-options="--vimhelp"
+  )
+  # Reading the modules and copying them
+  modDocDir="$workDir/src/$versionPkg/dist/doc/html/$pkg"
+  modList="$modDocDir/vimhelp_modules.txt"
+  for mod in `cat $modList`; do
+    cp $modDocDir/${mod}.txt $docDir/haddock_${mod}.txt
+  done
+done
+
+# Rebuild the helptags
+vim --cmd "helptags $docDir" --cmd quit
+

haddock.cabal

@@ -127 +127 @@
     Haddock.Backends.Xhtml.Types
     Haddock.Backends.Xhtml.Utils
     Haddock.Backends.LaTeX
+    Haddock.Backends.VimHelp
+    Haddock.Backends.VimHelp.Markup
+    Haddock.Backends.VimHelp.Utils
+    Haddock.Backends.VimHelp.Decl
     Haddock.Backends.HaddockDB
     Haddock.Backends.Hoogle
     Haddock.ModuleTree

(a) /dev/null vs. (b) b/src/Haddock/Backends/VimHelp.hs

@@ +1 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.VimHelp
+-- Copyright   :  (c) Lars Krueger 2012
+-- License     :  BSD-like
+--
+-- Maintainer  :  lars_e_krueger@gmx.de
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.VimHelp (
+  ppVimHelp
+) where
+
+import Haddock.Backends.VimHelp.Decl
+import Haddock.Backends.VimHelp.Markup
+import Haddock.Backends.VimHelp.Utils
+
+import Haddock.GhcUtils
+import Haddock.Types
+
+import Control.Monad
+import System.Directory
+import System.FilePath
+
+
+-- | Generate vim help files from interfaces.
+ppVimHelp :: [Interface]
+          -> FilePath                     -- destination directory
+          -> IO ()
+ppVimHelp visible_ifaces odir = do
+  createDirectoryIfMissing True odir
+  -- Write module index for haddock-rebuild-vimhelp.sh
+  let mdlNameList = map (moduleString . ifaceMod) visible_ifaces
+  writeFile (odir </> "vimhelp_modules.txt") $ unlines mdlNameList
+  -- Write the module help files
+  forM_ visible_ifaces $ \iface -> do
+      let (ifaceTxt,modName)= ppModuleText iface
+      writeFile (odir </> (modName ++ ".txt")) ifaceTxt
+
+
+-- | Render the text of this module
+ppModuleText :: Interface -> (String,String)
+ppModuleText iface = 
+  let mdl = ifaceMod iface
+      modName = moduleString mdl
+      txt = [ ppRef $ "haddock_" ++ modName ++ ".txt"
+            , MiNonBreakable " Haddock documentation"
+            ] 
+            ++ modInfotxt
+            ++ ppRuler '='
+            ++ [MiLineBreak]
+            ++ maybeDocSection (ifaceRnDoc iface)
+            ++ [MiLineBreak]
+            ++ concatMap docExpIt (ifaceRnExportItems iface)
+            ++ [ MiPushIndent0
+               , MiLineBreak
+               , MiLineBreak
+               , MiNonBreakable "vim:tw=78:fo=tcq2:isk=!-~,^*,^\\|,^\\\":ts=8:ft=help:norl:" ]
+  in ( ppRender txt , modName)
+  where
+  modInfo = ifaceInfo iface
+  modInfotxt = concat 
+    [ maybeTab "Portability: " $ hmi_portability modInfo
+    , maybeTab "Stability:   " $ hmi_stability modInfo
+    , maybeTab "Maintainer:  " $ hmi_maintainer modInfo
+    ]
+
+  maybeTab :: String -> Maybe String -> Markup
+  maybeTab _ (Nothing) = []
+  maybeTab a (Just b)  = [MiLineBreak, MiNonBreakable $ a ++ b]
+
+
+-- | ExportItem to Markup. 
+docExpIt :: ExportItem DocName -> Markup
+docExpIt (ExportDecl decl doc subdocs insts) = ppDecl decl doc insts subdocs
+docExpIt (ExportNoDecl y []) = [ppDocName y]
+docExpIt (ExportDoc d) = ppRenderDoc d
+
+docExpIt (ExportNoDecl y subs) 
+  = ppDocName y : parenList (map (\a -> [ppDocName a]) subs)
+
+docExpIt (ExportGroup lvl _ doc) 
+  = [ MiPushIndent0, MiLineBreak
+    , MiNonBreakable $ replicate lvl '*' ++ " "
+    ] 
+    ++ ppRenderDoc doc
+    ++ [MiIndent 2]
+
+docExpIt (ExportModule m) 
+  = [ MiNonBreakable "module "
+    , ppLink $ moduleString m
+    , MiLineBreak
+    ]

(a) /dev/null vs. (b) b/src/Haddock/Backends/VimHelp/Decl.hs

@@ +1 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.VimHelp.Decl
+-- Copyright   :  (c) Simon Marlow   2003-2006,
+--                    David Waern    2006-2009,
+--                    Mark Lentczner 2010
+--                    Lars Krueger   2012
+-- License     :  BSD-like
+--
+-- Maintainer  :  haddock@projects.haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- This is based on Haddock.Backends.Xhtml.Decl
+-----------------------------------------------------------------------------
+module Haddock.Backends.VimHelp.Decl (
+  ppDecl,
+) where
+
+
+import Haddock.Backends.VimHelp.Markup
+import Haddock.Backends.VimHelp.Utils
+
+import Haddock.GhcUtils
+import Haddock.Types
+
+import BasicTypes            ( IPName(..), Boxity(..) )
+import GHC
+import Name
+import Outputable            ( ppr, showSDoc, Outputable )
+
+import           Control.Monad         ( join )
+import qualified Data.Map as Map
+import           Data.Maybe
+import           Data.List
+
+
+forallSymbol :: MarkupItem
+forallSymbol = MiNonBreakable "forall"
+
+
+-- | Generate markup for a declaration.
+ppDecl :: LHsDecl DocName 
+       -> DocForDecl DocName 
+       -> [DocInstance DocName] 
+       -> [(DocName, DocForDecl DocName)] 
+       -> Markup
+ppDecl (L _ decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of
+  TyClD d@(TyFamily {})          -> ppTyFam False mbDoc d
+  TyClD d@(TyData {})
+    | Nothing <- tcdTyPats d     -> ppDataDecl instances subdocs mbDoc d
+    | Just _  <- tcdTyPats d     -> ppDataInst mbDoc d
+  TyClD d@(TySynonym {})
+    | Nothing <- tcdTyPats d     -> ppTySyn (mbDoc, fnArgsDoc) d
+    | Just _  <- tcdTyPats d     -> ppTyInst False mbDoc d
+  TyClD d@(ClassDecl {})         -> ppClassDecl instances mbDoc subdocs d
+  SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig (mbDoc, fnArgsDoc) n t
+  ForD d                         -> ppFor (mbDoc, fnArgsDoc) d
+  InstD _                        -> []
+  _                              -> error "declaration not supported by ppDecl"
+
+
+-- | Generate markup for function signature.
+ppFunSig :: DocForDecl DocName -> DocName -> HsType DocName -> Markup
+ppFunSig doc docname typ =
+  ppTypeOrFunSig typ doc
+    (ppTypeSig docname typ, [ppBinder docname], [dcolon])
+
+
+ppTypeOrFunSig :: HsType DocName 
+               -> DocForDecl DocName 
+               -> (Markup, Markup, Markup) 
+               -> Markup
+ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep)
+  | Map.null argDocs = topDeclElem pref1 $ maybeDocSection doc
+  | otherwise = topDeclElem pref2 $ 
+      subArguments (do_args 0 sep typ) ++ maybeDocSection doc
+  where
+    argDoc n = Map.lookup n argDocs
+
+    do_largs n leader (L _ t) = do_args n leader t
+    do_args :: Int -> Markup -> HsType DocName -> [SubDecl]
+    do_args n leader (HsForAllTy Explicit tvs lctxt ltype)
+      = (leader <+>
+          ((forallSymbol: ppTyVars tvs) ++ [dot]) <+>
+          ppLContextNoArrow lctxt,
+          Nothing, [])
+        : do_largs n [darrow] ltype
+    do_args n leader (HsForAllTy Implicit _ lctxt ltype)
+      | not (null (unLoc lctxt))
+      = (leader <+> ppLContextNoArrow lctxt,
+          Nothing, [])
+        : do_largs n [darrow] ltype
+      -- if we're not showing any 'forall' or class constraints or
+      -- anything, skip having an empty line for the context.
+      | otherwise
+      = do_largs n leader ltype
+    do_args n leader (HsFunTy lt r)
+      = (leader <+> ppLFunLhType lt, argDoc n, [])
+        : do_largs (n+1) [arrow] r
+    do_args n leader t
+      = [(leader <+> ppType t, argDoc n, [])]
+
+
+ppTyVars :: [LHsTyVarBndr DocName] -> Markup
+ppTyVars tvs = intercalate [space] $ map ppTyName (tyvarNames tvs)
+
+
+tyvarNames :: [LHsTyVarBndr DocName] -> [Name]
+tyvarNames = map (getName . hsTyVarName . unLoc)
+
+
+ppFor :: DocForDecl DocName -> ForeignDecl DocName -> Markup
+ppFor doc (ForeignImport (L _ name) (L _ typ) _) = ppFunSig doc name typ
+ppFor _ _ = error "ppFor"
+
+
+-- we skip type patterns for now
+ppTySyn :: DocForDecl DocName -> TyClDecl DocName -> Markup
+ppTySyn doc (TySynonym (L _ name) ltyvars _ ltype) = 
+  ppTypeOrFunSig (unLoc ltype) doc (full, hdr, [space,equals])
+  where
+    hdr  = [MiNonBreakable "type ", ppBinder name, MiSpaceBeforeLetter] 
+           ++ 
+           ppTyVars ltyvars
+    full = hdr <+> [equals] <+> ppLType ltype
+ppTySyn _ _ = error "declaration not supported by ppTySyn"
+
+
+ppTypeSig :: DocName -> HsType DocName  -> Markup
+ppTypeSig nm ty =
+    [ppBinder nm, space, dcolon] <+> ppType ty
+
+
+ppName :: Name -> Markup
+ppName n = [MiNonBreakable $ getOccString n]
+
+
+ppTyName :: Name -> Markup
+ppTyName name
+  | isNameSym name = parens (ppName name)
+  | otherwise = ppName name
+
+
+--------------------------------------------------------------------------------
+-- * Type families
+--------------------------------------------------------------------------------
+
+
+ppTyFamHeader :: Bool -> TyClDecl DocName -> Markup
+ppTyFamHeader associated decl =
+  (case tcdFlavour decl of
+     TypeFamily
+       | associated -> [MiNonBreakable "type"]
+       | otherwise  -> [MiNonBreakable "type family"]
+     DataFamily
+       | associated -> [MiNonBreakable "data"]
+       | otherwise  -> [MiNonBreakable "data family"]
+  ) <+>
+  ppTyClBinderWithVars decl <+>
+  case tcdKind decl of
+    Just kind -> [dcolon,space] ++ ppKind kind
+    Nothing -> []
+
+
+ppTyFam :: Bool -> Maybe (Doc DocName) -> TyClDecl DocName -> Markup
+ppTyFam associated mbDoc decl = 
+  header_ ++ maybeDocSection mbDoc ++ instancesBit
+  where
+    header_ = ppTyFamHeader associated decl
+    instancesBit = ppInstances instances 
+    -- TODO: get the instances
+    instances = []
+
+
+--------------------------------------------------------------------------------
+-- * Indexed data types
+--------------------------------------------------------------------------------
+
+
+ppDataInst :: a
+ppDataInst = undefined
+
+
+--------------------------------------------------------------------------------
+-- * Indexed types
+--------------------------------------------------------------------------------
+
+
+ppTyInst :: Bool 
+         -> Maybe (Doc DocName) 
+         -> TyClDecl DocName 
+         -> Markup
+ppTyInst associated mbDoc decl = header_ ++ maybeDocSection mbDoc
+  where
+    docname = tcdName decl
+    header_ = topDeclElem [ppBinder docname] (ppTyInstHeader associated decl)
+
+
+ppTyInstHeader :: Bool -> TyClDecl DocName -> Markup
+ppTyInstHeader _ decl =
+  MiNonBreakable "type instance " : ppAppNameTypes (tcdName decl) typeArgs
+  where
+    typeArgs = map unLoc . fromJust . tcdTyPats $ decl
+
+
+--------------------------------------------------------------------------------
+-- * Associated Types
+--------------------------------------------------------------------------------
+
+
+ppAssocType :: DocForDecl DocName -> LTyClDecl DocName -> Markup
+ppAssocType doc (L _ decl) =
+  case decl of
+    TyFamily  {} -> ppTyFam True (fst doc) decl
+    TySynonym {} -> ppTySyn doc decl
+    _            -> error "declaration type not supported by ppAssocType"
+
+
+--------------------------------------------------------------------------------
+-- * TyClDecl helpers
+--------------------------------------------------------------------------------
+
+
+-- | Print a type family / newtype / data / class binder and its variables 
+ppTyClBinderWithVars :: TyClDecl DocName -> Markup
+ppTyClBinderWithVars decl =
+  ppAppDocNameNames (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)
+
+
+--------------------------------------------------------------------------------
+-- * Type applications
+--------------------------------------------------------------------------------
+
+
+-- | Print an application of a DocName and a list of HsTypes
+ppAppNameTypes :: DocName -> [HsType DocName] -> Markup
+ppAppNameTypes n ts =
+    ppTypeApp n ts ppDocName ppParendType
+
+
+-- | Print an application of a DocName and a list of Names 
+ppAppDocNameNames :: DocName -> [Name] -> Markup
+ppAppDocNameNames n ns =
+  ppTypeApp n ns ppBinder ppTyName
+
+
+-- | General printing of type applications
+ppTypeApp :: DocName 
+          -> [a] 
+          -> (DocName -> MarkupItem) 
+          -> (a -> Markup) 
+          -> Markup
+ppTypeApp n (t1:t2:rest) ppDN ppT
+  | operator, not . null $ rest = 
+    parens $ opApp <+> intercalate [space] (map ppT rest)
+  | operator                    = opApp
+  where
+    operator = isNameSym . getName $ n
+    opApp = ppT t1 <+> [ppDN n] <+> ppT t2
+
+ppTypeApp n ts ppDN ppT = 
+  [ppDN n] <+> intercalate [space] (map ppT ts)
+
+
+-------------------------------------------------------------------------------
+-- * Contexts
+-------------------------------------------------------------------------------
+
+
+ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Markup
+ppLContext        = ppContext        . unLoc
+ppLContextNoArrow = ppContextNoArrow . unLoc
+
+
+ppContextNoArrow :: HsContext DocName -> Markup
+ppContextNoArrow []   = []
+ppContextNoArrow cxt  = ppHsContext (map unLoc cxt)
+
+
+ppContextNoLocs :: [HsPred DocName] -> Markup
+ppContextNoLocs []  = []
+ppContextNoLocs cxt = ppHsContext cxt <+> [darrow]
+
+
+ppContext :: HsContext DocName -> Markup
+ppContext cxt = ppContextNoLocs (map unLoc cxt)
+
+
+ppHsContext :: [HsPred DocName] -> Markup
+ppHsContext []  = []
+ppHsContext [p] = ppPred p
+ppHsContext cxt = parenList (intersperse [space] $ map ppPred cxt)
+
+
+ppPred :: HsPred DocName -> Markup
+ppPred (HsClassP n ts) = ppAppNameTypes n (map unLoc ts)
+ppPred (HsEqualP t1 t2) = ppLType t1 <+> [MiNonBreakable "~"] <+> ppLType t2
+ppPred (HsIParam (IPName n) t) = 
+  [MiNonBreakable "?", ppDocName n, space, dcolon] <+> ppLType t
+
+
+-------------------------------------------------------------------------------
+-- * Class declarations
+-------------------------------------------------------------------------------
+
+
+ppClassHdr :: Located [LHsPred DocName] 
+           -> DocName
+           -> [Located (HsTyVarBndr DocName)] 
+           -> [Located ([DocName], [DocName])]
+           -> Markup
+ppClassHdr lctxt n tvs fds =
+  [MiNonBreakable "class"]
+  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt else [])
+  <+> ppAppDocNameNames n (tyvarNames tvs)
+  <+> ppFds fds
+
+
+ppFds :: [Located ([DocName], [DocName])] -> Markup
+ppFds fds =
+  if null fds 
+     then [] 
+     else [ MiNonBreakable "|", space] 
+          ++ intersperse comma (concatMap (fundep . unLoc) fds)
+  where
+  fundep (vars1,vars2) = map ppDocName vars1 
+                         <+> [arrow] 
+                         <+> map ppDocName vars2
+
+
+ppClassDecl :: [DocInstance DocName]
+            -> Maybe (Doc DocName) 
+            -> [(DocName, DocForDecl DocName)]
+            -> TyClDecl DocName 
+            -> Markup
+ppClassDecl instances mbDoc subdocs
+        (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) = 
+  classheader 
+  ++ maybeDocSection mbDoc
+  ++ atBit 
+  ++ methodBit  
+  ++ instancesBit
+  where
+    classheader
+      | null lsigs = hdr 
+      | otherwise  = hdr ++ [MiNonBreakable " where"]
+
+    hdr = ppClassHdr lctxt (unLoc lname) ltyvars lfds
+
+    atBit = subAssociatedTypes [ ppAssocType doc at
+                      | at <- ats
+                      , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
+
+    methodBit = subMethods [ ppFunSig doc n typ
+                      | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
+                      , let doc = lookupAnySubdoc n subdocs ]
+
+    instancesBit = ppInstances instances
+
+ppClassDecl _ _ _ _ = error "declaration type not supported by ppShortClassDecl"
+
+
+ppInstances :: [DocInstance DocName] -> Markup
+ppInstances instances = subInstances (map instDecl instances)
+  where
+  instDecl :: DocInstance DocName -> SubDecl
+  instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
+  instHead ([],   n, ts) = ppAppNameTypes n ts
+  instHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAppNameTypes n ts
+
+
+lookupAnySubdoc :: (Eq name1) =>
+                   name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2
+lookupAnySubdoc n subdocs = fromMaybe noDocForDecl (lookup n subdocs)
+
+
+-------------------------------------------------------------------------------
+-- * Data & newtype declarations
+-------------------------------------------------------------------------------
+
+
+ppDataDecl :: [DocInstance DocName] 
+           -> [(DocName, DocForDecl DocName)] 
+           -> Maybe (Doc DocName) 
+           -> TyClDecl DocName 
+           -> Markup
+ppDataDecl instances subdocs mbDoc dataDecl = 
+  topDeclElem header_ $ maybeDocSection mbDoc ++ constrBit ++ instancesBit  
+  where
+    cons      = tcdCons dataDecl
+    resTy     = (con_res . unLoc . head) cons
+
+    header_ = ppDataHeader dataDecl
+             ++ [whereBit]
+
+    whereBit
+      | null cons = MiNothing
+      | otherwise = case resTy of
+        ResTyGADT _ -> MiNonBreakable "where"
+        _ -> MiNothing
+
+    constrBit = subConstructors 
+      (map (ppSideBySideConstr subdocs) cons)
+
+    instancesBit = ppInstances instances
+
+
+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax
+ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Markup
+ppConstrHdr forAllFlag tvs ctxt 
+ = (if null tvs then [] else ppForall)
+   ++
+   (if null ctxt then [] else ppContextNoArrow ctxt 
+        <+> [darrow, space])
+  where
+  ppForall = case forAllFlag of
+    Explicit -> 
+      [forallSymbol] 
+      <+> intercalate [space] (map ppName tvs) 
+      ++ [MiNonBreakable " . "]
+    Implicit -> []
+
+
+ppSideBySideConstr :: [(DocName, DocForDecl DocName)] 
+                   -> LConDecl DocName 
+                   -> SubDecl
+ppSideBySideConstr subdocs (L _ con) = (decl, mbDoc, fieldPart)
+ where
+    decl = case con_res con of
+      ResTyH98 -> case con_details con of
+        PrefixCon args ->
+          header_ ++ [ppBinderConstr occ] ++
+            concatMap (\a -> space:ppLParendType a)  args
+
+        RecCon _ -> header_ ++ [ppBinderConstr occ]
+
+        InfixCon arg1 arg2 ->
+          (header_ ++ ppLParendType arg1) ++ 
+            [ppBinder occ] ++
+            ppLParendType arg2
+
+      ResTyGADT resTy -> case con_details con of
+        -- prefix & infix could also use hsConDeclArgTys if it seemed to
+        -- simplify the code.
+        PrefixCon args -> doGADTCon args resTy
+        cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy
+        InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy
+
+    fieldPart = case con_details con of
+        RecCon fields -> [doRecordFields fields]
+        _ -> []
+
+    doRecordFields fields = subFields 
+      (map (ppSideBySideField subdocs ) fields)
+    doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Markup
+    doGADTCon args resTy =
+      [ppBinderConstr occ, space, dcolon, space] ++
+        (ppForAll forAllFlag ltvs (con_cxt con) ++
+                  ppLType (foldr mkFunTy resTy args) )
+
+    header_     = ppConstrHdr forAllFlag tyVars context
+    occ         = unLoc . con_name $ con
+    ltvs        = con_qvars con
+    tyVars      = tyvarNames (con_qvars con)
+    context     = unLoc (con_cxt con)
+    forAllFlag  = con_explicit con
+    -- don't use "con_doc con", in case it's reconstructed from a .hi file,
+    -- or also because we want Haddock to do the doc-parsing, not GHC.
+    -- 'join' is in Maybe.
+    mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs
+    mkFunTy a b = noLoc (HsFunTy a b)
+
+
+ppSideBySideField :: [(DocName, DocForDecl DocName)] 
+                  -> ConDeclField DocName ->  SubDecl
+ppSideBySideField subdocs (ConDeclField (L _ name) ltype _) =
+  ([ppBinder name, space, dcolon, space] ++ ppLType ltype,
+    mbDoc,
+    [])
+  where
+    -- don't use cd_fld_doc for same reason we don't use con_doc above
+    mbDoc = join $ fmap fst $ lookup name subdocs
+
+
+-- | Print the LHS of a data\/newtype declaration.
+-- Currently doesn't handle 'data instance' decls or kind signatures
+ppDataHeader :: TyClDecl DocName -> Markup
+ppDataHeader decl 
+  | not (isDataDecl decl) = error "ppDataHeader: illegal argument"
+  | otherwise =
+    -- newtype or data
+    [if tcdND decl == NewType 
+        then MiNonBreakable "newtype" 
+        else MiNonBreakable "data"] 
+    -- context
+    <?> ppLContext (tcdCtxt decl)
+    -- T a b c ..., or a :+: b
+    <?> ppTyClBinderWithVars decl
+
+
+--------------------------------------------------------------------------------
+-- * Types and contexts
+--------------------------------------------------------------------------------
+
+
+ppKind :: Outputable a => a -> Markup
+ppKind k = [MiNonBreakable $ showSDoc (ppr k)]
+
+
+ -- Unpacked args is an implementation detail, so we just show the strictness
+ -- annotation
+ppBang :: HsBang -> Markup
+ppBang HsNoBang = []
+ppBang _        = [MiNonBreakable "!" ]
+
+
+tupleParens :: Boxity -> [Markup] -> Markup
+tupleParens Boxed   = parenList
+tupleParens Unboxed = ubxParenList
+
+
+--------------------------------------------------------------------------------
+-- * Rendering of HsType
+--------------------------------------------------------------------------------
+
+
+pRECTOP, pRECFUN, pRECOP, pRECCON :: Int
+
+pRECTOP = 0 :: Int   -- type in ParseIface.y in GHC
+pRECFUN = 1 :: Int   -- btype in ParseIface.y in GHC
+                      -- Used for LH arg of (->)
+pRECOP  = 2 :: Int   -- Used for arg of any infix operator
+                      -- (we don't keep their fixities around)
+pRECCON = 3 :: Int   -- Used for arg of type applicn:
+                        -- always parenthesise unless atomic
+
+maybeParen :: Int           -- Precedence of context
+           -> Int           -- Precedence of top-level operator
+           -> Markup -> Markup  -- Wrap in parens if (ctxt >= op)
+maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p
+                               | otherwise            = p
+
+
+ppLType, ppLParendType, ppLFunLhType :: Located (HsType DocName) -> Markup
+ppLType       y = ppType (unLoc y)
+ppLParendType y = ppParendType (unLoc y)
+ppLFunLhType  y = ppFunLhType (unLoc y)
+
+
+ppType, ppParendType, ppFunLhType :: HsType DocName -> Markup
+ppType       = pprMonoTy pRECTOP
+ppParendType = pprMonoTy pRECCON
+ppFunLhType  = pprMonoTy pRECFUN
+
+
+-- Drop top-level for-all type variables in user style
+-- since they are implicit in Haskell
+
+ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]
+         -> Located (HsContext DocName) -> Markup
+ppForAll expl tvs cxt
+  | show_forall = forall_part <+> ppLContext cxt 
+  | otherwise   = ppLContext cxt 
+  where
+    show_forall = not (null tvs) && is_explicit
+    is_explicit = case expl of {Explicit -> True; Implicit -> False}
+    forall_part = (forallSymbol : space : ppTyVars tvs) ++ [dot]
+
+
+pprMonoLty :: Int -> LHsType DocName -> Markup
+pprMonoLty ctxt_prec ty = pprMonoTy ctxt_prec (unLoc ty)
+
+
+pprMonoTy :: Int -> HsType DocName -> Markup
+pprMonoTy _         (HsListTy ty)        = brackets (pprMonoLty pRECTOP ty)
+pprMonoTy _         (HsBangTy b ty)      = ppBang b ++ ppLParendType ty
+pprMonoTy ctxt_prec (HsFunTy ty1 ty2)    = pprFunTy ctxt_prec ty1 ty2 
+pprMonoTy _         (HsTupleTy con tys)  = tupleParens con (map ppLType tys)
+pprMonoTy _         (HsPredTy p)         = parens (ppPred p)
+pprMonoTy _         (HsNumTy n)          = [MiNonBreakable (show n)] -- generics only
+pprMonoTy ctxt_prec (HsParTy ty)         = pprMonoLty ctxt_prec ty 
+pprMonoTy ctxt_prec (HsDocTy ty _)       = pprMonoLty ctxt_prec ty 
+pprMonoTy _         (HsSpliceTy {})      = error "pprMonoTy HsSpliceTy"
+pprMonoTy _         (HsQuasiQuoteTy {})  = error "pprMonoTy HsQuasiQuoteTy"
+pprMonoTy _         (HsCoreTy {})        = error "pprMonoTy HsCoreTy"
+pprMonoTy _         (HsRecTy {})         = error "pprMonoTy HsRecTy"
+
+pprMonoTy ctxt_prec (HsForAllTy expl tvs ctxt ty) = 
+  maybeParen ctxt_prec pRECFUN $
+    ppForAll expl tvs ctxt <+> pprMonoLty pRECTOP ty
+
+pprMonoTy _         (HsTyVar name)       = 
+  [ppDocName name, MiSpaceBeforeLetter]
+
+pprMonoTy _         (HsKindSig ty kind)  = 
+  parens (pprMonoLty pRECTOP ty <+> [dcolon] <+> ppKind kind)
+
+pprMonoTy _         (HsPArrTy ty)        = 
+  pabrackets (pprMonoLty pRECTOP ty)
+
+pprMonoTy ctxt_prec (HsAppTy fun_ty arg_ty) = 
+  maybeParen ctxt_prec pRECCON $
+    pprMonoLty pRECFUN fun_ty ++ pprMonoLty pRECCON arg_ty
+
+pprMonoTy ctxt_prec (HsOpTy ty1 op ty2) = 
+  maybeParen ctxt_prec pRECFUN $
+    pprMonoLty pRECOP ty1 <+> ppr_op <+> pprMonoLty pRECOP ty2 
+  where
+  ppr_op = if not (isSymOcc occName) 
+              then quote (ppLDocName op) 
+              else ppLDocName op
+  occName = nameOccName . getName . unLoc $ op
+
+
+pprFunTy :: Int -> LHsType DocName -> LHsType DocName -> Markup
+pprFunTy ctxt_prec ty1 ty2 = 
+  let p1 = pprMonoLty pRECFUN ty1 
+      p2 = pprMonoLty pRECTOP ty2 
+  in maybeParen ctxt_prec pRECFUN $ p1 <+> [arrow] <+> p2
+
+
+ppLDocName :: Located DocName -> Markup
+ppLDocName (L _ d) = [ppDocName d]
+
+
+--------------------------------------------------------------------------------
+-- * Declaration containers
+--------------------------------------------------------------------------------
+
+
+type SubDecl = (Markup, Maybe (Doc DocName), [Markup])
+
+
+divSubDecls :: String -> Maybe Markup -> Markup
+divSubDecls _ Nothing  = [MiLineBreak]
+divSubDecls c (Just m) = 
+  [ MiPushIndent
+  , MiIndent 2
+  , MiNonBreakable c
+  , MiPushIndent
+  , MiNextIndent 3
+  ] 
+  ++ m 
+  ++ 
+  [ MiPopIndent
+  , MiPopIndent
+  , MiLineBreak
+  ]
+
+
+subDlist :: [SubDecl] -> Maybe Markup
+subDlist [] = Nothing
+subDlist decls = Just $ concatMap subEntry decls
+  where
+  subEntry (decl, mdoc, subs) =
+    ppListItem True decl (maybeDocSection mdoc ++ concat subs)
+
+
+subBlock :: [Markup] -> Maybe Markup
+subBlock [] = Nothing
+subBlock hs = Just $ concatMap (\a -> MiLineBreak : a) hs
+
+
+subArguments :: [SubDecl] -> Markup
+subArguments = divSubDecls "Arguments" . subDlist
+
+
+subAssociatedTypes :: [Markup] -> Markup
+subAssociatedTypes = divSubDecls "Associated Types" . subBlock
+
+
+subConstructors :: [SubDecl] -> Markup
+subConstructors = divSubDecls "Constructors" . subDlist
+
+
+subFields :: [SubDecl] -> Markup
+subFields = divSubDecls "Fields" . subDlist
+
+
+subInstances :: [SubDecl] -> Markup
+subInstances = divSubDecls "Instances" . subDlist
+
+subMethods :: [Markup] -> Markup
+subMethods = divSubDecls "Methods" . subBlock
+
+
+-- a box for top level documented names
+topDeclElem :: Markup -> Markup -> Markup
+topDeclElem hd body = (MiPushIndent:(MiIndent 2:hd)) ++ body ++ [MiPopIndent]

(a) /dev/null vs. (b) b/src/Haddock/Backends/VimHelp/Markup.hs

@@ +1 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.VimHelp.Markup
+-- Copyright   :  (c) Lars Krueger 2012
+-- License     :  BSD-like
+--
+-- Maintainer  :  lars_e_krueger@gmx.de
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- Simple markup processing to generate good-looking text without 
+-- too much character fiddling in the actual output generation. 
+-- The module takes care of the line width, breaks text, indents items, etc.
+-----------------------------------------------------------------------------
+module Haddock.Backends.VimHelp.Markup
+( MarkupItem (..)
+, Markup
+, ppRender
+, ppRuler
+) where
+
+
+import Data.Char
+
+
+-- | Simple linear markup. Each item influences the render state.
+data MarkupItem
+  = MiBreakable String        -- ^ Normal text, will be word-wrapped
+  | MiNonBreakable String     -- ^ String to be treated as one character
+  | MiNothing                 -- ^ Empty string to cope with maybes
+  | MiParagraph               -- ^ A paragraph begins
+  | MiIndent Int              -- ^ Change the indentation
+  | MiLineBreak               -- ^ A mandatory linebreak
+  | MiPushIndent0             -- ^ Store the indent level on the stack, set to 0
+  | MiPushIndent              -- ^ Store the indent level on the stack
+  | MiNextIndent Int          -- ^ Set the indent of the next line
+  | MiPopIndent               -- ^ Get the former indent level from the stack
+  | MiSpaceBeforeLetter       -- ^ If the next item begins with a letter, put
+                              -- a space here
+  | MiVerbatim Bool           -- ^ Do not manipulate the text
+  deriving (Eq)
+
+
+-- | A list of markup items.
+type Markup = [MarkupItem]
+
+
+-- | The width of the page in characters
+ppTextWidth :: Int
+ppTextWidth = 80
+
+
+-- | Render state.
+data RenderState = RenderState
+    { rsIndent      :: Int          -- ^ Number of characters to indent
+    , rsChars       :: Int          -- ^ Number of characters in line
+    , rsIndStack    :: [Int]        -- ^ Indent stack
+    , rsSpcBefLet   :: Bool         -- ^ Space before letter flag
+    , rsVerbatim    :: Bool         -- ^ Do not manipulate space
+    }
+
+
+-- | Result of a render function.
+type RenderResult a = (RenderState,a)
+
+
+-- | Convert markup into a string for printing. The final render state is not
+-- made available, hence you can't pass it around.
+ppRender :: Markup -> String
+ppRender = concat . renderItems (RenderState 0 0 [] False False)
+
+
+-- | Render the items and update the state.
+renderItems :: RenderState -> Markup -> [String]
+renderItems _ [] = []
+renderItems rs (it:its) = 
+  let (nrs,mbLine) = render rs it
+  in case mbLine of
+          Nothing -> renderItems nrs its
+          Just l  -> l:renderItems nrs its
+
+
+-- | Begin a new line with correct identation and place the given string at 
+newLine :: RenderState -> String -> RenderResult String
+newLine rs s = 
+  let ls = length s
+  in ( rs { rsSpcBefLet = False
+          , rsChars = ls }
+     , "\n" ++ replicate (rsIndent rs) ' ' ++ s
+     )
+
+
+-- | Append string, but do not break the line. Handle optional spaces.
+appendLine :: RenderState -> String -> RenderResult String
+appendLine rs str = 
+  let s = if rsSpcBefLet rs
+             then case str of
+                       c1:_ -> if canHazSpace c1
+                                  then ' ' : str
+                                  else str
+                       _ -> str
+             else str
+      ls = length s
+  in ( rs { rsChars = ls + rsChars rs
+          , rsSpcBefLet = False}
+     , s 
+     )
+  where
+  canHazSpace c = isLetter c || (c `elem` "*(|")
+
+
+-- | Append string, but open a new line if the string would not fit.
+appendWord :: RenderState -> String -> RenderResult String
+appendWord rs s = 
+  let ls = length s
+  in if (rsIndent rs + rsChars rs + ls) >= ppTextWidth
+       then newLine rs s
+       else appendLine rs s
+
+
+-- | Helper for output-generating markup items.
+just2 :: RenderResult a -> RenderResult (Maybe a)
+just2 (rs,a) = (rs, Just a)
+
+
+-- | Helper for state-changing markup items.
+nothing2 :: RenderState -> RenderResult (Maybe a)
+nothing2 rs = (rs,Nothing)
+
+
+-- | Render a single markup item to a single sting or just change the state.
+render :: RenderState -> MarkupItem -> RenderResult (Maybe String)
+render rs (MiNothing) = nothing2 rs
+render rs (MiSpaceBeforeLetter) = nothing2 $ rs { rsSpcBefLet = True }
+render rs (MiVerbatim v) = nothing2 $ rs { rsVerbatim = v }
+render rs (MiNonBreakable s) = just2 $ appendWord rs s
+render rs (MiParagraph) = just2 $ newLine rs "  "
+render rs (MiLineBreak) = just2 $ newLine (rs { rsSpcBefLet = False }) ""
+
+render rs (MiIndent ind) 
+  = just2 $ newLine 
+      (rs 
+        { rsSpcBefLet = False
+        , rsIndent = max 0 $ rsIndent rs + ind }
+      ) 
+      ""
+
+-- | Linebreak the string or copy if verbatim is on. Since we need to pass the
+-- render state through it and we need the final render state as a return
+-- value, this works with an intermediate list of (RenderState,String) tuples.
+-- Since most items here are short, this should not result in much memory
+-- overhead
+render rs (MiBreakable s) = 
+  -- switch functions for verbatim mode
+  let (wrds,aw,al,alp) = 
+        if rsVerbatim rs 
+          then (lines, appendLine, newLine, "")
+          else (words, appendWord, appendLine, " ")
+      rs_lns = mapState (processWord aw al alp) rs $ wrds s
+  in case rs_lns of
+          [] -> nothing2 rs
+          lns -> just2 (fst $ last lns, concatMap snd lns)
+  where
+  processWord aw al alp rs1 w
+    = let (rs2,l1) = aw rs1 w
+          (rs3,l2) = al rs2 alp
+      in (rs3,l1++l2)
+
+  mapState _ _ [] = []
+  mapState fun rs1 [a] = [fun rs1 a]
+  mapState fun rs1 (a:as) = let rs2b@(rs2,_) = fun rs1 a
+                            in rs2b:mapState fun rs2 as
+
+render rs (MiPushIndent0) = nothing2 $
+  rs { rsSpcBefLet = False
+     , rsIndent = 0
+     , rsIndStack = rsIndent rs : rsIndStack rs}
+
+render rs (MiPushIndent) = nothing2 $
+  rs { rsIndStack = rsIndent rs : rsIndStack rs}
+
+render rs (MiNextIndent ind) = nothing2 $
+  rs { rsSpcBefLet = False
+      , rsIndent = max 0 $ rsIndent rs + ind }
+
+render rs (MiPopIndent) = nothing2 $
+  case rsIndStack rs of
+       [] -> rs
+       (i:rest) -> rs { rsSpcBefLet = False
+                      , rsIndent = i
+                      , rsIndStack = rest }
+
+
+-- | Draw a horizontal line over the whole text width.
+ppRuler :: Char -> Markup
+ppRuler c = 
+  [ MiPushIndent0
+  , MiNonBreakable $ replicate ppTextWidth c
+  , MiPopIndent
+  ]

(a) /dev/null vs. (b) b/src/Haddock/Backends/VimHelp/Utils.hs

@@ +1 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Haddock.Backends.VimHelp.Utils
+-- Copyright   :  (c) Lars Krueger 2012
+-- License     :  BSD-like
+--
+-- Maintainer  :  lars_e_krueger@gmx.de
+-- Stability   :  experimental
+-- Portability :  portable
+-----------------------------------------------------------------------------
+module Haddock.Backends.VimHelp.Utils
+( ppDocName
+, ppBinder
+, ppBinderConstr
+, ppPlainName
+, parenList
+, dcolon
+, parens
+, brackets
+, pabrackets
+, braces
+, (<+>)
+, (<?>)
+, dot
+, darrow
+, arrow
+, equals
+, space
+, comma
+, ubxParenList
+, ubxparens
+, maybeDocSection
+, maybeIndentedDocSection 
+, quote
+, ppRenderDoc
+, ppLink
+, ppRef
+, ppListItem
+) where
+
+import Haddock.Backends.VimHelp.Markup
+
+import Haddock.GhcUtils
+import Haddock.Types
+
+import Module
+import Name
+
+import Data.List
+import Text.Printf
+
+
+-- | Generate a link to something (similar to <href>)
+ppLink :: String -> MarkupItem
+ppLink s = MiNonBreakable $ "|" ++ s ++ "|"
+
+
+-- | Generate an anchor for something (similar to <a>)
+ppRef :: String -> MarkupItem
+ppRef s = MiNonBreakable $ "*" ++ s ++ "*"
+
+
+-- | Markup for a DocName. Tries to be smart about built-in things.
+ppDocName :: DocName -> MarkupItem
+ppDocName (Undocumented name) = MiNonBreakable $ getOccString name
+ppDocName (Documented name mdl) = 
+  if isBuiltinModule mdl
+     then MiNonBreakable nameStr
+     else ppLink $ mdlStr ++ "." ++ nameStr
+  where
+  mdlStr = moduleString mdl
+  nameStr = getOccString name
+
+
+-- | Check if module if built-in
+isBuiltinModule :: Module -> Bool
+isBuiltinModule mdl = modulePackageId mdl `elem`
+  [ primPackageId
+  , integerPackageId
+  , basePackageId
+  , rtsPackageId
+  , thPackageId
+  , dphSeqPackageId
+  , dphParPackageId
+  , mainPackageId
+  ]
+
+
+-- | Generate a reference to this DocName, if possible
+ppBinder :: DocName -> MarkupItem
+ppBinder (Undocumented n) = MiNonBreakable $ getOccString n
+ppBinder (Documented n m) = ppRef $ moduleString m ++ "." ++ getOccString n
+
+
+-- | Generate a reference to this DocName, if possible. Special case for
+-- constructors that may have the same name as their type.
+ppBinderConstr :: DocName -> MarkupItem
+ppBinderConstr (Undocumented n) = MiNonBreakable $ getOccString n
+ppBinderConstr (Documented n m) = ppRef $ 
+  "Constructor:" ++ moduleString m ++ "." ++ getOccString n
+
+
+-- | DocName to regular string.
+ppPlainName :: DocName -> MarkupItem
+ppPlainName (Undocumented n) = MiNonBreakable $ getOccString n
+ppPlainName (Documented n _) = MiNonBreakable $ getOccString n
+
+
+parenList :: [Markup] -> Markup
+parenList = parens . intercalate [comma]
+
+
+dcolon :: MarkupItem
+dcolon = MiNonBreakable "::"
+
+
+dot :: MarkupItem
+dot = MiNonBreakable "."
+
+
+darrow :: MarkupItem
+darrow = MiNonBreakable "=>"
+
+
+arrow :: MarkupItem
+arrow = MiNonBreakable "->"
+
+
+equals :: MarkupItem
+equals = MiNonBreakable "="
+
+
+space :: MarkupItem
+space = MiNonBreakable " "
+
+
+comma :: MarkupItem
+comma = MiNonBreakable ","
+
+
+ubxparens :: Markup -> Markup
+ubxparens       = enclose "(#"  "#)"
+
+
+dquote :: Markup -> Markup
+dquote          = enclose "''"  "''"
+
+
+quote :: Markup -> Markup
+quote           = enclose "'"  "'"
+
+
+parens :: Markup -> Markup
+parens          = enclose "("  ")"
+
+
+brackets :: Markup -> Markup
+brackets        = enclose "["  "]"
+
+
+pabrackets :: Markup -> Markup
+pabrackets      = enclose "[:" ":]"
+
+
+braces :: Markup -> Markup
+braces          = enclose "{"  "}"
+
+
+enclose :: String -> String -> Markup -> Markup
+enclose a b h = 
+  (MiNonBreakable a : makeNonBreakable h) ++ [MiNonBreakable b]
+  where
+  makeNonBreakable = map toNonBreakable
+  toNonBreakable :: MarkupItem -> MarkupItem
+  toNonBreakable (MiBreakable s) = MiNonBreakable s
+  toNonBreakable i = i
+
+
+infixr 8 <+>
+(<+>) :: Markup-> Markup-> Markup
+a <+> b = a ++ (MiNonBreakable " " : b)
+
+
+infixr 8 <?>
+(<?>) :: Markup-> Markup-> Markup
+a <?> b = a ++ (MiSpaceBeforeLetter : b)
+
+
+ubxParenList :: [Markup] -> Markup
+ubxParenList = ubxparens . intercalate [comma]
+
+
+maybeDocSection :: Maybe (Doc DocName) -> Markup
+maybeDocSection Nothing = []
+maybeDocSection (Just s) = ppRenderDoc s
+
+
+maybeIndentedDocSection :: Maybe (Doc DocName) -> Markup
+maybeIndentedDocSection Nothing = []
+maybeIndentedDocSection (Just s) = 
+  (MiPushIndent : MiIndent 2 : dropParagraph ( ppRenderDoc s))
+  ++ 
+  [MiPopIndent]
+
+
+ppRenderDoc :: Doc DocName -> Markup
+ppRenderDoc DocEmpty                = []
+ppRenderDoc (DocPic _)              = []
+ppRenderDoc (DocAppend a b)         = ppRenderDoc a ++ ppRenderDoc b
+ppRenderDoc (DocString s)           = [MiBreakable s]
+ppRenderDoc (DocParagraph d)        = MiParagraph:ppRenderDoc d
+ppRenderDoc (DocModule m)           = [ppLink m]
+ppRenderDoc (DocEmphasis d)         = ppRenderDoc d
+ppRenderDoc (DocMonospaced d)       = ppRenderDoc d
+ppRenderDoc (DocURL s)              = [MiNonBreakable s]
+ppRenderDoc (DocAName s)            = [MiNonBreakable s]
+
+ppRenderDoc (DocExamples ex)        = concatMap renderEx ex
+  where
+  renderEx :: Example -> Markup
+  renderEx (Example exm res) = 
+    beginCodeBlock
+    ++ [
+    MiNonBreakable (">>> " ++ exm),
+    MiLineBreak] 
+    ++ concatMap (\a -> [MiNonBreakable a, MiLineBreak]) res
+    ++ endCodeBlock
+
+ppRenderDoc (DocCodeBlock d)        = 
+  beginCodeBlock ++ ppRenderDoc d ++ endCodeBlock
+
+-- Show the first identifier only
+ppRenderDoc (DocIdentifier ds)      = [ppDocName $ head ds, MiSpaceBeforeLetter]
+
+ppRenderDoc (DocUnorderedList ds)   = 
+  ppList (ppListItemDoc False [MiNonBreakable "-"]) ds
+
+ppRenderDoc (DocOrderedList ds)     = 
+  ppList (\(d,i) -> ppListItemDoc False [MiNonBreakable $ printf "%2d." i] d) 
+  $ 
+  zip ds [(1::Int)..]
+
+ppRenderDoc (DocDefList ds)         = 
+  ppList (\(c,d) -> ppListItemDoc True (dquote (ppRenderDoc c)) d) ds
+
+
+ppList :: (a -> Markup) -> [a] -> Markup
+ppList f ds = concatMap f ds ++ [MiLineBreak]
+
+
+ppListItem :: Bool -> Markup -> Markup -> Markup
+ppListItem _ bull [] = 
+  [MiPushIndent,MiLineBreak,MiNextIndent 2] 
+  ++ bull 
+  ++ [MiPopIndent]
+ppListItem doBreak bull desc = 
+  [MiPushIndent,MiLineBreak,MiNextIndent 2] 
+  ++ bull 
+  ++ ((if doBreak then MiLineBreak else MiSpaceBeforeLetter):dropParagraph desc)
+  ++ [MiPopIndent]
+
+
+ppListItemDoc :: Bool -> Markup -> Doc DocName -> Markup
+ppListItemDoc doBreak bull desc = 
+  ppListItem doBreak bull $ dropParagraph $ ppRenderDoc desc
+
+
+dropParagraph :: Markup -> Markup
+dropParagraph = dropWhile (== MiParagraph)
+
+
+beginCodeBlock :: Markup
+beginCodeBlock = 
+    [ MiPushIndent0
+    , MiLineBreak
+    , MiNonBreakable ">" 
+    , MiPopIndent
+    , MiPushIndent0
+    , MiIndent 2
+    , MiLineBreak
+    , MiVerbatim True
+    ]
+
+
+endCodeBlock :: Markup
+endCodeBlock = 
+    [ MiVerbatim False
+    , MiPopIndent
+    , MiPushIndent0
+    , MiLineBreak
+    , MiNonBreakable "<"
+    , MiPopIndent
+    ]

src/Haddock/Options.hs

@@ -58 +58 @@
   | Flag_WikiModuleURL String
   | Flag_WikiEntityURL String
   | Flag_LaTeX
+  | Flag_VimHelp
   | Flag_LaTeXStyle String
   | Flag_Help
   | Flag_Verbosity String
@@ -101 +102 @@
       "output in HTML (XHTML 1.0)",
     Option []  ["latex"]  (NoArg Flag_LaTeX) "use experimental LaTeX rendering",
     Option []  ["latex-style"]  (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",
+    Option []  ["vimhelp"]  (NoArg Flag_VimHelp) "use experimental VIM help file rendering",
     Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
     Option []  ["hoogle"]     (NoArg Flag_Hoogle)
       "output for Hoogle",

src/Main.hs

@@ -21 +21 @@
 import Haddock.Backends.Xhtml
 import Haddock.Backends.Xhtml.Themes (getThemes)
 import Haddock.Backends.LaTeX
+import Haddock.Backends.VimHelp
 import Haddock.Backends.Hoogle
 import Haddock.Interface
 import Haddock.Lex
@@ -142 +143 @@
     renderStep flags packages ifaces
 
   else do
-    when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
+    when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX, Flag_VimHelp]) flags) $
       throwE "No input file(s)."
 
     -- Get packages supplied with --read-interface.
@@ -247 +248 @@
     ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style
                   libDir
 
+  when (Flag_VimHelp `elem` flags) $ 
+    ppVimHelp visibleIfaces odir
+
 
 -------------------------------------------------------------------------------
 -- * Reading and dumping interface files
@@ -386 +390 @@
   when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
         && Flag_LaTeX `elem` flags) $
     throwE "--latex cannot be used with --gen-index or --gen-contents"
+
+  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags)
+        && Flag_VimHelp `elem` flags) $
+    throwE "--vimhelp cannot be used with --gen-index or --gen-contents"
   where
     byeVersion = bye $
       "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n"

src/Haddock/Backends/VimHelp/Decl.hs

@@ -54 +54 @@
     | Nothing <- tcdTyPats d     -> ppTySyn (mbDoc, fnArgsDoc) d
     | Just _  <- tcdTyPats d     -> ppTyInst False mbDoc d
   TyClD d@(ClassDecl {})         -> ppClassDecl instances mbDoc subdocs d
-  SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig (mbDoc, fnArgsDoc) n t
+  SigD (TypeSig lnames (L _ t))  -> ppFunSig (mbDoc, fnArgsDoc) (map unLoc lnames) t
   ForD d                         -> ppFor (mbDoc, fnArgsDoc) d
   InstD _                        -> []
   _                              -> error "declaration not supported by ppDecl"
 
 
 -- | Generate markup for function signature.
-ppFunSig :: DocForDecl DocName -> DocName -> HsType DocName -> Markup
-ppFunSig doc docname typ =
-  ppTypeOrFunSig typ doc
-    (ppTypeSig docname typ, [ppBinder docname], [dcolon])
+ppFunSig :: DocForDecl DocName -> [DocName] -> HsType DocName -> Markup
+ppFunSig doc docnames typ =
+  concatMap (\docname -> 
+    ppTypeOrFunSig typ doc
+      (ppTypeSig docname typ, [ppBinder docname], [dcolon])
+    ) docnames
 
 
 ppTypeOrFunSig :: HsType DocName 
@@ -111 +113 @@
 
 
 ppFor :: DocForDecl DocName -> ForeignDecl DocName -> Markup
-ppFor doc (ForeignImport (L _ name) (L _ typ) _) = ppFunSig doc name typ
+ppFor doc (ForeignImport (L _ name) (L _ typ) _ _) = ppFunSig doc [name] typ
 ppFor _ _ = error "ppFor"
 
 
@@ -159 +161 @@
   ) <+>
   ppTyClBinderWithVars decl <+>
   case tcdKind decl of
-    Just kind -> [dcolon,space] ++ ppKind kind
+    Just kind -> [dcolon,space] ++ ppKind (unLoc kind)
     Nothing -> []
 
 
@@ -278 +280 @@
 ppContextNoArrow cxt  = ppHsContext (map unLoc cxt)
 
 
-ppContextNoLocs :: [HsPred DocName] -> Markup
+ppContextNoLocs :: [HsType DocName] -> Markup
 ppContextNoLocs []  = []
 ppContextNoLocs cxt = ppHsContext cxt <+> [darrow]
 
@@ -287 +289 @@
 ppContext cxt = ppContextNoLocs (map unLoc cxt)
 
 
-ppHsContext :: [HsPred DocName] -> Markup
+ppHsContext :: [HsType DocName] -> Markup
 ppHsContext []  = []
-ppHsContext [p] = ppPred p
-ppHsContext cxt = parenList (intersperse [space] $ map ppPred cxt)
-
-
-ppPred :: HsPred DocName -> Markup
-ppPred (HsClassP n ts) = ppAppNameTypes n (map unLoc ts)
-ppPred (HsEqualP t1 t2) = ppLType t1 <+> [MiNonBreakable "~"] <+> ppLType t2
-ppPred (HsIParam (IPName n) t) = 
-  [MiNonBreakable "?", ppDocName n, space, dcolon] <+> ppLType t
+ppHsContext [p] = ppType p
+ppHsContext cxt = parenList (intersperse [space] $ map ppType cxt)
 
 
 -------------------------------------------------------------------------------
@@ -305 +300 @@
 -------------------------------------------------------------------------------
 
 
-ppClassHdr :: Located [LHsPred DocName] 
+ppClassHdr :: Located [LHsType DocName] 
            -> DocName
            -> [Located (HsTyVarBndr DocName)] 
            -> [Located ([DocName], [DocName])]
@@ -504 +499 @@
 --------------------------------------------------------------------------------
 
 
-ppKind :: Outputable a => a -> Markup
-ppKind k = [MiNonBreakable $ showSDoc (ppr k)]
+ppKind :: HsKind DocName -> Markup
+ppKind k = pprMonoTy pRECTOP k
 
 
  -- Unpacked args is an implementation detail, so we just show the strictness
@@ -515 +510 @@
 ppBang _        = [MiNonBreakable "!" ]
 
 
-tupleParens :: Boxity -> [Markup] -> Markup
-tupleParens Boxed   = parenList
-tupleParens Unboxed = ubxParenList
+tupleParens :: HsTupleSort -> [Markup] -> Markup
+tupleParens _ = parenList
 
 
 --------------------------------------------------------------------------------
@@ -577 +571 @@
 pprMonoTy _         (HsBangTy b ty)      = ppBang b ++ ppLParendType ty
 pprMonoTy ctxt_prec (HsFunTy ty1 ty2)    = pprFunTy ctxt_prec ty1 ty2 
 pprMonoTy _         (HsTupleTy con tys)  = tupleParens con (map ppLType tys)
-pprMonoTy _         (HsPredTy p)         = parens (ppPred p)
-pprMonoTy _         (HsNumTy n)          = [MiNonBreakable (show n)] -- generics only
+-- pprMonoTy _         (HsPredTy p)         = parens (ppPred p)
+-- pprMonoTy _         (HsNumTy n)          = [MiNonBreakable (show n)] -- generics only
 pprMonoTy ctxt_prec (HsParTy ty)         = pprMonoLty ctxt_prec ty 
 pprMonoTy ctxt_prec (HsDocTy ty _)       = pprMonoLty ctxt_prec ty 
 pprMonoTy _         (HsSpliceTy {})      = error "pprMonoTy HsSpliceTy"

src/Haddock/Backends/VimHelp/Utils.hs

@@ -229 +229 @@
 ppRenderDoc (DocCodeBlock d)        = 
   beginCodeBlock ++ ppRenderDoc d ++ endCodeBlock
 
--- Show the first identifier only
-ppRenderDoc (DocIdentifier ds)      = [ppDocName $ head ds, MiSpaceBeforeLetter]
+ppRenderDoc (DocIdentifier d)      = [ppDocName d, MiSpaceBeforeLetter]
+ppRenderDoc (DocIdentifierUnchecked (mn,on))      = [MiNonBreakable $ moduleNameString mn ++ "." ++ occNameString on, MiSpaceBeforeLetter]
 
 ppRenderDoc (DocUnorderedList ds)   = 
   ppList (ppListItemDoc False [MiNonBreakable "-"]) ds

src/Haddock/Backends/VimHelp/Utils.hs

@@ -15 +15 @@
 , ppPlainName
 , parenList
 , dcolon
+, tilde
 , parens
 , brackets
 , pabrackets
@@ -114 +115 @@
 dcolon = MiNonBreakable "::"
 
 
+tilde :: MarkupItem
+tilde = MiNonBreakable "~"
+
+
 dot :: MarkupItem
 dot = MiNonBreakable "."
 

src/Haddock/Backends/VimHelp/Decl.hs

@@ -24 +24 @@
 import Haddock.GhcUtils
 import Haddock.Types
 
-import BasicTypes            ( IPName(..), Boxity(..) )
 import GHC
 import Name
-import Outputable            ( ppr, showSDoc, Outputable )
+import BasicTypes            ( ipNameName )
 
 import           Control.Monad         ( join )
 import qualified Data.Map as Map
@@ -330 +329 @@
             -> TyClDecl DocName 
             -> Markup
 ppClassDecl instances mbDoc subdocs
-        (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) = 
+        (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) = 
   classheader 
   ++ maybeDocSection mbDoc
   ++ atBit 
@@ -347 +346 @@
                       | at <- ats
                       , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]
 
-    methodBit = subMethods [ ppFunSig doc n typ
-                      | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs
-                      , let doc = lookupAnySubdoc n subdocs ]
+    methodBit = subMethods [ ppFunSig doc names typ
+                      | L _ (TypeSig lnames (L _ typ)) <- lsigs
+                      , let doc = lookupAnySubdoc (head names) subdocs
+                            names = map unLoc lnames]
 
     instancesBit = ppInstances instances
 
@@ -571 +571 @@
 pprMonoTy _         (HsBangTy b ty)      = ppBang b ++ ppLParendType ty
 pprMonoTy ctxt_prec (HsFunTy ty1 ty2)    = pprFunTy ctxt_prec ty1 ty2 
 pprMonoTy _         (HsTupleTy con tys)  = tupleParens con (map ppLType tys)
--- pprMonoTy _         (HsPredTy p)         = parens (ppPred p)
--- pprMonoTy _         (HsNumTy n)          = [MiNonBreakable (show n)] -- generics only
 pprMonoTy ctxt_prec (HsParTy ty)         = pprMonoLty ctxt_prec ty 
 pprMonoTy ctxt_prec (HsDocTy ty _)       = pprMonoLty ctxt_prec ty 
 pprMonoTy _         (HsSpliceTy {})      = error "pprMonoTy HsSpliceTy"
+#if __GLASGOW_HASKELL__ == 612
+pprMonoTy _         (HsSpliceTyOut {})   = error "pprMonoTy HsQuasiQuoteTy"
+#else
 pprMonoTy _         (HsQuasiQuoteTy {})  = error "pprMonoTy HsQuasiQuoteTy"
+#endif
 pprMonoTy _         (HsCoreTy {})        = error "pprMonoTy HsCoreTy"
 pprMonoTy _         (HsRecTy {})         = error "pprMonoTy HsRecTy"
+pprMonoTy _         (HsExplicitListTy _ tys) = quote $ brackets $ intercalate [comma] $ map ppLType tys
+pprMonoTy _         (HsExplicitTupleTy _ tys) = quote $ parenList $ map ppLType tys
+pprMonoTy _         (HsWrapTy {})        = error "ppr_mono_ty HsWrapTy"
+
+pprMonoTy ctxt_prec (HsEqTy ty1 ty2)
+  = maybeParen ctxt_prec pRECOP $
+    pprMonoLty pRECOP ty1 <+> [tilde] <+> pprMonoLty pRECOP ty2
 
 pprMonoTy ctxt_prec (HsForAllTy expl tvs ctxt ty) = 
   maybeParen ctxt_prec pRECFUN $
@@ -588 +597 @@
   [ppDocName name, MiSpaceBeforeLetter]
 
 pprMonoTy _         (HsKindSig ty kind)  = 
-  parens (pprMonoLty pRECTOP ty <+> [dcolon] <+> ppKind kind)
+  parens (pprMonoLty pRECTOP ty <+> [dcolon] <+> (ppKind $ unLoc kind))
 
 pprMonoTy _         (HsPArrTy ty)        = 
   pabrackets (pprMonoLty pRECTOP ty)
 
+pprMonoTy _         (HsIParamTy n ty)   = 
+  brackets $ [ppDocName (ipNameName n)] <+> [dcolon] <+> pprMonoLty pRECTOP ty
+
 pprMonoTy ctxt_prec (HsAppTy fun_ty arg_ty) = 
   maybeParen ctxt_prec pRECCON $
     pprMonoLty pRECFUN fun_ty ++ pprMonoLty pRECCON arg_ty
 
-pprMonoTy ctxt_prec (HsOpTy ty1 op ty2) = 
+pprMonoTy ctxt_prec (HsOpTy ty1 (_,op) ty2) = 
   maybeParen ctxt_prec pRECFUN $
     pprMonoLty pRECOP ty1 <+> ppr_op <+> pprMonoLty pRECOP ty2 
   where

src/Main.hs

@@ -218 +218 @@
 
   libDir   <- getHaddockLibDir flags
   prologue <- getPrologue flags
-  themes   <- getThemes libDir flags >>= either bye return
 
   when (Flag_GenIndex `elem` flags) $ do
+    themes   <- getThemes libDir flags >>= either bye return
     ppHtmlIndex odir title pkgStr
                 themes opt_contents_url sourceUrls' opt_wiki_urls
                 allVisibleIfaces pretty
     copyHtmlBits odir libDir themes
 
   when (Flag_GenContents `elem` flags) $ do
+    themes   <- getThemes libDir flags >>= either bye return
     ppHtmlContents odir title pkgStr
                    themes opt_index_url sourceUrls' opt_wiki_urls
                    allVisibleIfaces True prologue pretty opt_qualification
     copyHtmlBits odir libDir themes
 
   when (Flag_Html `elem` flags) $ do
+    themes   <- getThemes libDir flags >>= either bye return
     ppHtml title pkgStr visibleIfaces odir
                 prologue
                 themes sourceUrls' opt_wiki_urls

haddock-rebuild-vimhelp.sh

@@ -3 +3 @@
 # Script to rebuild the vimhelp from the list of installed packages
 
 workDir="$PWD/temp"
-HADDOCK="$PWD/haddock/dist/build/haddock/haddock"
 
+# try to detect haddock
+HADDOCK=
+
+try_haddock() {
+  [ "x$HADDOCK" == "x" ] || return 0
+  HADDOCK=$1
+  command -v $HADDOCK > /dev/null 2>&1
+  [ $? -ne 0 ] || return 0
+  HADDOCK=
+}
+
+try_haddock "$PWD/haddock/dist/build/haddock/haddock"
+try_haddock "$PWD/dist/build/haddock/haddock"
+try_haddock "haddock"
+
+if [ "x$HADDOCK" == "x" ]; then
+  echo "haddock not found"
+fi
 
 # set the language to US english, UTF-8, to handle unicode correctly
 export LANG=en_US.UTF-8
@@ -33 +50 @@
 
   # Check for hidden packages
   isExposed=`ghc-pkg field $latestPkg exposed | cut -d ' ' -f 2 | head -1`
-  # if [ $isExposed == 'True' ]; then
-    echo -n "Checking for package $latestPkg ... "
 
-    # Download the package using cabal
-    cabal fetch --no-dependencies $latestPkg > /dev/null 2>&1
+  # Download the package using cabal
+  echo -n "Checking for package $latestPkg ... "
+  cabal fetch --no-dependencies $latestPkg > /dev/null 2>&1
 
-    if [ $? -eq 0 ] ; then
-      workList="$workList $pkg"
-      echo "OK"
-    else
-      echo "ignored"
-    fi
-  # else
-  #   echo "Package $pkg is hidden"
-  # fi
+  if [ $? -eq 0 ] ; then
+    workList="$workList $pkg"
+    echo "OK"
+  else
+    echo "ignored"
+  fi
 done
 
 # workList='digest ghc-paths ghc-paths base64-bytestring extensible-exceptions zip-archive transformers array blaze-builder citeproc-hs syb utf8-string containers blaze-html json highlighting-kate hpc binary zlib texmath bytestring text tagsoup regex-compat regex-base regex-pcre-builtin regex-posix old-locale random old-time html pretty haskell-src process directory haskell98 deepseq temporary filepath time HUnit xml pandoc-types pandoc Cabal hscolour mtl GLUT stm OpenGL network QuickCheck unix template-haskell haddock parallel parsec base hs-bibutils fgl xhtml xhtml cgi HTTP'
@@ -70 +83 @@
   (
     cd $workDir/src/$versionPkg
     cabal configure
-    cabal haddock --with-haddock=$HADDOCK --haddock-options="--vimhelp"
+    cabal haddock --hoogle --with-haddock=$HADDOCK --haddock-options="--vimhelp"
+    if [ $? -ne 0 ] ; then
+      echo "cabal haddock failed. Wrong haddock version?"
+      exit 1
+    fi
   )
+  if [ $? -eq 0 ] ; then
   # Reading the modules and copying them
-  modDocDir="$workDir/src/$versionPkg/dist/doc/html/$pkg"
-  modList="$modDocDir/vimhelp_modules.txt"
-  for mod in `cat $modList`; do
-    cp $modDocDir/${mod}.txt $docDir/haddock_${mod}.txt
-  done
+    modDocDir="$workDir/src/$versionPkg/dist/doc/html/$pkg"
+    modList="$modDocDir/vimhelp_modules.txt"
+    for mod in `cat $modList`; do
+      cp $modDocDir/${mod}.txt $docDir/haddock_${mod}.txt
+    done
+  fi
 done
 
 # Rebuild the helptags