import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
- isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch
+ isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch, placeHolderType
)
-import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName,
+import PrelNames ( mAIN_Name, mainName, ioTyConName, printName,
returnIOName, bindIOName, failIOName,
itName
)
import MkIface ( pprModDetails )
import TcExpr ( tcMonoExpr )
import TcMonad
-import TcType ( newTyVarTy, zonkTcType, tcInstType )
+import TcMType ( unifyTauTy, newTyVarTy, zonkTcType, tcInstType )
+import TcType ( Type, liftedTypeKind, openTypeKind,
+ tyVarsOfType, tidyType, tcFunResultTy,
+ mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
+ )
import TcMatches ( tcStmtsAndThen )
-import TcUnify ( unifyTauTy )
import Inst ( emptyLIE, plusLIE )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
import TcTyClsDecls ( tcTyAndClassDecls )
-
import CoreUnfold ( unfoldingTemplate, hasUnfolding )
import TysWiredIn ( mkListTy, unitTy )
-import Type
import ErrUtils ( printErrorsAndWarnings, errorsFound,
dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
import Id ( Id, idType, idUnfolding )
TyThing(..), implicitTyThingIds,
mkTypeEnv
)
-import VarSet
\end{code}
-> PrintUnqualified -- For error printing
-> Module -- Is this really needed
-> [Name] -- Names bound by the Stmt (empty for expressions)
- -> (SyntaxMap,
- RenamedStmt, -- The stmt itself
+ -> (RenamedStmt, -- The stmt itself
[RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
-> IO (Maybe (PersistentCompilerState,
TypecheckedHsExpr,
-- The returned [Id] is the same as the input except for
-- ExprStmt, in which case the returned [Name] is [itName]
-typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls)
- = typecheck dflags syn_map pcs hst unqual $
+typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (stmt, iface_decls)
+ = typecheck dflags pcs hst unqual $
-- use the default default settings, i.e. [Integer, Double]
tcSetDefaultTys defaultDefaultTys $
\begin{code}
tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id])
-tcUserStmt names (ExprStmt expr loc)
+tcUserStmt names (ExprStmt expr _ loc)
= ASSERT( null names )
tcGetUnique `thenNF_Tc` \ uniq ->
let
fresh_it = itName uniq
the_bind = FunMonoBind fresh_it False
- [ mkSimpleMatch [] expr Nothing loc ] loc
+ [ mkSimpleMatch [] expr placeHolderType loc ] loc
in
tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_`
tc_stmts [fresh_it] [
LetStmt (MonoBind the_bind [] NonRecursive),
- ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) loc])
+ ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc])
( traceTc (text "tcs 1a") `thenNF_Tc_`
tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc])
-- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
- (ExplicitListOut unitTy (map mk_item ids))
+ (ExplicitList unitTy (map mk_item ids))
mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
(HsVar id)
-> TypeEnv -- The interactive context's type envt
-> PrintUnqualified -- For error printing
-> Module
- -> (SyntaxMap,
- RenamedHsExpr, -- The expression itself
+ -> (RenamedHsExpr, -- The expression itself
[RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
-> IO (Maybe (PersistentCompilerState,
TypecheckedHsExpr,
[Id], -- always empty (matches typecheckStmt)
Type))
-typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls)
- = typecheck dflags syn_map pcs hst unqual $
+typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
+ = typecheck dflags pcs hst unqual $
-- use the default default settings, i.e. [Integer, Double]
tcSetDefaultTys defaultDefaultTys $
newTyVarTy openTypeKind `thenTc` \ ty ->
tcMonoExpr expr ty `thenTc` \ (e', lie) ->
- tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie
- `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
+ tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie
+ `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
tcSimplifyTop lie_free `thenTc` \ const_binds ->
let all_expr = mkHsLet const_binds $
-> HomeSymbolTable
-> ModIface -- Iface for this module
-> PrintUnqualified -- For error printing
- -> (SyntaxMap, [RenamedHsDecl])
+ -> [RenamedHsDecl]
-> IO (Maybe (PersistentCompilerState, TcResults))
-- The new PCS is Augmented with imported information,
-- (but not stuff from this module)
}
-typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls)
- = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $
+typecheckModule dflags pcs hst mod_iface unqual decls
+ = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
tcModule pcs hst get_fixity this_mod decls
; printTcDump dflags unqual maybe_tc_result
; return maybe_tc_result }
lie_rules
in
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
+ traceTc (text "endsimpltop") `thenTc_`
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
-> PersistentCompilerState
-> HomeSymbolTable
-> ModIface -- Iface for this module (just module & fixities)
- -> (SyntaxMap, [RenamedHsDecl])
+ -> [RenamedHsDecl]
-> IO (Maybe (PersistentCompilerState, ModDetails))
-- The new PCS is Augmented with imported information,
-- (but not stuff from this module).
-typecheckIface dflags pcs hst mod_iface (syn_map, decls)
- = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $
+typecheckIface dflags pcs hst mod_iface decls
+ = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
tcIfaceImports pcs hst get_fixity this_mod decls
; printIfaceDump dflags maybe_tc_stuff
; return maybe_tc_stuff }
\begin{code}
typecheck :: DynFlags
- -> SyntaxMap
-> PersistentCompilerState
-> HomeSymbolTable
-> PrintUnqualified -- For error printing
-> TcM r
-> IO (Maybe r)
-typecheck dflags syn_map pcs hst unqual thing_inside
+typecheck dflags pcs hst unqual thing_inside
= do { showPass dflags "Typechecker";
- ; env <- initTcEnv syn_map hst (pcs_PTE pcs)
+ ; env <- initTcEnv hst (pcs_PTE pcs)
; (maybe_tc_result, errs) <- initTc dflags env thing_inside
| otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
ppr_ep (EP from to)
- = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
+ = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
]
where
- (_,from_tau) = splitForAllTys (idType from)
-
+ (_,from_tau) = tcSplitForAllTys (idType from)
\end{code}
projects / ghc-hetmet.git / blobdiff