%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
-\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
+module ReadPrefix ( rdModule ) where
#include "HsVersions.h"
-\end{code}
-
-\begin{code}
-module ReadPrefix (
- rdModule,
- rdList, rdId, rdIdString, rdString, rdConDecl, rdMonoType
- ) where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-import Pretty
-
-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 HsTypes ( HsTyVar(..) )
+import HsPragmas ( noDataPragmas, noClassPragmas )
+import RdrHsSyn
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import PrelMods ( pRELUDE_Name )
import PrefixToHs
-import PrefixSyn
-import ProtoName
+import CallConv
+
+import CmdLineOpts ( opt_NoImplicitPrelude, opt_GlasgowExts, opt_D_dump_rdr )
+import Module ( ModuleName, mkSrcModuleFS, WhereFrom(..) )
+import OccName ( NameSpace, tcName, clsName, tcClsName, varName, dataName, tvName,
+ isLexCon
+ )
+import RdrName ( RdrName, isRdrDataCon, mkSrcQual, mkSrcUnqual, mkPreludeQual,
+ dummyRdrVarName
+ )
import Outputable
-import ReadPragmas
-import SrcLoc ( mkSrcLoc )
-import Util
+import ErrUtils ( dumpIfSet )
+import SrcLoc ( SrcLoc )
+import FastString ( mkFastCharString )
+import PrelRead ( readRational__ )
\end{code}
%************************************************************************
%* *
-\subsection[ReadPrefix-help]{Help Functions}
+\subsection[rdModule]{@rdModule@: reads in a Haskell module}
%* *
%************************************************************************
\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
+rdModule :: IO (ModuleName, -- this module's name
+ RdrNameHsModule) -- the main goods
- my_rev "" acc = RETN acc -- instead of reverse, so can see on heap-profiles
- my_rev (x:xs) acc = my_rev xs (x:acc)
-\end{code}
+rdModule
+ = -- call the Yacc parser!
+ _ccall_ hspmain >>= \ pt ->
-%************************************************************************
-%* *
-\subsection[rdModule]{@rdModule@: reads in a Haskell module}
-%* *
-%************************************************************************
+ -- Read from the Yacc tree
+ initUgn (read_module pt) >>= \ (mod_name, rdr_module) ->
-\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 )
- }
+ -- Dump if reqd
+ dumpIfSet opt_D_dump_rdr "Reader"
+ (ppr rdr_module) >>
+
+ -- And return
+ return (mod_name, rdr_module)
+
+read_module :: ParseTree -> UgnM (ModuleName, RdrNameHsModule)
+read_module pt
+ = rdU_tree pt `thenUgn` \ (U_hmodule mod_fs himplist hexplist
+ hmodlist srciface_version srcline) ->
+ let
+ srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
+ mod_name = mkSrcModuleFS mod_fs
+ in
+
+ setSrcFileUgn srcfile $
+ mkSrcLocUgn srcline $ \ src_loc ->
+
+ wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
+ wlkList rdImport himplist `thenUgn` \ imports ->
+ wlkBinding hmodlist `thenUgn` \ binding ->
+
+ let
+ top_decls = cvTopDecls srcfile binding
+ rdr_module = HsModule mod_name
+ (case srciface_version of { 0 -> Nothing; n -> Just n })
+ exports
+ imports
+ top_decls
+ src_loc
+ in
+ returnUgn (mod_name, rdr_module)
\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` wlkExpr
+rdPat pt = rdU_tree pt `thenUgn` wlkPat
+
+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 ->
+ wlkVarId lop `thenUgn` \ op ->
+ returnUgn (SectionL expr (HsVar op))
+
+ U_rsection rop rsexp -> -- right section
+ wlkVarId 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 match -> -- lambda expression
+ wlkMatch match `thenUgn` \ match' ->
+ returnUgn (HsLam match')
+
+ U_casee caseexpr casebody srcline -> -- case expression
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkExpr caseexpr `thenUgn` \ expr ->
+ wlkList rdMatch casebody `thenUgn` \ mats ->
+ returnUgn (HsCase expr mats 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
+ wlkLocalBinding letvdefs `thenUgn` \ binding ->
+ wlkExpr letvexpr `thenUgn` \ expr ->
+ returnUgn (HsLet binding expr)
+
+ U_doe gdo srcline -> -- do expression
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rd_stmt gdo `thenUgn` \ stmts ->
+ returnUgn (HsDo DoStmt 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 ->
+ wlkLocalBinding seqlet `thenUgn` \ binds ->
+ returnUgn (LetStmt binds)
+
+ U_comprh cexp cquals -> -- list comprehension
+ wlkExpr cexp `thenUgn` \ expr ->
+ wlkQuals cquals `thenUgn` \ quals ->
+ getSrcLocUgn `thenUgn` \ loc ->
+ returnUgn (HsDo ListComp (quals ++ [ReturnStmt expr]) loc)
+
+ 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 ->
+ wlkHsSigType 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
+ wlkVarId 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
+ wlkVarId fun `thenUgn` \ op ->
+ wlkExpr arg1 `thenUgn` \ expr1 ->
+ wlkExpr arg2 `thenUgn` \ expr2 ->
+ returnUgn (mkOpApp expr1 op expr2)
+
+ U_negate nexp -> -- prefix negation
+ wlkExpr nexp `thenUgn` \ expr ->
+ returnUgn (NegApp expr (HsVar dummyRdrVarName))
+
+ 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 True)
+
+ U_utuple tuplelist -> -- explicit tuple
+ wlkList rdExpr tuplelist `thenUgn` \ exprs ->
+ returnUgn (ExplicitTuple exprs False)
+
+ U_record con rbinds -> -- record construction
+ wlkDataId con `thenUgn` \ rcon ->
+ wlkList rdRbind rbinds `thenUgn` \ recbinds ->
+ returnUgn (RecordCon 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_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"
+#endif
+
+rdRbind pt
+ = rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
+ wlkVarId 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)
+ )
+
+wlkQuals cquals
+ = wlkList rd_qual cquals
+ 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 ->
+ getSrcLocUgn `thenUgn` \ loc ->
+ returnUgn (GuardStmt expr loc)
+
+ U_qual qpat qexp ->
+ wlkPat qpat `thenUgn` \ pat ->
+ wlkExpr qexp `thenUgn` \ expr ->
+ getSrcLocUgn `thenUgn` \ loc ->
+ returnUgn (BindStmt pat expr loc)
+
+ U_seqlet seqlet ->
+ wlkLocalBinding seqlet `thenUgn` \ binds ->
+ returnUgn (LetStmt binds)
+
+ U_let letvdefs letvexpr ->
+ wlkLocalBinding letvdefs `thenUgn` \ binds ->
+ wlkExpr letvexpr `thenUgn` \ expr ->
+ getSrcLocUgn `thenUgn` \ loc ->
+ returnUgn (GuardStmt (HsLet binds expr) loc)
\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 ->
+ -- tidy things up a little:
+ returnUgn (
+ case pat of
+ VarPatIn _ -> pat
+ WildPatIn -> pat
+ other -> ParPatIn pat
+ )
+
+ U_as avar as_pat -> -- "as" pattern
+ wlkVarId avar `thenUgn` \ var ->
+ wlkPat as_pat `thenUgn` \ pat ->
+ returnUgn (AsPatIn var pat)
+
+ U_restr pat ty ->
+ wlkPat pat `thenUgn` \ pat' ->
+ wlkHsType ty `thenUgn` \ ty' ->
+ returnUgn (SigPatIn pat' ty')
+
+ U_lazyp lazyp -> -- irrefutable ("twiddle") pattern
+ wlkPat lazyp `thenUgn` \ pat ->
+ returnUgn (LazyPatIn pat)
+
+ U_plusp avar lit ->
+ wlkVarId avar `thenUgn` \ var ->
+ wlkLiteral lit `thenUgn` \ lit ->
+ returnUgn (NPlusKPatIn var lit)
+
+ U_lit lit -> -- literal pattern
+ wlkLiteral lit `thenUgn` \ lit ->
+ returnUgn (LitPatIn lit)
+
+ U_ident (U_noqual s) | s == SLIT("_")-> returnUgn WildPatIn -- Wild-card pattern
+
+ U_ident nn -> -- simple identifier
+ wlkVarId nn `thenUgn` \ n ->
+ returnUgn (
+ if isRdrDataCon 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 ->
+ pprPanic "Illegal pattern `application'"
+ (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
+
+ ) `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)
+ U_par l ->
+ collect_pats l acc
+ other ->
+ wlkPat other `thenUgn` \ pat ->
+ returnUgn (pat,acc)
+
+ U_infixap fun arg1 arg2 -> -- infix pattern
+ wlkVarId fun `thenUgn` \ op ->
+ wlkPat arg1 `thenUgn` \ pat1 ->
+ wlkPat arg2 `thenUgn` \ pat2 ->
+ returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") 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 True)
+
+ U_utuple tuplelist -> -- explicit tuple
+ wlkList rdPat tuplelist `thenUgn` \ pats ->
+ returnUgn (TuplePatIn pats False)
+
+ U_record con rpats -> -- record destruction
+ wlkDataId con `thenUgn` \ rcon ->
+ wlkList rdRpat rpats `thenUgn` \ recpats ->
+ returnUgn (RecPatIn rcon recpats)
+ where
+ rdRpat pt
+ = rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
+ wlkVarId 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) -- use non-std readRational__
+ -- to handle rationals with leading '-'
+ 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
+wlkLocalBinding bind
+ = wlkBinding bind `thenUgn` \ bind' ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ returnUgn (cvBinds sf cvValSig bind')
+
+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)
+
+ -- fixity declaration
+ U_fixd op dir_n prec srcline ->
+ let
+ dir = case dir_n of
+ (-1) -> InfixL
+ 0 -> InfixN
+ 1 -> InfixR
+ in
+ wlkVarId op `thenUgn` \ op ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ returnUgn (RdrSig (FixSig (FixitySig op (Fixity prec dir) src_loc)))
+
+
+ -- "data" declaration
+ U_tbind tctxt ttype tcons tderivs srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkContext tctxt `thenUgn` \ ctxt ->
+ wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
+ wlkList rdConDecl tcons `thenUgn` \ cons ->
+ wlkDerivings tderivs `thenUgn` \ derivings ->
+ returnUgn (RdrHsDecl (TyClD (TyData DataType 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 ->
+ wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
+ wlkList rdConDecl ntcon `thenUgn` \ cons ->
+ wlkDerivings ntderivs `thenUgn` \ derivings ->
+ returnUgn (RdrHsDecl (TyClD (TyData NewType ctxt tycon tyvars cons
+ derivings noDataPragmas src_loc)))
+
+ -- "type" declaration
+ U_nbind nbindid nbindas srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
+ wlkHsType nbindas `thenUgn` \ expansion ->
+ returnUgn (RdrHsDecl (TyClD (TySynonym tycon tyvars expansion src_loc)))
+
+ -- function binding
+ U_fbind fbindm srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdMatch fbindm `thenUgn` \ matches ->
+ returnUgn (RdrValBinding (mkRdrFunctionBinding matches src_loc))
+
+ -- pattern binding
+ U_pbind pbindl pbindr srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ rdPat pbindl `thenUgn` \ pat ->
+ rdGRHSs pbindr `thenUgn` \ grhss ->
+ returnUgn (RdrValBinding (PatMonoBind pat grhss src_loc))
+
+ -- "class" declaration
+ U_cbind cbindc cbindid cbindw srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkContext cbindc `thenUgn` \ ctxt ->
+ wlkConAndTyVars cbindid `thenUgn` \ (clas, tyvars) ->
+ wlkBinding cbindw `thenUgn` \ binding ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
+ in
+ returnUgn (RdrHsDecl (TyClD (mkClassDecl ctxt clas tyvars final_sigs
+ final_methods noClassPragmas src_loc)))
+
+ -- "instance" declaration
+ U_ibind ty ibindw srcline ->
+ -- The "ty" contains the instance context too
+ -- So for "instance Eq a => Eq [a]" the type will be
+ -- Eq a => Eq [a]
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkInstType ty `thenUgn` \ inst_ty ->
+ wlkBinding ibindw `thenUgn` \ binding ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
+ in
+ returnUgn (RdrHsDecl (InstD (InstDecl inst_ty binds uprags
+ dummyRdrVarName {- No dfun id yet -}
+ src_loc)))
+
+ -- "default" declaration
+ U_dbind dbindts srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdMonoType dbindts `thenUgn` \ tys ->
+ returnUgn (RdrHsDecl (DefD (DefaultDecl tys src_loc)))
+
+ -- "foreign" declaration
+ U_fobind id ty ext_name unsafe_flag cconv imp_exp srcline ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkVarId id `thenUgn` \ h_id ->
+ wlkHsSigType ty `thenUgn` \ h_ty ->
+ wlkExtName ext_name `thenUgn` \ h_ext_name ->
+ rdCallConv cconv `thenUgn` \ h_cconv ->
+ rdForKind imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp ->
+ returnUgn (RdrHsDecl (ForD (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc)))
+
+ U_sbind sbindids sbindid srcline ->
+ -- Type signature
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdVarId sbindids `thenUgn` \ vars ->
+ wlkHsSigType sbindid `thenUgn` \ poly_ty ->
+ returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
+
+ U_vspec_uprag uvar vspec_tys srcline ->
+ -- value specialisation user-pragma
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkVarId uvar `thenUgn` \ var ->
+ wlkList rdHsSigType vspec_tys `thenUgn` \ tys ->
+ returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty src_loc)
+ | ty <- tys ])
+
+ U_ispec_uprag ispec_ty srcline ->
+ -- instance specialisation user-pragma
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkInstType ispec_ty `thenUgn` \ ty ->
+ returnUgn (RdrSig (SpecInstSig ty src_loc))
+
+ U_inline_uprag ivar srcline ->
+ -- value inlining user-pragma
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkVarId ivar `thenUgn` \ var ->
+ returnUgn (RdrSig (InlineSig var src_loc))
+
+ U_noinline_uprag ivar srcline ->
+ -- No-inline pragma
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkVarId ivar `thenUgn` \ var ->
+ returnUgn (RdrSig (NoInlineSig var src_loc))
+
+ U_rule_prag name ivars ilhs irhs srcline ->
+ -- Transforamation rule
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkList rdRuleBndr ivars `thenUgn` \ vars ->
+ rdExpr ilhs `thenUgn` \ lhs ->
+ rdExpr irhs `thenUgn` \ rhs ->
+ returnUgn (RdrHsDecl (RuleD (RuleDecl name [] vars lhs rhs src_loc)))
+
+mkRdrFunctionBinding :: [RdrNameMatch] -> SrcLoc -> RdrNameMonoBinds
+mkRdrFunctionBinding fun_matches src_loc
+ = FunMonoBind (head fns) (head infs) matches src_loc
+ where
+ (fns, infs, matches) = unzip3 (map de_fun_match fun_matches)
+
+ de_fun_match (Match _ [ConPatIn fn pats] sig grhss) = (fn, False, Match [] pats sig grhss)
+ de_fun_match (Match _ [ConOpPatIn p1 fn _ p2] sig grhss) = (fn, True, Match [] [p1,p2] sig grhss)
+
+
+rdRuleBndr :: ParseTree -> UgnM RdrNameRuleBndr
+rdRuleBndr pt = rdU_rulevar pt `thenUgn` wlkRuleBndr
+
+wlkRuleBndr :: U_rulevar -> UgnM RdrNameRuleBndr
+wlkRuleBndr (U_prulevar v)
+ = returnUgn (RuleBndr (mkSrcUnqual varName v))
+wlkRuleBndr (U_prulevarsig v ty)
+ = wlkHsType ty `thenUgn` \ ty' ->
+ returnUgn (RuleBndrSig (mkSrcUnqual varName v) ty')
+
+
+
+rdGRHSs :: ParseTree -> UgnM RdrNameGRHSs
+rdGRHSs pt = rdU_grhsb pt `thenUgn` wlkGRHSs
+
+wlkGRHSs :: U_grhsb -> UgnM RdrNameGRHSs
+wlkGRHSs (U_pguards rhss bind)
+ = wlkList rdGdExp rhss `thenUgn` \ gdexps ->
+ wlkLocalBinding bind `thenUgn` \ bind' ->
+ returnUgn (GRHSs gdexps bind' Nothing)
+wlkGRHSs (U_pnoguards srcline rhs bind)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ rdExpr rhs `thenUgn` \ rhs' ->
+ wlkLocalBinding bind `thenUgn` \ bind' ->
+ returnUgn (GRHSs (unguardedRHS rhs' src_loc) bind' Nothing)
+
+
+rdGdExp :: ParseTree -> UgnM RdrNameGRHS
+rdGdExp pt = rdU_gdexp pt `thenUgn` \ (U_pgdexp guards srcline rhs) ->
+ wlkQuals guards `thenUgn` \ guards' ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkExpr rhs `thenUgn` \ expr' ->
+ returnUgn (GRHS (guards' ++ [ExprStmt expr' src_loc]) src_loc)
\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
+wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
+
+wlkDerivings (U_nothing) = returnUgn Nothing
+wlkDerivings (U_just pt)
+ = rdU_list pt `thenUgn` \ ds ->
+ wlkList rdTCId ds `thenUgn` \ derivs ->
+ returnUgn (Just derivs)
\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)
+rdHsSigType :: ParseTree -> UgnM RdrNameHsType
+rdHsType :: ParseTree -> UgnM RdrNameHsType
+rdMonoType :: ParseTree -> UgnM RdrNameHsType
+
+rdHsSigType pt = rdU_ttype pt `thenUgn` wlkHsSigType
+rdHsType pt = rdU_ttype pt `thenUgn` wlkHsType
+rdMonoType pt = rdU_ttype pt `thenUgn` wlkHsType
+
+wlkHsConstrArgType ttype
+ -- Used for the argument types of contructors
+ -- Only an implicit quantification point if -fglasgow-exts
+ | opt_GlasgowExts = wlkHsSigType ttype
+ | otherwise = wlkHsType ttype
+
+ -- wlkHsSigType is used for type signatures: any place there
+ -- should be *implicit* quantification
+wlkHsSigType ttype
+ = wlkHsType ttype `thenUgn` \ ty ->
+ -- This is an implicit quantification point, so
+ -- make sure it starts with a ForAll
+ case ty of
+ HsForAllTy _ _ _ -> returnUgn ty
+ other -> returnUgn (HsForAllTy Nothing [] ty)
+
+wlkHsType :: U_ttype -> UgnM RdrNameHsType
+wlkHsType ttype
+ = case ttype of
+ U_forall u_tyvars u_theta u_ty -> -- Explicit forall
+ wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
+ wlkContext u_theta `thenUgn` \ theta ->
+ wlkHsType u_ty `thenUgn` \ ty ->
+ returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta ty)
+
+ U_imp_forall u_theta u_ty -> -- Implicit forall
+ wlkContext u_theta `thenUgn` \ theta ->
+ wlkHsType u_ty `thenUgn` \ ty ->
+ returnUgn (HsForAllTy Nothing theta ty)
+
+ U_namedtvar tv -> -- type variable
+ wlkTvId tv `thenUgn` \ tyvar ->
+ returnUgn (MonoTyVar tyvar)
+
+ U_tname tcon -> -- type constructor
+ wlkTcId tcon `thenUgn` \ tycon ->
+ returnUgn (MonoTyVar tycon)
+
+ U_tapp t1 t2 ->
+ wlkHsType t1 `thenUgn` \ ty1 ->
+ wlkHsType t2 `thenUgn` \ ty2 ->
+ returnUgn (MonoTyApp ty1 ty2)
+
+ U_tllist tlist -> -- list type
+ wlkHsType tlist `thenUgn` \ ty ->
+ returnUgn (MonoListTy ty)
+
+ U_ttuple ttuple ->
+ wlkList rdMonoType ttuple `thenUgn` \ tys ->
+ returnUgn (MonoTupleTy tys True)
+
+ U_tutuple ttuple ->
+ wlkList rdMonoType ttuple `thenUgn` \ tys ->
+ returnUgn (MonoTupleTy tys False)
+
+ U_tfun tfun targ ->
+ wlkHsType tfun `thenUgn` \ ty1 ->
+ wlkHsType targ `thenUgn` \ ty2 ->
+ returnUgn (MonoFunTy ty1 ty2)
+
+wlkInstType ttype
+ = case ttype of
+ U_forall u_tyvars u_theta inst_head ->
+ wlkList rdTvId u_tyvars `thenUgn` \ tyvars ->
+ wlkContext u_theta `thenUgn` \ theta ->
+ wlkClsTys inst_head `thenUgn` \ (clas, tys) ->
+ returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta (MonoDictTy clas tys))
+
+ U_imp_forall u_theta inst_head ->
+ wlkContext u_theta `thenUgn` \ theta ->
+ wlkClsTys inst_head `thenUgn` \ (clas, tys) ->
+ returnUgn (HsForAllTy Nothing theta (MonoDictTy clas tys))
+
+ other -> -- something else
+ wlkClsTys other `thenUgn` \ (clas, tys) ->
+ returnUgn (HsForAllTy Nothing [] (MonoDictTy clas tys))
\end{code}
\begin{code}
-rdTyConAndTyVars :: String -> RETN_TYPE ((ProtoName, [ProtoName]), String)
-rdContext :: String -> RETN_TYPE (ProtoNameContext, String)
-rdClassAssertTy :: String -> RETN_TYPE ((ProtoName, ProtoName), String)
-
-rdTyConAndTyVars xs
- = BIND (rdMonoType xs) _TO_ (MonoTyCon tycon ty_args, xs1) ->
+wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
+wlkConAndTyVars ttype
+ = wlkHsType ttype `thenUgn` \ ty ->
let
- args = [ a | (MonoTyVar a) <- ty_args ]
+ split (MonoTyApp fun (MonoTyVar arg)) args = split fun (UserTyVar arg : args)
+ split (MonoTyVar tycon) args = (tycon,args)
+ split other args = pprPanic "ERROR: malformed type: "
+ (ppr other)
in
- RETN ((tycon, args), xs1)
- BEND
-
-rdContext xs
- = BIND (rdList rdMonoType xs) _TO_ (tys, xs1) ->
- RETN (map mk_class_assertion tys, xs1)
- BEND
-
-rdClassAssertTy xs
- = BIND (rdMonoType xs) _TO_ (mono_ty, xs1) ->
- RETN (mk_class_assertion mono_ty, xs1)
- BEND
-
-mk_class_assertion :: ProtoNameMonoType -> (ProtoName, ProtoName)
-
-mk_class_assertion (MonoTyCon name [(MonoTyVar tyname)]) = (name, tyname)
-mk_class_assertion other
- = error ("ERROR: malformed type context: "++ppShow 80 (ppr PprForUser other)++"\n")
- -- regrettably, the parser does let some junk past
- -- e.g., f :: Num {-nothing-} => a -> ...
+ returnUgn (split ty [])
+
+
+wlkContext :: U_list -> UgnM RdrNameContext
+rdClsTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
+
+wlkContext list = wlkList rdClsTys list
+
+rdClsTys pt = rdU_ttype pt `thenUgn` wlkClsTys
+
+wlkClsTys ttype
+ = go ttype []
+ where
+ go (U_tname tcon) tys = wlkClsId tcon `thenUgn` \ cls ->
+ returnUgn (cls, tys)
+
+ go (U_tapp t1 t2) tys = wlkHsType t2 `thenUgn` \ ty2 ->
+ go t1 (ty2 : tys)
\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` wlkConDecl
+
+wlkConDecl :: U_constr -> UgnM RdrNameConDecl
+
+wlkConDecl (U_constrex u_tvs ccxt ccdecl)
+ = wlkList rdTvId u_tvs `thenUgn` \ tyvars ->
+ wlkContext ccxt `thenUgn` \ theta ->
+ wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ _ details loc) ->
+ returnUgn (ConDecl con (map UserTyVar tyvars) theta details loc)
+
+wlkConDecl (U_constrpre ccon ctys srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkDataId ccon `thenUgn` \ con ->
+ wlkList rdBangType ctys `thenUgn` \ tys ->
+ returnUgn (ConDecl con [] [] (VanillaCon tys) src_loc)
+
+wlkConDecl (U_constrinf cty1 cop cty2 srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkBangType cty1 `thenUgn` \ ty1 ->
+ wlkDataId cop `thenUgn` \ op ->
+ wlkBangType cty2 `thenUgn` \ ty2 ->
+ returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc)
+
+wlkConDecl (U_constrnew ccon cty mb_lab srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkDataId ccon `thenUgn` \ con ->
+ wlkHsSigType cty `thenUgn` \ ty ->
+ wlkMaybe rdVarId mb_lab `thenUgn` \ mb_lab ->
+ returnUgn (ConDecl con [] [] (NewCon ty mb_lab) src_loc)
+
+wlkConDecl (U_constrrec ccon cfields srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkDataId ccon `thenUgn` \ con ->
+ wlkList rd_field cfields `thenUgn` \ fields_lists ->
+ returnUgn (ConDecl con [] [] (RecCon fields_lists) src_loc)
+ where
+ rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
+ rd_field pt =
+ rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
+ wlkList rdVarId fvars `thenUgn` \ vars ->
+ wlkBangType fty `thenUgn` \ ty ->
+ returnUgn (vars, ty)
+
+-----------------
+rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType
+
+wlkBangType :: U_ttype -> UgnM (BangType RdrName)
+
+wlkBangType (U_tbang bty) = wlkHsConstrArgType bty `thenUgn` \ ty ->
+ returnUgn (Banged ty)
+wlkBangType uty = wlkHsConstrArgType 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 :: ParseTree -> UgnM RdrNameMatch
+rdMatch pt = rdU_match pt `thenUgn` wlkMatch
+
+wlkMatch :: U_match -> UgnM RdrNameMatch
+wlkMatch (U_pmatch pats sig grhsb)
+ = wlkList rdPat pats `thenUgn` \ pats' ->
+ wlkMaybe rdHsType sig `thenUgn` \ maybe_ty ->
+ wlkGRHSs grhsb `thenUgn` \ grhss' ->
+ returnUgn (Match [] pats' maybe_ty grhss')
+\end{code}
-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) ->
+%************************************************************************
+%* *
+\subsection[rdImport]{Read an import decl}
+%* *
+%************************************************************************
- RETN (RdrMatch (read (_UNPK_ srcline)) srcfun pat grhss binding, xs5)
- BEND BEND BEND BEND BEND
+\begin{code}
+rdImport :: ParseTree
+ -> UgnM RdrNameImportDecl
+
+rdImport pt
+ = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec isrc srcline) ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as ->
+ wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec ->
+ returnUgn (ImportDecl (mkSrcModuleFS imod)
+ (cvImportSource isrc)
+ (cvFlag iqual)
+ (case maybe_as of { Just m -> Just (mkSrcModuleFS m); Nothing -> Nothing })
+ maybe_spec src_loc)
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_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)
+
+cvImportSource 0 = ImportByUser -- No pragam
+cvImportSource 1 = ImportByUserSource -- {-# SOURCE #-}
\end{code}
+\begin{code}
+rdEntities pt = rdU_list pt `thenUgn` wlkList rdEntity
+
+rdEntity :: ParseTree -> UgnM (IE RdrName)
+
+rdEntity pt
+ = rdU_entidt pt `thenUgn` \ entity ->
+ case entity of
+ U_entid evar -> -- just a value
+ wlkEntId evar `thenUgn` \ var ->
+ returnUgn (IEVar var)
+
+ U_enttype x -> -- abstract type constructor/class
+ wlkTcClsId x `thenUgn` \ thing ->
+ returnUgn (IEThingAbs thing)
+
+ U_enttypeall x -> -- non-abstract type constructor/class
+ wlkTcClsId x `thenUgn` \ thing ->
+ returnUgn (IEThingAll thing)
+
+ U_enttypenamed x ns -> -- non-abstract type constructor/class
+ -- with specified constrs/methods
+ wlkTcClsId x `thenUgn` \ thing ->
+ wlkList rdVarId ns `thenUgn` \ names ->
+ returnUgn (IEThingWith thing names)
+
+ U_entmod mod -> -- everything provided unqualified by a module
+ returnUgn (IEModuleContents (mkSrcModuleFS mod))
+\end{code}
+
+
%************************************************************************
%* *
-\subsection[rdFixity]{Read in a fixity declaration}
+\subsection[rdExtName]{Read an external name}
%* *
%************************************************************************
\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
+wlkExtName :: U_maybe -> UgnM ExtName
+wlkExtName (U_nothing) = returnUgn Dynamic
+wlkExtName (U_just pt)
+ = rdU_list pt `thenUgn` \ ds ->
+ wlkList rdU_hstring ds `thenUgn` \ ss ->
+ case ss of
+ [nm] -> returnUgn (ExtName nm Nothing)
+ [mod,nm] -> returnUgn (ExtName nm (Just mod))
+
+rdCallConv :: Int -> UgnM CallConv
+rdCallConv x =
+ -- this tracks the #defines in parser/utils.h
+ case x of
+ (-1) -> -- no calling convention specified, use default.
+ returnUgn defaultCallConv
+ _ -> returnUgn x
+
+rdForKind :: Int -> Bool -> UgnM ForKind
+rdForKind 0 isUnsafe = -- foreign import
+ returnUgn (FoImport isUnsafe)
+rdForKind 1 _ = -- foreign export
+ returnUgn FoExport
+rdForKind 2 _ = -- foreign label
+ returnUgn FoLabel
+
\end{code}
%************************************************************************
%* *
-\subsection[rdImportedInterface]{Read an imported interface}
+\subsection[ReadPrefix-help]{Help Functions}
%* *
%************************************************************************
\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
+wlkList :: (U_VOID_STAR -> UgnM a) -> U_list -> UgnM [a]
+
+wlkList wlk_it U_lnil = returnUgn []
+
+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}
-rdRenaming :: String -> RETN_TYPE (Renaming, String)
+wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
-rdRenaming xs
- = BIND (rdIdString xs) _TO_ (id1, xs1) ->
- BIND (rdIdString xs1) _TO_ (id2, xs2) ->
- RETN (MkRenaming id1 id2, xs2)
- BEND BEND
+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}
-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
+wlkTcClsId = wlkQid (\_ -> tcClsName)
+wlkTcId = wlkQid (\_ -> tcName)
+wlkClsId = wlkQid (\_ -> clsName)
+wlkVarId = wlkQid (\occ -> if isLexCon occ
+ then dataName
+ else varName)
+wlkDataId = wlkQid (\_ -> dataName)
+wlkEntId = wlkQid (\occ -> if isLexCon occ
+ then tcClsName
+ else varName)
+
+wlkQid :: (FAST_STRING -> NameSpace) -> U_qid -> UgnM RdrName
+
+-- There are three kinds of qid:
+-- qualified name (aqual) A.x
+-- unqualified name (noqual) x
+-- special name (gid) [], (), ->, (,,,)
+-- The special names always mean "Prelude.whatever"; that's why
+-- they are distinct. So if you write "()", it's just as if you
+-- had written "Prelude.()".
+-- NB: The (qualified) prelude is always in scope, so the renamer will find it.
+
+-- EXCEPT: when we're compiling with -fno-implicit-prelude, in which
+-- case we need to unqualify these things. -- SDM.
+
+wlkQid mk_name_space (U_noqual name)
+ = returnUgn (mkSrcUnqual (mk_name_space name) name)
+wlkQid mk_name_space (U_aqual mod name)
+ = returnUgn (mkSrcQual (mk_name_space name) mod name)
+wlkQid mk_name_space (U_gid n name) -- Built in Prelude things
+ | opt_NoImplicitPrelude
+ = returnUgn (mkSrcUnqual (mk_name_space name) name)
+ | otherwise
+ = returnUgn (mkPreludeQual (mk_name_space name) pRELUDE_Name name)
+
+
+rdTCId pt = rdU_qid pt `thenUgn` wlkTcId
+rdVarId pt = rdU_qid pt `thenUgn` wlkVarId
+
+rdTvId pt = rdU_stringId pt `thenUgn` \ string -> wlkTvId string
+wlkTvId string = returnUgn (mkSrcUnqual tvName string)
+
+-- Unqualified variables, used in the 'forall' of a RULE
+rdUVarId pt = rdU_stringId pt `thenUgn` \ string -> wlkUVarId string
+wlkUVarId string = returnUgn (mkSrcUnqual varName string)
+
+cvFlag :: U_long -> Bool
+cvFlag 0 = False
+cvFlag 1 = True
\end{code}
+