compiler/rename/RnHsDoc.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 RnHsDoc ( rnHaddock, rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
   9
  10 import TcRnTypes
  11 import TcRnMonad   ( RnM )
  12 import RnEnv       ( dataTcOccs, lookupGreRn_maybe )
  13 import HsSyn
  14
  15 import RdrName     ( RdrName, gre_name )
  16 import Name        ( Name )
  17 import SrcLoc      ( Located(..) )
  18 import Outputable  ( ppr, defaultUserStyle )
  19
  20
  21 rnHaddock :: HaddockModInfo RdrName -> Maybe (HsDoc RdrName)
  22           -> TcGblEnv -> RnM TcGblEnv
  23 rnHaddock module_info maybe_doc tcg_env
  24   = do  { rn_module_doc <- rnMbHsDoc maybe_doc ;
  25
  26                 -- Rename the Haddock module info
  27         ; rn_description <- rnMbHsDoc (hmi_description module_info)
  28         ; let { rn_module_info = module_info { hmi_description = rn_description } }
  29
  30         ; return (tcg_env { tcg_doc = rn_module_doc,
  31                             tcg_hmi = rn_module_info }) }
  32
  33 rnMbHsDoc :: Maybe (HsDoc RdrName) -> RnM (Maybe (HsDoc Name))
  34 rnMbHsDoc mb_doc = case mb_doc of
  35   Just doc -> do
  36     doc' <- rnHsDoc doc
  37     return (Just doc')
  38   Nothing -> return Nothing
  39
  40 rnMbLHsDoc mb_doc = case mb_doc of
  41   Just doc -> do
  42     doc' <- rnLHsDoc doc
  43     return (Just doc')
  44   Nothing -> return Nothing
  45
  46 rnLHsDoc (L pos doc) = do
  47   doc' <- rnHsDoc doc
  48   return (L pos doc')
  49
  50 ids2string []    = []
  51 ids2string (x:_) = show $ ppr x defaultUserStyle
  52
  53 rnHsDoc :: HsDoc RdrName -> RnM (HsDoc Name)
  54 rnHsDoc doc = case doc of
  55
  56   DocEmpty -> return DocEmpty
  57
  58   DocAppend a b -> do
  59     a' <- rnHsDoc a
  60     b' <- rnHsDoc b
  61     return (DocAppend a' b')
  62
  63   DocString str -> return (DocString str)
  64
  65   DocParagraph doc -> do
  66     doc' <- rnHsDoc doc
  67     return (DocParagraph doc')
  68
  69   DocIdentifier ids -> do
  70     let choices = concatMap dataTcOccs ids
  71     mb_gres <- mapM lookupGreRn_maybe choices
  72     case [gre_name gre | Just gre <- mb_gres] of
  73       [] -> return (DocString (ids2string ids))
  74       ids' -> return (DocIdentifier ids')
  75
  76   DocModule str -> return (DocModule str)
  77
  78   DocEmphasis doc -> do
  79     doc' <- rnHsDoc doc
  80     return (DocEmphasis doc')
  81
  82   DocMonospaced doc -> do
  83     doc' <- rnHsDoc doc
  84     return (DocMonospaced doc')
  85
  86   DocUnorderedList docs -> do
  87     docs' <- mapM rnHsDoc docs
  88     return (DocUnorderedList docs')
  89
  90   DocOrderedList docs -> do
  91     docs' <- mapM rnHsDoc docs
  92     return (DocOrderedList docs')
  93
  94   DocDefList list -> do
  95     list' <- mapM (\(a,b) -> do
  96       a' <- rnHsDoc a
  97       b' <- rnHsDoc b
  98       return (a', b')) list
  99     return (DocDefList list')
 100
 101   DocCodeBlock doc -> do
 102     doc' <- rnHsDoc doc
 103     return (DocCodeBlock doc')
 104
 105   DocURL str -> return (DocURL str)
 106
 107   DocAName str -> return (DocAName str)