import HsSyn
import Class (FunDep)
import PrelNames ( rationalTyConName, integerTyConName, negateName )
-import OccName ( isDataOcc, isTvOcc, occNameUserString )
+import OccName ( isDataOcc, isTvOcc, occNameString )
-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
-- we do this by removing varName from the import of OccName above, making
-- a qualified instance of OccName and using OccNameAlias.varName where varName
-- ws previously used in this file.
import qualified OccName
-import Module ( Module, mkModule, moduleUserString )
+import Module ( Module, mkModule, moduleString )
import Id ( Id, mkLocalId )
-import OccName ( mkOccFS )
+import OccName ( mkOccNameFS )
import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule,
isExternalName, getSrcLoc )
import NameEnv
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
import BasicTypes ( isBoxed )
import Outputable
-import Bag ( bagToList )
+import Bag ( bagToList, unionManyBags )
import FastString ( unpackFS )
-import ForeignCall ( Safety(..), ForeignCall(..), CCallConv(..),
- CCallTarget(..) )
+import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
import Monad ( zipWithM )
import List ( sortBy )
decls <- addBinds ss (do {
- val_ds <- mapM rep_bind_group (hs_valds group) ;
+ val_ds <- rep_val_binds (hs_valds group) ;
tycl_ds <- mapM repTyClD (hs_tyclds group) ;
inst_ds <- mapM repInstD' (hs_instds group) ;
for_ds <- mapM repForD (hs_fords group) ;
-- more needed
- return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
+ return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
decl_ty <- lookupType decQTyConName ;
let { core_list = coreList' decl_ty decls } ;
groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_fords = foreign_decls })
-- Collect the binders of a Group
- = collectGroupBinders val_decls ++
+ = collectHsValBinders val_decls ++
[n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
[n | L _ (ForeignImport n _ _ _) <- foreign_decls]
cxt1 <- repLContext cxt ;
sigs1 <- rep_sigs sigs ;
binds1 <- rep_binds meth_binds ;
- fds1 <- repLFunDeps fds;
+ fds1 <- repLFunDeps fds;
decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
bndrs1 <- coreList nameTyConName bndrs ;
repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
return $ Just (loc, dec) }
-- Un-handled cases
-repTyClD (L loc d) = do { dsWarn (loc, hang ds_msg 4 (ppr d)) ;
- return Nothing
- }
+repTyClD (L loc d) = putSrcSpanDs loc $
+ do { dsWarn (hang ds_msg 4 (ppr d))
+ ; return Nothing }
-- represent fundeps
--
-------------------------------------------------------
repC :: LConDecl Name -> DsM (Core TH.ConQ)
-repC (L loc (ConDecl con [] (L _ []) details))
+repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
= do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences]
repConstr con1 details }
-repC (L loc (ConDecl con tvs (L cloc ctxt) details))
+repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
= do { addTyVarBinds tvs $ \bndrs -> do {
- c' <- repC (L loc (ConDecl con [] (L cloc []) details));
+ c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
ctxt' <- repContext ctxt;
bndrs' <- coreList nameTyConName bndrs;
rep2 forallCName [unC bndrs', unC ctxt', unC c']
}
}
-repC (L loc con_decl)
- = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
+repC (L loc con_decl) -- GADTs
+ = putSrcSpanDs loc $
+ do { dsWarn (hang ds_msg 4 (ppr con_decl))
; return (panic "DsMeta:repC") }
--- gaw 2004 FIX! Need a case for GadtDecl
-
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy ty= do
MkC s <- rep2 str []
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-- Singleton => Ok
-- Empty => Too hard, signature ignored
-rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc
-rep_sig other = return []
+rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig other = return []
rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
-- FIXME: I haven't got the types here right yet
repE (HsDo DoExpr sts body ty)
= do { (ss,zs) <- repLSts sts;
- body' <- repLE body;
+ body' <- addBinds ss $ repLE body;
ret <- repNoBindSt body';
e <- repDoE (nonEmptyCoreList (zs ++ [ret]));
wrapGenSyns ss e }
repE (HsDo ListComp sts body ty)
= do { (ss,zs) <- repLSts sts;
- body' <- repLE body;
+ body' <- addBinds ss $ repLE body;
ret <- repNoBindSt body';
e <- repComp (nonEmptyCoreList (zs ++ [ret]));
wrapGenSyns ss e }
return ([], x) }
process (L _ (GRHS ss rhs))
= do (gs, ss') <- repLSts ss
- rhs' <- repLE rhs
+ rhs' <- addBinds gs $ repLE rhs
g <- repPatGE (nonEmptyCoreList ss') rhs'
return (gs, g)
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
; return (ss2, z : zs) }
-repSts [] = panic "repSts ran out of statements"
+repSts [] = return ([],[])
repSts other = panic "Exotic Stmt in meta brackets"
-- Bindings
-----------------------------------------------------------
-repBinds :: [HsBindGroup Name] -> DsM ([GenSymBind], Core [TH.DecQ])
-repBinds decs
- = do { let { bndrs = map unLoc (collectGroupBinders decs) }
+repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
+repBinds EmptyLocalBinds
+ = do { core_list <- coreList decQTyConName []
+ ; return ([], core_list) }
+
+repBinds (HsIPBinds _)
+ = panic "DsMeta:repBinds: can't do implicit parameters"
+
+repBinds (HsValBinds decs)
+ = do { let { bndrs = map unLoc (collectHsValBinders decs) }
-- No need to worrry about detailed scopes within
-- the binding group, because we are talking Names
-- here, so we can safely treat it as a mutually
-- recursive group
; ss <- mkGenSyms bndrs
- ; core <- addBinds ss (rep_bind_groups decs)
- ; core_list <- coreList decQTyConName core
+ ; prs <- addBinds ss (rep_val_binds decs)
+ ; core_list <- coreList decQTyConName
+ (de_loc (sort_by_loc prs))
; return (ss, core_list) }
-rep_bind_groups :: [HsBindGroup Name] -> DsM [Core TH.DecQ]
+rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
-- Assumes: all the binders of the binding are alrady in the meta-env
-rep_bind_groups binds = do
- locs_cores_s <- mapM rep_bind_group binds
- return $ de_loc $ sort_by_loc (concat locs_cores_s)
-
-rep_bind_group :: HsBindGroup Name -> DsM [(SrcSpan, Core TH.DecQ)]
--- Assumes: all the binders of the binding are alrady in the meta-env
-rep_bind_group (HsBindGroup bs sigs _)
- = do { core1 <- mapM rep_bind (bagToList bs)
+rep_val_binds (ValBindsOut binds sigs)
+ = do { core1 <- rep_binds' (unionManyBags (map snd binds))
; core2 <- rep_sigs' sigs
; return (core1 ++ core2) }
-rep_bind_group (HsIPBinds _)
- = panic "DsMeta:repBinds: can't do implicit parameters"
rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
--- Assumes: all the binders of the binding are alrady in the meta-env
-rep_binds binds = do
- locs_cores <- mapM rep_bind (bagToList binds)
- return $ de_loc $ sort_by_loc locs_cores
+rep_binds binds = do { binds_w_locs <- rep_binds' binds
+ ; return (de_loc (sort_by_loc binds_w_locs)) }
+
+rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_binds' binds = mapM rep_bind (bagToList binds)
rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
-- Assumes: all the binders of the binding are alrady in the meta-env
-- Note GHC treats declarations of a variable (not a pattern)
-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match
-- with an empty list of patterns
-rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _)))
+rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _) _))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupLBinder fn
; ans' <- wrapGenSyns ss ans
; return (loc, ans') }
-rep_bind (L loc (FunBind fn infx (MatchGroup ms _)))
+rep_bind (L loc (FunBind fn infx (MatchGroup ms _) _))
= do { ms1 <- mapM repClauseTup ms
; fn' <- lookupLBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
; return (loc, ans) }
-rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2))
+rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2 _))
= do { patcore <- repLP pat
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] [])))
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
= do { mb_val <- dsLookupMetaEnv n;
case mb_val of
Just (Bound x) -> return (coreVar x)
- other -> pprPanic "Failed binder lookup:" (ppr n) }
+ other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
-- Look up a name that is either locally bound or a global name
--
; MkC uni <- coreIntLit (getKey (getUnique name))
; rep2 mkNameLName [occ,uni] }
where
- name_mod = moduleUserString (nameModule name)
+ name_mod = moduleString (nameModule name)
name_occ = nameOccName name
mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
| OccName.isVarOcc name_occ = mkNameG_vName
; return (NonRec id var) }
occNameLit :: Name -> DsM (Core String)
-occNameLit n = coreStringLit (occNameUserString (nameOccName n))
+occNameLit n = coreStringLit (occNameString (nameOccName n))
-- %*********************************************************************
thLib = mkModule "Language.Haskell.TH.Lib"
mk_known_key_name mod space str uniq
- = mkExternalName uniq mod (mkOccFS space str)
+ = mkExternalName uniq mod (mkOccNameFS space str)
Nothing noSrcLoc
libFun = mk_known_key_name thLib OccName.varName
projects / ghc-hetmet.git / blobdiff