import {-# SOURCE #-} RnExpr( rnLExpr )
import HsSyn
-import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts,
- GlobalRdrElt(..), isLocalGRE )
+import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv,
+ globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE )
import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import SrcLoc ( Located(..), unLoc, noLoc )
import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
-import Maybe ( isNothing )
+import Maybe ( isNothing, isJust )
+import Monad ( liftM, when )
import BasicTypes ( Boxity(..) )
\end{code}
%*********************************************************
\begin{code}
-rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
+rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- Used for both source and interface file decls
= rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' ->
+ -- Rename the associated types
+ -- The typechecker (not the renamer) checks that all
+ -- the declarations are for the right class
+ let
+ at_doc = text "In the associated types of an instance declaration"
+ at_names = map (head . tyClDeclNames . unLoc) ats
+ in
+ checkDupNames at_doc at_names `thenM_`
+ rnATInsts ats `thenM` \ (ats', at_fvs) ->
+
-- Rename the bindings
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
in
bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' ->
- returnM (InstDecl inst_ty' mbinds' uprags',
- meth_fvs `plusFV` hsSigsFVs uprags'
+ returnM (InstDecl inst_ty' mbinds' uprags' ats',
+ meth_fvs `plusFV` at_fvs
+ `plusFV` hsSigsFVs uprags'
`plusFV` extractHsTyNames inst_ty')
+ -- We return the renamed associated data type declarations so
+ -- that they can be entered into the list of type declarations
+ -- for the binding group, but we also keep a copy in the instance.
+ -- The latter is needed for well-formedness checks in the type
+ -- checker (eg, to ensure that all ATs of the instance actually
+ -- receive a declaration).
+ -- NB: Even the copies in the instance declaration carry copies of
+ -- the instance context after renaming. This is a bit
+ -- strange, but should not matter (and it would be more work
+ -- to remove the context).
+\end{code}
+
+Renaming of the associated types in instances.
+
+* We raise an error if we encounter a kind signature in an instance.
+
+\begin{code}
+rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATInsts atDecls =
+ mapFvRn (wrapLocFstM rnATInst) atDecls
+ where
+ rnATInst tydecl@TyFunction {} =
+ do
+ addErr noKindSig
+ rnTyClDecl tydecl
+ rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl
+ rnATInst tydecl@TyData {} =
+ do
+ checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
+ rnTyClDecl tydecl
+ rnATInst _ =
+ panic "RnSource.rnATInsts: not a type declaration"
+
+noKindSig = text "Instances cannot have kind signatures"
\end{code}
For the method bindings in class and instance decls, we extend the
rnLExpr lhs `thenM` \ (lhs', fv_lhs') ->
rnLExpr rhs `thenM` \ (rhs', fv_rhs') ->
- let
- mb_bad = validRuleLhs ids lhs'
- in
- checkErr (isNothing mb_bad)
- (badRuleLhsErr rule_name lhs' mb_bad) `thenM_`
- let
- bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
- in
- mappM (addErr . badRuleVar rule_name) bad_vars `thenM_`
+
+ checkValidRule rule_name ids lhs' fv_lhs' `thenM_`
+
returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
where
rn_var (RuleBndrSig (L loc v) t, id)
= rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
returnM (RuleBndrSig (L loc id) t', fvs)
+
+badRuleVar name var
+ = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
+ ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
+ ptext SLIT("does not appear on left hand side")]
\end{code}
-Check the shape of a transformation rule LHS. Currently
-we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
-not one of the @forall@'d variables. We also restrict the form of the LHS so
-that it may be plausibly matched. Basically you only get to write ordinary
-applications. (E.g. a case expression is not allowed: too elaborate.)
+Note [Rule LHS validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check the shape of a transformation rule LHS. Currently we only allow
+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
+@forall@'d variables.
-NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
+We used restrict the form of the 'ei' to prevent you writing rules
+with LHSs with a complicated desugaring (and hence unlikely to match);
+(e.g. a case expression is not allowed: too elaborate.)
+But there are legitimate non-trivial args ei, like sections and
+lambdas. So it seems simmpler not to check at all, and that is why
+check_e is commented out.
+
\begin{code}
+checkValidRule rule_name ids lhs' fv_lhs'
+ = do { -- Check for the form of the LHS
+ case (validRuleLhs ids lhs') of
+ Nothing -> return ()
+ Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
+
+ -- Check that LHS vars are all bound
+ ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
+ ; mappM (addErr . badRuleVar rule_name) bad_vars }
+
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
-- Nothing => OK
-- Just e => Not ok, and e is the offending expression
check (HsVar v) | v `notElem` foralls = Nothing
check other = Just other -- Failure
- checkl_e (L loc e) = check_e e
+ -- Check an argument
+ checkl_e (L loc e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
+{- Commented out; see Note [Rule LHS validity checking] above
check_e (HsVar v) = Nothing
check_e (HsPar e) = checkl_e e
check_e (HsLit e) = Nothing
check_e other = Just other -- Fails
checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
+-}
-badRuleLhsErr name lhs (Just bad_e)
+badRuleLhsErr name lhs bad_e
= sep [ptext SLIT("Rule") <+> ftext name <> colon,
nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
ptext SLIT("in left-hand side:") <+> ppr lhs])]
$$
ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
-
-badRuleVar name var
- = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
- ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
- ptext SLIT("does not appear on left hand side")]
\end{code}
returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
emptyFVs)
-rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
- tcdTyVars = tyvars, tcdCons = condecls,
- tcdKindSig = sig, tcdDerivs = derivs})
- | is_vanilla -- Normal Haskell data type decl
+rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
+ tcdLName = tycon, tcdTyVars = tyvars,
+ tcdTyPats = typatsMaybe, tcdCons = condecls,
+ tcdKindSig = sig, tcdDerivs = derivs})
+ | isKindSigDecl tydecl -- kind signature of indexed type
+ = rnTySig tydecl bindTyVarsRn
+ | is_vanilla -- Normal Haskell data type decl
= ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the
-- data type is syntactically illegal
bindTyVarsRn data_doc tyvars $ \ tyvars' ->
- do { tycon' <- lookupLocatedTopBndrRn tycon
+ do { tycon' <- if isIdxTyDecl tydecl
+ then lookupLocatedOccRn tycon -- may be imported family
+ else lookupLocatedTopBndrRn tycon
; context' <- rnContext data_doc context
+ ; typats' <- rnTyPats data_doc typatsMaybe
; (derivs', deriv_fvs) <- rn_derivs derivs
; checkDupNames data_doc con_names
; condecls' <- rnConDecls (unLoc tycon') condecls
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
- tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls',
- tcdDerivs = derivs'},
+ ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
+ tcdLName = tycon', tcdTyVars = tyvars',
+ tcdTyPats = typats', tcdKindSig = Nothing,
+ tcdCons = condecls', tcdDerivs = derivs'},
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context' `plusFV`
- plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs) }
-
- | otherwise -- GADT
- = do { tycon' <- lookupLocatedTopBndrRn tycon
+ plusFVs (map conDeclFVs condecls') `plusFV`
+ deriv_fvs `plusFV`
+ (if isIdxTyDecl tydecl
+ then unitFV (unLoc tycon') -- type instance => use
+ else emptyFVs))
+ }
+
+ | otherwise -- GADT
+ = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now
+ do { tycon' <- if isIdxTyDecl tydecl
+ then lookupLocatedOccRn tycon -- may be imported family
+ else lookupLocatedTopBndrRn tycon
; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
; tyvars' <- bindTyVarsRn data_doc tyvars
(\ tyvars' -> return tyvars')
; (derivs', deriv_fvs) <- rn_derivs derivs
; checkDupNames data_doc con_names
; condecls' <- rnConDecls (unLoc tycon') condecls
- ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
- tcdDerivs = derivs'},
- plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
-
+ ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
+ tcdLName = tycon', tcdTyVars = tyvars',
+ tcdTyPats = Nothing, tcdKindSig = sig,
+ tcdCons = condecls', tcdDerivs = derivs'},
+ plusFVs (map conDeclFVs condecls') `plusFV`
+ deriv_fvs `plusFV`
+ (if isIdxTyDecl tydecl
+ then unitFV (unLoc tycon') -- type instance => use
+ else emptyFVs))
+ }
where
is_vanilla = case condecls of -- Yuk
[] -> True
L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
other -> False
+ none Nothing = True
+ none (Just []) = True
+ none _ = False
+
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
con_names = map con_names_helper condecls
rn_derivs Nothing = returnM (Nothing, emptyFVs)
rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' ->
returnM (Just ds', extractHsTyNames_s ds')
-
-rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
- = lookupLocatedTopBndrRn name `thenM` \ name' ->
- bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) ->
- returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
- tcdSynRhs = ty'},
- delFVs (map hsLTyVarName tyvars') fvs)
+
+rnTyClDecl (tydecl@TyFunction {}) =
+ rnTySig tydecl bindTyVarsRn
+
+rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
+ tcdTyPats = typatsMaybe, tcdSynRhs = ty})
+ = bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
+ do { name' <- if isIdxTyDecl tydecl
+ then lookupLocatedOccRn name -- may be imported family
+ else lookupLocatedTopBndrRn name
+ ; typats' <- rnTyPats syn_doc typatsMaybe
+ ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
+ ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
+ tcdTyPats = typats', tcdSynRhs = ty'},
+ delFVs (map hsLTyVarName tyvars') $
+ fvs `plusFV`
+ (if isIdxTyDecl tydecl
+ then unitFV (unLoc name') -- type instance => use
+ else emptyFVs))
+ }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
- tcdMeths = mbinds})
+ tcdMeths = mbinds, tcdATs = ats})
= lookupLocatedTopBndrRn cname `thenM` \ cname' ->
-- Tyvars scope over superclass context and method signatures
bindTyVarsRn cls_doc tyvars ( \ tyvars' ->
rnContext cls_doc context `thenM` \ context' ->
rnFds cls_doc fds `thenM` \ fds' ->
+ rnATs ats `thenM` \ (ats', ats_fvs) ->
renameSigs okClsDclSig sigs `thenM` \ sigs' ->
- returnM (tyvars', context', fds', sigs')
- ) `thenM` \ (tyvars', context', fds', sigs') ->
+ returnM (tyvars', context', fds', (ats', ats_fvs), sigs')
+ ) `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
+
+ -- Check for duplicates among the associated types
+ let
+ at_rdr_names_w_locs = [tcdLName ty | L _ ty <- ats]
+ in
+ checkDupNames at_doc at_rdr_names_w_locs `thenM_`
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
) `thenM` \ (mbinds', meth_fvs) ->
- returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
- tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
+ returnM (ClassDecl { tcdCtxt = context', tcdLName = cname',
+ tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
+ tcdMeths = mbinds', tcdATs = ats'},
delFVs (map hsLTyVarName tyvars') $
extractHsCtxtTyNames context' `plusFV`
plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
hsSigsFVs sigs' `plusFV`
- meth_fvs)
+ meth_fvs `plusFV`
+ ats_fvs)
where
meth_doc = text "In the default-methods for class" <+> ppr cname
cls_doc = text "In the declaration for class" <+> ppr cname
sig_doc = text "In the signatures for class" <+> ppr cname
+ at_doc = text "In the associated types for class" <+> ppr cname
badGadtStupidTheta tycon
= vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
%*********************************************************
\begin{code}
+-- Although, we are processing type patterns here, all type variables will
+-- already be in scope (they are the same as in the 'tcdTyVars' field of the
+-- type declaration to which these patterns belong)
+--
+rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
+rnTyPats _ Nothing = return Nothing
+rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
+
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
rnConDecls tycon condecls
= mappM (wrapLocM rnConDecl) condecls
rnLHsType doc ty `thenM` \ new_ty ->
returnM (new_name, new_ty)
+-- Rename kind signatures (signatures of indexed data types/newtypes and
+-- signatures of type functions)
+--
+-- * This function is parametrised by the routine handling the index
+-- variables. On the toplevel, these are defining occurences, whereas they
+-- are usage occurences for associated types.
+--
+rnTySig :: TyClDecl RdrName
+ -> (SDoc -> [LHsTyVarBndr RdrName] ->
+ ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
+ RnM (TyClDecl Name, FreeVars))
+ -> RnM (TyClDecl Name, FreeVars)
+
+rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
+ tcdTyVars = tyvars, tcdTyPats = mb_typats,
+ tcdCons = condecls, tcdKindSig = sig,
+ tcdDerivs = derivs})
+ bindIdxVars =
+ ASSERT( null condecls ) -- won't have constructors
+ ASSERT( isNothing mb_typats ) -- won't have type patterns
+ ASSERT( isNothing derivs ) -- won't have deriving
+ ASSERT( isJust sig ) -- will have kind signature
+ do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1
+ ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
+ ; tycon' <- lookupLocatedTopBndrRn tycon
+ ; context' <- rnContext (ksig_doc tycon) context
+ ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context',
+ tcdLName = tycon', tcdTyVars = tyvars',
+ tcdTyPats = Nothing, tcdKindSig = sig,
+ tcdCons = [], tcdDerivs = Nothing},
+ delFVs (map hsLTyVarName tyvars') $
+ extractHsCtxtTyNames context')
+ } }
+ where
+
+rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
+ tcdKind = sig})
+ bindIdxVars =
+ do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1
+ ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
+ ; tycon' <- lookupLocatedTopBndrRn tycon
+ ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
+ tcdIso = tcdIso tydecl, tcdKind = sig},
+ emptyFVs)
+ } }
+
+ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
+needOneIdx = text "Kind signature requires at least one type index"
+
+-- Rename associated type declarations (in classes)
+--
+-- * This can be kind signatures and (default) type function equations.
+--
+rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
+rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
+ where
+ rn_at (tydecl@TyData {}) = rnTySig tydecl lookupIdxVars
+ rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
+ rn_at (tydecl@TySynonym {}) =
+ do
+ checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
+ rnTyClDecl tydecl
+ rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
+
+ lookupIdxVars _ tyvars cont =
+ do { checkForDups tyvars;
+ ; tyvars' <- mappM lookupIdxVar tyvars
+ ; cont tyvars'
+ }
+ -- Type index variables must be class parameters, which are the only
+ -- type variables in scope at this point.
+ lookupIdxVar (L l tyvar) =
+ do
+ name' <- lookupOccRn (hsTyVarName tyvar)
+ return $ L l (replaceTyVarName tyvar name')
+
+ -- Type variable may only occur once.
+ --
+ checkForDups [] = return ()
+ checkForDups (L loc tv:ltvs) =
+ do { setSrcSpan loc $
+ when (hsTyVarName tv `ltvElem` ltvs) $
+ addErr (repeatedTyVar tv)
+ ; checkForDups ltvs
+ }
+
+ rdrName `ltvElem` [] = False
+ rdrName `ltvElem` (L _ tv:ltvs)
+ | rdrName == hsTyVarName tv = True
+ | otherwise = rdrName `ltvElem` ltvs
+
+noPatterns = text "Default definition for an associated synonym cannot have"
+ <+> text "type pattern"
+
+repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
+ quotes (ppr tv)
+
-- This data decl will parse OK
-- data T = a Int
-- treating "a" as the constructor.
projects / ghc-hetmet.git / blobdiff