module ReadPrefix ( rdModule ) where
IMP_Ubiq()
+IMPORT_1_3(IO(hPutStr, stderr))
+#if __GLASGOW_HASKELL__ == 201
+import GHCio(stThen)
+#elif __GLASGOW_HASKELL__ >= 202
+import GlaExts
+import IOBase
+import PrelRead
+#endif
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, noInstancePragmas, noGenPragmas )
+import RdrHsSyn
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
import PrefixToHs
-import CmdLineOpts ( opt_CompilingPrelude )
+import CmdLineOpts ( opt_PprUserLength )
import ErrUtils ( addErrLoc, ghcExit )
import FiniteMap ( elemFM, FiniteMap )
-import Name ( RdrName(..), isRdrLexConOrSpecial )
-import PprStyle ( PprStyle(..) )
-import PrelMods ( fromPrelude, pRELUDE )
+import Name ( OccName(..), SYN_IE(Module) )
+import Lex ( isLexConId )
+import Outputable ( Outputable(..), PprStyle(..) )
+import PrelMods ( pRELUDE )
import Pretty
-import SrcLoc ( SrcLoc )
+import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
import Util ( nOfThem, pprError, panic )
\end{code}
\end{code}
\begin{code}
-rdQid :: ParseTree -> UgnM RdrName
-rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
-
-wlkQid :: U_qid -> UgnM RdrName
-wlkQid (U_noqual name)
- = returnUgn (Unqual name)
-wlkQid (U_aqual mod name)
- | fromPrelude mod
- = returnUgn (Unqual name)
- | otherwise
- = returnUgn (Qual mod name)
-wlkQid (U_gid n name)
- = returnUgn (Unqual name)
+wlkTvId = wlkQid TvOcc
+wlkTCId = wlkQid TCOcc
+wlkVarId = wlkQid VarOcc
+wlkDataId = wlkQid VarOcc
+wlkEntId = wlkQid (\occ -> if isLexConId occ
+ then TCOcc occ
+ else VarOcc occ)
+
+wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
+
+-- There are three kinds of qid:
+-- qualified name (noqual) A.x
+-- unqualified name (aqual) 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.
+
+wlkQid mk_occ_name (U_noqual name)
+ = returnUgn (Unqual (mk_occ_name name))
+wlkQid mk_occ_name (U_aqual mod name)
+ = returnUgn (Qual mod (mk_occ_name name) HiFile)
+wlkQid mk_occ_name (U_gid n name)
+ = returnUgn (Qual pRELUDE (mk_occ_name name) HiFile)
+
+rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
+rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
cvFlag :: U_long -> Bool
cvFlag 0 = False
%************************************************************************
\begin{code}
+#if __GLASGOW_HASKELL__ == 201
+# define PACK_STR packCString
+#elif __GLASGOW_HASKELL__ >= 202
+# define PACK_STR mkFastCharString
+#else
+# define PACK_STR mkFastCharString
+#endif
+
rdModule :: IO (Module, -- this module's name
RdrNameHsModule) -- the main goods
rdModule
- = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser!
+ = _ccall_ hspmain `CCALL_THEN` \ pt -> -- call the Yacc parser!
let
- srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM)
+ srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
in
initUgn $
rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
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 ->
+ mkSrcLocUgn srcline $ \ src_loc ->
- case sepDeclsForTopBinds binding of
- (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
+ wlkMaybe rdEntities hexplist `thenUgn` \ exports ->
+ wlkList rdImport himplist `thenUgn` \ imports ->
+ wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
+ wlkBinding hmodlist `thenUgn` \ binding ->
- returnUgn (modname,
- HsModule modname
+ let
+ val_decl = ValD (cvBinds srcfile cvValSig binding)
+ other_decls = cvOtherDecls binding
+ in
+ 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-}]
+ (val_decl: other_decls)
src_loc
)
\end{code}
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)
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 ->
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 ->
+ wlkHsType 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 ->
- -- this is a hack
- let
- neg = SLIT("negate")
- rdr = if opt_CompilingPrelude
- then Unqual neg
- else Qual pRELUDE neg
- in
- returnUgn (NegApp expr (HsVar rdr))
+ returnUgn (NegApp expr (HsVar dummyRdrVarName))
U_llist llist -> -- explicit list
wlkList rdExpr llist `thenUgn` \ exprs ->
returnUgn (ExplicitTuple exprs)
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 ->
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 ->
+ wlkBinding seqlet `thenUgn` \ bs ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ binds = cvBinds sf cvValSig bs
+ in
+ returnUgn (LetStmt binds)
+ U_let letvdefs letvexpr ->
+ wlkBinding letvdefs `thenUgn` \ binding ->
+ wlkExpr letvexpr `thenUgn` \ expr ->
+ getSrcLocUgn `thenUgn` \ loc ->
+ getSrcFileUgn `thenUgn` \ sf ->
+ let
+ binds = cvBinds sf cvValSig binding
+ in
+ returnUgn (GuardStmt (HsLet binds expr) loc)
\end{code}
Patterns: just bear in mind that lists of patterns are represented as
)
U_as avar as_pat -> -- "as" pattern
- wlkQid avar `thenUgn` \ var ->
+ wlkVarId avar `thenUgn` \ var ->
wlkPat as_pat `thenUgn` \ pat ->
returnUgn (AsPatIn var pat)
wlkPat lazyp `thenUgn` \ pat ->
returnUgn (LazyPatIn pat)
+ U_plusp avar lit ->
+ wlkVarId avar `thenUgn` \ var ->
+ wlkLiteral lit `thenUgn` \ lit ->
+ returnUgn (NPlusKPatIn var lit)
+
U_wildp -> returnUgn WildPatIn -- wildcard pattern
U_lit lit -> -- literal pattern
returnUgn (LitPatIn lit)
U_ident nn -> -- simple identifier
- wlkQid nn `thenUgn` \ n ->
+ wlkVarId nn `thenUgn` \ n ->
returnUgn (
- if isRdrLexConOrSpecial n
- then ConPatIn n []
- else VarPatIn n
+ case rdrNameOcc n of
+ VarOcc occ | isLexConId occ -> ConPatIn n []
+ other -> 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)
+ (\sty -> hsep (map (ppr sty) (lpat:lpats)))
+ msg = show (err (PprForUser opt_PprUserLength))
in
+#if __GLASGOW_HASKELL__ == 201
+ ioToUgnM (GHCbase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
+ ioToUgnM (GHCbase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
+#elif __GLASGOW_HASKELL__ >= 202
+ ioToUgnM (IOBase.ioToPrimIO (hPutStr stderr msg)) `thenUgn` \ _ ->
+ ioToUgnM (IOBase.ioToPrimIO (ghcExit 1)) `thenUgn` \ _ ->
+#else
ioToUgnM (hPutStr stderr msg) `thenUgn` \ _ ->
ioToUgnM (ghcExit 1) `thenUgn` \ _ ->
+#endif
returnUgn (error "ReadPrefix")
) `thenUgn` \ (n, arg_pats) ->
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 ->
returnUgn (TuplePatIn pats)
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
where
as_char s = _HEAD_ s
as_integer s = readInteger (_UNPK_ s)
+#if __GLASGOW_HASKELL__ == 201
+ as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std
+#elif __GLASGOW_HASKELL__ == 202
+ as_rational s = case readRational (_UNPK_ s) of { [(a,_)] -> a }
+#elif __GLASGOW_HASKELL__ >= 203
+ as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
+ -- to handle rationals with leading '-'
+#else
as_rational s = _readRational (_UNPK_ s) -- non-std
+#endif
as_string s = s
\end{code}
wlkTyConAndTyVars ttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl tcons `thenUgn` \ cons ->
wlkDerivings tderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyDecl (TyData ctxt tycon tyvars cons derivings noDataPragmas src_loc))
+ returnUgn (RdrTyDecl (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 ->
+ wlkList rdConDecl ntcon `thenUgn` \ cons ->
wlkDerivings ntderivs `thenUgn` \ derivings ->
- returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
+ returnUgn (RdrTyDecl (TyData NewType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
-- "type" declaration
U_nbind nbindid nbindas srcline ->
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))
U_ibind ibindc iclas ibindi ibindw srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkContext ibindc `thenUgn` \ ctxt ->
- wlkQid iclas `thenUgn` \ clas ->
- wlkMonoType ibindi `thenUgn` \ inst_ty ->
+ wlkTCId iclas `thenUgn` \ clas ->
+ wlkMonoType ibindi `thenUgn` \ at_ty ->
wlkBinding ibindw `thenUgn` \ binding ->
getSrcModUgn `thenUgn` \ modname ->
getSrcFileUgn `thenUgn` \ sf ->
let
- (ss, bs) = sepDeclsIntoSigsAndBinds binding
- binds = cvMonoBinds sf bs
- uprags = concat (map cvInstDeclSig ss)
- ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
- maybe_mod = if opt_CompilingPrelude
- then Nothing
- else Just modname
+ (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
+ inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
in
returnUgn (RdrInstDecl
- (InstDecl clas ctxt_inst_ty binds True maybe_mod uprags noInstancePragmas src_loc))
+ (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
-- "default" declaration
U_dbind dbindts srcline ->
wlkDerivings (U_nothing) = returnUgn Nothing
wlkDerivings (U_just pt)
= rdU_list pt `thenUgn` \ ds ->
- wlkList rdQid ds `thenUgn` \ derivs ->
+ wlkList rdTCId ds `thenUgn` \ derivs ->
returnUgn (Just derivs)
\end{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 ->
+ wlkList rdVarId sbindids `thenUgn` \ vars ->
+ wlkHsType sbindid `thenUgn` \ poly_ty ->
returnUgn (RdrTySig vars poly_ty src_loc)
-- value specialisation user-pragma
wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid uvar `thenUgn` \ var ->
+ wlkVarId 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 :: ParseTree -> UgnM (RdrNameHsType, 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 ->
+ wlkHsType vspec_ty `thenUgn` \ ty ->
+ wlkMaybe rdVarId 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 ->
+ wlkTCId iclas `thenUgn` \ clas ->
wlkMonoType ispec_ty `thenUgn` \ ty ->
returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
-- data specialisation user-pragma
wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid itycon `thenUgn` \ tycon ->
+ wlkTCId itycon `thenUgn` \ tycon ->
wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
- returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc))
+ returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
-- value inlining user-pragma
wlk_sig_thing (U_inline_uprag ivar srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ivar `thenUgn` \ var ->
+ wlkVarId 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 ->
+ wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
\end{code}
%************************************************************************
\begin{code}
-rdPolyType :: ParseTree -> UgnM RdrNamePolyType
-rdMonoType :: ParseTree -> UgnM RdrNameMonoType
+rdHsType :: ParseTree -> UgnM RdrNameHsType
+rdMonoType :: ParseTree -> UgnM RdrNameHsType
-rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
+rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
-wlkPolyType :: U_ttype -> UgnM RdrNamePolyType
-wlkMonoType :: U_ttype -> UgnM RdrNameMonoType
+wlkHsType :: U_ttype -> UgnM RdrNameHsType
+wlkMonoType :: U_ttype -> UgnM RdrNameHsType
-wlkPolyType ttype
+wlkHsType ttype
= case ttype of
U_context tcontextl tcontextt -> -- context
wlkContext tcontextl `thenUgn` \ ctxt ->
wlkMonoType ttype
= case ttype of
+ -- Glasgow extension: nested polymorhism
+ U_context tcontextl tcontextt -> -- context
+ wlkContext tcontextl `thenUgn` \ ctxt ->
+ wlkMonoType tcontextt `thenUgn` \ ty ->
+ returnUgn (HsPreForAllTy ctxt ty)
+
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 t1 `thenUgn` \ ty1 ->
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"
+ returnUgn (MonoTyApp ty1 ty2)
U_tllist tlist -> -- list type
wlkMonoType tlist `thenUgn` \ ty ->
- returnUgn (MonoListTy ty)
+ returnUgn (MonoListTy dummyRdrTcName ty)
U_ttuple ttuple ->
wlkList rdMonoType ttuple `thenUgn` \ tys ->
- returnUgn (MonoTupleTy tys)
+ returnUgn (MonoTupleTy dummyRdrTcName tys)
U_tfun tfun targ ->
wlkMonoType tfun `thenUgn` \ ty1 ->
\end{code}
\begin{code}
-wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [RdrName])
+wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
wlkContext :: U_list -> UgnM RdrNameContext
-wlkClassAssertTy :: U_ttype -> UgnM (RdrName, RdrName)
+wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
wlkTyConAndTyVars ttype
- = wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
+ = wlkMonoType 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)
in
- returnUgn (tycon, args)
+ returnUgn (split ty [])
wlkContext list
= wlkList rdMonoType list `thenUgn` \ tys ->
wlkClassAssertTy xs
= wlkMonoType xs `thenUgn` \ mono_ty ->
- returnUgn (mk_class_assertion mono_ty)
+ returnUgn (case mk_class_assertion mono_ty of
+ (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
+ )
-mk_class_assertion :: RdrNameMonoType -> (RdrName, RdrName)
+mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
-mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
+mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty)
mk_class_assertion other
- = pprError "ERROR: malformed type context: " (ppr PprForUser other)
+ = pprError "ERROR: malformed type context: " (ppr (PprForUser opt_PprUserLength) other)
-- regrettably, the parser does let some junk past
-- e.g., f :: Num {-nothing-} => a -> ...
\end{code}
wlkConDecl :: U_constr -> UgnM RdrNameConDecl
+wlkConDecl (U_constrcxt ccxt ccdecl)
+ = wlkContext ccxt `thenUgn` \ theta ->
+ wlkConDecl ccdecl `thenUgn` \ (ConDecl con _ details loc) ->
+ returnUgn (ConDecl con 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 ->
+ wlkDataId ccon `thenUgn` \ con ->
wlkMonoType cty `thenUgn` \ ty ->
- returnUgn (NewConDecl con ty src_loc)
+ returnUgn (ConDecl con [] (NewCon ty) 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)
+ 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 ->
+ wlkList rdVarId fvars `thenUgn` \ vars ->
wlkBangType fty `thenUgn` \ ty ->
returnUgn (vars, ty)
wlkBangType :: U_ttype -> UgnM (BangType RdrName)
wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
- returnUgn (Banged (HsPreForAllTy [] ty))
+ returnUgn (Banged ty)
wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
- returnUgn (Unbanged (HsPreForAllTy [] ty))
+ returnUgn (Unbanged ty)
\end{code}
%************************************************************************
mkSrcLocUgn srcline $ \ src_loc ->
wlkPat gpat `thenUgn` \ pat ->
wlkBinding gbind `thenUgn` \ binding ->
- wlkQid gsrcfun `thenUgn` \ srcfun ->
+ wlkVarId gsrcfun `thenUgn` \ srcfun ->
let
wlk_guards (U_pnoguards exp)
= wlkExpr exp `thenUgn` \ expr ->
where
rd_gd_expr pt
= rdU_pbinding pt `thenUgn` \ (U_pgdexp g e) ->
- wlkExpr g `thenUgn` \ guard ->
+ wlkQuals g `thenUgn` \ guard ->
wlkExpr e `thenUgn` \ expr ->
returnUgn (guard, expr)
\end{code}
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)
+ U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
+ returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
+ -- ToDo: add SrcLoc!
+ where
+ dir = case dir_n of
+ (-1) -> InfixL
+ 0 -> InfixN
+ 1 -> InfixR
_ -> error "ReadPrefix:rdFixOp"
\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 imod (cvFlag iqual) (cvIfaceFlavour isrc) maybe_as 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)
+
+cvIfaceFlavour 0 = HiFile -- No pragam
+cvIfaceFlavour 1 = HiBootFile -- {-# SOURCE #-}
\end{code}
\begin{code}
= 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 ->
+ wlkTCId x `thenUgn` \ thing ->
returnUgn (IEThingAbs thing)
U_enttypeall x -> -- non-abstract type constructor/class
- wlkQid x `thenUgn` \ thing ->
+ wlkTCId 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 ->
+ wlkTCId x `thenUgn` \ thing ->
+ wlkList rdVarId ns `thenUgn` \ names ->
returnUgn (IEThingWith thing names)
U_entmod mod -> -- everything provided unqualified by a module
projects / ghc-hetmet.git / blobdiff