Skip to content
Snippets Groups Projects
Commit 33208bb4 authored by batterseapower's avatar batterseapower
Browse files

Give an error message for INLINE/SPECIALISE for missing default method

Basically, if the user has written:

  class Foo a where
    bar :: a -> a
    {-# INLINE bar #-}

Then we should error out because there is no default method corresponding
to the `bar' INLINE pragma. This patch achieves this by splitting the
signatures for a class declaration apart into two sets: one that applies
to the defaults (INLINE, SPECIALISE), and one which defines the class itself
(fixity, type signatures). The two sets are then renamed in different contexts.
parent 1ecf3fd2
No related merge requests found
......@@ -55,6 +55,7 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import Control.Monad
import Maybes( orElse )
import Data.Maybe
import Data.List
\end{code}
\begin{code}
......@@ -521,8 +522,8 @@ type variable environment iff -fglasgow-exts
\begin{code}
extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
-> RnM (Bag (LHsBind Name), FreeVars)
-> RnM (Bag (LHsBind Name), FreeVars)
-> RnM (a, FreeVars)
-> RnM (a, FreeVars)
extendTyVarEnvForMethodBinds tyvars thing_inside
= do { scoped_tvs <- xoptM Opt_ScopedTypeVariables
; if scoped_tvs then
......@@ -791,19 +792,28 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
= do { cname' <- lookupLocatedTopBndrRn cname
-- Split the signatures into those that apply to the class *methods*
-- and those that apply to the default instance *implementations*
; let isMethodLSig (L _ sig) = case sig of
TypeSig _ _ -> True
IdSig _ -> True
FixSig _ -> True
_ -> False
(method_sigs, default_sigs) = partition isMethodLSig sigs
-- Tyvars scope over superclass context and method signatures
; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
; ((tyvars', context', fds', ats', method_sigs'), stuff_fvs)
<- bindTyVarsFV tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars
{ context' <- rnContext cls_doc context
; fds' <- rnFds cls_doc fds
; (ats', at_fvs) <- rnATs ats
; sigs' <- renameSigs Nothing okClsDclSig sigs
; method_sigs' <- renameSigs Nothing okClsDclSig method_sigs
; let fvs = at_fvs `plusFV`
extractHsCtxtTyNames context' `plusFV`
hsSigsFVs sigs'
hsSigsFVs method_sigs'
-- The fundeps have no free variables
; return ((tyvars', context', fds', ats', sigs'), fvs) }
; return ((tyvars', context', fds', ats', method_sigs'), fvs) }
-- No need to check for duplicate associated type decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
......@@ -825,7 +835,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
-- op {| a*b |} (a*b) = ...
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
; (mbinds', meth_fvs)
; ((mbinds', default_sigs'), meth_fvs)
<- extendTyVarEnvForMethodBinds tyvars' $ do
{ name_env <- getLocalRdrEnv
; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
......@@ -834,13 +844,21 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
-- since that is done by RnNames.extendGlobalRdrEnvRn
-- and the methods are already in scope
; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
; (mbinds', mbinds_fvs) <- rnMethodBinds (unLoc cname') (mkSigTvFn method_sigs') gen_tyvars mbinds
-- Rename signatures that apply to the default implementations seperately,
-- supplying the list of names for which the user supplied a default. This
-- lets us error out if e.g. the user writes an INLINE signature for a method
-- signature without supplying a default implementation.
; let default_xs = mkNameSet (collectHsBindsBinders mbinds')
; default_sigs' <- renameSigs (Just default_xs) okClsDclSig default_sigs
; let fvs = mbinds_fvs `plusFV` hsSigsFVs default_sigs'
; return ((mbinds', default_sigs'), fvs) }
-- Haddock docs
; docs' <- mapM (wrapLocM rnDocDecl) docs
; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = method_sigs' ++ default_sigs',
tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
meth_fvs `plusFV` stuff_fvs) }
where
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment