compiler/hsSyn/HsDoc.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 module HsDoc (
   9   HsDoc(..),
  10   LHsDoc,
  11   docAppend,
  12   docParagraph,
  13   ppr_mbDoc
  14   ) where
  15
  16 #include "HsVersions.h"
  17
  18 import Outputable
  19 import SrcLoc
  20
  21 import Data.Char (isSpace)
  22
  23 data HsDoc id
  24   = DocEmpty
  25   | DocAppend (HsDoc id) (HsDoc id)
  26   | DocString String
  27   | DocParagraph (HsDoc id)
  28   | DocIdentifier [id]
  29   | DocModule String
  30   | DocEmphasis (HsDoc id)
  31   | DocMonospaced (HsDoc id)
  32   | DocUnorderedList [HsDoc id]
  33   | DocOrderedList [HsDoc id]
  34   | DocDefList [(HsDoc id, HsDoc id)]
  35   | DocCodeBlock (HsDoc id)
  36   | DocURL String
  37   | DocPic String
  38   | DocAName String
  39   deriving (Eq, Show)
  40
  41 type LHsDoc a = Located (HsDoc a)
  42
  43 instance Outputable (HsDoc a) where
  44   ppr _ = text "<document comment>"
  45
  46 ppr_mbDoc (Just doc) = ppr doc
  47 ppr_mbDoc Nothing    = empty
  48
  49 -- used to make parsing easier; we group the list items later
  50 docAppend :: HsDoc id -> HsDoc id -> HsDoc id
  51 docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
  52   = DocUnorderedList (ds1++ds2)
  53 docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
  54   = DocAppend (DocUnorderedList (ds1++ds2)) d
  55 docAppend (DocOrderedList ds1) (DocOrderedList ds2)
  56   = DocOrderedList (ds1++ds2)
  57 docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
  58   = DocAppend (DocOrderedList (ds1++ds2)) d
  59 docAppend (DocDefList ds1) (DocDefList ds2)
  60   = DocDefList (ds1++ds2)
  61 docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
  62   = DocAppend (DocDefList (ds1++ds2)) d
  63 docAppend DocEmpty d = d
  64 docAppend d DocEmpty = d
  65 docAppend d1 d2
  66   = DocAppend d1 d2
  67
  68 -- again to make parsing easier - we spot a paragraph whose only item
  69 -- is a DocMonospaced and make it into a DocCodeBlock
  70 docParagraph :: HsDoc id -> HsDoc id
  71 docParagraph (DocMonospaced p)
  72   = DocCodeBlock (docCodeBlock p)
  73 docParagraph (DocAppend (DocString s1) (DocMonospaced p))
  74   | all isSpace s1
  75   = DocCodeBlock (docCodeBlock p)
  76 docParagraph (DocAppend (DocString s1)
  77     (DocAppend (DocMonospaced p) (DocString s2)))
  78   | all isSpace s1 && all isSpace s2
  79   = DocCodeBlock (docCodeBlock p)
  80 docParagraph (DocAppend (DocMonospaced p) (DocString s2))
  81   | all isSpace s2
  82   = DocCodeBlock (docCodeBlock p)
  83 docParagraph p
  84   = DocParagraph p
  85
  86
  87 -- Drop trailing whitespace from @..@ code blocks.  Otherwise this:
  88 --
  89 --    -- @
  90 --    -- foo
  91 --    -- @
  92 --
  93 -- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
  94 -- gives an extra vertical space after the code block.  The single space
  95 -- on the final line seems to trigger the extra vertical space.
  96 --
  97 docCodeBlock :: HsDoc id -> HsDoc id
  98 docCodeBlock (DocString s)
  99   = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
 100 docCodeBlock (DocAppend l r)
 101   = DocAppend l (docCodeBlock r)
 102 docCodeBlock d = d