[project @ 2000-10-05 10:05:53 by sewardj]
[ghc-hetmet.git] / ghc / compiler / ghci / CmSummarise.lhs
1 %
2 % (c) The AQUA Project, Glasgow University, 1993-2000
3 %
4 \section[CmSummarise]{Module summariser for GHCI}
5
6 \begin{code}
7 module CmSummarise ( ModImport(..), mi_name,
8                      ModSummary(..), summarise )
9 where
10
11 #include "HsVersions.h"
12
13 import List             ( nub )
14 import Char             ( ord, isAlphaNum )
15
16 import CmFind           ( ModName, ModLocation(..) )
17 import Outputable       ( pprPanic, text )
18 \end{code}
19
20 \begin{code}
21
22
23 data ModSummary
24    = ModSummary {
25         ms_loc     :: ModLocation,                   -- location and kind
26         ms_source  :: (Maybe (String, Fingerprint)), -- source and sig if .hs
27         ms_imports :: (Maybe [ModImport])            -- imports if .hs or .hi
28      }
29      deriving Show
30
31 data ModImport
32    = MINormal ModName | MISource ModName
33      deriving (Eq, Show)
34
35 mi_name (MINormal nm) = nm
36 mi_name (MISource nm) = nm
37
38 type Fingerprint = Int
39
40 summarise :: ModLocation -> IO ModSummary
41
42 summarise loc
43    = case loc of
44         InPackage mod path -- if in a package, investigate no further
45            -> return (ModSummary loc Nothing Nothing)
46         SourceOnly mod path -- source; read, cache and get imports
47            -> readFile path >>= \ modsrc ->
48               let imps = getImports modsrc
49                   fp   = fingerprint modsrc
50               in  return (ModSummary loc (Just (modsrc,fp)) (Just imps))
51         ObjectCode mod oPath hiPath -- can we get away with the src summariser
52                                     -- for interface files?
53            -> readFile hiPath >>= \ hisrc ->
54               let imps = getImports hisrc
55               in  return (ModSummary loc Nothing (Just imps))
56         NotFound
57            -> pprPanic "summarise:NotFound" (text (show loc))
58
59 fingerprint :: String -> Int
60 fingerprint s
61    = dofp s 3 3
62      where
63         -- Copied from hash() in Hugs' storage.c.
64         dofp :: String -> Int -> Int -> Int
65         dofp []     m fp = fp
66         dofp (c:cs) m fp = dofp cs (m+1) (iabs (fp + m * ord c))
67         iabs :: Int -> Int
68         iabs n = if n < 0 then -n else n
69 \end{code}
70
71 Collect up the imports from a Haskell source module.  This is
72 approximate: we don't parse the module, but we do eliminate comments
73 and strings.  Doesn't currently know how to unlit or cppify the module
74 first.
75
76 \begin{code}
77
78 getImports :: String -> [ModImport]
79 getImports = nub . gmiBase . clean
80
81 -- really get the imports from a de-litted, cpp'd, de-literal'd string
82 gmiBase :: String -> [ModImport]
83 gmiBase s
84    = f (words s)
85      where
86         f ("foreign" : "import" : ws) = f ws
87         f ("import" : "{-#" : "SOURCE" : "#-}" : "qualified" : m : ws) 
88            = MISource (takeWhile isModId m) : f ws
89         f ("import" : "{-#" : "SOURCE" : "#-}" : m : ws) 
90            = MISource (takeWhile isModId m) : f ws
91         f ("import" : "qualified" : m : ws) 
92            = MINormal (takeWhile isModId m) : f ws
93         f ("import" : m : ws) 
94            = MINormal (takeWhile isModId m) : f ws
95         f (w:ws) = f ws
96         f [] = []
97
98 isModId c = isAlphaNum c || c `elem` "'_"
99
100 -- remove literals and comments from a string
101 clean :: String -> String
102 clean s
103    = keep s
104      where
105         -- running through text we want to keep
106         keep []                   = []
107         keep ('"':cs)             = dquote cs
108                 -- try to eliminate single quotes when they're part of
109                 -- an identifier...
110         keep (c:'\'':cs) | isAlphaNum c || c == '_' = keep (dropWhile (=='\'') cs)
111         keep ('\'':cs)            = squote cs
112         keep ('-':'-':cs)         = linecomment cs
113         keep ('{':'-':'#':' ':cs) = "{-# " ++ keep cs
114         keep ('{':'-':cs)         = runcomment cs
115         keep (c:cs)               = c : keep cs
116
117         -- in a double-quoted string
118         dquote []             = []
119         dquote ('\\':'\"':cs) = dquote cs
120         dquote ('\\':'\\':cs) = dquote cs
121         dquote ('\"':cs)      = keep cs
122         dquote (c:cs)         = dquote cs
123
124         -- in a single-quoted string
125         squote []             = []
126         squote ('\\':'\'':cs) = squote cs
127         squote ('\\':'\\':cs) = squote cs
128         squote ('\'':cs)      = keep cs
129         squote (c:cs)         = squote cs
130
131         -- in a line comment
132         linecomment []        = []
133         linecomment ('\n':cs) = '\n':keep cs
134         linecomment (c:cs)    = linecomment cs
135
136         -- in a running comment
137         runcomment []           = []
138         runcomment ('-':'}':cs) = keep cs
139         runcomment (c:cs)       = runcomment cs
140 \end{code}