Commit 3e83dfb2 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Massive patch for the first months work adding System FC to GHC #34

Fri Sep 15 18:56:58 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Massive patch for the first months work adding System FC to GHC #34
  Fri Aug  4 18:20:57 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Massive patch for the first months work adding System FC to GHC #34
    
    Broken up massive patch -=chak
    Original log message:  
    This is (sadly) all done in one patch to avoid Darcs bugs.
    It's not complete work... more FC stuff to come.  A compiler
    using just this patch will fail dismally.
parent b360db77
......@@ -12,7 +12,7 @@ module Inst (
tidyInsts, tidyMoreInsts,
newDicts, newDictAtLoc, newDictsAtLoc, cloneDict,
newDicts, newDictsAtLoc, cloneDict,
shortCutFracLit, shortCutIntLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp, tcInstStupidTheta,
......@@ -22,6 +22,7 @@ module Inst (
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
mkInstCoFn,
lookupInst, LookupInstResult(..), lookupPred,
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
......@@ -30,7 +31,7 @@ module Inst (
isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
instToId, instName,
instToId, instToVar, instName,
InstOrigin(..), InstLoc(..), pprInstLoc
) where
......@@ -40,8 +41,8 @@ module Inst (
import {-# SOURCE #-} TcExpr( tcPolyExpr )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
nlHsLit, nlHsVar )
import TcHsSyn ( mkHsTyApp, mkHsDictApp, zonkId )
ExprCoFn(..), (<.>), nlHsLit, nlHsVar )
import TcHsSyn ( zonkId )
import TcRnMonad
import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..),
......@@ -69,10 +70,11 @@ import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSub
notElemTvSubst, extendTvSubstList )
import Unify ( tcMatchTys )
import Module ( modulePackageId )
import Kind ( isSubKind )
import {- Kind parts of -} Type ( isSubKind )
import HscTypes ( ExternalPackageState(..), HscEnv(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
import DataCon ( DataCon, dataConStupidTheta, dataConName,
dataConWrapId, dataConUnivTyVars )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
isInternalName, setNameUnique )
......@@ -95,13 +97,23 @@ import Outputable
Selection
~~~~~~~~~
\begin{code}
mkInstCoFn :: [TcType] -> [Inst] -> ExprCoFn
mkInstCoFn tys dicts = CoApps (map instToId dicts) <.> CoTyApps tys
instName :: Inst -> Name
instName inst = idName (instToId inst)
instToId :: Inst -> TcId
instToId (LitInst nm _ ty _) = mkLocalId nm ty
instToId (Dict nm pred _) = mkLocalId nm (mkPredTy pred)
instToId (Method id _ _ _ _) = id
instToId inst = ASSERT2( isId id, ppr inst ) id
where
id = instToVar inst
instToVar :: Inst -> Var
instToVar (LitInst nm _ ty _) = mkLocalId nm ty
instToVar (Method id _ _ _ _) = id
instToVar (Dict nm pred _)
| isEqPred pred = mkTyVar nm (mkPredTy pred)
| otherwise = mkLocalId nm (mkPredTy pred)
instLoc (Dict _ _ loc) = loc
instLoc (Method _ _ _ _ loc) = loc
......@@ -207,29 +219,28 @@ newDicts orig theta
= getInstLoc orig `thenM` \ loc ->
newDictsAtLoc loc theta
cloneDict :: Inst -> TcM Inst
cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
returnM (Dict (setNameUnique nm uniq) ty loc)
newDictAtLoc :: InstLoc -> TcPredType -> TcM Inst
newDictAtLoc inst_loc pred
= do { uniq <- newUnique
; return (mkDict inst_loc uniq pred) }
newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
newDictsAtLoc inst_loc theta
= newUniqueSupply `thenM` \ us ->
returnM (zipWith (mkDict inst_loc) (uniqsFromSupply us) theta)
mkDict inst_loc uniq pred
= Dict name pred inst_loc
where
name = mkPredName uniq (instLocSrcLoc inst_loc) pred
newDictsAtLoc inst_loc theta = mapM (newDictAtLoc inst_loc) theta
{-
newDictOcc :: InstLoc -> TcPredType -> TcM Inst
newDictOcc inst_loc (EqPred ty1 ty2)
= do { unifyType ty1 ty2 -- We insist that they unify right away
; return ty1 } -- And return the relexive coercion
-}
newDictAtLoc inst_loc pred
= do { uniq <- newUnique
; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
; return (Dict name pred inst_loc) }
-- For vanilla implicit parameters, there is only one in scope
-- at any time, so we used to use the name of the implicit parameter itself
-- But with splittable implicit parameters there may be many in
-- scope, so we make up a new name.
-- scope, so we make up a new namea.
newIPDict :: InstOrigin -> IPName Name -> Type
-> TcM (IPName Id, Inst)
newIPDict orig ip_name ty
......@@ -265,7 +276,7 @@ tcInstStupidTheta data_con inst_tys
; extendLIEs stupid_dicts }
where
stupid_theta = dataConStupidTheta data_con
tenv = zipTopTvSubst (dataConTyVars data_con) inst_tys
tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys
newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
newMethodFromName origin ty name
......@@ -580,8 +591,9 @@ lookupInst :: Inst -> TcM LookupInstResult
-- Methods
lookupInst inst@(Method _ id tys theta loc)
= newDictsAtLoc loc theta `thenM` \ dicts ->
returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts)))
= do { dicts <- newDictsAtLoc loc theta
; let co_fn = mkInstCoFn tys dicts
; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
where
span = instLocSrcSpan loc
......@@ -654,14 +666,15 @@ lookupInst (Dict _ pred loc)
-- any nested for-alls in rho. So the in-scope set is unchanged
dfun_rho = substTy tenv' rho
(theta, _) = tcSplitPhiTy dfun_rho
ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id))
(map (substTyVar tenv') tyvars)
src_loc = instLocSrcSpan loc
dfun = HsVar dfun_id
tys = map (substTyVar tenv') tyvars
; if null theta then
returnM (SimpleInst ty_app)
returnM (SimpleInst (L src_loc $ HsCoerce (CoTyApps tys) dfun))
else do
{ dicts <- newDictsAtLoc loc theta
; let rhs = mkHsDictApp ty_app (map instToId dicts)
; returnM (GenInst dicts rhs)
; let co_fn = mkInstCoFn tys dicts
; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
}}}}
---------------
......
......@@ -22,7 +22,8 @@ import TcType ( TcType, TcTauType, BoxyRhoType, mkFunTys, mkTyConApp,
import TcMType ( newFlexiTyVarTy, tcInstSkolTyVars, zonkTcType )
import TcBinds ( tcLocalBinds )
import TcSimplify ( tcSimplifyCheck )
import TcPat ( tcPat, tcPats, PatCtxt(..) )
import TcGadt ( Refinement, emptyRefinement, refineResType )
import TcPat ( tcLamPat, tcLamPats )
import TcUnify ( checkSigTyVarsWrt, boxySplitAppTy )
import TcRnMonad
import Inst ( tcSyntaxName )
......@@ -32,7 +33,7 @@ import VarSet
import TysPrim ( alphaTyVar )
import Type ( Kind, mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes )
import SrcLoc ( Located(..) )
import SrcLoc ( Located(..), noLoc, unLoc )
import Outputable
import Util ( lengthAtLeast )
......@@ -54,8 +55,8 @@ tcProc pat cmd exp_ty
do { (exp_ty1, res_ty) <- boxySplitAppTy exp_ty
; (arr_ty, arg_ty) <- boxySplitAppTy exp_ty1
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
; (pat', cmd') <- tcPat LamPat pat arg_ty res_ty $ \ res_ty' ->
tcCmdTop cmd_env cmd ([], res_ty')
; (pat', cmd') <- tcLamPat pat arg_ty (emptyRefinement, res_ty) $
tcCmdTop cmd_env cmd []
; return (pat', cmd') }
\end{code}
......@@ -79,20 +80,29 @@ mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
---------------------------------------
tcCmdTop :: CmdEnv
-> LHsCmdTop Name
-> (CmdStack, TcTauType) -- Expected result type; always a monotype
-> CmdStack
-> (Refinement, TcTauType) -- Expected result type; always a monotype
-- We know exactly how many cmd args are expected,
-- albeit perhaps not their types; so we can pass
-- in a CmdStack
-> TcM (LHsCmdTop TcId)
tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) (cmd_stk, res_ty)
tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk reft_res_ty@(_,res_ty)
= setSrcSpan loc $
do { cmd' <- tcCmd env cmd (cmd_stk, res_ty)
do { cmd' <- tcGuardedCmd env cmd cmd_stk reft_res_ty
; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
----------------------------------------
tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack
-> (Refinement, TcTauType) -> TcM (LHsExpr TcId)
-- A wrapper that deals with the refinement (if any)
tcGuardedCmd env expr stk (reft, res_ty)
= do { let (co, res_ty') = refineResType reft res_ty
; body <- tcCmd env expr (stk, res_ty')
; return (mkLHsCoerce co body) }
tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
-- The main recursive function
tcCmd env (L loc expr) res_ty
......@@ -120,7 +130,7 @@ tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = mc_body }
mc_body body res_ty' = tcCmd env body (stk, res_ty')
mc_body body res_ty' = tcGuardedCmd env body stk res_ty'
tc_cmd env (HsIf pred b1 b2) res_ty
= do { pred' <- tcMonoExpr pred boolTy
......@@ -169,7 +179,6 @@ tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty)
-------------------------------------------
-- Lambda
-- gaw 2004
tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig grhss))] _))
(cmd_stk, res_ty)
= addErrCtxt (matchCtxt match_ctxt match) $
......@@ -180,7 +189,7 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g
-- Check the patterns, and the GRHSs inside
; (pats', grhss') <- setSrcSpan mtch_loc $
tcPats LamPat pats cmd_stk res_ty $
tcLamPats pats cmd_stk res_ty $
tc_grhss grhss
; let match' = L mtch_loc (Match pats' Nothing grhss')
......@@ -199,9 +208,8 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g
; return (GRHSs grhss' binds') }
tc_grhs res_ty (GRHS guards body)
= do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt
guards res_ty
(\res_ty' -> tcCmd env body (stk', res_ty'))
= do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $
tcGuardedCmd env body stk'
; return (GRHS guards' rhs') }
-------------------------------------------
......@@ -209,8 +217,8 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g
tc_cmd env cmd@(HsDo do_or_lc stmts body ty) (cmd_stk, res_ty)
= do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts res_ty $ \ res_ty' ->
tcCmd env body ([], res_ty')
; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts (emptyRefinement, res_ty) $
tcGuardedCmd env body []
; return (HsDo do_or_lc stmts' body' res_ty) }
where
tc_stmt = tcMDoStmt tc_rhs
......@@ -256,7 +264,9 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
-- the s1..sm and check each cmd
; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
; returnM (HsArrForm (mkHsTyLam [w_tv] (mkHsDictLet inst_binds expr')) fixity cmds')
; returnM (HsArrForm (noLoc $ HsCoerce (CoTyLams [w_tv])
(unLoc $ mkHsDictLet inst_binds expr'))
fixity cmds')
}
where
-- Make the types
......@@ -264,7 +274,6 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
new_cmd_ty :: LHsCmdTop Name -> Int
-> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType)
new_cmd_ty cmd i
-- gaw 2004 FIX?
= do { b_ty <- newFlexiTyVarTy arrowTyConKind
; tup_ty <- newFlexiTyVarTy liftedTypeKind
-- We actually make a type variable for the tuple
......@@ -284,7 +293,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
(badFormFun i tup_ty')
; tcCmdTop (env { cmd_arr = b }) cmd (arg_tys, s) }
; tcCmdTop (env { cmd_arr = b }) cmd arg_tys (emptyRefinement, s) }
unscramble :: TcType -> (TcType, [TcType])
-- unscramble ((w,s1) .. sn) = (w, [s1..sn])
......
......@@ -30,14 +30,14 @@ import TcHsSyn ( zonkId )
import TcRnMonad
import Inst ( newDictsAtLoc, newIPDict, instToId )
import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2,
pprBinders, tcLookupLocalId_maybe, tcLookupId,
pprBinders, tcLookupId,
tcGetGlobalTyVars )
import TcUnify ( tcInfer, tcSubExp, unifyTheta,
bleatEscapedTvs, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck,
tcSimplifyRestricted, tcSimplifyIPs )
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( tcPat, PatCtxt(..) )
import TcPat ( tcLetPat )
import TcSimplify ( bindInstsOfLocalFuns )
import TcMType ( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar,
tcInstSigTyVars, tcInstSkolTyVars, tcInstType,
......@@ -48,9 +48,8 @@ import TcType ( TcType, TcTyVar, TcThetaType,
mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType,
mkForAllTy, isUnLiftedType, tcGetTyVar,
mkTyVarTys, tidyOpenTyVar )
import Kind ( argTypeKind )
import {- Kind parts of -} Type ( argTypeKind )
import VarEnv ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv )
import TysWiredIn ( unitTy )
import TysPrim ( alphaTyVar )
import Id ( Id, mkLocalId, mkVanillaGlobal )
import IdInfo ( vanillaIdInfo )
......@@ -323,7 +322,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
in
-- SET UP THE MAIN RECOVERY; take advantage of any type sigs
setSrcSpan loc $
recoverM (recoveryCode binder_names) $ do
recoverM (recoveryCode binder_names sig_fn) $ do
{ traceTc (ptext SLIT("------------------------------------------------"))
; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names)
......@@ -448,15 +447,14 @@ tcSpecPrag poly_id hs_ty inl
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise
-- subsequent error messages
recoveryCode binder_names
recoveryCode binder_names sig_fn
= do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
; poly_ids <- mapM mk_dummy binder_names
; return ([], poly_ids) }
where
mk_dummy name = do { mb_id <- tcLookupLocalId_maybe name
; case mb_id of
Just id -> return id -- Had signature, was in envt
Nothing -> return (mkLocalId name forall_a_a) } -- No signature
mk_dummy name
| isJust (sig_fn name) = tcLookupId name -- Had signature; look it up
| otherwise = return (mkLocalId name forall_a_a) -- No signature
forall_a_a :: TcType
forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
......@@ -651,9 +649,8 @@ tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss })
| (name, Just sig) <- nm_sig_prs]
sig_tau_fn = lookupNameEnv tau_sig_env
tc_pat exp_ty = tcPat (LetPat sig_tau_fn) pat exp_ty unitTy $ \ _ ->
tc_pat exp_ty = tcLetPat sig_tau_fn pat exp_ty $
mapM lookup_info nm_sig_prs
-- The unitTy is a bit bogus; it's the "result type" for lookup_info.
-- After typechecking the pattern, look up the binder
-- names, which the pattern has brought into scope.
......
......@@ -39,14 +39,14 @@ import Maybes ( catMaybes )
import RdrName ( RdrName )
import Name ( Name, getSrcLoc )
import NameSet ( duDefs )
import Kind ( splitKindFunTys )
import Type ( splitKindFunTys )
import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
isEnumerationTyCon, isRecursiveTyCon, TyCon
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
isUnLiftedType, mkClassPred, tyVarsOfType,
isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
isSubArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
import Var ( TyVar, tyVarKind, varName )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
......@@ -653,7 +653,7 @@ cond_typeableOK :: Condition
-- (b) 7 or fewer args
cond_typeableOK (gla_exts, tycon)
| tyConArity tycon > 7 = Just too_many
| not (all (isArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
| not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
| otherwise = Nothing
where
too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")
......
......@@ -19,7 +19,7 @@ module TcEnv(
tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupLocalId_maybe,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
lclEnvElts, getInLocalScope, findGlobals,
wrongThingErr, pprBinders,
......@@ -44,7 +44,8 @@ module TcEnv(
#include "HsVersions.h"
import HsSyn ( LRuleDecl, LHsBinds, LSig,
LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds )
LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds,
ExprCoFn(..), idCoercion, (<.>) )
import TcIface ( tcImportDecl )
import IfaceEnv ( newGlobalBinder )
import TcRnMonad
......@@ -54,6 +55,7 @@ import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst,
getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
tidyOpenType, isRefineableTy
)
import TcGadt ( Refinement, refineType )
import qualified Type ( getTyVar_maybe )
import Id ( idName, isLocalId, setIdType )
import Var ( TyVar, Id, idType, tyVarName )
......@@ -216,21 +218,16 @@ tcLookupTyVar name
other -> pprPanic "tcLookupTyVar" (ppr name)
tcLookupId :: Name -> TcM Id
-- Used when we aren't interested in the binding level
-- Never a DataCon. (Why does that matter? see TcExpr.tcId)
-- Used when we aren't interested in the binding level, nor refinement.
-- The "no refinement" part means that we return the un-refined Id regardless
--
-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
tcLookupId name
= tcLookup name `thenM` \ thing ->
case thing of
ATcId tc_id _ _ -> returnM tc_id
AGlobal (AnId id) -> returnM id
other -> pprPanic "tcLookupId" (ppr name)
tcLookupLocalId_maybe :: Name -> TcM (Maybe Id)
tcLookupLocalId_maybe name
= getLclEnv `thenM` \ local_env ->
case lookupNameEnv (tcl_env local_env) name of
Just (ATcId tc_id _ _) -> return (Just tc_id)
other -> return Nothing
ATcId { tct_id = id} -> returnM id
AGlobal (AnId id) -> returnM id
other -> pprPanic "tcLookupId" (ppr name)
tcLookupLocalIds :: [Name] -> TcM [TcId]
-- We expect the variables to all be bound, and all at
......@@ -241,8 +238,9 @@ tcLookupLocalIds ns
where
lookup lenv lvl name
= case lookupNameEnv lenv name of
Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id
other -> pprPanic "tcLookupLocalIds" (ppr name)
Just (ATcId { tct_id = id, tct_level = lvl1 })
-> ASSERT( lvl == lvl1 ) id
other -> pprPanic "tcLookupLocalIds" (ppr name)
lclEnvElts :: TcLclEnv -> [TcTyThing]
lclEnvElts env = nameEnvElts (tcl_env env)
......@@ -322,8 +320,13 @@ tcExtendIdEnv2 names_w_ids thing_inside
let
extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
th_lvl = thLevel (tcl_th_ctxt env)
extra_env = [ (name, ATcId id th_lvl (isRefineableTy (idType id)))
| (name,id) <- names_w_ids]
extra_env = [ (name, ATcId { tct_id = id,
tct_level = th_lvl,
tct_type = id_ty,
tct_co = if isRefineableTy id_ty
then Just idCoercion
else Nothing })
| (name,id) <- names_w_ids, let id_ty = idType id]
le' = extendNameEnvList (tcl_env env) extra_env
rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
in
......@@ -360,7 +363,7 @@ findGlobals tvs tidy_env
ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
-----------------------
find_thing ignore_it tidy_env (ATcId id _ _)
find_thing ignore_it tidy_env (ATcId { tct_id = id })
= zonkTcType (idType id) `thenM` \ id_ty ->
if ignore_it id_ty then
returnM (tidy_env, Nothing)
......@@ -393,16 +396,20 @@ find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
\end{code}
\begin{code}
refineEnvironment :: TvSubst -> TcM a -> TcM a
refineEnvironment :: Refinement -> TcM a -> TcM a
-- I don't think I have to refine the set of global type variables in scope
-- Reason: the refinement never increases that set
refineEnvironment reft thing_inside
= do { env <- getLclEnv
; let le' = mapNameEnv refine (tcl_env env)
; gtvs' <- refineGlobalTyVars reft (tcl_tyvars env)
; setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside }
; setLclEnv (env {tcl_env = le'}) thing_inside }
where
refine (ATcId id lvl True) = ATcId (setIdType id (substTy reft (idType id))) lvl True
refine (ATyVar tv ty) = ATyVar tv (substTy reft ty)
refine elt = elt
refine elt@(ATcId { tct_co = Just co, tct_type = ty })
= let (co', ty') = refineType reft ty
in elt { tct_co = Just (co' <.> co), tct_type = ty' }
refine (ATyVar tv ty) = ATyVar tv (snd (refineType reft ty))
-- Ignore the coercion that refineType returns
refine elt = elt
\end{code}
%************************************************************************
......@@ -415,11 +422,6 @@ refineEnvironment reft thing_inside
tc_extend_gtvs gtvs extra_global_tvs
= readMutVar gtvs `thenM` \ global_tvs ->
newMutVar (global_tvs `unionVarSet` extra_global_tvs)
refineGlobalTyVars :: GadtRefinement -> TcRef TcTyVarSet -> TcM (TcRef TcTyVarSet)
refineGlobalTyVars reft gtv_var
= readMutVar gtv_var `thenM` \ gbl_tvs ->
newMutVar (tcTyVarsOfTypes (map (substTyVar reft) (varSetElems gbl_tvs)))
\end{code}
@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
......
......@@ -21,39 +21,47 @@ import qualified DsMeta
#endif
import HsSyn ( HsExpr(..), LHsExpr, ArithSeqInfo(..), recBindFields,
HsMatchContext(..), HsRecordBinds,
mkHsCoerce, mkHsApp, mkHsDictApp, mkHsTyApp )
HsMatchContext(..), HsRecordBinds, mkHsCoerce,
mkHsApp )
import TcHsSyn ( hsLitType )
import TcRnMonad
import TcUnify ( tcInfer, tcSubExp, tcFunResTy, tcGen, boxyUnify, subFunTys, zapToMonotype, stripBoxyType,
boxySplitListTy, boxySplitTyConApp, wrapFunResCoercion, preSubType,
unBox )
import BasicTypes ( Arity, isMarkedStrict )
import Inst ( newMethodFromName, newIPDict, instToId,
import Inst ( newMethodFromName, newIPDict, mkInstCoFn,
newDicts, newMethodWithGivenTy, tcInstStupidTheta )
import TcBinds ( tcLocalBinds )
import TcEnv ( tcLookup, tcLookupId, tcLookupDataCon, tcLookupField )
import TcEnv ( tcLookup, tcLookupDataCon, tcLookupField )
import TcArrows ( tcProc )
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) )
import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcBody,
TcMatchCtxt(..) )
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( tcOverloadedLit, badFieldCon )
import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars, readFilledBox, zonkTcTypes )
import TcType ( TcType, TcSigmaType, TcRhoType,
import TcMType ( tcInstTyVars, newFlexiTyVarTy, newBoxyTyVars,
readFilledBox, zonkTcTypes )
import TcType ( TcType, TcSigmaType, TcRhoType, TvSubst,
BoxySigmaType, BoxyRhoType, ThetaType,
mkTyVarTys, mkFunTys,
tcMultiSplitSigmaTy, tcSplitFunTysN, tcSplitTyConApp_maybe,
tcMultiSplitSigmaTy, tcSplitFunTysN,
tcSplitTyConApp_maybe,
isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
exactTyVarsOfType, exactTyVarsOfTypes,
zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
)
import Kind ( argTypeKind )
import Id ( Id, idType, idName, recordSelectorFieldLabel,
isRecordSelector, isNaughtyRecordSelector, isDataConId_maybe )
import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConSourceArity,
dataConWrapId, isVanillaDataCon, dataConTyVars, dataConOrigArgTys )
import {- Kind parts of -}
Type ( argTypeKind )
import Id ( Id, idType, recordSelectorFieldLabel,
isRecordSelector, isNaughtyRecordSelector,
isDataConId_maybe )
import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks,
dataConSourceArity,
dataConWrapId, isVanillaDataCon, dataConUnivTyVars,
dataConOrigArgTys )
import Name ( Name )
import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons, isEnumerationTyCon )
import TyCon ( FieldLabel, tyConStupidTheta, tyConDataCons,
isEnumerationTyCon )
import Type ( substTheta, substTy )
import Var ( TyVar, tyVarKind )
import VarSet ( emptyVarSet, elemVarSet, unionVarSet )
......@@ -68,7 +76,7 @@ import PrimOp ( tagToEnumKey )
import DynFlags
import StaticFlags ( opt_NoMethodSharing )
import HscTypes ( TyThing(..) )
import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
import SrcLoc ( Located(..), unLoc, getLoc )
import Util
import ListSetOps ( assocMaybe )
import Maybes ( catMaybes )
......@@ -282,7 +290,7 @@ tcExpr (HsCase scrut matches) exp_ty
; return (HsCase scrut' matches') }
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = tcPolyExpr }
mc_body = tcBody }
tcExpr (HsIf pred b1 b2) res_ty
= do { pred' <- addErrCtxt (predCtxt pred) $
......@@ -440,7 +448,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
-- A constructor is only relevant to this process if
-- it contains *all* the fields that are being updated
con1 = head relevant_cons -- A representative constructor
con1_tyvars = dataConTyVars con1
con1_tyvars = dataConUnivTyVars con1
con1_flds = dataConFieldLabels con1
con1_arg_tys = dataConOrigArgTys con1
common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
......@@ -633,10 +641,11 @@ tcIdApp :: Name -- Function
-- Then fres <= bx_(k+1) -> ... -> bx_n -> res_ty
tcIdApp fun_name n_args arg_checker res_ty
= do { fun_id <- lookupFun (OccurrenceOf fun_name) fun_name
= do { let orig = OccurrenceOf fun_name
; (fun, fun_ty) <- lookupFun orig fun_name
-- Split up the function type
; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy (idType fun_id)
; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
(fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
......@@ -678,7 +687,7 @@ tcIdApp fun_name n_args arg_checker res_ty
-- And pack up the results
-- By applying the coercion just to the *function* we can make
-- tcFun work nicely for OpApp and Sections too
; fun' <- instFun fun_id qtvs qtys'' tv_theta_prs
; fun' <- instFun orig fun res_subst tv_theta_prs
; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
; return (mkHsCoerce co_fn' fun', args') }
\end{code}
......@@ -707,10 +716,10 @@ tcId :: InstOrigin
-> TcM (HsExpr TcId)
tcId orig fun_name res_ty
= do { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
; fun_id <- lookupFun orig fun_name
; (fun, fun_ty) <- lookupFun orig fun_name
-- Split up the function type
; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy (idType fun_id)
; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
tau_qtvs = exactTyVarsOfType fun_tau -- Mentioned in the tau part
; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
......@@ -722,7 +731,7 @@ tcId orig fun_name res_ty
; co_fn <- tcFunResTy fun_name fun_tau' res_ty
-- And pack up the results
; fun' <- instFun fun_id qtvs qtv_tys tv_theta_prs
; fun' <- instFun orig fun res_subst tv_theta_prs
; return (mkHsCoerce co_fn fun') }
-- Note [Push result type in]
......@@ -756,49 +765,49 @@ tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
tcSyntaxOp orig other ty = pprPanic "tcSyntaxOp" (ppr other)
---------------------------
instFun :: TcId
-> [TyVar] -> [TcType] -- Quantified type variables and
-- their instantiating types
-> [([TyVar], ThetaType)] -- Stuff to instantiate