A big improvement to the way command-line expressions are typechecked.
Now we don't wrap in "print" and hope for the best (the wrong "print"
might be in scope). Instead we work on the renamed epxression and
do the Right Thing by using the correct "print".
Also do generalisation, so that we get the right type back from
the :t command.
WARNING: it's possible that these files overlap with my fortcoming
Big Commit of typechecker stuff, so you may need to hang on for
a few mins.
#ifdef GHCI
cmGetExpr :: CmState
-> DynFlags
+ -> Bool -- True <=> wrap in 'print' to get an IO-typed result
-> Module
-> String
- -> Bool
-> IO (CmState, Maybe (HValue, PrintUnqualified, Type))
-cmGetExpr cmstate dflags mod expr wrap_print
+cmGetExpr cmstate dflags wrap_io mod expr
= do (new_pcs, maybe_stuff) <-
- hscExpr dflags hst hit pcs mod expr wrap_print
+ hscExpr dflags wrap_io hst hit pcs mod expr
case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
Just (bcos, print_unqual, ty) -> do
#ifdef GHCI
hscExpr
:: DynFlags
+ -> Bool -- True <=> wrap in 'print' to get a result of IO type
-> HomeSymbolTable
-> HomeIfaceTable
-> PersistentCompilerState -- IN: persistent compiler state
-> Module -- Context for compiling
-> String -- The expression
- -> Bool -- Should we wrap print if not IO-typed?
-> IO ( PersistentCompilerState,
Maybe (UnlinkedBCOExpr, PrintUnqualified, Type) )
-hscExpr dflags hst hit pcs0 this_module expr wrap_print
+hscExpr dflags wrap_io hst hit pcs0 this_module expr
= do {
maybe_parsed <- hscParseExpr dflags expr;
case maybe_parsed of
-- Typecheck it
maybe_tc_return
- <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr;
+ <- typecheckExpr dflags wrap_io pcs1 hst print_unqual this_module rn_expr;
case maybe_tc_return of {
Nothing -> return ({-WAS:pcs1-} pcs0, Nothing);
Just (pcs2, tc_expr, ty) -> do
- -- if it isn't an IO-typed expression,
- -- wrap "print" around it & recompile...
- let { is_IO_type = case splitTyConApp_maybe ty of {
- Just (tycon, _) -> getUnique tycon == ioTyConKey;
- Nothing -> False }
- };
-
- if (wrap_print && not is_IO_type)
- then do (new_pcs, maybe_stuff)
- <- hscExpr dflags hst hit pcs2 this_module
- ("PrelIO.print (" ++ expr ++ ")") False
- case maybe_stuff of
- Nothing -> return (new_pcs, maybe_stuff)
- Just (bcos, _, _) ->
- return (new_pcs, Just (bcos, print_unqual, ty))
- else do
-
-- Desugar it
ds_expr <- deSugarExpr dflags pcs2 hst this_module
print_unqual tc_expr;
timesIntegerName,
eqStringName,
assertName,
- runSTRepName
+ runSTRepName,
+ printName
]
\end{code}
pREL_PACK_Name = mkModuleName "PrelPack"
pREL_CONC_Name = mkModuleName "PrelConc"
pREL_IO_BASE_Name = mkModuleName "PrelIOBase"
+pREL_IO_Name = mkModuleName "PrelIO"
pREL_ST_Name = mkModuleName "PrelST"
pREL_ARR_Name = mkModuleName "PrelArr"
pREL_BYTEARR_Name = mkModuleName "PrelByteArr"
bindIOName = varQual pREL_IO_BASE_Name SLIT("bindIO") bindIOIdKey
returnIOName = varQual pREL_IO_BASE_Name SLIT("returnIO") returnIOIdKey
+-- IO things
+printName = varQual pREL_IO_Name SLIT("print") printIdKey
+
-- Int, Word, and Addr things
int8TyConName = tcQual pREL_INT_Name SLIT("Int8") int8TyConKey
int16TyConName = tcQual pREL_INT_Name SLIT("Int16") int16TyConKey
getTagIdKey = mkPreludeMiscIdUnique 40
plusIntegerIdKey = mkPreludeMiscIdUnique 41
timesIntegerIdKey = mkPreludeMiscIdUnique 42
+printIdKey = mkPreludeMiscIdUnique 43
\end{code}
Certain class operations from Prelude classes. They get their own
nameIsLocalOrFrom, nameOccName, nameModule,
)
import Name ( mkNameEnv, nameEnvElts, extendNameEnv )
-import RdrName ( elemRdrEnv, foldRdrEnv, isQual )
+import RdrName ( foldRdrEnv, isQual )
import OccName ( occNameFlavour )
import NameSet
import TysWiredIn ( unitTyCon, intTyCon, boolTyCon )
import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
- ioTyCon_RDR, main_RDR_Unqual,
- unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR,
- eqString_RDR
+ ioTyConName, printName,
+ unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
+ eqStringName
)
import PrelInfo ( derivingOccurrences )
import Type ( funTyCon )
import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM,
addToFM_C, elemFM, addToFM
)
-import UniqFM ( lookupUFM )
+import UniqFM ( lookupWithDefaultUFM )
import Maybes ( maybeToBool, catMaybes )
import Outputable
import IO ( openFile, IOMode(..) )
returnRn Nothing
else
- lookupOrigNames implicit_occs `thenRn` \ implicit_names ->
- slurpImpDecls (fvs `plusFV` implicit_names) `thenRn` \ decls ->
+ let
+ implicit_fvs = fvs `plusFV` string_names
+ `plusFV` default_tycon_names
+ `plusFV` unitFV printName
+ -- print :: a -> IO () may be needed later
+ in
+ slurpImpDecls (fvs `plusFV` implicit_fvs) `thenRn` \ decls ->
doDump e decls `thenRn_`
returnRn (Just (print_unqual, (e, decls)))
}}
where
- implicit_occs = string_occs
doc = text "context for compiling expression"
doDump :: RenamedHsExpr -> [RenamedHsDecl] -> RnMG (Either IOError ())
-- RENAME THE SOURCE
rnSourceDecls gbl_env local_fixity_env local_decls `thenRn` \ (rn_local_decls, source_fvs) ->
- -- CHECK THAT main IS DEFINED, IF REQUIRED
- checkMain this_module local_gbl_env `thenRn_`
-
-- EXIT IF ERRORS FOUND
-- We exit here if there are any errors in the source, *before*
-- we attempt to slurp the decls from the interfaces, otherwise
mod_name = moduleName this_module
\end{code}
-Checking that main is defined
-
-\begin{code}
-checkMain :: Module -> GlobalRdrEnv -> RnMG ()
-checkMain this_mod local_env
- | moduleName this_mod == mAIN_Name
- = checkRn (main_RDR_Unqual `elemRdrEnv` local_env) noMainErr
- | otherwise
- = returnRn ()
-\end{code}
-
@implicitFVs@ forces the renamer to slurp in some things which aren't
mentioned explicitly, but which might be needed by the type checker.
\begin{code}
implicitFVs mod_name decls
- = lookupOrigNames implicit_occs `thenRn` \ implicit_names ->
- returnRn (mkNameSet (map getName default_tycons) `plusFV`
- implicit_names)
+ = lookupOrigNames deriv_occs `thenRn` \ deriving_names ->
+ returnRn (default_tycon_names `plusFV`
+ string_names `plusFV`
+ deriving_names `plusFV`
+ implicit_main)
where
- -- Add occurrences for Int, and (), because they
- -- are the types to which ambigious type variables may be defaulted by
- -- the type checker; so they won't always appear explicitly.
- -- [The () one is a GHC extension for defaulting CCall results.]
- -- ALSO: funTyCon, since it occurs implicitly everywhere!
- -- (we don't want to be bothered with making funTyCon a
- -- free var at every function application!)
- -- Double is dealt with separately in getGates
- default_tycons = [unitTyCon, funTyCon, boolTyCon, intTyCon]
-- Add occurrences for IO or PrimIO
implicit_main | mod_name == mAIN_Name
- || mod_name == pREL_MAIN_Name = [ioTyCon_RDR]
- | otherwise = []
+ || mod_name == pREL_MAIN_Name = unitFV ioTyConName
+ | otherwise = emptyFVs
- -- Now add extra "occurrences" for things that
- -- the deriving mechanism, or defaulting, will later need in order to
- -- generate code
- implicit_occs = string_occs ++ foldr ((++) . get) implicit_main decls
-
-
- get (TyClD (TyData {tcdDerivs = Just deriv_classes})) = concat (map get_deriv deriv_classes)
- get other = []
-
- get_deriv cls = case lookupUFM derivingOccurrences cls of
- Nothing -> []
- Just occs -> occs
+ deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls,
+ cls <- deriv_classes,
+ occ <- lookupWithDefaultUFM derivingOccurrences [] cls ]
-- Virtually every program has error messages in it somewhere
-string_occs = [unpackCString_RDR, unpackCStringFoldr_RDR,
- unpackCStringUtf8_RDR, eqString_RDR]
+string_names = mkFVs [unpackCStringName, unpackCStringFoldrName,
+ unpackCStringUtf8Name, eqStringName]
+
+-- Add occurrences for Int, and (), because they
+-- are the types to which ambigious type variables may be defaulted by
+-- the type checker; so they won't always appear explicitly.
+-- [The () one is a GHC extension for defaulting CCall results.]
+-- ALSO: funTyCon, since it occurs implicitly everywhere!
+-- (we don't want to be bothered with making funTyCon a
+-- free var at every function application!)
+-- Double is dealt with separately in getGates
+default_tycon_names = mkFVs (map getName [unitTyCon, funTyCon, boolTyCon, intTyCon])
\end{code}
\begin{code}
local_names = foldl add emptyNameSet tycl_decls
add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl))
in
- -- Record that we have now got declarations for local_names
+
recordLocalSlurps local_names `thenRn_`
-- Do the transitive closure
- lookupOrigNames implicit_occs `thenRn` \ implicit_names ->
- closeDecls decls (needed `plusFV` implicit_names) `thenRn` \closed_decls ->
+ closeDecls decls (needed `plusFV` implicit_fvs) `thenRn` \closed_decls ->
rnDump [] closed_decls `thenRn_`
returnRn closed_decls
where
- implicit_occs = string_occs -- Data type decls with record selectors,
+ implicit_fvs = string_names -- Data type decls with record selectors,
-- which may appear in the decls, need unpackCString
-- and friends. It's easier to just grab them right now.
\end{code}
badDeprec d
= sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
nest 4 (ppr d)]
-
-noMainErr
- = hsep [ptext SLIT("Module"), quotes (ppr mAIN_Name),
- ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
\end{code}
#include "HsVersions.h"
import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
-import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..),
+import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
isIfaceRuleDecl, nullBinds, andMonoBindList
)
import HsTypes ( toHsType )
+import PrelNames ( mAIN_Name, mainName, ioTyConName, printName )
import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
TypecheckedForeignDecl, TypecheckedRuleDecl,
import TcMonad
-import TcType ( newTyVarTy, zonkTcType )
+import TcType ( newTyVarTy, zonkTcType, tcInstType )
+import TcUnify ( unifyTauTy )
import Inst ( plusLIE )
+import VarSet ( varSetElems )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults, defaultDefaultTys )
import TcExpr ( tcMonoExpr )
-import TcEnv ( TcEnv, InstInfo, tcExtendGlobalValEnv,
- isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
+import TcEnv ( TcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe,
+ isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
+ TcTyThing(..), tcLookupTyCon
)
import TcRules ( tcIfaceRules, tcSourceRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcSimplify ( tcSimplifyTop )
+import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
import TcTyClsDecls ( tcTyAndClassDecls )
import CoreUnfold ( unfoldingTemplate, hasUnfolding )
-import Type ( funResultTy, splitForAllTys, openTypeKind )
+import Type ( funResultTy, splitForAllTys, mkForAllTys, mkFunTys,
+ liftedTypeKind, openTypeKind, mkTyConApp, tyVarsOfType, tidyType )
import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass )
import Id ( idType, idName, isLocalId, idUnfolding )
-import Module ( Module, isHomeModule )
+import Module ( Module, isHomeModule, moduleName )
import Name ( Name, toRdrName, isGlobalName )
import Name ( nameEnvElts, lookupNameEnv )
import TyCon ( tyConGenInfo )
---------------
typecheckExpr :: DynFlags
+ -> Bool -- True <=> wrap in 'print' to get a result of IO type
-> PersistentCompilerState
-> HomeSymbolTable
-> PrintUnqualified -- For error printing
[RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
-> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
-typecheckExpr dflags pcs hst unqual this_mod (expr, decls)
+typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls)
= typecheck dflags pcs hst unqual $
-- use the default default settings, i.e. [Integer, Double]
ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
tcSetEnv env $
- newTyVarTy openTypeKind `thenTc` \ ty ->
- tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
- tcSimplifyTop lie `thenTc` \ binds ->
- let all_expr = mkHsLet binds expr' in
- zonkExpr all_expr `thenNF_Tc` \ zonked_expr ->
- zonkTcType ty `thenNF_Tc` \ zonked_ty ->
+ tc_expr expr `thenTc` \ (expr', lie, expr_ty) ->
+ tcSimplifyInfer smpl_doc
+ (varSetElems (tyVarsOfType expr_ty)) lie `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
+ tcSimplifyTop lie_free `thenTc` \ const_binds ->
+ let all_expr = mkHsLet const_binds $
+ TyLam qtvs $
+ DictLam dict_ids $
+ mkHsLet dict_binds $
+ expr'
+ all_expr_ty = mkForAllTys qtvs (mkFunTys (map idType dict_ids) expr_ty)
+ in
+ zonkExpr all_expr `thenNF_Tc` \ zonked_expr ->
+ zonkTcType all_expr_ty `thenNF_Tc` \ zonked_ty ->
ioToTc (dumpIfSet_dyn dflags
Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
returnTc (new_pcs, zonked_expr, zonked_ty)
+
where
get_fixity :: Name -> Maybe Fixity
get_fixity n = pprPanic "typecheckExpr" (ppr n)
+ smpl_doc = ptext SLIT("main expression")
+
+ -- Typecheck it, wrapping in 'print' if necessary to
+ -- get a result of type IO t. Returns the result type
+ -- that is free in the result type
+ tc_expr e
+ | wrap_io = tryTc_ (tc_io_expr (HsApp (HsVar printName) e)) -- Recovery case
+ (tc_io_expr e) -- Main case
+ | otherwise = newTyVarTy openTypeKind `thenTc` \ ty ->
+ tcMonoExpr expr ty `thenTc` \ (expr', lie) ->
+ returnTc (expr', lie, ty)
+
+ where
+ -- (tc_io_expr e) typechecks 'e' if that gives a result of IO t,
+ -- or 'print e' otherwise. Either way the result is of type IO t
+ tc_io_expr e = newTyVarTy openTypeKind `thenTc` \ ty ->
+ tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
+ let
+ res_ty = mkTyConApp ioTyCon [ty]
+ in
+ tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
+ returnTc (expr', lie, res_ty)
+
---------------
typecheck :: DynFlags
-> PersistentCompilerState
tcModule pcs hst get_fixity this_mod decls
= -- Type-check the type and class decls, and all imported decls
- tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
+ -- tcImports recovers internally, but if anything gave rise to
+ -- an error we'd better stop now, to avoid a cascade
+ checkNoErrsTc (
+ tcImports pcs hst get_fixity this_mod decls
+ ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
tcSetEnv env $
lie_rules
in
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
+
+ -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
+ tcCheckMain this_mod `thenTc_`
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
%************************************************************************
%* *
+\subsection{Checking the type of main}
+%* *
+%************************************************************************
+
+We must check that in module Main,
+ a) main is defined
+ b) main :: forall a1...an. IO t, for some type t
+
+If we have
+ main = error "Urk"
+then the type of main will be
+ main :: forall a. a
+and that should pass the test too.
+
+So we just instantiate the type and unify with IO t, and declare
+victory if doing so succeeds.
+
+\begin{code}
+tcCheckMain :: Module -> TcM ()
+tcCheckMain this_mod
+ | not (moduleName this_mod == mAIN_Name )
+ = returnTc ()
+
+ | otherwise
+ = -- First unify the main_id with IO t, for any old t
+ tcLookup_maybe mainName `thenNF_Tc` \ maybe_thing ->
+ case maybe_thing of
+ Just (ATcId main_id) -> check_main_ty (idType main_id)
+ other -> addErrTc noMainErr
+ where
+ check_main_ty main_ty
+ = tcInstType main_ty `thenNF_Tc` \ (tvs, theta, main_tau) ->
+ newTyVarTy liftedTypeKind `thenNF_Tc` \ arg_ty ->
+ tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
+ tcAddErrCtxtM (mainTypeCtxt main_ty) $
+ if not (null theta) then
+ failWithTc empty -- Context has the error message
+ else
+ unifyTauTy main_tau (mkTyConApp ioTyCon [arg_ty])
+
+mainTypeCtxt main_ty tidy_env
+ = zonkTcType main_ty `thenNF_Tc` \ main_ty' ->
+ returnNF_Tc (tidy_env, ptext SLIT("`main' has the illegal type") <+>
+ quotes (ppr (tidyType tidy_env main_ty')))
+
+noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
+ ptext SLIT("must include a definition for") <+> quotes (ptext SLIT("main"))]
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Dumping output}
%* *
%************************************************************************
projects / ghc-hetmet.git / commitdiff