diff options
| author | simonpj <unknown> | 2002-10-09 15:04:01 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2002-10-09 15:04:01 +0000 |
| commit | 8c1b6bd7ffb9ce97da7a72f9e102998df19b23a2 (patch) | |
| tree | b68c5ea5e4e8ad7baa6515e7c063b9ed43b1e30f /ghc/compiler | |
| parent | d04fb5dc5364513882e3e7619bfb4d459fc3ed51 (diff) | |
| download | haskell-8c1b6bd7ffb9ce97da7a72f9e102998df19b23a2.tar.gz | |
[project @ 2002-10-09 15:03:48 by simonpj]
-----------------------------------
Lots more Template Haskell stuff
-----------------------------------
At last! Top-level declaration splices work!
Syntax is
$(f x)
not "splice (f x)" as in the paper.
Lots jiggling around, particularly with the top-level plumbining.
Note the new data type HsDecls.HsGroup.
Diffstat (limited to 'ghc/compiler')
39 files changed, 1595 insertions, 961 deletions
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 9dd5e1b936..305399a6f1 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.223 2002/09/16 10:16:14 simonmar Exp $ +# $Id: Makefile,v 1.224 2002/10/09 15:03:48 simonpj Exp $ TOP = .. @@ -137,9 +137,9 @@ endif # Only include GHCi if we're bootstrapping with at least version 411 ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES" # Yes, include the interepreter, readline, and Template Haskell extensions -SRC_HC_OPTS += -DGHCI -package readline -package haskell-src +SRC_HC_OPTS += -DGHCI -package haskell-src ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32" -SRC_HC_OPTS += -package unix +SRC_HC_OPTS += -package unix -package readline endif ALL_DIRS += ghci else diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 06444e3a8c..fdaef1a232 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -99,9 +99,11 @@ import Demand hiding( Demand, seqDemand ) import qualified Demand import NewDemand import Outputable -import Util ( listLengthCmp ) import Maybe ( isJust ) +#ifdef OLD_STRICTNESS +import Util ( listLengthCmp ) import List ( replicate ) +#endif -- infixl so you can say (id `set` a `set` b) infixl 1 `setSpecInfo`, diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 17586a1d37..b2e26c2ce4 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -373,13 +373,21 @@ type TyVarSubst = Subst -- TyVarSubst are expected to have range elements -- it'll never be evaluated mkTyVarSubst :: [TyVar] -> [Type] -> Subst mkTyVarSubst tyvars tys = Subst (mkInScopeSet (tyVarsOfTypes tys)) - (zip_ty_env tyvars tys emptySubstEnv) + (zipTyEnv tyvars tys) -- mkTopTyVarSubst is called when doing top-level substitutions. -- Here we expect that the free vars of the range of the -- substitution will be empty. mkTopTyVarSubst :: [TyVar] -> [Type] -> Subst -mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zip_ty_env tyvars tys emptySubstEnv) +mkTopTyVarSubst tyvars tys = Subst emptyInScopeSet (zipTyEnv tyvars tys) + +zipTyEnv tyvars tys +#ifdef DEBUG + | length tyvars /= length tys + = pprTrace "mkTopTyVarSubst" (ppr tyvars $$ ppr tys) emptySubstEnv + | otherwise + = zip_ty_env tyvars tys emptySubstEnv +#endif zip_ty_env [] [] env = env zip_ty_env (tv:tvs) (ty:tys) env = zip_ty_env tvs tys (extendSubstEnv env tv (DoneTy ty)) diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 918f0e992f..97c844ed45 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -54,9 +54,6 @@ dsMonoBinds auto_scc (AndMonoBinds binds_1 binds_2) rest = dsMonoBinds auto_scc binds_2 rest `thenDs` \ rest' -> dsMonoBinds auto_scc binds_1 rest' -dsMonoBinds _ (CoreMonoBind var core_expr) rest - = returnDs ((var, core_expr) : rest) - dsMonoBinds _ (VarMonoBind var expr) rest = dsExpr expr `thenDs` \ core_expr -> diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 698eb86070..1899ff3e2c 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -3,10 +3,17 @@ -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the -- input HsExpr. We do this in the DsM monad, which supplies access to -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. +-- +-- It also defines a bunch of knownKeyNames, in the same way as is done +-- in prelude/PrelNames. It's much more convenient to do it here, becuase +-- otherwise we have to recompile PrelNames whenever we add a Name, which is +-- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- -module DsMeta( dsBracket ) where +module DsMeta( dsBracket, + templateHaskellNames, qTyConName, + liftName, exprTyConName, declTyConName ) where #include "HsVersions.h" @@ -22,38 +29,33 @@ import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), Match(..), GRHSs(..), GRHS(..), HsBracket(..), HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..), HsBinds(..), MonoBinds(..), HsConDetails(..), - HsDecl(..), TyClDecl(..), ForeignDecl(..), - PendingSplice, + TyClDecl(..), HsGroup(..), + HsType(..), HsContext(..), HsPred(..), HsTyOp(..), + HsTyVarBndr(..), Sig(..), ForeignDecl(..), + InstDecl(..), ConDecl(..), BangType(..), + PendingSplice, splitHsInstDeclTy, placeHolderType, tyClDeclNames, - collectHsBinders, - collectPatBinders, collectPatsBinders + collectHsBinders, collectPatBinders, collectPatsBinders, + hsTyVarName, hsConArgs, getBangType ) +import PrelNames ( mETA_META_Name, varQual, tcQual ) import Name ( Name, nameOccName, nameModule ) -import OccName ( isDataOcc, occNameUserString ) +import OccName ( isDataOcc, isTvOcc, occNameUserString ) import Module ( moduleUserString ) -import PrelNames ( intLName,charLName, - plitName, pvarName, ptupName, pconName, - ptildeName, paspatName, pwildName, - varName, conName, litName, appName, lamName, - tupName, doEName, compName, - listExpName, condName, letEName, caseEName, - infixAppName, guardedName, normalName, - bindStName, letStName, noBindStName, - fromName, fromThenName, fromToName, fromThenToName, - funName, valName, matchName, clauseName, - liftName, gensymName, bindQName, - matTyConName, expTyConName, clsTyConName, - pattTyConName, exprTyConName, declTyConName - ) - import Id ( Id ) import NameEnv +import NameSet import Type ( Type, mkGenTyConApp ) +import TyCon ( DataConDetails(..) ) import TysWiredIn ( stringTy ) import CoreSyn import CoreUtils ( exprType ) +import SrcLoc ( noSrcLoc ) +import Maybe ( catMaybes ) import Panic ( panic ) +import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique ) +import BasicTypes ( NewOrData(..), StrictnessMark(..) ) import Outputable import FastString ( mkFastString ) @@ -64,12 +66,15 @@ dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr -- The quoted thing is parameterised over Name, even though it has -- been type checked. We don't want all those type decorations! -dsBracket (ExpBr e) splices - = dsExtendMetaEnv new_bit (repE e) `thenDs` \ (MkC new_e) -> - returnDs new_e +dsBracket brack splices + = dsExtendMetaEnv new_bit (do_brack brack) where new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices] + do_brack (ExpBr e) = do { MkC e1 <- repE e ; return e1 } + do_brack (PatBr p) = do { MkC p1 <- repP p ; return p1 } + do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 } + do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 } {- -------------- Examples -------------------- @@ -86,91 +91,180 @@ dsBracket (ExpBr e) splices -} ------------------------------------------------------------------------------ --- repD - -{- -repDs :: [HsDecl Name] -> DsM (Core [M.Decl]) -repDs decls - = do { ds' <- mapM repD ds ; - coreList declTyConName ds' } - -repD :: HsDecl Name -> DsM (Core M.Decl) -repD (TyClD (TyData { tcdND = DataType, tcdCtxt = [], - tcdName = tc, tcdTyVars = tvs, - tcdCons = cons, tcdDerivs = mb_derivs })) - = do { tc1 <- localVar tc ; - cons1 <- mapM repCon cons ; +------------------------------------------------------- +-- Declarations +------------------------------------------------------- + +repTopDs :: HsGroup Name -> DsM (Core [M.Decl]) +repTopDs group + = do { let { bndrs = groupBinders group } ; + ss <- mkGenSyms bndrs ; + + decls <- addBinds ss (do { + val_ds <- rep_binds (hs_valds group) ; + tycl_ds <- mapM repTyClD (hs_tyclds group) ; + inst_ds <- mapM repInstD (hs_instds group) ; + -- more needed + return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ; + + core_list <- coreList declTyConName decls ; + wrapNongenSyms ss core_list + -- Do *not* gensym top-level binders + } + +groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = collectHsBinders val_decls ++ + [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++ + [n | ForeignImport n _ _ _ _ <- foreign_decls] + + +repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl)) + +repTyClD (TyData { tcdND = DataType, tcdCtxt = [], + tcdName = tc, tcdTyVars = tvs, + tcdCons = DataCons cons, tcdDerivs = mb_derivs }) + = do { tc1 <- lookupBinder tc ; tvs1 <- repTvs tvs ; + cons1 <- mapM repC cons ; cons2 <- coreList consTyConName cons1 ; derivs1 <- repDerivs mb_derivs ; - derivs2 <- coreList stringTyConName derivs1 ; - repData tc1 tvs1 cons2 derivs2 } + dec <- repData tc1 tvs1 cons2 derivs1 ; + return (Just dec) } -repD (TyClD (ClassD { tcdCtxt = cxt, tcdName = cls, +repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls, tcdTyVars = tvs, tcdFDs = [], - tcdSigs = sigs, tcdMeths = Just decls - })) - = do { cls1 <- localVar cls ; + tcdSigs = sigs, tcdMeths = Just binds + }) + = do { cls1 <- lookupBinder cls ; tvs1 <- repTvs tvs ; cxt1 <- repCtxt cxt ; - sigs1 <- repSigs sigs ; - repClass cxt1 cls1 tvs1 sigs1 } + sigs1 <- rep_sigs sigs ; + binds1 <- rep_monobind binds ; + decls1 <- coreList declTyConName (sigs1 ++ binds1) ; + dec <- repClass cxt1 cls1 tvs1 decls1 ; + return (Just dec) } + +-- Un-handled cases +repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ; + return Nothing + } + where + msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") -repD (InstD (InstDecl ty binds _ _ loc)) +repInstD (InstDecl ty binds _ _ loc) -- Ignore user pragmas for now - = do { cls1 <- localVar cls ; - cxt1 <- repCtxt cxt ; - tys1 <- repTys tys ; - binds1 <- repMonoBind binds ; - binds2 <- coreList declTyConName binds1 ; - repInst ... binds2 } + = do { cxt1 <- repCtxt cxt ; + inst_ty1 <- repPred (HsClassP cls tys) ; + binds1 <- rep_monobind binds ; + decls1 <- coreList declTyConName binds1 ; + repInst cxt1 inst_ty1 decls1 } where (tvs, cxt, cls, tys) = splitHsInstDeclTy ty --- Un-handled cases -repD d = do { dsWarn (hang (ptext SLIT("Cannot desugar this Template Haskell declaration:")) - 4 (ppr d)) ; - return (ValD EmptyBinds) -- A sort of empty decl - } + +------------------------------------------------------- +-- Constructors +------------------------------------------------------- + +repC :: ConDecl Name -> DsM (Core M.Cons) +repC (ConDecl con [] [] details loc) + = do { con1 <- lookupBinder con ; + arg_tys <- mapM (repBangTy con) (hsConArgs details) ; + arg_tys1 <- coreList typeTyConName arg_tys ; + repConstr con1 arg_tys1 } + +repBangTy con (BangType NotMarkedStrict ty) = repTy ty +repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) } + where + msg = ptext SLIT("Ignoring stricness on argument of constructor") + <+> quotes (ppr con) + +------------------------------------------------------- +-- Deriving clause +------------------------------------------------------- + +repDerivs :: Maybe (HsContext Name) -> DsM (Core [String]) +repDerivs Nothing = return (coreList' stringTy []) +repDerivs (Just ctxt) + = do { strs <- mapM rep_deriv ctxt ; + return (coreList' stringTy strs) } + where + rep_deriv :: HsPred Name -> DsM (Core String) + -- Deriving clauses must have the simple H98 form + rep_deriv (HsClassP cls []) = lookupOcc cls + rep_deriv other = panic "rep_deriv" + + +------------------------------------------------------- +-- Signatures in a class decl, or a group of bindings +------------------------------------------------------- + +rep_sigs :: [Sig Name] -> DsM [Core M.Decl] + -- We silently ignore ones we don't recognise +rep_sigs sigs = do { sigs1 <- mapM rep_sig sigs ; + return (concat sigs1) } + +rep_sig :: Sig Name -> DsM [Core M.Decl] + -- Singleton => Ok + -- Empty => Too hard, signature ignored +rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty +rep_sig (Sig nm ty _) = rep_proto nm ty +rep_sig other = return [] + +rep_proto nm ty = do { nm1 <- lookupBinder nm ; + ty1 <- repTy ty ; + sig <- repProto nm1 ty1 ; + return [sig] } + + +------------------------------------------------------- +-- Types +------------------------------------------------------- repTvs :: [HsTyVarBndr Name] -> DsM (Core [String]) repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ; - coreList stringTyConName tvs1 } + return (coreList' stringTy tvs1) } +----------------- repCtxt :: HsContext Name -> DsM (Core M.Ctxt) -repCtxt ctxt - = do { +repCtxt ctxt = do { preds <- mapM repPred ctxt; + coreList typeTyConName preds } -repTy :: HsType Name -> DsM (Core M.Type) -repTy ty@(HsForAllTy _ cxt ty) - = pprPanic "repTy" (ppr ty) +----------------- +repPred :: HsPred Name -> DsM (Core M.Type) +repPred (HsClassP cls tys) + = do { tc1 <- lookupOcc cls; tcon <- repNamedTyCon tc1; + tys1 <- repTys tys; repTapps tcon tys1 } +repPred (HsIParam _ _) = panic "No implicit parameters yet" -repTy (HsTyVar tv) - = do { tv1 <- localVar tv ; repTvar tv1 } +----------------- +repTys :: [HsType Name] -> DsM [Core M.Type] +repTys tys = mapM repTy tys -repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a2 } -repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; tcon <- repArrowTyCon ; repTapps tcon [f1,a1] } -repTy (HsListTy t) = do { t1 <- repTy t ; list <- repListTyCon ; repTapp tcon t1 } +----------------- +repTy :: HsType Name -> DsM (Core M.Type) -repTy (HsTupleTy tc tys) - = do +repTy (HsTyVar n) + | isTvOcc (nameOccName n) = do { tv1 <- localVar n ; repTvar tv1 } + | otherwise = do { tc1 <- lookupOcc n; repNamedTyCon tc1 } +repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a1 } +repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; + tcon <- repArrowTyCon ; repTapps tcon [f1,a1] } +repTy (HsListTy t) = do { t1 <- repTy t ; tcon <- repListTyCon ; repTapp tcon t1 } +repTy (HsTupleTy tc tys) = do { tys1 <- repTys tys; + tcon <- repTupleTyCon (length tys); + repTapps tcon tys1 } repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2) -repTy (HsOpTy ty1 (HsTyOp n) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2) +repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2) repTy (HsParTy t) = repTy t -repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsApp (HsTyVar c) tys) +repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys) - | HsTupleTy HsTupCon - [HsType name] -- Element types (length gives arity) - - | HsKindSig (HsType name) -- (ty :: kind) - Kind -- A type with a kind signature --} +repTy other_ty = pprPanic "repTy" (ppr other_ty) -- HsForAllTy, HsKindSig ----------------------------------------------------------------------------- --- Using the phantom type constructors "repConstructor" we define repE --- This ensures we keep the types of the CoreExpr objects we build are --- consistent with their real types. +-- Expressions +----------------------------------------------------------------------------- repEs :: [HsExpr Name] -> DsM (Core [M.Expr]) repEs es = do { es' <- mapM repE es ; @@ -181,11 +275,8 @@ repE (HsVar x) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of Nothing -> do { str <- globalVar x - ; if constructor x then - repCon str - else - repVar str } - Just (Bound y) -> repVar (coreVar y) + ; repVarOrCon x str } + Just (Bound y) -> repVarOrCon x (coreVar y) Just (Splice e) -> do { e' <- dsExpr e ; return (MkC e') } } @@ -207,14 +298,10 @@ repE (NegApp x nm) = panic "No negate yet" repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b } repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b } -repE (OpApp e1 (HsVar op) fix e2) = - do { arg1 <- repE e1; +repE (OpApp e1 (HsVar op) fix e2) + = do { arg1 <- repE e1; arg2 <- repE e2; - mb_val <- dsLookupMetaEnv op; - the_op <- case mb_val of { - Nothing -> globalVar op ; - Just (Bound x) -> return (coreVar x) ; - other -> pprPanic "repE:OpApp" (ppr op) } ; + the_op <- lookupOcc op ; repInfixApp arg1 the_op arg2 } repE (HsCase e ms loc) @@ -225,10 +312,10 @@ repE (HsCase e ms loc) -- I havn't got the types here right yet repE (HsDo DoExpr sts _ ty loc) = do { (ss,zs) <- repSts sts; e <- repDoE (nonEmptyCoreList zs); - combine expTyConName ss e } + wrapGenSyns expTyConName ss e } repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts; e <- repComp (nonEmptyCoreList zs); - combine expTyConName ss e } + wrapGenSyns expTyConName ss e } repE (ArithSeqIn (From e)) = do { ds1 <- repE e; repFrom ds1 } repE (ArithSeqIn (FromThen e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2; @@ -238,23 +325,20 @@ repE (ArithSeqIn (FromTo e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2; repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2; ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 } -repE (HsIf x y z loc) - = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c } - -repE (HsLet bs e) = - do { (ss,ds) <- repDecs bs - ; e2 <- addBinds ss (repE e) - ; z <- repLetE ds e2 - ; combine expTyConName ss z } -repE (HsWith _ _ _) = panic "No with for implicit parameters yet" -repE (ExplicitList ty es) = - do { xs <- repEs es; repListExp xs } -repE (ExplicitTuple es boxed) = - do { xs <- repEs es; repTup xs } -repE (ExplicitPArr ty es) = panic "No parallel arrays yet" -repE (RecordConOut _ _ _) = panic "No record construction yet" +repE (HsIf x y z loc) = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c } + +repE (HsLet bs e) = do { (ss,ds) <- repBinds bs + ; e2 <- addBinds ss (repE e) + ; z <- repLetE ds e2 + ; wrapGenSyns expTyConName ss z } +repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } +repE (ExplicitTuple es boxed) = do { xs <- repEs es; repTup xs } + +repE (HsWith _ _ _) = panic "No with for implicit parameters yet" +repE (ExplicitPArr ty es) = panic "No parallel arrays yet" +repE (RecordConOut _ _ _) = panic "No record construction yet" repE (RecordUpdOut _ _ _ _) = panic "No record update yet" -repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet" +repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet" ----------------------------------------------------------------------------- @@ -265,25 +349,25 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { ; p1 <- repP p - ; (ss2,ds) <- repDecs wheres + ; (ss2,ds) <- repBinds wheres ; addBinds ss2 $ do { ; gs <- repGuards guards ; match <- repMatch p1 gs ds - ; combine matTyConName (ss1++ss2) match }}} + ; wrapGenSyns matTyConName (ss1++ss2) match }}} repClauseTup :: Match Name -> DsM (Core M.Clse) repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { ps1 <- repPs ps - ; (ss2,ds) <- repDecs wheres + ; (ss2,ds) <- repBinds wheres ; addBinds ss2 $ do { gs <- repGuards guards ; clause <- repClause ps1 gs ds - ; combine clsTyConName (ss1++ss2) clause }}} + ; wrapGenSyns clsTyConName (ss1++ss2) clause }}} repGuards :: [GRHS Name] -> DsM (Core M.Rihs) -repGuards [GRHS[ResultStmt e loc] loc2] +repGuards [GRHS [ResultStmt e loc] loc2] = do {a <- repE e; repNormal a } repGuards other = do { zs <- mapM process other; @@ -333,7 +417,7 @@ repSts (BindStmt p e loc : ss) = ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} repSts (LetStmt bs : ss) = - do { (ss1,ds) <- repDecs bs + do { (ss1,ds) <- repBinds bs ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } @@ -345,59 +429,60 @@ repSts (ExprStmt e ty loc : ss) = repSts other = panic "Exotic Stmt in meta brackets" +----------------------------------------------------------- +-- Bindings +----------------------------------------------------------- -repDecs :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl]) -repDecs decs +repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl]) +repBinds decs = do { let { bndrs = collectHsBinders decs } ; - ss <- mkGenSyms bndrs ; - core <- addBinds ss (rep_decs decs) ; + ss <- mkGenSyms bndrs ; + core <- addBinds ss (rep_binds decs) ; core_list <- coreList declTyConName core ; return (ss, core_list) } -rep_decs :: HsBinds Name -> DsM [Core M.Decl] -rep_decs EmptyBinds = return [] -rep_decs (ThenBinds x y) - = do { core1 <- rep_decs x - ; core2 <- rep_decs y +rep_binds :: HsBinds Name -> DsM [Core M.Decl] +rep_binds EmptyBinds = return [] +rep_binds (ThenBinds x y) + = do { core1 <- rep_binds x + ; core2 <- rep_binds y ; return (core1 ++ core2) } -rep_decs (MonoBind bs sigs _) - = do { core1 <- repMonoBind bs +rep_binds (MonoBind bs sigs _) + = do { core1 <- rep_monobind bs ; core2 <- rep_sigs sigs ; return (core1 ++ core2) } -rep_sigs sigs = return [] -- Incomplete! - -repMonoBind :: MonoBinds Name -> DsM [Core M.Decl] -repMonoBind EmptyMonoBinds = return [] -repMonoBind (AndMonoBinds x y) = do { x1 <- repMonoBind x; - y1 <- repMonoBind y; - return (x1 ++ y1) } +rep_monobind :: MonoBinds Name -> DsM [Core M.Decl] +rep_monobind EmptyMonoBinds = return [] +rep_monobind (AndMonoBinds x y) = do { x1 <- rep_monobind x; + y1 <- rep_monobind y; + return (x1 ++ y1) } -- 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 -repMonoBind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) - = do { (ss,wherecore) <- repDecs wheres +rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) + = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; fn' <- lookupBinder fn ; p <- repPvar fn' ; ans <- repVal p guardcore wherecore ; return [ans] } -repMonoBind (FunMonoBind fn infx ms loc) +rep_monobind (FunMonoBind fn infx ms loc) = do { ms1 <- mapM repClauseTup ms ; fn' <- lookupBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) ; return [ans] } -repMonoBind (PatMonoBind pat (GRHSs guards wheres ty2) loc) +rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc) = do { patcore <- repP pat - ; (ss,wherecore) <- repDecs wheres + ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore ; return [ans] } -repMonoBind (VarMonoBind v e) +rep_monobind (VarMonoBind v e) = do { v' <- lookupBinder v ; e2 <- repE e ; x <- repNormal e2 @@ -422,23 +507,9 @@ repMonoBind (VarMonoBind v e) -- representations we build a shadow datatype MB with the same structure as -- MonoBinds, but which has slots for the representations ------------------------------------------------------------------------------ --- Gathering binders - -hsDeclsBinders :: [HsDecl Name] -> [Name] -hsDeclsBinders ds = concat (map hsDeclBinders ds) - -hsDeclBinders (ValD b) = collectHsBinders b -hsDeclBinders (TyClD d) = map fst (tyClDeclNames d) -hsDeclBinders (ForD d) = forDeclBinders d -hsDeclBinders other = [] - -forDeclBinders (ForeignImport n _ _ _ _) = [n] -forDeclBinders other = [] - ----------------------------------------------------------------------------- --- GHC seems to allow a more general form of lambda abstraction than specified +-- GHC allows a more general form of lambda abstraction than specified -- by Haskell 98. In particular it allows guarded lambda's like : -- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like @@ -451,13 +522,13 @@ repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ] ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repPs ps; body <- repE e; repLam xs body }) - ; combine expTyConName ss lam } + ; wrapGenSyns expTyConName ss lam } repLambda z = panic "Can't represent a guarded lambda in Template Haskell" ----------------------------------------------------------------------------- --- repP +-- Patterns -- repP deals with patterns. It assumes that we have already -- walked over the pattern(s) once to collect the binders, and -- have extended the environment. So every pattern-bound @@ -478,7 +549,7 @@ repP (ParPat p) = repP p repP (ListPat ps _) = repListPat ps repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs } repP (ConPatIn dc details) - = do { con_str <- globalVar dc + = do { con_str <- lookupOcc dc ; case details of PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs } RecCon pairs -> error "No records in template haskell yet" @@ -497,19 +568,6 @@ repListPat (p:ps) = do { p2 <- repP p ---------------------------------------------------------- --- Literals - -repLiteral :: HsLit -> DsM (Core M.Lit) -repLiteral (HsInt i) = rep2 intLName [mkIntExpr i] -repLiteral (HsChar c) = rep2 charLName [mkCharExpr c] -repLiteral x = panic "trying to represent exotic literal" - -repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit) -repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i] -repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet" - - ----------------------------------------------------------- -- The meta-environment type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id @@ -537,13 +595,15 @@ lookupType :: Name -- Name of type constructor (e.g. M.Expr) lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; return (mkGenTyConApp tc []) } --- combine[ x1 <- e1, x2 <- e2 ] y --- --> bindQ e1 (\ x1 -> bindQ e2 (\ x2 -> y)) +-- wrapGenSyns [(nm1,id1), (nm2,id2)] y +-- --> bindQ (gensym nm1) (\ id1 -> +-- bindQ (gensym nm2 (\ id2 -> +-- y)) -combine :: Name -- Name of the type (consructor) for 'a' - -> [GenSymBind] - -> Core (M.Q a) -> DsM (Core (M.Q a)) -combine tc_name binds body@(MkC b) +wrapGenSyns :: Name -- Name of the type (consructor) for 'a' + -> [GenSymBind] + -> Core (M.Q a) -> DsM (Core (M.Q a)) +wrapGenSyns tc_name binds body@(MkC b) = do { elt_ty <- lookupType tc_name ; go elt_ty binds } where @@ -555,8 +615,20 @@ combine tc_name binds body@(MkC b) ; repBindQ stringTy elt_ty gensym_app (MkC (Lam id body')) } -constructor :: Name -> Bool -constructor x = isDataOcc (nameOccName x) +-- Just like wrapGenSym, but don't actually do the gensym +-- Instead use the existing name +-- Only used for [Decl] +wrapNongenSyms :: [GenSymBind] + -> Core [M.Decl] -> DsM (Core [M.Decl]) +wrapNongenSyms binds body@(MkC b) + = go binds + where + go [] = return body + go ((name,id) : binds) + = do { MkC body' <- go binds + ; MkC lit_str <- localVar name -- No gensym + ; return (MkC (Let (NonRec id lit_str) body')) + } void = placeHolderType @@ -614,6 +686,10 @@ repPwild :: DsM (Core M.Patt) repPwild = rep2 pwildName [] --------------- Expressions ----------------- +repVarOrCon :: Name -> Core String -> DsM (Core M.Expr) +repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str + | otherwise = repVar str + repVar :: Core String -> DsM (Core M.Expr) repVar (MkC s) = rep2 varName [s] @@ -703,12 +779,11 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds] repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl) repFun (MkC nm) (MkC b) = rep2 funName [nm, b] -{- repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl) repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs] -repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -repInst (MkC cxt) (MkC ty) (Core ds) = rep2 instanceDName [cxt, ty, ds] +repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl) +repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds] repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds] @@ -716,6 +791,9 @@ repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs repProto :: Core String -> Core M.Type -> DsM (Core M.Decl) repProto (MkC s) (MkC ty) = rep2 protoName [s, ty] +repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons) +repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys] + ------------ Types ------------------- repTvar :: Core String -> DsM (Core M.Type) @@ -728,21 +806,35 @@ repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type) repTapps f [] = return f repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } +--------- Type constructors -------------- repNamedTyCon :: Core String -> DsM (Core M.Type) repNamedTyCon (MkC s) = rep2 namedTyConName [s] -repTupleTyCon :: Core Int -> DsM (Core M.Tag) -repTupleTyCon (MkC i) = rep2 tupleTyConName [i] +repTupleTyCon :: Int -> DsM (Core M.Type) +-- Note: not Core Int; it's easier to be direct here +repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)] repArrowTyCon :: DsM (Core M.Type) repArrowTyCon = rep2 arrowTyConName [] -repListTyCon :: DsM (Core M.Tag) +repListTyCon :: DsM (Core M.Type) repListTyCon = rep2 listTyConName [] --} +---------------------------------------------------------- +-- Literals + +repLiteral :: HsLit -> DsM (Core M.Lit) +repLiteral (HsInt i) = rep2 intLName [mkIntExpr i] +repLiteral (HsChar c) = rep2 charLName [mkCharExpr c] +repLiteral x = panic "trying to represent exotic literal" + +repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit) +repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i] +repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet" + + --------------- Miscellaneous ------------------- repLift :: Core e -> DsM (Core M.Expr) @@ -762,9 +854,11 @@ repBindQ ty_a ty_b (MkC x) (MkC y) coreList :: Name -- Of the TyCon of the element type -> [Core a] -> DsM (Core [a]) coreList tc_name es - = do { elt_ty <- lookupType tc_name - ; let es' = map unC es - ; return (MkC (mkListExpr elt_ty es')) } + = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } + +coreList' :: Type -- The element type + -> [Core a] -> Core [a] +coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) nonEmptyCoreList :: [Core a] -> Core [a] -- The list must be non-empty so we can get the element type @@ -775,6 +869,17 @@ nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) corePair :: (Core a, Core b) -> Core (a,b) corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y]) +lookupOcc :: Name -> DsM (Core String) +-- Lookup an occurrence; it can't be a splice. +-- Use the in-scope bindings if they exist +lookupOcc n + = do { mb_val <- dsLookupMetaEnv n ; + case mb_val of + Nothing -> globalVar n + Just (Bound x) -> return (coreVar x) + other -> pprPanic "repE:lookupOcc" (ppr n) + } + globalVar :: Name -> DsM (Core String) globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ) where @@ -789,3 +894,214 @@ coreStringLit s = do { z <- mkStringLit s; return(MkC z) } coreVar :: Id -> Core String -- The Id has type String coreVar id = MkC (Var id) + + + +-- %************************************************************************ +-- %* * +-- The known-key names for Template Haskell +-- %* * +-- %************************************************************************ + +-- To add a name, do three things +-- +-- 1) Allocate a key +-- 2) Make a "Name" +-- 3) Add the name to knownKeyNames + +templateHaskellNames :: NameSet +-- The names that are implicitly mentioned by ``bracket'' +-- Should stay in sync with the import list of DsMeta +templateHaskellNames + = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName, + pconName, ptildeName, paspatName, pwildName, + varName, conName, litName, appName, infixEName, lamName, + tupName, doEName, compName, + listExpName, condName, letEName, caseEName, + infixAppName, sectionLName, sectionRName, guardedName, normalName, + bindStName, letStName, noBindStName, parStName, + fromName, fromThenName, fromToName, fromThenToName, + funName, valName, liftName, + gensymName, returnQName, bindQName, + matchName, clauseName, funName, valName, dataDName, classDName, + instName, protoName, tvarName, tconName, tappName, + arrowTyConName, tupleTyConName, listTyConName, namedTyConName, + constrName, + exprTyConName, declTyConName, pattTyConName, mtchTyConName, + clseTyConName, stmtTyConName, consTyConName, typeTyConName, + qTyConName, expTyConName, matTyConName, clsTyConName ] + + + +intLName = varQual mETA_META_Name FSLIT("intL") intLIdKey +charLName = varQual mETA_META_Name FSLIT("charL") charLIdKey +plitName = varQual mETA_META_Name FSLIT("plit") plitIdKey +pvarName = varQual mETA_META_Name FSLIT("pvar") pvarIdKey +ptupName = varQual mETA_META_Name FSLIT("ptup") ptupIdKey +pconName = varQual mETA_META_Name FSLIT("pcon") pconIdKey +ptildeName = varQual mETA_META_Name FSLIT("ptilde") ptildeIdKey +paspatName = varQual mETA_META_Name FSLIT("paspat") paspatIdKey +pwildName = varQual mETA_META_Name FSLIT("pwild") pwildIdKey +varName = varQual mETA_META_Name FSLIT("var") varIdKey +conName = varQual mETA_META_Name FSLIT("con") conIdKey +litName = varQual mETA_META_Name FSLIT("lit") litIdKey +appName = varQual mETA_META_Name FSLIT("app") appIdKey +infixEName = varQual mETA_META_Name FSLIT("infixE") infixEIdKey +lamName = varQual mETA_META_Name FSLIT("lam") lamIdKey +tupName = varQual mETA_META_Name FSLIT("tup") tupIdKey +doEName = varQual mETA_META_Name FSLIT("doE") doEIdKey +compName = varQual mETA_META_Name FSLIT("comp") compIdKey +listExpName = varQual mETA_META_Name FSLIT("listExp") listExpIdKey +condName = varQual mETA_META_Name FSLIT("cond") condIdKey +letEName = varQual mETA_META_Name FSLIT("letE") letEIdKey +caseEName = varQual mETA_META_Name FSLIT("caseE") caseEIdKey +infixAppName = varQual mETA_META_Name FSLIT("infixApp") infixAppIdKey +sectionLName = varQual mETA_META_Name FSLIT("sectionL") sectionLIdKey +sectionRName = varQual mETA_META_Name FSLIT("sectionR") sectionRIdKey +guardedName = varQual mETA_META_Name FSLIT("guarded") guardedIdKey +normalName = varQual mETA_META_Name FSLIT("normal") normalIdKey +bindStName = varQual mETA_META_Name FSLIT("bindSt") bindStIdKey +letStName = varQual mETA_META_Name FSLIT("letSt") letStIdKey +noBindStName = varQual mETA_META_Name FSLIT("noBindSt") noBindStIdKey +parStName = varQual mETA_META_Name FSLIT("parSt") parStIdKey +fromName = varQual mETA_META_Name FSLIT("from") fromIdKey +fromThenName = varQual mETA_META_Name FSLIT("fromThen") fromThenIdKey +fromToName = varQual mETA_META_Name FSLIT("fromTo") fromToIdKey +fromThenToName = varQual mETA_META_Name FSLIT("fromThenTo") fromThenToIdKey +liftName = varQual mETA_META_Name FSLIT("lift") liftIdKey +gensymName = varQual mETA_META_Name FSLIT("gensym") gensymIdKey +returnQName = varQual mETA_META_Name FSLIT("returnQ") returnQIdKey +bindQName = varQual mETA_META_Name FSLIT("bindQ") bindQIdKey + +-- type Mat = ... +matchName = varQual mETA_META_Name FSLIT("match") matchIdKey + +-- type Cls = ... +clauseName = varQual mETA_META_Name FSLIT("clause") clauseIdKey + +-- data Dec = ... +funName = varQual mETA_META_Name FSLIT("fun") funIdKey +valName = varQual mETA_META_Name FSLIT("val") valIdKey +dataDName = varQual mETA_META_Name FSLIT("dataD") dataDIdKey +classDName = varQual mETA_META_Name FSLIT("classD") classDIdKey +instName = varQual mETA_META_Name FSLIT("inst") instIdKey +protoName = varQual mETA_META_Name FSLIT("proto") protoIdKey + +-- data Typ = ... +tvarName = varQual mETA_META_Name FSLIT("tvar") tvarIdKey +tconName = varQual mETA_META_Name FSLIT("tcon") tconIdKey +tappName = varQual mETA_META_Name FSLIT("tapp") tappIdKey + +-- data Tag = ... +arrowTyConName = varQual mETA_META_Name FSLIT("arrowTyCon") arrowIdKey +tupleTyConName = varQual mETA_META_Name FSLIT("tupleTyCon") tupleIdKey +listTyConName = varQual mETA_META_Name FSLIT("listTyCon") listIdKey +namedTyConName = varQual mETA_META_Name FSLIT("namedTyCon") namedTyConIdKey + +-- data Con = ... +constrName = varQual mETA_META_Name FSLIT("constr") constrIdKey + +exprTyConName = tcQual mETA_META_Name FSLIT("Expr") exprTyConKey +declTyConName = tcQual mETA_META_Name FSLIT("Decl") declTyConKey +pattTyConName = tcQual mETA_META_Name FSLIT("Patt") pattTyConKey +mtchTyConName = tcQual mETA_META_Name FSLIT("Mtch") mtchTyConKey +clseTyConName = tcQual mETA_META_Name FSLIT("Clse") clseTyConKey +stmtTyConName = tcQual mETA_META_Name FSLIT("Stmt") stmtTyConKey +consTyConName = tcQual mETA_META_Name FSLIT("Cons") consTyConKey +typeTyConName = tcQual mETA_META_Name FSLIT("Type") typeTyConKey + +qTyConName = tcQual mETA_META_Name FSLIT("Q") qTyConKey +expTyConName = tcQual mETA_META_Name FSLIT("Exp") expTyConKey +matTyConName = tcQual mETA_META_Name FSLIT("Mat") matTyConKey +clsTyConName = tcQual mETA_META_Name FSLIT("Cls") clsTyConKey + +-- TyConUniques available: 100-119 +-- Check in PrelNames if you want to change this + +expTyConKey = mkPreludeTyConUnique 100 +matTyConKey = mkPreludeTyConUnique 101 +clsTyConKey = mkPreludeTyConUnique 102 +qTyConKey = mkPreludeTyConUnique 103 +exprTyConKey = mkPreludeTyConUnique 104 +declTyConKey = mkPreludeTyConUnique 105 +pattTyConKey = mkPreludeTyConUnique 106 +mtchTyConKey = mkPreludeTyConUnique 107 +clseTyConKey = mkPreludeTyConUnique 108 +stmtTyConKey = mkPreludeTyConUnique 109 +consTyConKey = mkPreludeTyConUnique 110 +typeTyConKey = mkPreludeTyConUnique 111 + + +-- IdUniques available: 200-299 +-- If you want to change this, make sure you check in PrelNames +fromIdKey = mkPreludeMiscIdUnique 200 +fromThenIdKey = mkPreludeMiscIdUnique 201 +fromToIdKey = mkPreludeMiscIdUnique 202 +fromThenToIdKey = mkPreludeMiscIdUnique 203 +liftIdKey = mkPreludeMiscIdUnique 204 +gensymIdKey = mkPreludeMiscIdUnique 205 +returnQIdKey = mkPreludeMiscIdUnique 206 +bindQIdKey = mkPreludeMiscIdUnique 207 +funIdKey = mkPreludeMiscIdUnique 208 +valIdKey = mkPreludeMiscIdUnique 209 +protoIdKey = mkPreludeMiscIdUnique 210 +matchIdKey = mkPreludeMiscIdUnique 211 +clauseIdKey = mkPreludeMiscIdUnique 212 +intLIdKey = mkPreludeMiscIdUnique 213 +charLIdKey = mkPreludeMiscIdUnique 214 + +classDIdKey = mkPreludeMiscIdUnique 215 +instIdKey = mkPreludeMiscIdUnique 216 +dataDIdKey = mkPreludeMiscIdUnique 217 + + +plitIdKey = mkPreludeMiscIdUnique 220 +pvarIdKey = mkPreludeMiscIdUnique 221 +ptupIdKey = mkPreludeMiscIdUnique 222 +pconIdKey = mkPreludeMiscIdUnique 223 +ptildeIdKey = mkPreludeMiscIdUnique 224 +paspatIdKey = mkPreludeMiscIdUnique 225 +pwildIdKey = mkPreludeMiscIdUnique 226 +varIdKey = mkPreludeMiscIdUnique 227 +conIdKey = mkPreludeMiscIdUnique 228 +litIdKey = mkPreludeMiscIdUnique 229 +appIdKey = mkPreludeMiscIdUnique 230 +infixEIdKey = mkPreludeMiscIdUnique 231 +lamIdKey = mkPreludeMiscIdUnique 232 +tupIdKey = mkPreludeMiscIdUnique 233 +doEIdKey = mkPreludeMiscIdUnique 234 +compIdKey = mkPreludeMiscIdUnique 235 +listExpIdKey = mkPreludeMiscIdUnique 237 +condIdKey = mkPreludeMiscIdUnique 238 +letEIdKey = mkPreludeMiscIdUnique 239 +caseEIdKey = mkPreludeMiscIdUnique 240 +infixAppIdKey = mkPreludeMiscIdUnique 241 +sectionLIdKey = mkPreludeMiscIdUnique 242 +sectionRIdKey = mkPreludeMiscIdUnique 243 +guardedIdKey = mkPreludeMiscIdUnique 244 +normalIdKey = mkPreludeMiscIdUnique 245 +bindStIdKey = mkPreludeMiscIdUnique 246 +letStIdKey = mkPreludeMiscIdUnique 247 +noBindStIdKey = mkPreludeMiscIdUnique 248 +parStIdKey = mkPreludeMiscIdUnique 249 + +tvarIdKey = mkPreludeMiscIdUnique 250 +tconIdKey = mkPreludeMiscIdUnique 251 +tappIdKey = mkPreludeMiscIdUnique 252 + +arrowIdKey = mkPreludeMiscIdUnique 253 +tupleIdKey = mkPreludeMiscIdUnique 254 +listIdKey = mkPreludeMiscIdUnique 255 +namedTyConIdKey = mkPreludeMiscIdUnique 256 + +constrIdKey = mkPreludeMiscIdUnique 257 + +-- %************************************************************************ +-- %* * +-- Other utilities +-- %* * +-- %************************************************************************ + +-- It is rather usatisfactory that we don't have a SrcLoc +addDsWarn :: SDoc -> DsM () +addDsWarn msg = dsWarn (noSrcLoc, msg)
\ No newline at end of file diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 42bd271439..fe5aa75b5a 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -40,8 +40,7 @@ import CoreSyn import DsMonad import CoreUtils ( exprType, mkIfThenElse, mkCoerce ) -import PrelInfo ( iRREFUT_PAT_ERROR_ID ) -import MkId ( mkReboxingAlt, mkNewTypeBody ) +import MkId ( iRREFUT_PAT_ERROR_ID, mkReboxingAlt, mkNewTypeBody ) import Id ( idType, Id, mkWildId ) import Literal ( Literal(..), inIntRange, tARGET_MAX_INT ) import TyCon ( isNewTyCon, tyConDataCons ) diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index bbe56ade5c..41018f7edc 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -16,7 +16,7 @@ import HsSyn as Hs ( HsExpr(..), HsLit(..), ArithSeqInfo(..), HsStmtContext(..), Match(..), GRHSs(..), GRHS(..), HsPred(..), - HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..), + HsDecl(..), InstDecl(..), ConDecl(..), Stmt(..), HsBinds(..), MonoBinds(..), Sig(..), Pat(..), HsConDetails(..), HsOverLit, BangType(..), placeHolderType, HsType(..), HsTupCon(..), @@ -41,11 +41,12 @@ import Outputable ------------------------------------------------------------------- convertToHsDecls :: [Meta.Dec] -> [HsDecl RdrName] -convertToHsDecls ds - = ValD (cvtdecs binds_and_sigs) : map cvt_top top_decls - where - (binds_and_sigs, top_decls) = partition sigOrBindP ds +convertToHsDecls ds = map cvt_top ds + +cvt_top d@(Val _ _ _) = ValD (cvtd d) +cvt_top d@(Fun _ _) = ValD (cvtd d) + cvt_top (Data tc tvs constrs derivs) = TyClD (mkTyData DataType (noContext, tconName tc, cvt_tvs tvs) @@ -76,6 +77,8 @@ cvt_top (Instance tys ty decs) (cvt_context tys) (HsPredTy (cvt_pred ty)) +cvt_top (Proto nm typ) = SigD (Sig (vName nm) (cvtType typ) loc0) + noContext = [] noExistentials = [] noFunDeps = [] @@ -196,7 +199,7 @@ cvtp Pwild = WildPat void cvt_tvs :: [String] -> [HsTyVarBndr RdrName] cvt_tvs tvs = map (UserTyVar . tName) tvs -cvt_context :: Context -> HsContext RdrName +cvt_context :: Cxt -> HsContext RdrName cvt_context tys = map cvt_pred tys cvt_pred :: Typ -> HsPred RdrName @@ -205,15 +208,23 @@ cvt_pred ty = case split_ty_app ty of other -> panic "Malformed predicate" cvtType :: Meta.Typ -> HsType RdrName -cvtType (Tvar nm) = HsTyVar(tName nm) -cvtType (Tapp x y) = trans (root x [y]) - where root (Tapp a b) zs = root a (b:zs) - root t zs = (t,zs) - trans (Tcon (Tuple n),args) = HsTupleTy (HsTupCon Boxed n) (map cvtType args) - trans (Tcon Arrow,[x,y]) = HsFunTy (cvtType x) (cvtType y) - trans (Tcon List,[x]) = HsListTy (cvtType x) - trans (Tcon (Name nm),args) = HsTyVar(tconName nm) - trans (t,args) = panic "bad type application" +cvtType ty = trans (root ty []) + where root (Tapp a b) zs = root a (cvtType b : zs) + root t zs = (t,zs) + + trans (Tcon (Tuple n),args) | length args == n + = HsTupleTy (HsTupCon Boxed n) args + trans (Tcon Arrow, [x,y]) = HsFunTy x y + trans (Tcon List, [x]) = HsListTy x + + trans (Tvar nm, args) = foldl HsAppTy (HsTyVar (tName nm)) args + trans (Tcon tc, args) = foldl HsAppTy (HsTyVar (tc_name tc)) args + + tc_name (TconName nm) = tconName nm + tc_name Arrow = tconName "->" + tc_name List = tconName "[]" + tc_name (Tuple 0) = tconName "()" + tc_name (Tuple n) = tconName ("(" ++ replicate (n-1) ',' ++ ")") split_ty_app :: Typ -> (Typ, [Typ]) split_ty_app ty = go ty [] @@ -226,12 +237,6 @@ sigP :: Dec -> Bool sigP (Proto _ _) = True sigP other = False -sigOrBindP :: Dec -> Bool -sigOrBindP (Proto _ _) = True -sigOrBindP (Val _ _ _) = True -sigOrBindP (Fun _ _) = True -sigOrBindP other = False - ----------------------------------------------------------- -- some useful things diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index eb836a39a4..8f3d81e7e1 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -125,9 +125,6 @@ data MonoBinds id | VarMonoBind id -- TRANSLATION (HsExpr id) - | CoreMonoBind id -- TRANSLATION - CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types! - | AbsBinds -- Binds abstraction; TRANSLATION [TyVar] -- Type variables [id] -- Dicts @@ -212,9 +209,6 @@ ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches ppr_monobind (VarMonoBind name expr) = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)] -ppr_monobind (CoreMonoBind name expr) - = sep [pprBndr LetBind name <+> equals, nest 4 (ppr expr)] - ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds) = sep [ptext SLIT("AbsBinds"), brackets (interpp'SP tyvars), diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 7553cca68b..4bda850ed6 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -9,13 +9,12 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, \begin{code} module HsDecls ( HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..), - DefaultDecl(..), + DefaultDecl(..), HsGroup(..), ForeignDecl(..), ForeignImport(..), ForeignExport(..), CImportSpec(..), FoType(..), ConDecl(..), CoreDecl(..), BangType(..), getBangType, getBangStrictness, unbangedType, DeprecDecl(..), DeprecTxt, - hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, tyClDeclTyVars, isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isTypeOrClassDecl, countTyClDecls, @@ -68,17 +67,17 @@ import Maybe ( isNothing, fromJust ) data HsDecl id = TyClD (TyClDecl id) | InstD (InstDecl id) + | ValD (MonoBinds id) + | SigD (Sig id) | DefD (DefaultDecl id) - | ValD (HsBinds id) | ForD (ForeignDecl id) - | FixD (FixitySig id) | DeprecD (DeprecDecl id) | RuleD (RuleDecl id) | CoreD (CoreDecl id) | SpliceD (HsExpr id) -- Top level splice -- NB: all top-level fixity decls are contained EITHER --- EITHER FixDs +-- EITHER SigDs -- OR in the ClassDecls in TyClDs -- -- The former covers @@ -89,42 +88,63 @@ data HsDecl id -- d) top level decls -- -- The latter is for class methods only -\end{code} - -\begin{code} -#ifdef DEBUG -hsDeclName :: (NamedThing name, OutputableBndr name) - => HsDecl name -> name -#endif -hsDeclName (TyClD decl) = tyClDeclName decl -hsDeclName (InstD decl) = instDeclName decl -hsDeclName (ForD decl) = foreignDeclName decl -hsDeclName (FixD (FixitySig name _ _)) = name -hsDeclName (CoreD (CoreDecl name _ _ _)) = name --- Others don't make sense -#ifdef DEBUG -hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) -#endif - - -instDeclName :: InstDecl name -> name -instDeclName (InstDecl _ _ _ (Just name) _) = name +-- A [HsDecl] is categorised into a HsGroup before being +-- fed to the renamer. +data HsGroup id + = HsGroup { + hs_valds :: HsBinds id, + -- Before the renamer, this is a single big MonoBinds, + -- with all the bindings, and all the signatures. + -- The renamer does dependency analysis, using ThenBinds + -- to give the structure + + hs_tyclds :: [TyClDecl id], + hs_instds :: [InstDecl id], + + hs_fixds :: [FixitySig id], + -- Snaffled out of both top-level fixity signatures, + -- and those in class declarations + + hs_defds :: [DefaultDecl id], + hs_fords :: [ForeignDecl id], + hs_depds :: [DeprecDecl id], + hs_ruleds :: [RuleDecl id], + hs_coreds :: [CoreDecl id] + } \end{code} \begin{code} instance OutputableBndr name => Outputable (HsDecl name) where - ppr (TyClD dcl) = ppr dcl ppr (ValD binds) = ppr binds ppr (DefD def) = ppr def ppr (InstD inst) = ppr inst ppr (ForD fd) = ppr fd - ppr (FixD fd) = ppr fd + ppr (SigD sd) = ppr sd ppr (RuleD rd) = ppr rd ppr (DeprecD dd) = ppr dd ppr (CoreD dd) = ppr dd ppr (SpliceD e) = ptext SLIT("splice") <> parens (pprExpr e) + +instance OutputableBndr name => Outputable (HsGroup name) where + ppr (HsGroup { hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fixds = fix_decls, + hs_depds = deprec_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_coreds = core_decls }) + = vcat [ppr_ds fix_decls, ppr_ds default_decls, + ppr_ds deprec_decls, ppr_ds rule_decls, + ppr val_decls, + ppr_ds tycl_decls, ppr_ds inst_decls, + ppr_ds foreign_decls, ppr_ds core_decls] + where + ppr_ds [] = empty + ppr_ds ds = text "" $$ vcat (map ppr ds) \end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 59b5cd0aac..e295905961 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -9,7 +9,7 @@ module HsExpr where #include "HsVersions.h" -- friends: -import HsDecls ( HsDecl ) +import HsDecls ( HsGroup ) import HsBinds ( HsBinds(..), nullBinds ) import HsPat ( Pat ) import HsLit ( HsLit, HsOverLit ) @@ -670,7 +670,7 @@ pprComp brack stmts = brack $ \begin{code} data HsBracket id = ExpBr (HsExpr id) | PatBr (Pat id) - | DecBr [HsDecl id] + | DecBr (HsGroup id) | TypBr (HsType id) instance OutputableBndr id => Outputable (HsBracket id) where @@ -679,7 +679,7 @@ instance OutputableBndr id => Outputable (HsBracket id) where pprHsBracket (ExpBr e) = thBrackets empty (ppr e) pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) -pprHsBracket (DecBr d) = thBrackets (char 'd') (vcat (map ppr d)) +pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d) pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 290bc85756..708a82fb48 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -9,11 +9,9 @@ therefore, is almost nothing but re-exporting. \begin{code} module HsSyn ( - -- NB: don't reexport HsCore -- this module tells about "real Haskell" - module HsSyn, module HsBinds, module HsDecls, module HsExpr, @@ -23,10 +21,11 @@ module HsSyn ( module HsTypes, Fixity, NewOrData, + HsModule(..), hsModule, hsImports, + collectStmtsBinders, collectHsBinders, collectLocatedHsBinders, collectMonoBinders, collectLocatedMonoBinders, - collectSigTysFromHsBinds, collectSigTysFromMonoBinds, - hsModule, hsImports + collectSigTysFromHsBinds, collectSigTysFromMonoBinds ) where #include "HsVersions.h" @@ -151,6 +150,13 @@ collectMonoBinders binds go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) \end{code} + +%************************************************************************ +%* * +\subsection{Getting patterns out of bindings} +%* * +%************************************************************************ + Get all the pattern type signatures out of a bunch of bindings \begin{code} diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index 607ba78d28..311522fdf8 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.23 2002/09/18 10:51:01 simonmar Exp $ +-- $Id: DriverMkDepend.hs,v 1.24 2002/10/09 15:03:52 simonpj Exp $ -- -- GHC Driver -- @@ -22,7 +22,7 @@ import Finder ( findModuleDep ) import Util ( global ) import Panic -import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) +import DATA_IOREF ( IORef, readIORef, writeIORef ) import EXCEPTION import Directory diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index ebf7fb5606..9ca68195aa 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -41,9 +41,8 @@ import Lex ( ParseResult(..), ExtFlags(..), mkPState ) import SrcLoc ( mkSrcLoc ) import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface ) import Rules ( emptyRuleBase ) -import PrelInfo ( wiredInThingEnv, wiredInThings ) +import PrelInfo ( wiredInThingEnv, wiredInThings, knownKeyNames ) import PrelRules ( builtinRules ) -import PrelNames ( knownKeyNames ) import MkIface ( mkIface ) import InstEnv ( emptyInstEnv ) import Desugar diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 8c8fee439d..dcd85f85d9 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -34,7 +34,7 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) (" ImpAll ", import_all), (" ImpPartial ", import_partial), (" ImpHiding ", import_hiding), - ("FixityDecls ", fixity_ds), + ("FixityDecls ", fixity_sigs), ("DefaultDecls ", default_ds), ("TypeDecls ", type_ds), ("DataDecls ", data_ds), @@ -64,7 +64,8 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - fixity_ds = count (\ x -> case x of { FixD{} -> True; _ -> False}) decls + (fixity_sigs, bind_tys, _, bind_specs, bind_inlines) + = count_sigs [d | SigD d <- decls] -- NB: this omits fixity decls on local bindings and -- in class decls. ToDo @@ -83,8 +84,8 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) export_ds = n_exports - export_ms export_all = case exports of { Nothing -> 1; other -> 0 } - (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines) - = count_binds (foldr ThenBinds EmptyBinds val_decls) + (val_bind_ds, fn_bind_ds) + = foldr add2 (0,0) (map count_monobinds val_decls) (import_no, import_qual, import_as, import_all, import_partial, import_hiding) = foldr add6 (0,0,0,0,0,0) (map import_info imports) @@ -95,12 +96,6 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) (inst_method_ds, method_specs, method_inlines) = foldr add3 (0,0,0) (map inst_info inst_decls) - - count_binds EmptyBinds = (0,0,0,0,0) - count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2 - count_binds (MonoBind b sigs _) = case (count_monobinds b, count_sigs sigs) of - ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is) - count_monobinds EmptyMonoBinds = (0,0) count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2 count_monobinds (PatMonoBind (VarPat n) r _) = (1,0) @@ -110,13 +105,14 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) count_mb_monobinds (Just mbs) = count_monobinds mbs count_mb_monobinds Nothing = (0,0) - count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) + count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) - sig_info (Sig _ _ _) = (1,0,0,0) - sig_info (ClassOpSig _ _ _ _) = (0,1,0,0) - sig_info (SpecSig _ _ _) = (0,0,1,0) - sig_info (InlineSig _ _ _ _) = (0,0,0,1) - sig_info _ = (0,0,0,0) + sig_info (FixSig _) = (1,0,0,0,0) + sig_info (Sig _ _ _) = (0,1,0,0,0) + sig_info (ClassOpSig _ _ _ _) = (0,0,1,0,0) + sig_info (SpecSig _ _ _) = (0,0,0,1,0) + sig_info (InlineSig _ _ _ _) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) import_info (ImportDecl _ _ qual as spec _) = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) @@ -134,13 +130,13 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) class_info decl@(ClassDecl {}) = case count_sigs (tcdSigs decl) of - (_,classops,_,_) -> + (_,_,classops,_,_) -> (classops, addpr (count_mb_monobinds (tcdMeths decl))) class_info other = (0,0) inst_info (InstDecl _ inst_meths inst_sigs _ _) = case count_sigs inst_sigs of - (_,_,ss,is) -> + (_,_,_,ss,is) -> (addpr (count_monobinds inst_meths), ss, is) addpr :: (Int,Int) -> Int diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 1c9c47d271..f90e5959e1 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.105 2002/09/27 08:20:45 simonpj Exp $ +$Id: Parser.y,v 1.106 2002/10/09 15:03:53 simonpj Exp $ Haskell grammar. @@ -19,7 +19,6 @@ import HsTypes ( mkHsTupCon ) import RdrHsSyn import HscTypes ( ParsedIface(..), IsBootInterface ) import Lex -import ParseUtil import RdrName import PrelNames ( mAIN_Name, funTyConName, listTyConName, parrTyConName, consDataConName, nilDataConName ) @@ -280,7 +279,7 @@ top :: { ([RdrNameImportDecl], [RdrNameHsDecl]) } | cvtopdecls { ([],$1) } cvtopdecls :: { [RdrNameHsDecl] } - : topdecls { cvTopDecls (groupBindings $1)} + : topdecls { cvTopDecls $1 } ----------------------------------------------------------------------------- -- Interfaces (.hi-boot files) @@ -307,30 +306,14 @@ ifacebody :: { [RdrNameTyClDecl] } | layout_on ifacedecls close { $2 } ifacedecls :: { [RdrNameTyClDecl] } - : ifacedecl ';' ifacedecls { $1 : $3 } - | ';' ifacedecls { $2 } - | ifacedecl { [$1] } - | {- empty -} { [] } + : ifacedecl ';' ifacedecls { $1 : $3 } + | ';' ifacedecls { $2 } + | ifacedecl { [$1] } + | {- empty -} { [] } ifacedecl :: { RdrNameTyClDecl } - : srcloc 'data' tycl_hdr constrs - { mkTyData DataType $3 (DataCons (reverse $4)) Nothing $1 } - - | srcloc 'newtype' tycl_hdr '=' newconstr - { mkTyData NewType $3 (DataCons [$5]) Nothing $1 } - - | srcloc 'class' tycl_hdr fds where - { let - (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig - (groupBindings $5) - in - mkClassDecl $3 $4 sigs (Just binds) $1 } - - | srcloc 'type' tycon tv_bndrs '=' ctype - { TySynonym $3 $4 $6 $1 } - - | srcloc var '::' sigtype - { IfaceSig $2 $4 [] $1 } + : tycl_decl { $1 } + | srcloc var '::' sigtype { IfaceSig $2 $4 [] $1 } ----------------------------------------------------------------------------- -- The Export List @@ -404,8 +387,7 @@ impspec :: { (Bool, [RdrNameIE]) } prec :: { Int } : {- empty -} { 9 } - | INTEGER {% checkPrec $1 `thenP_` - returnP (fromInteger $1) } + | INTEGER {% checkPrecP (fromInteger $1) } infix :: { FixityDirection } : 'infix' { InfixN } @@ -419,48 +401,43 @@ ops :: { [RdrName] } ----------------------------------------------------------------------------- -- Top-Level Declarations -topdecls :: { [RdrBinding] } - : topdecls ';' topdecl { ($3 : $1) } +topdecls :: { [RdrBinding] } -- Reversed + : topdecls ';' topdecl { $3 : $1 } | topdecls ';' { $1 } | topdecl { [$1] } topdecl :: { RdrBinding } + : tycl_decl { RdrHsDecl (TyClD $1) } + | srcloc 'instance' inst_type where + { let (binds,sigs) = cvMonoBindsAndSigs $4 + in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) } + | srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) } + | 'foreign' fdecl { RdrHsDecl $2 } + | '{-# DEPRECATED' deprecations '#-}' { RdrBindings $2 } + | '{-# RULES' rules '#-}' { RdrBindings $2 } + | '$(' exp ')' { RdrHsDecl (SpliceD $2) } + | decl { $1 } + +tycl_decl :: { RdrNameTyClDecl } : srcloc 'type' syn_hdr '=' ctype -- Note ctype, not sigtype. -- We allow an explicit for-all but we don't insert one -- in type Foo a = (b,b) -- Instead we just say b is out of scope - { let (tc,tvs) = $3 - in RdrHsDecl (TyClD (TySynonym tc tvs $5 $1)) } + { let (tc,tvs) = $3 in TySynonym tc tvs $5 $1 } | srcloc 'data' tycl_hdr constrs deriving - {% returnP (RdrHsDecl (TyClD - (mkTyData DataType $3 (DataCons (reverse $4)) $5 $1))) } + { mkTyData DataType $3 (DataCons (reverse $4)) $5 $1 } | srcloc 'newtype' tycl_hdr '=' newconstr deriving - {% returnP (RdrHsDecl (TyClD - (mkTyData NewType $3 (DataCons [$5]) $6 $1))) } + { mkTyData NewType $3 (DataCons [$5]) $6 $1 } | srcloc 'class' tycl_hdr fds where - {% let - (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig (groupBindings $5) - in - returnP (RdrHsDecl (TyClD - (mkClassDecl $3 $4 sigs (Just binds) $1))) } - - | srcloc 'instance' inst_type where - { let (binds,sigs) - = cvMonoBindsAndSigs cvInstDeclSig - (groupBindings $4) - in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) } - - | srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) } - | 'foreign' fdecl { RdrHsDecl $2 } - | '{-# DEPRECATED' deprecations '#-}' { $2 } - | '{-# RULES' rules '#-}' { $2 } - | '$(' exp ')' { RdrHsDecl (SpliceD $2) } - | decl { $1 } + { let + (binds,sigs) = cvMonoBindsAndSigs $5 + in + mkClassDecl $3 $4 (map cvClassOpSig sigs) (Just binds) $1 } syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an infix -- type synonym declaration. Oh well. @@ -479,94 +456,41 @@ tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) } | type {% checkTyClHdr $1 `thenP` \ (tc,tvs) -> returnP ([], tc, tvs) } -{- - : '(' comma_types1 ')' '=>' gtycon tv_bndrs - {% mapP checkPred $2 `thenP` \ cxt -> - returnP (cxt, $5, $6) } - - | '(' ')' '=>' gtycon tv_bndrs - { ([], $4, $5) } - - -- qtycon for the class below name would lead to many s/r conflicts - -- FIXME: does the renamer pick up all wrong forms and raise an - -- error - | gtycon atypes1 '=>' gtycon atypes0 - {% checkTyVars $5 `thenP` \ tvs -> - returnP ([HsClassP $1 $2], $4, tvs) } - - | gtycon atypes0 - {% checkTyVars $2 `thenP` \ tvs -> - returnP ([], $1, tvs) } - -- We have to have qtycon in this production to avoid s/r - -- conflicts with the previous one. The renamer will complain - -- if we use a qualified tycon. - -- - -- Using a `gtycon' throughout. This enables special syntax, - -- such as "[]" for tycons as well as tycon ops in - -- parentheses. This is beyond H98, but used repeatedly in - -- the Prelude modules. (So, it would be a good idea to raise - -- an error in the renamer if some non-H98 form is used and - -- -fglasgow-exts is not given.) -=chak - -atypes0 :: { [RdrNameHsType] } - : atypes1 { $1 } - | {- empty -} { [] } - -atypes1 :: { [RdrNameHsType] } - : atype { [$1] } - | atype atypes1 { $1 : $2 } --} +----------------------------------------------------------------------------- +-- Nested declarations -decls :: { [RdrBinding] } +decls :: { [RdrBinding] } -- Reversed : decls ';' decl { $3 : $1 } | decls ';' { $1 } | decl { [$1] } | {- empty -} { [] } -decl :: { RdrBinding } - : fixdecl { $1 } - | valdef { $1 } - | '{-# INLINE' srcloc activation qvar '#-}' { RdrSig (InlineSig True $4 $3 $2) } - | '{-# NOINLINE' srcloc inverse_activation qvar '#-}' { RdrSig (InlineSig False $4 $3 $2) } - | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}' - { foldr1 RdrAndBindings - (map (\t -> RdrSig (SpecSig $3 t $2)) $5) } - | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}' - { RdrSig (SpecInstSig $4 $2) } wherebinds :: { RdrNameHsBinds } - : where { cvBinds cvValSig (groupBindings $1) } + : where { cvBinds $1 } -where :: { [RdrBinding] } +where :: { [RdrBinding] } -- Reversed : 'where' decllist { $2 } | {- empty -} { [] } -declbinds :: { RdrNameHsBinds } - : decllist { cvBinds cvValSig (groupBindings $1) } - -decllist :: { [RdrBinding] } +decllist :: { [RdrBinding] } -- Reversed : '{' decls '}' { $2 } | layout_on decls close { $2 } letbinds :: { RdrNameHsExpr -> RdrNameHsExpr } - : decllist { HsLet (cvBinds cvValSig (groupBindings $1)) } + : decllist { HsLet (cvBinds $1) } | '{' dbinds '}' { \e -> HsWith e $2 False{-not with-} } | layout_on dbinds close { \e -> HsWith e $2 False{-not with-} } -fixdecl :: { RdrBinding } - : srcloc infix prec ops { foldr1 RdrAndBindings - [ RdrSig (FixSig (FixitySig n - (Fixity $3 $2) $1)) - | n <- $4 ] } + ----------------------------------------------------------------------------- -- Transformation Rules -rules :: { RdrBinding } - : rules ';' rule { $1 `RdrAndBindings` $3 } - | rules ';' { $1 } - | rule { $1 } - | {- empty -} { RdrNullBind } +rules :: { [RdrBinding] } + : rule ';' rules { $1 : $3 } + | rule { [$1] } + | {- empty -} { [] } rule :: { RdrBinding } : STRING activation rule_forall infixexp '=' srcloc exp @@ -599,16 +523,15 @@ rule_var :: { RdrNameRuleBndr } ----------------------------------------------------------------------------- -- Deprecations -deprecations :: { RdrBinding } - : deprecations ';' deprecation { $1 `RdrAndBindings` $3 } - | deprecations ';' { $1 } - | deprecation { $1 } - | {- empty -} { RdrNullBind } +deprecations :: { [RdrBinding] } + : deprecation ';' deprecations { $1 : $3 } + | deprecation { [$1] } + | {- empty -} { [] } -- SUP: TEMPORARY HACK, not checking for `module Foo' deprecation :: { RdrBinding } : srcloc depreclist STRING - { foldr RdrAndBindings RdrNullBind + { RdrBindings [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] } @@ -957,16 +880,13 @@ deriving :: { Maybe RdrNameContext } We can't tell whether to reduce var to qvar until after we've read the signatures. -} -valdef :: { RdrBinding } - : infixexp srcloc opt_sig rhs {% (checkValDef $1 $3 $4 $2) } - | infixexp srcloc '::' sigtype {% (checkValSig $1 $4 $2) } - | var ',' sig_vars srcloc '::' sigtype { foldr1 RdrAndBindings - [ RdrSig (Sig n $6 $4) | n <- $1:$3 ] - } +decl :: { RdrBinding } + : sigdecl { $1 } + | infixexp srcloc opt_sig rhs {% checkValDef $1 $3 $4 $2 } rhs :: { RdrNameGRHSs } - : '=' srcloc exp wherebinds { (GRHSs (unguardedRHS $3 $2) $4 placeHolderType)} - | gdrhs wherebinds { GRHSs (reverse $1) $2 placeHolderType } + : '=' srcloc exp wherebinds { GRHSs (unguardedRHS $3 $2) $4 placeHolderType } + | gdrhs wherebinds { GRHSs (reverse $1) $2 placeHolderType } gdrhs :: { [RdrNameGRHS] } : gdrhs gdrh { $2 : $1 } @@ -975,11 +895,28 @@ gdrhs :: { [RdrNameGRHS] } gdrh :: { RdrNameGRHS } : '|' srcloc quals '=' exp { GRHS (reverse (ResultStmt $5 $2 : $3)) $2 } +sigdecl :: { RdrBinding } + : infixexp srcloc '::' sigtype + {% checkValSig $1 $4 $2 } + -- See the above notes for why we need infixexp here + | var ',' sig_vars srcloc '::' sigtype + { mkSigDecls [ Sig n $6 $4 | n <- $1:$3 ] } + | srcloc infix prec ops { mkSigDecls [ FixSig (FixitySig n (Fixity $3 $2) $1) + | n <- $4 ] } + | '{-# INLINE' srcloc activation qvar '#-}' + { RdrHsDecl (SigD (InlineSig True $4 $3 $2)) } + | '{-# NOINLINE' srcloc inverse_activation qvar '#-}' + { RdrHsDecl (SigD (InlineSig False $4 $3 $2)) } + | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}' + { mkSigDecls [ SpecSig $3 t $2 | t <- $5] } + | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}' + { RdrHsDecl (SigD (SpecInstSig $4 $2)) } + ----------------------------------------------------------------------------- -- Expressions exp :: { RdrNameHsExpr } - : infixexp '::' sigtype { (ExprWithTySig $1 $3) } + : infixexp '::' sigtype { ExprWithTySig $1 $3 } | infixexp 'with' dbinding { HsWith $1 $3 True{-not a let-} } | infixexp { $1 } @@ -1069,7 +1006,7 @@ aexp2 :: { RdrNameHsExpr } | '[t|' ctype '|]' { HsBracket (TypBr $2) } | '[p|' srcloc infixexp '|]' {% checkPattern $2 $3 `thenP` \p -> returnP (HsBracket (PatBr p)) } - | '[d|' cvtopdecls '|]' { HsBracket (DecBr $2) } + | '[d|' cvtopdecls '|]' { HsBracket (DecBr (mkGroup $2)) } texps :: { [RdrNameHsExpr] } @@ -1207,7 +1144,7 @@ stmt :: { RdrNameStmt } : srcloc infixexp '<-' exp {% checkPattern $1 $2 `thenP` \p -> returnP (BindStmt p $4 $1) } | srcloc exp { ExprStmt $2 placeHolderType $1 } - | srcloc 'let' declbinds { LetStmt $3 } + | srcloc 'let' decllist { LetStmt (cvBinds $3) } ----------------------------------------------------------------------------- -- Record Field Update/Construction diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index b00d84d308..1ed2429473 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -42,30 +42,73 @@ module RdrHsSyn ( RdrBinding(..), RdrMatch(..), - SigConverter, extractHsTyRdrNames, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, - mkHsDo, mkHsSplice, + mkHsDo, mkHsSplice, mkSigDecls, + mkTyData, mkPrefixCon, mkRecCon, + mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp + mkIfaceExports, -- :: [RdrNameTyClDecl] -> [RdrExportItem] cvBinds, cvMonoBindsAndSigs, cvTopDecls, - cvValSig, cvClassOpSig, cvInstDeclSig, - mkTyData + cvClassOpSig, + findSplice, addImpDecls, emptyGroup, mkGroup, + + -- Stuff to do with Foreign declarations + , CallConv(..) + , mkImport -- CallConv -> Safety + -- -> (FastString, RdrName, RdrNameHsType) + -- -> SrcLoc + -- -> P RdrNameHsDecl + , mkExport -- CallConv + -- -> (FastString, RdrName, RdrNameHsType) + -- -> SrcLoc + -- -> P RdrNameHsDecl + , mkExtName -- RdrName -> CLabelString + + -- Bunch of functions in the parser monad for + -- checking and constructing values + , checkPrecP -- Int -> P Int + , checkContext -- HsType -> P HsContext + , checkPred -- HsType -> P HsPred + , checkTyVars -- [HsTyVar] -> P [HsType] + , checkTyClHdr -- HsType -> (name,[tyvar]) + , checkInstType -- HsType -> P HsType + , checkPattern -- HsExp -> P HsPat + , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat] + , checkDo -- [Stmt] -> P [Stmt] + , checkMDo -- [Stmt] -> P [Stmt] + , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + , parseError -- String -> Pa ) where #include "HsVersions.h" import HsSyn -- Lots of it -import OccName ( mkDefaultMethodOcc, mkVarOcc ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar ) -import List ( nub ) -import BasicTypes ( RecFlag(..), FixitySig ) +import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc, + isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, + setRdrNameSpace ) +import BasicTypes ( RecFlag(..), FixitySig(..), maxPrecedence ) import Class ( DefMeth (..) ) +import Lex ( P, mapP, setSrcLocP, thenP, returnP, getSrcLocP, failMsgP ) +import HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) +import TysWiredIn ( unitTyCon ) +import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), + DNCallSpec(..)) +import OccName ( dataName, varName, isDataOcc, isTcOcc, occNameUserString, + mkDefaultMethodOcc, mkVarOcc ) +import SrcLoc +import CStrings ( CLabelString ) +import List ( isSuffixOf, nub ) +import Outputable +import FastString +import Panic \end{code} @@ -253,23 +296,14 @@ unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) \begin{code} data RdrBinding - = -- On input we use the Empty/And form rather than a list - RdrNullBind - | RdrAndBindings RdrBinding RdrBinding - - -- Value bindings havn't been united with their + = -- Value bindings havn't been united with their -- signatures yet - | RdrValBinding RdrNameMonoBinds + RdrBindings [RdrBinding] -- Convenience for parsing - -- Signatures are mysterious; we can't - -- tell if its a Sig or a ClassOpSig, - -- so we just save the pieces: - | RdrSig RdrNameSig + | RdrValBinding RdrNameMonoBinds -- The remainder all fit into the main HsDecl form | RdrHsDecl RdrNameHsDecl - -type SigConverter = RdrNameSig -> RdrNameSig \end{code} \begin{code} @@ -290,12 +324,7 @@ We make a point not to throw any user-pragma ``sigs'' at these conversion functions: \begin{code} -cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter - -cvValSig sig = sig - -cvInstDeclSig sig = sig - +cvClassOpSig :: RdrNameSig -> RdrNameSig cvClassOpSig (Sig var poly_ty src_loc) = mkClassOpSigDM var poly_ty src_loc cvClassOpSig sig = sig \end{code} @@ -311,38 +340,125 @@ Function definitions are restructured here. Each is assumed to be recursive initially, and non recursive definitions are discovered by the dependency analyser. -\begin{code} -cvBinds :: SigConverter -> RdrBinding -> RdrNameHsBinds - -- The mysterious SigConverter converts Sigs to ClassOpSigs - -- in class declarations. Mostly it's just an identity function -cvBinds sig_cvtr binding - = case (cvMonoBindsAndSigs sig_cvtr binding) of { (mbs, sigs) -> +\begin{code} +cvTopDecls :: [RdrBinding] -> [RdrNameHsDecl] +-- Incoming bindings are in reverse order; result is in ordinary order +-- (a) flatten RdrBindings +-- (b) Group together bindings for a single function +cvTopDecls decls + = go [] decls + where + go :: [RdrNameHsDecl] -> [RdrBinding] -> [RdrNameHsDecl] + go acc [] = acc + go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2 + go acc (RdrHsDecl d : ds) = go (d : acc) ds + go acc (RdrValBinding b : ds) = go (ValD b' : acc) ds' + where + (b', ds') = getMonoBind b ds + +cvBinds :: [RdrBinding] -> RdrNameHsBinds +cvBinds binding + = case (cvMonoBindsAndSigs binding) of { (mbs, sigs) -> MonoBind mbs sigs Recursive } -\end{code} -\begin{code} -cvMonoBindsAndSigs :: SigConverter - -> RdrBinding - -> (RdrNameMonoBinds, [RdrNameSig]) +cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig]) +-- Input bindings are in *reverse* order, +-- and contain just value bindings and signatuers -cvMonoBindsAndSigs sig_cvtr fb - = mangle_bind (EmptyMonoBinds, []) fb +cvMonoBindsAndSigs fb + = go (EmptyMonoBinds, []) fb where - mangle_bind acc RdrNullBind - = acc - - mangle_bind acc (RdrAndBindings fb1 fb2) - = mangle_bind (mangle_bind acc fb1) fb2 - - mangle_bind (b_acc, s_acc) (RdrSig sig) - = (b_acc, sig_cvtr sig : s_acc) - - mangle_bind (b_acc, s_acc) (RdrValBinding binding) - = (b_acc `AndMonoBinds` binding, s_acc) + go acc [] = acc + go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2 + go (bs, ss) (RdrHsDecl (SigD s) : ds) = go (bs, s : ss) ds + go (bs, ss) (RdrValBinding b : ds) = go (b' `AndMonoBinds` bs, ss) ds' + where + (b',ds') = getMonoBind b ds + +----------------------------------------------------------------------------- +-- Group function bindings into equation groups + +getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBinding]) +-- Suppose (b',ds') = getMonoBind b ds +-- ds is a *reversed* list of parsed bindings +-- b is a MonoBinds that has just been read off the front + +-- Then b' is the result of grouping more equations from ds that +-- belong with b into a single MonoBinds, and ds' is the depleted +-- list of parsed bindings. +-- +-- No AndMonoBinds or EmptyMonoBinds here; just single equations + +getMonoBind (FunMonoBind f1 inf1 mtchs1 loc1) binds + | has_args mtchs1 + = go mtchs1 loc1 binds + where + go mtchs loc (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds) + | f1 == f2 = go (mtchs2 ++ mtchs1) loc2 binds + -- Remember binds is reversed, so glue mtchs2 on the front + -- and use loc2 as the final location + go mtchs loc binds = (FunMonoBind f1 inf1 mtchs loc, binds) + +has_args ((Match args _ _) : _) = not (null args) + -- Don't group together FunMonoBinds if they have + -- no arguments. This is necessary now that variable bindings + -- with no arguments are now treated as FunMonoBinds rather + -- than pattern bindings (tests/rename/should_fail/rnfail002). \end{code} +\begin{code} +emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive, + -- The renamer adds structure to the bindings; + -- they start life as a single giant MonoBinds + hs_tyclds = [], hs_instds = [], + hs_fixds = [], hs_defds = [], hs_fords = [], + hs_depds = [] ,hs_ruleds = [], hs_coreds = [] } + +findSplice :: [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a])) +findSplice ds = add emptyGroup ds + +mkGroup :: [HsDecl a] -> HsGroup a +mkGroup ds = addImpDecls emptyGroup ds + +addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a +-- The decls are imported, and should not have a splice +addImpDecls group decls = case add group decls of + (group', Nothing) -> group' + other -> panic "addImpDecls" + +add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (HsExpr a, [HsDecl a])) + -- This stuff reverses the declarations (again) but it doesn't matter + +-- Base cases +add gp [] = (gp, Nothing) +add gp (SpliceD e : ds) = (gp, Just (e, ds)) + +-- Class declarations: pull out the fixity signatures to the top +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds) + | isClassDecl d = add (gp { hs_tyclds = d : ts, + hs_fixds = [f | FixSig f <- tcdSigs d] }) ds + | otherwise = add (gp { hs_tyclds = d : ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds +add gp@(HsGroup {hs_valds = ts}) (SigD d : ds) = add (gp {hs_valds = add_sig d ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_instds = ts}) (InstD d : ds) = add (gp { hs_instds = d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds +add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds +add gp@(HsGroup {hs_coreds = ts})(CoreD d : ds) = add (gp { hs_coreds = d : ts }) ds + +add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r +add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r +\end{code} %************************************************************************ %* * @@ -350,20 +466,403 @@ cvMonoBindsAndSigs sig_cvtr fb %* * %************************************************************************ -Separate declarations into all the various kinds: \begin{code} -cvTopDecls :: RdrBinding -> [RdrNameHsDecl] -cvTopDecls bind - = let - (top_decls, mono_binds, sigs) = go ([], EmptyMonoBinds, []) bind - in - (ValD (MonoBind mono_binds sigs Recursive) : top_decls) +----------------------------------------------------------------------------- +-- mkPrefixCon + +-- When parsing data declarations, we sometimes inadvertently parse +-- a constructor application as a type (eg. in data T a b = C a b `D` E a b) +-- This function splits up the type application, adds any pending +-- arguments, and converts the type constructor back into a data constructor. + +mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails) + +mkPrefixCon ty tys + = split ty tys + where + split (HsAppTy t u) ts = split t (unbangedType u : ts) + split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con -> + returnP (data_con, PrefixCon ts) + split _ _ = parseError "Illegal data/newtype declaration" + +mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails) +mkRecCon con fields + = tyConToDataCon con `thenP` \ data_con -> + returnP (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) + +tyConToDataCon :: RdrName -> P RdrName +tyConToDataCon tc + | isTcOcc (rdrNameOcc tc) + = returnP (setRdrNameSpace tc dataName) + | otherwise + = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) + +---------------------------------------------------------------------------- +-- Various Syntactic Checks + +checkInstType :: RdrNameHsType -> P RdrNameHsType +checkInstType t + = case t of + HsForAllTy tvs ctxt ty -> + checkDictTy ty [] `thenP` \ dict_ty -> + returnP (HsForAllTy tvs ctxt dict_ty) + + HsParTy ty -> checkInstType ty + + ty -> checkDictTy ty [] `thenP` \ dict_ty-> + returnP (HsForAllTy Nothing [] dict_ty) + +checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar] +checkTyVars tvs = mapP chk tvs + where + chk (HsKindSig (HsTyVar tv) k) = returnP (IfaceTyVar tv k) + chk (HsTyVar tv) = returnP (UserTyVar tv) + chk other = parseError "Type found where type variable expected" + +checkTyClHdr :: RdrNameHsType -> P (RdrName, [RdrNameHsTyVar]) +-- The header of a type or class decl should look like +-- (C a, D b) => T a b +-- or T a b +-- or a + b +-- etc +checkTyClHdr ty + = go ty [] + where + go (HsTyVar tc) acc + | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs -> + returnP (tc, tvs) + go (HsOpTy t1 (HsTyOp tc) t2) acc + = checkTyVars (t1:t2:acc) `thenP` \ tvs -> + returnP (tc, tvs) + go (HsParTy ty) acc = go ty acc + go (HsAppTy t1 t2) acc = go t1 (t2:acc) + go other acc = parseError "Malformed LHS to type of class declaration" + +checkContext :: RdrNameHsType -> P RdrNameContext +checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type + = mapP checkPred ts + +checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way + = checkContext ty + +checkContext (HsTyVar t) -- Empty context shows up as a unit type () + | t == getRdrName unitTyCon = returnP [] + +checkContext t + = checkPred t `thenP` \p -> + returnP [p] + +checkPred :: RdrNameHsType -> P (HsPred RdrName) +-- Watch out.. in ...deriving( Show )... we use checkPred on +-- the list of partially applied predicates in the deriving, +-- so there can be zero args. +checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty) +checkPred ty + = go ty [] + where + go (HsTyVar t) args | not (isRdrTyVar t) + = returnP (HsClassP t args) + go (HsAppTy l r) args = go l (r:args) + go (HsParTy t) args = go t args + go _ _ = parseError "Illegal class assertion" + +checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType +checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) + = returnP (mkHsDictTy t args) +checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) +checkDictTy (HsParTy t) args = checkDictTy t args +checkDictTy _ _ = parseError "Malformed context in instance header" + + +--------------------------------------------------------------------------- +-- Checking statements in a do-expression +-- We parse do { e1 ; e2 ; } +-- as [ExprStmt e1, ExprStmt e2] +-- checkDo (a) checks that the last thing is an ExprStmt +-- (b) transforms it to a ResultStmt +-- same comments apply for mdo as well + +checkDo = checkDoMDo "a " "'do'" +checkMDo = checkDoMDo "an " "'mdo'" + +checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct" +checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l] +checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression" +checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss `thenP` \ ss' -> + returnP (s:ss') + +--------------------------------------------------------------------------- +-- Checking Patterns. + +-- We parse patterns as expressions and check for valid patterns below, +-- converting the expression into a pattern at the same time. + +checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat +checkPattern loc e = setSrcLocP loc (checkPat e []) + +checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat] +checkPatterns loc es = mapP (checkPattern loc) es + +checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat +checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args)) +checkPat (HsApp f x) args = + checkPat x [] `thenP` \x -> + checkPat f (x:args) +checkPat e [] = case e of + EWildPat -> returnP (WildPat placeHolderType) + HsVar x -> returnP (VarPat x) + HsLit l -> returnP (LitPat l) + HsOverLit l -> returnP (NPatIn l Nothing) + ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat) + EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n) + ExprWithTySig e t -> checkPat e [] `thenP` \e -> + -- Pattern signatures are parsed as sigtypes, + -- but they aren't explicit forall points. Hence + -- we have to remove the implicit forall here. + let t' = case t of + HsForAllTy Nothing [] ty -> ty + other -> other + in + returnP (SigPatIn e t') + + -- Translate out NegApps of literals in patterns. We negate + -- the Integer here, and add back the call to 'negate' when + -- we typecheck the pattern. + -- NB. Negative *primitive* literals are already handled by + -- RdrHsSyn.mkHsNegApp + NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg)) + + OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _)) + | plus == plus_RDR + -> returnP (mkNPlusKPat n lit) + where + plus_RDR = mkUnqual varName FSLIT("+") -- Hack + + OpApp l op fix r -> checkPat l [] `thenP` \l -> + checkPat r [] `thenP` \r -> + case op of + HsVar c | isDataOcc (rdrNameOcc c) + -> returnP (ConPatIn c (InfixCon l r)) + _ -> patFail + + HsPar e -> checkPat e [] `thenP` (returnP . ParPat) + ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (ListPat ps placeHolderType) + ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (PArrPat ps placeHolderType) + + ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps -> + returnP (TuplePat ps b) + + RecordCon c fs -> mapP checkPatField fs `thenP` \fs -> + returnP (ConPatIn c (RecCon fs)) +-- Generics + HsType ty -> returnP (TypePat ty) + _ -> patFail + +checkPat _ _ = patFail + +checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat) +checkPatField (n,e) = checkPat e [] `thenP` \p -> + returnP (n,p) + +patFail = parseError "Parse error in pattern" + + +--------------------------------------------------------------------------- +-- Check Equation Syntax + +checkValDef + :: RdrNameHsExpr + -> Maybe RdrNameHsType + -> RdrNameGRHSs + -> SrcLoc + -> P RdrBinding + +checkValDef lhs opt_sig grhss loc + = case isFunLhs lhs [] of + Just (f,inf,es) -> + checkPatterns loc es `thenP` \ps -> + returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc)) + + Nothing -> + checkPattern loc lhs `thenP` \lhs -> + returnP (RdrValBinding (PatMonoBind lhs grhss loc)) + +checkValSig + :: RdrNameHsExpr + -> RdrNameHsType + -> SrcLoc + -> P RdrBinding +checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc))) +checkValSig other ty loc = parseError "Type signature given for an expression" + +mkSigDecls :: [Sig RdrName] -> RdrBinding +mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs] + + +-- A variable binding is parsed as an RdrNameFunMonoBind. +-- See comments with HsBinds.MonoBinds + +isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr]) +isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) + = Just (op, True, (l:r:es)) + | otherwise + = case isFunLhs l es of + Just (op', True, j : k : es') -> + Just (op', True, j : OpApp k (HsVar op) fix r : es') + _ -> Nothing +isFunLhs (HsVar f) es | not (isRdrDataCon f) + = Just (f,False,es) +isFunLhs (HsApp f e) es = isFunLhs f (e:es) +isFunLhs (HsPar e) es@(_:_) = isFunLhs e es +isFunLhs _ _ = Nothing + +--------------------------------------------------------------------------- +-- Miscellaneous utilities + +checkPrecP :: Int -> P Int +checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i + | otherwise = parseError "Precedence out of range" + +mkRecConstrOrUpdate + :: RdrNameHsExpr + -> RdrNameHsRecordBinds + -> P RdrNameHsExpr + +mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c + = returnP (RecordCon c fs) +mkRecConstrOrUpdate exp fs@(_:_) + = returnP (RecordUpd exp fs) +mkRecConstrOrUpdate _ _ + = parseError "Empty record update" + +----------------------------------------------------------------------------- +-- utilities for foreign declarations + +-- supported calling conventions +-- +data CallConv = CCall CCallConv -- ccall or stdcall + | DNCall -- .NET + +-- construct a foreign import declaration +-- +mkImport :: CallConv + -> Safety + -> (FastString, RdrName, RdrNameHsType) + -> SrcLoc + -> P RdrNameHsDecl +mkImport (CCall cconv) safety (entity, v, ty) loc = + parseCImport entity cconv safety v `thenP` \importSpec -> + returnP $ ForD (ForeignImport v ty importSpec False loc) +mkImport (DNCall ) _ (entity, v, ty) loc = + returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc) + +-- parse the entity string of a foreign import declaration for the `ccall' or +-- `stdcall' calling convention' +-- +parseCImport :: FastString + -> CCallConv + -> Safety + -> RdrName + -> P ForeignImport +parseCImport entity cconv safety v + -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak + | entity == FSLIT ("dynamic") = + returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) + | entity == FSLIT ("wrapper") = + returnP $ CImport cconv safety nilFS nilFS CWrapper + | otherwise = parse0 (unpackFS entity) + where + -- using the static keyword? + parse0 (' ': rest) = parse0 rest + parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest + parse0 rest = parse1 rest + -- check for header file name + parse1 "" = parse4 "" nilFS False nilFS + parse1 (' ':rest) = parse1 rest + parse1 str@('&':_ ) = parse2 str nilFS + parse1 str@('[':_ ) = parse3 str nilFS False + parse1 str + | ".h" `isSuffixOf` first = parse2 rest (mkFastString first) + | otherwise = parse4 str nilFS False nilFS + where + (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str + -- check for address operator (indicating a label import) + parse2 "" header = parse4 "" header False nilFS + parse2 (' ':rest) header = parse2 rest header + parse2 ('&':rest) header = parse3 rest header True + parse2 str@('[':_ ) header = parse3 str header False + parse2 str header = parse4 str header False nilFS + -- check for library object name + parse3 (' ':rest) header isLbl = parse3 rest header isLbl + parse3 ('[':rest) header isLbl = + case break (== ']') rest of + (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib) + _ -> parseError "Missing ']' in entity" + parse3 str header isLbl = parse4 str header isLbl nilFS + -- check for name of C function + parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib + parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib + parse4 str header isLbl lib + | all (== ' ') rest = build (mkFastString first) header isLbl lib + | otherwise = parseError "Malformed entity string" + where + (first, rest) = break (== ' ') str + -- + build cid header False lib = returnP $ + CImport cconv safety header lib (CFunction (StaticTarget cid)) + build cid header True lib = returnP $ + CImport cconv safety header lib (CLabel cid ) + +-- construct a foreign export declaration +-- +mkExport :: CallConv + -> (FastString, RdrName, RdrNameHsType) + -> SrcLoc + -> P RdrNameHsDecl +mkExport (CCall cconv) (entity, v, ty) loc = returnP $ + ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc) where - go acc RdrNullBind = acc - go acc (RdrAndBindings b1 b2) = go (go acc b1) b2 - go (topds, mbs, sigs) (RdrHsDecl d) = (d : topds, mbs, sigs) - go (topds, mbs, sigs) (RdrSig (FixSig d)) = (FixD d : topds, mbs, sigs) - go (topds, mbs, sigs) (RdrSig sig) = (topds, mbs, sig:sigs) - go (topds, mbs, sigs) (RdrValBinding bind) = (topds, mbs `AndMonoBinds` bind, sigs) + entity' | nullFastString entity = mkExtName v + | otherwise = entity +mkExport DNCall (entity, v, ty) loc = + parseError "Foreign export is not yet supported for .NET" + +-- Supplying the ext_name in a foreign decl is optional; if it +-- isn't there, the Haskell name is assumed. Note that no transformation +-- of the Haskell name is then performed, so if you foreign export (++), +-- it's external name will be "++". Too bad; it's important because we don't +-- want z-encoding (e.g. names with z's in them shouldn't be doubled) +-- (This is why we use occNameUserString.) +-- +mkExtName :: RdrName -> CLabelString +mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) + +-- --------------------------------------------------------------------------- +-- Make the export list for an interface + +mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo] +mkIfaceExports decls = map getExport decls + where getExport d = case d of + TyData{} -> tc_export + ClassDecl{} -> tc_export + _other -> var_export + where + tc_export = AvailTC (rdrNameOcc (tcdName d)) + (map (rdrNameOcc.fst) (tyClDeclNames d)) + var_export = Avail (rdrNameOcc (tcdName d)) \end{code} + + +----------------------------------------------------------------------------- +-- Misc utils + +\begin{code} +parseError :: String -> P a +parseError s = + getSrcLocP `thenP` \ loc -> + failMsgP (hcat [ppr loc, text ": ", text s]) +\end{code} + diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 74510fed12..766b9ce562 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -12,6 +12,7 @@ module PrelInfo ( wiredInThingEnv, ghcPrimExports, cCallableClassDecl, cReturnableClassDecl, + knownKeyNames, -- Random other things maybeCharLikeCon, maybeIntLikeCon, @@ -24,14 +25,22 @@ module PrelInfo ( #include "HsVersions.h" -import PrelNames -- Prelude module names +import PrelNames ( basicKnownKeyNames, + cCallableClassName, cReturnableClassName, + hasKey, charDataConKey, intDataConKey, + numericClassKeys, standardClassKeys, cCallishClassKeys, + noDictClassKeys ) +#ifdef GHCI +import DsMeta ( templateHaskellNames ) +#endif import PrimOp ( allThePrimOps, primOpOcc ) import DataCon ( DataCon ) import Id ( idName ) import MkId ( mkPrimOpId, wiredInIds ) import MkId -- All of it, for re-export -import Name ( nameOccName ) +import Name ( Name, nameOccName ) +import NameSet ( nameSetToList ) import RdrName ( mkRdrUnqual, getRdrName ) import HsSyn ( HsTyVarBndr(..) ) import OccName ( mkVarOcc ) @@ -40,7 +49,7 @@ import TysWiredIn ( wiredInTyCons ) import RdrHsSyn ( mkClassDecl ) import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv, GenAvailInfo(..), RdrAvailInfo ) -import Class ( Class, classKey ) +import Class ( Class, classKey, className ) import Type ( funTyCon, openTypeKind, liftedTypeKind ) import TyCon ( tyConName ) import SrcLoc ( noSrcLoc ) @@ -75,6 +84,13 @@ wiredInThings wiredInThingEnv :: TypeEnv wiredInThingEnv = mkTypeEnv wiredInThings + +knownKeyNames :: [Name] +knownKeyNames + = basicKnownKeyNames +#ifdef GHCI + ++ nameSetToList templateHaskellNames +#endif \end{code} We let a lot of "non-standard" values be visible, so that we can make @@ -153,7 +169,7 @@ isCcallishClass, isCreturnableClass, isNoDictClass, isNumericClass clas = classKey clas `is_elem` numericClassKeys isStandardClass clas = classKey clas `is_elem` standardClassKeys isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys -isCreturnableClass clas = classKey clas == cReturnableClassKey +isCreturnableClass clas = className clas == cReturnableClassName isNoDictClass clas = classKey clas `is_elem` noDictClassKeys is_elem = isIn "is_X_Class" \end{code} diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index d32f360bed..4932258ef4 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -4,13 +4,6 @@ \section[PrelNames]{Definitions of prelude modules and names} --- MetaHaskell Extension -to do -- three things -1) Allocate a key -2) Make a "Name" -3) Add the name to knownKeyNames - - The strings identify built-in prelude modules. They are defined here so as to avod @@ -53,7 +46,7 @@ module PrelNames ( -- So many that we export them all ----------------------------------------------------------- - knownKeyNames, templateHaskellNames, + basicKnownKeyNames, mkTupNameStr, isBuiltInSyntaxName, ------------------------------------------------------------ @@ -89,7 +82,6 @@ import Unique ( Unique, Uniquable(..), hasKey, ) import BasicTypes ( Boxity(..) ) import Name ( Name, mkInternalName, mkKnownKeyExternalName, mkWiredInName, nameUnique ) -import NameSet ( NameSet, mkNameSet ) import SrcLoc ( noSrcLoc ) import Util ( nOfThem ) import Panic ( panic ) @@ -151,12 +143,9 @@ This section tells what the compiler knows about the assocation of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. - -MetaHaskell Extension -It is here that the names defiend in module Meta must be added \begin{code} -knownKeyNames :: [Name] -knownKeyNames +basicKnownKeyNames :: [Name] +basicKnownKeyNames = [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, runIOName, @@ -231,53 +220,6 @@ knownKeyNames filterPName, zipPName, crossPName, indexPName, toPName, bpermutePName, bpermuteDftPName, indexOfPName, - -- MetaHaskell Extension, "the smart constructors" - -- text1 from Meta/work/gen.hs - intLName, - charLName, - plitName, - pvarName, - ptupName, - pconName, - ptildeName, - paspatName, - pwildName, - varName, - conName, - litName, - appName, - infixEName, - lamName, - tupName, - doEName, - compName, - listExpName, - condName, - letEName, - caseEName, - infixAppName, - sectionLName, - sectionRName, - guardedName, - normalName, - bindStName, - letStName, - noBindStName, - parStName, - fromName, - fromThenName, - fromToName, - fromThenToName, - liftName, - gensymName, - returnQName, - bindQName, - funName, - valName, - protoName, matchName, clauseName, - exprTyConName, declTyConName, pattTyConName, mtchTyConName, clseTyConName, - qTyConName, expTyConName, matTyConName, clsTyConName, - -- FFI primitive types that are not wired-in. int8TyConName, int16TyConName, int32TyConName, int64TyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, @@ -667,64 +609,6 @@ concatName = varQual pREL_LIST_Name FSLIT("concat") concatIdKey filterName = varQual pREL_LIST_Name FSLIT("filter") filterIdKey zipName = varQual pREL_LIST_Name FSLIT("zip") zipIdKey --- MetaHaskell Extension, "the smart constructors" --- text3 from Meta/work/gen.hs -intLName = varQual mETA_META_Name FSLIT("intL") intLIdKey -charLName = varQual mETA_META_Name FSLIT("charL") charLIdKey -plitName = varQual mETA_META_Name FSLIT("plit") plitIdKey -pvarName = varQual mETA_META_Name FSLIT("pvar") pvarIdKey -ptupName = varQual mETA_META_Name FSLIT("ptup") ptupIdKey -pconName = varQual mETA_META_Name FSLIT("pcon") pconIdKey -ptildeName = varQual mETA_META_Name FSLIT("ptilde") ptildeIdKey -paspatName = varQual mETA_META_Name FSLIT("paspat") paspatIdKey -pwildName = varQual mETA_META_Name FSLIT("pwild") pwildIdKey -varName = varQual mETA_META_Name FSLIT("var") varIdKey -conName = varQual mETA_META_Name FSLIT("con") conIdKey -litName = varQual mETA_META_Name FSLIT("lit") litIdKey -appName = varQual mETA_META_Name FSLIT("app") appIdKey -infixEName = varQual mETA_META_Name FSLIT("infixE") infixEIdKey -lamName = varQual mETA_META_Name FSLIT("lam") lamIdKey -tupName = varQual mETA_META_Name FSLIT("tup") tupIdKey -doEName = varQual mETA_META_Name FSLIT("doE") doEIdKey -compName = varQual mETA_META_Name FSLIT("comp") compIdKey -listExpName = varQual mETA_META_Name FSLIT("listExp") listExpIdKey -condName = varQual mETA_META_Name FSLIT("cond") condIdKey -letEName = varQual mETA_META_Name FSLIT("letE") letEIdKey -caseEName = varQual mETA_META_Name FSLIT("caseE") caseEIdKey -infixAppName = varQual mETA_META_Name FSLIT("infixApp") infixAppIdKey -sectionLName = varQual mETA_META_Name FSLIT("sectionL") sectionLIdKey -sectionRName = varQual mETA_META_Name FSLIT("sectionR") sectionRIdKey -guardedName = varQual mETA_META_Name FSLIT("guarded") guardedIdKey -normalName = varQual mETA_META_Name FSLIT("normal") normalIdKey -bindStName = varQual mETA_META_Name FSLIT("bindSt") bindStIdKey -letStName = varQual mETA_META_Name FSLIT("letSt") letStIdKey -noBindStName = varQual mETA_META_Name FSLIT("noBindSt") noBindStIdKey -parStName = varQual mETA_META_Name FSLIT("parSt") parStIdKey -fromName = varQual mETA_META_Name FSLIT("from") fromIdKey -fromThenName = varQual mETA_META_Name FSLIT("fromThen") fromThenIdKey -fromToName = varQual mETA_META_Name FSLIT("fromTo") fromToIdKey -fromThenToName = varQual mETA_META_Name FSLIT("fromThenTo") fromThenToIdKey -liftName = varQual mETA_META_Name FSLIT("lift") liftIdKey -gensymName = varQual mETA_META_Name FSLIT("gensym") gensymIdKey -returnQName = varQual mETA_META_Name FSLIT("returnQ") returnQIdKey -bindQName = varQual mETA_META_Name FSLIT("bindQ") bindQIdKey -funName = varQual mETA_META_Name FSLIT("fun") funIdKey -valName = varQual mETA_META_Name FSLIT("val") valIdKey -matchName = varQual mETA_META_Name FSLIT("match") matchIdKey -clauseName = varQual mETA_META_Name FSLIT("clause") clauseIdKey -protoName = varQual mETA_META_Name FSLIT("proto") protoIdKey -exprTyConName = tcQual mETA_META_Name FSLIT("Expr") exprTyConKey -declTyConName = tcQual mETA_META_Name FSLIT("Decl") declTyConKey -pattTyConName = tcQual mETA_META_Name FSLIT("Patt") pattTyConKey -mtchTyConName = tcQual mETA_META_Name FSLIT("Mtch") mtchTyConKey -clseTyConName = tcQual mETA_META_Name FSLIT("Clse") clseTyConKey -stmtTyConName = tcQual mETA_META_Name FSLIT("Stmt") stmtTyConKey - -qTyConName = tcQual mETA_META_Name FSLIT("Q") qTyConKey -expTyConName = tcQual mETA_META_Name FSLIT("Exp") expTyConKey -matTyConName = tcQual mETA_META_Name FSLIT("Mat") matTyConKey -clsTyConName = tcQual mETA_META_Name FSLIT("Cls") clsTyConKey - -- Class Show showClassName = clsQual pREL_SHOW_Name FSLIT("Show") showClassKey @@ -817,29 +701,6 @@ mfixName = varQual mONAD_FIX_Name FSLIT("mfix") mfixIdKey %************************************************************************ %* * -\subsection{Standard groups of names} -%* * -%************************************************************************ - -\begin{code} -templateHaskellNames :: NameSet --- The names that are implicitly mentioned by ``bracket'' --- Should stay in sync with the import list of DsMeta -templateHaskellNames - = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName, - pconName, ptildeName, paspatName, pwildName, - varName, conName, litName, appName, lamName, - tupName, doEName, compName, - listExpName, condName, letEName, caseEName, - infixAppName, guardedName, normalName, - bindStName, letStName, noBindStName, parStName, - fromName, fromThenName, fromToName, fromThenToName, - funName, valName, liftName,gensymName, bindQName, - appendName, matchName, clauseName ] -\end{code} - -%************************************************************************ -%* * \subsection{Local helpers} %* * %************************************************************************ @@ -981,17 +842,9 @@ genUnitTyConKey = mkPreludeTyConUnique 81 -- Parallel array type constructor parrTyConKey = mkPreludeTyConUnique 82 --- Template Haskell -qTyConKey = mkPreludeTyConUnique 83 -exprTyConKey = mkPreludeTyConUnique 84 -declTyConKey = mkPreludeTyConUnique 85 -pattTyConKey = mkPreludeTyConUnique 86 -mtchTyConKey = mkPreludeTyConUnique 87 -clseTyConKey = mkPreludeTyConUnique 88 -stmtTyConKey = mkPreludeTyConUnique 89 -expTyConKey = mkPreludeTyConUnique 90 -matTyConKey = mkPreludeTyConUnique 91 -clsTyConKey = mkPreludeTyConUnique 92 +---------------- Template Haskell ------------------- +-- USES TyConUniques 100-119 +----------------------------------------------------- unitTyConKey = mkTupleTyConUnique Boxed 0 \end{code} @@ -1141,54 +994,12 @@ bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>) returnMClassOpKey = mkPreludeMiscIdUnique 117 --- MetaHaskell Extension, (text4 118) from Meta/work/gen.hs -intLIdKey = mkPreludeMiscIdUnique 118 -charLIdKey = mkPreludeMiscIdUnique 119 -plitIdKey = mkPreludeMiscIdUnique 120 -pvarIdKey = mkPreludeMiscIdUnique 121 -ptupIdKey = mkPreludeMiscIdUnique 122 -pconIdKey = mkPreludeMiscIdUnique 123 -ptildeIdKey = mkPreludeMiscIdUnique 124 -paspatIdKey = mkPreludeMiscIdUnique 125 -pwildIdKey = mkPreludeMiscIdUnique 126 -varIdKey = mkPreludeMiscIdUnique 127 -conIdKey = mkPreludeMiscIdUnique 128 -litIdKey = mkPreludeMiscIdUnique 129 -appIdKey = mkPreludeMiscIdUnique 130 -infixEIdKey = mkPreludeMiscIdUnique 131 -lamIdKey = mkPreludeMiscIdUnique 132 -tupIdKey = mkPreludeMiscIdUnique 133 -doEIdKey = mkPreludeMiscIdUnique 134 -compIdKey = mkPreludeMiscIdUnique 135 -listExpIdKey = mkPreludeMiscIdUnique 137 -condIdKey = mkPreludeMiscIdUnique 138 -letEIdKey = mkPreludeMiscIdUnique 139 -caseEIdKey = mkPreludeMiscIdUnique 140 -infixAppIdKey = mkPreludeMiscIdUnique 141 -sectionLIdKey = mkPreludeMiscIdUnique 142 -sectionRIdKey = mkPreludeMiscIdUnique 143 -guardedIdKey = mkPreludeMiscIdUnique 144 -normalIdKey = mkPreludeMiscIdUnique 145 -bindStIdKey = mkPreludeMiscIdUnique 146 -letStIdKey = mkPreludeMiscIdUnique 147 -noBindStIdKey = mkPreludeMiscIdUnique 148 -parStIdKey = mkPreludeMiscIdUnique 149 -fromIdKey = mkPreludeMiscIdUnique 150 -fromThenIdKey = mkPreludeMiscIdUnique 151 -fromToIdKey = mkPreludeMiscIdUnique 152 -fromThenToIdKey = mkPreludeMiscIdUnique 153 -liftIdKey = mkPreludeMiscIdUnique 154 -gensymIdKey = mkPreludeMiscIdUnique 155 -returnQIdKey = mkPreludeMiscIdUnique 156 -bindQIdKey = mkPreludeMiscIdUnique 157 -funIdKey = mkPreludeMiscIdUnique 158 -valIdKey = mkPreludeMiscIdUnique 159 -protoIdKey = mkPreludeMiscIdUnique 160 -matchIdKey = mkPreludeMiscIdUnique 161 -clauseIdKey = mkPreludeMiscIdUnique 162 - -- Recursive do notation -mfixIdKey = mkPreludeMiscIdUnique 163 +mfixIdKey = mkPreludeMiscIdUnique 118 + +---------------- Template Haskell ------------------- +-- USES IdUniques 200-299 +----------------------------------------------------- \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 3205c222b3..03357aead3 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -208,7 +208,7 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds rnMonoBinds mbinds sigs `thenM` \ (binds, bind_fvs) -> -- Now do the "thing inside" - thing_inside binds `thenM` \ (result,result_fvs) -> + thing_inside binds `thenM` \ (result,result_fvs) -> -- Final error checking let diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index cb96bda651..fa8e8e380d 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -40,10 +40,10 @@ import PrelNames ( mkUnboundName, intTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, printName, bindIOName, returnIOName, failIOName, thenIOName + ) #ifdef GHCI - , templateHaskellNames, qTyConName +import DsMeta ( templateHaskellNames, qTyConName ) #endif - ) import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap import UniqSupply diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 36bbc4bfde..2b9ba9d0d7 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -28,6 +28,7 @@ import RdrHsSyn import RnHsSyn import TcRnMonad import RnEnv +import RnNames ( importsFromLocalDecls ) import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen, dupFieldErr, precParseErr, sectionPrecErr, patSigErr ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) @@ -41,8 +42,10 @@ import PrelNames ( hasKey, assertIdKey, replicatePName, mapPName, filterPName, crossPName, zipPName, toPName, enumFromToPName, enumFromThenToPName, assertErrorName, - negateName, qTyConName, monadNames, mfixName ) -import RdrName ( RdrName ) + negateName, monadNames, mfixName ) +#ifdef GHCI +import DsMeta ( qTyConName ) +#endif import Name ( Name, nameOccName ) import NameSet import UnicodeUtil ( stringToUtf8 ) @@ -224,12 +227,14 @@ rnExpr (HsPar e) returnM (HsPar e', fvs_e) -- Template Haskell extensions +#ifdef GHCI rnExpr (HsBracket br_body) = checkGHCI (thErr "bracket") `thenM_` rnBracket br_body `thenM` \ (body', fvs_e) -> returnM (HsBracket body', fvs_e `addOneFV` qTyConName) -- We use the Q tycon as a proxy to haul in all the smart -- constructors; see the hack in RnIfaces +#endif rnExpr (HsSplice n e) = checkGHCI (thErr "splice") `thenM_` @@ -458,10 +463,16 @@ rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> returnM (TypBr t', fvs) where doc = ptext SLIT("In a Template-Haskell quoted type") -rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) -> - -- Discard the tcg_env; it contains the extended global RdrEnv - -- because there is no scope that these decls cover (yet!) - returnM (DecBr ds', fvs) +rnBracket (DecBr group) + = importsFromLocalDecls group `thenM` \ (rdr_env, avails) -> + -- Discard avails (not useful here) + + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $ + + rnSrcDecls group `thenM` \ (tcg_env, group', fvs) -> + -- Discard the tcg_env; it contains only extra info about fixity + + returnM (DecBr group', fvs) \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 9e7c53ad8d..739bb73f0e 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -38,7 +38,7 @@ import Name ( Name {-instance NamedThing-}, isWiredInName, isInternalName, name import NameEnv ( delFromNameEnv, lookupNameEnv ) import NameSet import Module ( Module, isHomeModule, extendModuleSet ) -import PrelInfo ( hasKey, fractionalClassKey, numClassKey, +import PrelNames ( hasKey, fractionalClassKey, numClassKey, integerTyConName, doubleTyConName ) import FiniteMap import Outputable @@ -631,18 +631,16 @@ checkModUsage (mod_name, _, is_boot, whats_imported) in traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_` - recoverM (returnM Nothing) - (loadInterface doc_str mod_name from `thenM` \ iface -> - returnM (Just iface)) `thenM` \ mb_iface -> + tryM (loadInterface doc_str mod_name from) `thenM` \ mb_iface -> case mb_iface of { - Nothing -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), + Left exn -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), ppr mod_name])); -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain -- it might just be that -- the current module doesn't need that import and it's been deleted - Just iface -> + Right iface -> let new_vers = mi_version iface new_mod_vers = vers_module new_vers diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 8eef805e19..3e440e950c 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -16,7 +16,7 @@ import {-# SOURCE #-} RnHiFiles ( loadInterface ) import CmdLineOpts ( DynFlag(..) ) import HsSyn ( HsDecl(..), IE(..), ieName, ImportDecl(..), - ForeignDecl(..), + ForeignDecl(..), HsGroup(..), collectLocatedHsBinders, tyClDeclNames ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsDecl ) @@ -39,7 +39,8 @@ import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, Deprecations(..), ModIface(..), GlobalRdrElt(..), unQualInScope, isLocalGRE ) -import RdrName ( rdrNameOcc, setRdrNameSpace, emptyRdrEnv, foldRdrEnv, isQual ) +import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, + emptyRdrEnv, foldRdrEnv, isQual ) import Outputable import Maybes ( maybeToBool, catMaybes ) import ListSetOps ( removeDups ) @@ -127,13 +128,11 @@ importsFromImportDecl this_mod_name -- If there's an error in loadInterface, (e.g. interface -- file not found) we get lots of spurious errors from 'filterImports' - recoverM (returnM Nothing) - (loadInterface doc imp_mod_name (ImportByUser is_boot) `thenM` \ iface -> - returnM (Just iface)) `thenM` \ mb_iface -> + tryM (loadInterface doc imp_mod_name (ImportByUser is_boot)) `thenM` \ mb_iface -> case mb_iface of { - Nothing -> returnM (emptyRdrEnv, emptyImportAvails ) ; - Just iface -> + Left exn -> returnM (emptyRdrEnv, emptyImportAvails ) ; + Right iface -> let imp_mod = mi_module iface @@ -205,15 +204,13 @@ created by its bindings. Complain about duplicate bindings \begin{code} -importsFromLocalDecls :: [RdrNameHsDecl] +importsFromLocalDecls :: HsGroup RdrName -> TcRn m (GlobalRdrEnv, ImportAvails) -importsFromLocalDecls decls - = getModule `thenM` \ this_mod -> - mappM (getLocalDeclBinders this_mod) decls `thenM` \ avails_s -> +importsFromLocalDecls group + = getModule `thenM` \ this_mod -> + getLocalDeclBinders this_mod group `thenM` \ avails -> -- The avails that are returned don't include the "system" names let - avails = concat avails_s - all_names :: [Name] -- All the defns; no dups eliminated all_names = [name | avail <- avails, name <- availNames avail] @@ -283,35 +280,27 @@ files (@loadDecl@ calls @getTyClDeclBinders@). *** See "THE NAMING STORY" in HsDecls **** \begin{code} -getLocalDeclBinders :: Module -> RdrNameHsDecl -> TcRn m [AvailInfo] -getLocalDeclBinders mod (TyClD tycl_decl) +getLocalDeclBinders :: Module -> HsGroup RdrName -> TcRn m [AvailInfo] +getLocalDeclBinders mod (HsGroup {hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) = -- For type and class decls, we generate Global names, with -- no export indicator. They need to be global because they get -- permanently bound into the TyCons and Classes. They don't need -- an export indicator because they are all implicitly exported. - mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) -> - returnM [AvailTC main_name names] - where - new (nm,loc) = newTopBinder mod nm loc -getLocalDeclBinders mod (ValD binds) - = mappM new (collectLocatedHsBinders binds) `thenM` \ avails -> - returnM avails + mappM new_tc tycl_decls `thenM` \ tc_avails -> + mappM new_bndr (for_hs_bndrs ++ val_hs_bndrs) `thenM` \ simple_bndrs -> + + returnM (tc_avails ++ map Avail simple_bndrs) where - new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenM` \ name -> - returnM (Avail name) - -getLocalDeclBinders mod (ForD (ForeignImport nm _ _ _ loc)) - = newTopBinder mod nm loc `thenM` \ name -> - returnM [Avail name] -getLocalDeclBinders mod (ForD _) - = returnM [] - -getLocalDeclBinders mod (FixD _) = returnM [] -getLocalDeclBinders mod (DeprecD _) = returnM [] -getLocalDeclBinders mod (DefD _) = returnM [] -getLocalDeclBinders mod (InstD _) = returnM [] -getLocalDeclBinders mod (RuleD _) = returnM [] + new_bndr (rdr_name,loc) = newTopBinder mod rdr_name loc + + val_hs_bndrs = collectLocatedHsBinders val_decls + for_hs_bndrs = [(nm,loc) | ForeignImport nm _ _ _ loc <- foreign_decls] + + new_tc tc_decl = mappM new_bndr (tyClDeclNames tc_decl) `thenM` \ names@(main_name:_) -> + returnM (AvailTC main_name names) \end{code} diff --git a/ghc/compiler/rename/RnSource.hi-boot-5 b/ghc/compiler/rename/RnSource.hi-boot-5 index 09ea671c71..d9af80796b 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-5 +++ b/ghc/compiler/rename/RnSource.hi-boot-5 @@ -9,7 +9,7 @@ __export RnSource rnBindsAndThen rnBinds rnSrcDecls; 1 rnBinds :: RdrHsSyn.RdrNameHsBinds -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ; -1 rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl] - -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars) ; +1 rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName + -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.FreeVars) ; diff --git a/ghc/compiler/rename/RnSource.hi-boot-6 b/ghc/compiler/rename/RnSource.hi-boot-6 index 0cb682d7e0..07779ea861 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-6 +++ b/ghc/compiler/rename/RnSource.hi-boot-6 @@ -8,6 +8,6 @@ rnBindsAndThen :: forall b . RdrHsSyn.RdrNameHsBinds rnBinds :: RdrHsSyn.RdrNameHsBinds -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.FreeVars) ; -rnSrcDecls :: [RdrHsSyn.RdrNameHsDecl] - -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, [RnHsSyn.RenamedHsDecl], NameSet.FreeVars) +rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName + -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name, NameSet.FreeVars) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 1175d107d7..27281daf08 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -5,7 +5,7 @@ \begin{code} module RnSource ( - rnSrcDecls, rnExtCoreDecls, checkModDeprec, + rnSrcDecls, checkModDeprec, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnBinds, rnBindsAndThen, rnStats, ) where @@ -14,15 +14,13 @@ module RnSource ( import HsSyn import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) -import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, RdrNameHsDecl, +import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl, RdrNameDeprecation, RdrNameFixitySig, RdrNameHsBinds, extractGenericPatTyVars ) import RnHsSyn import HsCore - -import RnNames ( importsFromLocalDecls ) import RnExpr ( rnExpr ) import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext ) @@ -35,8 +33,7 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupSysBndr, bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, checkDupOrQualNames, checkDupNames, mapFvRn, lookupTopSrcBndr_maybe, lookupTopSrcBndr, - dataTcOccs, unknownNameErr, - plusGlobalRdrEnv + dataTcOccs, unknownNameErr ) import TcRnMonad @@ -78,48 +75,56 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} -rnSrcDecls :: [RdrNameHsDecl] -> RnM (TcGblEnv, [RenamedHsDecl], FreeVars) - -rnSrcDecls decls - = do { (rdr_env, imports) <- importsFromLocalDecls decls ; - updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` - tcg_rdr_env gbl, - tcg_imports = imports `plusImportAvails` - tcg_imports gbl }) - $ do { - - -- Deal with deprecations (returns only the extra deprecations) - deprecs <- rnSrcDeprecDecls [d | DeprecD d <- decls] ; +rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, FreeVars) + +rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fixds = fix_decls, + hs_depds = deprec_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_coreds = core_decls }) + + = do { -- Deal with deprecations (returns only the extra deprecations) + deprecs <- rnSrcDeprecDecls deprec_decls ; updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs }) $ do { -- Deal with top-level fixity decls -- (returns the total new fixity env) - fix_env <- rnSrcFixityDecls decls ; + fix_env <- rnSrcFixityDecls fix_decls ; updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env }) $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations - -- Rename remaining declarations - (rn_src_decls, src_fvs) <- rn_src_decls decls ; + -- Rename other declarations + (rn_val_decls, src_fvs1) <- rnTopMonoBinds binds sigs ; + (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ; + (rn_tycl_decls, src_fvs3) <- mapFvRn rnSrcTyClDecl tycl_decls ; + (rn_rule_decls, src_fvs4) <- mapFvRn rnHsRuleDecl rule_decls ; + (rn_foreign_decls, src_fvs5) <- mapFvRn rnHsForeignDecl foreign_decls ; + (rn_default_decls, src_fvs6) <- mapFvRn rnDefaultDecl default_decls ; + (rn_core_decls, src_fvs7) <- mapFvRn rnCoreDecl core_decls ; + + let { + rn_group = HsGroup { hs_valds = rn_val_decls, + hs_tyclds = rn_tycl_decls, + hs_instds = rn_inst_decls, + hs_fixds = [], + hs_depds = [], + hs_fords = rn_foreign_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, + hs_coreds = rn_core_decls } ; + src_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7] } ; tcg_env <- getGblEnv ; - return (tcg_env, rn_src_decls, src_fvs) - }}}} - -rnExtCoreDecls :: [RdrNameHsDecl] -> RnM ([RenamedHsDecl], FreeVars) -rnExtCoreDecls decls = rn_src_decls decls - -rn_src_decls decls -- Declarartions get reversed, but no matter - = go emptyFVs [] decls - where - -- Fixity and deprecations have been dealt with already; ignore them - go fvs ds' [] = returnM (ds', fvs) - go fvs ds' (FixD _:ds) = go fvs ds' ds - go fvs ds' (DeprecD _:ds) = go fvs ds' ds - go fvs ds' (d:ds) = rnSrcDecl d `thenM` \(d', fvs') -> - go (fvs `plusFV` fvs') (d':ds') ds + return (tcg_env, rn_group, src_fvs) + }}} \end{code} @@ -130,21 +135,13 @@ rn_src_decls decls -- Declarartions get reversed, but no matter %********************************************************* \begin{code} -rnSrcFixityDecls :: [RdrNameHsDecl] -> TcRn m FixityEnv -rnSrcFixityDecls decls +rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv +rnSrcFixityDecls fix_decls = getGblEnv `thenM` \ gbl_env -> foldlM rnFixityDecl (tcg_fix_env gbl_env) fix_decls `thenM` \ fix_env -> traceRn (text "fixity env" <+> ppr fix_env) `thenM_` returnM fix_env - where - fix_decls = foldr get_fix_sigs [] decls - - -- Get fixities from top level decls, and from class decl sigs too - get_fix_sigs (FixD fix) acc = fix:acc - get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc - = [sig | FixSig sig <- sigs] ++ acc - get_fix_sigs other_decl acc = acc rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv rnFixityDecl fix_env (FixitySig rdr_name fixity loc) @@ -213,43 +210,30 @@ badDeprec d %********************************************************* \begin{code} -rnSrcDecl :: RdrNameHsDecl -> RnM (RenamedHsDecl, FreeVars) - -rnSrcDecl (ValD binds) = rnTopBinds binds `thenM` \ (new_binds, fvs) -> - returnM (ValD new_binds, fvs) - -rnSrcDecl (TyClD tycl_decl) +rnSrcTyClDecl tycl_decl = rnTyClDecl tycl_decl `thenM` \ new_decl -> finishSourceTyClDecl tycl_decl new_decl `thenM` \ (new_decl', fvs) -> - returnM (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl') + returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl') -rnSrcDecl (InstD inst) +rnSrcInstDecl inst = rnInstDecl inst `thenM` \ new_inst -> finishSourceInstDecl inst new_inst `thenM` \ (new_inst', fvs) -> - returnM (InstD new_inst', fvs `plusFV` instDeclFVs new_inst') - -rnSrcDecl (RuleD rule) - = rnHsRuleDecl rule `thenM` \ (new_rule, fvs) -> - returnM (RuleD new_rule, fvs) - -rnSrcDecl (ForD ford) - = rnHsForeignDecl ford `thenM` \ (new_ford, fvs) -> - returnM (ForD new_ford, fvs) + returnM (new_inst', fvs `plusFV` instDeclFVs new_inst') -rnSrcDecl (DefD (DefaultDecl tys src_loc)) +rnDefaultDecl (DefaultDecl tys src_loc) = addSrcLoc src_loc $ mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> - returnM (DefD (DefaultDecl tys' src_loc), fvs) + returnM (DefaultDecl tys' src_loc, fvs) where doc_str = text "In a `default' declaration" -rnSrcDecl (CoreD (CoreDecl name ty rhs loc)) +rnCoreDecl (CoreDecl name ty rhs loc) = addSrcLoc loc $ lookupTopBndrRn name `thenM` \ name' -> rnHsTypeFVs doc_str ty `thenM` \ (ty', ty_fvs) -> rnCoreExpr rhs `thenM` \ rhs' -> - returnM (CoreD (CoreDecl name' ty' rhs' loc), + returnM (CoreDecl name' ty' rhs' loc, ty_fvs `plusFV` ufExprFVs rhs') where doc_str = text "In the Core declaration for" <+> quotes (ppr name) diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 97a82d2b71..88963e18f3 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -24,13 +24,13 @@ import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn, bindPatSigTyVars, bindLocalsFVRn, warnUnusedMatches ) import TcRnMonad -import PrelInfo ( cCallishClassKeys, eqStringName, eqClassName, ordClassName, +import PrelNames( cCallishClassKeys, eqStringName, eqClassName, ordClassName, negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, timesIntegerName, ratioDataConName, fromRationalName, cCallableClassName ) import TysWiredIn ( intTyCon ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import RdrName ( RdrName, elemRdrEnv ) +import RdrName ( elemRdrEnv ) import Name ( Name, NamedThing(..) ) import NameSet import Unique ( Uniquable(..) ) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 7eb24d05e5..92d6aa3758 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -80,7 +80,6 @@ import PrelNames( fromIntegerName, fromRationalName, rationalTyConName ) import Util ( equalLength ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) -import Bag import Outputable \end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index ef9ff7901a..1c13bc2807 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -8,9 +8,8 @@ module TcDefaults ( tcDefaults ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), DefaultDecl(..) ) -import RnHsSyn ( RenamedHsDecl ) - +import HsSyn ( DefaultDecl(..) ) +import Name ( Name ) import TcRnMonad import TcEnv ( tcLookupGlobal_maybe ) import TcMonoType ( tcHsType ) @@ -22,18 +21,17 @@ import HscTypes ( TyThing(..) ) \end{code} \begin{code} -tcDefaults :: [RenamedHsDecl] +tcDefaults :: [DefaultDecl Name] -> TcM [Type] -- defaulting types to heave -- into Tc monad for later use -- in Disambig. -tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls] -tc_defaults [] = returnM defaultDefaultTys +tcDefaults [] = returnM defaultDefaultTys -tc_defaults [DefaultDecl [] locn] +tcDefaults [DefaultDecl [] locn] = returnM [] -- no defaults -tc_defaults [DefaultDecl mono_tys locn] +tcDefaults [DefaultDecl mono_tys locn] = tcLookupGlobal_maybe numClassName `thenM` \ maybe_num -> case maybe_num of Just (AClass num_class) -> common_case num_class diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index c83b46e87b..9b3ead8dda 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -9,11 +9,10 @@ module TcExpr ( tcExpr, tcExpr_id, tcMonoExpr ) where #include "HsVersions.h" #ifdef GHCI /* Only if bootstrapped */ -import {-# SOURCE #-} TcSplice( tcSpliceExpr ) -import TcEnv ( bracketOK, tcMetaTy ) +import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) +import TcEnv ( bracketOK ) import TcSimplify ( tcSimplifyBracket ) -import PrelNames ( exprTyConName ) -import HsSyn ( HsBracket(..) ) +import DsMeta ( liftName ) #endif import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), @@ -63,8 +62,9 @@ import PrelNames ( cCallableClassName, cReturnableClassName, enumFromName, enumFromThenName, enumFromToName, enumFromThenToName, enumFromToPName, enumFromThenToPName, - ioTyConName, liftName + ioTyConName ) +import DsMeta import ListSetOps ( minusList ) import CmdLineOpts import HscTypes ( TyThing(..) ) @@ -624,7 +624,7 @@ tcMonoExpr (PArrSeqIn _) _ tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty -tcMonoExpr (HsBracket (ExpBr expr)) res_ty +tcMonoExpr (HsBracket brack) res_ty = getStage `thenM` \ level -> case bracketOK level of { Nothing -> failWithTc (illegalBracket level) ; @@ -635,19 +635,17 @@ tcMonoExpr (HsBracket (ExpBr expr)) res_ty -- it again when we actually use it. newMutVar [] `thenM` \ pending_splices -> getLIEVar `thenM` \ lie_var -> - newTyVarTy openTypeKind `thenM` \ any_ty -> setStage (Brack next_level pending_splices lie_var) ( - getLIE (tcMonoExpr expr any_ty) - ) `thenM` \ (expr', lie) -> - tcSimplifyBracket lie `thenM_` + getLIE (tcBracket brack) + ) `thenM` \ (meta_ty, lie) -> + tcSimplifyBracket lie `thenM_` - tcMetaTy exprTyConName `thenM` \ meta_exp_ty -> - unifyTauTy res_ty meta_exp_ty `thenM_` + unifyTauTy res_ty meta_ty `thenM_` -- Return the original expression, not the type-decorated one readMutVar pending_splices `thenM` \ pendings -> - returnM (HsBracketOut (ExpBr expr) pendings) + returnM (HsBracketOut brack pendings) } #endif GHCI \end{code} @@ -812,6 +810,7 @@ tcId name -- Look up the Id and instantiate its type = tcLookupIdLvl name `thenM` \ (id, bind_lvl) -> -- Check for cross-stage lifting +#ifdef GHCI getStage `thenM` \ use_stage -> case use_stage of Brack use_lvl ps_var lie_var @@ -850,7 +849,8 @@ tcId name -- Look up the Id and instantiate its type in checkTc (wellStaged bind_lvl use_lvl) (badStageErr id bind_lvl use_lvl) `thenM_` - +#endif + -- This is the bit that handles the no-Template-Haskell case case isDataConWrapId_maybe id of Nothing -> loop (HsVar id) (idType id) Just data_con -> inst_data_con id data_con diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index dadf8be67a..4439202fa4 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -19,11 +19,11 @@ module TcForeign #include "HsVersions.h" -import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..), +import HsSyn ( ForeignDecl(..), HsExpr(..), MonoBinds(..), ForeignImport(..), ForeignExport(..), CImportSpec(..) ) -import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl ) +import RnHsSyn ( RenamedForeignDecl ) import TcRnMonad import TcMonoType ( tcHsSigType, UserTypeCtxt(..) ) @@ -36,7 +36,7 @@ import IdInfo ( noCafIdInfo ) import PrimRep ( getPrimRepSize, isFloatingRep ) import Type ( typePrimRep ) import OccName ( mkForeignExportOcc ) -import Name ( NamedThing(..), mkExternalName ) +import Name ( Name, NamedThing(..), mkExternalName ) import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, tcSplitForAllTys, isFFIArgumentTy, isFFIImportResultTy, @@ -72,10 +72,9 @@ isForeignExport _ = False %************************************************************************ \begin{code} -tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl]) -tcForeignImports decls = - mapAndUnzipM tcFImport - [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] +tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl]) +tcForeignImports decls + = mapAndUnzipM tcFImport (filter isForeignImport decls) tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) @@ -190,11 +189,10 @@ checkFEDArgs arg_tys = returnM () %************************************************************************ \begin{code} -tcForeignExports :: [RenamedHsDecl] +tcForeignExports :: [ForeignDecl Name] -> TcM (TcMonoBinds, [TcForeignDecl]) -tcForeignExports decls = - foldlM combine (EmptyMonoBinds, []) - [foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] +tcForeignExports decls + = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls) where combine (binds, fs) fe = tcFExport fe `thenM ` \ (b, f) -> diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 4c07ff5e0a..a4b286f00f 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -31,6 +31,7 @@ import HsSyn ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..), HsBinds(..), HsType(..), HsStmtContext(..), unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType ) +import PrelNames ( ) import RdrName ( RdrName, mkUnqual, nameRdrName, getRdrName ) import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) @@ -49,7 +50,7 @@ import Name ( getOccString, getOccName, getSrcLoc, occNameString, ) import HscTypes ( FixityEnv, lookupFixity ) -import PrelInfo -- Lots of Names +import PrelNames -- Lots of Names import PrimOp -- Lots of Names import SrcLoc ( generatedSrcLoc, SrcLoc ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, @@ -62,7 +63,6 @@ import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, import Util ( zipWithEqual, isSingleton, zipWith3Equal, nOfThem, zipEqual ) import Panic ( panic, assertPanic ) -import Maybes ( maybeToBool ) import Char ( ord, isAlpha ) import Constants import List ( partition, intersperse ) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 3e83ab88e6..251c7ad562 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -339,10 +339,6 @@ zonkMonoBinds env (VarMonoBind var expr) zonkExpr env expr `thenM` \ new_expr -> returnM (VarMonoBind new_var new_expr, unitBag new_var) -zonkMonoBinds env (CoreMonoBind var core_expr) - = zonkIdBndr env var `thenM` \ new_var -> - returnM (CoreMonoBind new_var core_expr, unitBag new_var) - zonkMonoBinds env (FunMonoBind var inf ms locn) = zonkIdBndr env var `thenM` \ new_var -> mappM (zonkMatch env) ms `thenM` \ new_ms -> diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 00891a153e..04b0ca3308 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -8,19 +8,26 @@ module TcRnDriver ( #ifdef GHCI mkGlobalContext, getModuleContents, #endif - tcRnModule, checkOldIface, importSupportingDecls, + tcRnModule, checkOldIface, + importSupportingDecls, tcTopSrcDecls, tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing ) where #include "HsVersions.h" +#ifdef GHCI +import {-# SOURCE #-} TcSplice( tcSpliceDecls ) +#endif + import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), + HsGroup(..), mkSimpleMatch, placeHolderType, toHsType, andMonoBinds, isSrcRule, collectStmtsBinders ) -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr ) +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, + emptyGroup, mkGroup, findSplice, addImpDecls ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, returnIOName, bindIOName, failIOName, thenIOName, runIOName, @@ -69,7 +76,8 @@ import RnHiFiles ( readIface, loadOldIface ) import RnEnv ( lookupSrcName, lookupOccRn, ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs ) import RnExpr ( rnStmts, rnExpr ) -import RnSource ( rnSrcDecls, rnExtCoreDecls, checkModDeprec, rnStats ) +import RnNames ( importsFromLocalDecls ) +import RnSource ( rnSrcDecls, checkModDeprec, rnStats ) import OccName ( varName ) import CoreUnfold ( unfoldingTemplate ) @@ -213,7 +221,7 @@ tcRnIface hsc_env pcs -- Get the supporting decls, and typecheck them all together -- so that any mutually recursive types are done right extra_decls <- slurpImpDecls needed ; - env <- typecheckIfaceDecls (decls ++ extra_decls) ; + env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ; returnM (ModDetails { md_types = tcg_type_env env, md_insts = tcg_insts env, @@ -224,9 +232,9 @@ tcRnIface hsc_env pcs rule_decls = dcl_rules iface_decls inst_decls = dcl_insts iface_decls tycl_decls = dcl_tycl iface_decls - decls = map RuleD rule_decls ++ - map InstD inst_decls ++ - map TyClD tycl_decls + group = emptyGroup { hs_ruleds = rule_decls, + hs_instds = inst_decls, + hs_tyclds = tycl_decls } needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets` @@ -352,7 +360,7 @@ tcUserStmt (ExprStmt expr _ loc) the_bind = FunMonoBind fresh_it False [ mkSimpleMatch [] expr placeHolderType loc ] loc in - tryTc_ (do { -- Try this if the other fails + tryTcLIE_ (do { -- Try this if the other fails traceTc (text "tcs 1b") ; tc_stmts [ LetStmt (MonoBind the_bind [] NonRecursive), @@ -398,7 +406,7 @@ tc_stmts stmts -- Simplify the context right here, so that we fail -- if there aren't enough instances. Notably, when we see -- e - -- we use tryTc_ to try it <- e + -- we use recoverTc_ to try it <- e -- and then let it = e -- It's the simplify step that rejects the first. traceTc (text "tcs 3") ; @@ -471,7 +479,7 @@ tcRnThing hsc_env pcs ictxt rdr_name let { rdr_names = dataTcOccs rdr_name } ; (msgs_s, mb_names) <- initRnInteractive ictxt - (mapAndUnzipM (tryM . lookupOccRn) rdr_names) ; + (mapAndUnzipM (tryTc . lookupOccRn) rdr_names) ; let { names = catMaybes mb_names } ; if null names then @@ -523,18 +531,19 @@ tcRnExtCore hsc_env pcs -- Rename the source, only in interface mode. -- rnSrcDecls handles fixity decls etc too, which won't occur -- but that doesn't matter - (rn_local_decls, fvs) <- initRn (InterfaceMode this_mod) - (rnExtCoreDecls local_decls) ; + let { local_group = mkGroup local_decls } ; + (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod) + (rnSrcDecls local_group) ; failIfErrsM ; -- Get the supporting decls, and typecheck them all together -- so that any mutually recursive types are done right extra_decls <- slurpImpDecls fvs ; - tcg_env <- typecheckIfaceDecls (rn_local_decls ++ extra_decls) ; + tcg_env <- typecheckIfaceDecls (rn_local_decls `addImpDecls` extra_decls) ; setGblEnv tcg_env $ do { -- Now the core bindings - core_prs <- tcCoreBinds [d | CoreD d <- rn_local_decls] ; + core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ; tcExtendGlobalValEnv (map fst core_prs) $ do { -- Wrap up @@ -574,16 +583,20 @@ tcRnExtCore hsc_env pcs %* * %************************************************************************ +\begin{code} tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) -- Returns the variables free in the decls -tcRnSrcDecls [] = getGblEnv + -- Reason: solely to report unused imports and bindings +tcRnSrcDecls [] = do { tcg_env <- getGblEnv ; return (tcg_env, emptyFVs) } tcRnSrcDecls ds = do { let { (first_group, group_tail) = findSplice ds } ; - tcg_env <- tcRnGroup first_group ; + -- Type check the decls up to, but not including, the first splice + (tcg_env, src_fvs1) <- tcRnGroup first_group ; + -- If there is no splice, we're done case group_tail of - Nothing -> return gbl_env + Nothing -> return (tcg_env, src_fvs1) Just (splice_expr, rest_ds) -> do { setGblEnv tcg_env $ do { @@ -597,15 +610,11 @@ tcRnSrcDecls ds spliced_decls <- tcSpliceDecls rn_splice_expr ; -- Glue them on the front of the remaining decls and loop - tcRnSrcDeclsDecls (splice_decls ++ rest_ds) - }}}} + (tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ; -findSplice :: [HsDecl a] -> ([HsDecl a], Maybe (HsExpr a, [HsDecl a])) -findSplice [] = ([], Nothing) -findSplice (SpliceD e : ds) = ([], Just (e, ds)) -findSplice (d : ds) = (d:gs, rest) - where - (gs, rest) = findSplice ds + return (tcg_env, src_fvs1 `plusFV` src_fvs2) + }}}} +\end{code} %************************************************************************ @@ -614,7 +623,7 @@ findSplice (d : ds) = (d:gs, rest) %* * %************************************************************************ -tcRnSrcDecls takes a bunch of top-level source-code declarations, and +tcRnGroup takes a bunch of top-level source-code declarations, and * renames them * gets supporting declarations from interface files * typechecks them @@ -626,9 +635,9 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars) +tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, FreeVars) -- Returns the variables free in the decls -tcRnSrcDecls decls +tcRnGroup decls = do { -- Rename the declarations (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { @@ -639,26 +648,35 @@ tcRnSrcDecls decls }} ------------------------------------------------ -rnTopSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, [RenamedHsDecl], FreeVars) -rnTopSrcDecls decls - = do { (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls decls) ; +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars) +rnTopSrcDecls group + = do { -- Bring top level binders into scope + (rdr_env, imports) <- importsFromLocalDecls group ; + updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` + tcg_rdr_env gbl, + tcg_imports = imports `plusImportAvails` + tcg_imports gbl }) + $ do { + + -- Rename the source decls + (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ; setGblEnv tcg_env $ do { failIfErrsM ; -- Import consquential imports rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ; - let { rn_decls = rn_src_decls ++ rn_imp_decls } ; + let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; -- Dump trace of renaming part - rnDump (vcat (map ppr rn_decls)) ; + rnDump (ppr rn_decls) ; rnStats rn_imp_decls ; return (tcg_env, rn_decls, src_fvs) - }} + }}} ------------------------------------------------ -tcTopSrcDecls :: [RenamedHsDecl] -> TcM TcGblEnv +tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv tcTopSrcDecls rn_decls = fixM (\ unf_env -> do { -- Loop back the final environment, including the fully zonked @@ -695,7 +713,13 @@ tcTopSrcDecls rn_decls return tcg_env' }) -tc_src_decls unf_env decls +tc_src_decls unf_env + (HsGroup { hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls traceTc (text "Tc2") ; tcg_env <- tcTyClDecls unf_env tycl_decls ; @@ -712,14 +736,14 @@ tc_src_decls unf_env decls -- Foreign import declarations next. No zonking necessary -- here; we can tuck them straight into the global environment. traceTc (text "Tc4") ; - (fi_ids, fi_decls) <- tcForeignImports decls ; + (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; tcExtendGlobalValEnv fi_ids $ updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls }) $ do { -- Default declarations traceTc (text "Tc4a") ; - default_tys <- tcDefaults decls ; + default_tys <- tcDefaults default_decls ; updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do { -- Value declarations next @@ -740,7 +764,7 @@ tc_src_decls unf_env decls -- Foreign exports -- They need to be zonked, so we return them traceTc (text "Tc7") ; - (foe_binds, foe_decls) <- tcForeignExports decls ; + (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; -- Rules -- Need to partition them because the source rules @@ -760,12 +784,6 @@ tc_src_decls unf_env decls return (tcg_env, all_binds, src_rules, foe_decls) }}}}}}}}} - where - tycl_decls = [d | TyClD d <- decls] - rule_decls = [d | RuleD d <- decls] - inst_decls = [d | InstD d <- decls] - val_decls = [d | ValD d <- decls] - val_binds = foldr ThenBinds EmptyBinds val_decls \end{code} \begin{code} @@ -888,9 +906,9 @@ importSupportingDecls fvs = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ; decls <- slurpImpDecls fvs ; traceRn (text "...namely:" <+> vcat (map ppr decls)) ; - typecheckIfaceDecls decls } + typecheckIfaceDecls (mkGroup decls) } -typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv +typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv -- The decls are all interface-file declarations -- Usually they are all from other modules, but when we are reading -- this module's interface from a file, it's possible that some of @@ -900,12 +918,10 @@ typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv -- If all the decls are from other modules, the returned TcGblEnv -- will have an empty tc_genv, but its tc_inst_env and tc_ist -- caches may have been augmented. -typecheckIfaceDecls decls - = do { let { tycl_decls = [d | TyClD d <- decls] ; - inst_decls = [d | InstD d <- decls] ; - rule_decls = [d | RuleD d <- decls] } ; - - -- Typecheck the type, class, and interface-sig decls +typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_ruleds = rule_decls }) + = do { -- Typecheck the type, class, and interface-sig decls tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ; setGblEnv tcg_env $ do { diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 6c6e676bd8..f450dcfbad 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -367,45 +367,52 @@ checkGHCI m = addErr m \begin{code} -tryM :: TcRn m a -> TcRn m (Messages, Maybe a) - -- (try m) executes m, and returns +recoverM :: TcRn m r -- Recovery action; do this if the main one fails + -> TcRn m r -- Main action: do this first + -> TcRn m r +recoverM recover thing + = do { mb_res <- tryM thing ; + case mb_res of + Left exn -> recover + Right res -> returnM res } + +tryTc :: TcRn m a -> TcRn m (Messages, Maybe a) + -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) and caused no errors -- Nothing, if m fails, or caused errors -- It also returns all the errors accumulated by m -- (even in the Just case, there might be warnings) -- -- It always succeeds (never raises an exception) -tryM m +tryTc m = do { errs_var <- newMutVar emptyMessages ; - mb_r <- recoverM (return Nothing) - (do { r <- setErrsVar errs_var m ; - return (Just r) }) ; + mb_r <- tryM (setErrsVar errs_var m) ; new_errs <- readMutVar errs_var ; return (new_errs, case mb_r of - Nothing -> Nothing - Just r | errorsFound new_errs -> Nothing - | otherwise -> Just r) + Left exn -> Nothing + Right r | errorsFound new_errs -> Nothing + | otherwise -> Just r) } -tryTc :: TcM a -> TcM (Messages, Maybe a) --- Just like tryM, except that it ensures that the LIE +tryTcLIE :: TcM a -> TcM (Messages, Maybe a) +-- Just like tryTc, except that it ensures that the LIE -- for the thing is propagated only if there are no errors -- Hence it's restricted to the type-check monad -tryTc thing_inside - = do { ((errs, mb_r), lie) <- getLIE (tryM thing_inside) ; +tryTcLIE thing_inside + = do { ((errs, mb_r), lie) <- getLIE (tryTc thing_inside) ; ifM (isJust mb_r) (extendLIEs lie) ; return (errs, mb_r) } -tryTc_ :: TcM r -> TcM r -> TcM r +tryTcLIE_ :: TcM r -> TcM r -> TcM r -- (tryM_ r m) tries m; if it succeeds it returns it, -- otherwise it returns r. Any error messages added by m are discarded, -- whether or not m succeeds. -tryTc_ recover main - = do { (_msgs, mb_res) <- tryTc main ; +tryTcLIE_ recover main + = do { (_msgs, mb_res) <- tryTcLIE main ; case mb_res of Just res -> return res Nothing -> recover } @@ -418,7 +425,7 @@ checkNoErrs :: TcM r -> TcM r -- If so, it fails too. -- Regardless, any errors generated by m are propagated to the enclosing context. checkNoErrs main - = do { (msgs, mb_res) <- tryTc main ; + = do { (msgs, mb_res) <- tryTcLIE main ; addMessages msgs ; case mb_res of Just r -> return r @@ -458,7 +465,7 @@ forkM doc thing_inside = do { us <- newUniqueSupply ; unsafeInterleaveM $ do { us_var <- newMutVar us ; - (msgs, mb_res) <- tryTc (setUsVar us_var thing_inside) ; + (msgs, mb_res) <- tryTcLIE (setUsVar us_var thing_inside) ; case mb_res of Just r -> return (Just r) Nothing -> do { diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 0b3cbda9d6..81909bfebd 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -9,7 +9,7 @@ module TcRnTypes( thenM, thenM_, returnM, failM, -- Non-standard operations - runTcRn, fixM, recoverM, ioToTcRn, + runTcRn, fixM, tryM, ioToTcRn, newMutVar, readMutVar, writeMutVar, getEnv, setEnv, updEnv, unsafeInterleaveM, @@ -74,6 +74,7 @@ import UNSAFE_IO ( unsafeInterleaveIO ) import FIX_IO ( fixIO ) import Maybe ( mapMaybe ) import List ( nub ) +import Control.Exception as Exception ( try, Exception ) \end{code} @@ -151,11 +152,9 @@ fixM f = TcRn (\ env -> fixIO (\ r -> unTcRn (f r) env)) Error recovery \begin{code} -recoverM :: TcRn m r -- Recovery action; do this if the main one fails - -> TcRn m r -- Main action: do this first - -> TcRn m r -recoverM (TcRn recover) (TcRn m) - = TcRn (\ env -> catch (m env) (\ _ -> recover env)) +tryM :: TcRn m r -> TcRn m (Either Exception.Exception r) +-- Reflect exception into TcRn monad +tryM (TcRn thing) = TcRn (\ env -> Exception.try (thing env)) \end{code} Lazy interleave diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 4d3d8aec45..d017154934 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -52,8 +52,8 @@ import Name ( getOccName, getSrcLoc ) import NameSet ( NameSet, mkNameSet, elemNameSet ) import Class ( classBigSig ) import FunDeps ( oclose, grow, improve, pprEquationDoc ) -import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass, - splitName, fstName, sndName ) +import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass ) +import PrelNames ( splitName, fstName, sndName ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import TysWiredIn ( unitTy, pairTyCon ) @@ -1720,27 +1720,30 @@ disambigGroup dicts = failM try_default (default_ty : default_tys) - = tryTc_ (try_default default_tys) $ -- If default_ty fails, we try + = tryTcLIE_ (try_default default_tys) $ -- If default_ty fails, we try -- default_tys instead tcSimplifyDefault theta `thenM` \ _ -> returnM default_ty where theta = [mkClassPred clas [default_ty] | clas <- classes] in - -- See if any default works, and if so bind the type variable to it - -- If not, add an AmbigErr - recoverM (addAmbigErrs dicts `thenM_` - returnM EmptyMonoBinds) $ + -- See if any default works + tryM (try_default default_tys) `thenM` \ mb_ty -> + case mb_ty of { + Left _ -> -- If not, add an AmbigErr + addAmbigErrs dicts `thenM_` + returnM EmptyMonoBinds ; - try_default default_tys `thenM` \ chosen_default_ty -> + Right chosen_default_ty -> - -- Bind the type variable and reduce the context, for real this time + -- If so, bind the type variable + -- and reduce the context, for real this time unifyTauTy chosen_default_ty (mkTyVarTy tyvar) `thenM_` simpleReduceLoop (text "disambig" <+> ppr dicts) reduceMe dicts `thenM` \ (frees, binds, ambigs) -> WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs ) warnDefault dicts chosen_default_ty `thenM_` - returnM binds + returnM binds } | all isCreturnableClass classes = -- Default CCall stuff to (); we don't even both to check that () is an diff --git a/ghc/compiler/typecheck/TcSplice.hi-boot-6 b/ghc/compiler/typecheck/TcSplice.hi-boot-6 index f5f8c5195d..07ec2683e1 100644 --- a/ghc/compiler/typecheck/TcSplice.hi-boot-6 +++ b/ghc/compiler/typecheck/TcSplice.hi-boot-6 @@ -5,3 +5,8 @@ tcSpliceExpr :: Name.Name -> TcType.TcType -> TcRnTypes.TcM TcHsSyn.TcExpr +tcSpliceDecls :: RnHsSyn.RenamedHsExpr + -> TcRnTypes.TcM [RdrHsSyn.RdrNameHsDecl] + +tcBracket :: HsExpr.HsBracket Name.Name + -> TcRnTypes.TcM TcType.TcType
\ No newline at end of file diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 9e1b806cfb..e269f9f22a 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -4,21 +4,19 @@ \section[TcSplice]{Template Haskell splices} \begin{code} -module TcSplice( tcSpliceExpr, tcSpliceDecls ) where +module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where #include "HsVersions.h" import HscMain ( compileExpr ) -import TcRnDriver ( importSupportingDecls ) +import TcRnDriver ( importSupportingDecls, tcTopSrcDecls ) -- These imports are the reason that TcSplice -- is very high up the module hierarchy -import CompManager ( sandboxIO ) - -- Ditto, but this one could be defined muchlower down - import qualified Language.Haskell.THSyntax as Meta import HscTypes ( HscEnv(..), GhciMode(..), PersistentCompilerState(..), unQualInScope ) +import HsSyn ( HsBracket(..) ) import Convert ( convertToHsExpr, convertToHsDecls ) import RnExpr ( rnExpr ) import RdrHsSyn ( RdrNameHsExpr, RdrNameHsDecl ) @@ -26,14 +24,15 @@ import RnHsSyn ( RenamedHsExpr ) import TcExpr ( tcMonoExpr ) import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr ) import TcSimplify ( tcSimplifyTop ) -import TcType ( TcType ) +import TcType ( TcType, openTypeKind ) import TcEnv ( spliceOK, tcMetaTy ) import TcRnTypes ( TopEnv(..) ) +import TcMType ( newTyVarTy ) import Name ( Name ) import TcRnMonad import TysWiredIn ( mkListTy ) -import PrelNames ( exprTyConName, declTyConName ) +import DsMeta ( exprTyConName, declTyConName ) import Outputable import GHC.Base ( unsafeCoerce# ) -- Should have a better home in the module hierarchy \end{code} @@ -66,6 +65,25 @@ tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) %************************************************************************ \begin{code} +tcBracket :: HsBracket Name -> TcM TcType +tcBracket (ExpBr expr) + = newTyVarTy openTypeKind `thenM` \ any_ty -> + tcMonoExpr expr any_ty `thenM_` + tcMetaTy exprTyConName + +tcBracket (DecBr decls) + = tcTopSrcDecls decls `thenM_` + tcMetaTy declTyConName `thenM` \ decl_ty -> + returnM (mkListTy decl_ty) +\end{code} + +%************************************************************************ +%* * +\subsection{Splicing an expression} +%* * +%************************************************************************ + +\begin{code} tcSpliceExpr name expr res_ty = getStage `thenM` \ level -> case spliceOK level of { @@ -161,6 +179,7 @@ tcSpliceDecls expr decls :: [RdrNameHsDecl] decls = convertToHsDecls simple_expr in + traceTc (text "Got result" <+> vcat (map ppr decls)) `thenM_` returnM decls \end{code} @@ -174,15 +193,24 @@ tcSpliceDecls expr \begin{code} runMetaE :: TypecheckedHsExpr -- Of type (Q Exp) -> TcM Meta.Exp -- Of type Exp -runMetaE e = runMeta e +runMetaE e = runMeta tcRunQ e -runMetaD :: TypecheckedHsExpr -- Of type (Q [Dec] +runMetaD :: TypecheckedHsExpr -- Of type [Q Dec] -> TcM [Meta.Dec] -- Of type [Dec] -runMetaD e = runMeta e +runMetaD e = runMeta run_decl e + where + run_decl :: [Meta.Decl] -> TcM [Meta.Dec] + run_decl ds = mappM tcRunQ ds -runMeta :: TypecheckedHsExpr -- Of type (Q t) +-- Warning: if Q is anything other than IO, we need to change this +tcRunQ :: Meta.Q a -> TcM a +tcRunQ thing = ioToTcRn thing + + +runMeta :: (x -> TcM t) -- :: X -> IO t + -> TypecheckedHsExpr -- Of type X -> TcM t -- Of type t -runMeta expr :: TcM t +runMeta run_it expr :: TcM t = getTopEnv `thenM` \ top_env -> getEps `thenM` \ eps -> getNameCache `thenM` \ name_cache -> @@ -204,19 +232,17 @@ runMeta expr :: TcM t -- enough information available to link all the things that -- are needed when you try to run a splice else - ioToTcRn (do { - -- Warning: if Q is anything other than IO, we may need to wrap - -- the expression 'expr' in a runQ before compiling it - hval <- HscMain.compileExpr hsc_env pcs this_mod print_unqual expr - -- hval :: HValue - -- Need to coerce it to IO t - ; sandboxIO (unsafeCoerce# hval :: IO t) }) `thenM` \ either_tval -> + ioToTcRn (HscMain.compileExpr hsc_env pcs this_mod + print_unqual expr) `thenM` \ hval -> + + tryM (run_it (unsafeCoerce# hval)) `thenM` \ either_tval -> case either_tval of - Left err -> failWithTc (vcat [text "Exception when running compiled-time code:", - nest 4 (text (show err))]) - Right v -> returnM v + Left exn -> failWithTc (vcat [text "Exception when running compile-time code:", + nest 4 (vcat [text "Code:" <+> ppr expr, + text ("Exn: " ++ show exn)])]) + Right v -> returnM v \end{code} |