Commit 44ba24dc authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

some bug-fixes, newtype deriving might work now

Mon Sep 18 14:33:01 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * some bug-fixes, newtype deriving might work now
  Sat Aug  5 21:29:28 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * some bug-fixes, newtype deriving might work now
    Tue Jul 11 12:16:13 EDT 2006  kevind@bu.edu
parent e6e3c778
......@@ -396,12 +396,13 @@ lintCoreArg fun_ty a@(Type arg_ty) =
lintCoreArg fun_ty arg =
-- Make sure function type matches argument
do { arg_ty <- lintCoreExpr arg
; let err = mkAppMsg fun_ty arg_ty arg
; let err1 = mkAppMsg fun_ty arg_ty arg
err2 = mkNonFunAppMsg fun_ty arg_ty arg
; case splitFunTy_maybe fun_ty of
Just (arg,res) ->
do { checkTys arg arg_ty err
do { checkTys arg arg_ty err1
; return res }
_ -> addErrL err }
_ -> addErrL err2 }
\end{code}
\begin{code}
......@@ -819,6 +820,13 @@ mkAppMsg fun_ty arg_ty arg
hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
hang (ptext SLIT("Arg:")) 4 (ppr arg)]
mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
mkNonFunAppMsg fun_ty arg_ty arg
= vcat [ptext SLIT("Non-function type in function position"),
hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
hang (ptext SLIT("Arg:")) 4 (ppr arg)]
mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty
= vcat [ptext SLIT("Kinds don't match in type application:"),
......
......@@ -608,7 +608,7 @@ We know the list must have at least one @Match@ in it.
\begin{code}
pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches))
pprMatches ctxt (MatchGroup matches ty) = (ppr ty) $$ vcat (map (pprMatch ctxt) (map unLoc matches))
-- Exported to HsBinds, which can't see the defn of HsMatchContext
pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
......
......@@ -138,7 +138,7 @@ mkNewTyConRep tc rhs_ty
if isRecursiveTyCon tc then
go (tc:tcs) (substTyWith tvs tys rhs_ty)
else
go tcs (head tys)
substTyWith tvs tys rhs_ty
where
(tvs, rhs_ty) = newTyConRhs tc
......
......@@ -465,7 +465,7 @@ makeDerivEqns overlap_flag tycl_decls
-- If there are no tyvars, there's no need
-- to abstract over the dictionaries we need
dict_tvs = deriv_tvs ++ tc_tvs
dict_args | null dict_tvs = []
dict_args -- | null dict_tvs = []
| otherwise = rep_pred : sc_theta
-- Finally! Here's where we build the dictionary Id
......
......@@ -15,7 +15,7 @@ import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
import TcRnMonad
import TcMType ( tcSkolSigType, checkValidInstance, checkValidInstHead )
import TcType ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
SkolemInfo(InstSkol), tcSplitDFunTy )
SkolemInfo(InstSkol), tcSplitDFunTy, mkFunTy )
import Inst ( tcInstClassOp, newDicts, instToId, showLIE,
getOverlapFlag, tcExtendLocalInstEnv )
import InstEnv ( mkLocalInstance, instanceDFunId )
......@@ -29,11 +29,11 @@ import TcSimplify ( tcSimplifyCheck, tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, substTys, mkTyConApp, mkTyVarTy )
import Coercion ( mkAppCoercion, mkAppsCoercion )
import TyCon ( TyCon, newTyConCo )
import DataCon ( classDataCon, dataConTyCon )
import Class ( classBigSig )
import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys )
import Class ( classBigSig, classMethods )
import Var ( TyVar, Id, idName, idType )
import Id ( mkSysLocal )
import UniqSupply ( uniqsFromSupply )
import UniqSupply ( uniqsFromSupply, splitUniqSupply )
import MkId ( mkDictFunId )
import Name ( Name, getSrcLoc )
import Maybe ( catMaybes )
......@@ -337,9 +337,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec,
maybe_co_con = newTyConCo tycon
; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
; dicts <- newDicts origin theta
; uniqs <- newUniqueSupply
; let (cls, op_tys) = tcSplitDFunHead inst_head
; [this_dict] <- newDicts origin [mkClassPred cls op_tys]
; uniqs <- newUniqueSupply
; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head
; [this_dict] <- newDicts origin [mkClassPred cls rep_tys]
; let (rep_dict_id:sc_dict_ids) =
if null dicts then
[instToId this_dict]
......@@ -349,32 +349,48 @@ tcInstDecl2 (InstInfo { iSpec = ispec,
-- (Here, we are relying on the order of dictionary
-- arguments built by NewTypeDerived in TcDeriv.)
wrap_fn | null dicts = idCoercion
| otherwise = CoTyLams tvs <.> CoLams sc_dict_ids
wrap_fn = CoTyLams tvs <.> CoLams (rep_dict_id:sc_dict_ids)
coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id)
body | null dicts || null sc_dict_ids = coerced_rep_dict
body | null sc_dict_ids = coerced_rep_dict
| otherwise = HsCase (noLoc coerced_rep_dict) $
MatchGroup [the_match] inst_head
the_match = mkSimpleMatch [the_pat] the_rhs
MatchGroup [the_match] (mkFunTy in_dict_ty inst_head)
in_dict_ty = mkTyConApp cls_tycon cls_inst_tys
the_match = mkSimpleMatch [the_pat] the_rhs
(uniqs1, uniqs2) = splitUniqSupply uniqs
op_ids = zipWith (mkSysLocal FSLIT("op"))
(uniqsFromSupply uniqs) op_tys
the_pat = noLoc $ ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
pat_dicts = sc_dict_ids,
(uniqsFromSupply uniqs1) op_tys
dict_ids = zipWith (mkSysLocal FSLIT("dict"))
(uniqsFromSupply uniqs2) (map idType sc_dict_ids)
the_pat = noLoc $
ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
pat_dicts = dict_ids,
pat_binds = emptyLHsBinds,
pat_args = PrefixCon (map nlVarPat op_ids),
pat_ty = inst_head }
pat_ty = in_dict_ty}
cls_data_con = classDataCon cls
cls_tycon = dataConTyCon cls_data_con
cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
n_dict_args = if length dicts == 0 then 0 else length dicts - 1
op_tys = drop n_dict_args cls_arg_tys
the_rhs = mkHsConApp (cls_data_con) (mkTyVarTys tvs) (map HsVar (sc_dict_ids ++ op_ids))
the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
dict = (mkHsCoerce wrap_fn body)
; pprTrace "built dict:" (ppr dict) $ return (unitBag (noLoc $ VarBind (dfun_id) (noLoc dict))) }
; return (unitBag (noLoc $ VarBind (dfun_id) (noLoc dict))) }
where
co_fn :: [TyVar] -> TyCon -> ExprCoFn
co_fn tvs cls_tycon | Just co_con <- newTyConCo tycon
= ExprCoFn (mkAppCoercion (mkTyConApp cls_tycon [])
= ExprCoFn (mkAppCoercion -- (mkAppsCoercion
(mkTyConApp cls_tycon [])
-- rep_tys)
(mkTyConApp co_con (map mkTyVarTy tvs)))
| otherwise
= idCoercion
......
......@@ -107,6 +107,7 @@ import Outputable
import Control.Monad ( when )
import Data.List ( (\\) )
\end{code}
......
......@@ -2533,7 +2533,7 @@ monomorphism_fix = ptext SLIT("Probable fix:") <+>
warnDefault dicts default_ty
= doptM Opt_WarnTypeDefaults `thenM` \ warn_flag ->
addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg)
addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
where
-- Tidy them first
(_, tidy_dicts) = tidyInsts dicts
......
......@@ -76,6 +76,7 @@ import Char ( ord )
%************************************************************************
\begin{code}
data PprStyle
= PprUser PrintUnqualified Depth
-- Pretty-print in a way that will make sense to the
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment