X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=4c0d35163077f15c92bf46b95e25b1c4fe31c2ca;hb=1b5c8ce0a3565ec02a38325f82473f1e772d7afe;hp=ab94bdcdb89056f6acfde221c5d9f16e1d335136;hpb=e390fbac3cc1ce7562e26459d2a1e91893a282cd;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index ab94bdc..4c0d351 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -42,7 +42,8 @@ import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), toHsType ) -import PrelNames ( mETA_META_Name, rationalTyConName ) +import PrelNames ( mETA_META_Name, rationalTyConName, negateName, + parrTyConName ) import MkIface ( ifaceTyThing ) import Name ( Name, nameOccName, nameModule ) import OccName ( isDataOcc, isTvOcc, occNameUserString ) @@ -58,19 +59,23 @@ import Name ( mkKnownKeyExternalName ) import OccName ( mkOccFS ) import NameEnv import NameSet -import Type ( Type, TyThing(..), mkGenTyConApp ) +import Type ( Type, mkGenTyConApp ) +import TcType ( TyThing(..), tcTyConAppArgs ) import TyCon ( DataConDetails(..) ) import TysWiredIn ( stringTy ) import CoreSyn import CoreUtils ( exprType ) import SrcLoc ( noSrcLoc ) -import Maybe ( catMaybes ) +import Maybes ( orElse ) +import Maybe ( catMaybes, fromMaybe ) import Panic ( panic ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique ) import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) import Outputable import FastString ( mkFastString ) + +import Monad ( zipWithM ) ----------------------------------------------------------------------------- dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr @@ -131,7 +136,7 @@ dsReify r@(ReifyOut ReifyDecl name) -- Declarations ------------------------------------------------------- -repTopDs :: HsGroup Name -> DsM (Core [M.Decl]) +repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec])) repTopDs group = do { let { bndrs = groupBinders group } ; ss <- mkGenSyms bndrs ; @@ -141,7 +146,7 @@ repTopDs group -- do { t :: String <- genSym "T" ; -- return (Data t [] ...more t's... } -- The other important reason is that the output must mention - -- only "T", not "Foo.T" where Foo is the current module + -- only "T", not "Foo:T" where Foo is the current module decls <- addBinds ss (do { @@ -151,8 +156,13 @@ repTopDs group -- more needed return (val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ; - core_list <- coreList declTyConName decls ; - wrapNongenSyms ss core_list + decl_ty <- lookupType declTyConName ; + let { core_list = coreList' decl_ty decls } ; + + dec_ty <- lookupType decTyConName ; + q_decs <- repSequenceQ dec_ty core_list ; + + wrapNongenSyms ss q_decs -- Do *not* gensym top-level binders } @@ -190,29 +200,42 @@ in repTyClD and repC. repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl)) -repTyClD (TyData { tcdND = DataType, tcdCtxt = [], +repTyClD (TyData { tcdND = DataType, tcdCtxt = cxt, tcdName = tc, tcdTyVars = tvs, tcdCons = DataCons cons, tcdDerivs = mb_derivs }) - = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] - tvs1 <- repTvs tvs ; - cons1 <- mapM repC cons ; - cons2 <- coreList consTyConName cons1 ; - derivs1 <- repDerivs mb_derivs ; - dec <- repData tc1 tvs1 cons2 derivs1 ; - return (Just dec) } + = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] + dec <- addTyVarBinds tvs $ \bndrs -> do { + cxt1 <- repContext cxt ; + cons1 <- mapM repC cons ; + cons2 <- coreList consTyConName cons1 ; + derivs1 <- repDerivs mb_derivs ; + repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ; + return $ Just dec } + +repTyClD (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty }) + = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] + dec <- addTyVarBinds tvs $ \bndrs -> do { + ty1 <- repTy ty ; + repTySyn tc1 (coreList' stringTy bndrs) ty1 } ; + return (Just dec) } repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls, - tcdTyVars = tvs, tcdFDs = [], - tcdSigs = sigs, tcdMeths = Just binds - }) + tcdTyVars = tvs, + tcdFDs = [], -- We don't understand functional dependencies + tcdSigs = sigs, tcdMeths = mb_meth_binds }) = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences] - tvs1 <- repTvs tvs ; - cxt1 <- repCtxt cxt ; - sigs1 <- rep_sigs sigs ; - binds1 <- rep_monobind binds ; - decls1 <- coreList declTyConName (sigs1 ++ binds1) ; - dec <- repClass cxt1 cls1 tvs1 decls1 ; - return (Just dec) } + dec <- addTyVarBinds tvs $ \bndrs -> do { + cxt1 <- repContext cxt ; + sigs1 <- rep_sigs sigs ; + binds1 <- rep_monobind meth_binds ; + decls1 <- coreList declTyConName (sigs1 ++ binds1) ; + repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ; + return $ Just dec } + where + -- If the user quotes a class decl, it'll have default-method + -- bindings; but if we (reifyDecl C) where C is a class, we + -- won't be given the default methods (a definite infelicity). + meth_binds = mb_meth_binds `orElse` EmptyMonoBinds -- Un-handled cases repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ; @@ -223,7 +246,7 @@ repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ; repInstD (InstDecl ty binds _ _ loc) -- Ignore user pragmas for now - = do { cxt1 <- repCtxt cxt ; + = do { cxt1 <- repContext cxt ; inst_ty1 <- repPred (HsClassP cls tys) ; binds1 <- rep_monobind binds ; decls1 <- coreList declTyConName binds1 ; @@ -239,15 +262,15 @@ repInstD (InstDecl ty binds _ _ loc) repC :: ConDecl Name -> DsM (Core M.Cons) repC (ConDecl con [] [] details loc) = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences] - arg_tys <- mapM (repBangTy con) (hsConArgs details) ; - arg_tys1 <- coreList typeTyConName arg_tys ; - repConstr con1 arg_tys1 } + repConstr con1 details } -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) +repBangTy :: BangType Name -> DsM (Core (M.Q (M.Strictness, M.Typ))) +repBangTy (BangType str ty) = do MkC s <- rep2 strName [] + MkC t <- repTy ty + rep2 strictTypeName [s, t] + where strName = case str of + NotMarkedStrict -> nonstrictName + _ -> strictName ------------------------------------------------------- -- Deriving clause @@ -281,7 +304,7 @@ 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 ; +rep_proto nm ty = do { nm1 <- lookupOcc nm ; ty1 <- repTy ty ; sig <- repProto nm1 ty1 ; return [sig] } @@ -291,45 +314,92 @@ rep_proto nm ty = do { nm1 <- lookupBinder nm ; -- Types ------------------------------------------------------- -repTvs :: [HsTyVarBndr Name] -> DsM (Core [String]) -repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ; - return (coreList' stringTy tvs1) } - ------------------ -repCtxt :: HsContext Name -> DsM (Core M.Ctxt) -repCtxt ctxt = do { preds <- mapM repPred ctxt; - coreList typeTyConName preds } +-- gensym a list of type variables and enter them into the meta environment; +-- the computations passed as the second argument is executed in that extended +-- meta environment and gets the *new* names on Core-level as an argument +-- +addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added + -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env + -> DsM (Core (M.Q a)) +addTyVarBinds tvs m = + do + let names = map hsTyVarName tvs + freshNames <- mkGenSyms names + term <- addBinds freshNames $ do + bndrs <- mapM lookupBinder names + m bndrs + wrapGenSyns freshNames term + +-- represent a type context +-- +repContext :: HsContext Name -> DsM (Core M.Ctxt) +repContext ctxt = do + preds <- mapM repPred ctxt + predList <- coreList typeTyConName preds + repCtxt predList ------------------ +-- represent a type predicate +-- 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" - ------------------ +repPred (HsClassP cls tys) = do + tcon <- repTy (HsTyVar cls) + tys1 <- repTys tys + repTapps tcon tys1 +repPred (HsIParam _ _) = + panic "DsMeta.repTy: Can't represent predicates with implicit parameters" + +-- yield the representation of a list of types +-- repTys :: [HsType Name] -> DsM [Core M.Type] repTys tys = mapM repTy tys ------------------ +-- represent a type +-- repTy :: HsType Name -> DsM (Core M.Type) +repTy (HsForAllTy bndrs ctxt ty) = + addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do + ctxt' <- repContext ctxt + ty' <- repTy ty + repTForall (coreList' stringTy bndrs') ctxt' ty' 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 } + | isTvOcc (nameOccName n) = do + tv1 <- lookupBinder 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 (HsPArrTy t) = do + t1 <- repTy t + tcon <- repTy (HsTyVar parrTyConName) + 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) ty2) = 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 HsAppTy (HsTyVar c) tys) +repTy (HsNumTy i) = + panic "DsMeta.repTy: Can't represent number types (for generics)" +repTy (HsPredTy pred) = repPred pred +repTy (HsKindSig ty kind) = + panic "DsMeta.repTy: Can't represent explicit kind signatures yet" -repTy other_ty = pprPanic "repTy" (ppr other_ty) -- HsForAllTy, HsKindSig ----------------------------------------------------------------------------- -- Expressions @@ -361,13 +431,14 @@ repE (HsLam m) = repLambda m repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b} repE (OpApp e1 op fix e2) = - case op of - HsVar op -> do { arg1 <- repE e1; - arg2 <- repE e2; - the_op <- lookupOcc op ; - repInfixApp arg1 the_op arg2 } - _ -> panic "DsMeta.repE: Operator is not a variable" -repE (NegApp x nm) = repE x >>= repNeg + do { arg1 <- repE e1; + arg2 <- repE e2; + the_op <- repE op ; + repInfixApp arg1 the_op arg2 } +repE (NegApp x nm) = do + a <- repE x + negateVar <- lookupOcc negateName >>= repVar + negateVar `repApp` a repE (HsPar x) = repE x 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 } @@ -382,29 +453,34 @@ repE (HsIf x y z loc) = do repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repE e) ; z <- repLetE ds e2 - ; wrapGenSyns expTyConName ss z } + ; wrapGenSyns ss z } -- FIXME: I haven't got the types here right yet -repE (HsDo ctxt sts _ ty loc) - | isComprCtxt ctxt = do { (ss,zs) <- repSts sts; - e <- repDoE (nonEmptyCoreList zs); - wrapGenSyns expTyConName ss e } - | otherwise = - panic "DsMeta.repE: Can't represent mdo and [: :] yet" - where - isComprCtxt ListComp = True - isComprCtxt DoExpr = True - isComprCtxt _ = False +repE (HsDo DoExpr sts _ ty loc) + = do { (ss,zs) <- repSts sts; + e <- repDoE (nonEmptyCoreList zs); + wrapGenSyns ss e } +repE (HsDo ListComp sts _ ty loc) + = do { (ss,zs) <- repSts sts; + e <- repComp (nonEmptyCoreList zs); + wrapGenSyns ss e } +repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet" repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } repE (ExplicitPArr ty es) = panic "DsMeta.repE: No explicit parallel arrays yet" repE (ExplicitTuple es boxed) | isBoxed boxed = do { xs <- repEs es; repTup xs } | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples" -repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet" -repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet" +repE (RecordCon c flds) + = do { x <- lookupOcc c; + fs <- repFields flds; + repRecCon x fs } +repE (RecordUpd e flds) + = do { x <- repE e; + fs <- repFields flds; + repRecUpd x fs } repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 } -repE (ArithSeqOut _ aseq) = +repE (ArithSeqIn aseq) = case aseq of From e -> do { ds1 <- repE e; repFrom ds1 } FromThen e1 e2 -> do @@ -421,6 +497,7 @@ repE (ArithSeqOut _ aseq) = ds3 <- repE e3 repFromThenTo ds1 ds2 ds3 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" +repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__" repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC" repE (HsBracketOut _ _) = @@ -446,7 +523,7 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = ; addBinds ss2 $ do { ; gs <- repGuards guards ; match <- repMatch p1 gs ds - ; wrapGenSyns matTyConName (ss1++ss2) match }}} + ; wrapGenSyns (ss1++ss2) match }}} repClauseTup :: Match Name -> DsM (Core M.Clse) repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = @@ -457,7 +534,7 @@ repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = ; addBinds ss2 $ do { gs <- repGuards guards ; clause <- repClause ps1 gs ds - ; wrapGenSyns clsTyConName (ss1++ss2) clause }}} + ; wrapGenSyns (ss1++ss2) clause }}} repGuards :: [GRHS Name] -> DsM (Core M.Rihs) repGuards [GRHS [ResultStmt e loc] loc2] @@ -470,6 +547,13 @@ repGuards other = do { x <- repE e1; y <- repE e2; return (x, y) } process other = panic "Non Haskell 98 guarded body" +repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FldE]) +repFields flds = do + fnames <- mapM lookupOcc (map fst flds) + es <- mapM repE (map snd flds) + fs <- zipWithM (\n x -> rep2 fieldName [unC n, unC x]) fnames es + coreList fieldTyConName fs + ----------------------------------------------------------------------------- -- Representing Stmt's is tricky, especially if bound variables @@ -617,7 +701,7 @@ repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ] ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repPs ps; body <- repE e; repLam xs body }) - ; wrapGenSyns expTyConName ss lam } + ; wrapGenSyns ss lam } repLambda z = panic "Can't represent a guarded lambda in Template Haskell" @@ -647,9 +731,15 @@ repP (ConPatIn dc details) = 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" + RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs) + ; ps <- sequence $ map repP (map snd pairs) + ; fps <- zipWithM (\x y -> rep2 fieldPName [unC x,unC y]) vs ps + ; fps' <- coreList fieldPTyConName fps + ; repPrec con_str fps' } InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs } } +repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))" +repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a } repP other = panic "Exotic pattern inside meta brackets" repListPat :: [Pat Name] -> DsM (Core M.Patt) @@ -665,19 +755,31 @@ repListPat (p:ps) = do { p2 <- repP p ---------------------------------------------------------- -- The meta-environment +-- A name/identifier association for fresh names of locally bound entities +-- type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id -- I.e. (x, x_id) means -- let x_id = gensym "x" in ... -addBinds :: [GenSymBind] -> DsM a -> DsM a -addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m - +-- Generate a fresh name for a locally bound entity +-- mkGenSym :: Name -> DsM GenSymBind mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) } +-- Ditto for a list of names +-- mkGenSyms :: [Name] -> DsM [GenSymBind] mkGenSyms ns = mapM mkGenSym ns +-- Add a list of fresh names for locally bound entities to the meta +-- environment (which is part of the state carried around by the desugarer +-- monad) +-- +addBinds :: [GenSymBind] -> DsM a -> DsM a +addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m + +-- Look up a locally bound name +-- lookupBinder :: Name -> DsM (Core String) lookupBinder n = do { mb_val <- dsLookupMetaEnv n; @@ -685,6 +787,11 @@ lookupBinder n Just (Bound x) -> return (coreVar x) other -> pprPanic "Failed binder lookup:" (ppr n) } +-- Look up a name that is either locally bound or a global name +-- +-- * If it is a global name, generate the "original name" representation (ie, +-- the : form) for the associated entity +-- lookupOcc :: Name -> DsM (Core String) -- Lookup an occurrence; it can't be a splice. -- Use the in-scope bindings if they exist @@ -715,16 +822,19 @@ lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; -- bindQ (gensym nm2 (\ id2 -> -- y)) -wrapGenSyns :: Name -- Name of the type (consructor) for 'a' - -> [GenSymBind] +wrapGenSyns :: [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 } +wrapGenSyns binds body@(MkC b) + = go binds where - go elt_ty [] = return body - go elt_ty ((name,id) : binds) - = do { MkC body' <- go elt_ty binds + [elt_ty] = tcTyConAppArgs (exprType b) + -- b :: Q a, so we can get the type 'a' by looking at the + -- argument type. NB: this relies on Q being a data/newtype, + -- not a type synonym + + go [] = return body + go ((name,id) : binds) + = do { MkC body' <- go binds ; lit_str <- localVar name ; gensym_app <- repGensym lit_str ; repBindQ stringTy elt_ty @@ -733,17 +843,14 @@ wrapGenSyns tc_name binds body@(MkC b) -- 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 +wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a) +wrapNongenSyms binds (MkC body) + = do { binds' <- mapM do_one binds ; + return (MkC (mkLets binds' body)) } 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')) - } + do_one (name,id) + = do { MkC lit_str <- localVar name -- No gensym + ; return (NonRec id lit_str) } void = placeHolderType @@ -791,6 +898,9 @@ repPtup (MkC ps) = rep2 ptupName [ps] repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt) repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps] +repPrec :: Core String -> Core [(String,M.Patt)] -> DsM (Core M.Patt) +repPrec (MkC c) (MkC rps) = rep2 precName [c,rps] + repPtilde :: Core M.Patt -> DsM (Core M.Patt) repPtilde (MkC p) = rep2 ptildeName [p] @@ -844,17 +954,20 @@ repListExp (MkC es) = rep2 listExpName [es] repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr) repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t] -repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr) -repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] +repRecCon :: Core String -> Core [M.FldE]-> DsM (Core M.Expr) +repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs] + +repRecUpd :: Core M.Expr -> Core [M.FldE] -> DsM (Core M.Expr) +repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs] -repNeg :: Core M.Expr -> DsM (Core M.Expr) -repNeg (MkC x) = rep2 negName [x] +repInfixApp :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) -repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y] +repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) -repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y] +repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] ------------ Right hand sides (guarded expressions) ---- repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs) @@ -900,8 +1013,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] +repData :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl) +repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs] + +repTySyn :: Core String -> Core [String] -> Core M.Type -> DsM (Core M.Decl) +repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] 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] @@ -912,11 +1028,32 @@ 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] +repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt) +repCtxt (MkC tys) = rep2 ctxtName [tys] + +repConstr :: Core String -> HsConDetails Name (BangType Name) + -> DsM (Core M.Cons) +repConstr con (PrefixCon ps) + = do arg_tys <- mapM repBangTy ps + arg_tys1 <- coreList strTypeTyConName arg_tys + rep2 constrName [unC con, unC arg_tys1] +repConstr con (RecCon ips) + = do arg_vs <- mapM lookupOcc (map fst ips) + arg_tys <- mapM repBangTy (map snd ips) + arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) + arg_vs arg_tys + arg_vtys' <- coreList varStrTypeTyConName arg_vtys + rep2 recConstrName [unC con, unC arg_vtys'] +repConstr con (InfixCon st1 st2) + = do arg1 <- repBangTy st1 + arg2 <- repBangTy st2 + rep2 infixConstrName [unC arg1, unC con, unC arg2] ------------ Types ------------------- +repTForall :: Core [String] -> Core M.Ctxt -> Core M.Type -> DsM (Core M.Type) +repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 tforallName [tvars, ctxt, ty] + repTvar :: Core String -> DsM (Core M.Type) repTvar (MkC s) = rep2 tvarName [s] @@ -951,16 +1088,16 @@ repLiteral lit = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] } where lit_name = case lit of - HsInt _ -> intLName - HsChar _ -> charLName - HsString _ -> stringLName - HsRat _ _ -> rationalLName - other -> uh_oh + HsInteger _ -> integerLName + HsChar _ -> charLName + HsString _ -> stringLName + HsRat _ _ -> rationalLName + other -> uh_oh uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal" (ppr lit) repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit) -repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInt i) +repOverloadedLiteral (HsIntegral i _) = repLiteral (HsInteger i) repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ; repLiteral (HsRat f rat_ty) } -- The type Rational will be in the environment, becuase @@ -980,6 +1117,10 @@ repBindQ :: Type -> Type -- a and b repBindQ ty_a ty_b (MkC x) (MkC y) = rep2 bindQName [Type ty_a, Type ty_b, x, y] +repSequenceQ :: Type -> Core [M.Q a] -> DsM (Core (M.Q [a])) +repSequenceQ ty_a (MkC list) + = rep2 sequenceQName [Type ty_a, list] + ------------ Lists and Tuples ------------------- -- turn a list of patterns into a single pattern matching a list @@ -1025,26 +1166,30 @@ templateHaskellNames :: NameSet -- The names that are implicitly mentioned by ``bracket'' -- Should stay in sync with the import list of DsMeta templateHaskellNames - = mkNameSet [ intLName,charLName, stringLName, rationalLName, + = mkNameSet [ integerLName,charLName, stringLName, rationalLName, plitName, pvarName, ptupName, pconName, ptildeName, paspatName, pwildName, varName, conName, litName, appName, infixEName, lamName, tupName, doEName, compName, listExpName, sigExpName, condName, letEName, caseEName, - infixAppName, negName, sectionLName, sectionRName, + 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, + gensymName, returnQName, bindQName, sequenceQName, + matchName, clauseName, funName, valName, tySynDName, dataDName, classDName, + instName, protoName, tforallName, tvarName, tconName, tappName, arrowTyConName, tupleTyConName, listTyConName, namedTyConName, - constrName, + ctxtName, constrName, recConstrName, infixConstrName, exprTyConName, declTyConName, pattTyConName, mtchTyConName, clseTyConName, stmtTyConName, consTyConName, typeTyConName, + strTypeTyConName, varStrTypeTyConName, qTyConName, expTyConName, matTyConName, clsTyConName, - decTyConName, typTyConName ] + decTyConName, typTyConName, strictTypeName, varStrictTypeName, + recConName, recUpdName, precName, + fieldName, fieldTyConName, fieldPName, fieldPTyConName, + strictName, nonstrictName ] varQual = mk_known_key_name OccName.varName @@ -1057,7 +1202,7 @@ thModule = mkThPkgModule mETA_META_Name mk_known_key_name space str uniq = mkKnownKeyExternalName thModule (mkOccFS space str) uniq -intLName = varQual FSLIT("intL") intLIdKey +integerLName = varQual FSLIT("integerL") integerLIdKey charLName = varQual FSLIT("charL") charLIdKey stringLName = varQual FSLIT("stringL") stringLIdKey rationalLName = varQual FSLIT("rationalL") rationalLIdKey @@ -1068,6 +1213,7 @@ pconName = varQual FSLIT("pcon") pconIdKey ptildeName = varQual FSLIT("ptilde") ptildeIdKey paspatName = varQual FSLIT("paspat") paspatIdKey pwildName = varQual FSLIT("pwild") pwildIdKey +precName = varQual FSLIT("prec") precIdKey varName = varQual FSLIT("var") varIdKey conName = varQual FSLIT("con") conIdKey litName = varQual FSLIT("lit") litIdKey @@ -1083,9 +1229,10 @@ condName = varQual FSLIT("cond") condIdKey letEName = varQual FSLIT("letE") letEIdKey caseEName = varQual FSLIT("caseE") caseEIdKey infixAppName = varQual FSLIT("infixApp") infixAppIdKey -negName = varQual FSLIT("neg") negIdKey sectionLName = varQual FSLIT("sectionL") sectionLIdKey sectionRName = varQual FSLIT("sectionR") sectionRIdKey +recConName = varQual FSLIT("recCon") recConIdKey +recUpdName = varQual FSLIT("recUpd") recUpdIdKey guardedName = varQual FSLIT("guarded") guardedIdKey normalName = varQual FSLIT("normal") normalIdKey bindStName = varQual FSLIT("bindSt") bindStIdKey @@ -1100,6 +1247,7 @@ liftName = varQual FSLIT("lift") liftIdKey gensymName = varQual FSLIT("gensym") gensymIdKey returnQName = varQual FSLIT("returnQ") returnQIdKey bindQName = varQual FSLIT("bindQ") bindQIdKey +sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey -- type Mat = ... matchName = varQual FSLIT("match") matchIdKey @@ -1111,23 +1259,30 @@ clauseName = varQual FSLIT("clause") clauseIdKey funName = varQual FSLIT("fun") funIdKey valName = varQual FSLIT("val") valIdKey dataDName = varQual FSLIT("dataD") dataDIdKey +tySynDName = varQual FSLIT("tySynD") tySynDIdKey classDName = varQual FSLIT("classD") classDIdKey instName = varQual FSLIT("inst") instIdKey protoName = varQual FSLIT("proto") protoIdKey -- data Typ = ... +tforallName = varQual FSLIT("tforall") tforallIdKey tvarName = varQual FSLIT("tvar") tvarIdKey tconName = varQual FSLIT("tcon") tconIdKey tappName = varQual FSLIT("tapp") tappIdKey -- data Tag = ... -arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey -tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey -listTyConName = varQual FSLIT("listTyCon") listIdKey -namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey +arrowTyConName = varQual FSLIT("arrowTyCon") arrowIdKey +tupleTyConName = varQual FSLIT("tupleTyCon") tupleIdKey +listTyConName = varQual FSLIT("listTyCon") listIdKey +namedTyConName = varQual FSLIT("namedTyCon") namedTyConIdKey + +-- type Ctxt = ... +ctxtName = varQual FSLIT("ctxt") ctxtIdKey -- data Con = ... constrName = varQual FSLIT("constr") constrIdKey +recConstrName = varQual FSLIT("recConstr") recConstrIdKey +infixConstrName = varQual FSLIT("infixConstr") infixConstrIdKey exprTyConName = tcQual FSLIT("Expr") exprTyConKey declTyConName = tcQual FSLIT("Decl") declTyConKey @@ -1137,7 +1292,12 @@ clseTyConName = tcQual FSLIT("Clse") clseTyConKey stmtTyConName = tcQual FSLIT("Stmt") stmtTyConKey consTyConName = tcQual FSLIT("Cons") consTyConKey typeTyConName = tcQual FSLIT("Type") typeTyConKey - +strTypeTyConName = tcQual FSLIT("StrType") strTypeTyConKey +varStrTypeTyConName = tcQual FSLIT("VarStrType") varStrTypeTyConKey + +fieldTyConName = tcQual FSLIT("FldE") fieldTyConKey +fieldPTyConName = tcQual FSLIT("FldP") fieldPTyConKey + qTyConName = tcQual FSLIT("Q") qTyConKey expTyConName = tcQual FSLIT("Exp") expTyConKey decTyConName = tcQual FSLIT("Dec") decTyConKey @@ -1145,6 +1305,14 @@ typTyConName = tcQual FSLIT("Typ") typTyConKey matTyConName = tcQual FSLIT("Mat") matTyConKey clsTyConName = tcQual FSLIT("Cls") clsTyConKey +strictTypeName = varQual FSLIT("strictType") strictTypeKey +varStrictTypeName = varQual FSLIT("varStrictType") varStrictTypeKey +strictName = varQual FSLIT("strict") strictKey +nonstrictName = varQual FSLIT("nonstrict") nonstrictKey + +fieldName = varQual FSLIT("field") fieldKey +fieldPName = varQual FSLIT("fieldP") fieldPKey + -- TyConUniques available: 100-119 -- Check in PrelNames if you want to change this @@ -1162,6 +1330,10 @@ consTyConKey = mkPreludeTyConUnique 110 typeTyConKey = mkPreludeTyConUnique 111 typTyConKey = mkPreludeTyConUnique 112 decTyConKey = mkPreludeTyConUnique 113 +varStrTypeTyConKey = mkPreludeTyConUnique 114 +strTypeTyConKey = mkPreludeTyConUnique 115 +fieldTyConKey = mkPreludeTyConUnique 116 +fieldPTyConKey = mkPreludeTyConUnique 117 @@ -1180,13 +1352,15 @@ valIdKey = mkPreludeMiscIdUnique 209 protoIdKey = mkPreludeMiscIdUnique 210 matchIdKey = mkPreludeMiscIdUnique 211 clauseIdKey = mkPreludeMiscIdUnique 212 -intLIdKey = mkPreludeMiscIdUnique 213 +integerLIdKey = mkPreludeMiscIdUnique 213 charLIdKey = mkPreludeMiscIdUnique 214 classDIdKey = mkPreludeMiscIdUnique 215 instIdKey = mkPreludeMiscIdUnique 216 dataDIdKey = mkPreludeMiscIdUnique 217 +sequenceQIdKey = mkPreludeMiscIdUnique 218 +tySynDIdKey = mkPreludeMiscIdUnique 219 plitIdKey = mkPreludeMiscIdUnique 220 pvarIdKey = mkPreludeMiscIdUnique 221 @@ -1209,7 +1383,7 @@ condIdKey = mkPreludeMiscIdUnique 238 letEIdKey = mkPreludeMiscIdUnique 239 caseEIdKey = mkPreludeMiscIdUnique 240 infixAppIdKey = mkPreludeMiscIdUnique 241 -negIdKey = mkPreludeMiscIdUnique 242 +-- 242 unallocated sectionLIdKey = mkPreludeMiscIdUnique 243 sectionRIdKey = mkPreludeMiscIdUnique 244 guardedIdKey = mkPreludeMiscIdUnique 245 @@ -1219,22 +1393,38 @@ letStIdKey = mkPreludeMiscIdUnique 248 noBindStIdKey = mkPreludeMiscIdUnique 249 parStIdKey = mkPreludeMiscIdUnique 250 -tvarIdKey = mkPreludeMiscIdUnique 251 -tconIdKey = mkPreludeMiscIdUnique 252 -tappIdKey = mkPreludeMiscIdUnique 253 +tforallIdKey = mkPreludeMiscIdUnique 251 +tvarIdKey = mkPreludeMiscIdUnique 252 +tconIdKey = mkPreludeMiscIdUnique 253 +tappIdKey = mkPreludeMiscIdUnique 254 + +arrowIdKey = mkPreludeMiscIdUnique 255 +tupleIdKey = mkPreludeMiscIdUnique 256 +listIdKey = mkPreludeMiscIdUnique 257 +namedTyConIdKey = mkPreludeMiscIdUnique 258 + +ctxtIdKey = mkPreludeMiscIdUnique 259 + +constrIdKey = mkPreludeMiscIdUnique 260 -arrowIdKey = mkPreludeMiscIdUnique 254 -tupleIdKey = mkPreludeMiscIdUnique 255 -listIdKey = mkPreludeMiscIdUnique 256 -namedTyConIdKey = mkPreludeMiscIdUnique 257 +stringLIdKey = mkPreludeMiscIdUnique 261 +rationalLIdKey = mkPreludeMiscIdUnique 262 -constrIdKey = mkPreludeMiscIdUnique 258 +sigExpIdKey = mkPreludeMiscIdUnique 263 -stringLIdKey = mkPreludeMiscIdUnique 259 -rationalLIdKey = mkPreludeMiscIdUnique 260 +strictTypeKey = mkPreludeMiscIdUnique 264 +strictKey = mkPreludeMiscIdUnique 265 +nonstrictKey = mkPreludeMiscIdUnique 266 +varStrictTypeKey = mkPreludeMiscIdUnique 267 -sigExpIdKey = mkPreludeMiscIdUnique 261 +recConstrIdKey = mkPreludeMiscIdUnique 268 +infixConstrIdKey = mkPreludeMiscIdUnique 269 +recConIdKey = mkPreludeMiscIdUnique 270 +recUpdIdKey = mkPreludeMiscIdUnique 271 +precIdKey = mkPreludeMiscIdUnique 272 +fieldKey = mkPreludeMiscIdUnique 273 +fieldPKey = mkPreludeMiscIdUnique 274 -- %************************************************************************ @@ -1245,4 +1435,4 @@ sigExpIdKey = mkPreludeMiscIdUnique 261 -- 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 +addDsWarn msg = dsWarn (noSrcLoc, msg)