module RnSource (
rnSrcDecls, addTcgDUs,
rnTyClDecls, checkModDeprec,
- rnBindGroups, rnBindGroupsAndThen
+ rnBindGroups, rnBindGroupsAndThen, rnSplice
) where
#include "HsVersions.h"
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv )
import RdrHsSyn ( extractGenericPatTyVars )
import RnHsSyn
-import RnExpr ( rnLExpr )
-import RnTypes ( rnLHsType, rnHsSigType, rnHsTypeFVs, rnContext )
+import RnExpr ( rnLExpr, checkTH )
+import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopBinds, rnBinds, rnMethodBinds,
rnBindsAndThen, renameSigs, checkSigs )
import RnEnv ( lookupTopBndrRn, lookupTopFixSigNames,
import HscTypes ( FixityEnv, FixItem(..),
Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
import Class ( FunDep )
-import Name ( Name )
+import Name ( Name, nameOccName )
import NameSet
import NameEnv
import Outputable
-import SrcLoc ( Located(..), unLoc, getLoc )
+import SrcLoc ( Located(..), unLoc, getLoc, noLoc )
import CmdLineOpts ( DynFlag(..) )
-- Warn of unused for-all'd tyvars
import Maybes ( seqMaybe )
other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
src_fvs4, src_fvs5] ;
src_dus = bind_dus `plusDU` usesOnly other_fvs
+ -- Note: src_dus will contain *uses* for locally-defined types
+ -- and classes, but no *defs* for them. (Because rnTyClDecl
+ -- returns only the uses.) This is a little
+ -- surprising but it doesn't actually matter at all.
} ;
traceRn (text "finish rnSrc" <+> ppr rn_group) ;
+ traceRn (text "finish Dus" <+> ppr src_dus ) ;
tcg_env <- getGblEnv ;
return (tcg_env `addTcgDUs` src_dus, rn_group)
}}}
rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv
rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity))
- = addSrcSpan loc $
+ = setSrcSpan loc $
-- GHC extension: look up both the tycon and data con
-- for con-like things
-- If neither are in scope, report an error; otherwise
returnM fix_env
Nothing -> returnM (extendNameEnv fix_env name fix_item)
where
- fix_item = FixItem (rdrNameOcc (unLoc rdr_name)) fixity
- (getLoc rdr_name)
+ fix_item = FixItem (nameOccName name) fixity (getLoc rdr_name)
pprFixEnv :: FixityEnv -> SDoc
pprFixEnv env
rnBindGroups :: [HsBindGroup RdrName] -> RnM ([HsBindGroup Name], DefUses)
-- This version assumes that the binders are already in scope
-- It's used only in 'mdo'
-rnBindGropus []
+rnBindGroups []
= returnM ([], emptyDUs)
rnBindGroups [HsBindGroup bind sigs _]
= rnBinds NotTopLevel bind sigs
emptyFVs)
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
- tcdTyVars = tyvars, tcdCons = condecls,
- tcdDerivs = derivs})
- = lookupLocatedTopBndrRn tycon `thenM` \ tycon' ->
+ tcdTyVars = tyvars, tcdCons = condecls,
+ tcdKindSig = sig, tcdDerivs = derivs})
+ | 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' ->
- rnContext data_doc context `thenM` \ context' ->
- rn_derivs derivs `thenM` \ (derivs', deriv_fvs) ->
- checkDupNames data_doc con_names `thenM_`
- rnConDecls (unLoc tycon') condecls `thenM` \ condecls' ->
- returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
- tcdTyVars = tyvars', tcdCons = condecls',
- tcdDerivs = derivs'},
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs)
+ do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; context' <- rnContext data_doc context
+ ; (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'},
+ delFVs (map hsLTyVarName tyvars') $
+ extractHsCtxtTyNames context' `plusFV`
+ plusFVs (map conDeclFVs condecls') `plusFV`
+ deriv_fvs) }
+
+ | otherwise -- GADT
+ = ASSERT( null (unLoc context) )
+ do { tycon' <- lookupLocatedTopBndrRn tycon
+ ; tyvars' <- bindTyVarsRn data_doc tyvars
+ (\ tyvars' -> return tyvars')
+ -- For GADTs, the type variables in the declaration
+ -- do not scope over the constructor signatures
+ -- data T a where { T1 :: forall b. b-> b }
+ ; (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) }
+
where
+ is_vanilla = case condecls of -- Yuk
+ [] -> True
+ L _ (ConDecl {}) : _ -> True
+ other -> False
+
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
- con_names = [ n | L _ (ConDecl n _ _ _) <- condecls ]
+ con_names = map con_names_helper condecls
+
+ con_names_helper (L _ (ConDecl n _ _ _)) = n
+ con_names_helper (L _ (GadtDecl n _)) = n
rn_derivs Nothing = returnM (Nothing, emptyFVs)
- rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' ->
- returnM (Just ds', extractHsCtxtTyNames ds')
+ 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' ->
where
doc = text "In the definition of data constructor" <+> quotes (ppr name)
+rnConDecl (GadtDecl name ty)
+ = addLocM checkConName name `thenM_`
+ lookupLocatedTopBndrRn name `thenM` \ new_name ->
+ rnHsSigType doc ty `thenM` \ new_ty ->
+ returnM (GadtDecl new_name new_ty)
+ where
+ doc = text "In the definition of data constructor" <+> quotes (ppr name)
+
rnConDetails doc (PrefixCon tys)
- = mappM (rnLBangTy doc) tys `thenM` \ new_tys ->
+ = mappM (rnLHsType doc) tys `thenM` \ new_tys ->
returnM (PrefixCon new_tys)
rnConDetails doc (InfixCon ty1 ty2)
- = rnLBangTy doc ty1 `thenM` \ new_ty1 ->
- rnLBangTy doc ty2 `thenM` \ new_ty2 ->
+ = rnLHsType doc ty1 `thenM` \ new_ty1 ->
+ rnLHsType doc ty2 `thenM` \ new_ty2 ->
returnM (InfixCon new_ty1 new_ty2)
rnConDetails doc (RecCon fields)
rnField doc (name, ty)
= lookupLocatedTopBndrRn name `thenM` \ new_name ->
- rnLBangTy doc ty `thenM` \ new_ty ->
+ rnLHsType doc ty `thenM` \ new_ty ->
returnM (new_name, new_ty)
-rnLBangTy doc = wrapLocM (rnBangTy doc)
-
-rnBangTy doc (BangType s ty)
- = rnLHsType doc ty `thenM` \ new_ty ->
- returnM (BangType s new_ty)
-
-- This data decl will parse OK
-- data T = a Int
-- treating "a" as the constructor.
rnHsTyvar doc tyvar = lookupOccRn tyvar
\end{code}
+
+%*********************************************************
+%* *
+ Splices
+%* *
+%*********************************************************
+
+\begin{code}
+rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
+rnSplice (HsSplice n expr)
+ = checkTH expr "splice" `thenM_`
+ getSrcSpanM `thenM` \ loc ->
+ newLocalsRn [L loc n] `thenM` \ [n'] ->
+ rnLExpr expr `thenM` \ (expr', fvs) ->
+ returnM (HsSplice n' expr', fvs)
+\end{code}
projects / ghc-hetmet.git / blobdiff