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_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper))
14 IMPORT_1_3(List(partition))
16 import HsSyn -- quite a bit of stuff
17 import RdrHsSyn -- oodles of synonyms
18 import HsPragmas ( noDataPragmas, noClassPragmas, noClassOpPragmas,
22 import ErrUtils ( SYN_IE(Error) )
23 import FiniteMap ( unitFM, listToFM, lookupFM, plusFM, FiniteMap )
24 import Maybes ( maybeToBool, MaybeErr(..) )
25 import Name ( isLexConId, isLexVarId, isLexConSym,
26 mkTupNameStr, preludeQual, isRdrLexCon,
27 RdrName(..){-instance Outputable:ToDo:rm-}
29 import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
30 import PrelMods ( pRELUDE )
31 import Pretty ( ppCat, ppPStr, ppInt, ppShow, ppStr )
32 import SrcLoc ( mkIfaceSrcLoc )
33 import Util ( startsWith, isIn, panic, assertPanic, pprTrace{-ToDo:rm-} )
37 type UsagesMap = FiniteMap Module (Version, VersionsMap)
38 -- module => its version, then to all its entities
39 -- and their versions; "instance" is a magic entity
40 -- representing all the instances def'd in that module
41 type VersionsMap = FiniteMap FAST_STRING Version
42 -- Versions for things def'd in this module
43 type ExportsMap = FiniteMap FAST_STRING (OrigName, ExportFlag)
44 type FixitiesMap = FiniteMap FAST_STRING RdrNameFixityDecl
45 type LocalTyDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class
46 type LocalValDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for values incl DataCon
47 type LocalPragmasMap = FiniteMap FAST_STRING PragmaStuff
49 type PragmaStuff = String
54 (Bool, Bag Module) -- From a merging of these modules; True => merging occured
55 Version -- Module version number
56 (Maybe Version) -- Source version number
57 UsagesMap -- Used when compiling this module
58 VersionsMap -- Version numbers of things from this module
59 ExportsMap -- Exported names
60 (Bag Module) -- Special instance modules
61 FixitiesMap -- fixities of local things
62 LocalTyDefsMap -- Local TyCon/Class names defined
63 LocalValDefsMap -- Local value names defined
64 (Bag RdrIfaceInst) -- Local instance declarations
65 LocalPragmasMap -- Pragmas for local names
67 -----------------------------------------------------------------
70 = TypeSig RdrName SrcLoc RdrNameTyDecl
71 | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl
72 | DataSig RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl
73 | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl
74 | ValSig RdrName SrcLoc RdrNamePolyType
77 = InstSig RdrName RdrName SrcLoc (Module -> RdrNameInstDecl)
78 -- InstDecl minus a Module name
82 -----------------------------------------------------------------
84 = ITinterface -- keywords
103 | ITbang -- magic symbols
120 | ITinteger Integer -- numbers and names
121 | ITvarid FAST_STRING
122 | ITconid FAST_STRING
123 | ITvarsym FAST_STRING
124 | ITconsym FAST_STRING
129 deriving Text -- debugging
131 instance Text RdrName where -- debugging
132 showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
134 -----------------------------------------------------------------
135 de_qual (Unqual n) = n
136 de_qual (Qual _ n) = n
138 en_mono :: FAST_STRING -> RdrNameMonoType
139 en_mono tv = MonoTyVar (Unqual tv)
142 type2context (MonoTupleTy tys) = map type2class_assertion tys
143 type2context other_ty = [ type2class_assertion other_ty ]
145 type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar)
146 type2class_assertion _ = panic "type2class_assertion: bad format"
149 -----------------------------------------------------------------
150 mk_type :: (RdrName, [FAST_STRING])
154 mk_type (qtycon@(Qual mod tycon), tyvars) ty
156 qtyvars = map Unqual tyvars
158 unitFM tycon (TypeSig qtycon mkIfaceSrcLoc $
159 TySynonym qtycon qtyvars ty mkIfaceSrcLoc)
161 mk_data :: RdrNameContext
162 -> (RdrName, [FAST_STRING])
163 -> [(RdrName, RdrNameConDecl)]
164 -> (LocalTyDefsMap, LocalValDefsMap)
166 mk_data ctxt (qtycon@(Qual mod tycon), tyvars) names_and_constrs
168 (qthingnames, constrs) = unzip names_and_constrs
169 (qconnames, qfieldnames) = partition isRdrLexCon qthingnames
170 thingnames = [ t | (Qual _ t) <- qthingnames]
171 qtyvars = map Unqual tyvars
173 decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc $
174 TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc
176 (unitFM tycon decl, listToFM [(t,decl) | t <- thingnames])
178 mk_new :: RdrNameContext
179 -> (RdrName, [FAST_STRING])
180 -> (RdrName, RdrNameMonoType)
181 -> (LocalTyDefsMap, LocalValDefsMap)
183 mk_new ctxt (qtycon@(Qual mod1 tycon), tyvars) (qconname@(Qual mod2 conname), ty)
184 = ASSERT(mod1 == mod2)
186 qtyvars = map Unqual tyvars
187 constr = NewConDecl qconname ty mkIfaceSrcLoc
189 decl = NewTypeSig qtycon qconname mkIfaceSrcLoc $
190 TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc
192 (unitFM tycon decl, unitFM conname decl)
194 mk_class :: RdrNameContext
195 -> (RdrName, RdrName)
196 -> [(FAST_STRING, RdrNameSig)]
197 -> (LocalTyDefsMap, LocalValDefsMap)
199 mk_class ctxt (qclas@(Qual mod clas), tyvar) ops_and_sigs
200 = case (unzip ops_and_sigs) of { (opnames, sigs) ->
202 qopnames = map (Qual mod) opnames
203 op_sigs = map opify sigs
205 decl = ClassSig qclas qopnames mkIfaceSrcLoc $
206 ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc
208 (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
210 opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
215 -> RdrNameMonoType -- fish the tycon out yourself...
218 mk_inst tvs ctxt qclas@(Qual cmod cname) mono_ty
220 ty = HsForAllTy tvs ctxt mono_ty
222 -- pprTrace "mk_inst:" (ppr PprDebug ty) $
223 InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod ->
225 EmptyMonoBinds False{-not from_here-} mod [{-sigs-}]
226 noInstancePragmas mkIfaceSrcLoc
228 tycon_name (MonoTyApp tc _) = tc
229 tycon_name (MonoListTy _) = preludeQual SLIT("[]")
230 tycon_name (MonoFunTy _ _) = preludeQual SLIT("->")
231 tycon_name (MonoTupleTy ts) = preludeQual (mkTupNameStr (length ts))
233 -----------------------------------------------------------------
234 lexIface :: String -> [IfaceToken]
241 -- whitespace and comments
242 ' ' : cs -> lexIface cs
243 '\t' : cs -> lexIface cs
244 '\n' : cs -> lexIface cs
245 '-' : '-' : cs -> lex_comment cs
246 '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
248 '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs
249 '{' : '{' : cs -> ITdocurly : lexIface cs
250 '}' : '}' : cs -> ITdccurly : lexIface cs
251 '{' : cs -> ITocurly : lexIface cs
252 '}' : cs -> ITccurly : lexIface cs
253 '(' : cs -> IToparen : lexIface cs
254 ')' : cs -> ITcparen : lexIface cs
255 '[' : cs -> ITobrack : lexIface cs
256 ']' : cs -> ITcbrack : lexIface cs
257 ',' : cs -> ITcomma : lexIface cs
258 ';' : cs -> ITsemi : lexIface cs
260 '_' : '_' : cs -> lex_keyword cs
262 c : cs | isUpper c -> lex_word input -- don't know if "Module." on front or not
263 | isDigit c -> lex_num input
264 | isAlpha c -> lex_name Nothing is_var_sym input
265 | is_sym_sym c -> lex_name Nothing is_sym_sym input
267 other -> error ("lexing:"++other)
270 = case (span ((/=) '\n') str) of { (junk, rest) ->
274 lex_nested_comment lvl [] = error "EOF in nested comment in interface"
275 lex_nested_comment lvl str
277 '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
278 '-' : '}' : xs -> if lvl == 1
280 else lex_nested_comment (lvl-1) xs
281 _ : xs -> lex_nested_comment lvl xs
285 = case (span isDigit str) of { (num, rest) ->
286 ITinteger (read num) : lexIface rest }
289 is_var_sym c = isAlphanum c || c `elem` "_'#"
290 -- the last few for for Glasgow-extended names
292 is_var_sym1 '\'' = False
293 is_var_sym1 '#' = False
294 is_var_sym1 '_' = False
295 is_var_sym1 c = is_var_sym c
297 is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
299 is_list_sym '[' = True
300 is_list_sym ']' = True
301 is_list_sym _ = False
303 is_tuple_sym '(' = True
304 is_tuple_sym ')' = True
305 is_tuple_sym ',' = True
306 is_tuple_sym _ = False
309 lex_word str@(c:cs) -- we know we have a capital letter to start
310 = -- we first try for "<module>." on the front...
311 case (module_dot str) of
312 Nothing -> lex_name Nothing (in_the_club str) str
313 Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
315 in_the_club [] = panic "lex_word:in_the_club"
316 in_the_club (x:y) | isAlpha x = is_var_sym
317 | is_sym_sym x = is_sym_sym
318 | x == '[' = is_list_sym
319 | x == '(' = is_tuple_sym
320 | otherwise = panic ("lex_word:in_the_club="++(x:y))
323 = if not (isUpper c) || c == '\'' then
326 case (span is_var_sym cs) of { (word, rest) ->
329 (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
334 = case (span is_var_sym str) of { (kw, rest) ->
335 case (lookupFM keywordsFM kw) of
336 Nothing -> panic ("lex_keyword:"++str)
337 Just xx -> xx : lexIface rest
340 lex_name module_dot in_the_club str
341 = case (span in_the_club str) of { (word, rest) ->
342 case (lookupFM keywordsFM word) of
344 cont = xx : lexIface rest
347 ITbang -> case module_dot of
349 Just m -> ITqvarsym (Qual m SLIT("!"))
354 f = head word -- first char
359 categ f n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n)
364 categ f n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
369 categ f n conid varid consym varsym
370 = if f == '[' || f == '(' then
372 else if isLexConId n then conid
373 else if isLexVarId n then varid
374 else if isLexConSym n then consym
378 keywordsFM :: FiniteMap String IfaceToken
379 keywordsFM = listToFM [
380 ("interface", ITinterface)
382 ,("usages__", ITusages)
383 ,("versions__", ITversions)
384 ,("exports__", ITexports)
385 ,("instance_modules__", ITinstance_modules)
386 ,("instances__", ITinstances)
387 ,("fixities__", ITfixities)
388 ,("declarations__", ITdeclarations)
389 ,("pragmas__", ITpragmas)
390 ,("forall__", ITforall)
394 ,("newtype", ITnewtype)
397 ,("instance", ITinstance)
398 ,("infixl", ITinfixl)
399 ,("infixr", ITinfixr)
410 -----------------------------------------------------------------
411 type IfM a = MaybeErr a Error
413 returnIf :: a -> IfM a
414 thenIf :: IfM a -> (a -> IfM b) -> IfM b
415 happyError :: Int -> [IfaceToken] -> IfM a
417 returnIf a = Succeeded a
419 thenIf (Succeeded a) k = k a
420 thenIf (Failed err) _ = Failed err
422 happyError ln toks = Failed (ifaceParseErr ln toks)
423 -----------------------------------------------------------------
425 ifaceParseErr ln toks sty
426 = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]