-- for the ClassOp
info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
- -- See Note [Single-method classes] for why alwaysInlinePragma
+ -- See Note [Single-method classes] in TcInstDcls
+ -- for why alwaysInlinePragma
| otherwise = base_info `setSpecInfo` mkSpecInfo [rule]
`setInlinePragInfo` neverInlinePragma
-- Add a magic BuiltinRule, and never inline it
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
+ | isJust (isClassOpId_maybe poly_id)
+ = putSrcSpanDs loc $
+ do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")
+ <+> quotes (ppr poly_id))
+ ; return Nothing } -- There is no point in trying to specialise a class op
+ -- Moreover, classops don't (currently) have an inl_sat arity set
+ -- (it would be Just 0) and that in turn makes makeCorePair bleat
+
+ | otherwise
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
import FastString
import ForeignCall
import MonadUtils
+import Util( equalLength )
import Data.Maybe
import Control.Monad
do { cxt1 <- repLContext cxt
; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
- ; cons1 <- mapM repC cons
+ ; cons1 <- mapM (repC (hsLTyVarNames tvs)) cons
; cons2 <- coreList conQTyConName cons1
; derivs1 <- repDerivs mb_derivs
; bndrs1 <- coreList tyVarBndrTyConName bndrs
do { cxt1 <- repLContext cxt
; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts
; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1
- ; con1 <- repC con
+ ; con1 <- repC (hsLTyVarNames tvs) con
; derivs1 <- repDerivs mb_derivs
; bndrs1 <- coreList tyVarBndrTyConName bndrs
; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1
-- Constructors
-------------------------------------------------------
-repC :: LConDecl Name -> DsM (Core TH.ConQ)
-repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
- , con_details = details, con_res = ResTyH98 }))
+repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
+repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
+ , con_details = details, con_res = ResTyH98 }))
= do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
- ; repConstr con1 details
- }
-repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 }))
- = addTyVarBinds tvs $ \bndrs ->
- do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] }))
- ; ctxt' <- repContext ctxt
- ; bndrs' <- coreList tyVarBndrTyConName bndrs
- ; rep2 forallCName [unC bndrs', unC ctxt', unC c']
- }
-repC (L loc con_decl) -- GADTs
- = putSrcSpanDs loc $
- notHandled "GADT declaration" (ppr con_decl)
-
+ ; repConstr con1 details }
+repC tvs (L _ (ConDecl { con_name = con
+ , con_qvars = con_tvs, con_cxt = L _ ctxt
+ , con_details = details
+ , con_res = res_ty }))
+ = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
+ ; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
+ ; binds <- mapM dupBinder con_tv_subst
+ ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
+ addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
+ do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
+ ; c' <- repConstr con1 details
+ ; ctxt' <- repContext (eq_ctxt ++ ctxt)
+ ; ex_bndrs' <- coreList tyVarBndrTyConName ex_bndrs
+ ; rep2 forallCName [unC ex_bndrs', unC ctxt', unC c'] } }
+
+in_subst :: Name -> [(Name,Name)] -> Bool
+in_subst _ [] = False
+in_subst n ((n',_):ns) = n==n' || in_subst n ns
+
+mkGadtCtxt :: [Name] -- Tyvars of the data type
+ -> ResType Name
+ -> DsM (HsContext Name, [(Name,Name)])
+-- Given a data type in GADT syntax, figure out the equality
+-- context, so that we can represent it with an explicit
+-- equality context, because that is the only way to express
+-- the GADT in TH syntax
+--
+-- Example:
+-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
+-- mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
+-- returns
+-- (b~[e], c~e), [d->a]
+--
+-- This function is fiddly, but not really hard
+mkGadtCtxt _ ResTyH98
+ = return ([], [])
+mkGadtCtxt data_tvs (ResTyGADT res_ty)
+ | let (head_ty, tys) = splitHsAppTys res_ty []
+ , Just _ <- is_hs_tyvar head_ty
+ , data_tvs `equalLength` tys
+ = return (go [] [] (data_tvs `zip` tys))
+
+ | otherwise
+ = failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty)
+ where
+ go cxt subst [] = (cxt, subst)
+ go cxt subst ((data_tv, ty) : rest)
+ | Just con_tv <- is_hs_tyvar ty
+ , isTyVarName con_tv
+ , not (in_subst con_tv subst)
+ = go cxt ((con_tv, data_tv) : subst) rest
+ | otherwise
+ = go (eq_pred : cxt) subst rest
+ where
+ loc = getLoc ty
+ eq_pred = L loc (HsEqualP (L loc (HsTyVar data_tv)) ty)
+
+ is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons
+ is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
+ is_hs_tyvar _ = Nothing
+
+
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy ty= do
MkC s <- rep2 str []
-- meta environment and gets the *new* names on Core-level as an argument
--
addTyVarBinds :: ProcessTyVarBinds a
-addTyVarBinds tvs m =
- do
- let names = hsLTyVarNames tvs
- mkWithKinds = map repTyVarBndrWithKind tvs
- freshNames <- mkGenSyms names
- term <- addBinds freshNames $ do
- bndrs <- mapM lookupBinder names
- kindedBndrs <- zipWithM ($) mkWithKinds bndrs
- m kindedBndrs
- wrapGenSyms freshNames term
+addTyVarBinds tvs m
+ = do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
+ ; term <- addBinds freshNames $
+ do { kindedBndrs <- mapM mk_tv_bndr (tvs `zip` freshNames)
+ ; m kindedBndrs }
+ ; wrapGenSyms freshNames term }
+ where
+ mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
-- Look up a list of type variables; the computations passed as the second
-- argument gets the *new* names on Core-level as an argument
where
msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n
+dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
+dupBinder (new, old)
+ = do { mb_val <- dsLookupMetaEnv old
+ ; case mb_val of
+ Just val -> return (new, val)
+ Nothing -> pprPanic "dupBinder" (ppr old) }
+
-- Look up a name that is either locally bound or a global name
--
-- * If it is a global name, generate the "original name" representation (ie,
hsTyVarKind, hsTyVarNameKind,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy, splitHsFunType,
+ splitHsAppTys, mkHsAppTys,
-- Type place holder
PostTcType, placeHolderType, PostTcKind, placeHolderKind,
\begin{code}
+splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
+splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
+splitHsAppTys f as = (f,as)
+
+mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
+mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
+mkHsAppTys fun_ty (arg_ty:arg_tys)
+ = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
+ where
+ mk_app fun arg = HsAppTy (noLoc fun) arg
+ -- Add noLocs for inner nodes of the application;
+ -- they are never used
+
splitHsInstDeclTy
:: OutputableBndr name
=> HsType name
files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
cyclicModuleErr :: [ModSummary] -> SDoc
+-- From a strongly connected component we find
+-- a single cycle to report
cyclicModuleErr ms
- = hang (ptext (sLit "Module imports form a cycle for modules:"))
- 2 (vcat (map show_one ms))
+ = ASSERT( not (null ms) )
+ hang (ptext (sLit "Module imports form a cycle:"))
+ 2 (show_path (shortest [] root_mod))
where
- mods_in_cycle = map ms_mod_name ms
- imp_modname = unLoc . ideclName . unLoc
- just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
-
- show_one ms =
- vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
- maybe empty (parens . text) (ml_hs_file (ms_location ms)),
- nest 2 $ ptext (sLit "imports:") <+> vcat [
- pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
- pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]
- ]
- show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
- pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
+ deps :: [(ModuleName, [ModuleName])]
+ deps = [ (moduleName (ms_mod m), get_deps m) | m <- ms ]
+
+ get_deps :: ModSummary -> [ModuleName]
+ get_deps m = filter (\k -> Map.member k dep_env) (map unLoc (ms_home_imps m))
+
+ dep_env :: Map.Map ModuleName [ModuleName]
+ dep_env = Map.fromList deps
+
+ -- Find the module with fewest imports among the SCC modules
+ -- This is just a heuristic to find some plausible root module
+ root_mod :: ModuleName
+ root_mod = fst (minWith (length . snd) deps)
+
+ shortest :: [ModuleName] -> ModuleName -> [ModuleName]
+ -- (shortest [v1,v2,..,vn] m) assumes that
+ -- m is imported by v1
+ -- which is imported by v2
+ -- ...
+ -- which is imported by vn
+ -- It retuns an import chain [w1, w2, ..wm]
+ -- where w1 imports w2 imports .... imports wm imports w1
+ shortest visited m
+ | m `elem` visited
+ = m : reverse (takeWhile (/= m) visited)
+ | otherwise
+ = minWith length (map (shortest (m:visited)) deps)
+ where
+ Just deps = Map.lookup m dep_env
+
+ show_path [] = panic "show_path"
+ show_path [m] = ptext (sLit "module") <+> quotes (ppr m)
+ <+> ptext (sLit "imports itself")
+ show_path (m1:m2:ms) = ptext (sLit "module") <+> quotes (ppr m1)
+ <+> sep ( nest 6 (ptext (sLit "imports") <+> quotes (ppr m2))
+ : go ms)
+ where
+ go [] = [ptext (sLit "which imports") <+> quotes (ppr m1)]
+ go (m:ms) = (ptext (sLit "which imports") <+> quotes (ppr m)) : go ms
+
+minWith :: Ord b => (a -> b) -> [a] -> a
+minWith get_key xs = ASSERT( not (null xs) )
+ head (sortWith get_key xs)
= do { ty' <- kc_check_lhs_type ty exp_kind; return (HsParTy ty') }
kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind
- = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 ty2
+ = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
; (fun_ty', fun_kind) <- kc_lhs_type fun_ty
; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind
; return (mkHsAppTys fun_ty' arg_tys') }
return (HsOpTy ty1' op ty2', res_kind)
kc_hs_type (HsAppTy ty1 ty2) = do
+ let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
(fun_ty', fun_kind) <- kc_lhs_type fun_ty
(arg_tys', res_kind) <- kcApps fun_ty fun_kind arg_tys
return (mkHsAppTys fun_ty' arg_tys', res_kind)
- where
- (fun_ty, arg_tys) = splitHsAppTys ty1 ty2
kc_hs_type (HsPredTy pred)
= wrongPredErr pred
-- This improves error message; Trac #2994
; kc_check_lhs_types args_w_kinds }
-splitHsAppTys :: LHsType Name -> LHsType Name -> (LHsType Name, [LHsType Name])
-splitHsAppTys fun_ty arg_ty = split fun_ty [arg_ty]
- where
- split (L _ (HsAppTy f a)) as = split f (a:as)
- split f as = (f,as)
-
-mkHsAppTys :: LHsType Name -> [LHsType Name] -> HsType Name
-mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
-mkHsAppTys fun_ty (arg_ty:arg_tys)
- = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
- where
- mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of
- -- the application; they are
- -- never used
---------------------------
splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind)
check_pred_ty dflags ctxt pred@(EqPred ty1 ty2)
= do { -- Equational constraints are valid in all contexts if type
-- families are permitted
- ; checkTc (xopt Opt_TypeFamilies dflags) (eqPredTyErr pred)
+ ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags)
+ (eqPredTyErr pred)
; checkTc (case ctxt of ClassSCCtxt {} -> False; _ -> True)
(eqSuperClassErr pred)
badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred
eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred
$$
- parens (ptext (sLit "Use -XTypeFamilies to permit this"))
+ parens (ptext (sLit "Use -XGADTs or -XTypeFamilies to permit this"))
predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"),
nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)]
dupPredWarn :: [[PredType]] -> SDoc