2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[ParseUtils]{Help the interface parser}
7 #include "HsVersions.h"
9 module ParseUtils where
13 import HsSyn -- quite a bit of stuff
14 import RdrHsSyn -- oodles of synonyms
15 import HsPragmas ( noDataPragmas, noClassPragmas, noClassOpPragmas,
19 import ErrUtils ( Error(..) )
20 import FiniteMap ( unitFM, listToFM, lookupFM, plusFM, FiniteMap )
21 import Maybes ( maybeToBool, MaybeErr(..) )
22 import Name ( isLexConId, isLexVarId, isLexConSym,
24 RdrName(..){-instance Outputable:ToDo:rm-}
26 import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
27 import PrelMods ( fromPrelude )
28 import Pretty ( ppCat, ppPStr, ppInt, ppShow, ppStr )
29 import SrcLoc ( mkIfaceSrcLoc )
30 import Util ( startsWith, isIn, panic, assertPanic )
34 type UsagesMap = FiniteMap Module (Version, VersionsMap)
35 -- module => its version, then to all its entities
36 -- and their versions; "instance" is a magic entity
37 -- representing all the instances def'd in that module
38 type VersionsMap = FiniteMap FAST_STRING Version
39 -- Versions for things def'd in this module
40 type ExportsMap = FiniteMap FAST_STRING (RdrName, ExportFlag)
41 type FixitiesMap = FiniteMap FAST_STRING RdrNameFixityDecl
42 type LocalTyDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class
43 type LocalValDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for values incl DataCon
44 type LocalPragmasMap = FiniteMap FAST_STRING PragmaStuff
46 type PragmaStuff = String
51 (Bool, Bag Module) -- From a merging of these modules; True => merging occured
52 Version -- Module version number
53 (Maybe Version) -- Source version number
54 UsagesMap -- Used when compiling this module
55 VersionsMap -- Version numbers of things from this module
56 ExportsMap -- Exported names
57 (Bag Module) -- Special instance modules
58 FixitiesMap -- fixities of local things
59 LocalTyDefsMap -- Local TyCon/Class names defined
60 LocalValDefsMap -- Local value names defined
61 (Bag RdrIfaceInst) -- Local instance declarations
62 LocalPragmasMap -- Pragmas for local names
64 -----------------------------------------------------------------
67 = TypeSig RdrName SrcLoc RdrNameTyDecl
68 | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl
69 | DataSig RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl
70 | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl
71 | ValSig RdrName SrcLoc RdrNamePolyType
74 = InstSig RdrName RdrName SrcLoc RdrNameInstDecl
78 -----------------------------------------------------------------
80 = ITinterface -- keywords
98 | ITbang -- magic symbols
114 | ITinteger Integer -- numbers and names
115 | ITvarid FAST_STRING
116 | ITconid FAST_STRING
117 | ITvarsym FAST_STRING
118 | ITconsym FAST_STRING
123 deriving Text -- debugging
125 instance Text RdrName where -- debugging
126 showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
128 -----------------------------------------------------------------
129 de_qual (Unqual n) = n
130 de_qual (Qual _ n) = n
132 en_mono :: FAST_STRING -> RdrNameMonoType
133 en_mono tv = MonoTyVar (Unqual tv)
135 type2context (MonoTupleTy tys) = map type2class_assertion tys
136 type2context other_ty = [ type2class_assertion other_ty ]
138 type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar)
139 type2class_assertion _ = panic "type2class_assertion: bad format"
141 -----------------------------------------------------------------
142 mk_type :: (RdrName, [FAST_STRING])
146 mk_type (qtycon, tyvars) ty
148 tycon = de_qual qtycon
149 qtyvars = map Unqual tyvars
151 unitFM tycon (TypeSig qtycon mkIfaceSrcLoc (
152 TySynonym qtycon qtyvars ty mkIfaceSrcLoc))
154 mk_data :: RdrNameContext
155 -> (RdrName, [FAST_STRING])
156 -> [(RdrName, RdrNameConDecl)]
157 -> (LocalTyDefsMap, LocalValDefsMap)
159 mk_data ctxt (qtycon, tyvars) names_and_constrs
161 (qconnames, constrs) = unzip names_and_constrs
162 qfieldnames = [] -- ToDo ...
163 tycon = de_qual qtycon
164 connames = map de_qual qconnames
165 fieldnames = map de_qual qfieldnames
166 qtyvars = map Unqual tyvars
168 decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc (
169 TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc)
171 (unitFM tycon decl, listToFM [(c,decl) | c <- connames]
173 listToFM [(f,decl) | f <- fieldnames])
175 mk_new :: RdrNameContext
176 -> (RdrName, [FAST_STRING])
177 -> (RdrName, RdrNameMonoType)
178 -> (LocalTyDefsMap, LocalValDefsMap)
180 mk_new ctxt (qtycon, tyvars) (qconname, ty)
182 tycon = de_qual qtycon
183 conname = de_qual qconname
184 qtyvars = map Unqual tyvars
185 constr = NewConDecl qconname ty mkIfaceSrcLoc
187 decl = NewTypeSig qtycon qconname mkIfaceSrcLoc (
188 TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc)
190 (unitFM tycon decl, unitFM conname decl)
192 mk_class :: RdrNameContext
193 -> (RdrName, RdrName)
194 -> [(FAST_STRING, RdrNameSig)]
195 -> (LocalTyDefsMap, LocalValDefsMap)
197 mk_class ctxt (qclas, tyvar) ops_and_sigs
198 = case (unzip ops_and_sigs) of { (opnames, sigs) ->
200 qopnames = map Unqual opnames
202 op_sigs = map opify sigs
204 decl = ClassSig qclas qopnames mkIfaceSrcLoc (
205 ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc)
207 (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
209 opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
211 mk_inst :: RdrNameContext
213 -> RdrNameMonoType -- fish the tycon out yourself...
216 mk_inst ctxt clas mono_ty
217 = InstSig clas (tycon_name mono_ty) mkIfaceSrcLoc (
218 InstDecl clas (HsPreForAllTy ctxt mono_ty)
219 EmptyMonoBinds False Nothing{-lying-} [{-sigs-}]
220 noInstancePragmas mkIfaceSrcLoc)
222 tycon_name (MonoTyApp tc _) = tc
223 tycon_name (MonoListTy _) = Unqual SLIT("[]")
224 tycon_name (MonoFunTy _ _) = Unqual SLIT("->")
225 tycon_name (MonoTupleTy ts) = Unqual (mkTupNameStr (length ts))
227 -----------------------------------------------------------------
228 lexIface :: String -> [IfaceToken]
235 -- whitespace and comments
236 ' ' : cs -> lexIface cs
237 '\t' : cs -> lexIface cs
238 '\n' : cs -> lexIface cs
239 '-' : '-' : cs -> lex_comment cs
240 '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
242 '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs
243 '(' : cs -> IToparen : lexIface cs
244 ')' : cs -> ITcparen : lexIface cs
245 '[' : cs -> ITobrack : lexIface cs
246 ']' : cs -> ITcbrack : lexIface cs
247 '{' : cs -> ITocurly : lexIface cs
248 '}' : cs -> ITccurly : lexIface cs
249 ',' : cs -> ITcomma : lexIface cs
250 ';' : cs -> ITsemi : lexIface cs
251 '`' : cs -> ITbquote : lexIface cs
253 '_' : cs -> lex_name Nothing is_var_sym str
254 c : cs | isUpper c -> lex_word str -- don't know if "Module." on front or not
255 | isDigit c -> lex_num str
256 | isAlpha c -> lex_name Nothing is_var_sym str
257 | is_sym_sym c -> lex_name Nothing is_sym_sym str
259 other -> error ("lexing:"++other)
262 = case (span ((/=) '\n') str) of { (junk, rest) ->
266 lex_nested_comment lvl [] = error "EOF in nested comment in interface"
267 lex_nested_comment lvl str
269 '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
270 '-' : '}' : xs -> if lvl == 1
272 else lex_nested_comment (lvl-1) xs
273 _ : xs -> lex_nested_comment lvl xs
277 = case (span isDigit str) of { (num, rest) ->
278 ITinteger (read num) : lexIface rest }
281 is_var_sym '_' = True
282 is_var_sym c = isAlphanum c
284 is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
287 lex_word str@(c:cs) -- we know we have a capital letter to start
288 = -- we first try for "<module>." on the front...
289 case (module_dot str) of
290 Nothing -> lex_name Nothing is_var_sym str
291 Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
293 in_the_club [] = panic "lex_word:in_the_club"
294 in_the_club (c:_) | isAlpha c = is_var_sym
295 | is_sym_sym c = is_sym_sym
296 | otherwise = panic ("lex_word:in_the_club="++[c])
299 = if not (isUpper c) then
302 case (span is_var_sym cs) of { (word, rest) ->
305 (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
309 lex_name module_dot in_the_club str
310 = case (span in_the_club str) of { (word, rest) ->
311 case (lookupFM keywordsFM word) of
312 Just xx -> ASSERT( not (maybeToBool module_dot) )
316 f = head word -- first char
321 categ n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n)
324 q = if fromPrelude m then Unqual n else Qual m n
326 categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
331 categ n conid varid consym varsym
332 = if isLexConId n then conid
333 else if isLexVarId n then varid
334 else if isLexConSym n then consym
338 keywordsFM :: FiniteMap String IfaceToken
339 keywordsFM = listToFM [
340 ("interface", ITinterface)
342 ,("__usages__", ITusages)
343 ,("__versions__", ITversions)
344 ,("__exports__", ITexports)
345 ,("__instance_modules__",ITinstance_modules)
346 ,("__instances__", ITinstances)
347 ,("__fixities__", ITfixities)
348 ,("__declarations__", ITdeclarations)
349 ,("__pragmas__", ITpragmas)
353 ,("newtype", ITnewtype)
356 ,("instance", ITinstance)
357 ,("infixl", ITinfixl)
358 ,("infixr", ITinfixr)
369 -----------------------------------------------------------------
370 type IfM a = MaybeErr a Error
372 returnIf :: a -> IfM a
373 thenIf :: IfM a -> (a -> IfM b) -> IfM b
374 happyError :: Int -> [IfaceToken] -> IfM a
376 returnIf a = Succeeded a
378 thenIf (Succeeded a) k = k a
379 thenIf (Failed err) _ = Failed err
381 happyError ln toks = Failed (ifaceParseErr ln toks)
382 -----------------------------------------------------------------
384 ifaceParseErr ln toks sty
385 = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show toks)]