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 Version -- Module version number
52 (Maybe Version) -- Source version number
53 UsagesMap -- Used when compiling this module
54 VersionsMap -- Version numbers of things from this module
55 ExportsMap -- Exported names
56 (Bag Module) -- Special instance modules
57 FixitiesMap -- fixities of local things
58 LocalTyDefsMap -- Local TyCon/Class names defined
59 LocalValDefsMap -- Local value names defined
60 (Bag RdrIfaceInst)-- Local instance declarations
61 LocalPragmasMap -- Pragmas for local names
63 -----------------------------------------------------------------
66 = TypeSig RdrName SrcLoc RdrNameTyDecl
67 | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl
68 | DataSig RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl
69 | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl
70 | ValSig RdrName SrcLoc RdrNamePolyType
73 = InstSig RdrName RdrName SrcLoc RdrNameInstDecl
77 -----------------------------------------------------------------
79 = ITinterface -- keywords
97 | ITbang -- magic symbols
113 | ITinteger Integer -- numbers and names
114 | ITvarid FAST_STRING
115 | ITconid FAST_STRING
116 | ITvarsym FAST_STRING
117 | ITconsym FAST_STRING
122 deriving Text -- debugging
124 instance Text RdrName where -- debugging
125 showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
127 -----------------------------------------------------------------
128 de_qual (Unqual n) = n
129 de_qual (Qual _ n) = n
131 en_mono :: FAST_STRING -> RdrNameMonoType
132 en_mono tv = MonoTyVar (Unqual tv)
134 type2context (MonoTupleTy tys) = map type2class_assertion tys
135 type2context other_ty = [ type2class_assertion other_ty ]
137 type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar)
138 type2class_assertion _ = panic "type2class_assertion: bad format"
140 -----------------------------------------------------------------
141 mk_type :: (RdrName, [FAST_STRING])
145 mk_type (qtycon, tyvars) ty
147 tycon = de_qual qtycon
148 qtyvars = map Unqual tyvars
150 unitFM tycon (TypeSig qtycon mkIfaceSrcLoc (
151 TySynonym qtycon qtyvars ty mkIfaceSrcLoc))
153 mk_data :: RdrNameContext
154 -> (RdrName, [FAST_STRING])
155 -> [(RdrName, RdrNameConDecl)]
156 -> (LocalTyDefsMap, LocalValDefsMap)
158 mk_data ctxt (qtycon, tyvars) names_and_constrs
160 (qconnames, constrs) = unzip names_and_constrs
161 qfieldnames = [] -- ToDo ...
162 tycon = de_qual qtycon
163 connames = map de_qual qconnames
164 fieldnames = map de_qual qfieldnames
165 qtyvars = map Unqual tyvars
167 decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc (
168 TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc)
170 (unitFM tycon decl, listToFM [(c,decl) | c <- connames]
172 listToFM [(f,decl) | f <- fieldnames])
174 mk_new :: RdrNameContext
175 -> (RdrName, [FAST_STRING])
176 -> (RdrName, RdrNameMonoType)
177 -> (LocalTyDefsMap, LocalValDefsMap)
179 mk_new ctxt (qtycon, tyvars) (qconname, ty)
181 tycon = de_qual qtycon
182 conname = de_qual qconname
183 qtyvars = map Unqual tyvars
184 constr = NewConDecl qconname ty mkIfaceSrcLoc
186 decl = NewTypeSig qtycon qconname mkIfaceSrcLoc (
187 TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc)
189 (unitFM tycon decl, unitFM conname decl)
191 mk_class :: RdrNameContext
192 -> (RdrName, RdrName)
193 -> [(FAST_STRING, RdrNameSig)]
194 -> (LocalTyDefsMap, LocalValDefsMap)
196 mk_class ctxt (qclas, tyvar) ops_and_sigs
197 = case (unzip ops_and_sigs) of { (opnames, sigs) ->
199 qopnames = map Unqual opnames
201 op_sigs = map opify sigs
203 decl = ClassSig qclas qopnames mkIfaceSrcLoc (
204 ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc)
206 (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
208 opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
210 mk_inst :: RdrNameContext
212 -> RdrNameMonoType -- fish the tycon out yourself...
215 mk_inst ctxt clas mono_ty
216 = InstSig clas (tycon_name mono_ty) mkIfaceSrcLoc (
217 InstDecl clas (HsPreForAllTy ctxt mono_ty)
218 EmptyMonoBinds False Nothing{-lying-} [{-sigs-}]
219 noInstancePragmas mkIfaceSrcLoc)
221 tycon_name (MonoTyApp tc _) = tc
222 tycon_name (MonoListTy _) = Unqual SLIT("[]")
223 tycon_name (MonoFunTy _ _) = Unqual SLIT("->")
224 tycon_name (MonoTupleTy ts) = Unqual (mkTupNameStr (length ts))
226 -----------------------------------------------------------------
227 lexIface :: String -> [IfaceToken]
233 -- whitespace and comments
234 ' ' : cs -> lexIface cs
235 '\t' : cs -> lexIface cs
236 '\n' : cs -> lexIface cs
237 '-' : '-' : cs -> lex_comment cs
238 '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
240 '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs
241 '(' : cs -> IToparen : lexIface cs
242 ')' : cs -> ITcparen : lexIface cs
243 '[' : cs -> ITobrack : lexIface cs
244 ']' : cs -> ITcbrack : lexIface cs
245 '{' : cs -> ITocurly : lexIface cs
246 '}' : cs -> ITccurly : lexIface cs
247 ',' : cs -> ITcomma : lexIface cs
248 ';' : cs -> ITsemi : lexIface cs
249 '`' : cs -> ITbquote : lexIface cs
251 '_' : cs -> lex_name Nothing is_var_sym str
252 c : cs | isUpper c -> lex_word str -- don't know if "Module." on front or not
253 | isDigit c -> lex_num str
254 | isAlpha c -> lex_name Nothing is_var_sym str
255 | is_sym_sym c -> lex_name Nothing is_sym_sym str
257 other -> error ("lexing:"++other)
260 = case (span ((/=) '\n') str) of { (junk, rest) ->
264 lex_nested_comment lvl [] = error "EOF in nested comment in interface"
265 lex_nested_comment lvl str
267 '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
268 '-' : '}' : xs -> if lvl == 1
270 else lex_nested_comment (lvl-1) xs
271 _ : xs -> lex_nested_comment lvl xs
275 = case (span isDigit str) of { (num, rest) ->
276 ITinteger (read num) : lexIface rest }
279 is_var_sym '_' = True
280 is_var_sym c = isAlphanum c
282 is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
285 lex_word str@(c:cs) -- we know we have a capital letter to start
286 = -- we first try for "<module>." on the front...
287 case (module_dot str) of
288 Nothing -> lex_name Nothing is_var_sym str
289 Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
291 in_the_club [] = panic "lex_word:in_the_club"
292 in_the_club (c:_) | isAlpha c = is_var_sym
293 | is_sym_sym c = is_sym_sym
294 | otherwise = panic ("lex_word:in_the_club="++[c])
297 = if not (isUpper c) then
300 case (span is_var_sym cs) of { (word, rest) ->
303 (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
307 lex_name module_dot in_the_club str
308 = case (span in_the_club str) of { (word, rest) ->
309 case (lookupFM keywordsFM word) of
310 Just xx -> ASSERT( not (maybeToBool module_dot) )
314 f = head word -- first char
319 categ n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n)
322 q = if fromPrelude m then Unqual n else Qual m n
324 categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
329 categ n conid varid consym varsym
330 = if isLexConId n then conid
331 else if isLexVarId n then varid
332 else if isLexConSym n then consym
336 keywordsFM :: FiniteMap String IfaceToken
337 keywordsFM = listToFM [
338 ("interface", ITinterface)
340 ,("__usages__", ITusages)
341 ,("__versions__", ITversions)
342 ,("__exports__", ITexports)
343 ,("__instance_modules__",ITinstance_modules)
344 ,("__instances__", ITinstances)
345 ,("__fixities__", ITfixities)
346 ,("__declarations__", ITdeclarations)
347 ,("__pragmas__", ITpragmas)
351 ,("newtype", ITnewtype)
354 ,("instance", ITinstance)
355 ,("infixl", ITinfixl)
356 ,("infixr", ITinfixr)
367 -----------------------------------------------------------------
368 type IfM a = MaybeErr a Error
370 returnIf :: a -> IfM a
371 thenIf :: IfM a -> (a -> IfM b) -> IfM b
372 happyError :: Int -> [IfaceToken] -> IfM a
374 returnIf a = Succeeded a
376 thenIf (Succeeded a) k = k a
377 thenIf (Failed err) _ = Failed err
379 happyError ln toks = Failed (ifaceParseErr ln toks)
380 -----------------------------------------------------------------
382 ifaceParseErr ln toks sty
383 = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show toks)]