2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[ReadPrefix]{Read prefix-form input}
6 This module contains a function, @rdModule@, which reads a Haskell
7 module in `prefix form' emitted by the Lex/Yacc parser.
9 The prefix form string is converted into an algebraic data type
10 defined in @PrefixSyn@.
12 Identifier names are converted into the @ProtoName@ data type.
14 @sf@ is used consistently to mean ``source file'' (name).
17 -- HBC does not have stack stubbing; you get a space leak w/
18 -- default defns from HsVersions.h.
20 -- GHC may be overly slow to compile w/ the defaults...
23 #define _TO_ `thenLft` ( \ {--}
25 #define RETN returnLft
26 #define RETN_TYPE LiftM
28 #include "HsVersions.h"
35 rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType
38 IMPORT_Trace -- ToDo: rm (debugging)
42 import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
43 import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
44 import IdInfo ( UnfoldingGuidance(..) )
46 import Maybes ( Maybe(..) )
52 import SrcLoc ( mkSrcLoc )
56 %************************************************************************
58 \subsection[ReadPrefix-help]{Help Functions}
60 %************************************************************************
63 rdList :: (String -> RETN_TYPE (a, String)) -> String -> RETN_TYPE ([a], String)
65 rdList rd_it ('N':xs) = RETN ([], xs)
67 = BIND (rd_it xs) _TO_ (hd_it, xs1) ->
68 BIND (rdList rd_it xs1) _TO_ (tl_it, xs2) ->
69 RETN (hd_it : tl_it, xs2)
71 rdList rd_it junk = panic ("ReadPrefix.rdList:"++junk)
73 rdString, rdIdString :: String -> RETN_TYPE (FAST_STRING, String)
74 rdId :: String -> RETN_TYPE (ProtoName, String)
76 rdString ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
77 RETN (_PK_ (de_escape str), rest)
80 -- partain: tabs and backslashes are escaped
82 de_escape ('\\':'\\':xs) = '\\' : (de_escape xs)
83 de_escape ('\\':'t':xs) = '\t' : (de_escape xs)
84 de_escape (x:xs) = x : (de_escape xs)
86 rdString xs = panic ("ReadPrefix.rdString:"++xs)
88 rdIdString ('#':xs) = BIND (split_at_tab xs) _TO_ (stuff,rest) -> -- no de-escaping...
89 RETN (_PK_ stuff, rest)
91 rdIdString other = panic ("rdIdString:"++other)
93 -- no need to de-escape it...
94 rdId ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
95 RETN (Unk (_PK_ str), rest)
98 split_at_tab :: String -> RETN_TYPE (String, String) -- a la Lennart
102 split_me acc ('\t' : ys) = BIND (my_rev acc []) _TO_ reversed ->
105 split_me acc (y : ys) = split_me (y:acc) ys
107 my_rev "" acc = RETN acc -- instead of reverse, so can see on heap-profiles
108 my_rev (x:xs) acc = my_rev xs (x:acc)
111 %************************************************************************
113 \subsection[rdModule]{@rdModule@: reads in a Haskell module}
115 %************************************************************************
119 -> (FAST_STRING, -- this module's name
120 (FAST_STRING -> Bool, -- a function to chk if <x> is in the export list
121 FAST_STRING -> Bool), -- a function to chk if <M> is among the M..
122 -- ("dotdot") modules in the export list.
123 ProtoNameModule) -- the main goods
125 rdModule (next_char:xs)
126 = case next_char of { 'M' ->
128 BIND (rdString xs) _TO_ (srcline, xs1) ->
129 BIND (rdIdString xs1) _TO_ (name, xs2) ->
130 BIND (rdString xs2) _TO_ (srcfile, xs3) ->
131 BIND (rdBinding srcfile xs3) _TO_ (binding, xs4) ->
132 BIND (rdList rdFixity xs4) _TO_ (fixities, xs5) ->
133 BIND (rdList (rdImportedInterface srcfile) xs5) _TO_ (imports, xs6) ->
134 BIND (rdList rdEntity xs6) _TO_ (export_list, _) ->
136 case sepDeclsForTopBinds binding of {
137 (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
140 mk_export_list_chker export_list,
148 (cvInstDecls True name name instdecls) -- True indicates not imported
151 (cvSepdBinds srcfile cvValSig binds)
153 (mkSrcLoc srcfile srcline)
155 } BEND BEND BEND BEND BEND BEND BEND
158 mk_export_list_chker exp_list
159 = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) ->
160 ( \ n -> n `elemFM` just_the_strings,
161 \ n -> n `elemFM` dotdot_modules )
165 %************************************************************************
167 \subsection[rdExprOrPat]{@rdExpr@ and @rdPat@}
169 %************************************************************************
172 rdExpr :: SrcFile -> String -> RETN_TYPE (ProtoNameExpr, String)
173 rdPat :: SrcFile -> String -> RETN_TYPE (ProtoNamePat, String)
175 rdExpr sf (next_char:xs)
177 '(' -> -- left section
178 BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
179 BIND (rdId xs1) _TO_ (id, xs2) ->
180 RETN (SectionL expr (Var id), xs2)
183 ')' -> -- right section
184 BIND (rdId xs) _TO_ (id, xs1) ->
185 BIND (rdExpr sf xs1) _TO_ (expr,xs2) ->
186 RETN (SectionR (Var id) expr, xs2)
190 BIND (rdString xs) _TO_ (fun, xs1) ->
191 BIND (rdString xs1) _TO_ (flavor, xs2) ->
192 BIND (rdList (rdExpr sf) xs2) _TO_ (args, xs3) ->
194 (flavor == SLIT("p") || flavor == SLIT("P")) -- may invoke GC
195 (flavor == SLIT("N") || flavor == SLIT("P")) -- really a "casm"
196 (panic "CCall:result_ty"),
200 'k' -> -- scc (set-cost-centre) expression
201 BIND (rdString xs) _TO_ (label, xs1) ->
202 BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
203 RETN (SCC label expr, xs2)
206 'l' -> -- lambda expression
207 BIND (rdString xs) _TO_ (srcline, xs1) ->
208 BIND (rdList (rdPat sf) xs1) _TO_ (pats, xs2) ->
209 BIND (rdExpr sf xs2) _TO_ (body, xs3) ->
211 src_loc = mkSrcLoc sf srcline
213 RETN (Lam (foldr PatMatch
214 (GRHSMatch (GRHSsAndBindsIn
215 [OtherwiseGRHS body src_loc]
222 'c' -> -- case expression
223 BIND (rdExpr sf xs) _TO_ (expr, xs1) ->
224 BIND (rdList (rdMatch sf) xs1) _TO_ (mats, xs2) ->
226 matches = cvMatches sf True mats
228 RETN (Case expr matches, xs2)
231 'b' -> -- if expression
232 BIND (rdExpr sf xs) _TO_ (e1, xs1) ->
233 BIND (rdExpr sf xs1) _TO_ (e2, xs2) ->
234 BIND (rdExpr sf xs2) _TO_ (e3, xs3) ->
235 RETN (If e1 e2 e3, xs3)
238 'E' -> -- let expression
239 BIND (rdBinding sf xs) _TO_ (binding,xs1) ->
240 BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
242 binds = cvBinds sf cvValSig binding
244 RETN (Let binds expr, xs2)
247 'Z' -> -- list comprehension
248 BIND (rdExpr sf xs) _TO_ (expr, xs1) ->
249 BIND (rdList rd_qual xs1) _TO_ (quals, xs2) ->
250 RETN (ListComp expr quals, xs2)
254 = BIND (rdPat sf xs) _TO_ (pat, xs1) ->
255 BIND (rdExpr sf xs1) _TO_ (expr,xs2) ->
256 RETN (GeneratorQual pat expr, xs2)
260 = BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
261 RETN (FilterQual expr, xs1)
264 '.' -> -- arithmetic sequence
265 BIND (rdExpr sf xs) _TO_ (e1, xs1) ->
266 BIND (rdList (rdExpr sf) xs1) _TO_ (es2, xs2) ->
267 BIND (rdList (rdExpr sf) xs2) _TO_ (es3, xs3) ->
268 RETN (cv_arith_seq e1 es2 es3, xs3)
271 cv_arith_seq e1 [] [] = ArithSeqIn (From e1)
272 cv_arith_seq e1 [] [e3] = ArithSeqIn (FromTo e1 e3)
273 cv_arith_seq e1 [e2] [] = ArithSeqIn (FromThen e1 e2)
274 cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3)
276 'R' -> -- expression with type signature
277 BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
278 BIND (rdPolyType xs1) _TO_ (ty, xs2) ->
279 RETN (ExprWithTySig expr ty, xs2)
282 '-' -> -- negated expression
283 BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
284 RETN (App (Var (Unk SLIT("negate"))) expr, xs1)
287 '5' -> -- parallel ZF expression
288 BIND (rdExpr sf xs) _TO_ (expr, xs1) ->
289 BIND (rdList (rd_par_qual sf) xs1) _TO_ (qual_list, xs2) ->
291 quals = foldr1 AndParQuals qual_list
293 RETN (RdrParallelZF expr quals, xs2)
298 -- ToDo:DPH: I have kawunkled your RdrExplicitProcessor hack
299 '0':xs -> BIND (rdExPat sf xs) _TO_ (RdrExplicitProcessor pats pat, xs1) ->
300 BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
301 RETN (DrawnGenIn pats pat expr, xs2)
304 'w':xs -> BIND (rdExPat sf xs) _TO_ (RdrExplicitProcessor exprs pat, xs1) ->
305 BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
306 RETN (IndexGen exprs pat expr, xs2)
309 'I':xs -> BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
310 RETN (ParFilter expr, xs1)
313 '6' -> -- explicitPod expression
314 BIND (rdList (rdExpr sf) xs) _TO_ (exprs,xs1) ->
315 RETN (RdrExplicitPod exprs,xs1)
317 #endif {- Data Parallel Haskell -}
319 --------------------------------------------------------------
320 -- now the prefix items that can either be an expression or
321 -- pattern, except we know they are *expressions* here
322 -- (this code could be commoned up with the pattern version;
323 -- but it probably isn't worth it)
324 --------------------------------------------------------------
325 'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) ->
329 'i' -> -- simple identifier
330 BIND (rdId xs) _TO_ (str,xs1) ->
334 'a' -> -- application
335 BIND (rdExpr sf xs) _TO_ (expr1, xs1) ->
336 BIND (rdExpr sf xs1) _TO_ (expr2, xs2) ->
337 RETN (App expr1 expr2, xs2)
340 '@' -> -- operator application
341 BIND (rdExpr sf xs) _TO_ (expr1, xs1) ->
342 BIND (rdId xs1) _TO_ (op, xs2) ->
343 BIND (rdExpr sf xs2) _TO_ (expr2, xs3) ->
344 RETN (OpApp expr1 (Var op) expr2, xs3)
347 ':' -> -- explicit list
348 BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
349 RETN (ExplicitList exprs, xs1)
352 ',' -> -- explicit tuple
353 BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
354 RETN (ExplicitTuple exprs, xs1)
358 'O' -> -- explicitProcessor expression
359 BIND (rdList (rdExpr sf) xs) _TO_ (exprs,xs1) ->
360 BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
361 RETN (ExplicitProcessor exprs expr, xs2)
363 #endif {- Data Parallel Haskell -}
365 huh -> panic ("ReadPrefix.rdExpr:"++(next_char:xs))
368 Patterns: just bear in mind that lists of patterns are represented as
369 a series of ``applications''.
371 rdPat sf (next_char:xs)
373 's' -> -- "as" pattern
374 BIND (rdId xs) _TO_ (id, xs1) ->
375 BIND (rdPat sf xs1) _TO_ (pat,xs2) ->
376 RETN (AsPatIn id pat, xs2)
379 '~' -> -- irrefutable ("twiddle") pattern
380 BIND (rdPat sf xs) _TO_ (pat,xs1) ->
381 RETN (LazyPatIn pat, xs1)
384 '+' -> -- n+k pattern
385 BIND (rdPat sf xs) _TO_ (pat, xs1) ->
386 BIND (rdLiteral xs1) _TO_ (lit, xs2) ->
390 WildPatIn -> error "ERROR: rdPat: GHC can't handle _+k patterns yet"
392 RETN (NPlusKPatIn n lit, xs2)
395 '_' -> -- wildcard pattern
398 --------------------------------------------------------------
399 -- now the prefix items that can either be an expression or
400 -- pattern, except we know they are *patterns* here.
401 --------------------------------------------------------------
402 '-' -> BIND (rdPat sf xs) _TO_ (lit_pat, xs1) ->
404 LitPatIn lit -> RETN (LitPatIn (negLiteral lit), xs1)
405 _ -> panic "rdPat: bad negated pattern!"
408 'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) ->
409 RETN (LitPatIn lit, xs1)
412 'i' -> -- simple identifier
413 BIND (rdIdString xs) _TO_ (str, xs1) ->
414 RETN (if isConop str then
415 ConPatIn (Unk str) []
421 'a' -> -- "application": there's a list of patterns lurking here!
422 BIND (rd_curried_pats xs) _TO_ (lpat:lpats, xs1) ->
423 BIND (rdPat sf xs1) _TO_ (rpat, xs2) ->
427 VarPatIn x -> (x, [])
428 ConPatIn x [] -> (x, [])
429 ConOpPatIn x op y -> (op, [x, y])
430 other -> -- sorry about the weedy msg; the parser missed this one
431 error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)]))
433 arg_pats = llpats ++ lpats ++ [rpat]
434 bad_app = (lpat:lpats) ++ [rpat]
436 RETN (ConPatIn n arg_pats, xs2)
439 rd_curried_pats ('a' : ys)
440 = BIND (rd_curried_pats ys) _TO_ (lpats, ys1) ->
441 BIND (rdPat sf ys1) _TO_ (rpat, ys2) ->
442 RETN (lpats ++ [rpat], ys2)
445 = BIND (rdPat sf ys) _TO_ (pat, ys1) ->
449 '@' -> -- operator application
450 BIND (rdPat sf xs) _TO_ (pat1, xs1) ->
451 BIND (rdId xs1) _TO_ (op, xs2) ->
452 BIND (rdPat sf xs2) _TO_ (pat2, xs3) ->
453 RETN (ConOpPatIn pat1 op pat2, xs3)
456 ':' -> -- explicit list
457 BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
458 RETN (ListPatIn pats, xs1)
461 ',' -> -- explicit tuple
462 BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
463 RETN (TuplePatIn pats, xs1)
467 'O' -> -- explicitProcessor pattern
468 BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
469 BIND (rdPat sf xs1) _TO_ (pat, xs2) ->
470 RETN (ProcessorPatIn pats pat, xs2)
472 #endif {- Data Parallel Haskell -}
474 huh -> panic ("ReadPrefix.rdPat:"++(next_char:xs))
477 OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that
478 to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no
479 expressions). Therefore in the pattern matching below we are taking
480 this into consideration to create the @DrawGen@ whose fields are the
481 \tr{K} patterns, pat and the exp right of the generator.
484 rdLiteral :: String -> RETN_TYPE (Literal, String)
487 = BIND (rdString xs) _TO_ (x, zs) ->
491 as_char = chr ((read s) :: Int)
492 -- a char comes in as a number string
493 -- representing its ASCII code
494 as_integer = readInteger s
495 #if __GLASGOW_HASKELL__ <= 22
496 as_rational = toRational ((read s)::Double)
498 #ifdef __GLASGOW_HASKELL__
499 as_rational = _readRational s -- non-std
501 as_rational = ((read s)::Rational)
504 as_double = ((read s) :: Double)
507 '4' -> RETN (IntLit as_integer, zs);
508 'F' -> RETN (FracLit as_rational, zs);
509 'H' -> RETN (IntPrimLit as_integer, zs);
510 #if __GLASGOW_HASKELL__ <= 22
511 'J' -> RETN (DoublePrimLit as_double,zs);
512 'K' -> RETN (FloatPrimLit as_double, zs);
514 'J' -> RETN (DoublePrimLit as_rational,zs);
515 'K' -> RETN (FloatPrimLit as_rational, zs);
517 'C' -> RETN (CharLit as_char, zs);
518 'P' -> RETN (CharPrimLit as_char, zs);
519 'S' -> RETN (StringLit x, zs);
520 'V' -> RETN (StringPrimLit x, zs);
521 'Y' -> RETN (LitLitLitIn x, zs)
525 %************************************************************************
527 \subsection[rdBinding]{rdBinding}
529 %************************************************************************
532 rdBinding :: SrcFile -> String -> RETN_TYPE (RdrBinding, String)
534 rdBinding sf (next_char:xs)
536 'B' -> -- null binding
537 RETN (RdrNullBind, xs)
539 'A' -> -- "and" binding (just glue, really)
540 BIND (rdBinding sf xs) _TO_ (binding1, xs1) ->
541 BIND (rdBinding sf xs1) _TO_ (binding2, xs2) ->
542 RETN (RdrAndBindings binding1 binding2, xs2)
545 't' -> -- "data" declaration
546 BIND (rdString xs) _TO_ (srcline, xs1) ->
547 BIND (rdContext xs1) _TO_ (ctxt, xs2) ->
548 BIND (rdList rdId xs2) _TO_ (derivings, xs3) ->
549 BIND (rdTyConAndTyVars xs3) _TO_ ((tycon, tyvars), xs4) ->
550 BIND (rdList (rdConDecl sf) xs4) _TO_ (cons, xs5) ->
551 BIND (rdDataPragma xs5) _TO_ (pragma, xs6) ->
553 src_loc = mkSrcLoc sf srcline
555 RETN (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc),
557 BEND BEND BEND BEND BEND BEND
559 'n' -> -- "type" declaration
560 BIND (rdString xs) _TO_ (srcline, xs1) ->
561 BIND (rdTyConAndTyVars xs1) _TO_ ((tycon, tyvars), xs2) ->
562 BIND (rdMonoType xs2) _TO_ (expansion, xs3) ->
563 BIND (rdTypePragma xs3) _TO_ (pragma, xs4) ->
565 src_loc = mkSrcLoc sf srcline
567 RETN (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc),
571 'f' -> -- function binding
572 BIND (rdString xs) _TO_ (srcline, xs1) ->
573 BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) ->
574 RETN (RdrFunctionBinding (read (_UNPK_ srcline)) matches, xs2)
577 'p' -> -- pattern binding
578 BIND (rdString xs) _TO_ (srcline, xs1) ->
579 BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) ->
580 RETN (RdrPatternBinding (read (_UNPK_ srcline)) matches, xs2)
583 '$' -> -- "class" declaration
584 BIND (rdString xs) _TO_ (srcline, xs1) ->
585 BIND (rdContext xs1) _TO_ (ctxt, xs2) ->
586 BIND (rdClassAssertTy xs2) _TO_ ((clas, tyvar), xs3) ->
587 BIND (rdBinding sf xs3) _TO_ (binding, xs4) ->
588 BIND (rdClassPragma xs4) _TO_ (pragma, xs5) ->
590 (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
592 final_sigs = concat (map cvClassOpSig class_sigs)
593 final_methods = cvMonoBinds sf class_methods
595 src_loc = mkSrcLoc sf srcline
598 (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc),
600 BEND BEND BEND BEND BEND
602 '%' -> -- "instance" declaration
603 BIND (rdString xs) _TO_ (srcline, xs1) ->
604 BIND (rdContext xs1) _TO_ (ctxt, xs2) ->
605 BIND (rdId xs2) _TO_ (clas, xs3) ->
606 BIND (rdMonoType xs3) _TO_ (inst_ty, xs4) ->
607 BIND (rdBinding sf xs4) _TO_ (binding, xs5) ->
608 BIND (rdInstPragma xs5) _TO_ (modname_maybe, pragma, xs6) ->
610 (ss, bs) = sepDeclsIntoSigsAndBinds binding
611 binds = cvMonoBinds sf bs
612 uprags = concat (map cvInstDeclSig ss)
613 src_loc = mkSrcLoc sf srcline
615 case modname_maybe of {
617 RETN (RdrInstDecl (\ orig_mod infor_mod here ->
618 InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
621 RETN (RdrInstDecl (\ _ infor_mod here ->
622 InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
625 BEND BEND BEND BEND BEND BEND
627 'D' -> -- "default" declaration
628 BIND (rdString xs) _TO_ (srcline,xs1) ->
629 BIND (rdList rdMonoType xs1) _TO_ (tys, xs2) ->
631 RETN (RdrDefaultDecl (DefaultDecl tys (mkSrcLoc sf srcline)),
635 '7' -> -- "import" declaration in an interface
636 BIND (rdString xs) _TO_ (srcline, xs1) ->
637 BIND (rdIdString xs1) _TO_ (mod, xs2) ->
638 BIND (rdList rdEntity xs2) _TO_ (entities, xs3) ->
639 BIND (rdList rdRenaming xs3) _TO_ (renamings, xs4) ->
641 src_loc = mkSrcLoc sf srcline
643 RETN (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc),
647 'S' -> -- signature(-like) things, including user pragmas
652 rd_sig_thing sf (next_char:xs)
654 't' -> -- type signature
655 BIND (rdString xs) _TO_ (srcline, xs1) ->
656 BIND (rdList rdId xs1) _TO_ (vars, xs2) ->
657 BIND (rdPolyType xs2) _TO_ (poly_ty, xs3) ->
658 BIND (rdTySigPragmas xs3) _TO_ (pragma, xs4) ->
660 src_loc = mkSrcLoc sf srcline
662 RETN (RdrTySig vars poly_ty pragma src_loc, xs4)
665 's' -> -- value specialisation user-pragma
666 BIND (rdString xs) _TO_ (srcline, xs1) ->
667 BIND (rdId xs1) _TO_ (var, xs2) ->
668 BIND (rdList rdPolyType xs2) _TO_ (tys, xs3) ->
670 src_loc = mkSrcLoc sf srcline
672 RETN (RdrSpecValSig [SpecSig var ty Nothing{-ToDo: using...s-} src_loc | ty <- tys], xs3)
675 'S' -> -- instance specialisation user-pragma
676 BIND (rdString xs) _TO_ (srcline, xs1) ->
677 BIND (rdId xs1) _TO_ (clas, xs2) ->
678 BIND (rdMonoType xs2) _TO_ (ty, xs3) ->
680 src_loc = mkSrcLoc sf srcline
682 RETN (RdrSpecInstSig (InstSpecSig clas ty src_loc), xs3)
685 'i' -> -- value inlining user-pragma
686 BIND (rdString xs) _TO_ (srcline, xs1) ->
687 BIND (rdId xs1) _TO_ (var, xs2) ->
688 BIND (rdList rdIdString xs2) _TO_ (howto, xs3) ->
690 src_loc = mkSrcLoc sf srcline
695 [x] -> trace "ignoring unfold howto" }) UnfoldAlways
697 RETN (RdrInlineValSig (InlineSig var guidance src_loc), xs3)
700 'd' -> -- value deforest user-pragma
701 BIND (rdString xs) _TO_ (srcline, xs1) ->
702 BIND (rdId xs1) _TO_ (var, xs2) ->
704 src_loc = mkSrcLoc sf srcline
706 RETN (RdrDeforestSig (DeforestSig var src_loc), xs2)
709 'u' -> -- value magic-unfolding user-pragma
710 BIND (rdString xs) _TO_ (srcline, xs1) ->
711 BIND (rdId xs1) _TO_ (var, xs2) ->
712 BIND (rdIdString xs2) _TO_ (str, xs3) ->
714 src_loc = mkSrcLoc sf srcline
716 RETN (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc), xs3)
719 'a' -> -- abstract-type-synonym user-pragma
720 BIND (rdString xs) _TO_ (srcline, xs1) ->
721 BIND (rdId xs1) _TO_ (tycon, xs2) ->
723 src_loc = mkSrcLoc sf srcline
725 RETN (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc), xs2)
728 'd' -> -- data specialisation user-pragma
729 BIND (rdString xs) _TO_ (srcline, xs1) ->
730 BIND (rdId xs1) _TO_ (tycon, xs2) ->
731 BIND (rdList rdMonoType xs2) _TO_ (tys, xs3) ->
733 src_loc = mkSrcLoc sf srcline
734 spec_ty = MonoTyCon tycon tys
736 RETN (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc), xs3)
740 %************************************************************************
742 \subsection[rdTypes]{Reading in types in various forms (and data constructors)}
744 %************************************************************************
747 rdPolyType :: String -> RETN_TYPE (ProtoNamePolyType, String)
748 rdMonoType :: String -> RETN_TYPE (ProtoNameMonoType, String)
750 rdPolyType ('3' : xs)
751 = BIND (rdContext xs) _TO_ (ctxt, xs1) ->
752 BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
753 RETN (OverloadedTy ctxt ty, xs2)
756 rdPolyType ('2' : 'C' : xs)
757 = BIND (rdList rdId xs) _TO_ (tvs, xs1) ->
758 BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
759 RETN (ForAllTy tvs ty, xs2)
763 = BIND (rdMonoType other) _TO_ (ty, xs1) ->
764 RETN (UnoverloadedTy ty, xs1)
767 rdMonoType ('T' : xs)
768 = BIND (rdId xs) _TO_ (tycon, xs1) ->
769 BIND (rdList rdMonoType xs1) _TO_ (tys, xs2) ->
770 RETN (MonoTyCon tycon tys, xs2)
773 rdMonoType (':' : xs)
774 = BIND (rdMonoType xs) _TO_ (ty, xs1) ->
775 RETN (ListMonoTy ty, xs1)
778 rdMonoType (',' : xs)
779 = BIND (rdList rdPolyType xs) _TO_ (tys, xs1) ->
780 RETN (TupleMonoTy tys, xs1)
783 rdMonoType ('>' : xs)
784 = BIND (rdMonoType xs) _TO_ (ty1, xs1) ->
785 BIND (rdMonoType xs1) _TO_ (ty2, xs2) ->
786 RETN (FunMonoTy ty1 ty2, xs2)
789 rdMonoType ('y' : xs)
790 = BIND (rdId xs) _TO_ (tyvar, xs1) ->
791 RETN (MonoTyVar tyvar, xs1)
794 rdMonoType ('2' : 'A' : xs)
795 = BIND (rdId xs) _TO_ (clas, xs1) ->
796 BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
797 RETN (MonoDict clas ty, xs2)
800 rdMonoType ('2' : 'B' : xs)
801 = BIND (rdId xs) _TO_ (tv_tmpl, xs1) ->
802 RETN (MonoTyVarTemplate tv_tmpl, xs1)
806 rdMonoType ('v' : xs)
807 = BIND (rdMonoType xs) _TO_ (ty, xs1) ->
808 RETN (RdrExplicitPodTy ty, xs1)
811 rdMonoType ('u' : xs)
812 = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
813 BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
814 RETN (RdrExplicitProcessorTy tys ty, xs2)
816 #endif {- Data Parallel Haskell -}
818 rdMonoType oops = panic ("rdMonoType:"++oops)
822 rdTyConAndTyVars :: String -> RETN_TYPE ((ProtoName, [ProtoName]), String)
823 rdContext :: String -> RETN_TYPE (ProtoNameContext, String)
824 rdClassAssertTy :: String -> RETN_TYPE ((ProtoName, ProtoName), String)
827 = BIND (rdMonoType xs) _TO_ (MonoTyCon tycon ty_args, xs1) ->
829 args = [ a | (MonoTyVar a) <- ty_args ]
831 RETN ((tycon, args), xs1)
835 = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
836 RETN (map mk_class_assertion tys, xs1)
840 = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) ->
841 RETN (mk_class_assertion mono_ty, xs1)
844 mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
846 mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname)
847 mk_class_assertion other
848 = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
849 -- regrettably, the parser does let some junk past
850 -- e.g., f :: Num {-nothing-} => a -> ...
854 rdConDecl :: SrcFile -> String -> RETN_TYPE (ProtoNameConDecl, String)
856 rdConDecl sf ('1':xs)
857 = BIND (rdString xs) _TO_ (srcline, xs1) ->
858 BIND (rdId xs1) _TO_ (id, xs2) ->
859 BIND (rdList rdMonoType xs2) _TO_ (tys, xs3) ->
860 RETN (ConDecl id tys (mkSrcLoc sf srcline), xs3)
864 %************************************************************************
866 \subsection[rdMatch]{Read a ``match''}
868 %************************************************************************
871 rdMatch :: SrcFile -> String -> RETN_TYPE (RdrMatch, String)
874 = BIND (rdString xs) _TO_ (srcline, xs1) ->
875 BIND (rdIdString xs1) _TO_ (srcfun, xs2) ->
876 BIND (rdPat sf xs2) _TO_ (pat, xs3) ->
877 BIND (rdList rd_guarded xs3) _TO_ (grhss, xs4) ->
878 BIND (rdBinding sf xs4) _TO_ (binding, xs5) ->
880 RETN (RdrMatch (read (_UNPK_ srcline)) srcfun pat grhss binding, xs5)
881 BEND BEND BEND BEND BEND
884 = BIND (rdExpr sf xs) _TO_ (g, xs1) ->
885 BIND (rdExpr sf xs1) _TO_ (e, xs2) ->
890 %************************************************************************
892 \subsection[rdFixity]{Read in a fixity declaration}
894 %************************************************************************
897 rdFixity :: String -> RETN_TYPE (ProtoNameFixityDecl, String)
899 = BIND (rdId xs) _TO_ (op, xs1) ->
900 BIND (rdString xs1) _TO_ (associativity, xs2) ->
901 BIND (rdString xs2) _TO_ (prec_str, xs3) ->
903 precedence = read (_UNPK_ prec_str)
905 case (_UNPK_ associativity) of {
906 "infix" -> RETN (InfixN op precedence, xs3);
907 "infixl" -> RETN (InfixL op precedence, xs3);
908 "infixr" -> RETN (InfixR op precedence, xs3)
912 %************************************************************************
914 \subsection[rdImportedInterface]{Read an imported interface}
916 %************************************************************************
919 rdImportedInterface :: FAST_STRING -> String
920 -> RETN_TYPE (ProtoNameImportedInterface, String)
922 rdImportedInterface importing_srcfile (x:xs)
923 = BIND (rdString xs) _TO_ (srcline, xs1) ->
924 BIND (rdString xs1) _TO_ (srcfile, xs2) ->
925 BIND (rdIdString xs2) _TO_ (modname, xs3) ->
926 BIND (rdList rdEntity xs3) _TO_ (imports, xs4) ->
927 BIND (rdList rdRenaming xs4) _TO_ (renamings,xs5) ->
928 BIND (rdBinding srcfile xs5) _TO_ (iface_bs, xs6) ->
930 case (sepDeclsForInterface iface_bs) of {
931 (tydecls,classdecls,instdecls,sigs,iimpdecls) ->
933 expose_or_hide = case x of { 'e' -> ImportSome; 'h' -> ImportButHide }
936 = MkInterface modname
938 [{-fixity decls-}] -- can't get fixity decls in here yet (ToDo)
941 (cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-}
943 -- False indicates imported
944 (concat (map cvValSig sigs))
945 (mkSrcLoc importing_srcfile srcline)
948 (if null imports then
949 ImportAll cv_iface renamings
951 expose_or_hide cv_iface imports renamings
953 } BEND BEND BEND BEND BEND BEND
957 rdRenaming :: String -> RETN_TYPE (Renaming, String)
960 = BIND (rdIdString xs) _TO_ (id1, xs1) ->
961 BIND (rdIdString xs1) _TO_ (id2, xs2) ->
962 RETN (MkRenaming id1 id2, xs2)
967 rdEntity :: String -> RETN_TYPE (IE, String)
971 'x':xs -> BIND (rdIdString xs) _TO_ (var, xs1) ->
972 RETN (IEVar var, xs1)
975 'X':xs -> BIND (rdIdString xs) _TO_ (thing, xs1) ->
976 RETN (IEThingAbs thing, xs1)
979 'z':xs -> BIND (rdIdString xs) _TO_ (thing, xs1) ->
980 RETN (IEThingAll thing, xs1)
983 '8':xs -> BIND (rdIdString xs) _TO_ (tycon, xs1) ->
984 BIND (rdList rdString xs1) _TO_ (cons, xs2) ->
985 RETN (IEConWithCons tycon cons, xs2)
988 '9':xs -> BIND (rdIdString xs) _TO_ (c, xs1) ->
989 BIND (rdList rdString xs1) _TO_ (ops, xs2) ->
990 RETN (IEClsWithOps c ops, xs2)
993 'm':xs -> BIND (rdIdString xs) _TO_ (m, xs1) ->
994 RETN (IEModuleContents m, xs1)