gHC__, pRELUDE, pREL_BASE,
pREL_READ , pREL_NUM, pREL_LIST,
pREL_TUP , pACKED_STRING, cONC_BASE,
- iO_BASE , mONAD, rATIO, iX,
+ iO_BASE , eRROR, mONAD, rATIO, iX,
sT_BASE , aRR_BASE, fOREIGN, mAIN,
- gHC_MAIN , gHC_ERR
+ gHC_MAIN , gHC_ERR,
+ cCALL , aDDR
) where
CHK_Ubiq() -- debugging consistency check
pACKED_STRING= SLIT("PackBase")
cONC_BASE = SLIT("ConcBase")
iO_BASE = SLIT("IOBase")
+eRROR = SLIT("Error")
mONAD = SLIT("Monad")
rATIO = SLIT("Ratio")
iX = SLIT("Ix")
sT_BASE = SLIT("STBase")
aRR_BASE = SLIT("ArrBase")
fOREIGN = SLIT("Foreign")
+cCALL = SLIT("CCall")
+aDDR = SLIT("Addr")
mAIN = SLIT("Main")
gHC_MAIN = SLIT("GHCmain")
-- these "bottom" out, no matter what their arguments
eRROR_ID
- = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy
+ = pc_bottoming_Id errorIdKey eRROR SLIT("error") errorTy
generic_ERROR_ID u n
= pc_bottoming_Id u gHC_ERR n errorTy
%************************************************************************
\begin{code}
-primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld#
- = PrimResult SLIT("errorIO#") []
- [primio_ish_ty unitTy]
+-- errorIO# :: (State# RealWorld# -> a) -> State# RealWorld#
+primOpInfo ErrorIOPrimOp
+ = PrimResult SLIT("errorIO#") [alphaTyVar]
+ [mkFunTy realWorldStatePrimTy alphaTy]
statePrimTyCon VoidRep [realWorldTy]
- where
- primio_ish_ty result
- = mkFunTy (mkStatePrimTy realWorldTy) (mkSTretTy realWorldTy result)
\end{code}
%************************************************************************
liftTyCon,
listTyCon,
foreignObjTyCon,
+
mkLiftTy,
mkListTy,
- mkPrimIoTy,
- mkStateTy,
- mkStateTransformerTy,
- tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon,
mkTupleTy,
+ tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon,
nilDataCon,
- primIoTyCon,
realWorldStateTy,
return2GMPsTyCon,
returnIntAndGMPTyCon,
+
+ -- ST and STret types
+ mkStateTy,
+ mkStateTransformerTy,
+ mkSTretTy,
stTyCon,
stDataCon,
- stablePtrTyCon,
+ stRetDataCon,
+ stRetTyCon,
+
+ -- CCall result types
stateAndAddrPrimTyCon,
stateAndArrayPrimTyCon,
stateAndByteArrayPrimTyCon,
stateAndWordPrimTyCon,
stateDataCon,
stateTyCon,
- stRetDataCon,
- stRetTyCon,
- mkSTretTy,
+
+ stablePtrTyCon,
stringTy,
trueDataCon,
unitTy,
\begin{code}
addrTy = mkTyConTy addrTyCon
-addrTyCon = pcDataTyCon addrTyConKey fOREIGN SLIT("Addr") [] [addrDataCon]
-addrDataCon = pcDataCon addrDataConKey fOREIGN SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
+addrTyCon = pcDataTyCon addrTyConKey aDDR SLIT("Addr") [] [addrDataCon]
+addrDataCon = pcDataCon addrDataConKey aDDR SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
\end{code}
\begin{code}
\end{code}
\begin{code}
-mkSTretTy alpha beta = applyTyCon stRetTyCon [alpha,beta]
-
-stRetTyCon
- = pcDataTyCon stRetTyConKey sT_BASE SLIT("STret")
- alpha_beta_tyvars [stRetDataCon]
-stRetDataCon
- = pcDataCon stRetDataConKey sT_BASE SLIT("STret")
- alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy]
- stRetTyCon nullSpecEnv
-\end{code}
-
-\begin{code}
stablePtrTyCon
= pcDataTyCon stablePtrTyConKey fOREIGN SLIT("StablePtr")
alpha_tyvar [stablePtrDataCon]
%* *
%************************************************************************
-This is really just an ordinary synonym, except it is ABSTRACT.
+The only reason this is wired in is because we have to represent the
+type of runST.
\begin{code}
mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
where
ty = mkFunTy (mkStatePrimTy alphaTy) (mkSTretTy alphaTy betaTy)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TysWiredIn-IO]{The @PrimIO@ monadic-I/O type}
-%* *
-%************************************************************************
-\begin{code}
-mkPrimIoTy a = mkStateTransformerTy realWorldTy a
+mkSTretTy alpha beta = applyTyCon stRetTyCon [alpha,beta]
-primIoTyCon
- = pcSynTyCon
- primIoTyConKey sT_BASE SLIT("PrimIO")
- (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
- 1 alpha_tyvar (mkPrimIoTy alphaTy)
+stRetTyCon
+ = pcDataTyCon stRetTyConKey sT_BASE SLIT("STret")
+ alpha_beta_tyvars [stRetDataCon]
+stRetDataCon
+ = pcDataCon stRetDataConKey sT_BASE SLIT("STret")
+ alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy]
+ stRetTyCon nullSpecEnv
\end{code}
%************************************************************************
nameModule, pprModule, pprOccName, nameOccName
)
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon )
-import PrelInfo ( ioTyCon_NAME, primIoTyCon_NAME )
import TyCon ( TyCon )
import PrelMods ( mAIN, gHC_MAIN )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), pprBagOfErrors,
\begin{code}
addImplicits mod_name
- = addImplicitOccsRn (implicit_main ++ default_tys)
+ = addImplicitOccsRn default_tys
where
-- Add occurrences for Int, Double, and (), because they
-- are the types to which ambigious type variables may be defaulted by
-- the type checker; so they won't every appear explicitly.
-- [The () one is a GHC extension for defaulting CCall results.]
- default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon]
-
- -- Add occurrences for IO or PrimIO
- implicit_main | mod_name == mAIN = [ioTyCon_NAME]
- | mod_name == gHC_MAIN = [primIoTyCon_NAME]
- | otherwise = []
+ default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon ]
\end{code}
import RnEnv
import CmdLineOpts ( opt_GlasgowExts )
import BasicTypes ( Fixity(..), FixityDirection(..) )
-import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
- creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
- ratioDataCon_RDR, negate_RDR
+import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
+ ccallableClass_RDR, creturnableClass_RDR,
+ monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
+ ratioDataCon_RDR, negate_RDR,
+ ioDataCon_RDR, ioOkDataCon_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
rnExpr (CCall fun args may_gc is_casm fake_result_ty)
= lookupImplicitOccRn ccallableClass_RDR `thenRn_`
lookupImplicitOccRn creturnableClass_RDR `thenRn_`
+ lookupImplicitOccRn ioDataCon_RDR `thenRn_`
+ lookupImplicitOccRn ioOkDataCon_RDR `thenRn_`
rnExprs args `thenRn` \ (args', fvs_args) ->
returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
import TcBinds ( tcBindsAndThen, checkSigTyVars )
import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
- tcExtendGlobalTyVars, tcLookupGlobalValueMaybe
+ tcExtendGlobalTyVars, tcLookupGlobalValueMaybe,
+ tcLookupTyCon
)
import SpecEnv ( SpecEnv )
import TcMatches ( tcMatchesCase, tcMatchExpected )
getAppDataTyCon, maybeAppDataTyCon
)
import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, elementOfTyVarSet, mkTyVarSet )
+import TyCon ( tyConDataCons )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
floatPrimTy, addrPrimTy, realWorldTy
)
-import TysWiredIn ( addrTy,
- boolTy, charTy, stringTy, mkListTy,
- mkTupleTy, mkPrimIoTy, stDataCon
+import TysWiredIn ( addrTy, mkTupleTy,
+ boolTy, charTy, stringTy, mkListTy
)
+import PrelInfo ( ioTyCon_NAME )
import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists,
unifyFunTy, unifyListTy, unifyTupleTy
)
= -- Get the callable and returnable classes.
tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
+ tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) ->
let
new_arg_dict (arg, arg_ty)
tcExprs args ty_vars `thenTc` \ (args', args_lie) ->
-- The argument types can be unboxed or boxed; the result
- -- type must, however, be boxed since it's an argument to the PrimIO
+ -- type must, however, be boxed since it's an argument to the IO
-- type constructor.
newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ result_ty ->
- unifyTauTy (mkPrimIoTy result_ty) res_ty `thenTc_`
+ let
+ io_result_ty = applyTyCon ioTyCon [result_ty]
+ in
+ case tyConDataCons ioTyCon of { [ioDataCon] ->
+ unifyTauTy io_result_ty res_ty `thenTc_`
-- Construct the extra insts, which encode the
-- constraints on the argument and result types.
- mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s ->
- newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) ->
+ mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars)
+ `thenNF_Tc` \ ccarg_dicts_s ->
+ newDicts result_origin [(cReturnableClass, result_ty)]
+ `thenNF_Tc` \ (ccres_dict, _) ->
- returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty])
- (CCall lbl args' may_gc is_asm result_ty),
+ returnTc (HsApp (HsVar (RealId ioDataCon) `TyApp` [result_ty])
+ (CCall lbl args' may_gc is_asm io_result_ty),
-- do the wrapping in the newtype constructor here
foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
+ }
\end{code}
\begin{code}
import PprType ( GenType, GenTyVar )
import TysWiredIn ( unitTy )
import PrelMods ( gHC_MAIN, mAIN )
-import PrelInfo ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME )
+import PrelInfo ( main_NAME, ioTyCon_NAME )
import TyVar ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv )
import Unify ( unifyTauTy )
import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
\begin{code}
tcCheckMainSig mod_name
- | not is_main && not is_ghc_main
+ | mod_name /= mAIN
= returnTc () -- A non-main module
| otherwise
= -- Check that main is defined
- tcLookupTyCon tycon_name `thenTc` \ (_,_,tycon) ->
- tcLookupLocalValue main_name `thenNF_Tc` \ maybe_main_id ->
+ tcLookupTyCon ioTyCon_NAME `thenTc` \ (_,_,ioTyCon) ->
+ tcLookupLocalValue main_NAME `thenNF_Tc` \ maybe_main_id ->
case maybe_main_id of {
- Nothing -> failTc (noMainErr mod_name main_name);
+ Nothing -> failTc noMainErr;
Just main_id ->
-- Check that it has the right type (or a more general one)
- let
- expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy]
- | otherwise = applyTyCon tycon [unitTy]
- -- This is bizarre. There ought to be a suitable function in Type.lhs!
- in
- tcInstType [] expected_ty `thenNF_Tc` \ expected_tau ->
- tcId main_name `thenNF_Tc` \ (_, lie, main_tau) ->
- tcSetErrCtxt (mainTyCheckCtxt main_name) $
+ let expected_ty = applyTyCon ioTyCon [unitTy] in
+ tcInstType [] expected_ty `thenNF_Tc` \ expected_tau ->
+ tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) ->
+ tcSetErrCtxt mainTyCheckCtxt $
unifyTauTy expected_tau
- main_tau `thenTc_`
- checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id))
+ main_tau `thenTc_`
+ checkTc (isEmptyBag lie) (mainTyMisMatch expected_ty (idType main_id))
}
- where
- is_main = mod_name == mAIN
- is_ghc_main = mod_name == gHC_MAIN
-
- main_name | is_main = main_NAME
- | otherwise = mainPrimIO_NAME
-
- tycon_name | is_main = ioTyCon_NAME
- | otherwise = primIoTyCon_NAME
-mainTyCheckCtxt main_name sty
- = hsep [ptext SLIT("When checking that"), ppr sty main_name, ptext SLIT("has the required type")]
+mainTyCheckCtxt sty
+ = hsep [ptext SLIT("When checking that"), ppr sty main_NAME,
+ ptext SLIT("has the required type")]
-noMainErr mod_name main_name sty
- = hsep [ptext SLIT("Module"), pprModule sty mod_name,
- ptext SLIT("must include a definition for"), ppr sty main_name]
+noMainErr sty
+ = hsep [ptext SLIT("Module"), pprModule sty mAIN,
+ ptext SLIT("must include a definition for"), ppr sty main_NAME]
-mainTyMisMatch :: Name -> Type -> TcType s -> Error
-mainTyMisMatch main_name expected actual sty
- = hang (hsep [ppr sty main_name, ptext SLIT("has the wrong type")])
+mainTyMisMatch :: Type -> TcType s -> Error
+mainTyMisMatch expected actual sty
+ = hang (hsep [ppr sty main_NAME, ptext SLIT("has the wrong type")])
4 (vcat [
hsep [ptext SLIT("Expected:"), ppr sty expected],
hsep [ptext SLIT("Inferred:"), ppr sty actual]
projects / ghc-hetmet.git / commitdiff