Ticket #215: submission_20120929_ghc-7.4.2.patch

File submission_20120929_ghc-7.4.2.patch, 68.3 kB (added by lars_e_krueger, 2 years ago)
  • .gitignore

    From cbe5ad00c011807a986ccf6875e0052cf3a593a5 Mon Sep 17 00:00:00 2001
    From: Lars Krueger <lars_e_krueger@gmx.de>
    Date: Sat, 29 Sep 2012 08:17:19 +0200
    Subject: [PATCH 1/7] merge
    
    
    Signed-off-by: Lars Krueger <lars_e_krueger@gmx.de>
    ---
     .gitignore                             |    3 +
     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, 1380 insertions(+), 1 deletions(-)
     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
    index fdf5086..086a465 100644
    a b  
    33/tests/html-tests/tests/doc-index.html.ref 
    44/tests/html-tests/tests/index-frames.html.ref 
    55/tests/html-tests/tests/index.html.ref 
     6*~ 
     7.*.sw? 
     8.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 9d6f1a9..9d97cc5 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 46f9def..35efe60 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 8c15661..cadb3c3 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 
     
    147148    renderStep flags qual packages ifaces 
    148149 
    149150  else do 
    150     when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ 
     151    when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX, Flag_VimHelp]) flags) $ 
    151152      throwE "No input file(s)." 
    152153 
    153154    -- Get packages supplied with --read-interface. 
     
    252253    ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style 
    253254                  libDir 
    254255 
     256  when (Flag_VimHelp `elem` flags) $  
     257    ppVimHelp visibleIfaces odir 
     258 
    255259 
    256260------------------------------------------------------------------------------- 
    257261-- * Reading and dumping interface files 
     
    392396  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) 
    393397        && Flag_LaTeX `elem` flags) $ 
    394398    throwE "--latex cannot be used with --gen-index or --gen-contents" 
     399 
     400  when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) 
     401        && Flag_VimHelp `elem` flags) $ 
     402    throwE "--vimhelp cannot be used with --gen-index or --gen-contents" 
    395403  where 
    396404    byeVersion = bye $ 
    397405      "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" 
  • src/Haddock/Backends/VimHelp/Decl.hs

    -- 
    1.7.8.6
    
    
    From 1b7b9be90d1ecf130ca281b13e06d0832740f25b 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/7] 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 1746be4df3a85aaedeeb34052b782cf651d779d9 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/7] 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 d8ec58f780a6bca0154b619ee08653129413fef1 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/7] 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 80ff21ba80e333b9f5a4008c916982b6c6a7425d 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/7] 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 cadb3c3..bca2e3c 100644
    a b  
    222222 
    223223  libDir   <- getHaddockLibDir flags 
    224224  prologue <- getPrologue flags 
    225   themes   <- getThemes libDir flags >>= either bye return 
    226225 
    227226  when (Flag_GenIndex `elem` flags) $ do 
     227    themes   <- getThemes libDir flags >>= either bye return 
    228228    ppHtmlIndex odir title pkgStr 
    229229                themes opt_contents_url sourceUrls' opt_wiki_urls 
    230230                allVisibleIfaces pretty 
    231231    copyHtmlBits odir libDir themes 
    232232 
    233233  when (Flag_GenContents `elem` flags) $ do 
     234    themes   <- getThemes libDir flags >>= either bye return 
    234235    ppHtmlContents odir title pkgStr 
    235236                   themes opt_index_url sourceUrls' opt_wiki_urls 
    236237                   allVisibleIfaces True prologue pretty 
     
    238239    copyHtmlBits odir libDir themes 
    239240 
    240241  when (Flag_Html `elem` flags) $ do 
     242    themes   <- getThemes libDir flags >>= either bye return 
    241243    ppHtml title pkgStr visibleIfaces odir 
    242244                prologue 
    243245                themes sourceUrls' opt_wiki_urls 
  • haddock-rebuild-vimhelp.sh

    -- 
    1.7.8.6
    
    
    From 079cc0684a112b0206e47ead9e27f1e08fd9f2fb 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/7] 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 
  • src/Haddock/Backends/VimHelp.hs

    -- 
    1.7.8.6
    
    
    From a90024a0287738b9ff953973356273d01148b4d4 Mon Sep 17 00:00:00 2001
    From: Lars Krueger <lars_e_krueger@gmx.de>
    Date: Sat, 29 Sep 2012 08:45:28 +0200
    Subject: [PATCH 7/7] fixed to use Documentation
    
    
    Signed-off-by: Lars Krueger <lars_e_krueger@gmx.de>
    ---
     src/Haddock/Backends/VimHelp.hs       |    2 +-
     src/Haddock/Backends/VimHelp/Decl.hs  |   24 ++++++++++++------------
     src/Haddock/Backends/VimHelp/Utils.hs |    6 ++++++
     3 files changed, 19 insertions(+), 13 deletions(-)
    
    diff --git a/src/Haddock/Backends/VimHelp.hs b/src/Haddock/Backends/VimHelp.hs
    index b935e4d..5acf0aa 100644
    a b  
    5050            ++ modInfotxt 
    5151            ++ ppRuler '=' 
    5252            ++ [MiLineBreak] 
    53             ++ maybeDocSection (ifaceRnDoc iface) 
     53            ++ docSection (ifaceRnDoc iface) 
    5454            ++ [MiLineBreak] 
    5555            ++ concatMap docExpIt (ifaceRnExportItems iface) 
    5656            ++ [ MiPushIndent0 
  • src/Haddock/Backends/VimHelp/Decl.hs

    diff --git a/src/Haddock/Backends/VimHelp/Decl.hs b/src/Haddock/Backends/VimHelp/Decl.hs
    index ab6cb32..d6a6224 100644
    a b  
    7373               -> (Markup, Markup, Markup)  
    7474               -> Markup 
    7575ppTypeOrFunSig typ (doc, argDocs) (pref1, pref2, sep) 
    76   | Map.null argDocs = topDeclElem pref1 $ maybeDocSection doc 
     76  | Map.null argDocs = topDeclElem pref1 $ docSection doc 
    7777  | otherwise = topDeclElem pref2 $  
    78       subArguments (do_args 0 sep typ) ++ maybeDocSection doc 
     78      subArguments (do_args 0 sep typ) ++ docSection doc 
    7979  where 
    8080    argDoc n = Map.lookup n argDocs 
    8181 
     
    164164    Nothing -> [] 
    165165 
    166166 
    167 ppTyFam :: Bool -> Maybe (Doc DocName) -> TyClDecl DocName -> Markup 
     167ppTyFam :: Bool -> Documentation DocName -> TyClDecl DocName -> Markup 
    168168ppTyFam associated mbDoc decl =  
    169   header_ ++ maybeDocSection mbDoc ++ instancesBit 
     169  header_ ++ docSection mbDoc ++ instancesBit 
    170170  where 
    171171    header_ = ppTyFamHeader associated decl 
    172172    instancesBit = ppInstances instances  
     
    189189 
    190190 
    191191ppTyInst :: Bool  
    192          -> Maybe (Doc DocName)  
     192         -> Documentation DocName 
    193193         -> TyClDecl DocName  
    194194         -> Markup 
    195 ppTyInst associated mbDoc decl = header_ ++ maybeDocSection mbDoc 
     195ppTyInst associated mbDoc decl = header_ ++ docSection mbDoc 
    196196  where 
    197197    docname = tcdName decl 
    198198    header_ = topDeclElem [ppBinder docname] (ppTyInstHeader associated decl) 
     
    324324 
    325325 
    326326ppClassDecl :: [DocInstance DocName] 
    327             -> Maybe (Doc DocName)  
     327            -> Documentation DocName 
    328328            -> [(DocName, DocForDecl DocName)] 
    329329            -> TyClDecl DocName  
    330330            -> Markup 
    331331ppClassDecl instances mbDoc subdocs 
    332332        (ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) =  
    333333  classheader  
    334   ++ maybeDocSection mbDoc 
     334  ++ docSection mbDoc 
    335335  ++ atBit  
    336336  ++ methodBit   
    337337  ++ instancesBit 
     
    377377 
    378378ppDataDecl :: [DocInstance DocName]  
    379379           -> [(DocName, DocForDecl DocName)]  
    380            -> Maybe (Doc DocName)  
     380           -> Documentation DocName 
    381381           -> TyClDecl DocName  
    382382           -> Markup 
    383383ppDataDecl instances subdocs mbDoc dataDecl =  
    384   topDeclElem header_ $ maybeDocSection mbDoc ++ constrBit ++ instancesBit   
     384  topDeclElem header_ $ docSection mbDoc ++ constrBit ++ instancesBit   
    385385  where 
    386386    cons      = tcdCons dataDecl 
    387387    resTy     = (con_res . unLoc . head) cons 
     
    463463    -- don't use "con_doc con", in case it's reconstructed from a .hi file, 
    464464    -- or also because we want Haddock to do the doc-parsing, not GHC. 
    465465    -- 'join' is in Maybe. 
    466     mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs 
     466    mbDoc = join $ fmap combineDocumentation $ fmap fst $ lookup (unLoc $ con_name con) subdocs 
    467467    mkFunTy a b = noLoc (HsFunTy a b) 
    468468 
    469469 
     
    475475    []) 
    476476  where 
    477477    -- don't use cd_fld_doc for same reason we don't use con_doc above 
    478     mbDoc = join $ fmap fst $ lookup name subdocs 
     478    mbDoc = join $ fmap combineDocumentation $ fmap fst $ lookup name subdocs 
    479479 
    480480 
    481481-- | Print the LHS of a data\/newtype declaration. 
  • src/Haddock/Backends/VimHelp/Utils.hs

    diff --git a/src/Haddock/Backends/VimHelp/Utils.hs b/src/Haddock/Backends/VimHelp/Utils.hs
    index 4a01337..b2a3dfc 100644
    a b  
    3131, ubxParenList 
    3232, ubxparens 
    3333, maybeDocSection 
     34, docSection 
    3435, maybeIndentedDocSection  
    3536, quote 
    3637, ppRenderDoc 
     
    200201maybeDocSection (Just s) = ppRenderDoc s 
    201202 
    202203 
     204docSection :: Documentation DocName -> Markup 
     205docSection = maybeDocSection . combineDocumentation 
     206 
     207 
    203208maybeIndentedDocSection :: Maybe (Doc DocName) -> Markup 
    204209maybeIndentedDocSection Nothing = [] 
    205210maybeIndentedDocSection (Just s) =  
     
    210215 
    211216ppRenderDoc :: Doc DocName -> Markup 
    212217ppRenderDoc DocEmpty                = [] 
     218ppRenderDoc (DocWarning d)          = MiNonBreakable "WARNING!" : ppRenderDoc d 
    213219ppRenderDoc (DocPic _)              = [] 
    214220ppRenderDoc (DocAppend a b)         = ppRenderDoc a ++ ppRenderDoc b 
    215221ppRenderDoc (DocString s)           = [MiBreakable s]