\section{Read parse tree built by Yacc parser}
\begin{code}
-#include "HsVersions.h"
-
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
+#include "HsVersions.h"
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
import HsTypes ( HsTyVar(..) )
import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
import RdrHsSyn
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) )
import PrefixToHs
+import CallConv
-import CmdLineOpts ( opt_PprUserLength )
-import ErrUtils ( addErrLoc, ghcExit )
+import CmdLineOpts ( opt_NoImplicitPrelude )
import FiniteMap ( elemFM, FiniteMap )
-import Name ( OccName(..), SYN_IE(Module) )
+import Name ( OccName(..), Module )
import Lex ( isLexConId )
-import Outputable ( Outputable(..), PprStyle(..) )
-import PrelMods
-import Pretty
-import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
-import Util ( nOfThem, pprError, panic )
+import Outputable
+import PrelMods ( pRELUDE )
+import Util ( nOfThem )
+import FastString ( mkFastCharString )
+import IO ( hPutStr, stderr )
+import PrelRead ( readRational__ )
\end{code}
%************************************************************************
else VarOcc occ)
wlkQid :: (FAST_STRING -> OccName) -> 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_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))
-
- -- I don't understand this one! It is what shows up when we meet (), [], or (,,,).
+ = returnUgn (Qual mod (mk_occ_name name) HiFile)
wlkQid mk_occ_name (U_gid n name)
- = returnUgn (Unqual (mk_occ_name name))
+ | opt_NoImplicitPrelude
+ = returnUgn (Unqual (mk_occ_name name))
+ | otherwise
+ = 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
%************************************************************************
\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 `CCALL_THEN` \ pt -> -- call the Yacc parser!
+ = _ccall_ hspmain >>= \ pt -> -- call the Yacc parser!
let
- srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM)
+ srcfile = mkFastCharString ``input_filename'' -- What A Great Hack! (TM)
in
initUgn $
rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist
let
val_decl = ValD (cvBinds srcfile cvValSig binding)
+ for_decls = cvForeignDecls binding
other_decls = cvOtherDecls binding
in
returnUgn (modname,
exports
imports
fixities
- (val_decl: other_decls)
+ (for_decls ++ val_decl: other_decls)
src_loc
)
\end{code}
returnUgn (
HsLam (foldr PatMatch
(GRHSMatch (GRHSsAndBindsIn
- [OtherwiseGRHS body src_loc]
+ (unguardedRHS body src_loc)
EmptyBinds))
pats)
)
U_record con rbinds -> -- record construction
wlkDataId con `thenUgn` \ rcon ->
wlkList rdRbind rbinds `thenUgn` \ recbinds ->
- returnUgn (RecordCon (HsVar rcon) recbinds)
+ returnUgn (RecordCon rcon (HsVar rcon) recbinds)
U_rupdate updexp updbinds -> -- record update
wlkExpr updexp `thenUgn` \ aexp ->
U_dobind _ _ _ -> error "U_dobind"
U_doexp _ _ -> error "U_doexp"
U_rbind _ _ -> error "U_rbind"
- U_fixop _ _ _ -> error "U_fixop"
+ U_fixop _ _ _ _ -> error "U_fixop"
#endif
rdRbind pt
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
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 -> 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")
+ pprPanic "Illegal pattern `application'"
+ (ppr loc <> colon <+> hsep (map ppr (lpat:lpats)))
) `thenUgn` \ (n, arg_pats) ->
returnUgn (ConPatIn n arg_pats)
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 } -- ToDo, use non-std readRational__
-#else
- as_rational s = _readRational (_UNPK_ s) -- non-std
-#endif
+ as_rational s = readRational__ (_UNPK_ s) -- use non-std readRational__
+ -- to handle rationals with leading '-'
as_string s = s
\end{code}
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 DataType ctxt tycon tyvars cons derivings noDataPragmas src_loc))
U_ntbind ntctxt nttype ntcon ntderivs srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkContext ntctxt `thenUgn` \ ctxt ->
- wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
+ wlkConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
wlkList rdConDecl ntcon `thenUgn` \ cons ->
wlkDerivings ntderivs `thenUgn` \ derivings ->
returnUgn (RdrTyDecl (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) ->
+ wlkConAndTyVars nbindid `thenUgn` \ (tycon, tyvars) ->
wlkMonoType nbindas `thenUgn` \ expansion ->
returnUgn (RdrTyDecl (TySynonym tycon tyvars expansion 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
(final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
in
returnUgn (RdrClassDecl
- (ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
+ (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 ->
- wlkTCId iclas `thenUgn` \ clas ->
- wlkMonoType ibindi `thenUgn` \ at_ty ->
- wlkBinding ibindw `thenUgn` \ binding ->
- getSrcModUgn `thenUgn` \ modname ->
- getSrcFileUgn `thenUgn` \ sf ->
+ wlkInstType ty `thenUgn` \ inst_ty ->
+ wlkBinding ibindw `thenUgn` \ binding ->
+ getSrcModUgn `thenUgn` \ modname ->
+ getSrcFileUgn `thenUgn` \ sf ->
let
(binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
- inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
in
returnUgn (RdrInstDecl
(InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
wlkList rdMonoType dbindts `thenUgn` \ tys ->
returnUgn (RdrDefaultDecl (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 ->
+ wlkHsType ty `thenUgn` \ h_ty ->
+ wlkExtName ext_name `thenUgn` \ h_ext_name ->
+ rdCallConv cconv `thenUgn` \ h_cconv ->
+ rdImpExp imp_exp (cvFlag unsafe_flag) `thenUgn` \ h_imp_exp ->
+ returnUgn (RdrForeignDecl (ForeignDecl h_id h_imp_exp h_ty h_ext_name h_cconv src_loc))
+
a_sig_we_hope ->
-- signature(-like) things, including user pragmas
wlk_sig_thing a_sig_we_hope
= mkSrcLocUgn srcline $ \ src_loc ->
wlkList rdVarId sbindids `thenUgn` \ vars ->
wlkHsType sbindid `thenUgn` \ poly_ty ->
- returnUgn (RdrTySig vars poly_ty src_loc)
+ returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
-- value specialisation user-pragma
wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
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 ])
+ returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
+ | (ty, using_id) <- tys_and_ids ])
where
rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
rd_ty_and_id pt
-- instance specialisation user-pragma
wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- 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 ->
- wlkTCId itycon `thenUgn` \ tycon ->
- wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
- returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkHsType ispec_ty `thenUgn` \ ty ->
+ returnUgn (RdrSig (SpecInstSig ty src_loc))
-- value inlining user-pragma
wlk_sig_thing (U_inline_uprag ivar srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId ivar `thenUgn` \ var ->
- returnUgn (RdrInlineValSig (InlineSig var src_loc))
+ returnUgn (RdrSig (InlineSig var src_loc))
- -- "deforest me" user-pragma
-wlk_sig_thing (U_deforest_uprag ivar srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId 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 ->
+wlk_sig_thing (U_noinline_uprag ivar srcline)
+ = mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId ivar `thenUgn` \ var ->
- returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
+ returnUgn (RdrSig (NoInlineSig var src_loc))
\end{code}
%************************************************************************
wlkMonoType targ `thenUgn` \ ty2 ->
returnUgn (MonoFunTy ty1 ty2)
+wlkInstType ttype
+ = case ttype of
+ U_context tcontextl tcontextt -> -- context
+ wlkContext tcontextl `thenUgn` \ ctxt ->
+ wlkConAndTys tcontextt `thenUgn` \ (clas, tys) ->
+ returnUgn (HsPreForAllTy ctxt (MonoDictTy clas tys))
+
+ other -> -- something else
+ wlkConAndTys other `thenUgn` \ (clas, tys) ->
+ returnUgn (HsPreForAllTy [{-no context-}] (MonoDictTy clas tys))
\end{code}
\begin{code}
-wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
-wlkContext :: U_list -> UgnM RdrNameContext
-wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
-
-wlkTyConAndTyVars ttype
+wlkConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
+wlkConAndTyVars ttype
= wlkMonoType ttype `thenUgn` \ ty ->
let
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 (split ty [])
-wlkContext list
- = wlkList rdMonoType list `thenUgn` \ tys ->
- returnUgn (map mk_class_assertion tys)
-wlkClassAssertTy xs
- = wlkMonoType xs `thenUgn` \ mono_ty ->
- returnUgn (case mk_class_assertion mono_ty of
- (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
- )
+wlkContext :: U_list -> UgnM RdrNameContext
+rdConAndTys :: ParseTree -> UgnM (RdrName, [HsType RdrName])
+
+wlkContext list = wlkList rdConAndTys list
-mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
+rdConAndTys pt
+ = rdU_ttype pt `thenUgn` \ ttype ->
+ wlkConAndTys ttype
-mk_class_assertion (MonoTyApp (MonoTyVar name) ty@(MonoTyVar tyname)) = (name, ty)
-mk_class_assertion 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 -> ...
+wlkConAndTys ttype
+ = wlkMonoType ttype `thenUgn` \ ty ->
+ let
+ split (MonoTyApp fun ty) tys = split fun (ty : tys)
+ split (MonoTyVar tycon) tys = (tycon, tys)
+ split other tys = pprPanic "ERROR: malformed type: "
+ (ppr other)
+ in
+ returnUgn (split ty [])
\end{code}
\begin{code}
rdFixOp pt
= rdU_tree pt `thenUgn` \ fix ->
case fix of
- U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
- returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
- -- ToDo: add SrcLoc!
+ U_fixop op dir_n prec srcline -> wlkVarId op `thenUgn` \ op ->
+ mkSrcLocUgn srcline $ \ src_loc ->
+ returnUgn (FixityDecl op (Fixity prec dir) src_loc)
where
dir = case dir_n of
(-1) -> InfixL
-> 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}
returnUgn (IEModuleContents 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 = returnUgn x
+
+rdForKind :: Int -> Bool -> UgnM ForKind
+rdForKind 0 isUnsafe = -- foreign import
+ returnUgn (FoImport isUnsafe)
+rdImpExp 1 _ = -- foreign export
+ returnUgn FoExport
+rdImpExp 2 _ = -- foreign label
+ returnUgn FoLabel
+\end{code}
projects / ghc-hetmet.git / blobdiff