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

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.
......
This diff is collapsed.
......@@ -8,9 +8,9 @@ checker.
\begin{code}
module TcHsSyn (
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsDictLet, mkHsApp,
hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt,
mkHsConApp, mkHsDictLet, mkHsApp,
hsLitType, hsLPatType, hsPatType,
mkHsAppTy, mkSimpleHsAlt,
nlHsIntLit, mkVanillaTuplePat,
......@@ -30,9 +30,8 @@ import HsSyn -- oodles of it
import Id ( idType, setIdType, Id )
import TcRnMonad
import Type ( Type )
import Type ( Type, isLiftedTypeKind, liftedTypeKind, isSubKind, eqKind )
import TcType ( TcType, TcTyVar, mkTyVarTy, mkTyConApp, isImmutableTyVar )
import Kind ( isLiftedTypeKind, liftedTypeKind, isSubKind )
import qualified Type
import TcMType ( zonkQuantifiedTyVar, zonkType, zonkTcType, writeMetaTyVar )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
......@@ -42,7 +41,7 @@ import TysWiredIn ( charTy, stringTy, intTy,
mkListTy, mkPArrTy, mkTupleTy, unitTy,
voidTy, listTyCon, tupleTyCon )
import TyCon ( mkPrimTyCon, tyConKind, PrimRep(..) )
import Kind ( splitKindFunTys )
import {- Kind parts of -} Type ( splitKindFunTys )
import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
import Var ( Var, isId, isLocalVar, tyVarKind )
import VarSet
......@@ -63,33 +62,34 @@ import Outputable
%* *
%************************************************************************
Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
Note: If @hsLPatType@ doesn't bear a strong resemblance to @exprType@,
then something is wrong.
\begin{code}
mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat pats box
= TuplePat pats box (mkTupleTy box (length pats) (map hsPatType pats))
hsPatType :: OutPat Id -> Type
hsPatType (L _ pat) = pat_type pat
pat_type (ParPat pat) = hsPatType pat
pat_type (WildPat ty) = ty
pat_type (VarPat var) = idType var
pat_type (VarPatOut var _) = idType var
pat_type (BangPat pat) = hsPatType pat
pat_type (LazyPat pat) = hsPatType pat
pat_type (LitPat lit) = hsLitType lit
pat_type (AsPat var pat) = idType (unLoc var)
pat_type (ListPat _ ty) = mkListTy ty
pat_type (PArrPat _ ty) = mkPArrTy ty
pat_type (TuplePat pats box ty) = ty
pat_type (ConPatOut _ _ _ _ _ ty) = ty
pat_type (SigPatOut pat ty) = ty
pat_type (NPat lit _ _ ty) = ty
pat_type (NPlusKPat id _ _ _) = idType (unLoc id)
pat_type (DictPat ds ms) = case (ds ++ ms) of
= TuplePat pats box (mkTupleTy box (length pats) (map hsLPatType pats))
hsLPatType :: OutPat Id -> Type
hsLPatType (L _ pat) = hsPatType pat
hsPatType (ParPat pat) = hsLPatType pat
hsPatType (WildPat ty) = ty
hsPatType (VarPat var) = idType var
hsPatType (VarPatOut var _) = idType var
hsPatType (BangPat pat) = hsLPatType pat
hsPatType (LazyPat pat) = hsLPatType pat
hsPatType (LitPat lit) = hsLitType lit
hsPatType (AsPat var pat) = idType (unLoc var)
hsPatType (ListPat _ ty) = mkListTy ty
hsPatType (PArrPat _ ty) = mkPArrTy ty
hsPatType (TuplePat pats box ty) = ty
hsPatType (ConPatOut{ pat_ty = ty })= ty
hsPatType (SigPatOut pat ty) = ty
hsPatType (NPat lit _ _ ty) = ty
hsPatType (NPlusKPat id _ _ _) = idType (unLoc id)
hsPatType (CoPat _ _ ty) = ty
hsPatType (DictPat ds ms) = case (ds ++ ms) of
[] -> unitTy
[d] -> idType d
ds -> mkTupleTy Boxed (length ds) (map idType ds)
......@@ -495,28 +495,6 @@ zonkExpr env (HsCoreAnn lbl expr)
= zonkLExpr env expr `thenM` \ new_expr ->
returnM (HsCoreAnn lbl new_expr)
zonkExpr env (TyLam tyvars expr)
= ASSERT( all isImmutableTyVar tyvars )
zonkLExpr env expr `thenM` \ new_expr ->
returnM (TyLam tyvars new_expr)
zonkExpr env (TyApp expr tys)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkTcTypeToTypes env tys `thenM` \ new_tys ->
returnM (TyApp new_expr new_tys)
zonkExpr env (DictLam dicts expr)
= zonkIdBndrs env dicts `thenM` \ new_dicts ->
let
env1 = extendZonkEnv env new_dicts
in
zonkLExpr env1 expr `thenM` \ new_expr ->
returnM (DictLam new_dicts new_expr)
zonkExpr env (DictApp expr dicts)
= zonkLExpr env expr `thenM` \ new_expr ->
returnM (DictApp new_expr (zonkIdOccs env dicts))
-- arrow notation extensions
zonkExpr env (HsProc pat body)
= do { (env1, new_pat) <- zonkPat env pat
......@@ -554,24 +532,21 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
-------------------------------------------------------------------------
zonkCoFn :: ZonkEnv -> ExprCoFn -> TcM (ZonkEnv, ExprCoFn)
zonkCoFn env CoHole = return (env, CoHole)
zonkCoFn env (ExprCoFn co) = do { co' <- zonkTcTypeToType env co
; return (env, ExprCoFn co') }
zonkCoFn env (CoCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, CoCompose c1' c2') }
zonkCoFn env (CoLams ids c) = do { ids' <- zonkIdBndrs env ids
zonkCoFn env (CoLams ids) = do { ids' <- zonkIdBndrs env ids
; let env1 = extendZonkEnv env ids'
; (env2, c') <- zonkCoFn env1 c
; return (env2, CoLams ids' c') }
zonkCoFn env (CoTyLams tvs c) = ASSERT( all isImmutableTyVar tvs )
do { (env1, c') <- zonkCoFn env c
; return (env1, CoTyLams tvs c') }
zonkCoFn env (CoApps c ids) = do { (env1, c') <- zonkCoFn env c
; return (env1, CoApps c' (zonkIdOccs env ids)) }
zonkCoFn env (CoTyApps c tys) = do { tys' <- zonkTcTypeToTypes env tys
; (env1, c') <- zonkCoFn env c
; return (env1, CoTyApps c' tys') }
zonkCoFn env (CoLet bs c) = do { (env1, bs') <- zonkRecMonoBinds env bs
; (env2, c') <- zonkCoFn env1 c
; return (env2, CoLet bs' c') }
; return (env1, CoLams ids') }
zonkCoFn env (CoTyLams tvs) = ASSERT( all isImmutableTyVar tvs )
do { return (env, CoTyLams tvs) }
zonkCoFn env (CoApps ids) = do { return (env, CoApps (zonkIdOccs env ids)) }
zonkCoFn env (CoTyApps tys) = do { tys' <- zonkTcTypeToTypes env tys
; return (env, CoTyApps tys') }
zonkCoFn env (CoLet bs) = do { (env1, bs') <- zonkRecMonoBinds env bs
; return (env1, CoLet bs') }
-------------------------------------------------------------------------
......@@ -739,14 +714,15 @@ zonk_pat env (TuplePat pats boxed ty)
; (env', pats') <- zonkPats env pats
; return (env', TuplePat pats' boxed ty') }
zonk_pat env (ConPatOut n tvs dicts binds stuff ty)
= ASSERT( all isImmutableTyVar tvs )
zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
= ASSERT( all isImmutableTyVar (pat_tvs p) )
do { new_ty <- zonkTcTypeToType env ty
; new_dicts <- zonkIdBndrs env dicts
; let env1 = extendZonkEnv env new_dicts
; (env2, new_binds) <- zonkRecMonoBinds env1 binds
; (env', new_stuff) <- zonkConStuff env2 stuff
; returnM (env', ConPatOut n tvs new_dicts new_binds new_stuff new_ty) }
; (env', new_args) <- zonkConStuff env2 args
; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts,
pat_binds = new_binds, pat_args = new_args }) }
zonk_pat env (LitPat lit) = return (env, LitPat lit)
......@@ -953,7 +929,7 @@ mkArbitraryType tv
kind = tyVarKind tv
(args,res) = splitKindFunTys kind
tycon | kind == tyConKind listTyCon -- *->*
tycon | eqKind kind (tyConKind listTyCon) -- *->*
= listTyCon -- No tuples this size
| all isLiftedTypeKind args && isLiftedTypeKind res
......
......@@ -45,7 +45,7 @@ import TcType ( Type, PredType(..), ThetaType, BoxySigmaType,
substTyWith, mkTyVarTys, tcEqType,
tcIsTyVarTy, mkFunTy, mkSigmaTy, mkPredTy,
mkTyConApp, mkAppTys, typeKind )
import Kind ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind,
import {- Kind parts of -} Type ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind,
openTypeKind, argTypeKind, splitKindFunTys )
import Var ( TyVar, mkTyVar, tyVarName )
import TyCon ( TyCon, tyConKind )
......
......@@ -22,6 +22,10 @@ module TcMType (
-- Boxy type variables
newBoxyTyVar, newBoxyTyVars, newBoxyTyVarTys, readFilledBox,
--------------------------------
-- Creating new coercion variables
newCoVars,
--------------------------------
-- Instantiation
tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
......@@ -58,10 +62,11 @@ import TypeRep ( Type(..), PredType(..), -- Friend; can see representation
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..),
MetaDetails(..), SkolemInfo(..), BoxInfo(..),
BoxyTyVar, BoxyType, UserTypeCtxt(..),
isMetaTyVar, isSigTyVar, metaTvRef,
BoxyTyVar, BoxyType, UserTypeCtxt(..), kindVarRef,
mkKindVar, isMetaTyVar, isSigTyVar, metaTvRef,
tcCmpPred, isClassPred, tcGetTyVar,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcSplitPhiTy, tcSplitPredTy_maybe,
tcSplitAppTy_maybe,
tcValidInstHeadTy, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy,
isUnLiftedType, isIPPred,
......@@ -70,21 +75,23 @@ import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
tyVarsOfPred, getClassPredTys_maybe,
tyVarsOfType, tyVarsOfTypes, tcView,
pprPred, pprTheta, pprClassPred )
import Kind ( Kind(..), KindVar, kindVarRef, mkKindVar,
isLiftedTypeKind, isArgTypeKind, isOpenTypeKind,
import Type ( Kind, KindVar,
isLiftedTypeKind, isSubArgTypeKind, isSubOpenTypeKind,
liftedTypeKind, defaultKind
)
import Type ( TvSubst, zipTopTvSubst, substTy )
import Coercion ( mkCoKind )
import Class ( Class, classArity, className )
import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
tyConArity, tyConName )
import Var ( TyVar, tyVarKind, tyVarName, isTcTyVar,
mkTyVar, mkTcTyVar, tcTyVarDetails )
mkTyVar, mkTcTyVar, tcTyVarDetails,
CoVar, mkCoVar )
-- Assertions
#ifdef DEBUG
import TcType ( isFlexi, isBoxyTyVar, isImmutableTyVar )
import Kind ( isSubKind )
import Type ( isSubKind )
#endif