import TcPat
import TcMType
import TcType
-import RnBinds( misplacedSigErr )
import Coercion
import TysPrim
import Id
import Outputable
import FastString
-import Data.List( partition )
import Control.Monad
#include "HsVersions.h"
tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
= setSrcSpan loc $
recoverM (recoveryCode binder_names sig_fn) $ do
- -- Set up main recoer; take advantage of any type sigs
+ -- Set up main recover; take advantage of any type sigs
{ traceTc "------------------------------------------------" empty
; traceTc "Bindings for" (ppr binder_names)
+ -- Instantiate the polytypes of any binders that have signatures
+ -- (as determined by sig_fn), returning a TcSigInfo for each
; tc_sig_fn <- tcInstSigs sig_fn binder_names
; dflags <- getDOpts
; return (binds, poly_ids) }
where
binder_names = collectHsBindListBinders bind_list
- loc = getLoc (head bind_list)
- -- TODO: location a bit awkward, but the mbinds have been
- -- dependency analysed and may no longer be adjacent
+ loc = foldr1 combineSrcSpans (map getLoc bind_list)
+ -- The mbinds have been dependency analysed and
+ -- may no longer be adjacent; so find the narrowest
+ -- span that includes them all
------------------
tcPolyNoGen
-- it binds a single variable,
-- it has a signature,
tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped
- , sig_theta = theta, sig_tau = tau, sig_loc = loc })
+ , sig_theta = theta, sig_tau = tau })
prag_fn rec_tc bind_list
= do { ev_vars <- newEvVars theta
; let skol_info = SigSkol (FunSigCtxt (idName id)) (mkPhiTy theta tau)
; export <- mkExport prag_fn tvs theta mono_info
+ ; loc <- getSrcSpanM
; let (_, poly_id, _, _) = export
abs_bind = L loc $ AbsBinds
{ abs_tvs = tvs
-- dependencies based on type signatures
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
-tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
+tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list
= do { ((binds', mono_infos), wanted)
<- captureConstraints $
- tcMonoBinds sig_fn LetLclBndr rec_tc bind_list
+ tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
--------------
tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
+-- SPECIALISE pragamas for imported things
tcImpPrags prags
= do { this_mod <- getModule
- ; let is_imp prag
- = case sigName prag of
- Nothing -> False
- Just name -> not (nameIsLocalOrFrom this_mod name)
- (spec_prags, others) = partition isSpecLSig $
- filter is_imp prags
- ; mapM_ misplacedSigErr others
- -- Messy that this misplaced-sig error comes here
- -- but the others come from the renamer
- ; mapAndRecoverM (wrapLocM tcImpSpec) spec_prags }
-
-tcImpSpec :: Sig Name -> TcM TcSpecPrag
-tcImpSpec prag@(SpecSig (L _ name) _ _)
+ ; dflags <- getDOpts
+ ; if (not_specialising dflags) then
+ return []
+ else
+ mapAndRecoverM (wrapLocM tcImpSpec)
+ [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
+ , not (nameIsLocalOrFrom this_mod name) ] }
+ where
+ -- Ignore SPECIALISE pragmas for imported things
+ -- when we aren't specialising, or when we aren't generating
+ -- code. The latter happens when Haddocking the base library;
+ -- we don't wnat complaints about lack of INLINABLE pragmas
+ not_specialising dflags
+ | not (dopt Opt_Specialise dflags) = True
+ | otherwise = case hscTarget dflags of
+ HscNothing -> True
+ HscInterpreted -> True
+ _other -> False
+
+tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag
+tcImpSpec (name, prag)
= do { id <- tcLookupId name
- ; checkTc (isAnyInlinePragma (idInlinePragma id))
- (impSpecErr name)
+ ; unless (isAnyInlinePragma (idInlinePragma id))
+ (addWarnTc (impSpecErr name))
; tcSpec id prag }
-tcImpSpec p = pprPanic "tcImpSpec" (ppr p)
impSpecErr :: Name -> SDoc
impSpecErr name
= hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name))
2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma")
- , ptext (sLit "(or you compiled its defining module without -O)")])
+ , parens $ sep
+ [ ptext (sLit "or its defining module") <+> quotes (ppr mod)
+ , ptext (sLit "was compiled without -O")]])
+ where
+ mod = nameModule name
--------------
-tcVectDecls :: [LVectDecl Name] -> TcM [LVectDecl TcId]
+tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
tcVectDecls decls
= do { decls' <- mapM (wrapLocM tcVect) decls
; let ids = [unLoc id | L _ (HsVect id _) <- decls']
dups = findDupsEq (==) ids
; mapM_ reportVectDups dups
+ ; traceTcConstraints "End of tcVectDecls"
; return decls'
}
where
tcVect (HsVect name Nothing)
= addErrCtxt (vectCtxt name) $
do { id <- wrapLocM tcLookupId name
- ; return (HsVect id Nothing)
+ ; return $ HsVect id Nothing
}
tcVect (HsVect name@(L loc _) (Just rhs))
= addErrCtxt (vectCtxt name) $
; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind]
; traceTc "tcVect inferred type" $ ppr (varType id')
+ ; traceTc "tcVect bindings" $ ppr binds
- -- add the type variable and dictionary bindings produced by type generalisation to the
- -- right-hand side of the vectorisation declaration
+ -- add all bindings, including the type variable and dictionary bindings produced by type
+ -- generalisation to the right-hand side of the vectorisation declaration
; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
; let [bind'] = bagToList actualBinds
MatchGroup
-- where F is a type function and (F a ~ [a])
-- Then unification might succeed with a coercion. But it's much
-- much simpler to require that such signatures have identical contexts
- checkTc (all isIdentityCoI cois)
+ checkTc (all isReflCo cois)
(ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
}
\end{code}
projects / ghc-hetmet.git / blobdiff