← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to utils/haddock/src/Haddock/GhcUtils.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
utils/haddock/src/Haddock/GhcUtils.hs
 
1
{-# LANGUAGE FlexibleInstances #-}
 
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
 
3
{-# OPTIONS_HADDOCK hide #-}
 
4
-----------------------------------------------------------------------------
 
5
-- |
 
6
-- Module      :  Haddock.GhcUtils
 
7
-- Copyright   :  (c) David Waern 2006-2009
 
8
-- License     :  BSD-like
 
9
--
 
10
-- Maintainer  :  haddock@projects.haskell.org
 
11
-- Stability   :  experimental
 
12
-- Portability :  portable
 
13
--
 
14
-- Utils for dealing with types from the GHC API
 
15
-----------------------------------------------------------------------------
 
16
module Haddock.GhcUtils where
 
17
 
 
18
 
 
19
import Data.Version
 
20
import Control.Arrow
 
21
import Data.Foldable hiding (concatMap)
 
22
import Data.Traversable
 
23
import Distribution.Compat.ReadP
 
24
import Distribution.Text
 
25
 
 
26
import Exception
 
27
import Outputable
 
28
import Name
 
29
import Packages
 
30
import Module
 
31
import RdrName (GlobalRdrEnv)
 
32
import HscTypes
 
33
#if __GLASGOW_HASKELL__ >= 613
 
34
import UniqFM
 
35
#else
 
36
import LazyUniqFM
 
37
#endif
 
38
import GHC
 
39
 
 
40
 
 
41
moduleString :: Module -> String
 
42
moduleString = moduleNameString . moduleName
 
43
 
 
44
 
 
45
-- return the (name,version) of the package
 
46
modulePackageInfo :: Module -> (String, [Char])
 
47
modulePackageInfo modu = case unpackPackageId pkg of
 
48
                          Nothing -> (packageIdString pkg, "")
 
49
                          Just x -> (display $ pkgName x, showVersion (pkgVersion x))
 
50
  where pkg = modulePackageId modu
 
51
 
 
52
 
 
53
-- This was removed from GHC 6.11
 
54
-- XXX we shouldn't be using it, probably
 
55
 
 
56
-- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if
 
57
-- we could not parse it as such an object.
 
58
unpackPackageId :: PackageId -> Maybe PackageIdentifier
 
59
unpackPackageId p
 
60
  = case [ pid | (pid,"") <- readP_to_S parse str ] of
 
61
        []      -> Nothing
 
62
        (pid:_) -> Just pid
 
63
  where str = packageIdString p
 
64
 
 
65
 
 
66
mkModuleNoPackage :: String -> Module
 
67
mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str)
 
68
 
 
69
 
 
70
lookupLoadedHomeModuleGRE  :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv)
 
71
lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env ->
 
72
  case lookupUFM (hsc_HPT hsc_env) mod_name of
 
73
    Just mod_info      -> return (mi_globals (hm_iface mod_info))
 
74
    _not_a_home_module -> return Nothing
 
75
 
 
76
 
 
77
isNameSym :: Name -> Bool
 
78
isNameSym = isSymOcc . nameOccName
 
79
 
 
80
 
 
81
isVarSym :: OccName -> Bool
 
82
isVarSym = isLexVarSym . occNameFS
 
83
 
 
84
 
 
85
getMainDeclBinder :: HsDecl name -> Maybe name
 
86
getMainDeclBinder (TyClD d) = Just (tcdName d)
 
87
getMainDeclBinder (ValD d) =
 
88
#if __GLASGOW_HASKELL__ == 612
 
89
  case collectAcc d [] of
 
90
    []       -> Nothing
 
91
    (name:_) -> Just (unLoc name)
 
92
#else
 
93
  case collectHsBindBinders d of
 
94
    []       -> Nothing
 
95
    (name:_) -> Just name
 
96
#endif
 
97
 
 
98
 
 
99
getMainDeclBinder (SigD d) = sigNameNoLoc d
 
100
getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
 
101
getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing
 
102
getMainDeclBinder _ = Nothing
 
103
 
 
104
 
 
105
isTyClD :: HsDecl a -> Bool
 
106
isTyClD (TyClD _) = True
 
107
isTyClD _ = False
 
108
 
 
109
 
 
110
isClassD :: HsDecl a -> Bool
 
111
isClassD (TyClD d) = isClassDecl d
 
112
isClassD _ = False
 
113
 
 
114
 
 
115
isDocD :: HsDecl a -> Bool
 
116
isDocD (DocD _) = True
 
117
isDocD _ = False
 
118
 
 
119
 
 
120
isInstD :: HsDecl a -> Bool
 
121
isInstD (InstD _) = True
 
