X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=5da376b574df867fff7cf993db49d17cd04a7459;hp=5c3486a1c10c35713f133e097a3a9e7cc5752b79;hb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4;hpb=283e858564bb7979e59dcf00e852c2039aff231c diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 5c3486a..5da376b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -13,19 +13,12 @@ -- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-unused-imports #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details --- The kludge is only needed in this module because of trac #2267. - module DsMeta( dsBracket, templateHaskellNames, qTyConName, nameTyConName, - liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName, + liftName, liftStringName, expQTyConName, patQTyConName, + decQTyConName, decsQTyConName, typeQTyConName, decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, - quoteExpName, quotePatName + quoteExpName, quotePatName, quoteDecName, quoteTypeName ) where #include "HsVersions.h" @@ -33,7 +26,6 @@ module DsMeta( dsBracket, import {-# SOURCE #-} DsExpr ( dsExpr ) import MatchLit -import DsUtils import DsMonad import qualified Language.Haskell.TH as TH @@ -45,11 +37,11 @@ import PrelNames -- OccName.varName we do this by removing varName from the import of -- OccName above, making a qualified instance of OccName and using -- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName +import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName ) import Module import Id -import Name +import Name hiding( isVarOcc, isTcOcc, varName, tcName ) import NameEnv import TcType import TyCon @@ -81,11 +73,12 @@ dsBracket brack splices where new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices] - do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 } - do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } - do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 } + do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 } + do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } + do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } + do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } + do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL" {- -------------- Examples -------------------- @@ -106,9 +99,14 @@ dsBracket brack splices -- Declarations ------------------------------------------------------- +repTopP :: LPat Name -> DsM (Core TH.PatQ) +repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) + ; pat' <- addBinds ss (repLP pat) + ; wrapNongenSyms ss pat' } + repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) repTopDs group - = do { let { bndrs = map unLoc (groupBinders group) } ; + = do { let { bndrs = hsGroupBinders group } ; ss <- mkGenSyms bndrs ; -- Bind all the names mainly to avoid repeated use of explicit strings. @@ -121,7 +119,7 @@ repTopDs group decls <- addBinds ss (do { val_ds <- rep_val_binds (hs_valds group) ; - tycl_ds <- mapM repTyClD (hs_tyclds group) ; + tycl_ds <- mapM repTyClD (concat (hs_tyclds group)) ; inst_ds <- mapM repInstD' (hs_instds group) ; for_ds <- mapM repForD (hs_fords group) ; -- more needed @@ -137,16 +135,6 @@ repTopDs group -- Do *not* gensym top-level binders } -groupBinders :: HsGroup Name -> [Located Name] -groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, - hs_instds = inst_decls, hs_fords = foreign_decls }) --- Collect the binders of a Group - = collectHsValBinders val_decls ++ - [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++ - [n | L _ (ForeignImport n _ _) <- foreign_decls] - where - assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls] - {- Note [Binders and occurrences] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -188,7 +176,7 @@ repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, ; cons1 <- mapM repC cons ; cons2 <- coreList conQTyConName cons1 ; derivs1 <- repDerivs mb_derivs - ; bndrs1 <- coreList nameTyConName bndrs + ; bndrs1 <- coreList tyVarBndrTyConName bndrs ; repData cxt1 tc1 bndrs1 opt_tys2 cons2 derivs1 } ; return $ Just (loc, dec) @@ -204,7 +192,7 @@ repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 ; con1 <- repC con ; derivs1 <- repDerivs mb_derivs - ; bndrs1 <- coreList nameTyConName bndrs + ; bndrs1 <- coreList tyVarBndrTyConName bndrs ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1 } ; return $ Just (loc, dec) @@ -217,7 +205,7 @@ repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdTyPats = opt_tys do { opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 ; ty1 <- repLTy ty - ; bndrs1 <- coreList nameTyConName bndrs + ; bndrs1 <- coreList tyVarBndrTyConName bndrs ; repTySyn tc1 bndrs1 opt_tys2 ty1 } ; return (Just (loc, dec)) @@ -235,7 +223,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, ; fds1 <- repLFunDeps fds ; ats1 <- repLAssocFamilys ats ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1) - ; bndrs1 <- coreList nameTyConName bndrs + ; bndrs1 <- coreList tyVarBndrTyConName bndrs ; repClass cxt1 cls1 bndrs1 fds1 decls1 } ; return $ Just (loc, dec) @@ -255,13 +243,17 @@ repTyFamily :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) repTyFamily (L loc (TyFamily { tcdFlavour = flavour, tcdLName = tc, tcdTyVars = tvs, - tcdKind = _kind })) + tcdKind = opt_kind })) tyVarBinds = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; dec <- tyVarBinds tvs $ \bndrs -> do { flav <- repFamilyFlavour flavour - ; bndrs1 <- coreList nameTyConName bndrs - ; repFamily flav tc1 bndrs1 + ; bndrs1 <- coreList tyVarBndrTyConName bndrs + ; case opt_kind of + Nothing -> repFamilyNoKind flav tc1 bndrs1 + Just ki -> do { ki1 <- repKind ki + ; repFamilyKind flav tc1 bndrs1 ki1 + } } ; return $ Just (loc, dec) } @@ -315,7 +307,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now -- appear in the resulting data structure do { cxt1 <- repContext cxt ; inst_ty1 <- repPredTy (HsClassP cls tys) - ; ss <- mkGenSyms (collectHsBindBinders binds) + ; ss <- mkGenSyms (collectHsBindsBinders binds) ; binds1 <- addBinds ss (rep_binds binds) ; ats1 <- repLAssocFamInst ats ; decls1 <- coreList decQTyConName (ats1 ++ binds1) @@ -329,7 +321,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty) repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) -repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis))) +repForD (L loc (ForeignImport name typ (CImport cc s ch cis))) = do MkC name' <- lookupLOcc name MkC typ' <- repLTy typ MkC cc' <- repCCallConv cc @@ -337,27 +329,27 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis))) cis' <- conv_cimportspec cis MkC str <- coreStringLit $ static ++ unpackFS ch ++ " " - ++ unpackFS cn ++ " " ++ cis' dec <- rep2 forImpDName [cc', s', str, name', typ'] return (loc, dec) where conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) conv_cimportspec (CFunction DynamicTarget) = return "dynamic" - conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs) conv_cimportspec CWrapper = return "wrapper" static = case cis of - CFunction (StaticTarget _) -> "static " + CFunction (StaticTarget _ _) -> "static " _ -> "" repForD decl = notHandled "Foreign declaration" (ppr decl) repCCallConv :: CCallConv -> DsM (Core TH.Callconv) repCCallConv CCallConv = rep2 cCallName [] repCCallConv StdCallConv = rep2 stdCallName [] -repCCallConv CmmCallConv = notHandled "repCCallConv" (ppr CmmCallConv) +repCCallConv callConv = notHandled "repCCallConv" (ppr callConv) repSafety :: Safety -> DsM (Core TH.Safety) repSafety PlayRisky = rep2 unsafeName [] +repSafety PlayInterruptible = rep2 interruptibleName [] repSafety (PlaySafe False) = rep2 safeName [] repSafety (PlaySafe True) = rep2 threadsafeName [] @@ -369,17 +361,18 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L _ (ConDecl con _ [] (L _ []) details ResTyH98 _)) - = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences] - repConstr con1 details } -repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc)) - = do { addTyVarBinds tvs $ \bndrs -> do { - c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc)); - ctxt' <- repContext ctxt; - bndrs' <- coreList nameTyConName bndrs; - rep2 forallCName [unC bndrs', unC ctxt', unC c'] - } +repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] + , con_details = details, con_res = ResTyH98 })) + = do { con1 <- lookupLOcc con -- See note [Binders and occurrences] + ; repConstr con1 details } +repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 })) + = addTyVarBinds tvs $ \bndrs -> + do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] })) + ; ctxt' <- repContext ctxt + ; bndrs' <- coreList tyVarBndrTyConName bndrs + ; rep2 forallCName [unC bndrs', unC ctxt', unC c'] + } repC (L loc con_decl) -- GADTs = putSrcSpanDs loc $ notHandled "GADT declaration" (ppr con_decl) @@ -440,46 +433,51 @@ rep_proto nm ty loc ; return [(loc, sig)] } -rep_inline :: Located Name -> InlineSpec -> SrcSpan +rep_inline :: Located Name + -> InlinePragma -- Never defaultInlinePragma + -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_inline nm ispec loc = do { nm1 <- lookupLOcc nm - ; (_, ispec1) <- rep_InlineSpec ispec + ; ispec1 <- rep_InlinePrag ispec ; pragma <- repPragInl nm1 ispec1 ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan +rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc = do { nm1 <- lookupLOcc nm ; ty1 <- repLTy ty - ; (hasSpec, ispec1) <- rep_InlineSpec ispec - ; pragma <- if hasSpec - then repPragSpecInl nm1 ty1 ispec1 - else repPragSpec nm1 ty1 + ; pragma <- if isDefaultInlinePragma ispec + then repPragSpec nm1 ty1 -- SPECIALISE + else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE + ; repPragSpecInl nm1 ty1 ispec1 } ; return [(loc, pragma)] } --- extract all the information needed to build a TH.InlineSpec +-- Extract all the information needed to build a TH.InlinePrag -- -rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ) -rep_InlineSpec (Inline (InlinePragma activation match) inline) - | Nothing <- activation1 - = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1 +rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma + -> DsM (Core TH.InlineSpecQ) +rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline }) | Just (flag, phase) <- activation1 - = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase - | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec" - where + = repInlineSpecPhase inline1 match1 flag phase + | otherwise + = repInlineSpecNoPhase inline1 match1 + where match1 = coreBool (rep_RuleMatchInfo match) activation1 = rep_Activation activation - inline1 = coreBool inline + inline1 = case inline of + Inline -> coreBool True + _other -> coreBool False + -- We have no representation for Inlinable rep_RuleMatchInfo FunLike = False rep_RuleMatchInfo ConLike = True - rep_Activation NeverActive = Nothing - rep_Activation AlwaysActive = Nothing + rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive + rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive rep_Activation (ActiveBefore phase) = Just (coreBool False, MkC $ mkIntExprInt phase) rep_Activation (ActiveAfter phase) = Just (coreBool True, @@ -495,8 +493,8 @@ rep_InlineSpec (Inline (InlinePragma activation match) inline) -- families, depending on whether they are associated or not. -- type ProcessTyVarBinds a = - [LHsTyVarBndr Name] -- the binders to be added - -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env + [LHsTyVarBndr Name] -- the binders to be added + -> ([Core TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) -- gensym a list of type variables and enter them into the meta environment; @@ -506,12 +504,14 @@ type ProcessTyVarBinds a = addTyVarBinds :: ProcessTyVarBinds a addTyVarBinds tvs m = do - let names = map (hsTyVarName.unLoc) tvs + let names = hsLTyVarNames tvs + mkWithKinds = map repTyVarBndrWithKind tvs freshNames <- mkGenSyms names term <- addBinds freshNames $ do - bndrs <- mapM lookupBinder names - m bndrs - wrapGenSyns freshNames term + bndrs <- mapM lookupBinder names + kindedBndrs <- zipWithM ($) mkWithKinds bndrs + m kindedBndrs + wrapGenSyms freshNames term -- Look up a list of type variables; the computations passed as the second -- argument gets the *new* names on Core-level as an argument @@ -519,9 +519,20 @@ addTyVarBinds tvs m = lookupTyVarBinds :: ProcessTyVarBinds a lookupTyVarBinds tvs m = do - let names = map (hsTyVarName.unLoc) tvs - bndrs <- mapM lookupBinder names - m bndrs + let names = hsLTyVarNames tvs + mkWithKinds = map repTyVarBndrWithKind tvs + bndrs <- mapM lookupBinder names + kindedBndrs <- zipWithM ($) mkWithKinds bndrs + m kindedBndrs + +-- Produce kinded binder constructors from the Haskell tyvar binders +-- +repTyVarBndrWithKind :: LHsTyVarBndr Name + -> Core TH.Name -> DsM (Core TH.TyVarBndr) +repTyVarBndrWithKind (L _ (UserTyVar {})) nm + = repPlainTV nm +repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm + = repKind ki >>= repKindedTV nm -- represent a type context -- @@ -576,44 +587,77 @@ repTy (HsForAllTy _ tvs ctxt ty) = addTyVarBinds tvs $ \bndrs -> do ctxt1 <- repLContext ctxt ty1 <- repLTy ty - bndrs1 <- coreList nameTyConName bndrs + bndrs1 <- coreList tyVarBndrTyConName bndrs repTForall bndrs1 ctxt1 ty1 repTy (HsTyVar n) - | isTvOcc (nameOccName n) = do - tv1 <- lookupTvOcc n - repTvar tv1 - | otherwise = do - tc1 <- lookupOcc n - repNamedTyCon tc1 -repTy (HsAppTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - repTapp f1 a1 -repTy (HsFunTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - tcon <- repArrowTyCon - repTapps tcon [f1, a1] -repTy (HsListTy t) = do - t1 <- repLTy t - tcon <- repListTyCon - repTapp tcon t1 -repTy (HsPArrTy t) = do - t1 <- repLTy t - tcon <- repTy (HsTyVar (tyConName parrTyCon)) - repTapp tcon t1 -repTy (HsTupleTy _ tys) = do - tys1 <- repLTys tys - tcon <- repTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) - `nlHsAppTy` ty2) -repTy (HsParTy t) = repLTy t -repTy (HsPredTy pred) = repPredTy pred -repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) -repTy ty = notHandled "Exotic form of type" (ppr ty) + | isTvOcc (nameOccName n) = do + tv1 <- lookupTvOcc n + repTvar tv1 + | otherwise = do + tc1 <- lookupOcc n + repNamedTyCon tc1 +repTy (HsAppTy f a) = do + f1 <- repLTy f + a1 <- repLTy a + repTapp f1 a1 +repTy (HsFunTy f a) = do + f1 <- repLTy f + a1 <- repLTy a + tcon <- repArrowTyCon + repTapps tcon [f1, a1] +repTy (HsListTy t) = do + t1 <- repLTy t + tcon <- repListTyCon + repTapp tcon t1 +repTy (HsPArrTy t) = do + t1 <- repLTy t + tcon <- repTy (HsTyVar (tyConName parrTyCon)) + repTapp tcon t1 +repTy (HsTupleTy _ tys) = do + tys1 <- repLTys tys + tcon <- repTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) + `nlHsAppTy` ty2) +repTy (HsParTy t) = repLTy t +repTy (HsPredTy pred) = repPredTy pred +repTy (HsKindSig t k) = do + t1 <- repLTy t + k1 <- repKind k + repTSig t1 k1 +repTy (HsSpliceTy splice _ _) = repSplice splice +repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) +repTy ty = notHandled "Exotic form of type" (ppr ty) + +-- represent a kind +-- +repKind :: Kind -> DsM (Core TH.Kind) +repKind ki + = do { let (kis, ki') = splitKindFunTys ki + ; kis_rep <- mapM repKind kis + ; ki'_rep <- repNonArrowKind ki' + ; foldrM repArrowK ki'_rep kis_rep + } + where + repNonArrowKind k | isLiftedTypeKind k = repStarK + | otherwise = notHandled "Exotic form of kind" + (ppr k) + +----------------------------------------------------------------------------- +-- Splices +----------------------------------------------------------------------------- +repSplice :: HsSplice Name -> DsM (Core a) +-- See Note [How brackets and nested splices are handled] in TcSplice +-- We return a CoreExpr of any old type; the context should know +repSplice (HsSplice n _) + = do { mb_val <- dsLookupMetaEnv n + ; case mb_val of + Just (Splice e) -> do { e' <- dsExpr e + ; return (MkC e') } + _ -> pprPanic "HsSplice" (ppr n) } + -- Should not happen; statically checked ----------------------------------------------------------------------------- -- Expressions @@ -662,7 +706,7 @@ repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; repCaseE arg (nonEmptyCoreList ms2) } -repE (HsIf x y z) = do +repE (HsIf _ x y z) = do a <- repLE x b <- repLE y c <- repLE z @@ -670,26 +714,34 @@ repE (HsIf x y z) = do repE (HsLet bs e) = do { (ss,ds) <- repBinds bs ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 - ; wrapGenSyns ss z } + ; wrapGenSyms ss z } + -- FIXME: I haven't got the types here right yet -repE (HsDo DoExpr sts body _) +repE e@(HsDo ctxt sts body _) + | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; - e <- repDoE (nonEmptyCoreList (zs ++ [ret])); - wrapGenSyns ss e } -repE (HsDo ListComp sts body _) + e' <- repDoE (nonEmptyCoreList (zs ++ [ret])); + wrapGenSyms ss e' } + + | ListComp <- ctxt = do { (ss,zs) <- repLSts sts; body' <- addBinds ss $ repLE body; ret <- repNoBindSt body'; - e <- repComp (nonEmptyCoreList (zs ++ [ret])); - wrapGenSyns ss e } -repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e) + e' <- repComp (nonEmptyCoreList (zs ++ [ret])); + wrapGenSyms ss e' } + + | otherwise + = notHandled "mdo and [: :]" (ppr e) + repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) - | isBoxed boxed = do { xs <- repLEs es; repTup xs } - | otherwise = notHandled "Unboxed tuples" (ppr e) + | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e) + | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) + | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs } + repE (RecordCon c _ flds) = do { x <- lookupLOcc c; fs <- repFields flds; @@ -716,14 +768,8 @@ repE (ArithSeq _ aseq) = ds2 <- repLE e2 ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (HsSpliceE (HsSplice n _)) - = do { mb_val <- dsLookupMetaEnv n - ; case mb_val of - Just (Splice e) -> do { e' <- dsExpr e - ; return (MkC e') } - _ -> pprPanic "HsSplice" (ppr n) } - -- Should not happen; statically checked +repE (HsSpliceE splice) = repSplice splice repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) @@ -743,7 +789,7 @@ repMatchTup (L _ (Match [p] _ (GRHSs guards wheres))) = ; addBinds ss2 $ do { ; gs <- repGuards guards ; match <- repMatch p1 gs ds - ; wrapGenSyns (ss1++ss2) match }}} + ; wrapGenSyms (ss1++ss2) match }}} repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) @@ -755,7 +801,7 @@ repClauseTup (L _ (Match ps _ (GRHSs guards wheres))) = ; addBinds ss2 $ do { gs <- repGuards guards ; clause <- repClause ps1 gs ds - ; wrapGenSyns (ss1++ss2) clause }}} + ; wrapGenSyms (ss1++ss2) clause }}} repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ) repGuards [L _ (GRHS [] e)] @@ -764,7 +810,7 @@ repGuards other = do { zs <- mapM process other; let {(xs, ys) = unzip zs}; gd <- repGuarded (nonEmptyCoreList ys); - wrapGenSyns (concat xs) gd } + wrapGenSyms (concat xs) gd } where process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2)) @@ -847,7 +893,7 @@ repBinds EmptyLocalBinds repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b) repBinds (HsValBinds decs) - = do { let { bndrs = map unLoc (collectHsValBinders decs) } + = do { let { bndrs = collectHsValBinders decs } -- No need to worrry about detailed scopes within -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually @@ -887,7 +933,7 @@ rep_bind (L loc (FunBind { fun_id = fn, ; fn' <- lookupLBinder fn ; p <- repPvar fn' ; ans <- repVal p guardcore wherecore - ; ans' <- wrapGenSyns ss ans + ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ })) @@ -901,7 +947,7 @@ rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres })) ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore - ; ans' <- wrapGenSyns ss ans + ; ans' <- wrapGenSyms ss ans ; return (loc, ans') } rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) @@ -913,7 +959,7 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" +rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" ----------------------------------------------------------------------------- -- Since everything in a Bind is mutually recursive we need rename all @@ -945,7 +991,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( do { xs <- repLPs ps; body <- repLE e; repLam xs body }) - ; wrapGenSyns ss lam } + ; wrapGenSyms ss lam } repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) @@ -970,10 +1016,13 @@ 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 <- repLP p; repPtilde p1 } +repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } repP (ParPat p) = repLP p repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } -repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs } +repP p@(TuplePat ps boxed _) + | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p) + | otherwise = do { qs <- repLPs ps; repPtup qs } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of @@ -989,6 +1038,7 @@ repP (ConPatIn dc details) repPinfix p1' con_str p2' } } repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) -- The problem is to do with scoped type variables. @@ -1116,14 +1166,14 @@ lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; return (mkTyConApp tc []) } -wrapGenSyns :: [GenSymBind] +wrapGenSyms :: [GenSymBind] -> Core (TH.Q a) -> DsM (Core (TH.Q a)) --- wrapGenSyns [(nm1,id1), (nm2,id2)] y +-- wrapGenSyms [(nm1,id1), (nm2,id2)] y -- --> bindQ (gensym nm1) (\ id1 -> -- bindQ (gensym nm2 (\ id2 -> -- y)) -wrapGenSyns binds body@(MkC b) +wrapGenSyms binds body@(MkC b) = do { var_ty <- lookupType nameTyConName ; go var_ty binds } where @@ -1209,6 +1259,9 @@ repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ) repPtilde (MkC p) = rep2 tildePName [p] +repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ) +repPbang (MkC p) = rep2 bangPName [p] + repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] @@ -1218,6 +1271,9 @@ repPwild = rep2 wildPName [] repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPlist (MkC ps) = rep2 listPName [ps] +repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ) +repPview (MkC e) (MkC p) = rep2 viewPName [e,p] + --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str @@ -1242,7 +1298,7 @@ repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) repTup (MkC es) = rep2 tupEName [es] repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) -repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] +repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] @@ -1336,7 +1392,7 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] -repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] +repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] -> Maybe (Core [TH.TypeQ]) -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ) repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs) @@ -1344,7 +1400,7 @@ repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs) repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs) = rep2 dataInstDName [cxt, nm, tys, cons, derivs] -repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] +repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] -> Maybe (Core [TH.TypeQ]) -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ) repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs) @@ -1352,7 +1408,7 @@ repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs) repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs) = rep2 newtypeInstDName [cxt, nm, tys, con, derivs] -repTySyn :: Core TH.Name -> Core [TH.Name] +repTySyn :: Core TH.Name -> Core [TH.TyVarBndr] -> Maybe (Core [TH.TypeQ]) -> Core TH.TypeQ -> DsM (Core TH.DecQ) repTySyn (MkC nm) (MkC tvs) Nothing (MkC rhs) @@ -1363,7 +1419,7 @@ repTySyn (MkC nm) (MkC _) (Just (MkC tys)) (MkC rhs) repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds] -repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] +repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) @@ -1380,10 +1436,16 @@ repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.InlineSpecQ repPragSpecInl (MkC nm) (MkC ty) (MkC ispec) = rep2 pragSpecInlDName [nm, ty, ispec] -repFamily :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.Name] - -> DsM (Core TH.DecQ) -repFamily (MkC flav) (MkC nm) (MkC tvs) - = rep2 familyDName [flav, nm, tvs] +repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] + -> DsM (Core TH.DecQ) +repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs) + = rep2 familyNoKindDName [flav, nm, tvs] + +repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr] + -> Core TH.Kind + -> DsM (Core TH.DecQ) +repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki) + = rep2 familyKindDName [flav, nm, tvs, ki] repInlineSpecNoPhase :: Core Bool -> Core Bool -> DsM (Core TH.InlineSpecQ) repInlineSpecNoPhase (MkC inline) (MkC conlike) @@ -1429,7 +1491,8 @@ repConstr con (InfixCon st1 st2) ------------ Types ------------------- -repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) +repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ + -> DsM (Core TH.TypeQ) repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 forallTName [tvars, ctxt, ty] @@ -1437,12 +1500,15 @@ repTvar :: Core TH.Name -> DsM (Core TH.TypeQ) repTvar (MkC s) = rep2 varTName [s] repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) -repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2] +repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ) repTapps f [] = return f repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } +repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ) +repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] + --------- Type constructors -------------- repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) @@ -1458,6 +1524,19 @@ repArrowTyCon = rep2 arrowTName [] repListTyCon :: DsM (Core TH.TypeQ) repListTyCon = rep2 listTName [] +------------ Kinds ------------------- + +repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr) +repPlainTV (MkC nm) = rep2 plainTVName [nm] + +repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr) +repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] + +repStarK :: DsM (Core TH.Kind) +repStarK = rep2 starKName [] + +repArrowK :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind) +repArrowK (MkC ki1) (MkC ki2) = rep2 arrowKName [ki1, ki2] ---------------------------------------------------------- -- Literals @@ -1583,13 +1662,14 @@ templateHaskellNames :: [Name] templateHaskellNames = [ returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, - + liftStringName, + -- Lit charLName, stringLName, integerLName, intPrimLName, wordPrimLName, - floatPrimLName, doublePrimLName, rationalLName, + floatPrimLName, doublePrimLName, rationalLName, -- Pat - litPName, varPName, tupPName, conPName, tildePName, infixPName, - asPName, wildPName, recPName, listPName, sigPName, + litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName, -- FieldPat fieldPatName, -- Match @@ -1614,7 +1694,8 @@ templateHaskellNames = [ funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, - familyDName, dataInstDName, newtypeInstDName, tySynInstDName, + familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, + tySynInstDName, -- Cxt cxtName, -- Pred @@ -1629,13 +1710,18 @@ templateHaskellNames = [ varStrictTypeName, -- Type forallTName, varTName, conTName, appTName, - tupleTName, arrowTName, listTName, + tupleTName, arrowTName, listTName, sigTName, + -- TyVarBndr + plainTVName, kindedTVName, + -- Kind + starKName, arrowKName, -- Callconv cCallName, stdCallName, -- Safety unsafeName, safeName, threadsafeName, + interruptibleName, -- InlineSpec inlineSpecNoPhaseName, inlineSpecPhaseName, -- FunDep @@ -1648,11 +1734,12 @@ templateHaskellNames = [ clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName, stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, matchTyConName, clauseTyConName, patQTyConName, - fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, predQTyConName, + typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName, + patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName, + predQTyConName, decsQTyConName, -- Quasiquoting - quoteExpName, quotePatName] + quoteDecName, quoteTypeName, quoteExpName, quotePatName] thSyn, thLib, qqLib :: Module thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax") @@ -1672,7 +1759,8 @@ qqFun = mk_known_key_name OccName.varName qqLib -------------------- TH.Syntax ----------------------- qTyConName, nameTyConName, fieldExpTyConName, patTyConName, fieldPatTyConName, expTyConName, decTyConName, typeTyConName, - matchTyConName, clauseTyConName, funDepTyConName, predTyConName :: Name + tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName, + predTyConName :: Name qTyConName = thTc (fsLit "Q") qTyConKey nameTyConName = thTc (fsLit "Name") nameTyConKey fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey @@ -1681,6 +1769,7 @@ fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey expTyConName = thTc (fsLit "Exp") expTyConKey decTyConName = thTc (fsLit "Dec") decTyConKey typeTyConName = thTc (fsLit "Type") typeTyConKey +tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey matchTyConName = thTc (fsLit "Match") matchTyConKey clauseTyConName = thTc (fsLit "Clause") clauseTyConKey funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey @@ -1688,12 +1777,13 @@ predTyConName = thTc (fsLit "Pred") predTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, - mkNameLName :: Name -returnQName = thFun (fsLit "returnQ") returnQIdKey -bindQName = thFun (fsLit "bindQ") bindQIdKey -sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey + mkNameLName, liftStringName :: Name +returnQName = thFun (fsLit "returnQ") returnQIdKey +bindQName = thFun (fsLit "bindQ") bindQIdKey +sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey newNameName = thFun (fsLit "newName") newNameIdKey -liftName = thFun (fsLit "lift") liftIdKey +liftName = thFun (fsLit "lift") liftIdKey +liftStringName = thFun (fsLit "liftString") liftStringIdKey mkNameName = thFun (fsLit "mkName") mkNameIdKey mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey @@ -1715,19 +1805,21 @@ doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey rationalLName = libFun (fsLit "rationalL") rationalLIdKey -- data Pat = ... -litPName, varPName, tupPName, conPName, infixPName, tildePName, - asPName, wildPName, recPName, listPName, sigPName :: Name +litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName, + asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name litPName = libFun (fsLit "litP") litPIdKey varPName = libFun (fsLit "varP") varPIdKey tupPName = libFun (fsLit "tupP") tupPIdKey conPName = libFun (fsLit "conP") conPIdKey infixPName = libFun (fsLit "infixP") infixPIdKey tildePName = libFun (fsLit "tildeP") tildePIdKey +bangPName = libFun (fsLit "bangP") bangPIdKey asPName = libFun (fsLit "asP") asPIdKey wildPName = libFun (fsLit "wildP") wildPIdKey recPName = libFun (fsLit "recP") recPIdKey listPName = libFun (fsLit "listP") listPIdKey sigPName = libFun (fsLit "sigP") sigPIdKey +viewPName = libFun (fsLit "viewP") viewPIdKey -- type FieldPat = ... fieldPatName :: Name @@ -1797,8 +1889,8 @@ parSName = libFun (fsLit "parS") parSIdKey -- data Dec = ... funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName, - pragSpecInlDName, familyDName, dataInstDName, newtypeInstDName, - tySynInstDName :: Name + pragSpecInlDName, familyNoKindDName, familyKindDName, dataInstDName, + newtypeInstDName, tySynInstDName :: Name funDName = libFun (fsLit "funD") funDIdKey valDName = libFun (fsLit "valD") valDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey @@ -1811,7 +1903,8 @@ forImpDName = libFun (fsLit "forImpD") forImpDIdKey pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey -familyDName = libFun (fsLit "familyD") familyDIdKey +familyNoKindDName= libFun (fsLit "familyNoKindD")familyNoKindDIdKey +familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey @@ -1847,14 +1940,25 @@ varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey -- data Type = ... forallTName, varTName, conTName, tupleTName, arrowTName, - listTName, appTName :: Name + listTName, appTName, sigTName :: Name forallTName = libFun (fsLit "forallT") forallTIdKey varTName = libFun (fsLit "varT") varTIdKey conTName = libFun (fsLit "conT") conTIdKey -tupleTName = libFun (fsLit "tupleT") tupleTIdKey -arrowTName = libFun (fsLit "arrowT") arrowTIdKey -listTName = libFun (fsLit "listT") listTIdKey +tupleTName = libFun (fsLit "tupleT") tupleTIdKey +arrowTName = libFun (fsLit "arrowT") arrowTIdKey +listTName = libFun (fsLit "listT") listTIdKey appTName = libFun (fsLit "appT") appTIdKey +sigTName = libFun (fsLit "sigT") sigTIdKey + +-- data TyVarBndr = ... +plainTVName, kindedTVName :: Name +plainTVName = libFun (fsLit "plainTV") plainTVIdKey +kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey + +-- data Kind = ... +starKName, arrowKName :: Name +starKName = libFun (fsLit "starK") starKIdKey +arrowKName = libFun (fsLit "arrowK") arrowKIdKey -- data Callconv = ... cCallName, stdCallName :: Name @@ -1862,10 +1966,11 @@ cCallName = libFun (fsLit "cCall") cCallIdKey stdCallName = libFun (fsLit "stdCall") stdCallIdKey -- data Safety = ... -unsafeName, safeName, threadsafeName :: Name +unsafeName, safeName, threadsafeName, interruptibleName :: Name unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey +interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey -- data InlineSpec = ... inlineSpecNoPhaseName, inlineSpecPhaseName :: Name @@ -1884,13 +1989,14 @@ dataFamName = libFun (fsLit "dataFam") dataFamIdKey matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName, varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName, - patQTyConName, fieldPatQTyConName, predQTyConName :: Name + patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName :: Name matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey expQTyConName = libTc (fsLit "ExpQ") expQTyConKey stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey decQTyConName = libTc (fsLit "DecQ") decQTyConKey -conQTyConName = libTc (fsLit "ConQ") conQTyConKey +decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec] +conQTyConName = libTc (fsLit "ConQ") conQTyConKey strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey @@ -1900,20 +2006,22 @@ fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey predQTyConName = libTc (fsLit "PredQ") predQTyConKey -- quasiquoting -quoteExpName, quotePatName :: Name -quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey -quotePatName = qqFun (fsLit "quotePat") quotePatKey +quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name +quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey +quotePatName = qqFun (fsLit "quotePat") quotePatKey +quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey +quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey -- TyConUniques available: 100-129 -- Check in PrelNames if you want to change this expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey, - stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, + stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey, decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, - predQTyConKey :: Unique + predQTyConKey, decsQTyConKey :: Unique expTyConKey = mkPreludeTyConUnique 100 matchTyConKey = mkPreludeTyConUnique 101 clauseTyConKey = mkPreludeTyConUnique 102 @@ -1939,6 +2047,8 @@ fieldExpQTyConKey = mkPreludeTyConUnique 121 funDepTyConKey = mkPreludeTyConUnique 122 predTyConKey = mkPreludeTyConUnique 123 predQTyConKey = mkPreludeTyConUnique 124 +tyVarBndrTyConKey = mkPreludeTyConUnique 125 +decsQTyConKey = mkPreludeTyConUnique 126 -- IdUniques available: 200-399 -- If you want to change this, make sure you check in PrelNames @@ -1970,20 +2080,25 @@ floatPrimLIdKey = mkPreludeMiscIdUnique 215 doublePrimLIdKey = mkPreludeMiscIdUnique 216 rationalLIdKey = mkPreludeMiscIdUnique 217 +liftStringIdKey :: Unique +liftStringIdKey = mkPreludeMiscIdUnique 218 + -- data Pat = ... -litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, - asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique +litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, + asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique litPIdKey = mkPreludeMiscIdUnique 220 varPIdKey = mkPreludeMiscIdUnique 221 tupPIdKey = mkPreludeMiscIdUnique 222 conPIdKey = mkPreludeMiscIdUnique 223 infixPIdKey = mkPreludeMiscIdUnique 312 tildePIdKey = mkPreludeMiscIdUnique 224 +bangPIdKey = mkPreludeMiscIdUnique 359 asPIdKey = mkPreludeMiscIdUnique 225 wildPIdKey = mkPreludeMiscIdUnique 226 recPIdKey = mkPreludeMiscIdUnique 227 listPIdKey = mkPreludeMiscIdUnique 228 sigPIdKey = mkPreludeMiscIdUnique 229 +viewPIdKey = mkPreludeMiscIdUnique 360 -- type FieldPat = ... fieldPatIdKey :: Unique @@ -1997,6 +2112,7 @@ matchIdKey = mkPreludeMiscIdUnique 231 clauseIdKey :: Unique clauseIdKey = mkPreludeMiscIdUnique 232 + -- data Exp = ... varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey, @@ -2051,8 +2167,8 @@ parSIdKey = mkPreludeMiscIdUnique 271 -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, - pragSpecDIdKey, pragSpecInlDIdKey, familyDIdKey, dataInstDIdKey, - newtypeInstDIdKey, tySynInstDIdKey :: Unique + pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey, + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 272 valDIdKey = mkPreludeMiscIdUnique 273 dataDIdKey = mkPreludeMiscIdUnique 274 @@ -2065,7 +2181,8 @@ forImpDIdKey = mkPreludeMiscIdUnique 297 pragInlDIdKey = mkPreludeMiscIdUnique 348 pragSpecDIdKey = mkPreludeMiscIdUnique 349 pragSpecInlDIdKey = mkPreludeMiscIdUnique 352 -familyDIdKey = mkPreludeMiscIdUnique 340 +familyNoKindDIdKey= mkPreludeMiscIdUnique 340 +familyKindDIdKey = mkPreludeMiscIdUnique 353 dataInstDIdKey = mkPreludeMiscIdUnique 341 newtypeInstDIdKey = mkPreludeMiscIdUnique 342 tySynInstDIdKey = mkPreludeMiscIdUnique 343 @@ -2101,7 +2218,7 @@ varStrictTKey = mkPreludeMiscIdUnique 287 -- data Type = ... forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey, - listTIdKey, appTIdKey :: Unique + listTIdKey, appTIdKey, sigTIdKey :: Unique forallTIdKey = mkPreludeMiscIdUnique 290 varTIdKey = mkPreludeMiscIdUnique 291 conTIdKey = mkPreludeMiscIdUnique 292 @@ -2109,6 +2226,17 @@ tupleTIdKey = mkPreludeMiscIdUnique 294 arrowTIdKey = mkPreludeMiscIdUnique 295 listTIdKey = mkPreludeMiscIdUnique 296 appTIdKey = mkPreludeMiscIdUnique 293 +sigTIdKey = mkPreludeMiscIdUnique 358 + +-- data TyVarBndr = ... +plainTVIdKey, kindedTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 354 +kindedTVIdKey = mkPreludeMiscIdUnique 355 + +-- data Kind = ... +starKIdKey, arrowKIdKey :: Unique +starKIdKey = mkPreludeMiscIdUnique 356 +arrowKIdKey = mkPreludeMiscIdUnique 357 -- data Callconv = ... cCallIdKey, stdCallIdKey :: Unique @@ -2116,10 +2244,11 @@ cCallIdKey = mkPreludeMiscIdUnique 300 stdCallIdKey = mkPreludeMiscIdUnique 301 -- data Safety = ... -unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique +unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique unsafeIdKey = mkPreludeMiscIdUnique 305 safeIdKey = mkPreludeMiscIdUnique 306 threadsafeIdKey = mkPreludeMiscIdUnique 307 +interruptibleIdKey = mkPreludeMiscIdUnique 308 -- data InlineSpec = inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique @@ -2136,6 +2265,8 @@ typeFamIdKey = mkPreludeMiscIdUnique 344 dataFamIdKey = mkPreludeMiscIdUnique 345 -- quasiquoting -quoteExpKey, quotePatKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 321 -quotePatKey = mkPreludeMiscIdUnique 322 +quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique +quoteExpKey = mkPreludeMiscIdUnique 321 +quotePatKey = mkPreludeMiscIdUnique 322 +quoteDecKey = mkPreludeMiscIdUnique 323 +quoteTypeKey = mkPreludeMiscIdUnique 324