diff options
Diffstat (limited to 'ghc/compiler/reader/ReadPrefix.lhs')
| -rw-r--r-- | ghc/compiler/reader/ReadPrefix.lhs | 1670 |
1 files changed, 803 insertions, 867 deletions
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 5458884e66..6043f72c10 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -1,56 +1,37 @@ % -% (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 + -- used over in ReadPragmas... + wlkList, wlkMaybe, rdConDecl, wlkMonoType, rdMonoType + ) where -IMPORT_Trace -- ToDo: rm (debugging) -import Pretty +import Ubiq{-uitous-} +import RdrLoop -- for paranoia checking + +import UgenAll -- all Yacc parser gumpff... +import PrefixSyn -- and various syntaxen. +import HsSyn +import RdrHsSyn -import AbsSyn -import HsCore -- ****** NEED TO SEE CONSTRUCTORS ****** -import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** -import IdInfo ( UnfoldingGuidance(..) ) -import LiftMonad -import Maybes ( Maybe(..) ) -import PrefixToHs -import PrefixSyn -import ProtoName -import Outputable +-- friends: import ReadPragmas -import SrcLoc ( mkSrcLoc ) -import Util +import PrefixToHs -- reader utilities + +-- others: +import FiniteMap ( elemFM, FiniteMap ) +import MainMonad ( thenMn, MainIO(..) ) +import PprStyle ( PprStyle(..) ) +import Pretty +import ProtoName ( isConopPN, ProtoName(..) ) +import Util ( nOfThem, panic ) \end{code} %************************************************************************ @@ -60,52 +41,36 @@ import Util %************************************************************************ \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] - 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_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} +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 ProtoName +rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid + +wlkQid :: U_qid -> UgnM ProtoName +wlkQid (U_noqual name) + = returnUgn (Unk name) +wlkQid (U_aqual mod name) + = returnUgn (Qunk mod name) +wlkQid (U_gid n name) + = returnUgn (Unk name) \end{code} %************************************************************************ @@ -115,735 +80,673 @@ split_at_tab xs %************************************************************************ \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, _) -> +rdModule :: MainIO + (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. + ProtoNameHsModule) -- the main goods + +rdModule + = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser! + let + srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM) + in + initUgn srcfile ( + + rdU_tree pt `thenUgn` \ (U_hmodule name himplist hexplist hfixlist hmodlist srcline) -> + wlkList rdFixOp hfixlist `thenUgn` \ fixities -> + wlkBinding hmodlist `thenUgn` \ binding -> + wlkList rdImportedInterface himplist `thenUgn` \ imports -> + wlkMaybe rdEntities hexplist `thenUgn` \ exp_list -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> 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 - } + returnUgn ( + name, + mk_export_list_chker exp_list, + HsModule name + exp_list + imports + fixities + tydecls + tysigs + classdecls + instdecls + instsigs + defaultdecls + (cvSepdBinds srcfile cvValSig binds) + [{-no sigs-}] + src_loc + ) } ) where + mk_export_list_chker = panic "ReadPrefix:mk_export_list_chker" +{- LATER: 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 ) - } + = case (getExportees exp_list) of + Nothing -> ( \ n -> False, \ n -> False ) -- all suspicious + Just (entity_info, dotdot_modules) -> + ( \ n -> n `elemFM` entity_info, + \ n -> n `elemFM` dotdot_modules ) +-} \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 ProtoNameHsExpr +rdPat :: ParseTree -> UgnM ProtoNamePat + +rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree +rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree + +wlkExpr :: U_tree -> UgnM ProtoNameHsExpr +wlkPat :: U_tree -> UgnM ProtoNamePat + +wlkExpr expr + = case expr of + U_par expr -> -- parenthesised expr + wlkExpr 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 + wlkList rdPat lampats `thenUgn` \ pats -> + wlkExpr lamexpr `thenUgn` \ body -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn ( + HsLam (foldr PatMatch + (GRHSMatch (GRHSsAndBindsIn + [OtherwiseGRHS body src_loc] + EmptyBinds)) + pats) + ) + + U_casee caseexpr casebody srcline -> -- case expression + wlkExpr caseexpr `thenUgn` \ expr -> + wlkList rdMatch casebody `thenUgn` \ mats -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + getSrcFileUgn `thenUgn` \ sf -> + let + matches = cvMatches sf True mats + in + returnUgn (HsCase expr matches src_loc) + + U_ife ifpred ifthen ifelse srcline -> -- if expression + wlkExpr ifpred `thenUgn` \ e1 -> + wlkExpr ifthen `thenUgn` \ e2 -> + wlkExpr ifelse `thenUgn` \ e3 -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + 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 + wlkList rd_stmt gdo `thenUgn` \ stmts -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (HsDo stmts src_loc) + where + rd_stmt pt + = rdU_tree pt `thenUgn` \ bind -> + case bind of + U_doexp exp srcline -> + wlkExpr exp `thenUgn` \ expr -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (ExprStmt expr src_loc) + + U_dobind pat exp srcline -> + wlkPat pat `thenUgn` \ patt -> + wlkExpr exp `thenUgn` \ expr -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + 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 (HsApp (HsVar (Unk SLIT("negate"))) 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 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 (rvar, expr_maybe) \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 pat -> -- parenthesised pattern + wlkPat 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 + + -------------------------------------------------------------- + -- now the prefix items that can either be an expression or + -- pattern, except we know they are *patterns* here. + -------------------------------------------------------------- + U_negate nexp _ _ -> -- negated pattern: must be a literal + wlkPat nexp `thenUgn` \ lit_pat -> + case lit_pat of + LitPatIn lit -> returnUgn (LitPatIn (negLiteral lit)) + _ -> panic "wlkPat: bad negated pattern!" + + U_lit lit -> -- literal pattern + wlkLiteral lit `thenUgn` \ lit -> + returnUgn (LitPatIn lit) + + U_ident nn -> -- simple identifier + wlkQid nn `thenUgn` \ n -> + returnUgn ( + if isConopPN 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) -> + let + (n, arg_pats) + = case lpat of + VarPatIn x -> (x, lpats) + ConPatIn x [] -> (x, lpats) + ConOpPatIn x op y -> (op, x:y:lpats) + _ -> -- 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) (lpat:lpats))])) + in + 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 -> + wlkQid fun `thenUgn` \ op -> + wlkPat arg1 `thenUgn` \ pat1 -> + wlkPat arg2 `thenUgn` \ pat2 -> + returnUgn (ConOpPatIn pat1 op pat2) + + 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 (rvar, pat_maybe) \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 + U_nullbind -> -- null binding + returnUgn RdrNullBind + + U_abind a b -> -- "and" binding (just glue, really) + wlkBinding a `thenUgn` \ binding1 -> + wlkBinding b `thenUgn` \ binding2 -> + returnUgn (RdrAndBindings binding1 binding2) + + U_tbind tctxt ttype tcons tderivs srcline tpragma -> -- "data" declaration + wlkContext tctxt `thenUgn` \ ctxt -> + wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) -> + wlkList rdConDecl tcons `thenUgn` \ cons -> + wlkDerivings tderivs `thenUgn` \ derivings -> + wlkDataPragma tpragma `thenUgn` \ pragmas -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings pragmas src_loc)) + + U_ntbind ntctxt nttype ntcon ntderivs srcline ntpragma -> -- "newtype" declaration + wlkContext ntctxt `thenUgn` \ ctxt -> + wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) -> + wlkList rdConDecl ntcon `thenUgn` \ con -> + wlkDerivings ntderivs `thenUgn` \ derivings -> + wlkDataPragma ntpragma `thenUgn` \ pragma -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings pragma src_loc)) + + U_nbind nbindid nbindas srcline -> -- "type" declaration + wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) -> + wlkMonoType nbindas `thenUgn` \ expansion -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc)) + + U_fbind fbindl srcline -> -- function binding + wlkList rdMatch fbindl `thenUgn` \ matches -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrFunctionBinding srcline matches) + + U_pbind pbindl srcline -> -- pattern binding + wlkList rdMatch pbindl `thenUgn` \ matches -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrPatternBinding srcline matches) + + U_cbind cbindc cbindid cbindw srcline cpragma -> -- "class" declaration + wlkContext cbindc `thenUgn` \ ctxt -> + wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)-> + wlkBinding cbindw `thenUgn` \ binding -> + wlkClassPragma cpragma `thenUgn` \ pragma -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + 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 pragma src_loc)) + + U_ibind from_source orig_mod -- "instance" declaration + ibindc iclas ibindi ibindw srcline ipragma -> + wlkContext ibindc `thenUgn` \ ctxt -> + wlkQid iclas `thenUgn` \ clas -> + wlkMonoType ibindi `thenUgn` \ inst_ty -> + wlkBinding ibindw `thenUgn` \ binding -> + wlkInstPragma ipragma `thenUgn` \ pragma -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + getSrcFileUgn `thenUgn` \ sf -> + let + from_here = case from_source of { 0 -> False; 1 -> True } + (ss, bs) = sepDeclsIntoSigsAndBinds binding + binds = cvMonoBinds sf bs + uprags = concat (map cvInstDeclSig ss) + ctxt_inst_ty = HsPreForAllTy ctxt inst_ty + in + returnUgn (RdrInstDecl + (InstDecl clas ctxt_inst_ty binds from_here orig_mod uprags pragma src_loc)) + + U_dbind dbindts srcline -> -- "default" declaration + wlkList rdMonoType dbindts `thenUgn` \ tys -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrDefaultDecl (DefaultDecl tys src_loc)) + + U_mbind mod mbindimp srcline -> + -- "import" declaration in an interface + wlkList rdEntity mbindimp `thenUgn` \ entities -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrIfaceImportDecl (IfaceImportDecl mod entities src_loc)) + + U_mfbind fixes -> + -- "infix" declarations in an interface + wlkList rdFixOp fixes `thenUgn` \ fixities -> + returnUgn (RdrIfaceFixities fixities) + + 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 [ProtoName]) + +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 +wlk_sig_thing (U_sbind sbindids sbindid srcline spragma) -- type signature + = wlkList rdQid sbindids `thenUgn` \ vars -> + wlkPolyType sbindid `thenUgn` \ poly_ty -> + wlkTySigPragmas spragma `thenUgn` \ pragma -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrTySig vars poly_ty pragma src_loc) + +wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) -- value specialisation user-pragma + = wlkQid uvar `thenUgn` \ var -> + wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc + | (ty, using_id) <- tys_and_ids ]) + where + rd_ty_and_id :: ParseTree -> UgnM (ProtoNamePolyType, Maybe ProtoName) + 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) + +wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)-- instance specialisation user-pragma + = wlkQid iclas `thenUgn` \ clas -> + wlkMonoType ispec_ty `thenUgn` \ ty -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc)) + +wlk_sig_thing (U_inline_uprag ivar srcline) -- value inlining user-pragma + = wlkQid ivar `thenUgn` \ var -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrInlineValSig (InlineSig var src_loc)) + +wlk_sig_thing (U_deforest_uprag ivar srcline) -- "deforest me" user-pragma + = wlkQid ivar `thenUgn` \ var -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrDeforestSig (DeforestSig var src_loc)) + +wlk_sig_thing (U_magicuf_uprag ivar str srcline) -- "magic" unfolding user-pragma + = wlkQid ivar `thenUgn` \ var -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc)) + +wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline) + = wlkQid itycon `thenUgn` \ tycon -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + wlkList rdMonoType dspec_tys `thenUgn` \ tys -> + let + spec_ty = MonoTyApp tycon tys + in + returnUgn (RdrSpecDataSig (SpecDataSig tycon spec_ty 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 ProtoNamePolyType +rdMonoType :: ParseTree -> UgnM ProtoNameMonoType + +rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype +rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype + +wlkPolyType :: U_ttype -> UgnM ProtoNamePolyType +wlkMonoType :: U_ttype -> UgnM ProtoNameMonoType + +wlkPolyType ttype + = case ttype of +{-LATER: + U_uniforall utvs uty -> -- forall type (pragmas) + wlkList rdU_unkId utvs `thenUgn` \ tvs -> + wlkMonoType uty `thenUgn` \ ty -> + returnUgn (HsForAllTy tvs ty) +-} + + 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 tyvar -> -- type variable + 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 -> returnUgn (tv, 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) + + U_unidict uclas t -> -- DictTy (pragmas) + wlkQid uclas `thenUgn` \ clas -> + wlkMonoType t `thenUgn` \ ty -> + returnUgn (MonoDictTy clas ty) \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 (ProtoName, [ProtoName]) +wlkContext :: U_list -> UgnM ProtoNameContext +wlkClassAssertTy :: U_ttype -> UgnM (ProtoName, ProtoName) -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 (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") -- regrettably, the parser does let some junk past @@ -851,62 +754,103 @@ mk_class_assertion other \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 ProtoNameConDecl +rdConDecl pt + = rdU_constr pt `thenUgn` \ blah -> + wlkConDecl blah + +wlkConDecl :: U_constr -> UgnM ProtoNameConDecl + +wlkConDecl (U_constrpre ccon ctys srcline) + = mkSrcLocUgn srcline `thenUgn` \ 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 `thenUgn` \ 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 `thenUgn` \ src_loc -> + wlkQid ccon `thenUgn` \ con -> + wlkMonoType cty `thenUgn` \ ty -> + returnUgn (NewConDecl con ty src_loc) + +wlkConDecl (U_constrrec ccon cfields srcline) + = mkSrcLocUgn srcline `thenUgn` \ src_loc -> + wlkQid ccon `thenUgn` \ con -> + wlkList rd_field cfields `thenUgn` \ fields_lists -> + returnUgn (RecConDecl con (concat fields_lists) src_loc) + where + rd_field :: ParseTree -> UgnM [(ProtoName, BangType ProtoName)] + rd_field pt + = rdU_constr pt `thenUgn` \ (U_field fvars fty) -> + wlkList rdQid fvars `thenUgn` \ vars -> + wlkBangType fty `thenUgn` \ ty -> + returnUgn [ (var, ty) | var <- vars ] + +----------------- +rdBangType pt = rdU_ttype pt `thenUgn` \ ty -> wlkBangType ty + +wlkBangType :: U_ttype -> UgnM (BangType ProtoName) + +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 :: ParseTree -> UgnM RdrMatch -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 pt + = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) -> + + 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 ProtoNameFixityDecl +rdFixOp pt + = rdU_tree pt `thenUgn` \ fix -> + case fix of + U_fixop op (-1) prec -> returnUgn (InfixL op prec) + U_fixop op 0 prec -> returnUgn (InfixN op prec) + U_fixop op 1 prec -> returnUgn (InfixR op prec) + _ -> error "ReadPrefix:rdFixOp" \end{code} %************************************************************************ @@ -916,81 +860,73 @@ rdFixity xs %************************************************************************ \begin{code} -rdImportedInterface :: FAST_STRING -> String - -> RETN_TYPE (ProtoNameImportedInterface, String) +rdImportedInterface :: ParseTree + -> UgnM ProtoNameImportedInterface + +rdImportedInterface pt + = rdU_binding pt + `thenUgn` \ (U_import ifname iffile binddef imod iqual ias ispec srcline) -> -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) -> + mkSrcLocUgn srcline `thenUgn` \ src_loc -> + wlkMaybe rdU_stringId ias `thenUgn` \ maybe_as -> + wlkMaybe rd_spec ispec `thenUgn` \ maybe_spec -> + + setSrcFileUgn iffile ( -- looking inside the .hi file... + wlkBinding binddef + ) `thenUgn` \ iface_bs -> case (sepDeclsForInterface iface_bs) of { - (tydecls,classdecls,instdecls,sigs,iimpdecls) -> + (tydecls,classdecls,instdecls,sigs,iimpdecls,ifixities) -> 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 -\end{code} + cv_sigs = concat (map cvValSig sigs) -\begin{code} -rdRenaming :: String -> RETN_TYPE (Renaming, String) + cv_iface = Interface ifname iimpdecls ifixities + tydecls classdecls instdecls cv_sigs + src_loc -rdRenaming xs - = BIND (rdIdString xs) _TO_ (id1, xs1) -> - BIND (rdIdString xs1) _TO_ (id2, xs2) -> - RETN (MkRenaming id1 id2, xs2) - BEND BEND + cv_qual = case iqual of {0 -> False; 1 -> True} + in + returnUgn (ImportMod cv_iface cv_qual maybe_as maybe_spec) + } + 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} -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 +rdEntities pt + = rdU_list pt `thenUgn` \ list -> + wlkList rdEntity list + +rdEntity :: ParseTree -> UgnM (IE ProtoName) + +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} + |