Commit 243523ba authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents 9beb6153 1884f817
......@@ -1192,7 +1192,7 @@ exprIsConApp_maybe id_unf expr
-- Look through dictionary functions; see Note [Unfolding DFuns]
| DFunUnfolding dfun_nargs con ops <- unfolding
, length args == dfun_nargs -- See Note [DFun arity check]
, let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
, let (dfun_tvs, _theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
mk_arg (DFunPolyArg e) = mkApps e args
mk_arg (DFunLamArg i) = args !! i
......
......@@ -101,8 +101,8 @@ mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
mkDFunUnfolding dfun_ty ops
= DFunUnfolding dfun_nargs data_con ops
where
(tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty
dfun_nargs = length tvs + n_theta
(tvs, theta, cls, _) = tcSplitDFunTy dfun_ty
dfun_nargs = length tvs + length theta
data_con = classDataCon cls
mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
......
......@@ -818,15 +818,17 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
%************************************************************************
%* *
\subsection[InstDecl]{An instance declaration}
Instance declarations
%* *
%************************************************************************
\begin{code}
-- see note [Family instance equation groups]
----------------- Type synonym family instances -------------
-- See note [Family instance equation groups]
type LTyFamInstEqn name = Located (TyFamInstEqn name)
-- | one equation in a family instance declaration
-- | One equation in a family instance declaration
data TyFamInstEqn name
= TyFamInstEqn
{ tfie_tycon :: Located name
......@@ -839,13 +841,16 @@ data TyFamInstEqn name
type LTyFamInstDecl name = Located (TyFamInstDecl name)
data TyFamInstDecl name
= TyFamInstDecl
{ tfid_eqns :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns
, tfid_group :: Bool -- was this declared with the "where" syntax?
, tfid_fvs :: NameSet } -- the group is type-checked as one,
-- so one NameSet will do
-- INVARIANT: tfid_group == False --> length tfid_eqns == 1
{ tfid_eqns :: [LTyFamInstEqn name] -- ^ list of (possibly-overlapping) eqns
, tfid_group :: Bool -- Was this declared with the "where" syntax?
, tfid_fvs :: NameSet } -- The group is type-checked as one,
-- so one NameSet will do
-- INVARIANT: tfid_group == False --> length tfid_eqns == 1
deriving( Typeable, Data )
----------------- Data family instances -------------
type LDataFamInstDecl name = Located (DataFamInstDecl name)
data DataFamInstDecl name
= DataFamInstDecl
......@@ -857,15 +862,8 @@ data DataFamInstDecl name
, dfid_fvs :: NameSet } -- free vars for dependency analysis
deriving( Typeable, Data )
type LInstDecl name = Located (InstDecl name)
data InstDecl name -- Both class and family instances
= ClsInstD
{ cid_inst :: ClsInstDecl name }
| DataFamInstD -- data family instance
{ dfid_inst :: DataFamInstDecl name }
| TyFamInstD -- type family instance
{ tfid_inst :: TyFamInstDecl name }
deriving (Data, Typeable)
----------------- Class instances -------------
type LClsInstDecl name = Located (ClsInstDecl name)
data ClsInstDecl name
......@@ -880,6 +878,18 @@ data ClsInstDecl name
}
deriving (Data, Typeable)
----------------- Instances of all kinds -------------
type LInstDecl name = Located (InstDecl name)
data InstDecl name -- Both class and family instances
= ClsInstD
{ cid_inst :: ClsInstDecl name }
| DataFamInstD -- data family instance
{ dfid_inst :: DataFamInstDecl name }
| TyFamInstD -- type family instance
{ tfid_inst :: TyFamInstDecl name }
deriving (Data, Typeable)
\end{code}
Note [Family instance declaration binders]
......
......@@ -1604,8 +1604,9 @@ getFS x = occNameFS (getOccName x)
--------------------------
instanceToIfaceInst :: ClsInst -> IfaceClsInst
instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag,
is_cls = cls_name, is_tcs = mb_tcs })
instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
, is_cls_nm = cls_name, is_cls = cls
, is_tys = tys, is_tcs = mb_tcs })
= ASSERT( cls_name == className cls )
IfaceClsInst { ifDFun = dfun_name,
ifOFlag = oflag,
......@@ -1621,8 +1622,6 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag,
is_local name = nameIsLocalOrFrom mod name
-- Compute orphanhood. See Note [Orphans] in IfaceSyn
(_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
-- Slightly awkward: we need the Class to get the fundeps
(tvs, fds) = classTvsFds cls
arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]
......
......@@ -653,8 +653,8 @@ look at it.
tcIfaceInst :: IfaceClsInst -> IfL ClsInst
tcIfaceInst (IfaceClsInst { ifDFun = dfun_occ, ifOFlag = oflag
, ifInstCls = cls, ifInstTys = mb_tcs })
= do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId dfun_occ
= do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
tcIfaceExtId dfun_occ
; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
; return (mkImportedInstance cls mb_tcs' dfun oflag) }
......
......@@ -699,7 +699,7 @@ data DynFlags = DynFlags {
interactivePrint :: Maybe String,
llvmVersion :: IORef (Int),
llvmVersion :: IORef Int,
nextWrapperNum :: IORef Int
}
......
......@@ -136,7 +136,7 @@ mkBootModDetailsTc hsc_env
= do { let dflags = hsc_dflags hsc_env
; showPass dflags CoreTidy
; let { insts' = tidyInstances globaliseAndTidyId insts
; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts
; dfun_ids = map instanceDFunId insts'
; type_env1 = mkBootTypeEnv (availsToNameSet exports)
(typeEnvIds type_env) tcs fam_insts
......@@ -336,7 +336,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; tidy_type_env = tidyTypeEnv omit_prags
(extendTypeEnvWithIds type_env final_ids)
; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts
; tidy_insts = map (tidyClsInstDFun (lookup_dfun tidy_type_env)) insts
-- A DFunId will have a binding in tidy_binds, and so
-- will now be in final_env, replete with IdInfo
-- Its name will be unchanged since it was born, but
......@@ -440,14 +440,6 @@ trimThing (AnId id)
trimThing other_thing
= other_thing
tidyInstances :: (DFunId -> DFunId) -> [ClsInst] -> [ClsInst]
tidyInstances tidy_dfun ispecs
= map tidy ispecs
where
tidy ispec = setInstanceDFunId ispec $
tidy_dfun (instanceDFunId ispec)
\end{code}
\begin{code}
......
......@@ -1216,6 +1216,7 @@ datatypeClassKey = mkPreludeClassUnique 39
constructorClassKey = mkPreludeClassUnique 40
selectorClassKey = mkPreludeClassUnique 41
-- SingI: see Note [SingI and EvLit] in TcEvidence
singIClassNameKey, typeNatLeqClassNameKey :: Unique
singIClassNameKey = mkPreludeClassUnique 42
typeNatLeqClassNameKey = mkPreludeClassUnique 43
......
......@@ -414,64 +414,60 @@ addLocalInst :: InstEnv -> ClsInst -> TcM InstEnv
-- Check that the proposed new instance is OK,
-- and then add it to the home inst env
-- If overwrite_inst, then we can overwrite a direct match
addLocalInst home_ie ispec = do
-- Instantiate the dfun type so that we extend the instance
-- envt with completely fresh template variables
-- This is important because the template variables must
-- not overlap with anything in the things being looked up
-- (since we do unification).
--
-- We use tcInstSkolType because we don't want to allocate fresh
-- *meta* type variables.
--
-- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
-- these variables must be bindable by tcUnifyTys. See
-- the call to tcUnifyTys in InstEnv, and the special
-- treatment that instanceBindFun gives to isOverlappableTyVar
-- This is absurdly delicate.
let dfun = instanceDFunId ispec
(tvs', theta', tau') <- tcInstSkolType (idType dfun)
let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
ispec' = setInstanceDFunId ispec dfun'
-- Load imported instances, so that we report
-- duplicates correctly
eps <- getEps
let inst_envs = (eps_inst_env eps, home_ie)
-- Check functional dependencies
case checkFunDeps inst_envs ispec' of
Just specs -> funDepErr ispec' specs
Nothing -> return ()
-- Check for duplicate instance decls
let (matches, unifs, _) = lookupInstEnv inst_envs cls tys'
dup_ispecs = [ dup_ispec
| (dup_ispec, _) <- matches
, let (_,_,_,dup_tys) = instanceHead dup_ispec
, isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)]
-- Find memebers of the match list which ispec itself matches.
-- If the match is 2-way, it's a duplicate
-- If it's a duplicate, but we can overwrite home package dups, then overwrite
isGHCi <- getIsGHCi
overlapFlag <- getOverlapFlag
case isGHCi of
False -> case dup_ispecs of
dup : _ -> dupInstErr ispec' dup >> return (extendInstEnv home_ie ispec')
[] -> return (extendInstEnv home_ie ispec')
True -> case (dup_ispecs, home_ie_matches, unifs, overlapFlag) of
(_, _:_, _, _) -> return (overwriteInstEnv home_ie ispec')
(dup:_, [], _, _) -> dupInstErr ispec' dup >> return (extendInstEnv home_ie ispec')
([], _, u:_, NoOverlap _) -> overlappingInstErr ispec' u >> return (extendInstEnv home_ie ispec')
_ -> return (extendInstEnv home_ie ispec')
where (homematches, _) = lookupInstEnv' home_ie cls tys'
home_ie_matches = [ dup_ispec
| (dup_ispec, _) <- homematches
, let (_,_,_,dup_tys) = instanceHead dup_ispec
, isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)]
addLocalInst home_ie ispec
= do {
-- Instantiate the dfun type so that we extend the instance
-- envt with completely fresh template variables
-- This is important because the template variables must
-- not overlap with anything in the things being looked up
-- (since we do unification).
--
-- We use tcInstSkolType because we don't want to allocate fresh
-- *meta* type variables.
--
-- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
-- these variables must be bindable by tcUnifyTys. See
-- the call to tcUnifyTys in InstEnv, and the special
-- treatment that instanceBindFun gives to isOverlappableTyVar
-- This is absurdly delicate.
-- Load imported instances, so that we report
-- duplicates correctly
eps <- getEps
; let inst_envs = (eps_inst_env eps, home_ie)
(tvs, cls, tys) = instanceHead ispec
-- Check functional dependencies
; case checkFunDeps inst_envs ispec of
Just specs -> funDepErr ispec specs
Nothing -> return ()
-- Check for duplicate instance decls
; let (matches, unifs, _) = lookupInstEnv inst_envs cls tys
dup_ispecs = [ dup_ispec
| (dup_ispec, _) <- matches
, let dup_tys = is_tys dup_ispec
, isJust (tcMatchTys (mkVarSet tvs) tys dup_tys)]
-- Find memebers of the match list which ispec itself matches.
-- If the match is 2-way, it's a duplicate
-- If it's a duplicate, but we can overwrite home package dups, then overwrite
; isGHCi <- getIsGHCi
; overlapFlag <- getOverlapFlag
; case isGHCi of
False -> case dup_ispecs of
dup : _ -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec)
[] -> return (extendInstEnv home_ie ispec)
True -> case (dup_ispecs, home_ie_matches, unifs, overlapFlag) of
(_, _:_, _, _) -> return (overwriteInstEnv home_ie ispec)
(dup:_, [], _, _) -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec)
([], _, u:_, NoOverlap _) -> overlappingInstErr ispec u >> return (extendInstEnv home_ie ispec)
_ -> return (extendInstEnv home_ie ispec)
where (homematches, _) = lookupInstEnv' home_ie cls tys
home_ie_matches = [ dup_ispec
| (dup_ispec, _) <- homematches
, let dup_tys = is_tys dup_ispec
, isJust (tcMatchTys (mkVarSet tvs) tys dup_tys)] }
traceDFuns :: [ClsInst] -> TcRn ()
traceDFuns ispecs
......
......@@ -33,6 +33,7 @@ import RnEnv
import RnSource ( addTcgDUs )
import HscTypes
import Id( idType )
import Class
import Type
import ErrUtils
......@@ -323,7 +324,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
-- the stand-alone derived instances (@insts1@) are used when inferring
-- the contexts for "deriving" clauses' instances (@infer_specs@)
; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
inferInstanceContexts overlap_flag infer_specs
inferInstanceContexts overlap_flag infer_specs
; insts2 <- mapM (genInst False overlap_flag commonAuxs) final_specs
......@@ -426,12 +427,11 @@ renameDeriv is_boot inst_infos bagBinds
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
bindLocalNames (map Var.varName tyvars) $
do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds
do { (rn_binds, fvs) <- rnMethodBinds (is_cls_nm inst) (\_ -> []) binds
; let binds' = VanillaInst rn_binds [] standalone_deriv
; return (inst_info { iBinds = binds' }, fvs) }
where
(tyvars,_, clas,_) = instanceHead inst
clas_nm = className clas
(tyvars, _) = tcSplitForAllTys (idType (instanceDFunId inst))
\end{code}
Note [Newtype deriving and unused constructors]
......@@ -1378,8 +1378,7 @@ inferInstanceContexts oflag infer_specs
| otherwise
= do { -- Extend the inst info from the explicit instance decls
-- with the current set of solutions, and simplify each RHS
let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
current_solns infer_specs
inst_specs <- zipWithM (mkInstance oflag) current_solns infer_specs
; new_solns <- checkNoErrs $
extendLocalInstEnv inst_specs $
mapM gen_soln infer_specs
......@@ -1413,13 +1412,14 @@ inferInstanceContexts oflag infer_specs
the_pred = mkClassPred clas inst_tys
------------------------------------------------------------------
mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> ClsInst
mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> TcM ClsInst
mkInstance overlap_flag theta
(DS { ds_name = dfun_name
, ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
= mkLocalInstance dfun overlap_flag
(DS { ds_name = dfun_name
, ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
= do { (subst, tvs') <- tcInstSkolTyVars tvs
; return (mkLocalInstance dfun overlap_flag tvs' clas (substTys subst tys)) }
where
dfun = mkDictFunId dfun_name tyvars theta clas tys
dfun = mkDictFunId dfun_name tvs theta clas tys
extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
......@@ -1512,21 +1512,21 @@ genInst standalone_deriv oflag comauxs
, ds_theta = theta, ds_newtype = is_newtype
, ds_name = name, ds_cls = clas })
| is_newtype
= return (InstInfo { iSpec = inst_spec
, iBinds = NewTypeDerived co rep_tycon }, emptyBag)
= do { inst_spec <- mkInstance oflag theta spec
; return (InstInfo { iSpec = inst_spec
, iBinds = NewTypeDerived co rep_tycon }, emptyBag) }
| otherwise
= do { fix_env <- getFixityEnv
; (meth_binds, deriv_stuff) <- genDerivStuff (getSrcSpan name)
fix_env clas name rep_tycon
(lookup rep_tycon comauxs)
; inst_spec <- mkInstance oflag theta spec
; let inst_info = InstInfo { iSpec = inst_spec
, iBinds = VanillaInst meth_binds []
standalone_deriv }
; return ( inst_info, deriv_stuff) }
where
inst_spec = mkInstance oflag theta spec
co1 = case tyConFamilyCoercion_maybe rep_tycon of
Just co_con -> mkTcUnbranchedAxInstCo co_con rep_tc_args
Nothing -> id_co
......
......@@ -700,7 +700,7 @@ pprInstInfoDetails info
simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
(_, _, cls, [ty]) -> (cls, ty)
(_, cls, [ty]) -> (cls, ty)
_ -> panic "simpleInstInfoClsTy"
simpleInstInfoTy :: InstInfo a -> Type
......
......@@ -496,7 +496,7 @@ data EvTerm
-- selector Id. We count up from _0_
| EvLit EvLit -- Dictionary for class "SingI" for type lits.
-- Note [EvLit]
-- Note [SingI and EvLit]
deriving( Data.Data, Data.Typeable)
......@@ -550,27 +550,26 @@ Conclusion: a new wanted coercion variable should be made mutable.
from super classes will be "given" and hence rigid]
Note [EvLit]
~~~~~~~~~~~~
Note [SingI and EvLit]
~~~~~~~~~~~~~~~~~~~~~~
A part of the type-level literals implementation is the class "SingI",
which provides a "smart" constructor for defining singleton values.
Here is the key stuff from GHC.TypeLits
newtype Sing n = Sing (SingRep n)
class SingI n where
sing :: Sing n
class SingI n where
sing :: Sing n
type family SingRep a
type instance SingRep (a :: Nat) = Integer
type instance SingRep (a :: Symbol) = String
data family Sing (n::k)
newtype instance Sing (n :: Nat) = SNat Integer
newtype instance Sing (s :: Symbol) = SSym String
Conceptually, this class has infinitely many instances:
instance Sing 0 where sing = Sing 0
instance Sing 1 where sing = Sing 1
instance Sing 2 where sing = Sing 2
instance Sing "hello" where sing = Sing "hello"
...
instance Sing 0 where sing = SNat 0
instance Sing 1 where sing = SNat 1
instance Sing 2 where sing = SNat 2
instance Sing "hello" where sing = SSym "hello"
...
In practice, we solve "SingI" predicates in the type-checker because we can't
have infinately many instances. The evidence (aka "dictionary")
......
......@@ -136,33 +136,32 @@ metaTyConsToDerivStuff tc metaDts =
let
safeOverlap = safeLanguageOn dflags
(dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
mk_inst clas tc dfun_name
= mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
(NoOverlap safeOverlap)
[] clas tys
where
tys = [mkTyConTy tc]
-- Datatype
d_metaTycon = metaD metaDts
d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap
d_binds = VanillaInst dBinds [] False
d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas
[ mkTyConTy d_metaTycon ]
d_inst = mk_inst dClas d_metaTycon d_dfun_name
d_binds = VanillaInst dBinds [] False
d_mkInst = DerivInst (InstInfo { iSpec = d_inst, iBinds = d_binds })
-- Constructor
c_metaTycons = metaC metaDts
c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap
c_insts = [ mk_inst cClas c ds
| (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
c_binds = [ VanillaInst c [] False | c <- cBinds ]
c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas
[ mkTyConTy c ]
c_mkInst = [ DerivInst (InstInfo { iSpec = is, iBinds = bs })
| (is,bs) <- myZip1 c_insts c_binds ]
-- Selector
s_metaTycons = metaS metaDts
s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $
NoOverlap safeOverlap))
(myZip2 s_metaTycons s_dfun_names)
s_insts = map (map (\(s,ds) -> mk_inst sClas s ds))
(myZip2 s_metaTycons s_dfun_names)
s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
[ mkTyConTy s ]
s_mkInst = map (map (\(is,bs) -> DerivInst (InstInfo { iSpec = is
, iBinds = bs})))
(myZip2 s_insts s_binds)
......
......@@ -421,7 +421,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
, deriv_binds)
}}
where
typInstCheck ty = is_cls (iSpec ty) `elem` typeableClassNames
typInstCheck ty = is_cls_nm (iSpec ty) `elem` typeableClassNames
typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
++ " Haskell! Can only derive them"
......@@ -550,8 +550,11 @@ tcClsInstDecl (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
-- Dfun location is that of instance *header*
; overlap_flag <- getOverlapFlag
; (subst, tyvars') <- tcInstSkolTyVars tyvars
; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
ispec = mkLocalInstance dfun overlap_flag
ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys)
-- Be sure to freshen those type variables,
-- so they are sure not to appear in any lookup
inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }
; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }
......@@ -613,26 +616,27 @@ tcTyFamInstDecl fam_tc (L loc decl@(TyFamInstDecl { tfid_group = group }))
-- now, build the FamInstGroup
; return $ mkSynFamInst rep_tc_name fam_tc group fam_inst_branches }
where check_valid_mk_branch :: ([TyVar], [Type], Type, SrcSpan)
-> TcM (FamInstBranch, CoAxBranch)
check_valid_mk_branch (t_tvs, t_typats, t_rhs, loc)
= setSrcSpan loc $
do { -- check the well-formedness of the instance
checkValidFamInst t_typats t_rhs
where
check_valid_mk_branch :: ([TyVar], [Type], Type, SrcSpan)
-> TcM (FamInstBranch, CoAxBranch)
check_valid_mk_branch (t_tvs, t_typats, t_rhs, loc)
= setSrcSpan loc $
do { -- check the well-formedness of the instance
checkValidTyFamInst fam_tc t_tvs t_typats t_rhs
; return $ mkSynFamInstBranch loc t_tvs t_typats t_rhs }
; return $ mkSynFamInstBranch loc t_tvs t_typats t_rhs }
check_inaccessible_branches :: [FamInstBranch] -- previous
-> FamInstBranch -- current
-> TcM [FamInstBranch] -- current : previous
check_inaccessible_branches prev_branches
cur_branch@(FamInstBranch { fib_lhs = tys })
= setSrcSpan (famInstBranchSpan cur_branch) $
do { when (tys `isDominatedBy` prev_branches) $
addErrTc $ inaccessibleFamInstBranch fam_tc cur_branch
; return $ cur_branch : prev_branches }
check_inaccessible_branches :: [FamInstBranch] -- previous
-> FamInstBranch -- current
-> TcM [FamInstBranch] -- current : previous
check_inaccessible_branches prev_branches
cur_branch@(FamInstBranch { fib_lhs = tys })
= setSrcSpan (famInstBranchSpan cur_branch) $
do { when (tys `isDominatedBy` prev_branches) $
addErrTc $ inaccessibleFamInstBranch fam_tc cur_branch
; return $ cur_branch : prev_branches }
get_typats = map (\(_, tys, _, _) -> tys)
get_typats = map (\(_, tys, _, _) -> tys)
tcDataFamInstDecl :: TyCon -> DataFamInstDecl Name -> TcM (FamInst Unbranched)
-- "newtype instance" and "data instance"
......@@ -652,7 +656,7 @@ tcDataFamInstDecl fam_tc
-- Check that left-hand side contains no type family applications
-- (vanilla synonyms are fine, though, and we checked for
-- foralls earlier)
{ mapM_ checkTyFamFreeness pats'
{ checkValidFamPats fam_tc tvs' pats'
-- Result kind must be '*' (otherwise, we have too few patterns)
; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc)
......
......@@ -1719,13 +1719,45 @@ data LookupInstResult
matchClassInst :: InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
matchClassInst _ clas [ _, ty ] _
matchClassInst _ clas [ k, ty ] _
| className clas == singIClassName
, Just n <- isNumLitTy ty = return $ GenInst [] $ EvLit $ EvNum n
, Just n <- isNumLitTy ty = makeDict (EvNum n)
| className clas == singIClassName
, Just s <- isStrLitTy ty = return $ GenInst [] $ EvLit $ EvStr s
, Just s <- isStrLitTy ty = makeDict (EvStr s)
where
{- This adds a coercion that will convert the literal into a dictionary
of the appropriate type. The coercion happens in 3 steps:
evLit -> Sing_k_n -- literal to representation of data family
Sing_k_n -> Sing k n -- representation of data family to data family
Sing k n -> SingI k n -- data family to class dictionary.
-}
makeDict evLit =
case unwrapNewTyCon_maybe (classTyCon clas) of
Just (_,dictRep, axDict)
| Just tcSing <- tyConAppTyCon_maybe dictRep ->
do mbInst <- matchFam tcSing [k,ty]
case mbInst of
Just FamInstMatch
{ fim_instance = FamInst { fi_axiom = axDataFam
, fi_flavor = DataFamilyInst tcon
}
, fim_index = ix, fim_tys = tys
} | Just (_,_,axSing) <- unwrapNewTyCon_maybe tcon ->
do let co1 = mkTcSymCo $ mkTcUnbranchedAxInstCo axSing tys
co2 = mkTcSymCo $ mkTcAxInstCo axDataFam ix tys
co3 = mkTcSymCo $ mkTcUnbranchedAxInstCo axDict [k,ty]
return $ GenInst [] $ EvCast (EvLit evLit) $
mkTcTransCo co1 $ mkTcTransCo co2 co3
_ -> unexpected
_ -> unexpected
unexpected = panicTcS (text "Unexpected evidence for SingI")
matchClassInst inerts clas tys loc
= do { dflags <- getDynFlags
......
......@@ -52,9 +52,9 @@ module TcMType (
-- Checking type validity
Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
expectedKindInCtxt,
checkValidTheta,
checkValidTheta, checkValidFamPats,
checkValidInstHead, checkValidInstance, validDerivPred,
checkInstTermination, checkValidFamInst, checkTyFamFreeness,
checkInstTermination, checkValidTyFamInst, checkTyFamFreeness,
arityErr,
growThetaTyVars, quantifyPred,
......@@ -1809,7 +1809,7 @@ predUndecErr pred msg = sep [msg,