122
isInstD (TyClD d) = isFamInstDecl d
 
123
isInstD _ = False
 
124
 
 
125
 
 
126
declATs :: HsDecl a -> [a]
 
127
declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d
 
128
declATs _ = []
 
129
 
 
130
 
 
131
pretty :: Outputable a => a -> String
 
132
pretty x = showSDoc (ppr x)
 
133
 
 
134
 
 
135
trace_ppr :: Outputable a => a -> b -> b
 
136
trace_ppr x y = trace (pretty x) y
 
137
 
 
138
 
 
139
-------------------------------------------------------------------------------
 
140
-- * Located
 
141
-------------------------------------------------------------------------------
 
142
 
 
143
 
 
144
unL :: Located a -> a
 
145
unL (L _ x) = x
 
146
 
 
147
 
 
148
reL :: a -> Located a
 
149
reL = L undefined
 
150
 
 
151
 
 
152
instance Foldable Located where
 
153
  foldMap f (L _ x) = f x
 
154
 
 
155
 
 
156
instance Traversable Located where
 
157
  mapM f (L l x) = (return . L l) =<< f x
 
158
 
 
159
 
 
160
-------------------------------------------------------------------------------
 
161
-- * NamedThing instances
 
162
-------------------------------------------------------------------------------
 
163
 
 
164
 
 
165
instance NamedThing (TyClDecl Name) where
 
166
  getName = tcdName
 
167
 
 
168
 
 
169
instance NamedThing (ConDecl Name) where
 
170
  getName = unL . con_name
 
171
 
 
172
 
 
173
-------------------------------------------------------------------------------
 
174
-- * Subordinates
 
175
-------------------------------------------------------------------------------
 
176
 
 
177
 
 
178
class Parent a where
 
179
  children :: a -> [Name]
 
180
 
 
181
 
 
182
instance Parent (ConDecl Name) where
 
183
  children con =
 
184
    case con_details con of
 
185
      RecCon fields -> map (unL . cd_fld_name) fields
 
186
      _             -> []
 
187
 
 
188
 
 
189
instance Parent (TyClDecl Name) where
 
190
  children d
 
191
    | isDataDecl  d = map (unL . con_name . unL) . tcdCons $ d
 
192
    | isClassDecl d =
 
193
        map (tcdName . unL) (tcdATs d) ++
 
194
        [ unL n | L _ (TypeSig n _) <- tcdSigs d ]
 
195
    | otherwise = []
 
196
 
 
197
 
 
198
-- | A parent and its children
 
199
family :: (NamedThing a, Parent a) => a -> (Name, [Name])
 
200
family = getName &&& children
 
201
 
 
202
 
 
203
-- | A mapping from the parent (main-binder) to its children and from each
 
204
-- child to its grand-children, recursively.
 
205
families :: TyClDecl Name -> [(Name, [Name])]
 
206
families d
 
207
  | isDataDecl  d = family d : map (family . unL) (tcdCons d)
 
208
  | isClassDecl d = family d : concatMap (families . unL) (tcdATs d)
 
209
  | otherwise     = []
 
210
 
 
211
 
 
212
-- | A mapping from child to parent
 
213
parentMap :: TyClDecl Name -> [(Name, Name)]
 
214
parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ]
 
215
 
 
216
 
 
217
-- | The parents of a subordinate in a declaration
 
218
parents :: Name -> HsDecl Name -> [Name]
 
219
parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ]
 
220
parents _ _ = []
 
221
 
 
222
 
 
223
-------------------------------------------------------------------------------
 
224
-- * Utils that work in monads defined by GHC
 
225
-------------------------------------------------------------------------------
 
226
 
 
227
 
 
228
modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
 
229
modifySessionDynFlags f = do
 
230
  dflags <- getSessionDynFlags
 
231
  _ <- setSessionDynFlags (f dflags)
 
232
  return ()
 
233
 
 
234
 
 
235
-- | A variant of 'gbracket' where the return value from the first computation
 
236
-- is not required.
 
237
gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
 
238
gbracket_ before after thing = gbracket before (const after) (const thing)
 
239
 
 
240
 
 
241
-------------------------------------------------------------------------------
 
242
-- * DynFlags
 
243
-------------------------------------------------------------------------------
 
244
 
 
245
 
 
246
setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
 
247
setObjectDir  f d = d{ objectDir  = Just f}
 
248
setHiDir      f d = d{ hiDir      = Just f}
 
249
setStubDir    f d = d{ stubDir    = Just f, includePaths = f : includePaths d }
 
250
  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
 
251
  -- \#included from the .hc file when compiling with -fvia-C.
 
252
setOutputDir  f = setObjectDir f . setHiDir f . setStubDir f
 
253