\begin{code}
module RnSource (
- rnSrcDecls, addTcgDUs, rnTyClDecls
+ rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
) where
#include "HsVersions.h"
import {-# SOURCE #-} RnExpr( rnLExpr )
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
+#endif /* GHCI */
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
lookupTopBndrRn, lookupLocatedTopBndrRn,
- lookupOccRn, newLocalBndrsRn,
+ lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
- bindTyVarsRn, extendTyVarEnvFVRn,
+ bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
bindLocalNames, checkDupRdrNames, mapFvRn
)
import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn )
import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
import TcRnMonad
+import ForeignCall ( CCallTarget(..) )
+import Module
import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import Name ( Name, nameOccName )
import Outputable
import Bag
import FastString
+import Util ( filterOut )
import SrcLoc
-import DynFlags ( DynFlag(..) )
+import DynFlags ( DynFlag(..), DynFlags, thisPackage )
+import HscTypes ( HscEnv, hsc_dflags )
import BasicTypes ( Boxity(..) )
+import ListSetOps ( findDupsEq )
-import ListSetOps (findDupsEq)
import Control.Monad
import Data.Maybe
-- It uses the fixity env from (A) to bind fixities for view patterns.
new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
-- bind the LHSes (and their fixities) in the global rdr environment
- let { val_binders = map unLoc $ collectHsValBinders new_lhs ;
+ let { val_binders = collectHsValBinders new_lhs ;
val_bndr_set = mkNameSet val_binders ;
all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
val_avails = map Avail val_binders
rnSrcWarnDecls bound_names decls
= do { -- check for duplicates
- ; mapM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
- ; mapM (addLocM rn_deprec) decls `thenM` \ pairs_s ->
- return (WarnSome ((concat pairs_s))) }
+ ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr))
+ warn_rdr_dups
+ ; pairs_s <- mapM (addLocM rn_deprec) decls
+ ; return (WarnSome ((concat pairs_s))) }
where
rn_deprec (Warning rdr_name txt)
-- ensures that the names are defined locally
\begin{code}
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
rnHsForeignDecl (ForeignImport name ty spec)
- = lookupLocatedTopBndrRn name `thenM` \ name' ->
+ = getTopEnv `thenM` \ (topEnv :: HscEnv) ->
+ lookupLocatedTopBndrRn name `thenM` \ name' ->
rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) ->
- return (ForeignImport name' ty' spec, fvs)
+
+ -- Mark any PackageTarget style imports as coming from the current package
+ let packageId = thisPackage $ hsc_dflags topEnv
+ spec' = patchForeignImport packageId spec
+
+ in return (ForeignImport name' ty' spec', fvs)
rnHsForeignDecl (ForeignExport name ty spec)
= lookupLocatedOccRn name `thenM` \ name' ->
fo_decl_msg :: Located RdrName -> SDoc
fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
+
+
+-- | For Windows DLLs we need to know what packages imported symbols are from
+-- to generate correct calls. Imported symbols are tagged with the current
+-- package, so if they get inlined across a package boundry we'll still
+-- know where they're from.
+--
+patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
+patchForeignImport packageId (CImport cconv safety fs spec)
+ = CImport cconv safety fs (patchCImportSpec packageId spec)
+
+patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
+patchCImportSpec packageId spec
+ = case spec of
+ CFunction callTarget -> CFunction $ patchCCallTarget packageId callTarget
+ _ -> spec
+
+patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
+patchCCallTarget packageId callTarget
+ = case callTarget of
+ StaticTarget label Nothing
+ -> StaticTarget label (Just packageId)
+
+ _ -> callTarget
+
+
\end{code}
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
let
- meth_doc = text "In the bindings in an instance declaration"
- meth_names = collectHsBindLocatedBinders mbinds
+ meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
- checkDupRdrNames meth_doc meth_names `thenM_`
+ checkDupRdrNames meth_names `thenM_`
-- Check that the same method is not given twice in the
-- same instance decl instance C T where
-- f x = ...
-- 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
- checkDupRdrNames at_doc at_names `thenM_`
+ checkDupRdrNames at_names `thenM_`
-- See notes with checkDupRdrNames for methods, above
rnATInsts ats `thenM` \ (ats', at_fvs) ->
--
-- But the (unqualified) method names are in scope
let
- binders = collectHsBindBinders mbinds'
+ binders = collectHsBindsBinders mbinds'
bndr_set = mkNameSet binders
in
bindLocalNames binders
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
= bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
- bindLocatedLocalsFV doc (map get_var vars) $ \ ids ->
+ bindLocatedLocalsFV (map get_var vars) $ \ ids ->
do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
-- NB: The binders in a rule are always Ids
-- We don't (yet) support type variables
-- all flavours of type family declarations ("type family", "newtype fanily",
-- and "data family")
-rnTyClDecl (tydecl@TyFamily {}) =
- rnFamily tydecl bindTyVarsRn
+rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
-- "data", "newtype", "data instance, and "newtype instance" declarations
rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdLName = tycon, tcdTyVars = tyvars,
- tcdTyPats = typatsMaybe, tcdCons = condecls,
+ tcdTyPats = typats, 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
- ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct
- do { bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
- { tycon' <- if isFamInstDecl tydecl
- then lookupLocatedOccRn tycon -- may be imported family
- else lookupLocatedTopBndrRn tycon
- ; context' <- rnContext data_doc context
- ; typats' <- rnTyPats data_doc typatsMaybe
- ; condecls' <- rnConDecls (unLoc tycon') condecls
- -- No need to check for duplicate constructor decls
- -- since that is done by RnNames.extendGlobalRdrEnvRn
- ; (derivs', deriv_fvs) <- rn_derivs derivs
- ; return (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 `plusFV`
- (if isFamInstDecl tydecl
- then unitFV (unLoc tycon') -- type instance => use
- else emptyFVs))
- } }
-
- | otherwise -- GADT
= do { tycon' <- if isFamInstDecl tydecl
then lookupLocatedOccRn tycon -- may be imported family
else lookupLocatedTopBndrRn tycon
- ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
- ; (tyvars', typats')
- <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
- { typats' <- rnTyPats data_doc typatsMaybe
- ; return (tyvars', typats') }
- -- For GADTs, the type variables in the declaration
- -- do not scope over the constructor signatures
- -- data T a where { T1 :: forall b. b-> b }
-
- ; condecls' <- rnConDecls (unLoc tycon') condecls
+ ; checkTc (h98_style || null (unLoc context))
+ (badGadtStupidTheta tycon)
+ ; ((tyvars', context', typats', derivs'), stuff_fvs)
+ <- bindTyVarsFV tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
+ { context' <- rnContext data_doc context
+ ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
+ ; (derivs', fvs2) <- rn_derivs derivs
+ ; let fvs = fvs1 `plusFV` fvs2 `plusFV`
+ extractHsCtxtTyNames context'
+ ; return ((tyvars', context', typats', derivs'), fvs) }
+
+ -- For the constructor declarations, bring into scope the tyvars
+ -- bound by the header, but *only* in the H98 case
+ -- Reason: for GADTs, the type variables in the declaration
+ -- do not scope over the constructor signatures
+ -- data T a where { T1 :: forall b. b-> b }
+ ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
+ | otherwise = []
+ ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
+ rnConDecls condecls
-- No need to check for duplicate constructor decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
- ; (derivs', deriv_fvs) <- rn_derivs derivs
- ; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
+ ; return (TyData {tcdND = new_or_data, tcdCtxt = context',
tcdLName = tycon', tcdTyVars = tyvars',
tcdTyPats = typats', tcdKindSig = sig,
tcdCons = condecls', tcdDerivs = derivs'},
- plusFVs (map conDeclFVs condecls') `plusFV`
- deriv_fvs `plusFV`
- (if isFamInstDecl tydecl
- then unitFV (unLoc tycon') -- type instance => use
- else emptyFVs))
+ con_fvs `plusFV` stuff_fvs)
}
where
- is_vanilla = case condecls of -- Yuk
- [] -> True
- L _ (ConDecl { con_res = ResTyH98 }) : _ -> True
- _ -> False
-
+ h98_style = case condecls of -- Note [Stupid theta]
+ L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False
+ _ -> True
+
data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
rn_derivs Nothing = return (Nothing, emptyFVs)
-- "type" and "type instance" declarations
rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
- tcdTyPats = typatsMaybe, tcdSynRhs = ty})
- = ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct
- do { bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do
- { name' <- if isFamInstDecl tydecl
- then lookupLocatedOccRn name -- may be imported family
- else lookupLocatedTopBndrRn name
- ; typats' <- rnTyPats syn_doc typatsMaybe
- ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
- ; return (TySynonym {tcdLName = name', tcdTyVars = tyvars',
- tcdTyPats = typats', tcdSynRhs = ty'},
- delFVs (map hsLTyVarName tyvars') $
- fvs `plusFV`
- (if isFamInstDecl tydecl
- then unitFV (unLoc name') -- type instance => use
- else emptyFVs))
- } }
+ tcdTyPats = typats, tcdSynRhs = ty})
+ = bindTyVarsFV tyvars $ \ tyvars' -> do
+ { -- Checks for distinct tyvars
+ name' <- if isFamInstDecl tydecl
+ then lookupLocatedOccRn name -- may be imported family
+ else lookupLocatedTopBndrRn name
+ ; (typats',fvs1) <- rnTyPats syn_doc name' typats
+ ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty
+ ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
+ , tcdTyPats = typats', tcdSynRhs = ty'},
+ fvs1 `plusFV` fvs2) }
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
= do { cname' <- lookupLocatedTopBndrRn cname
-- Tyvars scope over superclass context and method signatures
- ; (tyvars', context', fds', ats', ats_fvs, sigs')
- <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
+ ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
+ <- bindTyVarsFV tyvars $ \ tyvars' -> do
+ -- Checks for distinct tyvars
{ context' <- rnContext cls_doc context
; fds' <- rnFds cls_doc fds
- ; (ats', ats_fvs) <- rnATs ats
+ ; (ats', at_fvs) <- rnATs ats
; sigs' <- renameSigs Nothing okClsDclSig sigs
- ; return (tyvars', context', fds', ats', ats_fvs, sigs') }
+ ; let fvs = at_fvs `plusFV`
+ extractHsCtxtTyNames context' `plusFV`
+ hsSigsFVs sigs'
+ -- The fundeps have no free variables
+ ; return ((tyvars', context', fds', ats', sigs'), fvs) }
-- No need to check for duplicate associated type decls
-- since that is done by RnNames.extendGlobalRdrEnvRn
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
- ; checkDupRdrNames sig_doc sig_rdr_names_w_locs
+ ; checkDupRdrNames sig_rdr_names_w_locs
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
-- The renamer *could* check this for class decls, but can't
; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
-
- delFVs (map hsLTyVarName tyvars') $
- extractHsCtxtTyNames context' `plusFV`
- plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV`
- hsSigsFVs sigs' `plusFV`
- meth_fvs `plusFV`
- ats_fvs) }
+ meth_fvs `plusFV` stuff_fvs) }
where
cls_doc = text "In the declaration for class" <+> ppr cname
- sig_doc = text "In the signatures for class" <+> ppr cname
-
-distinctTyVarBndrs :: [LHsTyVarBndr RdrName] -> Bool
--- The tyvar binders should have distinct names
-distinctTyVarBndrs tvs
- = null (findDupsEq eq tvs)
- where
- eq (L _ v1) (L _ v2) = hsTyVarName v1 == hsTyVarName v2
badGadtStupidTheta :: Located RdrName -> SDoc
badGadtStupidTheta _
ptext (sLit "(You can put a context on each contructor, though.)")]
\end{code}
+Note [Stupid theta]
+~~~~~~~~~~~~~~~~~~~
+Trac #3850 complains about a regression wrt 6.10 for
+ data Show a => T a
+There is no reason not to allow the stupid theta if there are no data
+constructors. It's still stupid, but does no harm, and I don't want
+to cause programs to break unnecessarily (notably HList). So if there
+are no data constructors we allow h98_style = True
+
%*********************************************************
%* *
%*********************************************************
\begin{code}
+rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
-- 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
- = mapM (wrapLocM rnConDecl) condecls
+rnTyPats _ _ Nothing
+ = return (Nothing, emptyFVs)
+rnTyPats doc tc (Just typats)
+ = do { typats' <- rnLHsTypes doc typats
+ ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
+ -- type instance => use, hence addOneFV
+ ; return (Just typats', fvs) }
+
+rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
+rnConDecls condecls
+ = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
+ ; return (condecls', plusFVs (map conDeclFVs condecls')) }
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
- , con_cxt = cxt, con_details = details
- , con_res = res_ty, con_doc = mb_doc
- , con_old_rec = old_rec, con_explicit = expl })
+ , con_cxt = cxt, con_details = details
+ , con_res = res_ty, con_doc = mb_doc
+ , con_old_rec = old_rec, con_explicit = expl })
= do { addLocM checkConName name
; when old_rec (addWarn (deprecRecSyntax decl))
-
; new_name <- lookupLocatedTopBndrRn name
- ; name_env <- getLocalRdrEnv
-
- -- For H98 syntax, the tvs are the existential ones
- -- For GADT syntax, the tvs are all the quantified tyvars
- -- Hence the 'filter' in the ResTyH98 case only
- ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc
- arg_tys = hsConDeclArgTys details
- implicit_tvs = case res_ty of
- ResTyH98 -> filter not_in_scope $
- get_rdr_tvs arg_tys
- ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+
+ -- For H98 syntax, the tvs are the existential ones
+ -- For GADT syntax, the tvs are all the quantified tyvars
+ -- Hence the 'filter' in the ResTyH98 case only
+ ; rdr_env <- getLocalRdrEnv
+ ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc
+ arg_tys = hsConDeclArgTys details
+ implicit_tvs = case res_ty of
+ ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
+ ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
new_tvs = case expl of
Explicit -> tvs
Implicit -> userHsTyVarBndrs implicit_tvs
; mb_doc' <- rnMbLHsDoc mb_doc
- ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
+ ; bindTyVarsRn new_tvs $ \new_tyvars -> do
{ new_context <- rnContext doc cxt
; new_details <- rnConDeclDetails doc details
; (new_details', new_res_ty) <- rnConResult doc new_details res_ty
-- are usage occurences for associated types.
--
rnFamily :: TyClDecl RdrName
- -> (SDoc -> [LHsTyVarBndr RdrName] ->
+ -> ([LHsTyVarBndr RdrName] ->
([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
RnM (TyClDecl Name, FreeVars))
-> RnM (TyClDecl Name, FreeVars)
rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
tcdLName = tycon, tcdTyVars = tyvars})
bindIdxVars =
- do { bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
+ do { bindIdxVars tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
} }
rnFamily d _ = pprPanic "rnFamily" (ppr d)
-family_doc :: Located RdrName -> SDoc
-family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
-
-- Rename associated type declarations (in classes)
--
-- * This can be family declarations and (default) type instances
rnTyClDecl tydecl
rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
- lookupIdxVars _ tyvars cont =
- do { checkForDups tyvars;
+ lookupIdxVars tyvars cont =
+ do { checkForDups tyvars
; tyvars' <- mapM lookupIdxVar tyvars
; cont tyvars'
}
\end{code}
+%*********************************************************
+%* *
+ findSplice
+%* *
+%*********************************************************
+
+This code marches down the declarations, looking for the first
+Template Haskell splice. As it does so it
+ a) groups the declarations into a HsGroup
+ b) runs any top-level quasi-quotes
+
+\begin{code}
+findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
+findSplice ds = addl emptyRdrGroup ds
+
+addl :: HsGroup RdrName -> [LHsDecl RdrName]
+ -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
+-- This stuff reverses the declarations (again) but it doesn't matter
+addl gp [] = return (gp, Nothing)
+addl gp (L l d : ds) = add gp l d ds
+
+
+add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
+ -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
+
+add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
+ = do { -- We've found a top-level splice. If it is an *implicit* one
+ -- (i.e. a naked top level expression)
+ case flag of
+ Explicit -> return ()
+ Implicit -> do { th_on <- doptM Opt_TemplateHaskell
+ ; unless th_on $ setSrcSpan loc $
+ failWith badImplicitSplice }
+
+ ; return (gp, Just (splice, ds)) }
+ where
+ badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
+
+#ifndef GHCI
+add _ _ (QuasiQuoteD qq) _
+ = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
+#else
+add gp _ (QuasiQuoteD qq) ds -- Expand quasiquotes
+ = do { ds' <- runQuasiQuoteDecl qq
+ ; addl gp (ds' ++ ds) }
+#endif
+
+-- Class declarations: pull out the fixity signatures to the top
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
+ | isClassDecl d
+ = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
+ addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
+ | otherwise
+ = addl (gp { hs_tyclds = L l d : ts }) ds
+
+-- Signatures: fixity sigs go a different place than all others
+add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
+ = addl (gp {hs_fixds = L l f : ts}) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
+ = addl (gp {hs_valds = add_sig (L l d) ts}) ds
+
+-- Value declarations: use add_bind
+add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
+ = addl (gp { hs_valds = add_bind (L l d) ts }) ds
+
+-- The rest are routine
+add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds
+ = addl (gp { hs_instds = L l d : ts }) ds
+add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
+ = addl (gp { hs_derivds = L l d : ts }) ds
+add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
+ = addl (gp { hs_defds = L l d : ts }) ds
+add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
+ = addl (gp { hs_fords = L l d : ts }) ds
+add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
+ = addl (gp { hs_warnds = L l d : ts }) ds
+add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
+ = addl (gp { hs_annds = L l d : ts }) ds
+add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
+ = addl (gp { hs_ruleds = L l d : ts }) ds
+add gp l (DocD d) ds
+ = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
+
+add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
+add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
+add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
+
+add_sig :: LSig a -> HsValBinds a -> HsValBinds a
+add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
+add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
+\end{code}
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff