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