import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
SpliceDecl(..), HsBind(..), LHsBinds,
emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
- nlHsApp, nlHsVar, pprLHsBinds )
+ nlHsApp, nlHsVar, pprLHsBinds, HaddockModInfo(..) )
import RdrHsSyn ( findSplice )
import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
main_RDR_Unqual )
import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv )
+import TyCon ( isOpenTyCon )
import TcHsSyn ( zonkTopDecls )
import TcExpr ( tcInferRho )
import TcRnMonad
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcIface ( tcExtCoreBindings, tcHiBootIface )
-import IfaceSyn ( checkBootDecl, tyThingToIfaceDecl, IfaceExtName(..) )
+import MkIface ( tyThingToIfaceDecl )
+import IfaceSyn ( checkBootDecl, IfaceExtName(..) )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
+import RnHsDoc ( rnMbHsDoc )
import PprCore ( pprRules, pprCoreBindings )
import CoreSyn ( CoreRule, bindersOfBinds )
import ErrUtils ( Messages, mkDumpDoc, showPass )
HsLocalBinds(..), HsValBinds(..),
LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds,
collectLStmtsBinders, collectLStmtBinders, nlVarPat,
- mkFunBind, placeHolderType, noSyntaxExpr )
+ mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp )
import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
import RnSource ( addTcgDUs )
import TcMType ( zonkTcType, zonkQuantifiedTyVar )
import TcMatches ( tcStmts, tcDoStmt )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
+import TcGadt ( emptyRefinement )
import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy,
isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
+import TypeRep ( TyThing(..) )
import RnTypes ( rnLHsType )
import Inst ( tcGetInstEnvs )
import InstEnv ( classInstances, instEnvElts )
import TyCon ( tyConName )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
-import Kind ( Kind )
+import {- Kind parts of -} Type ( Kind )
import Var ( globaliseId )
-import Name ( nameModule, isBuiltInSyntax, isInternalName )
+import Name ( isBuiltInSyntax, isInternalName )
import OccName ( isTcOcc )
import NameEnv ( delListFromNameEnv )
import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName,
Dependencies(..) )
import BasicTypes ( Fixity, RecFlag(..) )
import SrcLoc ( unLoc )
+import Data.Maybe ( isNothing )
#endif
import FastString ( mkFastString )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
-import Data.Maybe ( isJust, isNothing )
+import Data.Maybe ( isJust )
\end{code}
tcRnModule hsc_env hsc_src save_rn_syntax
(L loc (HsModule maybe_mod export_ies
- import_decls local_decls mod_deprec))
+ import_decls local_decls mod_deprec _ module_info maybe_doc))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
-- Process the export list
rn_exports <- rnExports export_ies ;
+
+ -- Rename the Haddock documentation header
+ rn_module_doc <- rnMbHsDoc maybe_doc ;
+
+ -- Rename the Haddock module info
+ rn_description <- rnMbHsDoc (hmi_description module_info) ;
+ let { rn_module_info = module_info { hmi_description = rn_description } } ;
+
let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ;
- exports <- mkExportNameSet (isJust maybe_mod) (liftM2' (,) rn_exports export_ies) ;
+ exports <- mkExportNameSet (isJust maybe_mod)
+ (liftM2' (,) rn_exports export_ies) ;
-- Check whether the entire module is deprecated
-- This happens only once per module
else Nothing,
tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
- mod_deprecs }
+ mod_deprecs,
+ tcg_doc = rn_module_doc,
+ tcg_hmi = rn_module_info
+ }
-- A module deprecation over-rides the earlier ones
} ;
TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
- tcDump tcg_env ;
(bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
rules fords ;
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
failIfErrsM ; -- Don't typecheck if renaming failed
+ rnDump (ppr rn_splice_expr) ;
-- Execute the splice
spliced_decls <- tcSpliceDecls rn_splice_expr ;
-- Typecheck instance decls
; traceTc (text "Tc3")
- ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
+ ; (tcg_env, inst_infos, _binds)
+ <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
= ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
bootMisMatch thing boot_decl real_decl
= ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
+ $+$ (ppr boot_decl) $+$ (ppr real_decl)
instMisMatch inst
= hang (ppr inst)
2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc (text "Tc3") ;
- (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
+ (tcg_env, inst_infos, deriv_binds)
+ <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
setGblEnv tcg_env $ do {
-- Foreign import declarations next. No zonking necessary
| [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
= do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
(HsVar thenIOName) placeHolderType
+
+ ; print_bind_result <- doptM Opt_PrintBindResult
+ ; let print_plan = do
+ { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
+ ; v_ty <- zonkTcType (idType v_id)
+ ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
+ ; return stuff }
+
-- The plans are:
-- [stmt; print v] but not if v::()
-- [stmt]
- ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
- ; v_ty <- zonkTcType (idType v_id)
- ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
- ; return stuff },
- tcGhciStmts [stmt]
- ]}
+ ; runPlans ((if print_bind_result then [print_plan] else []) ++
+ [tcGhciStmts [stmt]])
+ }
mkPlan stmt
= tcGhciStmts [stmt]
io_ty = mkTyConApp ioTyCon [] ;
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
+ tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts
+ (emptyRefinement, io_ret_ty) ;
names = map unLoc (collectLStmtsBinders stmts) ;
-- then the type checker would instantiate x..z, and we wouldn't
-- get their *polymorphic* values. (And we'd get ambiguity errs
-- if they were overloaded, since they aren't applied to anything.)
- mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
+ mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty])
(noLoc $ ExplicitList unitTy (map mk_item ids)) ;
- mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
+ mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
(nlHsVar id)
} ;
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
- ((tc_stmts, ids), lie) <- getLIE $
- tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ ->
- mappM tcLookupId names ;
+ ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+ mappM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
projects / ghc-hetmet.git / blobdiff