X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMeta.hs;h=b02761cdad96ada7c3a5140e215a2a3c62785ed9;hb=424d45ae7a17cb085d41e5b3d85c699b7c9951ed;hp=4c0d35163077f15c92bf46b95e25b1c4fe31c2ca;hpb=1b5c8ce0a3565ec02a38325f82473f1e772d7afe;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 4c0d351..b02761c 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -13,8 +13,8 @@ module DsMeta( dsBracket, dsReify, templateHaskellNames, qTyConName, - liftName, exprTyConName, declTyConName, typeTyConName, - decTyConName, typTyConName ) where + liftName, expQTyConName, decQTyConName, typeQTyConName, + decTyConName, typeTyConName ) where #include "HsVersions.h" @@ -45,7 +45,7 @@ import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), import PrelNames ( mETA_META_Name, rationalTyConName, negateName, parrTyConName ) import MkIface ( ifaceTyThing ) -import Name ( Name, nameOccName, nameModule ) +import Name ( Name, nameOccName, nameModule, getSrcLoc ) import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName -- we do this by removing varName from the import of OccName above, making @@ -71,15 +71,17 @@ import Maybe ( catMaybes, fromMaybe ) import Panic ( panic ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique ) import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) +import SrcLoc ( SrcLoc ) import Outputable import FastString ( mkFastString ) import Monad ( zipWithM ) +import List ( sortBy ) ----------------------------------------------------------------------------- dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr --- Returns a CoreExpr of type M.Expr +-- Returns a CoreExpr of type M.ExpQ -- The quoted thing is parameterised over Name, even though it has -- been type checked. We don't want all those type decorations! @@ -95,8 +97,8 @@ dsBracket brack splices ----------------------------------------------------------------------------- dsReify :: HsReify Id -> DsM CoreExpr --- Returns a CoreExpr of type reifyType --> M.Type --- reifyDecl --> M.Decl +-- Returns a CoreExpr of type reifyType --> M.TypeQ +-- reifyDecl --> M.DecQ -- reifyFixty --> Q M.Fix dsReify (ReifyOut ReifyType name) = do { thing <- dsLookupGlobal name ; @@ -150,13 +152,13 @@ repTopDs group 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) ; + 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) }) ; + return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ; - decl_ty <- lookupType declTyConName ; + decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; dec_ty <- lookupType decTyConName ; @@ -198,39 +200,58 @@ in repTyClD and repC. -} -repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl)) +repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.DecQ)) +repTyClD decl = do x <- repTyClD' decl + return (fmap snd x) -repTyClD (TyData { tcdND = DataType, tcdCtxt = cxt, +repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ)) + +repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, tcdName = tc, tcdTyVars = tvs, - tcdCons = DataCons cons, tcdDerivs = mb_derivs }) + tcdCons = DataCons cons, tcdDerivs = mb_derivs, + tcdLoc = loc}) = 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 ; + cons2 <- coreList conQTyConName cons1 ; derivs1 <- repDerivs mb_derivs ; repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ; - return $ Just dec } + return $ Just (loc, dec) } + +repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt, + tcdName = tc, tcdTyVars = tvs, + tcdCons = DataCons [con], tcdDerivs = mb_derivs, + tcdLoc = loc}) + = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] + dec <- addTyVarBinds tvs $ \bndrs -> do { + cxt1 <- repContext cxt ; + con1 <- repC con ; + derivs1 <- repDerivs mb_derivs ; + repNewtype cxt1 tc1 (coreList' stringTy bndrs) con1 derivs1 } ; + return $ Just (loc, dec) } -repTyClD (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty }) +repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty, + tcdLoc = loc}) = 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) } + return (Just (loc, dec)) } -repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls, +repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls, tcdTyVars = tvs, tcdFDs = [], -- We don't understand functional dependencies - tcdSigs = sigs, tcdMeths = mb_meth_binds }) + tcdSigs = sigs, tcdMeths = mb_meth_binds, + tcdLoc = loc}) = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { cxt1 <- repContext cxt ; sigs1 <- rep_sigs sigs ; binds1 <- rep_monobind meth_binds ; - decls1 <- coreList declTyConName (sigs1 ++ binds1) ; + decls1 <- coreList decQTyConName (sigs1 ++ binds1) ; repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ; - return $ Just dec } + return $ Just (loc, 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 @@ -238,19 +259,20 @@ repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls, meth_binds = mb_meth_binds `orElse` EmptyMonoBinds -- Un-handled cases -repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ; +repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ; return Nothing } where msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") -repInstD (InstDecl ty binds _ _ loc) +repInstD' (InstDecl ty binds _ _ loc) -- Ignore user pragmas for now = do { cxt1 <- repContext cxt ; inst_ty1 <- repPred (HsClassP cls tys) ; binds1 <- rep_monobind binds ; - decls1 <- coreList declTyConName binds1 ; - repInst cxt1 inst_ty1 decls1 } + decls1 <- coreList decQTyConName binds1 ; + i <- repInst cxt1 inst_ty1 decls1; + return (loc, i)} where (tvs, cxt, cls, tys) = splitHsInstDeclTy ty @@ -259,18 +281,18 @@ repInstD (InstDecl ty binds _ _ loc) -- Constructors ------------------------------------------------------- -repC :: ConDecl Name -> DsM (Core M.Cons) +repC :: ConDecl Name -> DsM (Core M.ConQ) repC (ConDecl con [] [] details loc) = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences] repConstr con1 details } -repBangTy :: BangType Name -> DsM (Core (M.Q (M.Strictness, M.Typ))) +repBangTy :: BangType Name -> DsM (Core (M.StrictTypeQ)) 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 + NotMarkedStrict -> notStrictName + _ -> isStrictName ------------------------------------------------------- -- Deriving clause @@ -292,22 +314,27 @@ repDerivs (Just ctxt) -- Signatures in a class decl, or a group of bindings ------------------------------------------------------- -rep_sigs :: [Sig Name] -> DsM [Core M.Decl] +rep_sigs :: [Sig Name] -> DsM [Core M.DecQ] +rep_sigs sigs = do locs_cores <- rep_sigs' sigs + return $ de_loc $ sort_by_loc locs_cores + +rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core M.DecQ)] -- We silently ignore ones we don't recognise -rep_sigs sigs = do { sigs1 <- mapM rep_sig sigs ; +rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; return (concat sigs1) } -rep_sig :: Sig Name -> DsM [Core M.Decl] +rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)] -- 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 (ClassOpSig nm _ ty loc) = rep_proto nm ty loc +rep_sig (Sig nm ty loc) = rep_proto nm ty loc rep_sig other = return [] -rep_proto nm ty = do { nm1 <- lookupOcc nm ; +rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)] +rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; ty1 <- repTy ty ; sig <- repProto nm1 ty1 ; - return [sig] } + return [(loc, sig)] } ------------------------------------------------------- @@ -332,15 +359,15 @@ addTyVarBinds tvs m = -- represent a type context -- -repContext :: HsContext Name -> DsM (Core M.Ctxt) +repContext :: HsContext Name -> DsM (Core M.CxtQ) repContext ctxt = do preds <- mapM repPred ctxt - predList <- coreList typeTyConName preds + predList <- coreList typeQTyConName preds repCtxt predList -- represent a type predicate -- -repPred :: HsPred Name -> DsM (Core M.Type) +repPred :: HsPred Name -> DsM (Core M.TypeQ) repPred (HsClassP cls tys) = do tcon <- repTy (HsTyVar cls) tys1 <- repTys tys @@ -350,12 +377,12 @@ repPred (HsIParam _ _) = -- yield the representation of a list of types -- -repTys :: [HsType Name] -> DsM [Core M.Type] +repTys :: [HsType Name] -> DsM [Core M.TypeQ] repTys tys = mapM repTy tys -- represent a type -- -repTy :: HsType Name -> DsM (Core M.Type) +repTy :: HsType Name -> DsM (Core M.TypeQ) repTy (HsForAllTy bndrs ctxt ty) = addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do ctxt' <- repContext ctxt @@ -405,14 +432,14 @@ repTy (HsKindSig ty kind) = -- Expressions ----------------------------------------------------------------------------- -repEs :: [HsExpr Name] -> DsM (Core [M.Expr]) +repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ]) repEs es = do { es' <- mapM repE es ; - coreList exprTyConName es' } + coreList expQTyConName es' } -- FIXME: some of these panics should be converted into proper error messages -- unless we can make sure that constructs, which are plainly not -- supported in TH already lead to error messages at an earlier stage -repE :: HsExpr Name -> DsM (Core M.Expr) +repE :: HsExpr Name -> DsM (Core M.ExpQ) repE (HsVar x) = do { mb_val <- dsLookupMetaEnv x ; case mb_val of @@ -514,7 +541,7 @@ repE e = ----------------------------------------------------------------------------- -- Building representations of auxillary structures like Match, Clause, Stmt, -repMatchTup :: Match Name -> DsM (Core M.Mtch) +repMatchTup :: Match Name -> DsM (Core M.MatchQ) repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { @@ -525,7 +552,7 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = ; match <- repMatch p1 gs ds ; wrapGenSyns (ss1++ss2) match }}} -repClauseTup :: Match Name -> DsM (Core M.Clse) +repClauseTup :: Match Name -> DsM (Core M.ClauseQ) repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { @@ -536,7 +563,7 @@ repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = ; clause <- repClause ps1 gs ds ; wrapGenSyns (ss1++ss2) clause }}} -repGuards :: [GRHS Name] -> DsM (Core M.Rihs) +repGuards :: [GRHS Name] -> DsM (Core M.BodyQ) repGuards [GRHS [ResultStmt e loc] loc2] = do {a <- repE e; repNormal a } repGuards other @@ -547,12 +574,12 @@ 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 :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp]) 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 + fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es + coreList fieldExpTyConName fs ----------------------------------------------------------------------------- @@ -580,7 +607,7 @@ repFields flds = do -- The helper function repSts computes the translation of each sub expression -- and a bunch of prefix bindings denoting the dynamic renaming. -repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt]) +repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.StmtQ]) repSts [ResultStmt e loc] = do { a <- repE e ; e1 <- repNoBindSt a @@ -610,65 +637,73 @@ repSts other = panic "Exotic Stmt in meta brackets" -- Bindings ----------------------------------------------------------- -repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl]) +repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ]) repBinds decs = do { let { bndrs = collectHsBinders decs } ; ss <- mkGenSyms bndrs ; core <- addBinds ss (rep_binds decs) ; - core_list <- coreList declTyConName core ; + core_list <- coreList decQTyConName core ; return (ss, core_list) } -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 +rep_binds :: HsBinds Name -> DsM [Core M.DecQ] +rep_binds binds = do locs_cores <- rep_binds' binds + return $ de_loc $ sort_by_loc locs_cores + +rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)] +rep_binds' EmptyBinds = return [] +rep_binds' (ThenBinds x y) + = do { core1 <- rep_binds' x + ; core2 <- rep_binds' y ; return (core1 ++ core2) } -rep_binds (MonoBind bs sigs _) - = do { core1 <- rep_monobind bs - ; core2 <- rep_sigs sigs +rep_binds' (MonoBind bs sigs _) + = do { core1 <- rep_monobind' bs + ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_binds (IPBinds _ _) +rep_binds' (IPBinds _ _) = panic "DsMeta:repBinds: can't do implicit parameters" -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; +rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ] +rep_monobind binds = do locs_cores <- rep_monobind' binds + return $ de_loc $ sort_by_loc locs_cores + +rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)] +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 -rep_monobind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) +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] } + ; return [(loc, ans)] } -rep_monobind (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] } + ; return [(loc, ans)] } -rep_monobind (PatMonoBind pat (GRHSs guards wheres ty2) loc) +rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc) = do { patcore <- repP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore - ; return [ans] } + ; return [(loc, ans)] } -rep_monobind (VarMonoBind v e) +rep_monobind' (VarMonoBind v e) = do { v' <- lookupBinder v ; e2 <- repE e ; x <- repNormal e2 ; patcore <- repPvar v' - ; empty_decls <- coreList declTyConName [] + ; empty_decls <- coreList decQTyConName [] ; ans <- repVal patcore x empty_decls - ; return [ans] } + ; return [(getSrcLoc v, ans)] } ----------------------------------------------------------------------------- -- Since everything in a MonoBind is mutually recursive we need rename all @@ -694,7 +729,7 @@ rep_monobind (VarMonoBind v e) -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like -- (\ p1 .. pn -> exp) by causing an error. -repLambda :: Match Name -> DsM (Core M.Expr) +repLambda :: Match Name -> DsM (Core M.ExpQ) repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ] EmptyBinds _)) = do { let bndrs = collectPatsBinders ps ; @@ -714,18 +749,18 @@ repLambda z = panic "Can't represent a guarded lambda in Template Haskell" -- variable should already appear in the environment. -- Process a list of patterns -repPs :: [Pat Name] -> DsM (Core [M.Patt]) +repPs :: [Pat Name] -> DsM (Core [M.Pat]) repPs ps = do { ps' <- mapM repP ps ; - coreList pattTyConName ps' } + coreList patTyConName ps' } -repP :: Pat Name -> DsM (Core M.Patt) +repP :: Pat Name -> DsM (Core M.Pat) repP (WildPat _) = repPwild repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 } repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 } repP (ParPat p) = repP p -repP (ListPat ps _) = repListPat ps +repP (ListPat ps _) = do { qs <- repPs ps; repPlist qs } repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs } repP (ConPatIn dc details) = do { con_str <- lookupOcc dc @@ -733,8 +768,8 @@ repP (ConPatIn dc details) PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs } 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 + ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps + ; fps' <- coreList fieldPatTyConName fps ; repPrec con_str fps' } InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs } } @@ -742,15 +777,15 @@ repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns y 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) -repListPat [] = do { nil_con <- coreStringLit "[]" - ; nil_args <- coreList pattTyConName [] - ; repPcon nil_con nil_args } -repListPat (p:ps) = do { p2 <- repP p - ; ps2 <- repListPat ps - ; cons_con <- coreStringLit ":" - ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) } +---------------------------------------------------------- +-- Declaration ordering helpers + +sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)] +sort_by_loc xs = sortBy comp xs + where comp x y = compare (fst x) (fst y) +de_loc :: [(SrcLoc, a)] -> [a] +de_loc = map snd ---------------------------------------------------------- -- The meta-environment @@ -812,7 +847,7 @@ globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ) localVar :: Name -> DsM (Core String) localVar n = coreStringLit (occNameUserString (nameOccName n)) -lookupType :: Name -- Name of type constructor (e.g. M.Expr) +lookupType :: Name -- Name of type constructor (e.g. M.ExpQ) -> DsM Type -- The type lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; return (mkGenTyConApp tc []) } @@ -886,198 +921,207 @@ rep2 n xs = do { id <- dsLookupGlobalId n -- %********************************************************************* --------------- Patterns ----------------- -repPlit :: Core M.Lit -> DsM (Core M.Patt) -repPlit (MkC l) = rep2 plitName [l] +repPlit :: Core M.Lit -> DsM (Core M.Pat) +repPlit (MkC l) = rep2 litPName [l] + +repPvar :: Core String -> DsM (Core M.Pat) +repPvar (MkC s) = rep2 varPName [s] -repPvar :: Core String -> DsM (Core M.Patt) -repPvar (MkC s) = rep2 pvarName [s] +repPtup :: Core [M.Pat] -> DsM (Core M.Pat) +repPtup (MkC ps) = rep2 tupPName [ps] -repPtup :: Core [M.Patt] -> DsM (Core M.Patt) -repPtup (MkC ps) = rep2 ptupName [ps] +repPcon :: Core String -> Core [M.Pat] -> DsM (Core M.Pat) +repPcon (MkC s) (MkC ps) = rep2 conPName [s, 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.Pat)] -> DsM (Core M.Pat) +repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] -repPrec :: Core String -> Core [(String,M.Patt)] -> DsM (Core M.Patt) -repPrec (MkC c) (MkC rps) = rep2 precName [c,rps] +repPtilde :: Core M.Pat -> DsM (Core M.Pat) +repPtilde (MkC p) = rep2 tildePName [p] -repPtilde :: Core M.Patt -> DsM (Core M.Patt) -repPtilde (MkC p) = rep2 ptildeName [p] +repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat) +repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] -repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt) -repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p] +repPwild :: DsM (Core M.Pat) +repPwild = rep2 wildPName [] -repPwild :: DsM (Core M.Patt) -repPwild = rep2 pwildName [] +repPlist :: Core [M.Pat] -> DsM (Core M.Pat) +repPlist (MkC ps) = rep2 listPName [ps] --------------- Expressions ----------------- -repVarOrCon :: Name -> Core String -> DsM (Core M.Expr) +repVarOrCon :: Name -> Core String -> DsM (Core M.ExpQ) repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str | otherwise = repVar str -repVar :: Core String -> DsM (Core M.Expr) -repVar (MkC s) = rep2 varName [s] +repVar :: Core String -> DsM (Core M.ExpQ) +repVar (MkC s) = rep2 varEName [s] -repCon :: Core String -> DsM (Core M.Expr) -repCon (MkC s) = rep2 conName [s] +repCon :: Core String -> DsM (Core M.ExpQ) +repCon (MkC s) = rep2 conEName [s] -repLit :: Core M.Lit -> DsM (Core M.Expr) -repLit (MkC c) = rep2 litName [c] +repLit :: Core M.Lit -> DsM (Core M.ExpQ) +repLit (MkC c) = rep2 litEName [c] -repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) -repApp (MkC x) (MkC y) = rep2 appName [x,y] +repApp :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ) +repApp (MkC x) (MkC y) = rep2 appEName [x,y] -repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr) -repLam (MkC ps) (MkC e) = rep2 lamName [ps, e] +repLam :: Core [M.Pat] -> Core M.ExpQ -> DsM (Core M.ExpQ) +repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] -repTup :: Core [M.Expr] -> DsM (Core M.Expr) -repTup (MkC es) = rep2 tupName [es] +repTup :: Core [M.ExpQ] -> DsM (Core M.ExpQ) +repTup (MkC es) = rep2 tupEName [es] -repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) -repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z] +repCond :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ) +repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] -repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr) +repLetE :: Core [M.DecQ] -> Core M.ExpQ -> DsM (Core M.ExpQ) repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] -repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr) +repCaseE :: Core M.ExpQ -> Core [M.MatchQ] -> DsM( Core M.ExpQ) repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] -repDoE :: Core [M.Stmt] -> DsM (Core M.Expr) +repDoE :: Core [M.StmtQ] -> DsM (Core M.ExpQ) repDoE (MkC ss) = rep2 doEName [ss] -repComp :: Core [M.Stmt] -> DsM (Core M.Expr) -repComp (MkC ss) = rep2 compName [ss] +repComp :: Core [M.StmtQ] -> DsM (Core M.ExpQ) +repComp (MkC ss) = rep2 compEName [ss] -repListExp :: Core [M.Expr] -> DsM (Core M.Expr) -repListExp (MkC es) = rep2 listExpName [es] +repListExp :: Core [M.ExpQ] -> DsM (Core M.ExpQ) +repListExp (MkC es) = rep2 listEName [es] -repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr) -repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t] +repSigExp :: Core M.ExpQ -> Core M.TypeQ -> DsM (Core M.ExpQ) +repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] -repRecCon :: Core String -> Core [M.FldE]-> DsM (Core M.Expr) -repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs] +repRecCon :: Core String -> Core [M.FieldExp]-> DsM (Core M.ExpQ) +repRecCon (MkC c) (MkC fs) = rep2 recCName [c,fs] -repRecUpd :: Core M.Expr -> Core [M.FldE] -> DsM (Core M.Expr) -repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs] +repRecUpd :: Core M.ExpQ -> Core [M.FieldExp] -> DsM (Core M.ExpQ) +repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] -repInfixApp :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repInfixApp :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ) repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] -repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repSectionL :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ) repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] -repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repSectionR :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ) repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] ------------ Right hand sides (guarded expressions) ---- -repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs) -repGuarded (MkC pairs) = rep2 guardedName [pairs] +repGuarded :: Core [(M.ExpQ, M.ExpQ)] -> DsM (Core M.BodyQ) +repGuarded (MkC pairs) = rep2 guardedBName [pairs] -repNormal :: Core M.Expr -> DsM (Core M.Rihs) -repNormal (MkC e) = rep2 normalName [e] +repNormal :: Core M.ExpQ -> DsM (Core M.BodyQ) +repNormal (MkC e) = rep2 normalBName [e] -------------- Statements ------------------- -repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt) -repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e] +------------- Stmts ------------------- +repBindSt :: Core M.Pat -> Core M.ExpQ -> DsM (Core M.StmtQ) +repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] -repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt) -repLetSt (MkC ds) = rep2 letStName [ds] +repLetSt :: Core [M.DecQ] -> DsM (Core M.StmtQ) +repLetSt (MkC ds) = rep2 letSName [ds] -repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt) -repNoBindSt (MkC e) = rep2 noBindStName [e] +repNoBindSt :: Core M.ExpQ -> DsM (Core M.StmtQ) +repNoBindSt (MkC e) = rep2 noBindSName [e] --------------- DotDot (Arithmetic sequences) ----------- -repFrom :: Core M.Expr -> DsM (Core M.Expr) -repFrom (MkC x) = rep2 fromName [x] +-------------- Range (Arithmetic sequences) ----------- +repFrom :: Core M.ExpQ -> DsM (Core M.ExpQ) +repFrom (MkC x) = rep2 fromEName [x] -repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) -repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y] +repFromThen :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ) +repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y] -repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) -repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y] +repFromTo :: Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ) +repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y] -repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) -repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z] +repFromThenTo :: Core M.ExpQ -> Core M.ExpQ -> Core M.ExpQ -> DsM (Core M.ExpQ) +repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] ------------ Match and Clause Tuples ----------- -repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch) +repMatch :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.MatchQ) repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] -repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse) +repClause :: Core [M.Pat] -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.ClauseQ) repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] -------------- Dec ----------------------------- -repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl) -repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds] +repVal :: Core M.Pat -> Core M.BodyQ -> Core [M.DecQ] -> DsM (Core M.DecQ) +repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] -repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl) -repFun (MkC nm) (MkC b) = rep2 funName [nm, b] +repFun :: Core String -> Core [M.ClauseQ] -> DsM (Core M.DecQ) +repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] -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] +repData :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.ConQ] -> Core [String] -> DsM (Core M.DecQ) +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) +repNewtype :: Core M.CxtQ -> Core String -> Core [String] -> Core M.ConQ -> Core [String] -> DsM (Core M.DecQ) +repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs) + = rep2 newtypeDName [cxt, nm, tvs, con, derivs] + +repTySyn :: Core String -> Core [String] -> Core M.TypeQ -> DsM (Core M.DecQ) 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] +repInst :: Core M.CxtQ -> Core M.TypeQ -> Core [M.DecQ] -> DsM (Core M.DecQ) +repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds] -repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl) +repClass :: Core M.CxtQ -> Core String -> Core [String] -> Core [M.DecQ] -> DsM (Core M.DecQ) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds] -repProto :: Core String -> Core M.Type -> DsM (Core M.Decl) -repProto (MkC s) (MkC ty) = rep2 protoName [s, ty] +repProto :: Core String -> Core M.TypeQ -> DsM (Core M.DecQ) +repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty] -repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt) -repCtxt (MkC tys) = rep2 ctxtName [tys] +repCtxt :: Core [M.TypeQ] -> DsM (Core M.CxtQ) +repCtxt (MkC tys) = rep2 cxtName [tys] repConstr :: Core String -> HsConDetails Name (BangType Name) - -> DsM (Core M.Cons) + -> DsM (Core M.ConQ) repConstr con (PrefixCon ps) = do arg_tys <- mapM repBangTy ps - arg_tys1 <- coreList strTypeTyConName arg_tys - rep2 constrName [unC con, unC arg_tys1] + arg_tys1 <- coreList strictTypeQTyConName arg_tys + rep2 normalCName [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'] + arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys + rep2 recCName [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] + rep2 infixCName [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] +repTForall :: Core [String] -> Core M.CxtQ -> Core M.TypeQ -> DsM (Core M.TypeQ) +repTForall (MkC tvars) (MkC ctxt) (MkC ty) + = rep2 forallTName [tvars, ctxt, ty] -repTvar :: Core String -> DsM (Core M.Type) -repTvar (MkC s) = rep2 tvarName [s] +repTvar :: Core String -> DsM (Core M.TypeQ) +repTvar (MkC s) = rep2 varTName [s] -repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type) -repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2] +repTapp :: Core M.TypeQ -> Core M.TypeQ -> DsM (Core M.TypeQ) +repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2] -repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type) +repTapps :: Core M.TypeQ -> [Core M.TypeQ] -> DsM (Core M.TypeQ) 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] +repNamedTyCon :: Core String -> DsM (Core M.TypeQ) +repNamedTyCon (MkC s) = rep2 conTName [s] -repTupleTyCon :: Int -> DsM (Core M.Type) +repTupleTyCon :: Int -> DsM (Core M.TypeQ) -- Note: not Core Int; it's easier to be direct here -repTupleTyCon i = rep2 tupleTyConName [mkIntExpr (fromIntegral i)] +repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)] -repArrowTyCon :: DsM (Core M.Type) -repArrowTyCon = rep2 arrowTyConName [] +repArrowTyCon :: DsM (Core M.TypeQ) +repArrowTyCon = rep2 arrowTName [] -repListTyCon :: DsM (Core M.Type) -repListTyCon = rep2 listTyConName [] +repListTyCon :: DsM (Core M.TypeQ) +repListTyCon = rep2 listTName [] ---------------------------------------------------------- @@ -1085,14 +1129,27 @@ repListTyCon = rep2 listTyConName [] repLiteral :: HsLit -> DsM (Core M.Lit) repLiteral lit - = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] } + = do lit' <- case lit of + HsIntPrim i -> return $ HsInteger i + HsInt i -> return $ HsInteger i + HsFloatPrim r -> do rat_ty <- lookupType rationalTyConName + return $ HsRat r rat_ty + HsDoublePrim r -> do rat_ty <- lookupType rationalTyConName + return $ HsRat r rat_ty + _ -> return lit + lit_expr <- dsLit lit' + rep2 lit_name [lit_expr] where lit_name = case lit of - HsInteger _ -> integerLName - HsChar _ -> charLName - HsString _ -> stringLName - HsRat _ _ -> rationalLName - other -> uh_oh + HsInteger _ -> integerLName + HsInt _ -> integerLName + HsIntPrim _ -> intPrimLName + HsFloatPrim _ -> floatPrimLName + HsDoublePrim _ -> doublePrimLName + HsChar _ -> charLName + HsString _ -> stringLName + HsRat _ _ -> rationalLName + other -> uh_oh uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal" (ppr lit) @@ -1106,7 +1163,7 @@ repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyCo --------------- Miscellaneous ------------------- -repLift :: Core e -> DsM (Core M.Expr) +repLift :: Core e -> DsM (Core M.ExpQ) repLift (MkC x) = rep2 liftName [x] repGensym :: Core String -> DsM (Core (M.Q String)) @@ -1165,32 +1222,56 @@ coreVar id = MkC (Var id) templateHaskellNames :: NameSet -- The names that are implicitly mentioned by ``bracket'' -- Should stay in sync with the import list of DsMeta -templateHaskellNames - = 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, sectionLName, sectionRName, - guardedName, normalName, - bindStName, letStName, noBindStName, parStName, - fromName, fromThenName, fromToName, fromThenToName, - funName, valName, liftName, - gensymName, returnQName, bindQName, sequenceQName, - matchName, clauseName, funName, valName, tySynDName, dataDName, classDName, - instName, protoName, tforallName, tvarName, tconName, tappName, - arrowTyConName, tupleTyConName, listTyConName, namedTyConName, - ctxtName, constrName, recConstrName, infixConstrName, - exprTyConName, declTyConName, pattTyConName, mtchTyConName, - clseTyConName, stmtTyConName, consTyConName, typeTyConName, - strTypeTyConName, varStrTypeTyConName, - qTyConName, expTyConName, matTyConName, clsTyConName, - decTyConName, typTyConName, strictTypeName, varStrictTypeName, - recConName, recUpdName, precName, - fieldName, fieldTyConName, fieldPName, fieldPTyConName, - strictName, nonstrictName ] +templateHaskellNames = mkNameSet [ + returnQName, bindQName, sequenceQName, gensymName, liftName, + -- Lit + charLName, stringLName, integerLName, intPrimLName, + floatPrimLName, doublePrimLName, rationalLName, + -- Pat + litPName, varPName, tupPName, conPName, tildePName, + asPName, wildPName, recPName, listPName, + -- FieldPat + fieldPatName, + -- Match + matchName, + -- Clause + clauseName, + -- Exp + varEName, conEName, litEName, appEName, infixEName, + infixAppName, sectionLName, sectionRName, lamEName, tupEName, + condEName, letEName, caseEName, doEName, compEName, + fromEName, fromThenEName, fromToEName, fromThenToEName, + listEName, sigEName, recConEName, recUpdEName, + -- FieldExp + fieldExpName, + -- Body + guardedBName, normalBName, + -- Stmt + bindSName, letSName, noBindSName, parSName, + -- Dec + funDName, valDName, dataDName, newtypeDName, tySynDName, + classDName, instanceDName, sigDName, + -- Cxt + cxtName, + -- Strict + isStrictName, notStrictName, + -- Con + normalCName, recCName, infixCName, + -- StrictType + strictTypeName, + -- VarStrictType + varStrictTypeName, + -- Type + forallTName, varTName, conTName, appTName, + tupleTName, arrowTName, listTName, + + -- And the tycons + qTyConName, patTyConName, fieldPatTyConName, matchQTyConName, + clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName, + decQTyConName, conQTyConName, strictTypeQTyConName, + varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, + typeTyConName, matchTyConName, clauseTyConName] varQual = mk_known_key_name OccName.varName tcQual = mk_known_key_name OccName.tcName @@ -1202,230 +1283,272 @@ thModule = mkThPkgModule mETA_META_Name mk_known_key_name space str uniq = mkKnownKeyExternalName thModule (mkOccFS space str) uniq -integerLName = varQual FSLIT("integerL") integerLIdKey -charLName = varQual FSLIT("charL") charLIdKey -stringLName = varQual FSLIT("stringL") stringLIdKey -rationalLName = varQual FSLIT("rationalL") rationalLIdKey -plitName = varQual FSLIT("plit") plitIdKey -pvarName = varQual FSLIT("pvar") pvarIdKey -ptupName = varQual FSLIT("ptup") ptupIdKey -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 -appName = varQual FSLIT("app") appIdKey -infixEName = varQual FSLIT("infixE") infixEIdKey -lamName = varQual FSLIT("lam") lamIdKey -tupName = varQual FSLIT("tup") tupIdKey -doEName = varQual FSLIT("doE") doEIdKey -compName = varQual FSLIT("comp") compIdKey -listExpName = varQual FSLIT("listExp") listExpIdKey -sigExpName = varQual FSLIT("sigExp") sigExpIdKey -condName = varQual FSLIT("cond") condIdKey -letEName = varQual FSLIT("letE") letEIdKey -caseEName = varQual FSLIT("caseE") caseEIdKey -infixAppName = varQual FSLIT("infixApp") infixAppIdKey -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 -letStName = varQual FSLIT("letSt") letStIdKey -noBindStName = varQual FSLIT("noBindSt") noBindStIdKey -parStName = varQual FSLIT("parSt") parStIdKey -fromName = varQual FSLIT("from") fromIdKey -fromThenName = varQual FSLIT("fromThen") fromThenIdKey -fromToName = varQual FSLIT("fromTo") fromToIdKey -fromThenToName = varQual FSLIT("fromThenTo") fromThenToIdKey -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 - --- type Cls = ... -clauseName = varQual FSLIT("clause") clauseIdKey - --- data Dec = ... -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 +returnQName = varQual FSLIT("returnQ") returnQIdKey +bindQName = varQual FSLIT("bindQ") bindQIdKey +sequenceQName = varQual FSLIT("sequenceQ") sequenceQIdKey +gensymName = varQual FSLIT("gensym") gensymIdKey +liftName = varQual FSLIT("lift") liftIdKey + +-- data Lit = ... +charLName = varQual FSLIT("charL") charLIdKey +stringLName = varQual FSLIT("stringL") stringLIdKey +integerLName = varQual FSLIT("integerL") integerLIdKey +intPrimLName = varQual FSLIT("intPrimL") intPrimLIdKey +floatPrimLName = varQual FSLIT("floatPrimL") floatPrimLIdKey +doublePrimLName = varQual FSLIT("doublePrimL") doublePrimLIdKey +rationalLName = varQual FSLIT("rationalL") rationalLIdKey + +-- data Pat = ... +litPName = varQual FSLIT("litP") litPIdKey +varPName = varQual FSLIT("varP") varPIdKey +tupPName = varQual FSLIT("tupP") tupPIdKey +conPName = varQual FSLIT("conP") conPIdKey +tildePName = varQual FSLIT("tildeP") tildePIdKey +asPName = varQual FSLIT("asP") asPIdKey +wildPName = varQual FSLIT("wildP") wildPIdKey +recPName = varQual FSLIT("recP") recPIdKey +listPName = varQual FSLIT("listP") listPIdKey + +-- type FieldPat = ... +fieldPatName = varQual FSLIT("fieldPat") fieldPatIdKey + +-- data Match = ... +matchName = varQual FSLIT("match") matchIdKey + +-- data Clause = ... +clauseName = varQual FSLIT("clause") clauseIdKey + +-- data Exp = ... +varEName = varQual FSLIT("varE") varEIdKey +conEName = varQual FSLIT("conE") conEIdKey +litEName = varQual FSLIT("litE") litEIdKey +appEName = varQual FSLIT("appE") appEIdKey +infixEName = varQual FSLIT("infixE") infixEIdKey +infixAppName = varQual FSLIT("infixApp") infixAppIdKey +sectionLName = varQual FSLIT("sectionL") sectionLIdKey +sectionRName = varQual FSLIT("sectionR") sectionRIdKey +lamEName = varQual FSLIT("lamE") lamEIdKey +tupEName = varQual FSLIT("tupE") tupEIdKey +condEName = varQual FSLIT("condE") condEIdKey +letEName = varQual FSLIT("letE") letEIdKey +caseEName = varQual FSLIT("caseE") caseEIdKey +doEName = varQual FSLIT("doE") doEIdKey +compEName = varQual FSLIT("compE") compEIdKey +-- ArithSeq skips a level +fromEName = varQual FSLIT("fromE") fromEIdKey +fromThenEName = varQual FSLIT("fromThenE") fromThenEIdKey +fromToEName = varQual FSLIT("fromToE") fromToEIdKey +fromThenToEName = varQual FSLIT("fromThenToE") fromThenToEIdKey +-- end ArithSeq +listEName = varQual FSLIT("listE") listEIdKey +sigEName = varQual FSLIT("sigE") sigEIdKey +recConEName = varQual FSLIT("recConE") recConEIdKey +recUpdEName = varQual FSLIT("recUpdE") recUpdEIdKey + +-- type FieldExp = ... +fieldExpName = varQual FSLIT("fieldExp") fieldExpIdKey + +-- data Body = ... +guardedBName = varQual FSLIT("guardedB") guardedBIdKey +normalBName = varQual FSLIT("normalB") normalBIdKey + +-- data Stmt = ... +bindSName = varQual FSLIT("bindS") bindSIdKey +letSName = varQual FSLIT("letS") letSIdKey +noBindSName = varQual FSLIT("noBindS") noBindSIdKey +parSName = varQual FSLIT("parS") parSIdKey + +-- data Dec = ... +funDName = varQual FSLIT("funD") funDIdKey +valDName = varQual FSLIT("valD") valDIdKey +dataDName = varQual FSLIT("dataD") dataDIdKey +newtypeDName = varQual FSLIT("newtypeD") newtypeDIdKey +tySynDName = varQual FSLIT("tySynD") tySynDIdKey +classDName = varQual FSLIT("classD") classDIdKey +instanceDName = varQual FSLIT("instanceD") instanceDIdKey +sigDName = varQual FSLIT("sigD") sigDIdKey -- type Ctxt = ... -ctxtName = varQual FSLIT("ctxt") ctxtIdKey - +cxtName = varQual FSLIT("cxt") cxtIdKey + +-- data Strict = ... +isStrictName = varQual FSLIT("isStrict") isStrictKey +notStrictName = varQual FSLIT("notStrict") notStrictKey + -- data Con = ... -constrName = varQual FSLIT("constr") constrIdKey -recConstrName = varQual FSLIT("recConstr") recConstrIdKey -infixConstrName = varQual FSLIT("infixConstr") infixConstrIdKey +normalCName = varQual FSLIT("normalC") normalCIdKey +recCName = varQual FSLIT("recC") recCIdKey +infixCName = varQual FSLIT("infixC") infixCIdKey + +-- type StrictType = ... +strictTypeName = varQual FSLIT("strictType") strictTKey + +-- type VarStrictType = ... +varStrictTypeName = varQual FSLIT("varStrictType") varStrictTKey + +-- data Type = ... +forallTName = varQual FSLIT("forallT") forallTIdKey +varTName = varQual FSLIT("varT") varTIdKey +conTName = varQual FSLIT("conT") conTIdKey +tupleTName = varQual FSLIT("tupleT") tupleTIdKey +arrowTName = varQual FSLIT("arrowT") arrowTIdKey +listTName = varQual FSLIT("listT") listTIdKey +appTName = varQual FSLIT("appT") appTIdKey -exprTyConName = tcQual FSLIT("Expr") exprTyConKey -declTyConName = tcQual FSLIT("Decl") declTyConKey -pattTyConName = tcQual FSLIT("Patt") pattTyConKey -mtchTyConName = tcQual FSLIT("Mtch") mtchTyConKey -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 -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 +qTyConName = tcQual FSLIT("Q") qTyConKey +patTyConName = tcQual FSLIT("Pat") patTyConKey +fieldPatTyConName = tcQual FSLIT("FieldPat") fieldPatTyConKey +matchQTyConName = tcQual FSLIT("MatchQ") matchQTyConKey +clauseQTyConName = tcQual FSLIT("ClauseQ") clauseQTyConKey +expQTyConName = tcQual FSLIT("ExpQ") expQTyConKey +fieldExpTyConName = tcQual FSLIT("FieldExp") fieldExpTyConKey +stmtQTyConName = tcQual FSLIT("StmtQ") stmtQTyConKey +decQTyConName = tcQual FSLIT("DecQ") decQTyConKey +conQTyConName = tcQual FSLIT("ConQ") conQTyConKey +strictTypeQTyConName = tcQual FSLIT("StrictTypeQ") strictTypeQTyConKey +varStrictTypeQTyConName = tcQual FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey +typeQTyConName = tcQual FSLIT("TypeQ") typeQTyConKey + +expTyConName = tcQual FSLIT("Exp") expTyConKey +decTyConName = tcQual FSLIT("Dec") decTyConKey +typeTyConName = tcQual FSLIT("Type") typeTyConKey +matchTyConName = tcQual FSLIT("Match") matchTyConKey +clauseTyConName = tcQual FSLIT("Clause") clauseTyConKey -- 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 -typTyConKey = mkPreludeTyConUnique 112 -decTyConKey = mkPreludeTyConUnique 113 -varStrTypeTyConKey = mkPreludeTyConUnique 114 -strTypeTyConKey = mkPreludeTyConUnique 115 -fieldTyConKey = mkPreludeTyConUnique 116 -fieldPTyConKey = mkPreludeTyConUnique 117 - - +expTyConKey = mkPreludeTyConUnique 100 +matchTyConKey = mkPreludeTyConUnique 101 +clauseTyConKey = mkPreludeTyConUnique 102 +qTyConKey = mkPreludeTyConUnique 103 +expQTyConKey = mkPreludeTyConUnique 104 +decQTyConKey = mkPreludeTyConUnique 105 +patTyConKey = mkPreludeTyConUnique 106 +matchQTyConKey = mkPreludeTyConUnique 107 +clauseQTyConKey = mkPreludeTyConUnique 108 +stmtQTyConKey = mkPreludeTyConUnique 109 +conQTyConKey = mkPreludeTyConUnique 110 +typeQTyConKey = mkPreludeTyConUnique 111 +typeTyConKey = mkPreludeTyConUnique 112 +decTyConKey = mkPreludeTyConUnique 113 +varStrictTypeQTyConKey = mkPreludeTyConUnique 114 +strictTypeQTyConKey = mkPreludeTyConUnique 115 +fieldExpTyConKey = mkPreludeTyConUnique 116 +fieldPatTyConKey = mkPreludeTyConUnique 117 -- 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 -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 -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 --- 242 unallocated -sectionLIdKey = mkPreludeMiscIdUnique 243 -sectionRIdKey = mkPreludeMiscIdUnique 244 -guardedIdKey = mkPreludeMiscIdUnique 245 -normalIdKey = mkPreludeMiscIdUnique 246 -bindStIdKey = mkPreludeMiscIdUnique 247 -letStIdKey = mkPreludeMiscIdUnique 248 -noBindStIdKey = mkPreludeMiscIdUnique 249 -parStIdKey = mkPreludeMiscIdUnique 250 - -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 - -stringLIdKey = mkPreludeMiscIdUnique 261 -rationalLIdKey = mkPreludeMiscIdUnique 262 - -sigExpIdKey = mkPreludeMiscIdUnique 263 - -strictTypeKey = mkPreludeMiscIdUnique 264 -strictKey = mkPreludeMiscIdUnique 265 -nonstrictKey = mkPreludeMiscIdUnique 266 -varStrictTypeKey = mkPreludeMiscIdUnique 267 - -recConstrIdKey = mkPreludeMiscIdUnique 268 -infixConstrIdKey = mkPreludeMiscIdUnique 269 - -recConIdKey = mkPreludeMiscIdUnique 270 -recUpdIdKey = mkPreludeMiscIdUnique 271 -precIdKey = mkPreludeMiscIdUnique 272 -fieldKey = mkPreludeMiscIdUnique 273 -fieldPKey = mkPreludeMiscIdUnique 274 +returnQIdKey = mkPreludeMiscIdUnique 200 +bindQIdKey = mkPreludeMiscIdUnique 201 +sequenceQIdKey = mkPreludeMiscIdUnique 202 +gensymIdKey = mkPreludeMiscIdUnique 203 +liftIdKey = mkPreludeMiscIdUnique 204 + +-- data Lit = ... +charLIdKey = mkPreludeMiscIdUnique 210 +stringLIdKey = mkPreludeMiscIdUnique 211 +integerLIdKey = mkPreludeMiscIdUnique 212 +intPrimLIdKey = mkPreludeMiscIdUnique 213 +floatPrimLIdKey = mkPreludeMiscIdUnique 214 +doublePrimLIdKey = mkPreludeMiscIdUnique 215 +rationalLIdKey = mkPreludeMiscIdUnique 216 + +-- data Pat = ... +litPIdKey = mkPreludeMiscIdUnique 220 +varPIdKey = mkPreludeMiscIdUnique 221 +tupPIdKey = mkPreludeMiscIdUnique 222 +conPIdKey = mkPreludeMiscIdUnique 223 +tildePIdKey = mkPreludeMiscIdUnique 224 +asPIdKey = mkPreludeMiscIdUnique 225 +wildPIdKey = mkPreludeMiscIdUnique 226 +recPIdKey = mkPreludeMiscIdUnique 227 +listPIdKey = mkPreludeMiscIdUnique 228 + +-- type FieldPat = ... +fieldPatIdKey = mkPreludeMiscIdUnique 230 + +-- data Match = ... +matchIdKey = mkPreludeMiscIdUnique 231 + +-- data Clause = ... +clauseIdKey = mkPreludeMiscIdUnique 232 + +-- data Exp = ... +varEIdKey = mkPreludeMiscIdUnique 240 +conEIdKey = mkPreludeMiscIdUnique 241 +litEIdKey = mkPreludeMiscIdUnique 242 +appEIdKey = mkPreludeMiscIdUnique 243 +infixEIdKey = mkPreludeMiscIdUnique 244 +infixAppIdKey = mkPreludeMiscIdUnique 245 +sectionLIdKey = mkPreludeMiscIdUnique 246 +sectionRIdKey = mkPreludeMiscIdUnique 247 +lamEIdKey = mkPreludeMiscIdUnique 248 +tupEIdKey = mkPreludeMiscIdUnique 249 +condEIdKey = mkPreludeMiscIdUnique 250 +letEIdKey = mkPreludeMiscIdUnique 251 +caseEIdKey = mkPreludeMiscIdUnique 252 +doEIdKey = mkPreludeMiscIdUnique 253 +compEIdKey = mkPreludeMiscIdUnique 254 +fromEIdKey = mkPreludeMiscIdUnique 255 +fromThenEIdKey = mkPreludeMiscIdUnique 256 +fromToEIdKey = mkPreludeMiscIdUnique 257 +fromThenToEIdKey = mkPreludeMiscIdUnique 258 +listEIdKey = mkPreludeMiscIdUnique 259 +sigEIdKey = mkPreludeMiscIdUnique 260 +recConEIdKey = mkPreludeMiscIdUnique 261 +recUpdEIdKey = mkPreludeMiscIdUnique 262 + +-- type FieldExp = ... +fieldExpIdKey = mkPreludeMiscIdUnique 265 + +-- data Body = ... +guardedBIdKey = mkPreludeMiscIdUnique 266 +normalBIdKey = mkPreludeMiscIdUnique 267 + +-- data Stmt = ... +bindSIdKey = mkPreludeMiscIdUnique 268 +letSIdKey = mkPreludeMiscIdUnique 269 +noBindSIdKey = mkPreludeMiscIdUnique 270 +parSIdKey = mkPreludeMiscIdUnique 271 + +-- data Dec = ... +funDIdKey = mkPreludeMiscIdUnique 272 +valDIdKey = mkPreludeMiscIdUnique 273 +dataDIdKey = mkPreludeMiscIdUnique 274 +newtypeDIdKey = mkPreludeMiscIdUnique 275 +tySynDIdKey = mkPreludeMiscIdUnique 276 +classDIdKey = mkPreludeMiscIdUnique 277 +instanceDIdKey = mkPreludeMiscIdUnique 278 +sigDIdKey = mkPreludeMiscIdUnique 279 + +-- type Cxt = ... +cxtIdKey = mkPreludeMiscIdUnique 280 + +-- data Strict = ... +isStrictKey = mkPreludeMiscIdUnique 281 +notStrictKey = mkPreludeMiscIdUnique 282 + +-- data Con = ... +normalCIdKey = mkPreludeMiscIdUnique 283 +recCIdKey = mkPreludeMiscIdUnique 284 +infixCIdKey = mkPreludeMiscIdUnique 285 + +-- type StrictType = ... +strictTKey = mkPreludeMiscIdUnique 2286 + +-- type VarStrictType = ... +varStrictTKey = mkPreludeMiscIdUnique 287 + +-- data Type = ... +forallTIdKey = mkPreludeMiscIdUnique 290 +varTIdKey = mkPreludeMiscIdUnique 291 +conTIdKey = mkPreludeMiscIdUnique 292 +tupleTIdKey = mkPreludeMiscIdUnique 294 +arrowTIdKey = mkPreludeMiscIdUnique 295 +listTIdKey = mkPreludeMiscIdUnique 296 +appTIdKey = mkPreludeMiscIdUnique 293 -- %************************************************************************ -- %* * @@ -1436,3 +1559,4 @@ fieldPKey = mkPreludeMiscIdUnique 274 -- It is rather usatisfactory that we don't have a SrcLoc addDsWarn :: SDoc -> DsM () addDsWarn msg = dsWarn (noSrcLoc, msg) +