%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section{Read parse tree built by Yacc parser}
\begin{code}
-#include "HsVersions.h"
-
-module ReadPrefix (
- rdModule
- ) where
+module ReadPrefix ( rdModule ) where
-import Ubiq
+#include "HsVersions.h"
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
import HsSyn
-import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas )
-import RdrHsSyn
+import HsTypes ( HsTyVar(..) )
+import HsPragmas ( noDataPragmas, noClassPragmas )
+import RdrHsSyn
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import PrelMods ( pRELUDE_Name )
import PrefixToHs
-
-import CmdLineOpts ( opt_CompilingPrelude )
-import ErrUtils ( addErrLoc )
-import FiniteMap ( elemFM, FiniteMap )
-import MainMonad ( writeMn, exitMn, MainIO(..) )
-import Name ( RdrName(..), isConopRdr )
-import PprStyle ( PprStyle(..) )
-import Pretty
+import 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 ErrUtils ( dumpIfSet )
import SrcLoc ( SrcLoc )
-import Util ( nOfThem, pprError, panic )
+import FastString ( mkFastCharString )
+import PrelRead ( readRational__ )
\end{code}
%************************************************************************
%* *
-\subsection[ReadPrefix-help]{Help Functions}
+\subsection[rdModule]{@rdModule@: reads in a Haskell module}
%* *
%************************************************************************
\begin{code}
-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}
+rdModule :: IO (ModuleName, -- this module's name
+ RdrNameHsModule) -- the main goods
-\begin{code}
-wlkMaybe :: (U_VOID_STAR -> UgnM a) -> U_maybe -> UgnM (Maybe a)
+rdModule
+ = -- call the Yacc parser!
+ _ccall_ hspmain >>= \ pt ->
-wlkMaybe wlk_it U_nothing = returnUgn Nothing
-wlkMaybe wlk_it (U_just x)
- = wlk_it x `thenUgn` \ it ->
- returnUgn (Just it)
-\end{code}
+ -- Read from the Yacc tree
+ initUgn (read_module pt) >>= \ (mod_name, rdr_module) ->
-\begin{code}
-rdQid :: ParseTree -> UgnM RdrName
-rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
+ -- Dump if reqd
+ dumpIfSet opt_D_dump_rdr "Reader"
+ (ppr rdr_module) >>
-wlkQid :: U_qid -> UgnM RdrName
-wlkQid (U_noqual name)
- = returnUgn (Unqual name)
-wlkQid (U_aqual mod name)
- = returnUgn (Qual mod name)
-wlkQid (U_gid n name)
- = returnUgn (Unqual name)
+ -- And return
+ return (mod_name, rdr_module)
-cvFlag :: U_long -> Bool
-cvFlag 0 = False
-cvFlag 1 = True
-\end{code}
+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
-%************************************************************************
-%* *
-\subsection[rdModule]{@rdModule@: reads in a Haskell module}
-%* *
-%************************************************************************
+ setSrcFileUgn srcfile $
+ mkSrcLocUgn srcline $ \ src_loc ->
-\begin{code}
-rdModule :: MainIO (Module, -- this module's name
- RdrNameHsModule) -- the main goods
+ wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
+ wlkList rdImport himplist `thenUgn` \ imports ->
+ wlkBinding hmodlist `thenUgn` \ binding ->
-rdModule
- = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
let
- srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM)
+ 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
- initUgn $
- rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
- hmodlist srciface_version srcline) ->
-
- setSrcFileUgn srcfile $
- setSrcModUgn modname $
- mkSrcLocUgn srcline $ \ src_loc ->
-
- wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
- wlkList rdImport himplist `thenUgn` \ imports ->
- wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
- wlkBinding hmodlist `thenUgn` \ binding ->
-
- case sepDeclsForTopBinds binding of
- (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
-
- returnUgn (modname,
- HsModule modname
- (case srciface_version of { 0 -> Nothing; n -> Just n })
- exports
- imports
- fixities
- tydecls
- tysigs
- classdecls
- instdecls
- instsigs
- defaultdecls
- (cvSepdBinds srcfile cvValSig binds)
- [{-no interface sigs yet-}]
- src_loc
- )
+ returnUgn (mod_name, rdr_module)
\end{code}
%************************************************************************
rdExpr :: ParseTree -> UgnM RdrNameHsExpr
rdPat :: ParseTree -> UgnM RdrNamePat
-rdExpr pt = rdU_tree pt `thenUgn` \ tree -> wlkExpr tree
-rdPat pt = rdU_tree pt `thenUgn` \ tree -> wlkPat tree
+rdExpr pt = rdU_tree pt `thenUgn` wlkExpr
+rdPat pt = rdU_tree pt `thenUgn` wlkPat
wlkExpr :: U_tree -> UgnM RdrNameHsExpr
wlkPat :: U_tree -> UgnM RdrNamePat
U_lsection lsexp lop -> -- left section
wlkExpr lsexp `thenUgn` \ expr ->
- wlkQid lop `thenUgn` \ op ->
+ wlkVarId lop `thenUgn` \ op ->
returnUgn (SectionL expr (HsVar op))
U_rsection rop rsexp -> -- right section
- wlkQid rop `thenUgn` \ op ->
+ wlkVarId rop `thenUgn` \ op ->
wlkExpr rsexp `thenUgn` \ expr ->
returnUgn (SectionR (HsVar op) expr)
wlkExpr sccexp `thenUgn` \ expr ->
returnUgn (HsSCC label expr)
- U_lambda lampats lamexpr srcline -> -- lambda expression
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdPat lampats `thenUgn` \ pats ->
- wlkExpr lamexpr `thenUgn` \ body ->
- returnUgn (
- HsLam (foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn
- [OtherwiseGRHS body src_loc]
- EmptyBinds))
- pats)
- )
+ U_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 ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- matches = cvMatches sf True mats
- in
- returnUgn (HsCase expr matches src_loc)
+ returnUgn (HsCase expr mats src_loc)
U_ife ifpred ifthen ifelse srcline -> -- if expression
mkSrcLocUgn srcline $ \ 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)
+ 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 stmts src_loc)
+ returnUgn (HsDo DoStmt stmts src_loc)
where
rd_stmt pt
= rdU_tree pt `thenUgn` \ bind ->
returnUgn (BindStmt patt expr src_loc)
U_seqlet seqlet ->
- wlkBinding seqlet `thenUgn` \ bs ->
- getSrcFileUgn `thenUgn` \ sf ->
- let
- binds = cvBinds sf cvValSig bs
- in
+ wlkLocalBinding seqlet `thenUgn` \ binds ->
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)
+ 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 ->
U_restr restre restrt -> -- expression with type signature
wlkExpr restre `thenUgn` \ expr ->
- wlkPolyType restrt `thenUgn` \ ty ->
+ wlkHsSigType restrt `thenUgn` \ ty ->
returnUgn (ExprWithTySig expr ty)
--------------------------------------------------------------
returnUgn (HsLit lit)
U_ident n -> -- simple identifier
- wlkQid n `thenUgn` \ var ->
+ wlkVarId n `thenUgn` \ var ->
returnUgn (HsVar var)
U_ap fun arg -> -- application
returnUgn (HsApp expr1 expr2)
U_infixap fun arg1 arg2 -> -- infix application
- wlkQid fun `thenUgn` \ op ->
+ wlkVarId fun `thenUgn` \ op ->
wlkExpr arg1 `thenUgn` \ expr1 ->
wlkExpr arg2 `thenUgn` \ expr2 ->
- returnUgn (OpApp expr1 (HsVar op) expr2)
+ returnUgn (mkOpApp expr1 op expr2)
U_negate nexp -> -- prefix negation
wlkExpr nexp `thenUgn` \ expr ->
- returnUgn (NegApp expr)
+ returnUgn (NegApp expr (HsVar dummyRdrVarName))
U_llist llist -> -- explicit list
wlkList rdExpr llist `thenUgn` \ exprs ->
U_tuple tuplelist -> -- explicit tuple
wlkList rdExpr tuplelist `thenUgn` \ exprs ->
- returnUgn (ExplicitTuple 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
- wlkQid con `thenUgn` \ rcon ->
+ wlkDataId con `thenUgn` \ rcon ->
wlkList rdRbind rbinds `thenUgn` \ recbinds ->
- returnUgn (RecordCon (HsVar rcon) recbinds)
+ returnUgn (RecordCon rcon recbinds)
U_rupdate updexp updbinds -> -- record update
wlkExpr updexp `thenUgn` \ aexp ->
returnUgn (RecordUpd aexp recbinds)
#ifdef DEBUG
- U_hmodule _ _ _ _ _ _ _ -> error "U_hmodule"
+ 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 ->
+ 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
= case pat of
U_par ppat -> -- parenthesised pattern
wlkPat ppat `thenUgn` \ pat ->
- returnUgn (ParPatIn pat)
+ -- tidy things up a little:
+ returnUgn (
+ case pat of
+ VarPatIn _ -> pat
+ WildPatIn -> pat
+ other -> ParPatIn pat
+ )
U_as avar as_pat -> -- "as" pattern
- wlkQid avar `thenUgn` \ var ->
+ 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_wildp -> returnUgn WildPatIn -- wildcard pattern
+ 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 nn -> -- simple identifier
- wlkQid nn `thenUgn` \ n ->
+ U_ident (U_noqual s) | s == SLIT("_")-> returnUgn WildPatIn -- Wild-card pattern
+
+ U_ident nn -> -- simple identifier
+ wlkVarId nn `thenUgn` \ n ->
returnUgn (
- if isConopRdr n
- then ConPatIn n []
- else VarPatIn n
+ 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)
+ VarPatIn x -> returnUgn (x, lpats)
+ ConPatIn x [] -> returnUgn (x, lpats)
+ ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
_ -> getSrcLocUgn `thenUgn` \ loc ->
- let
- err = addErrLoc loc "Illegal pattern `application'"
- (\sty -> ppInterleave ppSP (map (ppr sty) (lpat:lpats)))
- msg = ppShow 100 (err PprForUser)
- in
- ioToUgnM (writeMn stderr msg) `thenUgn` \ _ ->
- ioToUgnM (exitMn 1) `thenUgn` \ _ ->
- returnUgn (error "ReadPrefix")
+ pprPanic "Illegal pattern `application'"
+ (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
) `thenUgn` \ (n, arg_pats) ->
returnUgn (ConPatIn n arg_pats)
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
- wlkQid fun `thenUgn` \ op ->
+ wlkVarId fun `thenUgn` \ op ->
wlkPat arg1 `thenUgn` \ pat1 ->
wlkPat arg2 `thenUgn` \ pat2 ->
- returnUgn (ConOpPatIn pat1 op pat2)
+ returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
U_negate npat -> -- negated pattern
wlkPat npat `thenUgn` \ pat ->
U_tuple tuplelist -> -- explicit tuple
wlkList rdPat tuplelist `thenUgn` \ pats ->
- returnUgn (TuplePatIn 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
- wlkQid con `thenUgn` \ rcon ->
+ wlkDataId 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 ->
+ wlkVarId var `thenUgn` \ rvar ->
wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
returnUgn (
case pat_maybe of
wlkLiteral ulit
= returnUgn (
case ulit of
- U_integer s -> HsInt (as_integer s)
+ 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)
where
as_char s = _HEAD_ s
as_integer s = readInteger (_UNPK_ s)
- as_rational s = _readRational (_UNPK_ s) -- non-std
+ as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
+ -- to handle rationals with leading '-'
as_string s = s
\end{code}
%************************************************************************
\begin{code}
+wlkLocalBinding bind
+ = wlkBinding bind `thenUgn` \ bind' ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ returnUgn (cvBinds sf cvValSig bind')
+
wlkBinding :: U_binding -> UgnM RdrBinding
wlkBinding binding
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 ->
- wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
+ wlkConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl tcons `thenUgn` \ cons ->
wlkDerivings tderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc))
+ 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 ->
- wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
- wlkList rdConDecl ntcon `thenUgn` \ con ->
+ wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
+ wlkList rdConDecl ntcon `thenUgn` \ cons ->
wlkDerivings ntderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
+ returnUgn (RdrHsDecl (TyClD (TyData NewType ctxt tycon tyvars cons
+ derivings noDataPragmas src_loc)))
-- "type" declaration
U_nbind nbindid nbindas srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
- wlkTyConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
- wlkMonoType nbindas `thenUgn` \ expansion ->
- returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion src_loc))
+ wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
+ wlkHsType nbindas `thenUgn` \ expansion ->
+ returnUgn (RdrHsDecl (TyClD (TySynonym tycon tyvars expansion src_loc)))
-- function binding
- U_fbind fbindl srcline ->
+ U_fbind fbindm srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdMatch fbindl `thenUgn` \ matches ->
- returnUgn (RdrFunctionBinding srcline matches)
+ wlkList rdMatch fbindm `thenUgn` \ matches ->
+ returnUgn (RdrValBinding (mkRdrFunctionBinding matches src_loc))
-- pattern binding
- U_pbind pbindl srcline ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdMatch pbindl `thenUgn` \ matches ->
- returnUgn (RdrPatternBinding srcline matches)
+ 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 ->
- wlkClassAssertTy cbindid `thenUgn` \ (clas, tyvar)->
- wlkBinding cbindw `thenUgn` \ binding ->
- getSrcFileUgn `thenUgn` \ sf ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ wlkContext cbindc `thenUgn` \ ctxt ->
+ wlkConAndTyVars cbindid `thenUgn` \ (clas, tyvars) ->
+ wlkBinding cbindw `thenUgn` \ binding ->
+ getSrcFileUgn `thenUgn` \ sf ->
let
- (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
-
- final_sigs = concat (map cvClassOpSig class_sigs)
- final_methods = cvMonoBinds sf class_methods
+ (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
in
- returnUgn (RdrClassDecl
- (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
+ returnUgn (RdrHsDecl (TyClD (mkClassDecl ctxt clas tyvars final_sigs
+ final_methods noClassPragmas src_loc)))
-- "instance" declaration
- U_ibind ibindc iclas ibindi ibindw srcline ->
+ 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 ->
- wlkContext ibindc `thenUgn` \ ctxt ->
- wlkQid iclas `thenUgn` \ clas ->
- wlkMonoType ibindi `thenUgn` \ inst_ty ->
- wlkBinding ibindw `thenUgn` \ binding ->
- getSrcModUgn `thenUgn` \ modname ->
- getSrcFileUgn `thenUgn` \ sf ->
+ wlkInstType ty `thenUgn` \ inst_ty ->
+ wlkBinding ibindw `thenUgn` \ binding ->
+ getSrcFileUgn `thenUgn` \ sf ->
let
- (ss, bs) = sepDeclsIntoSigsAndBinds binding
- binds = cvMonoBinds sf bs
- uprags = concat (map cvInstDeclSig ss)
- ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
- maybe_mod = if opt_CompilingPrelude
- then Nothing
- else Just modname
+ (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
in
- returnUgn (RdrInstDecl
- (InstDecl clas ctxt_inst_ty binds True maybe_mod uprags noInstancePragmas src_loc))
+ 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 (RdrDefaultDecl (DefaultDecl tys src_loc))
+ 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])
- a_sig_we_hope ->
- -- signature(-like) things, including user pragmas
- wlk_sig_thing a_sig_we_hope
-\end{code}
+ 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 ])
-\begin{code}
-wlkDerivings :: U_maybe -> UgnM (Maybe [RdrName])
+ 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))
-wlkDerivings (U_nothing) = returnUgn Nothing
-wlkDerivings (U_just pt)
- = rdU_list pt `thenUgn` \ ds ->
- wlkList rdQid ds `thenUgn` \ derivs ->
- returnUgn (Just derivs)
-\end{code}
+ 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)
-\begin{code}
- -- type signature
-wlk_sig_thing (U_sbind sbindids sbindid srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdQid sbindids `thenUgn` \ vars ->
- wlkPolyType sbindid `thenUgn` \ poly_ty ->
- returnUgn (RdrTySig vars poly_ty src_loc)
+ 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)
- -- value specialisation user-pragma
-wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid uvar `thenUgn` \ var ->
- wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
- returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
- | (ty, using_id) <- tys_and_ids ])
- where
- rd_ty_and_id :: ParseTree -> UgnM (RdrNamePolyType, Maybe RdrName)
- rd_ty_and_id pt
- = rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
- wlkPolyType vspec_ty `thenUgn` \ ty ->
- wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe ->
- returnUgn(ty, id_maybe)
- -- instance specialisation user-pragma
-wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid iclas `thenUgn` \ clas ->
- wlkMonoType ispec_ty `thenUgn` \ ty ->
- returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
+rdRuleBndr :: ParseTree -> UgnM RdrNameRuleBndr
+rdRuleBndr pt = rdU_rulevar pt `thenUgn` wlkRuleBndr
- -- data specialisation user-pragma
-wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid itycon `thenUgn` \ tycon ->
- wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
- returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc))
+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')
- -- value inlining user-pragma
-wlk_sig_thing (U_inline_uprag ivar srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ivar `thenUgn` \ var ->
- returnUgn (RdrInlineValSig (InlineSig var src_loc))
- -- "deforest me" user-pragma
-wlk_sig_thing (U_deforest_uprag ivar srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ivar `thenUgn` \ var ->
- returnUgn (RdrDeforestSig (DeforestSig var src_loc))
- -- "magic" unfolding user-pragma
-wlk_sig_thing (U_magicuf_uprag ivar str srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ivar `thenUgn` \ var ->
- returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
+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}
+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}
%************************************************************************
%************************************************************************
\begin{code}
-rdPolyType :: ParseTree -> UgnM RdrNamePolyType
-rdMonoType :: ParseTree -> UgnM RdrNameMonoType
-
-rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
-rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
-
-wlkPolyType :: U_ttype -> UgnM RdrNamePolyType
-wlkMonoType :: U_ttype -> UgnM RdrNameMonoType
-
-wlkPolyType ttype
+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_context tcontextl tcontextt -> -- context
- wlkContext tcontextl `thenUgn` \ ctxt ->
- wlkMonoType tcontextt `thenUgn` \ ty ->
- returnUgn (HsPreForAllTy ctxt ty)
+ 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)
- other -> -- something else
- wlkMonoType other `thenUgn` \ ty ->
- returnUgn (HsPreForAllTy [{-no context-}] 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)
-wlkMonoType ttype
- = case ttype of
U_namedtvar tv -> -- type variable
- wlkQid tv `thenUgn` \ tyvar ->
+ wlkTvId tv `thenUgn` \ tyvar ->
returnUgn (MonoTyVar tyvar)
U_tname tcon -> -- type constructor
- wlkQid tcon `thenUgn` \ tycon ->
- returnUgn (MonoTyApp tycon [])
+ wlkTcId tcon `thenUgn` \ tycon ->
+ returnUgn (MonoTyVar tycon)
U_tapp t1 t2 ->
- wlkMonoType t2 `thenUgn` \ ty2 ->
- collect t1 [ty2] `thenUgn` \ (tycon, tys) ->
- returnUgn (MonoTyApp tycon tys)
- where
- collect t acc
- = case t of
- U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
- collect t1 (ty2:acc)
- U_tname tcon -> wlkQid tcon `thenUgn` \ tycon ->
- returnUgn (tycon, acc)
- U_namedtvar tv -> wlkQid tv `thenUgn` \ tyvar ->
- returnUgn (tyvar, acc)
- U_tllist _ -> panic "tlist"
- U_ttuple _ -> panic "ttuple"
- U_tfun _ _ -> panic "tfun"
- U_tbang _ -> panic "tbang"
- U_context _ _ -> panic "context"
- _ -> panic "something else"
+ wlkHsType t1 `thenUgn` \ ty1 ->
+ wlkHsType t2 `thenUgn` \ ty2 ->
+ returnUgn (MonoTyApp ty1 ty2)
U_tllist tlist -> -- list type
- wlkMonoType tlist `thenUgn` \ ty ->
+ wlkHsType tlist `thenUgn` \ ty ->
returnUgn (MonoListTy ty)
U_ttuple ttuple ->
wlkList rdMonoType ttuple `thenUgn` \ tys ->
- returnUgn (MonoTupleTy tys)
+ returnUgn (MonoTupleTy tys True)
+
+ U_tutuple ttuple ->
+ wlkList rdMonoType ttuple `thenUgn` \ tys ->
+ returnUgn (MonoTupleTy tys False)
U_tfun tfun targ ->
- wlkMonoType tfun `thenUgn` \ ty1 ->
- wlkMonoType targ `thenUgn` \ ty2 ->
+ 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}
-wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [RdrName])
-wlkContext :: U_list -> UgnM RdrNameContext
-wlkClassAssertTy :: U_ttype -> UgnM (RdrName, RdrName)
-
-wlkTyConAndTyVars ttype
- = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
+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
- returnUgn (tycon, args)
+ returnUgn (split ty [])
-wlkContext list
- = wlkList rdMonoType list `thenUgn` \ tys ->
- returnUgn (map mk_class_assertion tys)
-wlkClassAssertTy xs
- = wlkMonoType xs `thenUgn` \ mono_ty ->
- returnUgn (mk_class_assertion mono_ty)
+wlkContext :: U_list -> UgnM RdrNameContext
+rdClsTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
-mk_class_assertion :: RdrNameMonoType -> (RdrName, RdrName)
+wlkContext list = wlkList rdClsTys list
-mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
-mk_class_assertion other
- = pprError "ERROR: malformed type context: " (ppr PprForUser other)
- -- regrettably, the parser does let some junk past
- -- e.g., f :: Num {-nothing-} => a -> ...
+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 :: ParseTree -> UgnM RdrNameConDecl
-rdConDecl pt
- = rdU_constr pt `thenUgn` \ blah ->
- wlkConDecl blah
+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 ->
- wlkQid ccon `thenUgn` \ con ->
+ wlkDataId ccon `thenUgn` \ con ->
wlkList rdBangType ctys `thenUgn` \ tys ->
- returnUgn (ConDecl con tys src_loc)
+ returnUgn (ConDecl con [] [] (VanillaCon tys) src_loc)
wlkConDecl (U_constrinf cty1 cop cty2 srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkBangType cty1 `thenUgn` \ ty1 ->
- wlkQid cop `thenUgn` \ op ->
+ wlkDataId cop `thenUgn` \ op ->
wlkBangType cty2 `thenUgn` \ ty2 ->
- returnUgn (ConOpDecl ty1 op ty2 src_loc)
+ returnUgn (ConDecl op [] [] (InfixCon ty1 ty2) src_loc)
-wlkConDecl (U_constrnew ccon cty srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ccon `thenUgn` \ con ->
- wlkMonoType cty `thenUgn` \ ty ->
- returnUgn (NewConDecl con ty src_loc)
+wlkConDecl (U_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 ->
- wlkQid ccon `thenUgn` \ con ->
+ wlkDataId ccon `thenUgn` \ con ->
wlkList rd_field cfields `thenUgn` \ fields_lists ->
- returnUgn (RecConDecl con fields_lists src_loc)
- where
+ 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 rdQid fvars `thenUgn` \ vars ->
- wlkBangType fty `thenUgn` \ ty ->
- returnUgn (vars, ty)
+ 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` \ ty -> wlkBangType ty
+rdBangType pt = rdU_ttype pt `thenUgn` wlkBangType
wlkBangType :: U_ttype -> UgnM (BangType RdrName)
-wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty -> returnUgn (Banged ty)
-wlkBangType uty = wlkMonoType uty `thenUgn` \ ty -> returnUgn (Unbanged ty)
-
+wlkBangType (U_tbang bty) = wlkHsConstrArgType bty `thenUgn` \ ty ->
+ returnUgn (Banged ty)
+wlkBangType uty = wlkHsConstrArgType uty `thenUgn` \ ty ->
+ returnUgn (Unbanged ty)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-rdMatch :: ParseTree -> UgnM RdrMatch
-
-rdMatch pt
- = rdU_pbinding pt `thenUgn` \ (U_pgrhs gpat gdexprs gbind gsrcfun srcline) ->
- mkSrcLocUgn srcline $ \ src_loc ->
- wlkPat gpat `thenUgn` \ pat ->
- wlkBinding gbind `thenUgn` \ binding ->
- wlkQid gsrcfun `thenUgn` \ srcfun ->
- let
- wlk_guards (U_pnoguards exp)
- = wlkExpr exp `thenUgn` \ expr ->
- returnUgn (RdrMatch_NoGuard srcline srcfun pat expr binding)
-
- 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_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[rdFixOp]{Read in a fixity declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-rdFixOp :: ParseTree -> UgnM RdrNameFixityDecl
-rdFixOp pt
- = rdU_tree pt `thenUgn` \ fix ->
- case fix of
- U_fixop op (-1) prec -> wlkQid op `thenUgn` \ op ->
- returnUgn (InfixL op prec)
- U_fixop op 0 prec -> wlkQid op `thenUgn` \ op ->
- returnUgn (InfixN op prec)
- U_fixop op 1 prec -> wlkQid op `thenUgn` \ op ->
- returnUgn (InfixR op prec)
- _ -> error "ReadPrefix:rdFixOp"
+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}
%************************************************************************
-> UgnM RdrNameImportDecl
rdImport pt
- = rdU_binding pt `thenUgn` \ (U_import imod iqual ias ispec srcline) ->
+ = 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 imod (cvFlag iqual) maybe_as maybe_spec src_loc)
+ 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_spec pt = rdU_either pt `thenUgn` \ spec ->
case spec of
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` \ list ->
- wlkList rdEntity list
+rdEntities pt = rdU_list pt `thenUgn` wlkList rdEntity
rdEntity :: ParseTree -> UgnM (IE RdrName)
= rdU_entidt pt `thenUgn` \ entity ->
case entity of
U_entid evar -> -- just a value
- wlkQid evar `thenUgn` \ var ->
+ wlkEntId evar `thenUgn` \ var ->
returnUgn (IEVar var)
U_enttype x -> -- abstract type constructor/class
- wlkQid x `thenUgn` \ thing ->
+ wlkTcClsId x `thenUgn` \ thing ->
returnUgn (IEThingAbs thing)
U_enttypeall x -> -- non-abstract type constructor/class
- wlkQid x `thenUgn` \ thing ->
+ wlkTcClsId 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)
+ 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[rdExtName]{Read an external name}
+%* *
+%************************************************************************
+
+\begin{code}
+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[ReadPrefix-help]{Help Functions}
+%* *
+%************************************************************************
- U_entmod mod -> -- everything provided by a module
- returnUgn (IEModuleContents mod)
+\begin{code}
+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}
+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}
+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}