%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
-\section[ReadPrefix]{Read prefix-form input}
-
-This module contains a function, @rdModule@, which reads a Haskell
-module in `prefix form' emitted by the Lex/Yacc parser.
-
-The prefix form string is converted into an algebraic data type
-defined in @PrefixSyn@.
-
-Identifier names are converted into the @ProtoName@ data type.
-
-@sf@ is used consistently to mean ``source file'' (name).
+\section{Read parse tree built by Yacc parser}
\begin{code}
--- HBC does not have stack stubbing; you get a space leak w/
--- default defns from HsVersions.h.
-
--- GHC may be overly slow to compile w/ the defaults...
-
-#define BIND {--}
-#define _TO_ `thenLft` ( \ {--}
-#define BEND )
-#define RETN returnLft
-#define RETN_TYPE LiftM
-
#include "HsVersions.h"
-\end{code}
-\begin{code}
module ReadPrefix (
- rdModule,
-
- rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType
- ) where
+ rdModule
+ ) where
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
+import Ubiq
-import AbsSyn
-import HsCore -- ****** NEED TO SEE CONSTRUCTORS ******
-import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ******
-import IdInfo ( UnfoldingGuidance(..) )
-import LiftMonad
-import Maybes ( Maybe(..) )
+import UgenAll -- all Yacc parser gumpff...
+import PrefixSyn -- and various syntaxen.
+import HsSyn
+import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas )
+import RdrHsSyn
import PrefixToHs
-import PrefixSyn
-import ProtoName
-import Outputable
-import ReadPragmas
-import SrcLoc ( mkSrcLoc )
-import Util
+
+import CmdLineOpts ( opt_CompilingPrelude )
+import ErrUtils ( addErrLoc )
+import FiniteMap ( elemFM, FiniteMap )
+import MainMonad ( writeMn, exitMn, MainIO(..) )
+import Name ( RdrName(..), isConopRdr )
+import PprStyle ( PprStyle(..) )
+import Pretty
+import SrcLoc ( SrcLoc )
+import Util ( nOfThem, pprError, panic )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rdList :: (String -> RETN_TYPE (a, String)) -> String -> RETN_TYPE ([a], String)
-
-rdList rd_it ('N':xs) = RETN ([], xs)
-rdList rd_it ('L':xs)
- = BIND (rd_it xs) _TO_ (hd_it, xs1) ->
- BIND (rdList rd_it xs1) _TO_ (tl_it, xs2) ->
- RETN (hd_it : tl_it, xs2)
- BEND BEND
-rdList rd_it junk = panic ("ReadPrefix.rdList:"++junk)
-
-rdString, rdIdString :: String -> RETN_TYPE (FAST_STRING, String)
-rdId :: String -> RETN_TYPE (ProtoName, String)
-
-rdString ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
- RETN (_PK_ (de_escape str), rest)
- BEND
- where
- -- partain: tabs and backslashes are escaped
- de_escape [] = []
- de_escape ('\\':'\\':xs) = '\\' : (de_escape xs)
- de_escape ('\\':'t':xs) = '\t' : (de_escape xs)
- de_escape (x:xs) = x : (de_escape xs)
-
-rdString xs = panic ("ReadPrefix.rdString:"++xs)
-
-rdIdString ('#':xs) = BIND (split_at_tab xs) _TO_ (stuff,rest) -> -- no de-escaping...
- RETN (_PK_ stuff, rest)
- BEND
-rdIdString other = panic ("rdIdString:"++other)
-
- -- no need to de-escape it...
-rdId ('#':xs) = BIND (split_at_tab xs) _TO_ (str, rest) ->
- RETN (Unk (_PK_ str), rest)
- BEND
-
-split_at_tab :: String -> RETN_TYPE (String, String) -- a la Lennart
-split_at_tab xs
- = split_me [] xs
- where
- split_me acc ('\t' : ys) = BIND (my_rev acc []) _TO_ reversed ->
- RETN (reversed, ys)
- BEND
- split_me acc (y : ys) = split_me (y:acc) ys
+wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
+
+wlkList wlk_it U_lnil = returnUgn []
- my_rev "" acc = RETN acc -- instead of reverse, so can see on heap-profiles
- my_rev (x:xs) acc = my_rev xs (x:acc)
+wlkList wlk_it (U_lcons hd tl)
+ = wlk_it hd `thenUgn` \ hd_it ->
+ wlkList wlk_it tl `thenUgn` \ tl_it ->
+ returnUgn (hd_it : tl_it)
+\end{code}
+
+\begin{code}
+wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
+
+wlkMaybe wlk_it U_nothing = returnUgn Nothing
+wlkMaybe wlk_it (U_just x)
+ = wlk_it x `thenUgn` \ it ->
+ returnUgn (Just it)
+\end{code}
+
+\begin{code}
+rdQid :: ParseTree -> UgnM RdrName
+rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
+
+wlkQid :: U_qid -> UgnM RdrName
+wlkQid (U_noqual name)
+ = returnUgn (Unqual name)
+wlkQid (U_aqual mod name)
+ = returnUgn (Qual mod name)
+wlkQid (U_gid n name)
+ = returnUgn (Unqual name)
+
+cvFlag :: U_long -> Bool
+cvFlag 0 = False
+cvFlag 1 = True
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rdModule :: String
- -> (FAST_STRING, -- this module's name
- (FAST_STRING -> Bool, -- a function to chk if <x> is in the export list
- FAST_STRING -> Bool), -- a function to chk if <M> is among the M..
- -- ("dotdot") modules in the export list.
- ProtoNameModule) -- the main goods
-
-rdModule (next_char:xs)
- = case next_char of { 'M' ->
-
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdIdString xs1) _TO_ (name, xs2) ->
- BIND (rdString xs2) _TO_ (srcfile, xs3) ->
- BIND (rdBinding srcfile xs3) _TO_ (binding, xs4) ->
- BIND (rdList rdFixity xs4) _TO_ (fixities, xs5) ->
- BIND (rdList (rdImportedInterface srcfile) xs5) _TO_ (imports, xs6) ->
- BIND (rdList rdEntity xs6) _TO_ (export_list, _) ->
-
- case sepDeclsForTopBinds binding of {
- (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
-
- (name,
- mk_export_list_chker export_list,
- Module name
- export_list
- imports
- fixities
- tydecls
- tysigs
- classdecls
- (cvInstDecls True name name instdecls) -- True indicates not imported
- instsigs
- defaultdecls
- (cvSepdBinds srcfile cvValSig binds)
- [{-no sigs-}]
- (mkSrcLoc srcfile srcline)
- )
- } BEND BEND BEND BEND BEND BEND BEND
- }
- where
- mk_export_list_chker exp_list
- = case (getIEStrings exp_list) of { (entity_info, dotdot_modules) ->
- ( \ n -> n `elemFM` just_the_strings,
- \ n -> n `elemFM` dotdot_modules )
- }
+rdModule :: MainIO (Module, -- this module's name
+ RdrNameHsModule) -- the main goods
+
+rdModule
+ = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
+ let
+ srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM)
+ in
+ initUgn $
+ rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
+ hmodlist srciface_version srcline) ->
+
+ setSrcFileUgn srcfile $
+ setSrcModUgn modname $
+ mkSrcLocUgn srcline $ \ src_loc ->
+
+ wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
+ wlkList rdImport himplist `thenUgn` \ imports ->
+ wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
+ wlkBinding hmodlist `thenUgn` \ binding ->
+
+ case sepDeclsForTopBinds binding of
+ (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
+
+ returnUgn (modname,
+ HsModule modname
+ (case srciface_version of { 0 -> Nothing; n -> Just n })
+ exports
+ imports
+ fixities
+ tydecls
+ tysigs
+ classdecls
+ instdecls
+ instsigs
+ defaultdecls
+ (cvSepdBinds srcfile cvValSig binds)
+ [{-no interface sigs yet-}]
+ src_loc
+ )
\end{code}
%************************************************************************
%* *
-\subsection[rdExprOrPat]{@rdExpr@ and @rdPat@}
+\subsection[wlkExprOrPat]{@wlkExpr@ and @wlkPat@}
%* *
%************************************************************************
\begin{code}
-rdExpr :: SrcFile -> String -> RETN_TYPE (ProtoNameExpr, String)
-rdPat :: SrcFile -> String -> RETN_TYPE (ProtoNamePat, String)
-
-rdExpr sf (next_char:xs)
- = case next_char of
- '(' -> -- left section
- BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- BIND (rdId xs1) _TO_ (id, xs2) ->
- RETN (SectionL expr (Var id), xs2)
- BEND BEND
-
- ')' -> -- right section
- BIND (rdId xs) _TO_ (id, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr,xs2) ->
- RETN (SectionR (Var id) expr, xs2)
- BEND BEND
-
- 'j' -> -- ccall/casm
- BIND (rdString xs) _TO_ (fun, xs1) ->
- BIND (rdString xs1) _TO_ (flavor, xs2) ->
- BIND (rdList (rdExpr sf) xs2) _TO_ (args, xs3) ->
- RETN (CCall fun args
- (flavor == SLIT("p") || flavor == SLIT("P")) -- may invoke GC
- (flavor == SLIT("N") || flavor == SLIT("P")) -- really a "casm"
- (panic "CCall:result_ty"),
- xs3)
- BEND BEND BEND
-
- 'k' -> -- scc (set-cost-centre) expression
- BIND (rdString xs) _TO_ (label, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- RETN (SCC label expr, xs2)
- BEND BEND
-
- 'l' -> -- lambda expression
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdList (rdPat sf) xs1) _TO_ (pats, xs2) ->
- BIND (rdExpr sf xs2) _TO_ (body, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (Lam (foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn
- [OtherwiseGRHS body src_loc]
- EmptyBinds))
- pats
- ),
- xs3)
- BEND BEND BEND
-
- 'c' -> -- case expression
- BIND (rdExpr sf xs) _TO_ (expr, xs1) ->
- BIND (rdList (rdMatch sf) xs1) _TO_ (mats, xs2) ->
- let
- matches = cvMatches sf True mats
- in
- RETN (Case expr matches, xs2)
- BEND BEND
-
- 'b' -> -- if expression
- BIND (rdExpr sf xs) _TO_ (e1, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (e2, xs2) ->
- BIND (rdExpr sf xs2) _TO_ (e3, xs3) ->
- RETN (If e1 e2 e3, xs3)
- BEND BEND BEND
-
- 'E' -> -- let expression
- BIND (rdBinding sf xs) _TO_ (binding,xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- let
- binds = cvBinds sf cvValSig binding
- in
- RETN (Let binds expr, xs2)
- BEND BEND
-
- 'Z' -> -- list comprehension
- BIND (rdExpr sf xs) _TO_ (expr, xs1) ->
- BIND (rdList rd_qual xs1) _TO_ (quals, xs2) ->
- RETN (ListComp expr quals, xs2)
- BEND BEND
- where
- rd_qual ('G':xs)
- = BIND (rdPat sf xs) _TO_ (pat, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr,xs2) ->
- RETN (GeneratorQual pat expr, xs2)
- BEND BEND
-
- rd_qual ('g':xs)
- = BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- RETN (FilterQual expr, xs1)
- BEND
-
- '.' -> -- arithmetic sequence
- BIND (rdExpr sf xs) _TO_ (e1, xs1) ->
- BIND (rdList (rdExpr sf) xs1) _TO_ (es2, xs2) ->
- BIND (rdList (rdExpr sf) xs2) _TO_ (es3, xs3) ->
- RETN (cv_arith_seq e1 es2 es3, xs3)
- BEND BEND BEND
- where
- cv_arith_seq e1 [] [] = ArithSeqIn (From e1)
- cv_arith_seq e1 [] [e3] = ArithSeqIn (FromTo e1 e3)
- cv_arith_seq e1 [e2] [] = ArithSeqIn (FromThen e1 e2)
- cv_arith_seq e1 [e2] [e3] = ArithSeqIn (FromThenTo e1 e2 e3)
-
- 'R' -> -- expression with type signature
- BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- BIND (rdPolyType xs1) _TO_ (ty, xs2) ->
- RETN (ExprWithTySig expr ty, xs2)
- BEND BEND
-
- '-' -> -- negated expression
- BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- RETN (App (Var (Unk SLIT("negate"))) expr, xs1)
- BEND
-#ifdef DPH
- '5' -> -- parallel ZF expression
- BIND (rdExpr sf xs) _TO_ (expr, xs1) ->
- BIND (rdList (rd_par_qual sf) xs1) _TO_ (qual_list, xs2) ->
- let
- quals = foldr1 AndParQuals qual_list
- in
- RETN (RdrParallelZF expr quals, xs2)
- BEND BEND
- where
- rdParQual sf inp
- = case inp of
- -- ToDo:DPH: I have kawunkled your RdrExplicitProcessor hack
- '0':xs -> BIND (rdExPat sf xs) _TO_ (RdrExplicitProcessor pats pat, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- RETN (DrawnGenIn pats pat expr, xs2)
- BEND BEND
-
- 'w':xs -> BIND (rdExPat sf xs) _TO_ (RdrExplicitProcessor exprs pat, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- RETN (IndexGen exprs pat expr, xs2)
- BEND BEND
-
- 'I':xs -> BIND (rdExpr sf xs) _TO_ (expr,xs1) ->
- RETN (ParFilter expr, xs1)
- BEND
-
- '6' -> -- explicitPod expression
- BIND (rdList (rdExpr sf) xs) _TO_ (exprs,xs1) ->
- RETN (RdrExplicitPod exprs,xs1)
- BEND
-#endif {- Data Parallel Haskell -}
-
- --------------------------------------------------------------
- -- now the prefix items that can either be an expression or
- -- pattern, except we know they are *expressions* here
- -- (this code could be commoned up with the pattern version;
- -- but it probably isn't worth it)
- --------------------------------------------------------------
- 'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) ->
- RETN (Lit lit, xs1)
- BEND
-
- 'i' -> -- simple identifier
- BIND (rdId xs) _TO_ (str,xs1) ->
- RETN (Var str, xs1)
- BEND
-
- 'a' -> -- application
- BIND (rdExpr sf xs) _TO_ (expr1, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr2, xs2) ->
- RETN (App expr1 expr2, xs2)
- BEND BEND
-
- '@' -> -- operator application
- BIND (rdExpr sf xs) _TO_ (expr1, xs1) ->
- BIND (rdId xs1) _TO_ (op, xs2) ->
- BIND (rdExpr sf xs2) _TO_ (expr2, xs3) ->
- RETN (OpApp expr1 (Var op) expr2, xs3)
- BEND BEND BEND
-
- ':' -> -- explicit list
- BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
- RETN (ExplicitList exprs, xs1)
- BEND
-
- ',' -> -- explicit tuple
- BIND (rdList (rdExpr sf) xs) _TO_ (exprs, xs1) ->
- RETN (ExplicitTuple exprs, xs1)
- BEND
-
-#ifdef DPH
- 'O' -> -- explicitProcessor expression
- BIND (rdList (rdExpr sf) xs) _TO_ (exprs,xs1) ->
- BIND (rdExpr sf xs1) _TO_ (expr, xs2) ->
- RETN (ExplicitProcessor exprs expr, xs2)
- BEND BEND
-#endif {- Data Parallel Haskell -}
-
- huh -> panic ("ReadPrefix.rdExpr:"++(next_char:xs))
+rdExpr :: ParseTree -> UgnM RdrNameHsExpr
+rdPat :: ParseTree -> UgnM RdrNamePat
+
+rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
+rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
+
+wlkExpr :: U_tree -> UgnM RdrNameHsExpr
+wlkPat :: U_tree -> UgnM RdrNamePat
+
+wlkExpr expr
+ = case expr of
+ U_par pexpr -> -- parenthesised expr
+ wlkExpr pexpr `thenUgn` \ expr ->
+ returnUgn (HsPar expr)
+
+ U_lsection lsexp lop -> -- left section
+ wlkExpr lsexp `thenUgn` \ expr ->
+ wlkQid lop `thenUgn` \ op ->
+ returnUgn (SectionL expr (HsVar op))
+
+ U_rsection rop rsexp -> -- right section
+ wlkQid rop `thenUgn` \ op ->
+ wlkExpr rsexp `thenUgn` \ expr ->
+ returnUgn (SectionR (HsVar op) expr)
+
+ U_ccall fun flavor ccargs -> -- ccall/casm
+ wlkList rdExpr ccargs `thenUgn` \ args ->
+ let
+ tag = _HEAD_ flavor
+ in
+ returnUgn (CCall fun args
+ (tag == 'p' || tag == 'P') -- may invoke GC
+ (tag == 'N' || tag == 'P') -- really a "casm"
+ (panic "CCall:result_ty"))
+
+ U_scc label sccexp -> -- scc (set-cost-centre) expression
+ wlkExpr sccexp `thenUgn` \ expr ->
+ returnUgn (HsSCC label expr)
+
+ U_lambda lampats lamexpr srcline -> -- lambda expression
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdPat lampats `thenUgn` \ pats ->
+ wlkExpr lamexpr `thenUgn` \ body ->
+ returnUgn (
+ HsLam (foldr PatMatch
+ (GRHSMatch (GRHSsAndBindsIn
+ [OtherwiseGRHS body src_loc]
+ EmptyBinds))
+ pats)
+ )
+
+ U_casee caseexpr casebody srcline -> -- case expression
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkExpr caseexpr `thenUgn` \ expr ->
+ wlkList rdMatch casebody `thenUgn` \ mats ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ matches = cvMatches sf True mats
+ in
+ returnUgn (HsCase expr matches src_loc)
+
+ U_ife ifpred ifthen ifelse srcline -> -- if expression
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkExpr ifpred `thenUgn` \ e1 ->
+ wlkExpr ifthen `thenUgn` \ e2 ->
+ wlkExpr ifelse `thenUgn` \ e3 ->
+ returnUgn (HsIf e1 e2 e3 src_loc)
+
+ U_let letvdefs letvexpr -> -- let expression
+ wlkBinding letvdefs `thenUgn` \ binding ->
+ wlkExpr letvexpr `thenUgn` \ expr ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ binds = cvBinds sf cvValSig binding
+ in
+ returnUgn (HsLet binds expr)
+
+ U_doe gdo srcline -> -- do expression
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rd_stmt gdo `thenUgn` \ stmts ->
+ returnUgn (HsDo stmts src_loc)
+ where
+ rd_stmt pt
+ = rdU_tree pt `thenUgn` \ bind ->
+ case bind of
+ U_doexp exp srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkExpr exp `thenUgn` \ expr ->
+ returnUgn (ExprStmt expr src_loc)
+
+ U_dobind pat exp srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkPat pat `thenUgn` \ patt ->
+ wlkExpr exp `thenUgn` \ expr ->
+ returnUgn (BindStmt patt expr src_loc)
+
+ U_seqlet seqlet ->
+ wlkBinding seqlet `thenUgn` \ bs ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ binds = cvBinds sf cvValSig bs
+ in
+ returnUgn (LetStmt binds)
+
+ U_comprh cexp cquals -> -- list comprehension
+ wlkExpr cexp `thenUgn` \ expr ->
+ wlkList rd_qual cquals `thenUgn` \ quals ->
+ returnUgn (ListComp expr quals)
+ where
+ rd_qual pt
+ = rdU_tree pt `thenUgn` \ qual ->
+ wlk_qual qual
+
+ wlk_qual qual
+ = case qual of
+ U_guard exp ->
+ wlkExpr exp `thenUgn` \ expr ->
+ returnUgn (FilterQual expr)
+
+ U_qual qpat qexp ->
+ wlkPat qpat `thenUgn` \ pat ->
+ wlkExpr qexp `thenUgn` \ expr ->
+ returnUgn (GeneratorQual pat expr)
+
+ U_seqlet seqlet ->
+ wlkBinding seqlet `thenUgn` \ bs ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ binds = cvBinds sf cvValSig bs
+ in
+ returnUgn (LetQual binds)
+
+ U_eenum efrom estep eto -> -- arithmetic sequence
+ wlkExpr efrom `thenUgn` \ e1 ->
+ wlkMaybe rdExpr estep `thenUgn` \ es2 ->
+ wlkMaybe rdExpr eto `thenUgn` \ es3 ->
+ returnUgn (cv_arith_seq e1 es2 es3)
+ where
+ cv_arith_seq e1 Nothing Nothing = ArithSeqIn (From e1)
+ cv_arith_seq e1 Nothing (Just e3) = ArithSeqIn (FromTo e1 e3)
+ cv_arith_seq e1 (Just e2) Nothing = ArithSeqIn (FromThen e1 e2)
+ cv_arith_seq e1 (Just e2) (Just e3) = ArithSeqIn (FromThenTo e1 e2 e3)
+
+ U_restr restre restrt -> -- expression with type signature
+ wlkExpr restre `thenUgn` \ expr ->
+ wlkPolyType restrt `thenUgn` \ ty ->
+ returnUgn (ExprWithTySig expr ty)
+
+ --------------------------------------------------------------
+ -- now the prefix items that can either be an expression or
+ -- pattern, except we know they are *expressions* here
+ -- (this code could be commoned up with the pattern version;
+ -- but it probably isn't worth it)
+ --------------------------------------------------------------
+ U_lit lit ->
+ wlkLiteral lit `thenUgn` \ lit ->
+ returnUgn (HsLit lit)
+
+ U_ident n -> -- simple identifier
+ wlkQid n `thenUgn` \ var ->
+ returnUgn (HsVar var)
+
+ U_ap fun arg -> -- application
+ wlkExpr fun `thenUgn` \ expr1 ->
+ wlkExpr arg `thenUgn` \ expr2 ->
+ returnUgn (HsApp expr1 expr2)
+
+ U_infixap fun arg1 arg2 -> -- infix application
+ wlkQid fun `thenUgn` \ op ->
+ wlkExpr arg1 `thenUgn` \ expr1 ->
+ wlkExpr arg2 `thenUgn` \ expr2 ->
+ returnUgn (OpApp expr1 (HsVar op) expr2)
+
+ U_negate nexp -> -- prefix negation
+ wlkExpr nexp `thenUgn` \ expr ->
+ returnUgn (NegApp expr)
+
+ U_llist llist -> -- explicit list
+ wlkList rdExpr llist `thenUgn` \ exprs ->
+ returnUgn (ExplicitList exprs)
+
+ U_tuple tuplelist -> -- explicit tuple
+ wlkList rdExpr tuplelist `thenUgn` \ exprs ->
+ returnUgn (ExplicitTuple exprs)
+
+ U_record con rbinds -> -- record construction
+ wlkQid con `thenUgn` \ rcon ->
+ wlkList rdRbind rbinds `thenUgn` \ recbinds ->
+ returnUgn (RecordCon (HsVar rcon) recbinds)
+
+ U_rupdate updexp updbinds -> -- record update
+ wlkExpr updexp `thenUgn` \ aexp ->
+ wlkList rdRbind updbinds `thenUgn` \ recbinds ->
+ returnUgn (RecordUpd aexp recbinds)
+
+#ifdef DEBUG
+ U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
+ U_as _ _ -> error "U_as"
+ U_lazyp _ -> error "U_lazyp"
+ U_wildp -> error "U_wildp"
+ U_qual _ _ -> error "U_qual"
+ U_guard _ -> error "U_guard"
+ U_seqlet _ -> error "U_seqlet"
+ U_dobind _ _ _ -> error "U_dobind"
+ U_doexp _ _ -> error "U_doexp"
+ U_rbind _ _ -> error "U_rbind"
+ U_fixop _ _ _ -> error "U_fixop"
+#endif
+
+rdRbind pt
+ = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
+ wlkQid var `thenUgn` \ rvar ->
+ wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
+ returnUgn (
+ case expr_maybe of
+ Nothing -> (rvar, HsVar rvar, True{-pun-})
+ Just re -> (rvar, re, False)
+ )
\end{code}
Patterns: just bear in mind that lists of patterns are represented as
a series of ``applications''.
\begin{code}
-rdPat sf (next_char:xs)
- = case next_char of
- 's' -> -- "as" pattern
- BIND (rdId xs) _TO_ (id, xs1) ->
- BIND (rdPat sf xs1) _TO_ (pat,xs2) ->
- RETN (AsPatIn id pat, xs2)
- BEND BEND
-
- '~' -> -- irrefutable ("twiddle") pattern
- BIND (rdPat sf xs) _TO_ (pat,xs1) ->
- RETN (LazyPatIn pat, xs1)
- BEND
-
- '+' -> -- n+k pattern
- BIND (rdPat sf xs) _TO_ (pat, xs1) ->
- BIND (rdLiteral xs1) _TO_ (lit, xs2) ->
- let
- n = case pat of
- VarPatIn n -> n
- WildPatIn -> error "ERROR: rdPat: GHC can't handle _+k patterns yet"
- in
- RETN (NPlusKPatIn n lit, xs2)
- BEND BEND
-
- '_' -> -- wildcard pattern
- RETN (WildPatIn, xs)
-
- --------------------------------------------------------------
- -- now the prefix items that can either be an expression or
- -- pattern, except we know they are *patterns* here.
- --------------------------------------------------------------
- '-' -> BIND (rdPat sf xs) _TO_ (lit_pat, xs1) ->
- case lit_pat of
- LitPatIn lit -> RETN (LitPatIn (negLiteral lit), xs1)
- _ -> panic "rdPat: bad negated pattern!"
- BEND
-
- 'C' -> BIND (rdLiteral xs) _TO_ (lit, xs1) ->
- RETN (LitPatIn lit, xs1)
- BEND
-
- 'i' -> -- simple identifier
- BIND (rdIdString xs) _TO_ (str, xs1) ->
- RETN (if isConop str then
- ConPatIn (Unk str) []
- else
- VarPatIn (Unk str),
- xs1)
- BEND
-
- 'a' -> -- "application": there's a list of patterns lurking here!
- BIND (rd_curried_pats xs) _TO_ (lpat:lpats, xs1) ->
- BIND (rdPat sf xs1) _TO_ (rpat, xs2) ->
- let
- (n, llpats)
- = case lpat of
- VarPatIn x -> (x, [])
- ConPatIn x [] -> (x, [])
- ConOpPatIn x op y -> (op, [x, y])
- other -> -- sorry about the weedy msg; the parser missed this one
- error (ppShow 100 (ppCat [ppStr "ERROR: an illegal `application' of a pattern to another one:", ppInterleave ppSP (map (ppr PprForUser) bad_app)]))
-
- arg_pats = llpats ++ lpats ++ [rpat]
- bad_app = (lpat:lpats) ++ [rpat]
- in
- RETN (ConPatIn n arg_pats, xs2)
- BEND BEND
- where
- rd_curried_pats ('a' : ys)
- = BIND (rd_curried_pats ys) _TO_ (lpats, ys1) ->
- BIND (rdPat sf ys1) _TO_ (rpat, ys2) ->
- RETN (lpats ++ [rpat], ys2)
- BEND BEND
- rd_curried_pats ys
- = BIND (rdPat sf ys) _TO_ (pat, ys1) ->
- RETN ([pat], ys1)
- BEND
-
- '@' -> -- operator application
- BIND (rdPat sf xs) _TO_ (pat1, xs1) ->
- BIND (rdId xs1) _TO_ (op, xs2) ->
- BIND (rdPat sf xs2) _TO_ (pat2, xs3) ->
- RETN (ConOpPatIn pat1 op pat2, xs3)
- BEND BEND BEND
-
- ':' -> -- explicit list
- BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
- RETN (ListPatIn pats, xs1)
- BEND
-
- ',' -> -- explicit tuple
- BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
- RETN (TuplePatIn pats, xs1)
- BEND
-
-#ifdef DPH
- 'O' -> -- explicitProcessor pattern
- BIND (rdList (rdPat sf) xs) _TO_ (pats, xs1) ->
- BIND (rdPat sf xs1) _TO_ (pat, xs2) ->
- RETN (ProcessorPatIn pats pat, xs2)
- BEND BEND
-#endif {- Data Parallel Haskell -}
-
- huh -> panic ("ReadPrefix.rdPat:"++(next_char:xs))
+wlkPat pat
+ = case pat of
+ U_par ppat -> -- parenthesised pattern
+ wlkPat ppat `thenUgn` \ pat ->
+ returnUgn (ParPatIn pat)
+
+ U_as avar as_pat -> -- "as" pattern
+ wlkQid avar `thenUgn` \ var ->
+ wlkPat as_pat `thenUgn` \ pat ->
+ returnUgn (AsPatIn var pat)
+
+ U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
+ wlkPat lazyp `thenUgn` \ pat ->
+ returnUgn (LazyPatIn pat)
+
+ U_wildp -> returnUgn WildPatIn -- wildcard pattern
+
+ U_lit lit -> -- literal pattern
+ wlkLiteral lit `thenUgn` \ lit ->
+ returnUgn (LitPatIn lit)
+
+ U_ident nn -> -- simple identifier
+ wlkQid nn `thenUgn` \ n ->
+ returnUgn (
+ if isConopRdr n
+ then ConPatIn n []
+ else VarPatIn n
+ )
+
+ U_ap l r -> -- "application": there's a list of patterns lurking here!
+ wlkPat r `thenUgn` \ rpat ->
+ collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
+ (case lpat of
+ VarPatIn x -> returnUgn (x, lpats)
+ ConPatIn x [] -> returnUgn (x, lpats)
+ ConOpPatIn x op y -> returnUgn (op, x:y:lpats)
+ _ -> getSrcLocUgn `thenUgn` \ loc ->
+ let
+ err = addErrLoc loc "Illegal pattern `application'"
+ (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
+ msg = ppShow 100 (err PprForUser)
+ in
+ ioToUgnM (writeMn stderr msg) `thenUgn` \ _ ->
+ ioToUgnM (exitMn 1) `thenUgn` \ _ ->
+ returnUgn (error "ReadPrefix")
+
+ ) `thenUgn` \ (n, arg_pats) ->
+ returnUgn (ConPatIn n arg_pats)
+ where
+ collect_pats pat acc
+ = case pat of
+ U_ap l r ->
+ wlkPat r `thenUgn` \ rpat ->
+ collect_pats l (rpat:acc)
+ other ->
+ wlkPat other `thenUgn` \ pat ->
+ returnUgn (pat,acc)
+
+ U_infixap fun arg1 arg2 -> -- infix pattern
+ wlkQid fun `thenUgn` \ op ->
+ wlkPat arg1 `thenUgn` \ pat1 ->
+ wlkPat arg2 `thenUgn` \ pat2 ->
+ returnUgn (ConOpPatIn pat1 op pat2)
+
+ U_negate npat -> -- negated pattern
+ wlkPat npat `thenUgn` \ pat ->
+ returnUgn (NegPatIn pat)
+
+ U_llist llist -> -- explicit list
+ wlkList rdPat llist `thenUgn` \ pats ->
+ returnUgn (ListPatIn pats)
+
+ U_tuple tuplelist -> -- explicit tuple
+ wlkList rdPat tuplelist `thenUgn` \ pats ->
+ returnUgn (TuplePatIn pats)
+
+ U_record con rpats -> -- record destruction
+ wlkQid con `thenUgn` \ rcon ->
+ wlkList rdRpat rpats `thenUgn` \ recpats ->
+ returnUgn (RecPatIn rcon recpats)
+ where
+ rdRpat pt
+ = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
+ wlkQid var `thenUgn` \ rvar ->
+ wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
+ returnUgn (
+ case pat_maybe of
+ Nothing -> (rvar, VarPatIn rvar, True{-pun-})
+ Just rp -> (rvar, rp, False)
+ )
\end{code}
-OLD, MISPLACED NOTE: The extra DPH syntax above is defined such that
-to the left of a \tr{<<-} or \tr{<<=} there has to be a processor (no
-expressions). Therefore in the pattern matching below we are taking
-this into consideration to create the @DrawGen@ whose fields are the
-\tr{K} patterns, pat and the exp right of the generator.
-
\begin{code}
-rdLiteral :: String -> RETN_TYPE (Literal, String)
-
-rdLiteral (tag : xs)
- = BIND (rdString xs) _TO_ (x, zs) ->
- let
- s = _UNPK_ x
-
- as_char = chr ((read s) :: Int)
- -- a char comes in as a number string
- -- representing its ASCII code
- as_integer = readInteger s
-#if __GLASGOW_HASKELL__ <= 22
- as_rational = toRational ((read s)::Double)
-#else
-#ifdef __GLASGOW_HASKELL__
- as_rational = _readRational s -- non-std
-#else
- as_rational = ((read s)::Rational)
-#endif
-#endif
- as_double = ((read s) :: Double)
- in
- case tag of {
- '4' -> RETN (IntLit as_integer, zs);
- 'F' -> RETN (FracLit as_rational, zs);
- 'H' -> RETN (IntPrimLit as_integer, zs);
-#if __GLASGOW_HASKELL__ <= 22
- 'J' -> RETN (DoublePrimLit as_double,zs);
- 'K' -> RETN (FloatPrimLit as_double, zs);
-#else
- 'J' -> RETN (DoublePrimLit as_rational,zs);
- 'K' -> RETN (FloatPrimLit as_rational, zs);
-#endif
- 'C' -> RETN (CharLit as_char, zs);
- 'P' -> RETN (CharPrimLit as_char, zs);
- 'S' -> RETN (StringLit x, zs);
- 'V' -> RETN (StringPrimLit x, zs);
- 'Y' -> RETN (LitLitLitIn x, zs)
- } BEND
+wlkLiteral :: U_literal -> UgnM HsLit
+
+wlkLiteral ulit
+ = returnUgn (
+ case ulit of
+ U_integer s -> HsInt (as_integer s)
+ U_floatr s -> HsFrac (as_rational s)
+ U_intprim s -> HsIntPrim (as_integer s)
+ U_doubleprim s -> HsDoublePrim (as_rational s)
+ U_floatprim s -> HsFloatPrim (as_rational s)
+ U_charr s -> HsChar (as_char s)
+ U_charprim s -> HsCharPrim (as_char s)
+ U_string s -> HsString (as_string s)
+ U_stringprim s -> HsStringPrim (as_string s)
+ U_clitlit s -> HsLitLit (as_string s)
+ )
+ where
+ as_char s = _HEAD_ s
+ as_integer s = readInteger (_UNPK_ s)
+ as_rational s = _readRational (_UNPK_ s) -- non-std
+ as_string s = s
\end{code}
%************************************************************************
%* *
-\subsection[rdBinding]{rdBinding}
+\subsection{wlkBinding}
%* *
%************************************************************************
\begin{code}
-rdBinding :: SrcFile -> String -> RETN_TYPE (RdrBinding, String)
-
-rdBinding sf (next_char:xs)
- = case next_char of
- 'B' -> -- null binding
- RETN (RdrNullBind, xs)
-
- 'A' -> -- "and" binding (just glue, really)
- BIND (rdBinding sf xs) _TO_ (binding1, xs1) ->
- BIND (rdBinding sf xs1) _TO_ (binding2, xs2) ->
- RETN (RdrAndBindings binding1 binding2, xs2)
- BEND BEND
-
- 't' -> -- "data" declaration
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdContext xs1) _TO_ (ctxt, xs2) ->
- BIND (rdList rdId xs2) _TO_ (derivings, xs3) ->
- BIND (rdTyConAndTyVars xs3) _TO_ ((tycon, tyvars), xs4) ->
- BIND (rdList (rdConDecl sf) xs4) _TO_ (cons, xs5) ->
- BIND (rdDataPragma xs5) _TO_ (pragma, xs6) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrTyData (TyData ctxt tycon tyvars cons derivings pragma src_loc),
- xs6)
- BEND BEND BEND BEND BEND BEND
-
- 'n' -> -- "type" declaration
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdTyConAndTyVars xs1) _TO_ ((tycon, tyvars), xs2) ->
- BIND (rdMonoType xs2) _TO_ (expansion, xs3) ->
- BIND (rdTypePragma xs3) _TO_ (pragma, xs4) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrTySynonym (TySynonym tycon tyvars expansion pragma src_loc),
- xs4)
- BEND BEND BEND BEND
-
- 'f' -> -- function binding
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) ->
- RETN (RdrFunctionBinding (read (_UNPK_ srcline)) matches, xs2)
- BEND BEND
-
- 'p' -> -- pattern binding
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdList (rdMatch sf) xs1) _TO_ (matches, xs2) ->
- RETN (RdrPatternBinding (read (_UNPK_ srcline)) matches, xs2)
- BEND BEND
-
- '$' -> -- "class" declaration
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdContext xs1) _TO_ (ctxt, xs2) ->
- BIND (rdClassAssertTy xs2) _TO_ ((clas, tyvar), xs3) ->
- BIND (rdBinding sf xs3) _TO_ (binding, xs4) ->
- BIND (rdClassPragma xs4) _TO_ (pragma, xs5) ->
- let
- (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
-
- final_sigs = concat (map cvClassOpSig class_sigs)
- final_methods = cvMonoBinds sf class_methods
-
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrClassDecl
- (ClassDecl ctxt clas tyvar final_sigs final_methods pragma src_loc),
- xs5)
- BEND BEND BEND BEND BEND
-
- '%' -> -- "instance" declaration
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdContext xs1) _TO_ (ctxt, xs2) ->
- BIND (rdId xs2) _TO_ (clas, xs3) ->
- BIND (rdMonoType xs3) _TO_ (inst_ty, xs4) ->
- BIND (rdBinding sf xs4) _TO_ (binding, xs5) ->
- BIND (rdInstPragma xs5) _TO_ (modname_maybe, pragma, xs6) ->
- let
- (ss, bs) = sepDeclsIntoSigsAndBinds binding
- binds = cvMonoBinds sf bs
- uprags = concat (map cvInstDeclSig ss)
- src_loc = mkSrcLoc sf srcline
- in
- case modname_maybe of {
- Nothing ->
- RETN (RdrInstDecl (\ orig_mod infor_mod here ->
- InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
- xs6);
- Just orig_mod ->
- RETN (RdrInstDecl (\ _ infor_mod here ->
- InstDecl ctxt clas inst_ty binds here orig_mod infor_mod uprags pragma src_loc),
- xs6)
- }
- BEND BEND BEND BEND BEND BEND
-
- 'D' -> -- "default" declaration
- BIND (rdString xs) _TO_ (srcline,xs1) ->
- BIND (rdList rdMonoType xs1) _TO_ (tys, xs2) ->
-
- RETN (RdrDefaultDecl (DefaultDecl tys (mkSrcLoc sf srcline)),
- xs2)
- BEND BEND
-
- '7' -> -- "import" declaration in an interface
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdIdString xs1) _TO_ (mod, xs2) ->
- BIND (rdList rdEntity xs2) _TO_ (entities, xs3) ->
- BIND (rdList rdRenaming xs3) _TO_ (renamings, xs4) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrIfaceImportDecl (IfaceImportDecl mod entities renamings src_loc),
- xs4)
- BEND BEND BEND BEND
-
- 'S' -> -- signature(-like) things, including user pragmas
- rd_sig_thing sf xs
+wlkBinding :: U_binding -> UgnM RdrBinding
+
+wlkBinding binding
+ = case binding of
+ -- null binding
+ U_nullbind ->
+ returnUgn RdrNullBind
+
+ -- "and" binding (just glue, really)
+ U_abind a b ->
+ wlkBinding a `thenUgn` \ binding1 ->
+ wlkBinding b `thenUgn` \ binding2 ->
+ returnUgn (RdrAndBindings binding1 binding2)
+
+ -- "data" declaration
+ U_tbind tctxt ttype tcons tderivs srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkContext tctxt `thenUgn` \ ctxt ->
+ wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
+ wlkList rdConDecl tcons `thenUgn` \ cons ->
+ wlkDerivings tderivs `thenUgn` \ derivings ->
+ returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc))
+
+ -- "newtype" declaration
+ U_ntbind ntctxt nttype ntcon ntderivs srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkContext ntctxt `thenUgn` \ ctxt ->
+ wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
+ wlkList rdConDecl ntcon `thenUgn` \ con ->
+ wlkDerivings ntderivs `thenUgn` \ derivings ->
+ returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
+
+ -- "type" declaration
+ U_nbind nbindid nbindas srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
+ wlkMonoType nbindas `thenUgn` \ expansion ->
+ returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
+
+ -- function binding
+ U_fbind fbindl srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdMatch fbindl `thenUgn` \ matches ->
+ returnUgn (RdrFunctionBinding srcline matches)
+
+ -- pattern binding
+ U_pbind pbindl srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdMatch pbindl `thenUgn` \ matches ->
+ returnUgn (RdrPatternBinding srcline matches)
+
+ -- "class" declaration
+ U_cbind cbindc cbindid cbindw srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkContext cbindc `thenUgn` \ ctxt ->
+ wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
+ wlkBinding cbindw `thenUgn` \ binding ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
+
+ final_sigs = concat (map cvClassOpSig class_sigs)
+ final_methods = cvMonoBinds sf class_methods
+ in
+ returnUgn (RdrClassDecl
+ (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
+
+ -- "instance" declaration
+ U_ibind ibindc iclas ibindi ibindw srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkContext ibindc `thenUgn` \ ctxt ->
+ wlkQid iclas `thenUgn` \ clas ->
+ wlkMonoType ibindi `thenUgn` \ inst_ty ->
+ wlkBinding ibindw `thenUgn` \ binding ->
+ getSrcModUgn `thenUgn` \ modname ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ (ss, bs) = sepDeclsIntoSigsAndBinds binding
+ binds = cvMonoBinds sf bs
+ uprags = concat (map cvInstDeclSig ss)
+ ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
+ maybe_mod = if opt_CompilingPrelude
+ then Nothing
+ else Just modname
+ in
+ returnUgn (RdrInstDecl
+ (InstDecl clas ctxt_inst_ty binds True maybe_mod uprags noInstancePragmas src_loc))
+
+ -- "default" declaration
+ U_dbind dbindts srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdMonoType dbindts `thenUgn` \ tys ->
+ returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc))
+
+ a_sig_we_hope ->
+ -- signature(-like) things, including user pragmas
+ wlk_sig_thing a_sig_we_hope
+\end{code}
+
+\begin{code}
+wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
+
+wlkDerivings (U_nothing) = returnUgn Nothing
+wlkDerivings (U_just pt)
+ = rdU_list pt `thenUgn` \ ds ->
+ wlkList rdQid ds `thenUgn` \ derivs ->
+ returnUgn (Just derivs)
\end{code}
\begin{code}
-rd_sig_thing sf (next_char:xs)
- = case next_char of
- 't' -> -- type signature
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdList rdId xs1) _TO_ (vars, xs2) ->
- BIND (rdPolyType xs2) _TO_ (poly_ty, xs3) ->
- BIND (rdTySigPragmas xs3) _TO_ (pragma, xs4) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrTySig vars poly_ty pragma src_loc, xs4)
- BEND BEND BEND BEND
-
- 's' -> -- value specialisation user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (var, xs2) ->
- BIND (rdList rdPolyType xs2) _TO_ (tys, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrSpecValSig [SpecSig var ty Nothing{-ToDo: using...s-} src_loc | ty <- tys], xs3)
- BEND BEND BEND
-
- 'S' -> -- instance specialisation user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (clas, xs2) ->
- BIND (rdMonoType xs2) _TO_ (ty, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrSpecInstSig (InstSpecSig clas ty src_loc), xs3)
- BEND BEND BEND
-
- 'i' -> -- value inlining user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (var, xs2) ->
- BIND (rdList rdIdString xs2) _TO_ (howto, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
-
- guidance
- = (case howto of {
- [] -> id;
- [x] -> trace "ignoring unfold howto" }) UnfoldAlways
- in
- RETN (RdrInlineValSig (InlineSig var guidance src_loc), xs3)
- BEND BEND BEND
-
- 'd' -> -- value deforest user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (var, xs2) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrDeforestSig (DeforestSig var src_loc), xs2)
- BEND BEND
-
- 'u' -> -- value magic-unfolding user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (var, xs2) ->
- BIND (rdIdString xs2) _TO_ (str, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc), xs3)
- BEND BEND BEND
-
- 'a' -> -- abstract-type-synonym user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (tycon, xs2) ->
- let
- src_loc = mkSrcLoc sf srcline
- in
- RETN (RdrAbstractTypeSig (AbstractTypeSig tycon src_loc), xs2)
- BEND BEND
-
- 'd' -> -- data specialisation user-pragma
- BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (tycon, xs2) ->
- BIND (rdList rdMonoType xs2) _TO_ (tys, xs3) ->
- let
- src_loc = mkSrcLoc sf srcline
- spec_ty = MonoTyCon tycon tys
- in
- RETN (RdrSpecDataSig (SpecDataSig tycon spec_ty src_loc), xs3)
- BEND BEND BEND
+ -- type signature
+wlk_sig_thing (U_sbind sbindids sbindid srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdQid sbindids `thenUgn` \ vars ->
+ wlkPolyType sbindid `thenUgn` \ poly_ty ->
+ returnUgn (RdrTySig vars poly_ty src_loc)
+
+ -- value specialisation user-pragma
+wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid uvar `thenUgn` \ var ->
+ wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
+ returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
+ | (ty, using_id) <- tys_and_ids ])
+ where
+ rd_ty_and_id :: ParseTree -> UgnM (RdrNamePolyType, Maybe RdrName)
+ rd_ty_and_id pt
+ = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
+ wlkPolyType vspec_ty `thenUgn` \ ty ->
+ wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe ->
+ returnUgn(ty, id_maybe)
+
+ -- instance specialisation user-pragma
+wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid iclas `thenUgn` \ clas ->
+ wlkMonoType ispec_ty `thenUgn` \ ty ->
+ returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
+
+ -- data specialisation user-pragma
+wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid itycon `thenUgn` \ tycon ->
+ wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
+ returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc))
+
+ -- value inlining user-pragma
+wlk_sig_thing (U_inline_uprag ivar srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid ivar `thenUgn` \ var ->
+ returnUgn (RdrInlineValSig (InlineSig var src_loc))
+
+ -- "deforest me" user-pragma
+wlk_sig_thing (U_deforest_uprag ivar srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid ivar `thenUgn` \ var ->
+ returnUgn (RdrDeforestSig (DeforestSig var src_loc))
+
+ -- "magic" unfolding user-pragma
+wlk_sig_thing (U_magicuf_uprag ivar str srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid ivar `thenUgn` \ var ->
+ returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
\end{code}
%************************************************************************
%* *
-\subsection[rdTypes]{Reading in types in various forms (and data constructors)}
+\subsection[wlkTypes]{Reading in types in various forms (and data constructors)}
%* *
%************************************************************************
\begin{code}
-rdPolyType :: String -> RETN_TYPE (ProtoNamePolyType, String)
-rdMonoType :: String -> RETN_TYPE (ProtoNameMonoType, String)
-
-rdPolyType ('3' : xs)
- = BIND (rdContext xs) _TO_ (ctxt, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (OverloadedTy ctxt ty, xs2)
- BEND BEND
-
-rdPolyType ('2' : 'C' : xs)
- = BIND (rdList rdId xs) _TO_ (tvs, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (ForAllTy tvs ty, xs2)
- BEND BEND
-
-rdPolyType other
- = BIND (rdMonoType other) _TO_ (ty, xs1) ->
- RETN (UnoverloadedTy ty, xs1)
- BEND
-
-rdMonoType ('T' : xs)
- = BIND (rdId xs) _TO_ (tycon, xs1) ->
- BIND (rdList rdMonoType xs1) _TO_ (tys, xs2) ->
- RETN (MonoTyCon tycon tys, xs2)
- BEND BEND
-
-rdMonoType (':' : xs)
- = BIND (rdMonoType xs) _TO_ (ty, xs1) ->
- RETN (ListMonoTy ty, xs1)
- BEND
-
-rdMonoType (',' : xs)
- = BIND (rdList rdPolyType xs) _TO_ (tys, xs1) ->
- RETN (TupleMonoTy tys, xs1)
- BEND
-
-rdMonoType ('>' : xs)
- = BIND (rdMonoType xs) _TO_ (ty1, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty2, xs2) ->
- RETN (FunMonoTy ty1 ty2, xs2)
- BEND BEND
-
-rdMonoType ('y' : xs)
- = BIND (rdId xs) _TO_ (tyvar, xs1) ->
- RETN (MonoTyVar tyvar, xs1)
- BEND
-
-rdMonoType ('2' : 'A' : xs)
- = BIND (rdId xs) _TO_ (clas, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (MonoDict clas ty, xs2)
- BEND BEND
-
-rdMonoType ('2' : 'B' : xs)
- = BIND (rdId xs) _TO_ (tv_tmpl, xs1) ->
- RETN (MonoTyVarTemplate tv_tmpl, xs1)
- BEND
-
-#ifdef DPH
-rdMonoType ('v' : xs)
- = BIND (rdMonoType xs) _TO_ (ty, xs1) ->
- RETN (RdrExplicitPodTy ty, xs1)
- BEND
-
-rdMonoType ('u' : xs)
- = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
- BIND (rdMonoType xs1) _TO_ (ty, xs2) ->
- RETN (RdrExplicitProcessorTy tys ty, xs2)
- BEND BEND
-#endif {- Data Parallel Haskell -}
-
-rdMonoType oops = panic ("rdMonoType:"++oops)
+rdPolyType :: ParseTree -> UgnM RdrNamePolyType
+rdMonoType :: ParseTree -> UgnM RdrNameMonoType
+
+rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
+rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
+
+wlkPolyType :: U_ttype -> UgnM RdrNamePolyType
+wlkMonoType :: U_ttype -> UgnM RdrNameMonoType
+
+wlkPolyType ttype
+ = case ttype of
+ U_context tcontextl tcontextt -> -- context
+ wlkContext tcontextl `thenUgn` \ ctxt ->
+ wlkMonoType tcontextt `thenUgn` \ ty ->
+ returnUgn (HsPreForAllTy ctxt ty)
+
+ other -> -- something else
+ wlkMonoType other `thenUgn` \ ty ->
+ returnUgn (HsPreForAllTy [{-no context-}] ty)
+
+wlkMonoType ttype
+ = case ttype of
+ U_namedtvar tv -> -- type variable
+ wlkQid tv `thenUgn` \ tyvar ->
+ returnUgn (MonoTyVar tyvar)
+
+ U_tname tcon -> -- type constructor
+ wlkQid tcon `thenUgn` \ tycon ->
+ returnUgn (MonoTyApp tycon [])
+
+ U_tapp t1 t2 ->
+ wlkMonoType t2 `thenUgn` \ ty2 ->
+ collect t1 [ty2] `thenUgn` \ (tycon, tys) ->
+ returnUgn (MonoTyApp tycon tys)
+ where
+ collect t acc
+ = case t of
+ U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
+ collect t1 (ty2:acc)
+ U_tname tcon -> wlkQid tcon `thenUgn` \ tycon ->
+ returnUgn (tycon, acc)
+ U_namedtvar tv -> wlkQid tv `thenUgn` \ tyvar ->
+ returnUgn (tyvar, acc)
+ U_tllist _ -> panic "tlist"
+ U_ttuple _ -> panic "ttuple"
+ U_tfun _ _ -> panic "tfun"
+ U_tbang _ -> panic "tbang"
+ U_context _ _ -> panic "context"
+ _ -> panic "something else"
+
+ U_tllist tlist -> -- list type
+ wlkMonoType tlist `thenUgn` \ ty ->
+ returnUgn (MonoListTy ty)
+
+ U_ttuple ttuple ->
+ wlkList rdMonoType ttuple `thenUgn` \ tys ->
+ returnUgn (MonoTupleTy tys)
+
+ U_tfun tfun targ ->
+ wlkMonoType tfun `thenUgn` \ ty1 ->
+ wlkMonoType targ `thenUgn` \ ty2 ->
+ returnUgn (MonoFunTy ty1 ty2)
+
\end{code}
\begin{code}
-rdTyConAndTyVars :: String -> RETN_TYPE ((ProtoName, [ProtoName]), String)
-rdContext :: String -> RETN_TYPE (ProtoNameContext, String)
-rdClassAssertTy :: String -> RETN_TYPE ((ProtoName, ProtoName), String)
+wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [RdrName])
+wlkContext :: U_list -> UgnM RdrNameContext
+wlkClassAssertTy :: U_ttype -> UgnM (RdrName, RdrName)
-rdTyConAndTyVars xs
- = BIND (rdMonoType xs) _TO_ (MonoTyCon tycon ty_args, xs1) ->
+wlkTyConAndTyVars ttype
+ = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
let
args = [ a | (MonoTyVar a) <- ty_args ]
in
- RETN ((tycon, args), xs1)
- BEND
+ returnUgn (tycon, args)
-rdContext xs
- = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
- RETN (map mk_class_assertion tys, xs1)
- BEND
+wlkContext list
+ = wlkList rdMonoType list `thenUgn` \ tys ->
+ returnUgn (map mk_class_assertion tys)
-rdClassAssertTy xs
- = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) ->
- RETN (mk_class_assertion mono_ty, xs1)
- BEND
+wlkClassAssertTy xs
+ = wlkMonoType xs `thenUgn` \ mono_ty ->
+ returnUgn (mk_class_assertion mono_ty)
-mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
+mk_class_assertion :: RdrNameMonoType -> (RdrName, RdrName)
-mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname)
+mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
mk_class_assertion other
- = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
+ = pprError "ERROR: malformed type context: " (ppr PprForUser other)
-- regrettably, the parser does let some junk past
-- e.g., f :: Num {-nothing-} => a -> ...
\end{code}
\begin{code}
-rdConDecl :: SrcFile -> String -> RETN_TYPE (ProtoNameConDecl, String)
-
-rdConDecl sf ('1':xs)
- = BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdId xs1) _TO_ (id, xs2) ->
- BIND (rdList rdMonoType xs2) _TO_ (tys, xs3) ->
- RETN (ConDecl id tys (mkSrcLoc sf srcline), xs3)
- BEND BEND BEND
+rdConDecl :: ParseTree -> UgnM RdrNameConDecl
+rdConDecl pt
+ = rdU_constr pt `thenUgn` \ blah ->
+ wlkConDecl blah
+
+wlkConDecl :: U_constr -> UgnM RdrNameConDecl
+
+wlkConDecl (U_constrpre ccon ctys srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid ccon `thenUgn` \ con ->
+ wlkList rdBangType ctys `thenUgn` \ tys ->
+ returnUgn (ConDecl con tys src_loc)
+
+wlkConDecl (U_constrinf cty1 cop cty2 srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkBangType cty1 `thenUgn` \ ty1 ->
+ wlkQid cop `thenUgn` \ op ->
+ wlkBangType cty2 `thenUgn` \ ty2 ->
+ returnUgn (ConOpDecl ty1 op ty2 src_loc)
+
+wlkConDecl (U_constrnew ccon cty srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid ccon `thenUgn` \ con ->
+ wlkMonoType cty `thenUgn` \ ty ->
+ returnUgn (NewConDecl con ty src_loc)
+
+wlkConDecl (U_constrrec ccon cfields srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkQid ccon `thenUgn` \ con ->
+ wlkList rd_field cfields `thenUgn` \ fields_lists ->
+ returnUgn (RecConDecl con fields_lists src_loc)
+ where
+ rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
+ rd_field pt
+ = rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
+ wlkList rdQid fvars `thenUgn` \ vars ->
+ wlkBangType fty `thenUgn` \ ty ->
+ returnUgn (vars, ty)
+
+-----------------
+rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty
+
+wlkBangType :: U_ttype -> UgnM (BangType RdrName)
+
+wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged ty)
+wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
+
\end{code}
%************************************************************************
%* *
-\subsection[rdMatch]{Read a ``match''}
+\subsection{Read a ``match''}
%* *
%************************************************************************
\begin{code}
-rdMatch :: SrcFile -> String -> RETN_TYPE (RdrMatch, String)
-
-rdMatch sf ('W':xs)
- = BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdIdString xs1) _TO_ (srcfun, xs2) ->
- BIND (rdPat sf xs2) _TO_ (pat, xs3) ->
- BIND (rdList rd_guarded xs3) _TO_ (grhss, xs4) ->
- BIND (rdBinding sf xs4) _TO_ (binding, xs5) ->
+rdMatch :: ParseTree -> UgnM RdrMatch
+
+rdMatch pt
+ = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkPat gpat `thenUgn` \ pat ->
+ wlkBinding gbind `thenUgn` \ binding ->
+ wlkQid gsrcfun `thenUgn` \ srcfun ->
+ let
+ wlk_guards (U_pnoguards exp)
+ = wlkExpr exp `thenUgn` \ expr ->
+ returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
- RETN (RdrMatch (read (_UNPK_ srcline)) srcfun pat grhss binding, xs5)
- BEND BEND BEND BEND BEND
+ wlk_guards (U_pguards gs)
+ = wlkList rd_gd_expr gs `thenUgn` \ gd_exps ->
+ returnUgn (RdrMatch_Guards srcline srcfun pat gd_exps binding)
+ in
+ wlk_guards gdexprs
where
- rd_guarded xs
- = BIND (rdExpr sf xs) _TO_ (g, xs1) ->
- BIND (rdExpr sf xs1) _TO_ (e, xs2) ->
- RETN ((g, e), xs2)
- BEND BEND
+ rd_gd_expr pt
+ = rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
+ wlkExpr g `thenUgn` \ guard ->
+ wlkExpr e `thenUgn` \ expr ->
+ returnUgn (guard, expr)
\end{code}
%************************************************************************
%* *
-\subsection[rdFixity]{Read in a fixity declaration}
+\subsection[rdFixOp]{Read in a fixity declaration}
%* *
%************************************************************************
\begin{code}
-rdFixity :: String -> RETN_TYPE (ProtoNameFixityDecl, String)
-rdFixity xs
- = BIND (rdId xs) _TO_ (op, xs1) ->
- BIND (rdString xs1) _TO_ (associativity, xs2) ->
- BIND (rdString xs2) _TO_ (prec_str, xs3) ->
- let
- precedence = read (_UNPK_ prec_str)
- in
- case (_UNPK_ associativity) of {
- "infix" -> RETN (InfixN op precedence, xs3);
- "infixl" -> RETN (InfixL op precedence, xs3);
- "infixr" -> RETN (InfixR op precedence, xs3)
- } BEND BEND BEND
+rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
+rdFixOp pt
+ = rdU_tree pt `thenUgn` \ fix ->
+ case fix of
+ U_fixop op (-1) prec -> wlkQid op `thenUgn` \ op ->
+ returnUgn (InfixL op prec)
+ U_fixop op 0 prec -> wlkQid op `thenUgn` \ op ->
+ returnUgn (InfixN op prec)
+ U_fixop op 1 prec -> wlkQid op `thenUgn` \ op ->
+ returnUgn (InfixR op prec)
+ _ -> error "ReadPrefix:rdFixOp"
\end{code}
%************************************************************************
%* *
-\subsection[rdImportedInterface]{Read an imported interface}
+\subsection[rdImport]{Read an import decl}
%* *
%************************************************************************
\begin{code}
-rdImportedInterface :: FAST_STRING -> String
- -> RETN_TYPE (ProtoNameImportedInterface, String)
-
-rdImportedInterface importing_srcfile (x:xs)
- = BIND (rdString xs) _TO_ (srcline, xs1) ->
- BIND (rdString xs1) _TO_ (srcfile, xs2) ->
- BIND (rdIdString xs2) _TO_ (modname, xs3) ->
- BIND (rdList rdEntity xs3) _TO_ (imports, xs4) ->
- BIND (rdList rdRenaming xs4) _TO_ (renamings,xs5) ->
- BIND (rdBinding srcfile xs5) _TO_ (iface_bs, xs6) ->
-
- case (sepDeclsForInterface iface_bs) of {
- (tydecls,classdecls,instdecls,sigs,iimpdecls) ->
- let
- expose_or_hide = case x of { 'e' -> ImportSome; 'h' -> ImportButHide }
-
- cv_iface
- = MkInterface modname
- iimpdecls
- [{-fixity decls-}] -- can't get fixity decls in here yet (ToDo)
- tydecls
- classdecls
- (cvInstDecls False SLIT(""){-probably superceded by modname < pragmas-}
- modname instdecls)
- -- False indicates imported
- (concat (map cvValSig sigs))
- (mkSrcLoc importing_srcfile srcline)
- in
- RETN (
- (if null imports then
- ImportAll cv_iface renamings
- else
- expose_or_hide cv_iface imports renamings
- , xs6))
- } BEND BEND BEND BEND BEND BEND
+rdImport :: ParseTree
+ -> UgnM RdrNameImportDecl
+
+rdImport pt
+ = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec srcline) ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
+ wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
+ returnUgn (ImportDecl imod (cvFlag iqual) maybe_as maybe_spec src_loc)
+ where
+ rd_spec pt = rdU_either pt `thenUgn` \ spec ->
+ case spec of
+ U_left pt -> rdEntities pt `thenUgn` \ ents ->
+ returnUgn (False, ents)
+ U_right pt -> rdEntities pt `thenUgn` \ ents ->
+ returnUgn (True, ents)
\end{code}
\begin{code}
-rdRenaming :: String -> RETN_TYPE (Renaming, String)
-
-rdRenaming xs
- = BIND (rdIdString xs) _TO_ (id1, xs1) ->
- BIND (rdIdString xs1) _TO_ (id2, xs2) ->
- RETN (MkRenaming id1 id2, xs2)
- BEND BEND
+rdEntities pt
+ = rdU_list pt `thenUgn` \ list ->
+ wlkList rdEntity list
+
+rdEntity :: ParseTree -> UgnM (IE RdrName)
+
+rdEntity pt
+ = rdU_entidt pt `thenUgn` \ entity ->
+ case entity of
+ U_entid evar -> -- just a value
+ wlkQid evar `thenUgn` \ var ->
+ returnUgn (IEVar var)
+
+ U_enttype x -> -- abstract type constructor/class
+ wlkQid x `thenUgn` \ thing ->
+ returnUgn (IEThingAbs thing)
+
+ U_enttypeall x -> -- non-abstract type constructor/class
+ wlkQid x `thenUgn` \ thing ->
+ returnUgn (IEThingAll thing)
+
+ U_enttypenamed x ns -> -- non-abstract type constructor/class
+ -- with specified constrs/methods
+ wlkQid x `thenUgn` \ thing ->
+ wlkList rdQid ns `thenUgn` \ names ->
+ returnUgn (IEThingAll thing)
+ -- returnUgn (IEThingWith thing names)
+
+ U_entmod mod -> -- everything provided by a module
+ returnUgn (IEModuleContents mod)
\end{code}
-\begin{code}
-rdEntity :: String -> RETN_TYPE (IE, String)
-
-rdEntity inp
- = case inp of
- 'x':xs -> BIND (rdIdString xs) _TO_ (var, xs1) ->
- RETN (IEVar var, xs1)
- BEND
-
- 'X':xs -> BIND (rdIdString xs) _TO_ (thing, xs1) ->
- RETN (IEThingAbs thing, xs1)
- BEND
-
- 'z':xs -> BIND (rdIdString xs) _TO_ (thing, xs1) ->
- RETN (IEThingAll thing, xs1)
- BEND
-
- '8':xs -> BIND (rdIdString xs) _TO_ (tycon, xs1) ->
- BIND (rdList rdString xs1) _TO_ (cons, xs2) ->
- RETN (IEConWithCons tycon cons, xs2)
- BEND BEND
-
- '9':xs -> BIND (rdIdString xs) _TO_ (c, xs1) ->
- BIND (rdList rdString xs1) _TO_ (ops, xs2) ->
- RETN (IEClsWithOps c ops, xs2)
- BEND BEND
-
- 'm':xs -> BIND (rdIdString xs) _TO_ (m, xs1) ->
- RETN (IEModuleContents m, xs1)
- BEND
-\end{code}
projects / ghc-hetmet.git / blobdiff