Ticket #215: submission_20120929_ghc-7.4.1.patch

File submission_20120929_ghc-7.4.1.patch, 68.2 kB (added by lars_e_krueger, 2 years ago)
  • (a) /dev/null vs. (b) b/.gitignore

    From c9ad4aad410d051ec25ae4c59d187a16366ae89e Mon Sep 17 00:00:00 2001
    From: Lars Krueger <lars_e_krueger@gmx.de>
    Date: Sat, 14 Apr 2012 21:17:03 +0200
    Subject: [PATCH 1/6] Squashed commit of the following:
    
    commit aedb6c7987edbd21fae704af8bfe5366528543a2
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Apr 14 19:58:11 2012 +0200
    
        hlint suggestions integrated
    
    commit 098707c8de20f7650f664b8d6a9fa7b6c2f04f5b
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Apr 14 19:06:46 2012 +0200
    
        formatting according to coding guide lines
    
    commit 694ec87fcaca9d9906edd0d5a9ddb05bfcfdacb5
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Apr 14 13:01:13 2012 +0200
    
        markup renderer without state monad
    
    commit 86c2edb98ba7279b7ae57ac1171d70747585b7f4
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Apr 14 11:15:43 2012 +0200
    
        factorisation
    
    commit 2bb4301266cca500d025650118b14030ebb9a259
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Apr 14 10:35:15 2012 +0200
    
        VimHelp code is warning free now
    
    commit c8cba4846ee41358881f33e15f1883f555246d65
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Apr 14 10:27:20 2012 +0200
    
        VimHelp backend: API cleanup
    
    commit 461dd13d070cc5c981342e522742e8a0da92fe8b
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Fri Apr 13 13:31:50 2012 +0200
    
        render bugs fixed (missing spaces etc)
    
    commit 9a4374dc55df0a873ba072c078c35271cf042ca9
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Mar 25 14:33:40 2012 +0200
    
        install help files in vim folder
    
    commit c6cd0610e9b6813db6a789831dd10351e7ff2f91
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Mar 24 17:07:13 2012 +0100
    
        removed some debug strings
    
    commit 90299b3644a8b23533cbe6f0b87faafef5be1bc8
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Mar 24 17:07:03 2012 +0100
    
        build help for all packages
    
    commit 8f1156ac0315d32ef66370baa12c72a0e7f34225
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Mar 17 15:10:23 2012 +0100
    
        added script to rebuild vimhelp docu
    
    commit 9cd228d0e34b9ff4589318a1b8e4cf26fda3bfe9
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Fri Mar 16 21:59:36 2012 +0100
    
        formatting correct on examples
    
    commit 1763dc1a19c09705c7458978a374a027d6162aa7
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Thu Mar 15 23:29:46 2012 +0100
    
        formatting fixed
    
    commit b1b556fafd3aecc6ba524db04c4e06c650237e85
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Mon Mar 5 22:17:38 2012 +0100
    
        everything ported to linear markup
    
    commit 0fd6567f2b76ba57dd3fc3ea26c3af42ed3229ad
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Mon Mar 5 08:54:03 2012 +0100
    
        utils use new markup
    
    commit 5d87785b4dd8a5b1ad07b26e2e1aaa74640b6a42
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Mon Mar 5 08:53:42 2012 +0100
    
        more state modifiers
    
    commit 2e71618fdbc3f1f88cecc1783c2c474469ae47fe
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Mon Mar 5 08:53:24 2012 +0100
    
        added package mtl
    
    commit 23a8f98e0491b952faf4de4f33c6f5eb7d46b96e
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Mar 4 21:38:41 2012 +0100
    
        Implemented linear markup
    
    commit 862b5145ee33cc60e2787254b307c7e86f679ef8
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Mar 4 19:45:39 2012 +0100
    
        special case for builtin types
    
    commit 4f256232bc1d9b1b6891c7da8b2b7c8a8daf9415
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Mar 4 19:45:26 2012 +0100
    
        added vhText to strip EOLs
    
    commit 065921d36471120317fd8bd5039affde52fc6649
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sat Mar 3 11:17:20 2012 +0100
    
        activated all top level renderers
    
    commit 0a491ab001b37603920c3d6db24d3c381c93ab07
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Mon Feb 27 21:28:02 2012 +0100
    
        ported Xhtml.Decl to VimHelp.Decl
    
    commit 667adaf7ef8cf298cf8c7529e2b3a08d8d023b6a
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Feb 19 22:44:43 2012 +0100
    
        use own markup engine
    
    commit 070bd38511f90c369e006a8fc5d5ba1c41652149
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Feb 19 22:44:22 2012 +0100
    
        added simple markup engine
    
    commit 60b0d3f3b1ebc19a84680386410e831b8e5e4a78
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Thu Feb 16 20:45:55 2012 +0100
    
        Basic ExportItem output added
    
    commit 6f9a03c18c09f234763626702706c1d99f669328
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Thu Feb 16 20:45:32 2012 +0100
    
        removed dummy text for maybeDoc
    
    commit 243150343c98d8227434ea332ad112a032188157
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Thu Feb 16 20:44:51 2012 +0100
    
        fixed DocParagraph output
    
    commit d97621b586e37b6436a390f654138b7e3b76995c
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Thu Feb 16 20:44:33 2012 +0100
    
        fixed DocModule output
    
    commit 8d68bd17fe0e9caf421f10c18a5eb2b6a5972cd9
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Thu Feb 16 20:43:57 2012 +0100
    
        fixed examples and code blocks
    
    commit f19958aa26ded9474873ea233b3f6277ed62af90
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Tue Feb 14 22:15:24 2012 +0100
    
        added index and module generation
    
    commit 846beaaf183198680eb36c3207e124d6712c1fd8
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Feb 12 16:31:16 2012 +0100
    
        ignore .viminfo
    
    commit b1a84a2a04eae75a518e730f86f3932ad10abda4
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Feb 12 14:51:10 2012 +0100
    
        integrated VimHelp backend
    
    commit d0144b6c361af340d17d83144741e7db1ed3b7dd
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Feb 12 14:50:24 2012 +0100
    
        ignore vim backup files
    
    commit f9858abd10cc36d6938ad8476576a04d80cb892a
    Author: Lars Krueger <lars_e_krueger@gmx.de>
    Date:   Sun Feb 12 14:06:34 2012 +0100
    
        added gitignore
    
    Signed-off-by: Lars Krueger <lars_e_krueger@gmx.de>
    ---
     .gitignore                             |    4 +
     haddock-rebuild-vimhelp.sh             |   85 ++++
     haddock.cabal                          |    4 +
     src/Haddock/Backends/VimHelp.hs        |   94 +++++
     src/Haddock/Backends/VimHelp/Decl.hs   |  690 ++++++++++++++++++++++++++++++++
     src/Haddock/Backends/VimHelp/Markup.hs |  200 +++++++++
     src/Haddock/Backends/VimHelp/Utils.hs  |  293 ++++++++++++++
     src/Haddock/Options.hs                 |    2 +
     src/Main.hs                            |   10 +-
     9 files changed, 1381 insertions(+), 1 deletions(-)
     create mode 100644 .gitignore
     create mode 100755 haddock-rebuild-vimhelp.sh
     create mode 100644 src/Haddock/Backends/VimHelp.hs
     create mode 100644 src/Haddock/Backends/VimHelp/Decl.hs
     create mode 100644 src/Haddock/Backends/VimHelp/Markup.hs
     create mode 100644 src/Haddock/Backends/VimHelp/Utils.hs
    
    diff --git a/.gitignore b/.gitignore
    new file mode 100644
    index 0000000..2f35f5b
    a b  
     1dist 
     2*~ 
     3.*.sw? 
     4.viminfo 
  • (a) /dev/null vs. (b) b/haddock-rebuild-vimhelp.sh

    diff --git a/haddock-rebuild-vimhelp.sh b/haddock-rebuild-vimhelp.sh
    new file mode 100755
    index 0000000..c0c0bc5
    a b  
     1#! /bin/bash  
     2 
     3# Script to rebuild the vimhelp from the list of installed packages 
     4 
     5workDir="$PWD/temp" 
     6HADDOCK="$PWD/haddock/dist/build/haddock/haddock" 
     7 
     8 
     9# set the language to US english, UTF-8, to handle unicode correctly 
     10export LANG=en_US.UTF-8 
     11 
     12# Check for the required tools 
     13test_for_program() { 
     14  prgName=$1 
     15  command -v $prgName > /dev/null 2>&1 
     16  [ $? -ne 0 ] || return 0 
     17  echo "Required program $prgName not found" 
     18  exit 1 
     19} 
     20 
     21test_for_program 'ghc-pkg' 
     22test_for_program 'cabal' 
     23test_for_program 'vim' 
     24 
     25# Get the list of installed packages 
     26instPkg=`ghc-pkg list --simple-output --names-only` 
     27 
     28# Process the packages 
     29workList='' 
     30for pkg in $instPkg; do 
     31  # Get the latest version of package 
     32  latestPkg=`ghc-pkg latest $pkg` 
     33 
     34  # Check for hidden packages 
     35  isExposed=`ghc-pkg field $latestPkg exposed | cut -d ' ' -f 2 | head -1` 
     36  # if [ $isExposed == 'True' ]; then 
     37    echo -n "Checking for package $latestPkg ... " 
     38 
     39    # Download the package using cabal 
     40    cabal fetch --no-dependencies $latestPkg > /dev/null 2>&1 
     41 
     42    if [ $? -eq 0 ] ; then 
     43      workList="$workList $pkg" 
     44      echo "OK" 
     45    else 
     46      echo "ignored" 
     47    fi 
     48  # else 
     49  #   echo "Package $pkg is hidden" 
     50  # fi 
     51done 
     52 
     53# 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' 
     54 
     55workList=`(for w in $workList; do echo $w; done) | sort -u` 
     56 
     57versionList=`(for w in $workList; do ghc-pkg latest $w; done)` 
     58 
     59# Unpack all the packages 
     60rm -Rf $workDir 
     61cabal unpack --destdir=$workDir/src $versionList 
     62 
     63# For each package, run haddock and make it generate the vimhelp info 
     64docDir="/home/lars/.vim/doc" 
     65mkdir -p $docDir 
     66for pkg in $workList; do 
     67  versionPkg=`ghc-pkg latest $pkg` 
     68 
     69  # Generating the docs 
     70  ( 
     71    cd $workDir/src/$versionPkg 
     72    cabal configure 
     73    cabal haddock --with-haddock=$HADDOCK --haddock-options="--vimhelp" 
     74  ) 
     75  # Reading the modules and copying them 
     76  modDocDir="$workDir/src/$versionPkg/dist/doc/html/$pkg" 
     77  modList="$modDocDir/vimhelp_modules.txt" 
     78  for mod in `cat $modList`; do 
     79    cp $modDocDir/${mod}.txt $docDir/haddock_${mod}.txt 
     80  done 
     81done 
     82 
     83# Rebuild the helptags 
     84vim --cmd "helptags $docDir" --cmd quit 
     85 
  • haddock.cabal

    diff --git a/haddock.cabal b/haddock.cabal
    index 84d3c2a..5563472 100644
    a b  
    127127    Haddock.Backends.Xhtml.Types 
    128128    Haddock.Backends.Xhtml.Utils 
    129129    Haddock.Backends.LaTeX 
     130    Haddock.Backends.VimHelp 
     131    Haddock.Backends.VimHelp.Markup 
     132    Haddock.Backends.VimHelp.Utils 
     133    Haddock.Backends.VimHelp.Decl 
    130134    Haddock.Backends.HaddockDB 
    131135    Haddock.Backends.Hoogle 
    132136    Haddock.ModuleTree 
  • (a) /dev/null vs. (b) b/src/Haddock/Backends/VimHelp.hs

    diff --git a/src/Haddock/Backends/VimHelp.hs b/src/Haddock/Backends/VimHelp.hs
    new file mode 100644
    index 0000000..b935e4d
    a b  
     1----------------------------------------------------------------------------- 
     2-- | 
     3-- Module      :  Haddock.Backends.VimHelp 
     4-- Copyright   :  (c) Lars Krueger 2012 
     5-- License     :  BSD-like 
     6-- 
     7-- Maintainer  :  lars_e_krueger@gmx.de 
     8-- Stability   :  experimental 
     9-- Portability :  portable 
     10----------------------------------------------------------------------------- 
     11module Haddock.Backends.VimHelp ( 
     12  ppVimHelp 
     13) where 
     14 
     15import Haddock.Backends.VimHelp.Decl 
     16import Haddock.Backends.VimHelp.Markup 
     17import Haddock.Backends.VimHelp.Utils 
     18 
     19import Haddock.GhcUtils 
     20import Haddock.Types 
     21 
     22import Control.Monad 
     23import System.Directory 
     24import System.FilePath 
     25 
     26 
     27-- | Generate vim help files from interfaces. 
     28ppVimHelp :: [Interface] 
     29          -> FilePath                     -- destination directory 
     30          -> IO () 
     31ppVimHelp visible_ifaces odir = do 
     32  createDirectoryIfMissing True odir 
     33  -- Write module index for haddock-rebuild-vimhelp.sh 
     34  let mdlNameList = map (moduleString . ifaceMod) visible_ifaces 
     35  writeFile (odir </> "vimhelp_modules.txt") $ unlines mdlNameList 
     36  -- Write the module help files 
     37  forM_ visible_ifaces $ \iface -> do 
     38      let (ifaceTxt,modName)= ppModuleText iface 
     39      writeFile (odir </> (modName ++ ".txt")) ifaceTxt 
     40 
     41 
     42-- | Render the text of this module 
     43ppModuleText :: Interface -> (String,String) 
     44ppModuleText iface =  
     45  let mdl = ifaceMod iface 
     46      modName = moduleString mdl 
     47      txt = [ ppRef $ "haddock_" ++ modName ++ ".txt" 
     48            , MiNonBreakable " Haddock documentation" 
     49            ]  
     50            ++ modInfotxt 
     51            ++ ppRuler '=' 
     52            ++ [MiLineBreak] 
     53            ++ maybeDocSection (ifaceRnDoc iface) 
     54            ++ [MiLineBreak] 
     55            ++ concatMap docExpIt (ifaceRnExportItems iface) 
     56            ++ [ MiPushIndent0 
     57               , MiLineBreak 
     58               , MiLineBreak 
     59               , MiNonBreakable "vim:tw=78:fo=tcq2:isk=!-~,^*,^\\|,^\\\":ts=8:ft=help:norl:" ] 
     60  in ( ppRender txt , modName) 
     61  where 
     62  modInfo = ifaceInfo iface 
     63  modInfotxt = concat  
     64    [ maybeTab "Portability: " $ hmi_portability modInfo 
     65    , maybeTab "Stability:   " $ hmi_stability modInfo 
     66    , maybeTab "Maintainer:  " $ hmi_maintainer modInfo 
     67    ] 
     68 
     69  maybeTab :: String -> Maybe String -> Markup 
     70  maybeTab _ (Nothing) = [] 
     71  maybeTab a (Just b)  = [MiLineBreak, MiNonBreakable $ a ++ b] 
     72 
     73 
     74-- | ExportItem to Markup.  
     75docExpIt :: ExportItem DocName -> Markup 
     76docExpIt (ExportDecl decl doc subdocs insts) = ppDecl decl doc insts subdocs 
     77docExpIt (ExportNoDecl y []) = [ppDocName y] 
     78docExpIt (ExportDoc d) = ppRenderDoc d 
     79 
     80docExpIt (ExportNoDecl y subs)  
     81  = ppDocName y : parenList (map (\a -> [ppDocName a]) subs) 
     82 
     83docExpIt (ExportGroup lvl _ doc)  
     84  = [ MiPushIndent0, MiLineBreak 
     85    , MiNonBreakable $ replicate lvl '*' ++ " " 
     86    ]  
     87    ++ ppRenderDoc doc 
     88    ++ [MiIndent 2] 
     89 
     90docExpIt (ExportModule m)  
     91  = [ MiNonBreakable "module " 
     92    , ppLink $ moduleString m 
     93    , MiLineBreak 
     94    ] 
  • (a) /dev/null vs. (b) b/src/Haddock/Backends/VimHelp/Decl.hs

    diff --git a/src/Haddock/Backends/VimHelp/Decl.hs b/src/Haddock/Backends/VimHelp/Decl.hs
    new file mode 100644
    index 0000000..9b7a69f
    a b  
     1----------------------------------------------------------------------------- 
     2-- | 
     3-- Module      :  Haddock.Backends.VimHelp.Decl 
     4-- Copyright   :  (c) Simon Marlow   2003-2006, 
     5--                    David Waern    2006-2009, 
     6--                    Mark Lentczner 2010 
     7--                    Lars Krueger   2012 
     8-- License     :  BSD-like 
     9-- 
     10-- Maintainer  :  haddock@projects.haskell.org 
     11-- Stability   :  experimental 
     12-- Portability :  portable 
     13-- 
     14-- This is based on Haddock.Backends.Xhtml.Decl 
     15----------------------------------------------------------------------------- 
     16module Haddock.Backends.VimHelp.Decl ( 
     17  ppDecl, 
     18) where 
     19 
     20 
     21import Haddock.Backends.VimHelp.Markup 
     22import Haddock.Backends.VimHelp.Utils 
     23 
     24import Haddock.GhcUtils 
     25import Haddock.Types 
     26 
     27import BasicTypes            ( IPName(..), Boxity(..) ) 
     28import GHC 
     29import Name 
     30import Outputable            ( ppr, showSDoc, Outputable ) 
     31 
     32import           Control.Monad         ( join ) 
     33import qualified Data.Map as Map 
     34import           Data.Maybe 
     35import           Data.List 
     36 
     37 
     38forallSymbol :: MarkupItem 
     39forallSymbol = MiNonBreakable "forall" 
     40 
     41 
     42-- | Generate markup for a declaration. 
     43ppDecl :: LHsDecl DocName  
     44       -> DocForDecl DocName  
     45       -> [DocInstance DocName]  
     46       -> [(DocName, DocForDecl DocName)]  
     47       -> Markup 
     48ppDecl (L _ decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of 
     49  TyClD d@(TyFamily {})          -> ppTyFam False mbDoc d 
     50  TyClD d@(TyData {}) 
     51    | Nothing <- tcdTyPats d     -> ppDataDecl instances subdocs mbDoc d 
     52    | Just _  <- tcdTyPats d     -> ppDataInst mbDoc d 
     53  TyClD d@(TySynonym {}) 
     54    | Nothing <- tcdTyPats d     -> ppTySyn (mbDoc, fnArgsDoc) d 
     55    | Just _  <- tcdTyPats d     -> ppTyInst False mbDoc d 
     56  TyClD d@(ClassDecl {})         -> ppClassDecl instances mbDoc subdocs d 
     57  SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig (mbDoc, fnArgsDoc) n t 
     58  ForD d                         -> ppFor (mbDoc, fnArgsDoc) d 
     59  InstD _                        -> [] 
     60  _                              -> error "declaration not supported by ppDecl" 
     61 
     62 
     63-- | Generate markup for function signature. 
     64ppFunSig :: DocForDecl DocName -> DocName -> HsType DocName -> Markup 
     65ppFunSig doc docname typ = 
     66  ppTypeOrFunSig typ doc 
     67    (ppTypeSig docname typ, [ppBinder docname], [dcolon]) 
     68 
     69 
     70ppTypeOrFunSig :: HsType DocName  
     71               -> DocForDecl DocName  
     72               -> (Markup, Markup, Markup)  
     73               -> Markup 
     74ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep) 
     75  | Map.null argDocs = topDeclElem pref1 $ maybeDocSection doc 
     76  | otherwise = topDeclElem pref2 $  
     77      subArguments (do_args 0 sep typ) ++ maybeDocSection doc 
     78  where 
     79    argDoc n = Map.lookup n argDocs 
     80 
     81    do_largs n leader (L _ t) = do_args n leader t 
     82    do_args :: Int -> Markup -> HsType DocName -> [SubDecl] 
     83    do_args n leader (HsForAllTy Explicit tvs lctxt ltype) 
     84      = (leader <+> 
     85          ((forallSymbol: ppTyVars tvs) ++ [dot]) <+> 
     86          ppLContextNoArrow lctxt, 
     87          Nothing, []) 
     88        : do_largs n [darrow] ltype 
     89    do_args n leader (HsForAllTy Implicit _ lctxt ltype) 
     90      | not (null (unLoc lctxt)) 
     91      = (leader <+> ppLContextNoArrow lctxt, 
     92          Nothing, []) 
     93        : do_largs n [darrow] ltype 
     94      -- if we're not showing any 'forall' or class constraints or 
     95      -- anything, skip having an empty line for the context. 
     96      | otherwise 
     97      = do_largs n leader ltype 
     98    do_args n leader (HsFunTy lt r) 
     99      = (leader <+> ppLFunLhType lt, argDoc n, []) 
     100        : do_largs (n+1) [arrow] r 
     101    do_args n leader t 
     102      = [(leader <+> ppType t, argDoc n, [])] 
     103 
     104 
     105ppTyVars :: [LHsTyVarBndr DocName] -> Markup 
     106ppTyVars tvs = intercalate [space] $ map ppTyName (tyvarNames tvs) 
     107 
     108 
     109tyvarNames :: [LHsTyVarBndr DocName] -> [Name] 
     110tyvarNames = map (getName . hsTyVarName . unLoc) 
     111 
     112 
     113ppFor :: DocForDecl DocName -> ForeignDecl DocName -> Markup 
     114ppFor doc (ForeignImport (L _ name) (L _ typ) _) = ppFunSig doc name typ 
     115ppFor _ _ = error "ppFor" 
     116 
     117 
     118-- we skip type patterns for now 
     119ppTySyn :: DocForDecl DocName -> TyClDecl DocName -> Markup 
     120ppTySyn doc (TySynonym (L _ name) ltyvars _ ltype) =  
     121  ppTypeOrFunSig (unLoc ltype) doc (full, hdr, [space,equals]) 
     122  where 
     123    hdr  = [MiNonBreakable "type ", ppBinder name, MiSpaceBeforeLetter]  
     124           ++  
     125           ppTyVars ltyvars 
     126    full = hdr <+> [equals] <+> ppLType ltype 
     127ppTySyn _ _ = error "declaration not supported by ppTySyn" 
     128 
     129 
     130ppTypeSig :: DocName -> HsType DocName  -> Markup 
     131ppTypeSig nm ty = 
     132    [ppBinder nm, space, dcolon] <+> ppType ty 
     133 
     134 
     135ppName :: Name -> Markup 
     136ppName n = [MiNonBreakable $ getOccString n] 
     137 
     138 
     139ppTyName :: Name -> Markup 
     140ppTyName name 
     141  | isNameSym name = parens (ppName name) 
     142  | otherwise = ppName name 
     143 
     144 
     145-------------------------------------------------------------------------------- 
     146-- * Type families 
     147-------------------------------------------------------------------------------- 
     148 
     149 
     150ppTyFamHeader :: Bool -> TyClDecl DocName -> Markup 
     151ppTyFamHeader associated decl = 
     152  (case tcdFlavour decl of 
     153     TypeFamily 
     154       | associated -> [MiNonBreakable "type"] 
     155       | otherwise  -> [MiNonBreakable "type family"] 
     156     DataFamily 
     157       | associated -> [MiNonBreakable "data"] 
     158       | otherwise  -> [MiNonBreakable "data family"] 
     159  ) <+> 
     160  ppTyClBinderWithVars decl <+> 
     161  case tcdKind decl of 
     162    Just kind -> [dcolon,space] ++ ppKind kind 
     163    Nothing -> [] 
     164 
     165 
     166ppTyFam :: Bool -> Maybe (Doc DocName) -> TyClDecl DocName -> Markup 
     167ppTyFam associated mbDoc decl =  
     168  header_ ++ maybeDocSection mbDoc ++ instancesBit 
     169  where 
     170    header_ = ppTyFamHeader associated decl 
     171    instancesBit = ppInstances instances  
     172    -- TODO: get the instances 
     173    instances = [] 
     174 
     175 
     176-------------------------------------------------------------------------------- 
     177-- * Indexed data types 
     178-------------------------------------------------------------------------------- 
     179 
     180 
     181ppDataInst :: a 
     182ppDataInst = undefined 
     183 
     184 
     185-------------------------------------------------------------------------------- 
     186-- * Indexed types 
     187-------------------------------------------------------------------------------- 
     188 
     189 
     190ppTyInst :: Bool  
     191         -> Maybe (Doc DocName)  
     192         -> TyClDecl DocName  
     193         -> Markup 
     194ppTyInst associated mbDoc decl = header_ ++ maybeDocSection mbDoc 
     195  where 
     196    docname = tcdName decl 
     197    header_ = topDeclElem [ppBinder docname] (ppTyInstHeader associated decl) 
     198 
     199 
     200ppTyInstHeader :: Bool -> TyClDecl DocName -> Markup 
     201ppTyInstHeader _ decl = 
     202  MiNonBreakable "type instance " : ppAppNameTypes (tcdName decl) typeArgs 
     203  where 
     204    typeArgs = map unLoc . fromJust . tcdTyPats $ decl 
     205 
     206 
     207-------------------------------------------------------------------------------- 
     208-- * Associated Types 
     209-------------------------------------------------------------------------------- 
     210 
     211 
     212ppAssocType :: DocForDecl DocName -> LTyClDecl DocName -> Markup 
     213ppAssocType doc (L _ decl) = 
     214  case decl of 
     215    TyFamily  {} -> ppTyFam True (fst doc) decl 
     216    TySynonym {} -> ppTySyn doc decl 
     217    _            -> error "declaration type not supported by ppAssocType" 
     218 
     219 
     220-------------------------------------------------------------------------------- 
     221-- * TyClDecl helpers 
     222-------------------------------------------------------------------------------- 
     223 
     224 
     225-- | Print a type family / newtype / data / class binder and its variables  
     226ppTyClBinderWithVars :: TyClDecl DocName -> Markup 
     227ppTyClBinderWithVars decl = 
     228  ppAppDocNameNames (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl) 
     229 
     230 
     231-------------------------------------------------------------------------------- 
     232-- * Type applications 
     233-------------------------------------------------------------------------------- 
     234 
     235 
     236-- | Print an application of a DocName and a list of HsTypes 
     237ppAppNameTypes :: DocName -> [HsType DocName] -> Markup 
     238ppAppNameTypes n ts = 
     239    ppTypeApp n ts ppDocName ppParendType 
     240 
     241 
     242-- | Print an application of a DocName and a list of Names  
     243ppAppDocNameNames :: DocName -> [Name] -> Markup 
     244ppAppDocNameNames n ns = 
     245  ppTypeApp n ns ppBinder ppTyName 
     246 
     247 
     248-- | General printing of type applications 
     249ppTypeApp :: DocName  
     250          -> [a]  
     251          -> (DocName -> MarkupItem)  
     252          -> (a -> Markup)  
     253          -> Markup 
     254ppTypeApp n (t1:t2:rest) ppDN ppT 
     255  | operator, not . null $ rest =  
     256    parens $ opApp <+> intercalate [space] (map ppT rest) 
     257  | operator                    = opApp 
     258  where 
     259    operator = isNameSym . getName $ n 
     260    opApp = ppT t1 <+> [ppDN n] <+> ppT t2 
     261 
     262ppTypeApp n ts ppDN ppT =  
     263  [ppDN n] <+> intercalate [space] (map ppT ts) 
     264 
     265 
     266------------------------------------------------------------------------------- 
     267-- * Contexts 
     268------------------------------------------------------------------------------- 
     269 
     270 
     271ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Markup 
     272ppLContext        = ppContext        . unLoc 
     273ppLContextNoArrow = ppContextNoArrow . unLoc 
     274 
     275 
     276ppContextNoArrow :: HsContext DocName -> Markup 
     277ppContextNoArrow []   = [] 
     278ppContextNoArrow cxt  = ppHsContext (map unLoc cxt) 
     279 
     280 
     281ppContextNoLocs :: [HsPred DocName] -> Markup 
     282ppContextNoLocs []  = [] 
     283ppContextNoLocs cxt = ppHsContext cxt <+> [darrow] 
     284 
     285 
     286ppContext :: HsContext DocName -> Markup 
     287ppContext cxt = ppContextNoLocs (map unLoc cxt) 
     288 
     289 
     290ppHsContext :: [HsPred DocName] -> Markup 
     291ppHsContext []  = [] 
     292ppHsContext [p] = ppPred p 
     293ppHsContext cxt = parenList (intersperse [space] $ map ppPred cxt) 
     294 
     295 
     296ppPred :: HsPred DocName -> Markup 
     297ppPred (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) 
     298ppPred (HsEqualP t1 t2) = ppLType t1 <+> [MiNonBreakable "~"] <+> ppLType t2 
     299ppPred (HsIParam (IPName n) t) =  
     300  [MiNonBreakable "?", ppDocName n, space, dcolon] <+> ppLType t 
     301 
     302 
     303------------------------------------------------------------------------------- 
     304-- * Class declarations 
     305------------------------------------------------------------------------------- 
     306 
     307 
     308ppClassHdr :: Located [LHsPred DocName]  
     309           -> DocName 
     310           -> [Located (HsTyVarBndr DocName)]  
     311           -> [Located ([DocName], [DocName])] 
     312           -> Markup 
     313ppClassHdr lctxt n tvs fds = 
     314  [MiNonBreakable "class"] 
     315  <+> (if not . null . unLoc $ lctxt then ppLContext lctxt else []) 
     316  <+> ppAppDocNameNames n (tyvarNames tvs) 
     317  <+> ppFds fds 
     318 
     319 
     320ppFds :: [Located ([DocName], [DocName])] -> Markup 
     321ppFds fds = 
     322  if null fds  
     323     then []  
     324     else [ MiNonBreakable "|", space]  
     325          ++ intersperse comma (concatMap (fundep . unLoc) fds) 
     326  where 
     327  fundep (vars1,vars2) = map ppDocName vars1  
     328                         <+> [arrow]  
     329                         <+> map ppDocName vars2 
     330 
     331 
     332ppClassDecl :: [DocInstance DocName] 
     333            -> Maybe (Doc DocName)  
     334            -> [(DocName, DocForDecl DocName)] 
     335            -> TyClDecl DocName  
     336            -> Markup 
     337ppClassDecl instances mbDoc subdocs 
     338        (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) =  
     339  classheader  
     340  ++ maybeDocSection mbDoc 
     341  ++ atBit  
     342  ++ methodBit   
     343  ++ instancesBit 
     344  where 
     345    classheader 
     346      | null lsigs = hdr  
     347      | otherwise  = hdr ++ [MiNonBreakable " where"] 
     348 
     349    hdr = ppClassHdr lctxt (unLoc lname) ltyvars lfds 
     350 
     351    atBit = subAssociatedTypes [ ppAssocType doc at 
     352                      | at <- ats 
     353                      , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] 
     354 
     355    methodBit = subMethods [ ppFunSig doc n typ 
     356                      | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs 
     357                      , let doc = lookupAnySubdoc n subdocs ] 
     358 
     359    instancesBit = ppInstances instances 
     360 
     361ppClassDecl _ _ _ _ = error "declaration type not supported by ppShortClassDecl" 
     362 
     363 
     364ppInstances :: [DocInstance DocName] -> Markup 
     365ppInstances instances = subInstances (map instDecl instances) 
     366  where 
     367  instDecl :: DocInstance DocName -> SubDecl 
     368  instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) 
     369  instHead ([],   n, ts) = ppAppNameTypes n ts 
     370  instHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAppNameTypes n ts 
     371 
     372 
     373lookupAnySubdoc :: (Eq name1) => 
     374                   name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 
     375lookupAnySubdoc n subdocs = fromMaybe noDocForDecl (lookup n subdocs) 
     376 
     377 
     378------------------------------------------------------------------------------- 
     379-- * Data & newtype declarations 
     380------------------------------------------------------------------------------- 
     381 
     382 
     383ppDataDecl :: [DocInstance DocName]  
     384           -> [(DocName, DocForDecl DocName)]  
     385           -> Maybe (Doc DocName)  
     386           -> TyClDecl DocName  
     387           -> Markup 
     388ppDataDecl instances subdocs mbDoc dataDecl =  
     389  topDeclElem header_ $ maybeDocSection mbDoc ++ constrBit ++ instancesBit   
     390  where 
     391    cons      = tcdCons dataDecl 
     392    resTy     = (con_res . unLoc . head) cons 
     393 
     394    header_ = ppDataHeader dataDecl 
     395             ++ [whereBit] 
     396 
     397    whereBit 
     398      | null cons = MiNothing 
     399      | otherwise = case resTy of 
     400        ResTyGADT _ -> MiNonBreakable "where" 
     401        _ -> MiNothing 
     402 
     403    constrBit = subConstructors  
     404      (map (ppSideBySideConstr subdocs) cons) 
     405 
     406    instancesBit = ppInstances instances 
     407 
     408 
     409-- ppConstrHdr is for (non-GADT) existentials constructors' syntax 
     410ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Markup 
     411ppConstrHdr forAllFlag tvs ctxt  
     412 = (if null tvs then [] else ppForall) 
     413   ++ 
     414   (if null ctxt then [] else ppContextNoArrow ctxt  
     415        <+> [darrow, space]) 
     416  where 
     417  ppForall = case forAllFlag of 
     418    Explicit ->  
     419      [forallSymbol]  
     420      <+> intercalate [space] (map ppName tvs)  
     421      ++ [MiNonBreakable " . "] 
     422    Implicit -> [] 
     423 
     424 
     425ppSideBySideConstr :: [(DocName, DocForDecl DocName)]  
     426                   -> LConDecl DocName  
     427                   -> SubDecl 
     428ppSideBySideConstr subdocs (L _ con) = (decl, mbDoc, fieldPart) 
     429 where 
     430    decl = case con_res con of 
     431      ResTyH98 -> case con_details con of 
     432        PrefixCon args -> 
     433          header_ ++ [ppBinderConstr occ] ++ 
     434            concatMap (\a -> space:ppLParendType a)  args 
     435 
     436        RecCon _ -> header_ ++ [ppBinderConstr occ] 
     437 
     438        InfixCon arg1 arg2 -> 
     439          (header_ ++ ppLParendType arg1) ++  
     440            [ppBinder occ] ++ 
     441            ppLParendType arg2 
     442 
     443      ResTyGADT resTy -> case con_details con of 
     444        -- prefix & infix could also use hsConDeclArgTys if it seemed to 
     445        -- simplify the code. 
     446        PrefixCon args -> doGADTCon args resTy 
     447        cd@(RecCon _) -> doGADTCon (hsConDeclArgTys cd) resTy 
     448        InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy 
     449 
     450    fieldPart = case con_details con of 
     451        RecCon fields -> [doRecordFields fields] 
     452        _ -> [] 
     453 
     454    doRecordFields fields = subFields  
     455      (map (ppSideBySideField subdocs ) fields) 
     456    doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Markup 
     457    doGADTCon args resTy = 
     458      [ppBinderConstr occ, space, dcolon, space] ++ 
     459        (ppForAll forAllFlag ltvs (con_cxt con) ++ 
     460                  ppLType (foldr mkFunTy resTy args) ) 
     461 
     462    header_     = ppConstrHdr forAllFlag tyVars context 
     463    occ         = unLoc . con_name $ con 
     464    ltvs        = con_qvars con 
     465    tyVars      = tyvarNames (con_qvars con) 
     466    context     = unLoc (con_cxt con) 
     467    forAllFlag  = con_explicit con 
     468    -- don't use "con_doc con", in case it's reconstructed from a .hi file, 
     469    -- or also because we want Haddock to do the doc-parsing, not GHC. 
     470    -- 'join' is in Maybe. 
     471    mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs 
     472    mkFunTy a b = noLoc (HsFunTy a b) 
     473 
     474 
     475ppSideBySideField :: [(DocName, DocForDecl DocName)]  
     476                  -> ConDeclField DocName ->  SubDecl 
     477ppSideBySideField subdocs (ConDeclField (L _ name) ltype _) = 
     478  ([ppBinder name, space, dcolon, space] ++ ppLType ltype, 
     479    mbDoc, 
     480    []) 
     481  where 
     482    -- don't use cd_fld_doc for same reason we don't use con_doc above 
     483    mbDoc = join $ fmap fst $ lookup name subdocs 
     484 
     485 
     486-- | Print the LHS of a data\/newtype declaration. 
     487-- Currently doesn't handle 'data instance' decls or kind signatures 
     488ppDataHeader :: TyClDecl DocName -> Markup 
     489ppDataHeader decl  
     490  | not (isDataDecl decl) = error "ppDataHeader: illegal argument" 
     491  | otherwise = 
     492    -- newtype or data 
     493    [if tcdND decl == NewType  
     494        then MiNonBreakable "newtype"  
     495        else MiNonBreakable "data"]  
     496    -- context 
     497    <?> ppLContext (tcdCtxt decl) 
     498    -- T a b c ..., or a :+: b 
     499    <?> ppTyClBinderWithVars decl 
     500 
     501 
     502-------------------------------------------------------------------------------- 
     503-- * Types and contexts 
     504-------------------------------------------------------------------------------- 
     505 
     506 
     507ppKind :: Outputable a => a -> Markup 
     508ppKind k = [MiNonBreakable $ showSDoc (ppr k)] 
     509 
     510 
     511 -- Unpacked args is an implementation detail, so we just show the strictness 
     512 -- annotation 
     513ppBang :: HsBang -> Markup 
     514ppBang HsNoBang = [] 
     515ppBang _        = [MiNonBreakable "!" ] 
     516 
     517 
     518tupleParens :: Boxity -> [Markup] -> Markup 
     519tupleParens Boxed   = parenList 
     520tupleParens Unboxed = ubxParenList 
     521 
     522 
     523-------------------------------------------------------------------------------- 
     524-- * Rendering of HsType 
     525-------------------------------------------------------------------------------- 
     526 
     527 
     528pRECTOP, pRECFUN, pRECOP, pRECCON :: Int 
     529 
     530pRECTOP = 0 :: Int   -- type in ParseIface.y in GHC 
     531pRECFUN = 1 :: Int   -- btype in ParseIface.y in GHC 
     532                      -- Used for LH arg of (->) 
     533pRECOP  = 2 :: Int   -- Used for arg of any infix operator 
     534                      -- (we don't keep their fixities around) 
     535pRECCON = 3 :: Int   -- Used for arg of type applicn: 
     536                        -- always parenthesise unless atomic 
     537 
     538maybeParen :: Int           -- Precedence of context 
     539           -> Int           -- Precedence of top-level operator 
     540           -> Markup -> Markup  -- Wrap in parens if (ctxt >= op) 
     541maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p 
     542                               | otherwise            = p 
     543 
     544 
     545ppLType, ppLParendType, ppLFunLhType :: Located (HsType DocName) -> Markup 
     546ppLType       y = ppType (unLoc y) 
     547ppLParendType y = ppParendType (unLoc y) 
     548ppLFunLhType  y = ppFunLhType (unLoc y) 
     549 
     550 
     551ppType, ppParendType, ppFunLhType :: HsType DocName -> Markup 
     552ppType       = pprMonoTy pRECTOP 
     553ppParendType = pprMonoTy pRECCON 
     554ppFunLhType  = pprMonoTy pRECFUN 
     555 
     556 
     557-- Drop top-level for-all type variables in user style 
     558-- since they are implicit in Haskell 
     559 
     560ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)] 
     561         -> Located (HsContext DocName) -> Markup 
     562ppForAll expl tvs cxt 
     563  | show_forall = forall_part <+> ppLContext cxt  
     564  | otherwise   = ppLContext cxt  
     565  where 
     566    show_forall = not (null tvs) && is_explicit 
     567    is_explicit = case expl of {Explicit -> True; Implicit -> False} 
     568    forall_part = (forallSymbol : space : ppTyVars tvs) ++ [dot] 
     569 
     570 
     571pprMonoLty :: Int -> LHsType DocName -> Markup 
     572pprMonoLty ctxt_prec ty = pprMonoTy ctxt_prec (unLoc ty) 
     573 
     574 
     575pprMonoTy :: Int -> HsType DocName -> Markup 
     576pprMonoTy _         (HsListTy ty)        = brackets (pprMonoLty pRECTOP ty) 
     577pprMonoTy _         (HsBangTy b ty)      = ppBang b ++ ppLParendType ty 
     578pprMonoTy ctxt_prec (HsFunTy ty1 ty2)    = pprFunTy ctxt_prec ty1 ty2  
     579pprMonoTy _         (HsTupleTy con tys)  = tupleParens con (map ppLType tys) 
     580pprMonoTy _         (HsPredTy p)         = parens (ppPred p) 
     581pprMonoTy _         (HsNumTy n)          = [MiNonBreakable (show n)] -- generics only 
     582pprMonoTy ctxt_prec (HsParTy ty)         = pprMonoLty ctxt_prec ty  
     583pprMonoTy ctxt_prec (HsDocTy ty _)       = pprMonoLty ctxt_prec ty  
     584pprMonoTy _         (HsSpliceTy {})      = error "pprMonoTy HsSpliceTy" 
     585pprMonoTy _         (HsQuasiQuoteTy {})  = error "pprMonoTy HsQuasiQuoteTy" 
     586pprMonoTy _         (HsCoreTy {})        = error "pprMonoTy HsCoreTy" 
     587pprMonoTy _         (HsRecTy {})         = error "pprMonoTy HsRecTy" 
     588 
     589pprMonoTy ctxt_prec (HsForAllTy expl tvs ctxt ty) =  
     590  maybeParen ctxt_prec pRECFUN $ 
     591    ppForAll expl tvs ctxt <+> pprMonoLty pRECTOP ty 
     592 
     593pprMonoTy _         (HsTyVar name)       =  
     594  [ppDocName name, MiSpaceBeforeLetter] 
     595 
     596pprMonoTy _         (HsKindSig ty kind)  =  
     597  parens (pprMonoLty pRECTOP ty <+> [dcolon] <+> ppKind kind) 
     598 
     599pprMonoTy _         (HsPArrTy ty)        =  
     600  pabrackets (pprMonoLty pRECTOP ty) 
     601 
     602pprMonoTy ctxt_prec (HsAppTy fun_ty arg_ty) =  
     603  maybeParen ctxt_prec pRECCON $ 
     604    pprMonoLty pRECFUN fun_ty ++ pprMonoLty pRECCON arg_ty 
     605 
     606pprMonoTy ctxt_prec (HsOpTy ty1 op ty2) =  
     607  maybeParen ctxt_prec pRECFUN $ 
     608    pprMonoLty pRECOP ty1 <+> ppr_op <+> pprMonoLty pRECOP ty2  
     609  where 
     610  ppr_op = if not (isSymOcc occName)  
     611              then quote (ppLDocName op)  
     612              else ppLDocName op 
     613  occName = nameOccName . getName . unLoc $ op 
     614 
     615 
     616pprFunTy :: Int -> LHsType DocName -> LHsType DocName -> Markup 
     617pprFunTy ctxt_prec ty1 ty2 =  
     618  let p1 = pprMonoLty pRECFUN ty1  
     619      p2 = pprMonoLty pRECTOP ty2  
     620  in maybeParen ctxt_prec pRECFUN $ p1 <+> [arrow] <+> p2 
     621 
     622 
     623ppLDocName :: Located DocName -> Markup 
     624ppLDocName (L _ d) = [ppDocName d] 
     625 
     626 
     627-------------------------------------------------------------------------------- 
     628-- * Declaration containers 
     629-------------------------------------------------------------------------------- 
     630 
     631 
     632type SubDecl = (Markup, Maybe (Doc DocName), [Markup]) 
     633 
     634 
     635divSubDecls :: String -> Maybe Markup -> Markup 
     636divSubDecls _ Nothing  = [MiLineBreak] 
     637divSubDecls c (Just m) =  
     638  [ MiPushIndent 
     639  , MiIndent 2 
     640  , MiNonBreakable c 
     641  , MiPushIndent 
     642  , MiNextIndent 3 
     643  ]  
     644  ++ m  
     645  ++  
     646  [ MiPopIndent 
     647  , MiPopIndent 
     648  , MiLineBreak 
     649  ] 
     650 
     651 
     652subDlist :: [SubDecl] -> Maybe Markup 
     653subDlist [] = Nothing 
     654subDlist decls = Just $ concatMap subEntry decls 
     655  where 
     656  subEntry (decl, mdoc, subs) = 
     657    ppListItem True decl (maybeDocSection mdoc ++ concat subs) 
     658 
     659 
     660subBlock :: [Markup] -> Maybe Markup 
     661subBlock [] = Nothing 
     662subBlock hs = Just $ concatMap (\a -> MiLineBreak : a) hs 
     663 
     664 
     665subArguments :: [SubDecl] -> Markup 
     666subArguments = divSubDecls "Arguments" . subDlist 
     667 
     668 
     669subAssociatedTypes :: [Markup] -> Markup 
     670subAssociatedTypes = divSubDecls "Associated Types" . subBlock 
     671 
     672 
     673subConstructors :: [SubDecl] -> Markup 
     674subConstructors = divSubDecls "Constructors" . subDlist 
     675 
     676 
     677subFields :: [SubDecl] -> Markup 
     678subFields = divSubDecls "Fields" . subDlist 
     679 
     680 
     681subInstances :: [SubDecl] -> Markup 
     682subInstances = divSubDecls "Instances" . subDlist 
     683 
     684subMethods :: [Markup] -> Markup 
     685subMethods = divSubDecls "Methods" . subBlock 
     686 
     687 
     688-- a box for top level documented names 
     689topDeclElem :: Markup -> Markup -> Markup 
     690topDeclElem hd body = (MiPushIndent:(MiIndent 2:hd)) ++ body ++ [MiPopIndent] 
  • (a) /dev/null vs. (b) b/src/Haddock/Backends/VimHelp/Markup.hs

    diff --git a/src/Haddock/Backends/VimHelp/Markup.hs b/src/Haddock/Backends/VimHelp/Markup.hs
    new file mode 100644
    index 0000000..4c8fcf6
    a b  
     1----------------------------------------------------------------------------- 
     2-- | 
     3-- Module      :  Haddock.Backends.VimHelp.Markup 
     4-- Copyright   :  (c) Lars Krueger 2012 
     5-- License     :  BSD-like 
     6-- 
     7-- Maintainer  :  lars_e_krueger@gmx.de 
     8-- Stability   :  experimental 
     9-- Portability :  portable 
     10-- 
     11-- Simple markup processing to generate good-looking text without  
     12-- too much character fiddling in the actual output generation.  
     13-- The module takes care of the line width, breaks text, indents items, etc. 
     14----------------------------------------------------------------------------- 
     15module Haddock.Backends.VimHelp.Markup 
     16( MarkupItem (..) 
     17, Markup 
     18, ppRender 
     19, ppRuler 
     20) where 
     21 
     22 
     23import Data.Char 
     24 
     25 
     26-- | Simple linear markup. Each item influences the render state. 
     27data MarkupItem 
     28  = MiBreakable String        -- ^ Normal text, will be word-wrapped 
     29  | MiNonBreakable String     -- ^ String to be treated as one character 
     30  | MiNothing                 -- ^ Empty string to cope with maybes 
     31  | MiParagraph               -- ^ A paragraph begins 
     32  | MiIndent Int              -- ^ Change the indentation 
     33  | MiLineBreak               -- ^ A mandatory linebreak 
     34  | MiPushIndent0             -- ^ Store the indent level on the stack, set to 0 
     35  | MiPushIndent              -- ^ Store the indent level on the stack 
     36  | MiNextIndent Int          -- ^ Set the indent of the next line 
     37  | MiPopIndent               -- ^ Get the former indent level from the stack 
     38  | MiSpaceBeforeLetter       -- ^ If the next item begins with a letter, put 
     39                              -- a space here 
     40  | MiVerbatim Bool           -- ^ Do not manipulate the text 
     41  deriving (Eq) 
     42 
     43 
     44-- | A list of markup items. 
     45type Markup = [MarkupItem] 
     46 
     47 
     48-- | The width of the page in characters 
     49ppTextWidth :: Int 
     50ppTextWidth = 80 
     51 
     52 
     53-- | Render state. 
     54data RenderState = RenderState 
     55    { rsIndent      :: Int          -- ^ Number of characters to indent 
     56    , rsChars       :: Int          -- ^ Number of characters in line 
     57    , rsIndStack    :: [Int]        -- ^ Indent stack 
     58    , rsSpcBefLet   :: Bool         -- ^ Space before letter flag 
     59    , rsVerbatim    :: Bool         -- ^ Do not manipulate space 
     60    } 
     61 
     62 
     63-- | Result of a render function. 
     64type RenderResult a = (RenderState,a) 
     65 
     66 
     67-- | Convert markup into a string for printing. The final render state is not 
     68-- made available, hence you can't pass it around. 
     69ppRender :: Markup -> String 
     70ppRender = concat . renderItems (RenderState 0 0 [] False False) 
     71 
     72 
     73-- | Render the items and update the state. 
     74renderItems :: RenderState -> Markup -> [String] 
     75renderItems _ [] = [] 
     76renderItems rs (it:its) =  
     77  let (nrs,mbLine) = render rs it 
     78  in case mbLine of 
     79          Nothing -> renderItems nrs its 
     80          Just l  -> l:renderItems nrs its 
     81 
     82 
     83-- | Begin a new line with correct identation and place the given string at  
     84newLine :: RenderState -> String -> RenderResult String 
     85newLine rs s =  
     86  let ls = length s 
     87  in ( rs { rsSpcBefLet = False 
     88          , rsChars = ls } 
     89     , "\n" ++ replicate (rsIndent rs) ' ' ++ s 
     90     ) 
     91 
     92 
     93-- | Append string, but do not break the line. Handle optional spaces. 
     94appendLine :: RenderState -> String -> RenderResult String 
     95appendLine rs str =  
     96  let s = if rsSpcBefLet rs 
     97             then case str of 
     98                       c1:_ -> if canHazSpace c1 
     99                                  then ' ' : str 
     100                                  else str 
     101                       _ -> str 
     102             else str 
     103      ls = length s 
     104  in ( rs { rsChars = ls + rsChars rs 
     105          , rsSpcBefLet = False} 
     106     , s  
     107     ) 
     108  where 
     109  canHazSpace c = isLetter c || (c `elem` "*(|") 
     110 
     111 
     112-- | Append string, but open a new line if the string would not fit. 
     113appendWord :: RenderState -> String -> RenderResult String 
     114appendWord rs s =  
     115  let ls = length s 
     116  in if (rsIndent rs + rsChars rs + ls) >= ppTextWidth 
     117       then newLine rs s 
     118       else appendLine rs s 
     119 
     120 
     121-- | Helper for output-generating markup items. 
     122just2 :: RenderResult a -> RenderResult (Maybe a) 
     123just2 (rs,a) = (rs, Just a) 
     124 
     125 
     126-- | Helper for state-changing markup items. 
     127nothing2 :: RenderState -> RenderResult (Maybe a) 
     128nothing2 rs = (rs,Nothing) 
     129 
     130 
     131-- | Render a single markup item to a single sting or just change the state. 
     132render :: RenderState -> MarkupItem -> RenderResult (Maybe String) 
     133render rs (MiNothing) = nothing2 rs 
     134render rs (MiSpaceBeforeLetter) = nothing2 $ rs { rsSpcBefLet = True } 
     135render rs (MiVerbatim v) = nothing2 $ rs { rsVerbatim = v } 
     136render rs (MiNonBreakable s) = just2 $ appendWord rs s 
     137render rs (MiParagraph) = just2 $ newLine rs "  " 
     138render rs (MiLineBreak) = just2 $ newLine (rs { rsSpcBefLet = False }) "" 
     139 
     140render rs (MiIndent ind)  
     141  = just2 $ newLine  
     142      (rs  
     143        { rsSpcBefLet = False 
     144        , rsIndent = max 0 $ rsIndent rs + ind } 
     145      )  
     146      "" 
     147 
     148-- | Linebreak the string or copy if verbatim is on. Since we need to pass the 
     149-- render state through it and we need the final render state as a return 
     150-- value, this works with an intermediate list of (RenderState,String) tuples. 
     151-- Since most items here are short, this should not result in much memory 
     152-- overhead 
     153render rs (MiBreakable s) =  
     154  -- switch functions for verbatim mode 
     155  let (wrds,aw,al,alp) =  
     156        if rsVerbatim rs  
     157          then (lines, appendLine, newLine, "") 
     158          else (words, appendWord, appendLine, " ") 
     159      rs_lns = mapState (processWord aw al alp) rs $ wrds s 
     160  in case rs_lns of 
     161          [] -> nothing2 rs 
     162          lns -> just2 (fst $ last lns, concatMap snd lns) 
     163  where 
     164  processWord aw al alp rs1 w 
     165    = let (rs2,l1) = aw rs1 w 
     166          (rs3,l2) = al rs2 alp 
     167      in (rs3,l1++l2) 
     168 
     169  mapState _ _ [] = [] 
     170  mapState fun rs1 [a] = [fun rs1 a] 
     171  mapState fun rs1 (a:as) = let rs2b@(rs2,_) = fun rs1 a 
     172                            in rs2b:mapState fun rs2 as 
     173 
     174render rs (MiPushIndent0) = nothing2 $ 
     175  rs { rsSpcBefLet = False 
     176     , rsIndent = 0 
     177     , rsIndStack = rsIndent rs : rsIndStack rs} 
     178 
     179render rs (MiPushIndent) = nothing2 $ 
     180  rs { rsIndStack = rsIndent rs : rsIndStack rs} 
     181 
     182render rs (MiNextIndent ind) = nothing2 $ 
     183  rs { rsSpcBefLet = False 
     184      , rsIndent = max 0 $ rsIndent rs + ind } 
     185 
     186render rs (MiPopIndent) = nothing2 $ 
     187  case rsIndStack rs of 
     188       [] -> rs 
     189       (i:rest) -> rs { rsSpcBefLet = False 
     190                      , rsIndent = i 
     191                      , rsIndStack = rest } 
     192 
     193 
     194-- | Draw a horizontal line over the whole text width. 
     195ppRuler :: Char -> Markup 
     196ppRuler c =  
     197  [ MiPushIndent0 
     198  , MiNonBreakable $ replicate ppTextWidth c 
     199  , MiPopIndent 
     200  ] 
  • (a) /dev/null vs. (b) b/src/Haddock/Backends/VimHelp/Utils.hs

    diff --git a/src/Haddock/Backends/VimHelp/Utils.hs b/src/Haddock/Backends/VimHelp/Utils.hs
    new file mode 100644
    index 0000000..9dd0bce
    a b  
     1----------------------------------------------------------------------------- 
     2-- | 
     3-- Module      :  Haddock.Backends.VimHelp.Utils 
     4-- Copyright   :  (c) Lars Krueger 2012 
     5-- License     :  BSD-like 
     6-- 
     7-- Maintainer  :  lars_e_krueger@gmx.de 
     8-- Stability   :  experimental 
     9-- Portability :  portable 
     10----------------------------------------------------------------------------- 
     11module Haddock.Backends.VimHelp.Utils 
     12( ppDocName 
     13, ppBinder 
     14, ppBinderConstr 
     15, ppPlainName 
     16, parenList 
     17, dcolon 
     18, parens 
     19, brackets 
     20, pabrackets 
     21, braces 
     22, (<+>) 
     23, (<?>) 
     24, dot 
     25, darrow 
     26, arrow 
     27, equals 
     28, space 
     29, comma 
     30, ubxParenList 
     31, ubxparens 
     32, maybeDocSection 
     33, maybeIndentedDocSection  
     34, quote 
     35, ppRenderDoc 
     36, ppLink 
     37, ppRef 
     38, ppListItem 
     39) where 
     40 
     41import Haddock.Backends.VimHelp.Markup 
     42 
     43import Haddock.GhcUtils 
     44import Haddock.Types 
     45 
     46import Module 
     47import Name 
     48 
     49import Data.List 
     50import Text.Printf 
     51 
     52 
     53-- | Generate a link to something (similar to <href>) 
     54ppLink :: String -> MarkupItem 
     55ppLink s = MiNonBreakable $ "|" ++ s ++ "|" 
     56 
     57 
     58-- | Generate an anchor for something (similar to <a>) 
     59ppRef :: String -> MarkupItem 
     60ppRef s = MiNonBreakable $ "*" ++ s ++ "*" 
     61 
     62 
     63-- | Markup for a DocName. Tries to be smart about built-in things. 
     64ppDocName :: DocName -> MarkupItem 
     65ppDocName (Undocumented name) = MiNonBreakable $ getOccString name 
     66ppDocName (Documented name mdl) =  
     67  if isBuiltinModule mdl 
     68     then MiNonBreakable nameStr 
     69     else ppLink $ mdlStr ++ "." ++ nameStr 
     70  where 
     71  mdlStr = moduleString mdl 
     72  nameStr = getOccString name 
     73 
     74 
     75-- | Check if module if built-in 
     76isBuiltinModule :: Module -> Bool 
     77isBuiltinModule mdl = modulePackageId mdl `elem` 
     78  [ primPackageId 
     79  , integerPackageId 
     80  , basePackageId 
     81  , rtsPackageId 
     82  , thPackageId 
     83  , dphSeqPackageId 
     84  , dphParPackageId 
     85  , mainPackageId 
     86  ] 
     87 
     88 
     89-- | Generate a reference to this DocName, if possible 
     90ppBinder :: DocName -> MarkupItem 
     91ppBinder (Undocumented n) = MiNonBreakable $ getOccString n 
     92ppBinder (Documented n m) = ppRef $ moduleString m ++ "." ++ getOccString n 
     93 
     94 
     95-- | Generate a reference to this DocName, if possible. Special case for 
     96-- constructors that may have the same name as their type. 
     97ppBinderConstr :: DocName -> MarkupItem 
     98ppBinderConstr (Undocumented n) = MiNonBreakable $ getOccString n 
     99ppBinderConstr (Documented n m) = ppRef $  
     100  "Constructor:" ++ moduleString m ++ "." ++ getOccString n 
     101 
     102 
     103-- | DocName to regular string. 
     104ppPlainName :: DocName -> MarkupItem 
     105ppPlainName (Undocumented n) = MiNonBreakable $ getOccString n 
     106ppPlainName (Documented n _) = MiNonBreakable $ getOccString n 
     107 
     108 
     109parenList :: [Markup] -> Markup 
     110parenList = parens . intercalate [comma] 
     111 
     112 
     113dcolon :: MarkupItem 
     114dcolon = MiNonBreakable "::" 
     115 
     116 
     117dot :: MarkupItem 
     118dot = MiNonBreakable "." 
     119 
     120 
     121darrow :: MarkupItem 
     122darrow = MiNonBreakable "=>" 
     123 
     124 
     125arrow :: MarkupItem 
     126arrow = MiNonBreakable "->" 
     127 
     128 
     129equals :: MarkupItem 
     130equals = MiNonBreakable "=" 
     131 
     132 
     133space :: MarkupItem 
     134space = MiNonBreakable " " 
     135 
     136 
     137comma :: MarkupItem 
     138comma = MiNonBreakable "," 
     139 
     140 
     141ubxparens :: Markup -> Markup 
     142ubxparens       = enclose "(#"  "#)" 
     143 
     144 
     145dquote :: Markup -> Markup 
     146dquote          = enclose "''"  "''" 
     147 
     148 
     149quote :: Markup -> Markup 
     150quote           = enclose "'"  "'" 
     151 
     152 
     153parens :: Markup -> Markup 
     154parens          = enclose "("  ")" 
     155 
     156 
     157brackets :: Markup -> Markup 
     158brackets        = enclose "["  "]" 
     159 
     160 
     161pabrackets :: Markup -> Markup 
     162pabrackets      = enclose "[:" ":]" 
     163 
     164 
     165braces :: Markup -> Markup 
     166braces          = enclose "{"  "}" 
     167 
     168 
     169enclose :: String -> String -> Markup -> Markup 
     170enclose a b h =  
     171  (MiNonBreakable a : makeNonBreakable h) ++ [MiNonBreakable b] 
     172  where 
     173  makeNonBreakable = map toNonBreakable 
     174  toNonBreakable :: MarkupItem -> MarkupItem 
     175  toNonBreakable (MiBreakable s) = MiNonBreakable s 
     176  toNonBreakable i = i 
     177 
     178 
     179infixr 8 <+> 
     180(<+>) :: Markup-> Markup-> Markup 
     181a <+> b = a ++ (MiNonBreakable " " : b) 
     182 
     183 
     184infixr 8 <?> 
     185(<?>) :: Markup-> Markup-> Markup 
     186a <?> b = a ++ (MiSpaceBeforeLetter : b) 
     187 
     188 
     189ubxParenList :: [Markup] -> Markup 
     190ubxParenList = ubxparens . intercalate [comma] 
     191 
     192 
     193maybeDocSection :: Maybe (Doc DocName) -> Markup 
     194maybeDocSection Nothing = [] 
     195maybeDocSection (Just s) = ppRenderDoc s 
     196 
     197 
     198maybeIndentedDocSection :: Maybe (Doc DocName) -> Markup 
     199maybeIndentedDocSection Nothing = [] 
     200maybeIndentedDocSection (Just s) =  
     201  (MiPushIndent : MiIndent 2 : dropParagraph ( ppRenderDoc s)) 
     202  ++  
     203  [MiPopIndent] 
     204 
     205 
     206ppRenderDoc :: Doc DocName -> Markup 
     207ppRenderDoc DocEmpty                = [] 
     208ppRenderDoc (DocPic _)              = [] 
     209ppRenderDoc (DocAppend a b)         = ppRenderDoc a ++ ppRenderDoc b 
     210ppRenderDoc (DocString s)           = [MiBreakable s] 
     211ppRenderDoc (DocParagraph d)        = MiParagraph:ppRenderDoc d 
     212ppRenderDoc (DocModule m)           = [ppLink m] 
     213ppRenderDoc (DocEmphasis d)         = ppRenderDoc d 
     214ppRenderDoc (DocMonospaced d)       = ppRenderDoc d 
     215ppRenderDoc (DocURL s)              = [MiNonBreakable s] 
     216ppRenderDoc (DocAName s)            = [MiNonBreakable s] 
     217 
     218ppRenderDoc (DocExamples ex)        = concatMap renderEx ex 
     219  where 
     220  renderEx :: Example -> Markup 
     221  renderEx (Example exm res) =  
     222    beginCodeBlock 
     223    ++ [ 
     224    MiNonBreakable (">>> " ++ exm), 
     225    MiLineBreak]  
     226    ++ concatMap (\a -> [MiNonBreakable a, MiLineBreak]) res 
     227    ++ endCodeBlock 
     228 
     229ppRenderDoc (DocCodeBlock d)        =  
     230  beginCodeBlock ++ ppRenderDoc d ++ endCodeBlock 
     231 
     232-- Show the first identifier only 
     233ppRenderDoc (DocIdentifier ds)      = [ppDocName $ head ds, MiSpaceBeforeLetter] 
     234 
     235ppRenderDoc (DocUnorderedList ds)   =  
     236  ppList (ppListItemDoc False [MiNonBreakable "-"]) ds 
     237 
     238ppRenderDoc (DocOrderedList ds)     =  
     239  ppList (\(d,i) -> ppListItemDoc False [MiNonBreakable $ printf "%2d." i] d)  
     240  $  
     241  zip ds [(1::Int)..] 
     242 
     243ppRenderDoc (DocDefList ds)         =  
     244  ppList (\(c,d) -> ppListItemDoc True (dquote (ppRenderDoc c)) d) ds 
     245 
     246 
     247ppList :: (a -> Markup) -> [a] -> Markup 
     248ppList f ds = concatMap f ds ++ [MiLineBreak] 
     249 
     250 
     251ppListItem :: Bool -> Markup -> Markup -> Markup 
     252ppListItem _ bull [] =  
     253  [MiPushIndent,MiLineBreak,MiNextIndent 2]  
     254  ++ bull  
     255  ++ [MiPopIndent] 
     256ppListItem doBreak bull desc =  
     257  [MiPushIndent,MiLineBreak,MiNextIndent 2]  
     258  ++ bull  
     259  ++ ((if doBreak then MiLineBreak else MiSpaceBeforeLetter):dropParagraph desc) 
     260  ++ [MiPopIndent] 
     261 
     262 
     263ppListItemDoc :: Bool -> Markup -> Doc DocName -> Markup 
     264ppListItemDoc doBreak bull desc =  
     265  ppListItem doBreak bull $ dropParagraph $ ppRenderDoc desc 
     266 
     267 
     268dropParagraph :: Markup -> Markup 
     269dropParagraph = dropWhile (== MiParagraph) 
     270 
     271 
     272beginCodeBlock :: Markup 
     273beginCodeBlock =  
     274    [ MiPushIndent0 
     275    , MiLineBreak 
     276    , MiNonBreakable ">"  
     277    , MiPopIndent 
     278    , MiPushIndent0 
     279    , MiIndent 2 
     280    , MiLineBreak 
     281    , MiVerbatim True 
     282    ] 
     283 
     284 
     285endCodeBlock :: Markup 
     286endCodeBlock =  
     287    [ MiVerbatim False 
     288    , MiPopIndent 
     289    , MiPushIndent0 
     290    , MiLineBreak 
     291    , MiNonBreakable "<" 
     292    , MiPopIndent 
     293    ] 
  • src/Haddock/Options.hs

    diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
    index 4e42fd3..c64cf69 100644
    a b  
    5858  | Flag_WikiModuleURL String 
    5959  | Flag_WikiEntityURL String 
    6060  | Flag_LaTeX 
     61  | Flag_VimHelp 
    6162  | Flag_LaTeXStyle String 
    6263  | Flag_Help 
    6364  | Flag_Verbosity String 
     
    101102      "output in HTML (XHTML 1.0)", 
    102103    Option []  ["latex"]  (NoArg Flag_LaTeX) "use experimental LaTeX rendering", 
    103104    Option []  ["latex-style"]  (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", 
     105    Option []  ["vimhelp"]  (NoArg Flag_VimHelp) "use experimental VIM help file rendering", 
    104106    Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", 
    105107    Option []  ["hoogle"]     (NoArg Flag_Hoogle) 
    106108      "output for Hoogle", 
  • src/Main.hs

    diff --git a/src/Main.hs b/src/Main.hs
    index 0a3c9ff..724b78f 100644
    a b  
    2121import Haddock.Backends.Xhtml 
    2222import Haddock.Backends.Xhtml.Themes (getThemes) 
    2323import Haddock.Backends.LaTeX 
     24import Haddock.Backends.VimHelp 
    2425import Haddock.Backends.Hoogle 
    2526import Haddock.Interface 
    2627import Haddock.Lex 
     
    142143    renderStep flags packages ifaces 
    143144 
    144145  else do 
    145     when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ 
     146    when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX, Flag_VimHelp]) flags) $ 
    146147      throwE "No input file(s)." 
    147148 
    148149    -- Get packages supplied with --read-interface. 
     
    247248    ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style 
    248249                  libDir 
    249250 
     251  when (Flag_VimHelp `elem` flags) $  
     252    ppVimHelp visibleIfaces odir 
     253 
    250254 
    251255------------------------------------------------------------------------------- 
    252256-- * Reading and dumping interface files 
     
    386390  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) 
    387391        && Flag_LaTeX `elem` flags) $ 
    388392    throwE "--latex cannot be used with --gen-index or --gen-contents" 
     393 
     394  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) 
     395        && Flag_VimHelp `elem` flags) $ 
     396    throwE "--vimhelp cannot be used with --gen-index or --gen-contents" 
    389397  where 
    390398    byeVersion = bye $ 
    391399      "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" 
  • src/Haddock/Backends/VimHelp/Decl.hs

    -- 
    1.7.8.6
    
    
    From 2dc9deed1e9cef639d9f0f328f4348aefc29c295 Mon Sep 17 00:00:00 2001
    From: Lars Krueger <lars_e_krueger@gmx.de>
    Date: Wed, 19 Sep 2012 20:59:32 +0200
    Subject: [PATCH 2/6] partial fixes for new api
    
    
    Signed-off-by: Lars Krueger <lars_e_krueger@gmx.de>
    ---
     src/Haddock/Backends/VimHelp/Decl.hs  |   46 ++++++++++++++------------------
     src/Haddock/Backends/VimHelp/Utils.hs |    4 +-
     2 files changed, 22 insertions(+), 28 deletions(-)
    
    diff --git a/src/Haddock/Backends/VimHelp/Decl.hs b/src/Haddock/Backends/VimHelp/Decl.hs
    index 9b7a69f..504041c 100644
    a b  
    5454    | Nothing <- tcdTyPats d     -> ppTySyn (mbDoc, fnArgsDoc) d 
    5555    | Just _  <- tcdTyPats d     -> ppTyInst False mbDoc d 
    5656  TyClD d@(ClassDecl {})         -> ppClassDecl instances mbDoc subdocs d 
    57   SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig (mbDoc, fnArgsDoc) n t 
     57  SigD (TypeSig lnames (L _ t))  -> ppFunSig (mbDoc, fnArgsDoc) (map unLoc lnames) t 
    5858  ForD d                         -> ppFor (mbDoc, fnArgsDoc) d 
    5959  InstD _                        -> [] 
    6060  _                              -> error "declaration not supported by ppDecl" 
    6161 
    6262 
    6363-- | Generate markup for function signature. 
    64 ppFunSig :: DocForDecl DocName -> DocName -> HsType DocName -> Markup 
    65 ppFunSig doc docname typ = 
    66   ppTypeOrFunSig typ doc 
    67     (ppTypeSig docname typ, [ppBinder docname], [dcolon]) 
     64ppFunSig :: DocForDecl DocName -> [DocName] -> HsType DocName -> Markup 
     65ppFunSig doc docnames typ = 
     66  concatMap (\docname ->  
     67    ppTypeOrFunSig typ doc 
     68      (ppTypeSig docname typ, [ppBinder docname], [dcolon]) 
     69    ) docnames 
    6870 
    6971 
    7072ppTypeOrFunSig :: HsType DocName  
     
    111113 
    112114 
    113115ppFor :: DocForDecl DocName -> ForeignDecl DocName -> Markup 
    114 ppFor doc (ForeignImport (L _ name) (L _ typ) _) = ppFunSig doc name typ 
     116ppFor doc (ForeignImport (L _ name) (L _ typ) _ _) = ppFunSig doc [name] typ 
    115117ppFor _ _ = error "ppFor" 
    116118 
    117119 
     
    159161  ) <+> 
    160162  ppTyClBinderWithVars decl <+> 
    161163  case tcdKind decl of 
    162     Just kind -> [dcolon,space] ++ ppKind kind 
     164    Just kind -> [dcolon,space] ++ ppKind (unLoc kind) 
    163165    Nothing -> [] 
    164166 
    165167 
     
    278280ppContextNoArrow cxt  = ppHsContext (map unLoc cxt) 
    279281 
    280282 
    281 ppContextNoLocs :: [HsPred DocName] -> Markup 
     283ppContextNoLocs :: [HsType DocName] -> Markup 
    282284ppContextNoLocs []  = [] 
    283285ppContextNoLocs cxt = ppHsContext cxt <+> [darrow] 
    284286 
     
    287289ppContext cxt = ppContextNoLocs (map unLoc cxt) 
    288290 
    289291 
    290 ppHsContext :: [HsPred DocName] -> Markup 
     292ppHsContext :: [HsType DocName] -> Markup 
    291293ppHsContext []  = [] 
    292 ppHsContext [p] = ppPred p 
    293 ppHsContext cxt = parenList (intersperse [space] $ map ppPred cxt) 
    294  
    295  
    296 ppPred :: HsPred DocName -> Markup 
    297 ppPred (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) 
    298 ppPred (HsEqualP t1 t2) = ppLType t1 <+> [MiNonBreakable "~"] <+> ppLType t2 
    299 ppPred (HsIParam (IPName n) t) =  
    300   [MiNonBreakable "?", ppDocName n, space, dcolon] <+> ppLType t 
     294ppHsContext [p] = ppType p 
     295ppHsContext cxt = parenList (intersperse [space] $ map ppType cxt) 
    301296 
    302297 
    303298------------------------------------------------------------------------------- 
     
    305300------------------------------------------------------------------------------- 
    306301 
    307302 
    308 ppClassHdr :: Located [LHsPred DocName]  
     303ppClassHdr :: Located [LHsType DocName]  
    309304           -> DocName 
    310305           -> [Located (HsTyVarBndr DocName)]  
    311306           -> [Located ([DocName], [DocName])] 
     
    504499-------------------------------------------------------------------------------- 
    505500 
    506501 
    507 ppKind :: Outputable a => a -> Markup 
    508 ppKind k = [MiNonBreakable $ showSDoc (ppr k)] 
     502ppKind :: HsKind DocName -> Markup 
     503ppKind k = pprMonoTy pRECTOP k 
    509504 
    510505 
    511506 -- Unpacked args is an implementation detail, so we just show the strictness 
     
    515510ppBang _        = [MiNonBreakable "!" ] 
    516511 
    517512 
    518 tupleParens :: Boxity -> [Markup] -> Markup 
    519 tupleParens Boxed   = parenList 
    520 tupleParens Unboxed = ubxParenList 
     513tupleParens :: HsTupleSort -> [Markup] -> Markup 
     514tupleParens _ = parenList 
    521515 
    522516 
    523517-------------------------------------------------------------------------------- 
     
    577571pprMonoTy _         (HsBangTy b ty)      = ppBang b ++ ppLParendType ty 
    578572pprMonoTy ctxt_prec (HsFunTy ty1 ty2)    = pprFunTy ctxt_prec ty1 ty2  
    579573pprMonoTy _         (HsTupleTy con tys)  = tupleParens con (map ppLType tys) 
    580 pprMonoTy _         (HsPredTy p)         = parens (ppPred p) 
    581 pprMonoTy _         (HsNumTy n)          = [MiNonBreakable (show n)] -- generics only 
     574-- pprMonoTy _         (HsPredTy p)         = parens (ppPred p) 
     575-- pprMonoTy _         (HsNumTy n)          = [MiNonBreakable (show n)] -- generics only 
    582576pprMonoTy ctxt_prec (HsParTy ty)         = pprMonoLty ctxt_prec ty  
    583577pprMonoTy ctxt_prec (HsDocTy ty _)       = pprMonoLty ctxt_prec ty  
    584578pprMonoTy _         (HsSpliceTy {})      = error "pprMonoTy HsSpliceTy" 
  • src/Haddock/Backends/VimHelp/Utils.hs

    diff --git a/src/Haddock/Backends/VimHelp/Utils.hs b/src/Haddock/Backends/VimHelp/Utils.hs
    index 9dd0bce..c4be0d8 100644
    a b  
    229229ppRenderDoc (DocCodeBlock d)        =  
    230230  beginCodeBlock ++ ppRenderDoc d ++ endCodeBlock 
    231231 
    232 -- Show the first identifier only 
    233 ppRenderDoc (DocIdentifier ds)      = [ppDocName $ head ds, MiSpaceBeforeLetter] 
     232ppRenderDoc (DocIdentifier d)      = [ppDocName d, MiSpaceBeforeLetter] 
     233ppRenderDoc (DocIdentifierUnchecked (mn,on))      = [MiNonBreakable $ moduleNameString mn ++ "." ++ occNameString on, MiSpaceBeforeLetter] 
    234234 
    235235ppRenderDoc (DocUnorderedList ds)   =  
    236236  ppList (ppListItemDoc False [MiNonBreakable "-"]) ds 
  • src/Haddock/Backends/VimHelp/Utils.hs

    -- 
    1.7.8.6
    
    
    From 7bf7ff77738b8c69893e85a8bd86ef2a4693916d Mon Sep 17 00:00:00 2001
    From: Lars Krueger <lars_e_krueger@gmx.de>
    Date: Fri, 28 Sep 2012 20:44:41 +0200
    Subject: [PATCH 3/6] added tilde function
    
    
    Signed-off-by: Lars Krueger <lars_e_krueger@gmx.de>
    ---
     src/Haddock/Backends/VimHelp/Utils.hs |    5 +++++
     1 files changed, 5 insertions(+), 0 deletions(-)
    
    diff --git a/src/Haddock/Backends/VimHelp/Utils.hs b/src/Haddock/Backends/VimHelp/Utils.hs
    index c4be0d8..4a01337 100644
    a b  
    1515, ppPlainName 
    1616, parenList 
    1717, dcolon 
     18, tilde 
    1819, parens 
    1920, brackets 
    2021, pabrackets 
     
    114115dcolon = MiNonBreakable "::" 
    115116 
    116117 
     118tilde :: MarkupItem 
     119tilde = MiNonBreakable "~" 
     120 
     121 
    117122dot :: MarkupItem 
    118123dot = MiNonBreakable "." 
    119124 
  • src/Haddock/Backends/VimHelp/Decl.hs

    -- 
    1.7.8.6
    
    
    From 5016d07272970c25cc29566a5a314f047c62899f Mon Sep 17 00:00:00 2001
    From: Lars Krueger <lars_e_krueger@gmx.de>
    Date: Fri, 28 Sep 2012 20:45:18 +0200
    Subject: [PATCH 4/6] compiles now with 7.4.2
    
    
    Signed-off-by: Lars Krueger <lars_e_krueger@gmx.de>
    ---
     src/Haddock/Backends/VimHelp/Decl.hs |   32 ++++++++++++++++++++++----------
     1 files changed, 22 insertions(+), 10 deletions(-)
    
    diff --git a/src/Haddock/Backends/VimHelp/Decl.hs b/src/Haddock/Backends/VimHelp/Decl.hs
    index 504041c..ab6cb32 100644
    a b  
    2424import Haddock.GhcUtils 
    2525import Haddock.Types 
    2626 
    27 import BasicTypes            ( IPName(..), Boxity(..) ) 
    2827import GHC 
    2928import Name 
    30 import Outputable            ( ppr, showSDoc, Outputable ) 
     29import BasicTypes            ( ipNameName ) 
    3130 
    3231import           Control.Monad         ( join ) 
    3332import qualified Data.Map as Map 
     
    330329            -> TyClDecl DocName  
    331330            -> Markup 
    332331ppClassDecl instances mbDoc subdocs 
    333         (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) =  
     332        (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) =  
    334333  classheader  
    335334  ++ maybeDocSection mbDoc 
    336335  ++ atBit  
     
    347346                      | at <- ats 
    348347                      , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] 
    349348 
    350     methodBit = subMethods [ ppFunSig doc n typ 
    351                       | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs 
    352                       , let doc = lookupAnySubdoc n subdocs ] 
     349    methodBit = subMethods [ ppFunSig doc names typ 
     350                      | L _ (TypeSig lnames (L _ typ)) <- lsigs 
     351                      , let doc = lookupAnySubdoc (head names) subdocs 
     352                            names = map unLoc lnames] 
    353353 
    354354    instancesBit = ppInstances instances 
    355355 
     
    571571pprMonoTy _         (HsBangTy b ty)      = ppBang b ++ ppLParendType ty 
    572572pprMonoTy ctxt_prec (HsFunTy ty1 ty2)    = pprFunTy ctxt_prec ty1 ty2  
    573573pprMonoTy _         (HsTupleTy con tys)  = tupleParens con (map ppLType tys) 
    574 -- pprMonoTy _         (HsPredTy p)         = parens (ppPred p) 
    575 -- pprMonoTy _         (HsNumTy n)          = [MiNonBreakable (show n)] -- generics only 
    576574pprMonoTy ctxt_prec (HsParTy ty)         = pprMonoLty ctxt_prec ty  
    577575pprMonoTy ctxt_prec (HsDocTy ty _)       = pprMonoLty ctxt_prec ty  
    578576pprMonoTy _         (HsSpliceTy {})      = error "pprMonoTy HsSpliceTy" 
     577#if __GLASGOW_HASKELL__ == 612 
     578pprMonoTy _         (HsSpliceTyOut {})   = error "pprMonoTy HsQuasiQuoteTy" 
     579#else 
    579580pprMonoTy _         (HsQuasiQuoteTy {})  = error "pprMonoTy HsQuasiQuoteTy" 
     581#endif 
    580582pprMonoTy _         (HsCoreTy {})        = error "pprMonoTy HsCoreTy" 
    581583pprMonoTy _         (HsRecTy {})         = error "pprMonoTy HsRecTy" 
     584pprMonoTy _         (HsExplicitListTy _ tys) = quote $ brackets $ intercalate [comma] $ map ppLType tys 
     585pprMonoTy _         (HsExplicitTupleTy _ tys) = quote $ parenList $ map ppLType tys 
     586pprMonoTy _         (HsWrapTy {})        = error "ppr_mono_ty HsWrapTy" 
     587 
     588pprMonoTy ctxt_prec (HsEqTy ty1 ty2) 
     589  = maybeParen ctxt_prec pRECOP $ 
     590    pprMonoLty pRECOP ty1 <+> [tilde] <+> pprMonoLty pRECOP ty2 
    582591 
    583592pprMonoTy ctxt_prec (HsForAllTy expl tvs ctxt ty) =  
    584593  maybeParen ctxt_prec pRECFUN $ 
     
    588597  [ppDocName name, MiSpaceBeforeLetter] 
    589598 
    590599pprMonoTy _         (HsKindSig ty kind)  =  
    591   parens (pprMonoLty pRECTOP ty <+> [dcolon] <+> ppKind kind) 
     600  parens (pprMonoLty pRECTOP ty <+> [dcolon] <+> (ppKind $ unLoc kind)) 
    592601 
    593602pprMonoTy _         (HsPArrTy ty)        =  
    594603  pabrackets (pprMonoLty pRECTOP ty) 
    595604 
     605pprMonoTy _         (HsIParamTy n ty)   =  
     606  brackets $ [ppDocName (ipNameName n)] <+> [dcolon] <+> pprMonoLty pRECTOP ty 
     607 
    596608pprMonoTy ctxt_prec (HsAppTy fun_ty arg_ty) =  
    597609  maybeParen ctxt_prec pRECCON $ 
    598610    pprMonoLty pRECFUN fun_ty ++ pprMonoLty pRECCON arg_ty 
    599611 
    600 pprMonoTy ctxt_prec (HsOpTy ty1 op ty2) =  
     612pprMonoTy ctxt_prec (HsOpTy ty1 (_,op) ty2) =  
    601613  maybeParen ctxt_prec pRECFUN $ 
    602614    pprMonoLty pRECOP ty1 <+> ppr_op <+> pprMonoLty pRECOP ty2  
    603615  where 
  • src/Main.hs

    -- 
    1.7.8.6
    
    
    From 7bdb2ba16065e2defc0b70edcdd545a548aa0574 Mon Sep 17 00:00:00 2001
    From: Lars Krueger <lars_e_krueger@gmx.de>
    Date: Fri, 28 Sep 2012 22:10:41 +0200
    Subject: [PATCH 5/6] read themes only in html related modes
    
    
    Signed-off-by: Lars Krueger <lars_e_krueger@gmx.de>
    ---
     src/Main.hs |    4 +++-
     1 files changed, 3 insertions(+), 1 deletions(-)
    
    diff --git a/src/Main.hs b/src/Main.hs
    index 724b78f..ef5b921 100644
    a b  
    218218 
    219219  libDir   <- getHaddockLibDir flags 
    220220  prologue <- getPrologue flags 
    221   themes   <- getThemes libDir flags >>= either bye return 
    222221 
    223222  when (Flag_GenIndex `elem` flags) $ do 
     223    themes   <- getThemes libDir flags >>= either bye return 
    224224    ppHtmlIndex odir title pkgStr 
    225225                themes opt_contents_url sourceUrls' opt_wiki_urls 
    226226                allVisibleIfaces pretty 
    227227    copyHtmlBits odir libDir themes 
    228228 
    229229  when (Flag_GenContents `elem` flags) $ do 
     230    themes   <- getThemes libDir flags >>= either bye return 
    230231    ppHtmlContents odir title pkgStr 
    231232                   themes opt_index_url sourceUrls' opt_wiki_urls 
    232233                   allVisibleIfaces True prologue pretty opt_qualification 
    233234    copyHtmlBits odir libDir themes 
    234235 
    235236  when (Flag_Html `elem` flags) $ do 
     237    themes   <- getThemes libDir flags >>= either bye return 
    236238    ppHtml title pkgStr visibleIfaces odir 
    237239                prologue 
    238240                themes sourceUrls' opt_wiki_urls 
  • haddock-rebuild-vimhelp.sh

    -- 
    1.7.8.6
    
    
    From d82e21aa28a6841dd221baa63044ca19ff117a4c Mon Sep 17 00:00:00 2001
    From: Lars Krueger <lars_e_krueger@gmx.de>
    Date: Fri, 28 Sep 2012 22:25:49 +0200
    Subject: [PATCH 6/6] More robust calls to haddock
    
    
    Signed-off-by: Lars Krueger <lars_e_krueger@gmx.de>
    ---
     haddock-rebuild-vimhelp.sh |   59 +++++++++++++++++++++++++++++---------------
     1 files changed, 39 insertions(+), 20 deletions(-)
    
    diff --git a/haddock-rebuild-vimhelp.sh b/haddock-rebuild-vimhelp.sh
    index c0c0bc5..3bd3680 100755
    a b  
    33# Script to rebuild the vimhelp from the list of installed packages 
    44 
    55workDir="$PWD/temp" 
    6 HADDOCK="$PWD/haddock/dist/build/haddock/haddock" 
    76 
     7# try to detect haddock 
     8HADDOCK= 
     9 
     10try_haddock() { 
     11  [ "x$HADDOCK" == "x" ] || return 0 
     12  HADDOCK=$1 
     13  command -v $HADDOCK > /dev/null 2>&1 
     14  [ $? -ne 0 ] || return 0 
     15  HADDOCK= 
     16} 
     17 
     18try_haddock "$PWD/haddock/dist/build/haddock/haddock" 
     19try_haddock "$PWD/dist/build/haddock/haddock" 
     20try_haddock "haddock" 
     21 
     22if [ "x$HADDOCK" == "x" ]; then 
     23  echo "haddock not found" 
     24fi 
    825 
    926# set the language to US english, UTF-8, to handle unicode correctly 
    1027export LANG=en_US.UTF-8 
     
    3350 
    3451  # Check for hidden packages 
    3552  isExposed=`ghc-pkg field $latestPkg exposed | cut -d ' ' -f 2 | head -1` 
    36   # if [ $isExposed == 'True' ]; then 
    37     echo -n "Checking for package $latestPkg ... " 
    3853 
    39     # Download the package using cabal 
    40     cabal fetch --no-dependencies $latestPkg > /dev/null 2>&1 
     54  # Download the package using cabal 
     55  echo -n "Checking for package $latestPkg ... " 
     56  cabal fetch --no-dependencies $latestPkg > /dev/null 2>&1 
    4157 
    42     if [ $? -eq 0 ] ; then 
    43       workList="$workList $pkg" 
    44       echo "OK" 
    45     else 
    46       echo "ignored" 
    47     fi 
    48   # else 
    49   #   echo "Package $pkg is hidden" 
    50   # fi 
     58  if [ $? -eq 0 ] ; then 
     59    workList="$workList $pkg" 
     60    echo "OK" 
     61  else 
     62    echo "ignored" 
     63  fi 
    5164done 
    5265 
    5366# 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' 
     
    7083  ( 
    7184    cd $workDir/src/$versionPkg 
    7285    cabal configure 
    73     cabal haddock --with-haddock=$HADDOCK --haddock-options="--vimhelp" 
     86    cabal haddock --hoogle --with-haddock=$HADDOCK --haddock-options="--vimhelp" 
     87    if [ $? -ne 0 ] ; then 
     88      echo "cabal haddock failed. Wrong haddock version?" 
     89      exit 1 
     90    fi 
    7491  ) 
     92  if [ $? -eq 0 ] ; then 
    7593  # Reading the modules and copying them 
    76   modDocDir="$workDir/src/$versionPkg/dist/doc/html/$pkg" 
    77   modList="$modDocDir/vimhelp_modules.txt" 
    78   for mod in `cat $modList`; do 
    79     cp $modDocDir/${mod}.txt $docDir/haddock_${mod}.txt 
    80   done 
     94    modDocDir="$workDir/src/$versionPkg/dist/doc/html/$pkg" 
     95    modList="$modDocDir/vimhelp_modules.txt" 
     96    for mod in `cat $modList`; do 
     97      cp $modDocDir/${mod}.txt $docDir/haddock_${mod}.txt 
     98    done 
     99  fi 
    81100done 
    82101 
    83102# Rebuild the helptags