import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
-import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
+import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
import RnEnv ( lookupLocalDataTcNames,
lookupLocatedTopBndrRn, lookupLocatedOccRn,
lookupOccRn, newLocalsRn,
import NameEnv
import OccName ( occEnvElts )
import Outputable
-import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
+import SrcLoc ( Located(..), unLoc, noLoc )
import DynFlags ( DynFlag(..) )
import Maybes ( seqMaybe )
import Maybe ( isNothing )
%*********************************************************
\begin{code}
-rnHsForeignDecl (ForeignImport name ty spec isDeprec)
+rnHsForeignDecl (ForeignImport name ty spec)
= lookupLocatedTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignImport name' ty' spec isDeprec, fvs)
+ returnM (ForeignImport name' ty' spec, fvs)
-rnHsForeignDecl (ForeignExport name ty spec isDeprec)
+rnHsForeignDecl (ForeignExport name ty spec)
= lookupLocatedOccRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- returnM (ForeignExport name' ty' spec isDeprec, fvs )
+ returnM (ForeignExport name' ty' spec, fvs )
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
-- be imported from another module
extendTyVarEnvForMethodBinds inst_tyvars (
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
- rnMethodBinds cls [] mbinds
+ rnMethodBinds cls (\n->[]) -- No scoped tyvars
+ [] mbinds
) `thenM` \ (mbinds', meth_fvs) ->
-- Rename the prags and signatures.
-- Note that the type variables are not in scope here,
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}
in
checkDupNames meth_doc meth_rdr_names_w_locs `thenM_`
newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars ->
- rnMethodBinds (unLoc cname') gen_tyvars mbinds
+ rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
) `thenM` \ (mbinds', meth_fvs) ->
returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
; bindTyVarsRn doc tvs' $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
; new_details <- rnConDetails doc details
- ; new_res_ty <- rnConResult doc res_ty
- ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
- ; traceRn (text "****** - autrijus" <> ppr rv)
- ; return rv } }
+ ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
+ ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
-rnConResult _ ResTyH98 = return ResTyH98
-rnConResult doc (ResTyGADT ty) = do
+rnConResult _ details ResTyH98 = return (details, ResTyH98)
+
+rnConResult doc details (ResTyGADT ty) = do
ty' <- rnHsSigType doc ty
- return $ ResTyGADT ty'
+ let (arg_tys, res_ty) = splitHsFunType ty'
+ -- We can split it up, now the renamer has dealt with fixities
+ case details of
+ PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
+ RecCon fields -> return (details, ResTyGADT ty')
+ InfixCon {} -> panic "rnConResult"
rnConDetails doc (PrefixCon tys)
= mappM (rnLHsType doc) tys `thenM` \ new_tys ->
projects / ghc-hetmet.git / blobdiff