1{-# LANGUAGE CPP, TypeFamilies #-} 2{-# LANGUAGE FlexibleContexts #-} 3{-# LANGUAGE ViewPatterns #-} 4 5----------------------------------------------------------------------------- 6-- 7-- (c) The University of Glasgow 2006 8-- 9-- The purpose of this module is to transform an HsExpr into a CoreExpr which 10-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the 11-- input HsExpr. We do this in the DsM monad, which supplies access to 12-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. 13-- 14-- It also defines a bunch of knownKeyNames, in the same way as is done 15-- in prelude/PrelNames. It's much more convenient to do it here, because 16-- otherwise we have to recompile PrelNames whenever we add a Name, which is 17-- a Royal Pain (triggers other recompilation). 18----------------------------------------------------------------------------- 19 20module DsMeta( dsBracket ) where 21 22#include "HsVersions.h" 23 24import GhcPrelude 25 26import {-# SOURCE #-} DsExpr ( dsExpr ) 27 28import MatchLit 29import DsMonad 30 31import qualified Language.Haskell.TH as TH 32 33import GHC.Hs 34import PrelNames 35-- To avoid clashes with DsMeta.varName we must make a local alias for 36-- OccName.varName we do this by removing varName from the import of 37-- OccName above, making a qualified instance of OccName and using 38-- OccNameAlias.varName where varName ws previously used in this file. 39import qualified OccName( isDataOcc, isVarOcc, isTcOcc ) 40 41import Module 42import Id 43import Name hiding( isVarOcc, isTcOcc, varName, tcName ) 44import THNames 45import NameEnv 46import TcType 47import TyCon 48import TysWiredIn 49import CoreSyn 50import MkCore 51import CoreUtils 52import SrcLoc 53import Unique 54import BasicTypes 55import Outputable 56import Bag 57import DynFlags 58import FastString 59import ForeignCall 60import Util 61import Maybes 62import MonadUtils 63 64import Data.ByteString ( unpack ) 65import Control.Monad 66import Data.List 67 68----------------------------------------------------------------------------- 69dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr 70-- Returns a CoreExpr of type TH.ExpQ 71-- The quoted thing is parameterised over Name, even though it has 72-- been type checked. We don't want all those type decorations! 73 74dsBracket brack splices 75 = dsExtendMetaEnv new_bit (do_brack brack) 76 where 77 new_bit = mkNameEnv [(n, DsSplice (unLoc e)) 78 | PendingTcSplice n e <- splices] 79 80 do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOcc n ; return e1 } 81 do_brack (ExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } 82 do_brack (PatBr _ p) = do { MkC p1 <- repTopP p ; return p1 } 83 do_brack (TypBr _ t) = do { MkC t1 <- repLTy t ; return t1 } 84 do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } 85 do_brack (DecBrL {}) = panic "dsBracket: unexpected DecBrL" 86 do_brack (TExpBr _ e) = do { MkC e1 <- repLE e ; return e1 } 87 do_brack (XBracket nec) = noExtCon nec 88 89{- -------------- Examples -------------------- 90 91 [| \x -> x |] 92====> 93 gensym (unpackString "x"#) `bindQ` \ x1::String -> 94 lam (pvar x1) (var x1) 95 96 97 [| \x -> $(f [| x |]) |] 98====> 99 gensym (unpackString "x"#) `bindQ` \ x1::String -> 100 lam (pvar x1) (f (var x1)) 101-} 102 103 104------------------------------------------------------- 105-- Declarations 106------------------------------------------------------- 107 108repTopP :: LPat GhcRn -> DsM (Core TH.PatQ) 109repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) 110 ; pat' <- addBinds ss (repLP pat) 111 ; wrapGenSyms ss pat' } 112 113repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec])) 114repTopDs group@(HsGroup { hs_valds = valds 115 , hs_splcds = splcds 116 , hs_tyclds = tyclds 117 , hs_derivds = derivds 118 , hs_fixds = fixds 119 , hs_defds = defds 120 , hs_fords = fords 121 , hs_warnds = warnds 122 , hs_annds = annds 123 , hs_ruleds = ruleds 124 , hs_docs = docs }) 125 = do { let { bndrs = hsScopedTvBinders valds 126 ++ hsGroupBinders group 127 ++ hsPatSynSelectors valds 128 ; instds = tyclds >>= group_instds } ; 129 ss <- mkGenSyms bndrs ; 130 131 -- Bind all the names mainly to avoid repeated use of explicit strings. 132 -- Thus we get 133 -- do { t :: String <- genSym "T" ; 134 -- return (Data t [] ...more t's... } 135 -- The other important reason is that the output must mention 136 -- only "T", not "Foo:T" where Foo is the current module 137 138 decls <- addBinds ss ( 139 do { val_ds <- rep_val_binds valds 140 ; _ <- mapM no_splice splcds 141 ; tycl_ds <- mapM repTyClD (tyClGroupTyClDecls tyclds) 142 ; role_ds <- mapM repRoleD (concatMap group_roles tyclds) 143 ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds) 144 ; inst_ds <- mapM repInstD instds 145 ; deriv_ds <- mapM repStandaloneDerivD derivds 146 ; fix_ds <- mapM repFixD fixds 147 ; _ <- mapM no_default_decl defds 148 ; for_ds <- mapM repForD fords 149 ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc) 150 warnds) 151 ; ann_ds <- mapM repAnnD annds 152 ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc) 153 ruleds) 154 ; _ <- mapM no_doc docs 155 156 -- more needed 157 ; return (de_loc $ sort_by_loc $ 158 val_ds ++ catMaybes tycl_ds ++ role_ds 159 ++ kisig_ds 160 ++ (concat fix_ds) 161 ++ inst_ds ++ rule_ds ++ for_ds 162 ++ ann_ds ++ deriv_ds) }) ; 163 164 decl_ty <- lookupType decQTyConName ; 165 let { core_list = coreList' decl_ty decls } ; 166 167 dec_ty <- lookupType decTyConName ; 168 q_decs <- repSequenceQ dec_ty core_list ; 169 170 wrapGenSyms ss q_decs 171 } 172 where 173 no_splice (dL->L loc _) 174 = notHandledL loc "Splices within declaration brackets" empty 175 no_default_decl (dL->L loc decl) 176 = notHandledL loc "Default declarations" (ppr decl) 177 no_warn (dL->L loc (Warning _ thing _)) 178 = notHandledL loc "WARNING and DEPRECATION pragmas" $ 179 text "Pragma for declaration of" <+> ppr thing 180 no_warn _ = panic "repTopDs" 181 no_doc (dL->L loc _) 182 = notHandledL loc "Haddock documentation" empty 183repTopDs (XHsGroup nec) = noExtCon nec 184 185hsScopedTvBinders :: HsValBinds GhcRn -> [Name] 186-- See Note [Scoped type variables in bindings] 187hsScopedTvBinders binds 188 = concatMap get_scoped_tvs sigs 189 where 190 sigs = case binds of 191 ValBinds _ _ sigs -> sigs 192 XValBindsLR (NValBinds _ sigs) -> sigs 193 194get_scoped_tvs :: LSig GhcRn -> [Name] 195get_scoped_tvs (dL->L _ signature) 196 | TypeSig _ _ sig <- signature 197 = get_scoped_tvs_from_sig (hswc_body sig) 198 | ClassOpSig _ _ _ sig <- signature 199 = get_scoped_tvs_from_sig sig 200 | PatSynSig _ _ sig <- signature 201 = get_scoped_tvs_from_sig sig 202 | otherwise 203 = [] 204 where 205 get_scoped_tvs_from_sig sig 206 -- Both implicit and explicit quantified variables 207 -- We need the implicit ones for f :: forall (a::k). blah 208 -- here 'k' scopes too 209 | HsIB { hsib_ext = implicit_vars 210 , hsib_body = hs_ty } <- sig 211 , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty 212 = implicit_vars ++ hsLTyVarNames explicit_vars 213 get_scoped_tvs_from_sig (XHsImplicitBndrs nec) 214 = noExtCon nec 215 216{- Notes 217 218Note [Scoped type variables in bindings] 219~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 220Consider 221 f :: forall a. a -> a 222 f x = x::a 223Here the 'forall a' brings 'a' into scope over the binding group. 224To achieve this we 225 226 a) Gensym a binding for 'a' at the same time as we do one for 'f' 227 collecting the relevant binders with hsScopedTvBinders 228 229 b) When processing the 'forall', don't gensym 230 231The relevant places are signposted with references to this Note 232 233Note [Scoped type variables in class and instance declarations] 234~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 235Scoped type variables may occur in default methods and default 236signatures. We need to bring the type variables in 'foralls' 237into the scope of the method bindings. 238 239Consider 240 class Foo a where 241 foo :: forall (b :: k). a -> Proxy b -> Proxy b 242 foo _ x = (x :: Proxy b) 243 244We want to ensure that the 'b' in the type signature and the default 245implementation are the same, so we do the following: 246 247 a) Before desugaring the signature and binding of 'foo', use 248 get_scoped_tvs to collect type variables in 'forall' and 249 create symbols for them. 250 b) Use 'addBinds' to bring these symbols into the scope of the type 251 signatures and bindings. 252 c) Use these symbols to generate Core for the class/instance declaration. 253 254Note that when desugaring the signatures, we lookup the type variables 255from the scope rather than recreate symbols for them. See more details 256in "rep_ty_sig" and in Trac#14885. 257 258Note [Binders and occurrences] 259~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 260When we desugar [d| data T = MkT |] 261we want to get 262 Data "T" [] [Con "MkT" []] [] 263and *not* 264 Data "Foo:T" [] [Con "Foo:MkT" []] [] 265That is, the new data decl should fit into whatever new module it is 266asked to fit in. We do *not* clone, though; no need for this: 267 Data "T79" .... 268 269But if we see this: 270 data T = MkT 271 foo = reifyDecl T 272 273then we must desugar to 274 foo = Data "Foo:T" [] [Con "Foo:MkT" []] [] 275 276So in repTopDs we bring the binders into scope with mkGenSyms and addBinds. 277And we use lookupOcc, rather than lookupBinder 278in repTyClD and repC. 279 280Note [Don't quantify implicit type variables in quotes] 281~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 282If you're not careful, it's suprisingly easy to take this quoted declaration: 283 284 [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b 285 idProxy x = x 286 |] 287 288and have Template Haskell turn it into this: 289 290 idProxy :: forall k proxy (b :: k). proxy b -> proxy b 291 idProxy x = x 292 293Notice that we explicitly quantified the variable `k`! The latter declaration 294isn't what the user wrote in the first place. 295 296Usually, the culprit behind these bugs is taking implicitly quantified type 297variables (often from the hsib_vars field of HsImplicitBinders) and putting 298them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123. 299-} 300 301-- represent associated family instances 302-- 303repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ)) 304 305repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $ 306 repFamilyDecl (L loc fam) 307 308repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) 309 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] 310 ; dec <- addTyClTyVarBinds tvs $ \bndrs -> 311 repSynDecl tc1 bndrs rhs 312 ; return (Just (loc, dec)) } 313 314repTyClD (dL->L loc (DataDecl { tcdLName = tc 315 , tcdTyVars = tvs 316 , tcdDataDefn = defn })) 317 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] 318 ; dec <- addTyClTyVarBinds tvs $ \bndrs -> 319 repDataDefn tc1 (Left bndrs) defn 320 ; return (Just (loc, dec)) } 321 322repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, 323 tcdTyVars = tvs, tcdFDs = fds, 324 tcdSigs = sigs, tcdMeths = meth_binds, 325 tcdATs = ats, tcdATDefs = atds })) 326 = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] 327 ; dec <- addTyVarBinds tvs $ \bndrs -> 328 do { cxt1 <- repLContext cxt 329 -- See Note [Scoped type variables in class and instance declarations] 330 ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds 331 ; fds1 <- repLFunDeps fds 332 ; ats1 <- repFamilyDecls ats 333 ; atds1 <- mapM (repAssocTyFamDefaultD . unLoc) atds 334 ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds) 335 ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1 336 ; wrapGenSyms ss decls2 } 337 ; return $ Just (loc, dec) 338 } 339 340repTyClD _ = panic "repTyClD" 341 342------------------------- 343repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) 344repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles)) 345 = do { tycon1 <- lookupLOcc tycon 346 ; roles1 <- mapM repRole roles 347 ; roles2 <- coreList roleTyConName roles1 348 ; dec <- repRoleAnnotD tycon1 roles2 349 ; return (loc, dec) } 350repRoleD _ = panic "repRoleD" 351 352------------------------- 353repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ) 354repKiSigD (dL->L loc kisig) = 355 case kisig of 356 StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v 357 XStandaloneKindSig nec -> noExtCon nec 358 359------------------------- 360repDataDefn :: Core TH.Name 361 -> Either (Core [TH.TyVarBndrQ]) 362 -- the repTyClD case 363 (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ) 364 -- the repDataFamInstD case 365 -> HsDataDefn GhcRn 366 -> DsM (Core TH.DecQ) 367repDataDefn tc opts 368 (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig 369 , dd_cons = cons, dd_derivs = mb_derivs }) 370 = do { cxt1 <- repLContext cxt 371 ; derivs1 <- repDerivs mb_derivs 372 ; case (new_or_data, cons) of 373 (NewType, [con]) -> do { con' <- repC con 374 ; ksig' <- repMaybeLTy ksig 375 ; repNewtype cxt1 tc opts ksig' con' 376 derivs1 } 377 (NewType, _) -> failWithDs (text "Multiple constructors for newtype:" 378 <+> pprQuotedList 379 (getConNames $ unLoc $ head cons)) 380 (DataType, _) -> do { ksig' <- repMaybeLTy ksig 381 ; consL <- mapM repC cons 382 ; cons1 <- coreList conQTyConName consL 383 ; repData cxt1 tc opts ksig' cons1 384 derivs1 } 385 } 386repDataDefn _ _ (XHsDataDefn nec) = noExtCon nec 387 388repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ] 389 -> LHsType GhcRn 390 -> DsM (Core TH.DecQ) 391repSynDecl tc bndrs ty 392 = do { ty1 <- repLTy ty 393 ; repTySyn tc bndrs ty1 } 394 395repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) 396repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo = info 397 , fdLName = tc 398 , fdTyVars = tvs 399 , fdResultSig = dL->L _ resultSig 400 , fdInjectivityAnn = injectivity })) 401 = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] 402 ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn 403 mkHsQTvs tvs = HsQTvs { hsq_ext = [] 404 , hsq_explicit = tvs } 405 resTyVar = case resultSig of 406 TyVarSig _ bndr -> mkHsQTvs [bndr] 407 _ -> mkHsQTvs [] 408 ; dec <- addTyClTyVarBinds tvs $ \bndrs -> 409 addTyClTyVarBinds resTyVar $ \_ -> 410 case info of 411 ClosedTypeFamily Nothing -> 412 notHandled "abstract closed type family" (ppr decl) 413 ClosedTypeFamily (Just eqns) -> 414 do { eqns1 <- mapM (repTyFamEqn . unLoc) eqns 415 ; eqns2 <- coreList tySynEqnQTyConName eqns1 416 ; result <- repFamilyResultSig resultSig 417 ; inj <- repInjectivityAnn injectivity 418 ; repClosedFamilyD tc1 bndrs result inj eqns2 } 419 OpenTypeFamily -> 420 do { result <- repFamilyResultSig resultSig 421 ; inj <- repInjectivityAnn injectivity 422 ; repOpenFamilyD tc1 bndrs result inj } 423 DataFamily -> 424 do { kind <- repFamilyResultSigToMaybeKind resultSig 425 ; repDataFamilyD tc1 bndrs kind } 426 ; return (loc, dec) 427 } 428repFamilyDecl _ = panic "repFamilyDecl" 429 430-- | Represent result signature of a type family 431repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ) 432repFamilyResultSig (NoSig _) = repNoSig 433repFamilyResultSig (KindSig _ ki) = do { ki' <- repLTy ki 434 ; repKindSig ki' } 435repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr 436 ; repTyVarSig bndr' } 437repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec 438 439-- | Represent result signature using a Maybe Kind. Used with data families, 440-- where the result signature can be either missing or a kind but never a named 441-- result variable. 442repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn 443 -> DsM (Core (Maybe TH.KindQ)) 444repFamilyResultSigToMaybeKind (NoSig _) = 445 do { coreNothing kindQTyConName } 446repFamilyResultSigToMaybeKind (KindSig _ ki) = 447 do { ki' <- repLTy ki 448 ; coreJust kindQTyConName ki' } 449repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind" 450 451-- | Represent injectivity annotation of a type family 452repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) 453 -> DsM (Core (Maybe TH.InjectivityAnn)) 454repInjectivityAnn Nothing = 455 do { coreNothing injAnnTyConName } 456repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) = 457 do { lhs' <- lookupBinder (unLoc lhs) 458 ; rhs1 <- mapM (lookupBinder . unLoc) rhs 459 ; rhs2 <- coreList nameTyConName rhs1 460 ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2] 461 ; coreJust injAnnTyConName injAnn } 462 463repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ] 464repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds) 465 466repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ) 467repAssocTyFamDefaultD = repTyFamInstD 468 469------------------------- 470-- represent fundeps 471-- 472repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep]) 473repLFunDeps fds = repList funDepTyConName repLFunDep fds 474 475repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep) 476repLFunDep (dL->L _ (xs, ys)) 477 = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs 478 ys' <- repList nameTyConName (lookupBinder . unLoc) ys 479 repFunDep xs' ys' 480 481-- Represent instance declarations 482-- 483repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) 484repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl })) 485 = do { dec <- repTyFamInstD fi_decl 486 ; return (loc, dec) } 487repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl })) 488 = do { dec <- repDataFamInstD fi_decl 489 ; return (loc, dec) } 490repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl })) 491 = do { dec <- repClsInstD cls_decl 492 ; return (loc, dec) } 493repInstD _ = panic "repInstD" 494 495repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ) 496repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds 497 , cid_sigs = sigs, cid_tyfam_insts = ats 498 , cid_datafam_insts = adts 499 , cid_overlap_mode = overlap 500 }) 501 = addSimpleTyVarBinds tvs $ 502 -- We must bring the type variables into scope, so their 503 -- occurrences don't fail, even though the binders don't 504 -- appear in the resulting data structure 505 -- 506 -- But we do NOT bring the binders of 'binds' into scope 507 -- because they are properly regarded as occurrences 508 -- For example, the method names should be bound to 509 -- the selector Ids, not to fresh names (#5410) 510 -- 511 do { cxt1 <- repLContext cxt 512 ; inst_ty1 <- repLTy inst_ty 513 -- See Note [Scoped type variables in class and instance declarations] 514 ; (ss, sigs_binds) <- rep_sigs_binds sigs binds 515 ; ats1 <- mapM (repTyFamInstD . unLoc) ats 516 ; adts1 <- mapM (repDataFamInstD . unLoc) adts 517 ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds) 518 ; rOver <- repOverlap (fmap unLoc overlap) 519 ; decls2 <- repInst rOver cxt1 inst_ty1 decls1 520 ; wrapGenSyms ss decls2 } 521 where 522 (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty 523repClsInstD (XClsInstDecl nec) = noExtCon nec 524 525repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) 526repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat 527 , deriv_type = ty })) 528 = do { dec <- addSimpleTyVarBinds tvs $ 529 do { cxt' <- repLContext cxt 530 ; strat' <- repDerivStrategy strat 531 ; inst_ty' <- repLTy inst_ty 532 ; repDeriv strat' cxt' inst_ty' } 533 ; return (loc, dec) } 534 where 535 (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) 536repStandaloneDerivD _ = panic "repStandaloneDerivD" 537 538repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) 539repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) 540 = do { eqn1 <- repTyFamEqn eqn 541 ; repTySynInst eqn1 } 542 543repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) 544repTyFamEqn (HsIB { hsib_ext = var_names 545 , hsib_body = FamEqn { feqn_tycon = tc_name 546 , feqn_bndrs = mb_bndrs 547 , feqn_pats = tys 548 , feqn_fixity = fixity 549 , feqn_rhs = rhs }}) 550 = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] 551 ; let hs_tvs = HsQTvs { hsq_ext = var_names 552 , hsq_explicit = fromMaybe [] mb_bndrs } 553 ; addTyClTyVarBinds hs_tvs $ \ _ -> 554 do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName 555 repTyVarBndr 556 mb_bndrs 557 ; tys1 <- case fixity of 558 Prefix -> repTyArgs (repNamedTyCon tc) tys 559 Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys 560 ; t1' <- repLTy t1 561 ; t2' <- repLTy t2 562 ; repTyArgs (repTInfix t1' tc t2') args } 563 ; rhs1 <- repLTy rhs 564 ; repTySynEqn mb_bndrs1 tys1 rhs1 } } 565 where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn] 566 checkTys tys@(HsValArg _:HsValArg _:_) = return tys 567 checkTys _ = panic "repTyFamEqn:checkTys" 568repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec 569repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec 570 571repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ) 572repTyArgs f [] = f 573repTyArgs f (HsValArg ty : as) = do { f' <- f 574 ; ty' <- repLTy ty 575 ; repTyArgs (repTapp f' ty') as } 576repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f 577 ; ki' <- repLTy ki 578 ; repTyArgs (repTappKind f' ki') as } 579repTyArgs f (HsArgPar _ : as) = repTyArgs f as 580 581repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ) 582repDataFamInstD (DataFamInstDecl { dfid_eqn = 583 (HsIB { hsib_ext = var_names 584 , hsib_body = FamEqn { feqn_tycon = tc_name 585 , feqn_bndrs = mb_bndrs 586 , feqn_pats = tys 587 , feqn_fixity = fixity 588 , feqn_rhs = defn }})}) 589 = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] 590 ; let hs_tvs = HsQTvs { hsq_ext = var_names 591 , hsq_explicit = fromMaybe [] mb_bndrs } 592 ; addTyClTyVarBinds hs_tvs $ \ _ -> 593 do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName 594 repTyVarBndr 595 mb_bndrs 596 ; tys1 <- case fixity of 597 Prefix -> repTyArgs (repNamedTyCon tc) tys 598 Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys 599 ; t1' <- repLTy t1 600 ; t2' <- repLTy t2 601 ; repTyArgs (repTInfix t1' tc t2') args } 602 ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } } 603 604 where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn] 605 checkTys tys@(HsValArg _: HsValArg _: _) = return tys 606 checkTys _ = panic "repDataFamInstD:checkTys" 607 608repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec)) 609 = noExtCon nec 610repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec))) 611 = noExtCon nec 612 613repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ) 614repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ 615 , fd_fi = CImport (dL->L _ cc) 616 (dL->L _ s) mch cis _ })) 617 = do MkC name' <- lookupLOcc name 618 MkC typ' <- repHsSigType typ 619 MkC cc' <- repCCallConv cc 620 MkC s' <- repSafety s 621 cis' <- conv_cimportspec cis 622 MkC str <- coreStringLit (static ++ chStr ++ cis') 623 dec <- rep2 forImpDName [cc', s', str, name', typ'] 624 return (loc, dec) 625 where 626 conv_cimportspec (CLabel cls) 627 = notHandled "Foreign label" (doubleQuotes (ppr cls)) 628 conv_cimportspec (CFunction DynamicTarget) = return "dynamic" 629 conv_cimportspec (CFunction (StaticTarget _ fs _ True)) 630 = return (unpackFS fs) 631 conv_cimportspec (CFunction (StaticTarget _ _ _ False)) 632 = panic "conv_cimportspec: values not supported yet" 633 conv_cimportspec CWrapper = return "wrapper" 634 -- these calling conventions do not support headers and the static keyword 635 raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv 636 static = case cis of 637 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static " 638 _ -> "" 639 chStr = case mch of 640 Just (Header _ h) | not raw_cconv -> unpackFS h ++ " " 641 _ -> "" 642repForD decl = notHandled "Foreign declaration" (ppr decl) 643 644repCCallConv :: CCallConv -> DsM (Core TH.Callconv) 645repCCallConv CCallConv = rep2 cCallName [] 646repCCallConv StdCallConv = rep2 stdCallName [] 647repCCallConv CApiConv = rep2 cApiCallName [] 648repCCallConv PrimCallConv = rep2 primCallName [] 649repCCallConv JavaScriptCallConv = rep2 javaScriptCallName [] 650 651repSafety :: Safety -> DsM (Core TH.Safety) 652repSafety PlayRisky = rep2 unsafeName [] 653repSafety PlayInterruptible = rep2 interruptibleName [] 654repSafety PlaySafe = rep2 safeName [] 655 656repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] 657repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir))) 658 = do { MkC prec' <- coreIntLit prec 659 ; let rep_fn = case dir of 660 InfixL -> infixLDName 661 InfixR -> infixRDName 662 InfixN -> infixNDName 663 ; let do_one name 664 = do { MkC name' <- lookupLOcc name 665 ; dec <- rep2 rep_fn [prec', name'] 666 ; return (loc,dec) } 667 ; mapM do_one names } 668repFixD _ = panic "repFixD" 669 670repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) 671repRuleD (dL->L loc (HsRule { rd_name = n 672 , rd_act = act 673 , rd_tyvs = ty_bndrs 674 , rd_tmvs = tm_bndrs 675 , rd_lhs = lhs 676 , rd_rhs = rhs })) 677 = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> 678 do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs 679 ; ss <- mkGenSyms tm_bndr_names 680 ; rule <- addBinds ss $ 681 do { ty_bndrs' <- case ty_bndrs of 682 Nothing -> coreNothingList tyVarBndrQTyConName 683 Just _ -> coreJustList tyVarBndrQTyConName 684 ex_bndrs 685 ; tm_bndrs' <- repList ruleBndrQTyConName 686 repRuleBndr 687 tm_bndrs 688 ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n 689 ; act' <- repPhases act 690 ; lhs' <- repLE lhs 691 ; rhs' <- repLE rhs 692 ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' } 693 ; wrapGenSyms ss rule } 694 ; return (loc, rule) } 695repRuleD _ = panic "repRuleD" 696 697ruleBndrNames :: LRuleBndr GhcRn -> [Name] 698ruleBndrNames (dL->L _ (RuleBndr _ n)) = [unLoc n] 699ruleBndrNames (dL->L _ (RuleBndrSig _ n sig)) 700 | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig 701 = unLoc n : vars 702ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _)))) 703 = panic "ruleBndrNames" 704ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _))) 705 = panic "ruleBndrNames" 706ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec 707ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884 708 709repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ) 710repRuleBndr (dL->L _ (RuleBndr _ n)) 711 = do { MkC n' <- lookupLBinder n 712 ; rep2 ruleVarName [n'] } 713repRuleBndr (dL->L _ (RuleBndrSig _ n sig)) 714 = do { MkC n' <- lookupLBinder n 715 ; MkC ty' <- repLTy (hsSigWcType sig) 716 ; rep2 typedRuleVarName [n', ty'] } 717repRuleBndr _ = panic "repRuleBndr" 718 719repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) 720repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp))) 721 = do { target <- repAnnProv ann_prov 722 ; exp' <- repE exp 723 ; dec <- repPragAnn target exp' 724 ; return (loc, dec) } 725repAnnD _ = panic "repAnnD" 726 727repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) 728repAnnProv (ValueAnnProvenance (dL->L _ n)) 729 = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level 730 ; rep2 valueAnnotationName [ n' ] } 731repAnnProv (TypeAnnProvenance (dL->L _ n)) 732 = do { MkC n' <- globalVar n 733 ; rep2 typeAnnotationName [ n' ] } 734repAnnProv ModuleAnnProvenance 735 = rep2 moduleAnnotationName [] 736 737------------------------------------------------------- 738-- Constructors 739------------------------------------------------------- 740 741repC :: LConDecl GhcRn -> DsM (Core TH.ConQ) 742repC (dL->L _ (ConDeclH98 { con_name = con 743 , con_forall = (dL->L _ False) 744 , con_mb_cxt = Nothing 745 , con_args = args })) 746 = repDataCon con args 747 748repC (dL->L _ (ConDeclH98 { con_name = con 749 , con_forall = (dL->L _ is_existential) 750 , con_ex_tvs = con_tvs 751 , con_mb_cxt = mcxt 752 , con_args = args })) 753 = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> 754 do { c' <- repDataCon con args 755 ; ctxt' <- repMbContext mcxt 756 ; if not is_existential && isNothing mcxt 757 then return c' 758 else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) 759 } 760 } 761 762repC (dL->L _ (ConDeclGADT { con_names = cons 763 , con_qvars = qtvs 764 , con_mb_cxt = mcxt 765 , con_args = args 766 , con_res_ty = res_ty })) 767 | isEmptyLHsQTvs qtvs -- No implicit or explicit variables 768 , Nothing <- mcxt -- No context 769 -- ==> no need for a forall 770 = repGadtDataCons cons args res_ty 771 772 | otherwise 773 = addTyVarBinds qtvs $ \ ex_bndrs -> 774 -- See Note [Don't quantify implicit type variables in quotes] 775 do { c' <- repGadtDataCons cons args res_ty 776 ; ctxt' <- repMbContext mcxt 777 ; if null (hsQTvExplicit qtvs) && isNothing mcxt 778 then return c' 779 else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } 780 781repC _ = panic "repC" 782 783 784repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ) 785repMbContext Nothing = repContext [] 786repMbContext (Just (dL->L _ cxt)) = repContext cxt 787 788repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ) 789repSrcUnpackedness SrcUnpack = rep2 sourceUnpackName [] 790repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName [] 791repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName [] 792 793repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ) 794repSrcStrictness SrcLazy = rep2 sourceLazyName [] 795repSrcStrictness SrcStrict = rep2 sourceStrictName [] 796repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName [] 797 798repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ)) 799repBangTy ty = do 800 MkC u <- repSrcUnpackedness su' 801 MkC s <- repSrcStrictness ss' 802 MkC b <- rep2 bangName [u, s] 803 MkC t <- repLTy ty' 804 rep2 bangTypeName [b, t] 805 where 806 (su', ss', ty') = case unLoc ty of 807 HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty) 808 _ -> (NoSrcUnpack, NoSrcStrict, ty) 809 810------------------------------------------------------- 811-- Deriving clauses 812------------------------------------------------------- 813 814repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ]) 815repDerivs (dL->L _ clauses) 816 = repList derivClauseQTyConName repDerivClause clauses 817 818repDerivClause :: LHsDerivingClause GhcRn 819 -> DsM (Core TH.DerivClauseQ) 820repDerivClause (dL->L _ (HsDerivingClause 821 { deriv_clause_strategy = dcs 822 , deriv_clause_tys = (dL->L _ dct) })) 823 = do MkC dcs' <- repDerivStrategy dcs 824 MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct 825 rep2 derivClauseName [dcs',dct'] 826 where 827 rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ) 828 rep_deriv_ty ty = repLTy ty 829repDerivClause _ = panic "repDerivClause" 830 831rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn 832 -> DsM ([GenSymBind], [Core TH.DecQ]) 833-- Represent signatures and methods in class/instance declarations. 834-- See Note [Scoped type variables in class and instance declarations] 835-- 836-- Why not use 'repBinds': we have already created symbols for methods in 837-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate 838-- these fun_id via 'collectHsValBinders decs', which would lead to the 839-- instance declarations failing in TH. 840rep_sigs_binds sigs binds 841 = do { let tvs = concatMap get_scoped_tvs sigs 842 ; ss <- mkGenSyms tvs 843 ; sigs1 <- addBinds ss $ rep_sigs sigs 844 ; binds1 <- addBinds ss $ rep_binds binds 845 ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) } 846 847------------------------------------------------------- 848-- Signatures in a class decl, or a group of bindings 849------------------------------------------------------- 850 851rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)] 852 -- We silently ignore ones we don't recognise 853rep_sigs = concatMapM rep_sig 854 855rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] 856rep_sig (dL->L loc (TypeSig _ nms ty)) 857 = mapM (rep_wc_ty_sig sigDName loc ty) nms 858rep_sig (dL->L loc (PatSynSig _ nms ty)) 859 = mapM (rep_patsyn_ty_sig loc ty) nms 860rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty)) 861 | is_deflt = mapM (rep_ty_sig defaultSigDName loc ty) nms 862 | otherwise = mapM (rep_ty_sig sigDName loc ty) nms 863rep_sig d@(dL->L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) 864rep_sig (dL->L _ (FixSig {})) = return [] -- fixity sigs at top level 865rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc 866rep_sig (dL->L loc (SpecSig _ nm tys ispec)) 867 = concatMapM (\t -> rep_specialise nm t ispec loc) tys 868rep_sig (dL->L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty loc 869rep_sig (dL->L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty 870rep_sig (dL->L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty 871rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty)) 872 = rep_complete_sig cls mty loc 873rep_sig _ = panic "rep_sig" 874 875rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name 876 -> DsM (SrcSpan, Core TH.DecQ) 877-- Don't create the implicit and explicit variables when desugaring signatures, 878-- see Note [Scoped type variables in class and instance declarations]. 879-- and Note [Don't quantify implicit type variables in quotes] 880rep_ty_sig mk_sig loc sig_ty nm 881 | HsIB { hsib_body = hs_ty } <- sig_ty 882 , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty 883 = do { nm1 <- lookupLOcc nm 884 ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) 885 ; repTyVarBndrWithKind tv name } 886 ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv 887 explicit_tvs 888 889 -- NB: Don't pass any implicit type variables to repList above 890 -- See Note [Don't quantify implicit type variables in quotes] 891 892 ; th_ctxt <- repLContext ctxt 893 ; th_ty <- repLTy ty 894 ; ty1 <- if null explicit_tvs && null (unLoc ctxt) 895 then return th_ty 896 else repTForall th_explicit_tvs th_ctxt th_ty 897 ; sig <- repProto mk_sig nm1 ty1 898 ; return (loc, sig) } 899rep_ty_sig _ _ (XHsImplicitBndrs nec) _ = noExtCon nec 900 901rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name 902 -> DsM (SrcSpan, Core TH.DecQ) 903-- represents a pattern synonym type signature; 904-- see Note [Pattern synonym type signatures and Template Haskell] in Convert 905-- 906-- Don't create the implicit and explicit variables when desugaring signatures, 907-- see Note [Scoped type variables in class and instance declarations] 908-- and Note [Don't quantify implicit type variables in quotes] 909rep_patsyn_ty_sig loc sig_ty nm 910 | HsIB { hsib_body = hs_ty } <- sig_ty 911 , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty 912 = do { nm1 <- lookupLOcc nm 913 ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) 914 ; repTyVarBndrWithKind tv name } 915 ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs 916 ; th_exis <- repList tyVarBndrQTyConName rep_in_scope_tv exis 917 918 -- NB: Don't pass any implicit type variables to repList above 919 -- See Note [Don't quantify implicit type variables in quotes] 920 921 ; th_reqs <- repLContext reqs 922 ; th_provs <- repLContext provs 923 ; th_ty <- repLTy ty 924 ; ty1 <- repTForall th_univs th_reqs =<< 925 repTForall th_exis th_provs th_ty 926 ; sig <- repProto patSynSigDName nm1 ty1 927 ; return (loc, sig) } 928rep_patsyn_ty_sig _ (XHsImplicitBndrs nec) _ = noExtCon nec 929 930rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name 931 -> DsM (SrcSpan, Core TH.DecQ) 932rep_wc_ty_sig mk_sig loc sig_ty nm 933 = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm 934 935rep_inline :: Located Name 936 -> InlinePragma -- Never defaultInlinePragma 937 -> SrcSpan 938 -> DsM [(SrcSpan, Core TH.DecQ)] 939rep_inline nm ispec loc 940 = do { nm1 <- lookupLOcc nm 941 ; inline <- repInline $ inl_inline ispec 942 ; rm <- repRuleMatch $ inl_rule ispec 943 ; phases <- repPhases $ inl_act ispec 944 ; pragma <- repPragInl nm1 inline rm phases 945 ; return [(loc, pragma)] 946 } 947 948rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma 949 -> SrcSpan 950 -> DsM [(SrcSpan, Core TH.DecQ)] 951rep_specialise nm ty ispec loc 952 = do { nm1 <- lookupLOcc nm 953 ; ty1 <- repHsSigType ty 954 ; phases <- repPhases $ inl_act ispec 955 ; let inline = inl_inline ispec 956 ; pragma <- if noUserInlineSpec inline 957 then -- SPECIALISE 958 repPragSpec nm1 ty1 phases 959 else -- SPECIALISE INLINE 960 do { inline1 <- repInline inline 961 ; repPragSpecInl nm1 ty1 inline1 phases } 962 ; return [(loc, pragma)] 963 } 964 965rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan 966 -> DsM [(SrcSpan, Core TH.DecQ)] 967rep_specialiseInst ty loc 968 = do { ty1 <- repHsSigType ty 969 ; pragma <- repPragSpecInst ty1 970 ; return [(loc, pragma)] } 971 972repInline :: InlineSpec -> DsM (Core TH.Inline) 973repInline NoInline = dataCon noInlineDataConName 974repInline Inline = dataCon inlineDataConName 975repInline Inlinable = dataCon inlinableDataConName 976repInline spec = notHandled "repInline" (ppr spec) 977 978repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch) 979repRuleMatch ConLike = dataCon conLikeDataConName 980repRuleMatch FunLike = dataCon funLikeDataConName 981 982repPhases :: Activation -> DsM (Core TH.Phases) 983repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i 984 ; dataCon' beforePhaseDataConName [arg] } 985repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i 986 ; dataCon' fromPhaseDataConName [arg] } 987repPhases _ = dataCon allPhasesDataConName 988 989rep_complete_sig :: Located [Located Name] 990 -> Maybe (Located Name) 991 -> SrcSpan 992 -> DsM [(SrcSpan, Core TH.DecQ)] 993rep_complete_sig (dL->L _ cls) mty loc 994 = do { mty' <- repMaybe nameTyConName lookupLOcc mty 995 ; cls' <- repList nameTyConName lookupLOcc cls 996 ; sig <- repPragComplete cls' mty' 997 ; return [(loc, sig)] } 998 999------------------------------------------------------- 1000-- Types 1001------------------------------------------------------- 1002 1003addSimpleTyVarBinds :: [Name] -- the binders to be added 1004 -> DsM (Core (TH.Q a)) -- action in the ext env 1005 -> DsM (Core (TH.Q a)) 1006addSimpleTyVarBinds names thing_inside 1007 = do { fresh_names <- mkGenSyms names 1008 ; term <- addBinds fresh_names thing_inside 1009 ; wrapGenSyms fresh_names term } 1010 1011addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added 1012 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env 1013 -> DsM (Core (TH.Q a)) 1014addHsTyVarBinds exp_tvs thing_inside 1015 = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs) 1016 ; term <- addBinds fresh_exp_names $ 1017 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr 1018 (exp_tvs `zip` fresh_exp_names) 1019 ; thing_inside kbs } 1020 ; wrapGenSyms fresh_exp_names term } 1021 where 1022 mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) 1023 1024addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added 1025 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) -- action in the ext env 1026 -> DsM (Core (TH.Q a)) 1027-- gensym a list of type variables and enter them into the meta environment; 1028-- the computations passed as the second argument is executed in that extended 1029-- meta environment and gets the *new* names on Core-level as an argument 1030addTyVarBinds (HsQTvs { hsq_ext = imp_tvs 1031 , hsq_explicit = exp_tvs }) 1032 thing_inside 1033 = addSimpleTyVarBinds imp_tvs $ 1034 addHsTyVarBinds exp_tvs $ 1035 thing_inside 1036addTyVarBinds (XLHsQTyVars nec) _ = noExtCon nec 1037 1038addTyClTyVarBinds :: LHsQTyVars GhcRn 1039 -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a))) 1040 -> DsM (Core (TH.Q a)) 1041 1042-- Used for data/newtype declarations, and family instances, 1043-- so that the nested type variables work right 1044-- instance C (T a) where 1045-- type W (T a) = blah 1046-- The 'a' in the type instance is the one bound by the instance decl 1047addTyClTyVarBinds tvs m 1048 = do { let tv_names = hsAllLTyVarNames tvs 1049 ; env <- dsGetMetaEnv 1050 ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) 1051 -- Make fresh names for the ones that are not already in scope 1052 -- This makes things work for family declarations 1053 1054 ; term <- addBinds freshNames $ 1055 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr 1056 (hsQTvExplicit tvs) 1057 ; m kbs } 1058 1059 ; wrapGenSyms freshNames term } 1060 where 1061 mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) 1062 mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) 1063 ; repTyVarBndrWithKind tv v } 1064 1065-- Produce kinded binder constructors from the Haskell tyvar binders 1066-- 1067repTyVarBndrWithKind :: LHsTyVarBndr GhcRn 1068 -> Core TH.Name -> DsM (Core TH.TyVarBndrQ) 1069repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm 1070 = repPlainTV nm 1071repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm 1072 = repLTy ki >>= repKindedTV nm 1073repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind" 1074 1075-- | Represent a type variable binder 1076repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ) 1077repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) ) 1078 = do { nm' <- lookupBinder nm 1079 ; repPlainTV nm' } 1080repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki)) 1081 = do { nm' <- lookupBinder nm 1082 ; ki' <- repLTy ki 1083 ; repKindedTV nm' ki' } 1084repTyVarBndr _ = panic "repTyVarBndr" 1085 1086-- represent a type context 1087-- 1088repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ) 1089repLContext ctxt = repContext (unLoc ctxt) 1090 1091repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ) 1092repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt 1093 repCtxt preds 1094 1095repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ) 1096repHsSigType (HsIB { hsib_ext = implicit_tvs 1097 , hsib_body = body }) 1098 | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body 1099 = addSimpleTyVarBinds implicit_tvs $ 1100 -- See Note [Don't quantify implicit type variables in quotes] 1101 addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs -> 1102 do { th_ctxt <- repLContext ctxt 1103 ; th_ty <- repLTy ty 1104 ; if null explicit_tvs && null (unLoc ctxt) 1105 then return th_ty 1106 else repTForall th_explicit_tvs th_ctxt th_ty } 1107repHsSigType (XHsImplicitBndrs nec) = noExtCon nec 1108 1109repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ) 1110repHsSigWcType (HsWC { hswc_body = sig1 }) 1111 = repHsSigType sig1 1112repHsSigWcType (XHsWildCardBndrs nec) = noExtCon nec 1113 1114-- yield the representation of a list of types 1115repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ] 1116repLTys tys = mapM repLTy tys 1117 1118-- represent a type 1119repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ) 1120repLTy ty = repTy (unLoc ty) 1121 1122-- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or 1123-- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax. 1124-- In other words, the argument to this function is always an 1125-- @HsForAllTy ForallInvis@ or @HsQualTy@. 1126-- Types headed by visible foralls (which are desugared to ForallVisT) are 1127-- handled separately in repTy. 1128repForallT :: HsType GhcRn -> DsM (Core TH.TypeQ) 1129repForallT ty 1130 | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty) 1131 = addHsTyVarBinds tvs $ \bndrs -> 1132 do { ctxt1 <- repLContext ctxt 1133 ; tau1 <- repLTy tau 1134 ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...} 1135 } 1136 1137repTy :: HsType GhcRn -> DsM (Core TH.TypeQ) 1138repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) = 1139 case fvf of 1140 ForallInvis -> repForallT ty 1141 ForallVis -> addHsTyVarBinds tvs $ \bndrs -> 1142 do body1 <- repLTy body 1143 repTForallVis bndrs body1 1144repTy ty@(HsQualTy {}) = repForallT ty 1145 1146repTy (HsTyVar _ _ (dL->L _ n)) 1147 | isLiftedTypeKindTyConName n = repTStar 1148 | n `hasKey` constraintKindTyConKey = repTConstraint 1149 | n `hasKey` funTyConKey = repArrowTyCon 1150 | isTvOcc occ = do tv1 <- lookupOcc n 1151 repTvar tv1 1152 | isDataOcc occ = do tc1 <- lookupOcc n 1153 repPromotedDataCon tc1 1154 | n == eqTyConName = repTequality 1155 | otherwise = do tc1 <- lookupOcc n 1156 repNamedTyCon tc1 1157 where 1158 occ = nameOccName n 1159 1160repTy (HsAppTy _ f a) = do 1161 f1 <- repLTy f 1162 a1 <- repLTy a 1163 repTapp f1 a1 1164repTy (HsAppKindTy _ ty ki) = do 1165 ty1 <- repLTy ty 1166 ki1 <- repLTy ki 1167 repTappKind ty1 ki1 1168repTy (HsFunTy _ f a) = do 1169 f1 <- repLTy f 1170 a1 <- repLTy a 1171 tcon <- repArrowTyCon 1172 repTapps tcon [f1, a1] 1173repTy (HsListTy _ t) = do 1174 t1 <- repLTy t 1175 tcon <- repListTyCon 1176 repTapp tcon t1 1177repTy (HsTupleTy _ HsUnboxedTuple tys) = do 1178 tys1 <- repLTys tys 1179 tcon <- repUnboxedTupleTyCon (length tys) 1180 repTapps tcon tys1 1181repTy (HsTupleTy _ _ tys) = do tys1 <- repLTys tys 1182 tcon <- repTupleTyCon (length tys) 1183 repTapps tcon tys1 1184repTy (HsSumTy _ tys) = do tys1 <- repLTys tys 1185 tcon <- repUnboxedSumTyCon (length tys) 1186 repTapps tcon tys1 1187repTy (HsOpTy _ ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) 1188 `nlHsAppTy` ty2) 1189repTy (HsParTy _ t) = repLTy t 1190repTy (HsStarTy _ _) = repTStar 1191repTy (HsKindSig _ t k) = do 1192 t1 <- repLTy t 1193 k1 <- repLTy k 1194 repTSig t1 k1 1195repTy (HsSpliceTy _ splice) = repSplice splice 1196repTy (HsExplicitListTy _ _ tys) = do 1197 tys1 <- repLTys tys 1198 repTPromotedList tys1 1199repTy (HsExplicitTupleTy _ tys) = do 1200 tys1 <- repLTys tys 1201 tcon <- repPromotedTupleTyCon (length tys) 1202 repTapps tcon tys1 1203repTy (HsTyLit _ lit) = do 1204 lit' <- repTyLit lit 1205 repTLit lit' 1206repTy (HsWildCardTy _) = repTWildCard 1207repTy (HsIParamTy _ n t) = do 1208 n' <- rep_implicit_param_name (unLoc n) 1209 t' <- repLTy t 1210 repTImplicitParam n' t' 1211 1212repTy ty = notHandled "Exotic form of type" (ppr ty) 1213 1214repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ) 1215repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i 1216 rep2 numTyLitName [iExpr] 1217repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s 1218 ; rep2 strTyLitName [s'] 1219 } 1220 1221-- | Represent a type wrapped in a Maybe 1222repMaybeLTy :: Maybe (LHsKind GhcRn) 1223 -> DsM (Core (Maybe TH.TypeQ)) 1224repMaybeLTy = repMaybe kindQTyConName repLTy 1225 1226repRole :: Located (Maybe Role) -> DsM (Core TH.Role) 1227repRole (dL->L _ (Just Nominal)) = rep2 nominalRName [] 1228repRole (dL->L _ (Just Representational)) = rep2 representationalRName [] 1229repRole (dL->L _ (Just Phantom)) = rep2 phantomRName [] 1230repRole (dL->L _ Nothing) = rep2 inferRName [] 1231repRole _ = panic "repRole: Impossible Match" -- due to #15884 1232 1233----------------------------------------------------------------------------- 1234-- Splices 1235----------------------------------------------------------------------------- 1236 1237repSplice :: HsSplice GhcRn -> DsM (Core a) 1238-- See Note [How brackets and nested splices are handled] in TcSplice 1239-- We return a CoreExpr of any old type; the context should know 1240repSplice (HsTypedSplice _ _ n _) = rep_splice n 1241repSplice (HsUntypedSplice _ _ n _) = rep_splice n 1242repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n 1243repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) 1244repSplice e@(HsSplicedT {}) = pprPanic "repSpliceT" (ppr e) 1245repSplice (XSplice nec) = noExtCon nec 1246 1247rep_splice :: Name -> DsM (Core a) 1248rep_splice splice_name 1249 = do { mb_val <- dsLookupMetaEnv splice_name 1250 ; case mb_val of 1251 Just (DsSplice e) -> do { e' <- dsExpr e 1252 ; return (MkC e') } 1253 _ -> pprPanic "HsSplice" (ppr splice_name) } 1254 -- Should not happen; statically checked 1255 1256----------------------------------------------------------------------------- 1257-- Expressions 1258----------------------------------------------------------------------------- 1259 1260repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ]) 1261repLEs es = repList expQTyConName repLE es 1262 1263-- FIXME: some of these panics should be converted into proper error messages 1264-- unless we can make sure that constructs, which are plainly not 1265-- supported in TH already lead to error messages at an earlier stage 1266repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ) 1267repLE (dL->L loc e) = putSrcSpanDs loc (repE e) 1268 1269repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ) 1270repE (HsVar _ (dL->L _ x)) = 1271 do { mb_val <- dsLookupMetaEnv x 1272 ; case mb_val of 1273 Nothing -> do { str <- globalVar x 1274 ; repVarOrCon x str } 1275 Just (DsBound y) -> repVarOrCon x (coreVar y) 1276 Just (DsSplice e) -> do { e' <- dsExpr e 1277 ; return (MkC e') } } 1278repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar 1279repE (HsOverLabel _ _ s) = repOverLabel s 1280 1281repE e@(HsRecFld _ f) = case f of 1282 Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) 1283 Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) 1284 XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e) 1285 1286 -- Remember, we're desugaring renamer output here, so 1287 -- HsOverlit can definitely occur 1288repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } 1289repE (HsLit _ l) = do { a <- repLiteral l; repLit a } 1290repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m 1291repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) })) 1292 = do { ms' <- mapM repMatchTup ms 1293 ; core_ms <- coreList matchQTyConName ms' 1294 ; repLamCase core_ms } 1295repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} 1296repE (HsAppType _ e t) = do { a <- repLE e 1297 ; s <- repLTy (hswc_body t) 1298 ; repAppType a s } 1299 1300repE (OpApp _ e1 op e2) = 1301 do { arg1 <- repLE e1; 1302 arg2 <- repLE e2; 1303 the_op <- repLE op ; 1304 repInfixApp arg1 the_op arg2 } 1305repE (NegApp _ x _) = do 1306 a <- repLE x 1307 negateVar <- lookupOcc negateName >>= repVar 1308 negateVar `repApp` a 1309repE (HsPar _ x) = repLE x 1310repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } 1311repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } 1312repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) })) 1313 = do { arg <- repLE e 1314 ; ms2 <- mapM repMatchTup ms 1315 ; core_ms2 <- coreList matchQTyConName ms2 1316 ; repCaseE arg core_ms2 } 1317repE (HsIf _ _ x y z) = do 1318 a <- repLE x 1319 b <- repLE y 1320 c <- repLE z 1321 repCond a b c 1322repE (HsMultiIf _ alts) 1323 = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts 1324 ; expr' <- repMultiIf (nonEmptyCoreList alts') 1325 ; wrapGenSyms (concat binds) expr' } 1326repE (HsLet _ (dL->L _ bs) e) = do { (ss,ds) <- repBinds bs 1327 ; e2 <- addBinds ss (repLE e) 1328 ; z <- repLetE ds e2 1329 ; wrapGenSyms ss z } 1330 1331-- FIXME: I haven't got the types here right yet 1332repE e@(HsDo _ ctxt (dL->L _ sts)) 1333 | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } 1334 = do { (ss,zs) <- repLSts sts; 1335 e' <- repDoE (nonEmptyCoreList zs); 1336 wrapGenSyms ss e' } 1337 1338 | ListComp <- ctxt 1339 = do { (ss,zs) <- repLSts sts; 1340 e' <- repComp (nonEmptyCoreList zs); 1341 wrapGenSyms ss e' } 1342 1343 | MDoExpr <- ctxt 1344 = do { (ss,zs) <- repLSts sts; 1345 e' <- repMDoE (nonEmptyCoreList zs); 1346 wrapGenSyms ss e' } 1347 1348 | otherwise 1349 = notHandled "monad comprehension and [: :]" (ppr e) 1350 1351repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } 1352repE (ExplicitTuple _ es boxity) = 1353 let tupArgToCoreExp :: LHsTupArg GhcRn -> DsM (Core (Maybe TH.ExpQ)) 1354 tupArgToCoreExp a 1355 | L _ (Present _ e) <- dL a = do { e' <- repLE e 1356 ; coreJust expQTyConName e' } 1357 | otherwise = coreNothing expQTyConName 1358 1359 in do { args <- mapM tupArgToCoreExp es 1360 ; expQTy <- lookupType expQTyConName 1361 ; let maybeExpQTy = mkTyConApp maybeTyCon [expQTy] 1362 listArg = coreList' maybeExpQTy args 1363 ; if isBoxed boxity 1364 then repTup listArg 1365 else repUnboxedTup listArg } 1366 1367repE (ExplicitSum _ alt arity e) 1368 = do { e1 <- repLE e 1369 ; repUnboxedSum e1 alt arity } 1370 1371repE (RecordCon { rcon_con_name = c, rcon_flds = flds }) 1372 = do { x <- lookupLOcc c; 1373 fs <- repFields flds; 1374 repRecCon x fs } 1375repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) 1376 = do { x <- repLE e; 1377 fs <- repUpdFields flds; 1378 repRecUpd x fs } 1379 1380repE (ExprWithTySig _ e ty) 1381 = do { e1 <- repLE e 1382 ; t1 <- repHsSigWcType ty 1383 ; repSigExp e1 t1 } 1384 1385repE (ArithSeq _ _ aseq) = 1386 case aseq of 1387 From e -> do { ds1 <- repLE e; repFrom ds1 } 1388 FromThen e1 e2 -> do 1389 ds1 <- repLE e1 1390 ds2 <- repLE e2 1391 repFromThen ds1 ds2 1392 FromTo e1 e2 -> do 1393 ds1 <- repLE e1 1394 ds2 <- repLE e2 1395 repFromTo ds1 ds2 1396 FromThenTo e1 e2 e3 -> do 1397 ds1 <- repLE e1 1398 ds2 <- repLE e2 1399 ds3 <- repLE e3 1400 repFromThenTo ds1 ds2 ds3 1401 1402repE (HsSpliceE _ splice) = repSplice splice 1403repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC 1404repE (HsUnboundVar _ uv) = do 1405 occ <- occNameLit (unboundVarOcc uv) 1406 sname <- repNameS occ 1407 repUnboundVar sname 1408 1409repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) 1410repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) 1411repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) 1412repE e = notHandled "Expression form" (ppr e) 1413 1414----------------------------------------------------------------------------- 1415-- Building representations of auxillary structures like Match, Clause, Stmt, 1416 1417repMatchTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ) 1418repMatchTup (dL->L _ (Match { m_pats = [p] 1419 , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = 1420 do { ss1 <- mkGenSyms (collectPatBinders p) 1421 ; addBinds ss1 $ do { 1422 ; p1 <- repLP p 1423 ; (ss2,ds) <- repBinds wheres 1424 ; addBinds ss2 $ do { 1425 ; gs <- repGuards guards 1426 ; match <- repMatch p1 gs ds 1427 ; wrapGenSyms (ss1++ss2) match }}} 1428repMatchTup _ = panic "repMatchTup: case alt with more than one arg" 1429 1430repClauseTup :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ) 1431repClauseTup (dL->L _ (Match { m_pats = ps 1432 , m_grhss = GRHSs _ guards (dL->L _ wheres) })) = 1433 do { ss1 <- mkGenSyms (collectPatsBinders ps) 1434 ; addBinds ss1 $ do { 1435 ps1 <- repLPs ps 1436 ; (ss2,ds) <- repBinds wheres 1437 ; addBinds ss2 $ do { 1438 gs <- repGuards guards 1439 ; clause <- repClause ps1 gs ds 1440 ; wrapGenSyms (ss1++ss2) clause }}} 1441repClauseTup (dL->L _ (Match _ _ _ (XGRHSs nec))) = noExtCon nec 1442repClauseTup _ = panic "repClauseTup" 1443 1444repGuards :: [LGRHS GhcRn (LHsExpr GhcRn)] -> DsM (Core TH.BodyQ) 1445repGuards [dL->L _ (GRHS _ [] e)] 1446 = do {a <- repLE e; repNormal a } 1447repGuards other 1448 = do { zs <- mapM repLGRHS other 1449 ; let (xs, ys) = unzip zs 1450 ; gd <- repGuarded (nonEmptyCoreList ys) 1451 ; wrapGenSyms (concat xs) gd } 1452 1453repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn) 1454 -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) 1455repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2)) 1456 = do { guarded <- repLNormalGE e1 e2 1457 ; return ([], guarded) } 1458repLGRHS (dL->L _ (GRHS _ ss rhs)) 1459 = do { (gs, ss') <- repLSts ss 1460 ; rhs' <- addBinds gs $ repLE rhs 1461 ; guarded <- repPatGE (nonEmptyCoreList ss') rhs' 1462 ; return (gs, guarded) } 1463repLGRHS _ = panic "repLGRHS" 1464 1465repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp]) 1466repFields (HsRecFields { rec_flds = flds }) 1467 = repList fieldExpQTyConName rep_fld flds 1468 where 1469 rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn) 1470 -> DsM (Core (TH.Q TH.FieldExp)) 1471 rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld) 1472 ; e <- repLE (hsRecFieldArg fld) 1473 ; repFieldExp fn e } 1474 1475repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp]) 1476repUpdFields = repList fieldExpQTyConName rep_fld 1477 where 1478 rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp)) 1479 rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of 1480 Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name) 1481 ; e <- repLE (hsRecFieldArg fld) 1482 ; repFieldExp fn e } 1483 _ -> notHandled "Ambiguous record updates" (ppr fld) 1484 1485 1486 1487----------------------------------------------------------------------------- 1488-- Representing Stmt's is tricky, especially if bound variables 1489-- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] 1490-- First gensym new names for every variable in any of the patterns. 1491-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) 1492-- if variables didn't shaddow, the static gensym wouldn't be necessary 1493-- and we could reuse the original names (x and x). 1494-- 1495-- do { x'1 <- gensym "x" 1496-- ; x'2 <- gensym "x" 1497-- ; doE [ BindSt (pvar x'1) [| f 1 |] 1498-- , BindSt (pvar x'2) [| f x |] 1499-- , NoBindSt [| g x |] 1500-- ] 1501-- } 1502 1503-- The strategy is to translate a whole list of do-bindings by building a 1504-- bigger environment, and a bigger set of meta bindings 1505-- (like: x'1 <- gensym "x" ) and then combining these with the translations 1506-- of the expressions within the Do 1507 1508----------------------------------------------------------------------------- 1509-- The helper function repSts computes the translation of each sub expression 1510-- and a bunch of prefix bindings denoting the dynamic renaming. 1511 1512repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) 1513repLSts stmts = repSts (map unLoc stmts) 1514 1515repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ]) 1516repSts (BindStmt _ p e _ _ : ss) = 1517 do { e2 <- repLE e 1518 ; ss1 <- mkGenSyms (collectPatBinders p) 1519 ; addBinds ss1 $ do { 1520 ; p1 <- repLP p; 1521 ; (ss2,zs) <- repSts ss 1522 ; z <- repBindSt p1 e2 1523 ; return (ss1++ss2, z : zs) }} 1524repSts (LetStmt _ (dL->L _ bs) : ss) = 1525 do { (ss1,ds) <- repBinds bs 1526 ; z <- repLetSt ds 1527 ; (ss2,zs) <- addBinds ss1 (repSts ss) 1528 ; return (ss1++ss2, z : zs) } 1529repSts (BodyStmt _ e _ _ : ss) = 1530 do { e2 <- repLE e 1531 ; z <- repNoBindSt e2 1532 ; (ss2,zs) <- repSts ss 1533 ; return (ss2, z : zs) } 1534repSts (ParStmt _ stmt_blocks _ _ : ss) = 1535 do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks 1536 ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1 1537 ss1 = concat ss_s 1538 ; z <- repParSt stmt_blocks2 1539 ; (ss2, zs) <- addBinds ss1 (repSts ss) 1540 ; return (ss1++ss2, z : zs) } 1541 where 1542 rep_stmt_block :: ParStmtBlock GhcRn GhcRn 1543 -> DsM ([GenSymBind], Core [TH.StmtQ]) 1544 rep_stmt_block (ParStmtBlock _ stmts _ _) = 1545 do { (ss1, zs) <- repSts (map unLoc stmts) 1546 ; zs1 <- coreList stmtQTyConName zs 1547 ; return (ss1, zs1) } 1548 rep_stmt_block (XParStmtBlock nec) = noExtCon nec 1549repSts [LastStmt _ e _ _] 1550 = do { e2 <- repLE e 1551 ; z <- repNoBindSt e2 1552 ; return ([], [z]) } 1553repSts (stmt@RecStmt{} : ss) 1554 = do { let binders = collectLStmtsBinders (recS_stmts stmt) 1555 ; ss1 <- mkGenSyms binders 1556 -- Bring all of binders in the recursive group into scope for the 1557 -- whole group. 1558 ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt)) 1559 ; MASSERT(sort ss1 == sort ss1_other) 1560 ; z <- repRecSt (nonEmptyCoreList rss) 1561 ; (ss2,zs) <- addBinds ss1 (repSts ss) 1562 ; return (ss1++ss2, z : zs) } 1563repSts [] = return ([],[]) 1564repSts other = notHandled "Exotic statement" (ppr other) 1565 1566 1567----------------------------------------------------------- 1568-- Bindings 1569----------------------------------------------------------- 1570 1571repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ]) 1572repBinds (EmptyLocalBinds _) 1573 = do { core_list <- coreList decQTyConName [] 1574 ; return ([], core_list) } 1575 1576repBinds (HsIPBinds _ (IPBinds _ decs)) 1577 = do { ips <- mapM rep_implicit_param_bind decs 1578 ; core_list <- coreList decQTyConName 1579 (de_loc (sort_by_loc ips)) 1580 ; return ([], core_list) 1581 } 1582 1583repBinds b@(HsIPBinds _ XHsIPBinds {}) 1584 = notHandled "Implicit parameter binds extension" (ppr b) 1585 1586repBinds (HsValBinds _ decs) 1587 = do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs } 1588 -- No need to worry about detailed scopes within 1589 -- the binding group, because we are talking Names 1590 -- here, so we can safely treat it as a mutually 1591 -- recursive group 1592 -- For hsScopedTvBinders see Note [Scoped type variables in bindings] 1593 ; ss <- mkGenSyms bndrs 1594 ; prs <- addBinds ss (rep_val_binds decs) 1595 ; core_list <- coreList decQTyConName 1596 (de_loc (sort_by_loc prs)) 1597 ; return (ss, core_list) } 1598repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b) 1599 1600rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) 1601rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs))) 1602 = do { name <- case ename of 1603 Left (dL->L _ n) -> rep_implicit_param_name n 1604 Right _ -> 1605 panic "rep_implicit_param_bind: post typechecking" 1606 ; rhs' <- repE rhs 1607 ; ipb <- repImplicitParamBind name rhs' 1608 ; return (loc, ipb) } 1609rep_implicit_param_bind (dL->L _ b@(XIPBind _)) 1610 = notHandled "Implicit parameter bind extension" (ppr b) 1611rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match" 1612 -- due to #15884 1613 1614rep_implicit_param_name :: HsIPName -> DsM (Core String) 1615rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) 1616 1617rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] 1618-- Assumes: all the binders of the binding are already in the meta-env 1619rep_val_binds (XValBindsLR (NValBinds binds sigs)) 1620 = do { core1 <- rep_binds (unionManyBags (map snd binds)) 1621 ; core2 <- rep_sigs sigs 1622 ; return (core1 ++ core2) } 1623rep_val_binds (ValBinds _ _ _) 1624 = panic "rep_val_binds: ValBinds" 1625 1626rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)] 1627rep_binds = mapM rep_bind . bagToList 1628 1629rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ) 1630-- Assumes: all the binders of the binding are already in the meta-env 1631 1632-- Note GHC treats declarations of a variable (not a pattern) 1633-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match 1634-- with an empty list of patterns 1635rep_bind (dL->L loc (FunBind 1636 { fun_id = fn, 1637 fun_matches = MG { mg_alts 1638 = (dL->L _ [dL->L _ (Match 1639 { m_pats = [] 1640 , m_grhss = GRHSs _ guards 1641 (dL->L _ wheres) } 1642 )]) } })) 1643 = do { (ss,wherecore) <- repBinds wheres 1644 ; guardcore <- addBinds ss (repGuards guards) 1645 ; fn' <- lookupLBinder fn 1646 ; p <- repPvar fn' 1647 ; ans <- repVal p guardcore wherecore 1648 ; ans' <- wrapGenSyms ss ans 1649 ; return (loc, ans') } 1650 1651rep_bind (dL->L loc (FunBind { fun_id = fn 1652 , fun_matches = MG { mg_alts = (dL->L _ ms) } })) 1653 = do { ms1 <- mapM repClauseTup ms 1654 ; fn' <- lookupLBinder fn 1655 ; ans <- repFun fn' (nonEmptyCoreList ms1) 1656 ; return (loc, ans) } 1657 1658rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup nec })) = noExtCon nec 1659 1660rep_bind (dL->L loc (PatBind { pat_lhs = pat 1661 , pat_rhs = GRHSs _ guards (dL->L _ wheres) })) 1662 = do { patcore <- repLP pat 1663 ; (ss,wherecore) <- repBinds wheres 1664 ; guardcore <- addBinds ss (repGuards guards) 1665 ; ans <- repVal patcore guardcore wherecore 1666 ; ans' <- wrapGenSyms ss ans 1667 ; return (loc, ans') } 1668rep_bind (dL->L _ (PatBind _ _ (XGRHSs nec) _)) = noExtCon nec 1669 1670rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e})) 1671 = do { v' <- lookupBinder v 1672 ; e2 <- repLE e 1673 ; x <- repNormal e2 1674 ; patcore <- repPvar v' 1675 ; empty_decls <- coreList decQTyConName [] 1676 ; ans <- repVal patcore x empty_decls 1677 ; return (srcLocSpan (getSrcLoc v), ans) } 1678 1679rep_bind (dL->L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" 1680rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id = syn 1681 , psb_args = args 1682 , psb_def = pat 1683 , psb_dir = dir }))) 1684 = do { syn' <- lookupLBinder syn 1685 ; dir' <- repPatSynDir dir 1686 ; ss <- mkGenArgSyms args 1687 ; patSynD' <- addBinds ss ( 1688 do { args' <- repPatSynArgs args 1689 ; pat' <- repLP pat 1690 ; repPatSynD syn' args' dir' pat' }) 1691 ; patSynD'' <- wrapGenArgSyms args ss patSynD' 1692 ; return (loc, patSynD'') } 1693 where 1694 mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind] 1695 -- for Record Pattern Synonyms we want to conflate the selector 1696 -- and the pattern-only names in order to provide a nicer TH 1697 -- API. Whereas inside GHC, record pattern synonym selectors and 1698 -- their pattern-only bound right hand sides have different names, 1699 -- we want to treat them the same in TH. This is the reason why we 1700 -- need an adjusted mkGenArgSyms in the `RecCon` case below. 1701 mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args) 1702 mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2] 1703 mkGenArgSyms (RecCon fields) 1704 = do { let pats = map (unLoc . recordPatSynPatVar) fields 1705 sels = map (unLoc . recordPatSynSelectorId) fields 1706 ; ss <- mkGenSyms sels 1707 ; return $ replaceNames (zip sels pats) ss } 1708 1709 replaceNames selsPats genSyms 1710 = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats 1711 , sel == sel' ] 1712 1713 wrapGenArgSyms :: HsPatSynDetails (Located Name) 1714 -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ) 1715 wrapGenArgSyms (RecCon _) _ dec = return dec 1716 wrapGenArgSyms _ ss dec = wrapGenSyms ss dec 1717 1718rep_bind (dL->L _ (PatSynBind _ (XPatSynBind nec))) 1719 = noExtCon nec 1720rep_bind (dL->L _ (XHsBindsLR nec)) = noExtCon nec 1721rep_bind _ = panic "rep_bind: Impossible match!" 1722 -- due to #15884 1723 1724repPatSynD :: Core TH.Name 1725 -> Core TH.PatSynArgsQ 1726 -> Core TH.PatSynDirQ 1727 -> Core TH.PatQ 1728 -> DsM (Core TH.DecQ) 1729repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat) 1730 = rep2 patSynDName [syn, args, dir, pat] 1731 1732repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ) 1733repPatSynArgs (PrefixCon args) 1734 = do { args' <- repList nameTyConName lookupLOcc args 1735 ; repPrefixPatSynArgs args' } 1736repPatSynArgs (InfixCon arg1 arg2) 1737 = do { arg1' <- lookupLOcc arg1 1738 ; arg2' <- lookupLOcc arg2 1739 ; repInfixPatSynArgs arg1' arg2' } 1740repPatSynArgs (RecCon fields) 1741 = do { sels' <- repList nameTyConName lookupLOcc sels 1742 ; repRecordPatSynArgs sels' } 1743 where sels = map recordPatSynSelectorId fields 1744 1745repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ) 1746repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms] 1747 1748repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ) 1749repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2] 1750 1751repRecordPatSynArgs :: Core [TH.Name] 1752 -> DsM (Core TH.PatSynArgsQ) 1753repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels] 1754 1755repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ) 1756repPatSynDir Unidirectional = rep2 unidirPatSynName [] 1757repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName [] 1758repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) })) 1759 = do { clauses' <- mapM repClauseTup clauses 1760 ; repExplBidirPatSynDir (nonEmptyCoreList clauses') } 1761repPatSynDir (ExplicitBidirectional (XMatchGroup nec)) = noExtCon nec 1762 1763repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ) 1764repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls] 1765 1766 1767----------------------------------------------------------------------------- 1768-- Since everything in a Bind is mutually recursive we need rename all 1769-- all the variables simultaneously. For example: 1770-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to 1771-- do { f'1 <- gensym "f" 1772-- ; g'2 <- gensym "g" 1773-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, 1774-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} 1775-- ]} 1776-- This requires collecting the bindings (f'1 <- gensym "f"), and the 1777-- environment ( f |-> f'1 ) from each binding, and then unioning them 1778-- together. As we do this we collect GenSymBinds's which represent the renamed 1779-- variables bound by the Bindings. In order not to lose track of these 1780-- representations we build a shadow datatype MB with the same structure as 1781-- MonoBinds, but which has slots for the representations 1782 1783 1784----------------------------------------------------------------------------- 1785-- GHC allows a more general form of lambda abstraction than specified 1786-- by Haskell 98. In particular it allows guarded lambda's like : 1787-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in 1788-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like 1789-- (\ p1 .. pn -> exp) by causing an error. 1790 1791repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ) 1792repLambda (dL->L _ (Match { m_pats = ps 1793 , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)] 1794 (dL->L _ (EmptyLocalBinds _)) } )) 1795 = do { let bndrs = collectPatsBinders ps ; 1796 ; ss <- mkGenSyms bndrs 1797 ; lam <- addBinds ss ( 1798 do { xs <- repLPs ps; body <- repLE e; repLam xs body }) 1799 ; wrapGenSyms ss lam } 1800 1801repLambda (dL->L _ m) = notHandled "Guarded lambdas" (pprMatch m) 1802 1803 1804----------------------------------------------------------------------------- 1805-- Patterns 1806-- repP deals with patterns. It assumes that we have already 1807-- walked over the pattern(s) once to collect the binders, and 1808-- have extended the environment. So every pattern-bound 1809-- variable should already appear in the environment. 1810 1811-- Process a list of patterns 1812repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ]) 1813repLPs ps = repList patQTyConName repLP ps 1814 1815repLP :: LPat GhcRn -> DsM (Core TH.PatQ) 1816repLP p = repP (unLoc p) 1817 1818repP :: Pat GhcRn -> DsM (Core TH.PatQ) 1819repP (WildPat _) = repPwild 1820repP (LitPat _ l) = do { l2 <- repLiteral l; repPlit l2 } 1821repP (VarPat _ x) = do { x' <- lookupBinder (unLoc x); repPvar x' } 1822repP (LazyPat _ p) = do { p1 <- repLP p; repPtilde p1 } 1823repP (BangPat _ p) = do { p1 <- repLP p; repPbang p1 } 1824repP (AsPat _ x p) = do { x' <- lookupLBinder x; p1 <- repLP p 1825 ; repPaspat x' p1 } 1826repP (ParPat _ p) = repLP p 1827repP (ListPat Nothing ps) = do { qs <- repLPs ps; repPlist qs } 1828repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps) 1829 ; e' <- repE (syn_expr e) 1830 ; repPview e' p} 1831repP (TuplePat _ ps boxed) 1832 | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } 1833 | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } 1834repP (SumPat _ p alt arity) = do { p1 <- repLP p 1835 ; repPunboxedSum p1 alt arity } 1836repP (ConPatIn dc details) 1837 = do { con_str <- lookupLOcc dc 1838 ; case details of 1839 PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } 1840 RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec) 1841 ; repPrec con_str fps } 1842 InfixCon p1 p2 -> do { p1' <- repLP p1; 1843 p2' <- repLP p2; 1844 repPinfix p1' con_str p2' } 1845 } 1846 where 1847 rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ)) 1848 rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld) 1849 ; MkC p <- repLP (hsRecFieldArg fld) 1850 ; rep2 fieldPatName [v,p] } 1851 1852repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l 1853 ; repPlit a } 1854repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } 1855repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) 1856repP (SigPat _ p t) = do { p' <- repLP p 1857 ; t' <- repLTy (hsSigWcType t) 1858 ; repPsig p' t' } 1859repP (SplicePat _ splice) = repSplice splice 1860 1861repP other = notHandled "Exotic pattern" (ppr other) 1862 1863---------------------------------------------------------- 1864-- Declaration ordering helpers 1865 1866sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] 1867sort_by_loc xs = sortBy comp xs 1868 where comp x y = compare (fst x) (fst y) 1869 1870de_loc :: [(a, b)] -> [b] 1871de_loc = map snd 1872 1873---------------------------------------------------------- 1874-- The meta-environment 1875 1876-- A name/identifier association for fresh names of locally bound entities 1877type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id 1878 -- I.e. (x, x_id) means 1879 -- let x_id = gensym "x" in ... 1880 1881-- Generate a fresh name for a locally bound entity 1882 1883mkGenSyms :: [Name] -> DsM [GenSymBind] 1884-- We can use the existing name. For example: 1885-- [| \x_77 -> x_77 + x_77 |] 1886-- desugars to 1887-- do { x_77 <- genSym "x"; .... } 1888-- We use the same x_77 in the desugared program, but with the type Bndr 1889-- instead of Int 1890-- 1891-- We do make it an Internal name, though (hence localiseName) 1892-- 1893-- Nevertheless, it's monadic because we have to generate nameTy 1894mkGenSyms ns = do { var_ty <- lookupType nameTyConName 1895 ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] } 1896 1897 1898addBinds :: [GenSymBind] -> DsM a -> DsM a 1899-- Add a list of fresh names for locally bound entities to the 1900-- meta environment (which is part of the state carried around 1901-- by the desugarer monad) 1902addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m 1903 1904-- Look up a locally bound name 1905-- 1906lookupLBinder :: Located Name -> DsM (Core TH.Name) 1907lookupLBinder n = lookupBinder (unLoc n) 1908 1909lookupBinder :: Name -> DsM (Core TH.Name) 1910lookupBinder = lookupOcc 1911 -- Binders are brought into scope before the pattern or what-not is 1912 -- desugared. Moreover, in instance declaration the binder of a method 1913 -- will be the selector Id and hence a global; so we need the 1914 -- globalVar case of lookupOcc 1915 1916-- Look up a name that is either locally bound or a global name 1917-- 1918-- * If it is a global name, generate the "original name" representation (ie, 1919-- the <module>:<name> form) for the associated entity 1920-- 1921lookupLOcc :: Located Name -> DsM (Core TH.Name) 1922-- Lookup an occurrence; it can't be a splice. 1923-- Use the in-scope bindings if they exist 1924lookupLOcc n = lookupOcc (unLoc n) 1925 1926lookupOcc :: Name -> DsM (Core TH.Name) 1927lookupOcc n 1928 = do { mb_val <- dsLookupMetaEnv n ; 1929 case mb_val of 1930 Nothing -> globalVar n 1931 Just (DsBound x) -> return (coreVar x) 1932 Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n) 1933 } 1934 1935globalVar :: Name -> DsM (Core TH.Name) 1936-- Not bound by the meta-env 1937-- Could be top-level; or could be local 1938-- f x = $(g [| x |]) 1939-- Here the x will be local 1940globalVar name 1941 | isExternalName name 1942 = do { MkC mod <- coreStringLit name_mod 1943 ; MkC pkg <- coreStringLit name_pkg 1944 ; MkC occ <- nameLit name 1945 ; rep2 mk_varg [pkg,mod,occ] } 1946 | otherwise 1947 = do { MkC occ <- nameLit name 1948 ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name)) 1949 ; rep2 mkNameLName [occ,uni] } 1950 where 1951 mod = ASSERT( isExternalName name) nameModule name 1952 name_mod = moduleNameString (moduleName mod) 1953 name_pkg = unitIdString (moduleUnitId mod) 1954 name_occ = nameOccName name 1955 mk_varg | OccName.isDataOcc name_occ = mkNameG_dName 1956 | OccName.isVarOcc name_occ = mkNameG_vName 1957 | OccName.isTcOcc name_occ = mkNameG_tcName 1958 | otherwise = pprPanic "DsMeta.globalVar" (ppr name) 1959 1960lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ) 1961 -> DsM Type -- The type 1962lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; 1963 return (mkTyConApp tc []) } 1964 1965wrapGenSyms :: [GenSymBind] 1966 -> Core (TH.Q a) -> DsM (Core (TH.Q a)) 1967-- wrapGenSyms [(nm1,id1), (nm2,id2)] y 1968-- --> bindQ (gensym nm1) (\ id1 -> 1969-- bindQ (gensym nm2 (\ id2 -> 1970-- y)) 1971 1972wrapGenSyms binds body@(MkC b) 1973 = do { var_ty <- lookupType nameTyConName 1974 ; go var_ty binds } 1975 where 1976 [elt_ty] = tcTyConAppArgs (exprType b) 1977 -- b :: Q a, so we can get the type 'a' by looking at the 1978 -- argument type. NB: this relies on Q being a data/newtype, 1979 -- not a type synonym 1980 1981 go _ [] = return body 1982 go var_ty ((name,id) : binds) 1983 = do { MkC body' <- go var_ty binds 1984 ; lit_str <- nameLit name 1985 ; gensym_app <- repGensym lit_str 1986 ; repBindQ var_ty elt_ty 1987 gensym_app (MkC (Lam id body')) } 1988 1989nameLit :: Name -> DsM (Core String) 1990nameLit n = coreStringLit (occNameString (nameOccName n)) 1991 1992occNameLit :: OccName -> DsM (Core String) 1993occNameLit name = coreStringLit (occNameString name) 1994 1995 1996-- %********************************************************************* 1997-- %* * 1998-- Constructing code 1999-- %* * 2000-- %********************************************************************* 2001 2002----------------------------------------------------------------------------- 2003-- PHANTOM TYPES for consistency. In order to make sure we do this correct 2004-- we invent a new datatype which uses phantom types. 2005 2006newtype Core a = MkC CoreExpr 2007unC :: Core a -> CoreExpr 2008unC (MkC x) = x 2009 2010rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) 2011rep2 n xs = do { id <- dsLookupGlobalId n 2012 ; return (MkC (foldl' App (Var id) xs)) } 2013 2014dataCon' :: Name -> [CoreExpr] -> DsM (Core a) 2015dataCon' n args = do { id <- dsLookupDataCon n 2016 ; return $ MkC $ mkCoreConApps id args } 2017 2018dataCon :: Name -> DsM (Core a) 2019dataCon n = dataCon' n [] 2020 2021 2022-- %********************************************************************* 2023-- %* * 2024-- The 'smart constructors' 2025-- %* * 2026-- %********************************************************************* 2027 2028--------------- Patterns ----------------- 2029repPlit :: Core TH.Lit -> DsM (Core TH.PatQ) 2030repPlit (MkC l) = rep2 litPName [l] 2031 2032repPvar :: Core TH.Name -> DsM (Core TH.PatQ) 2033repPvar (MkC s) = rep2 varPName [s] 2034 2035repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) 2036repPtup (MkC ps) = rep2 tupPName [ps] 2037 2038repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) 2039repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] 2040 2041repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ) 2042-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here 2043repPunboxedSum (MkC p) alt arity 2044 = do { dflags <- getDynFlags 2045 ; rep2 unboxedSumPName [ p 2046 , mkIntExprInt dflags alt 2047 , mkIntExprInt dflags arity ] } 2048 2049repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ) 2050repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] 2051 2052repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ) 2053repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps] 2054 2055repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) 2056repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2] 2057 2058repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ) 2059repPtilde (MkC p) = rep2 tildePName [p] 2060 2061repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ) 2062repPbang (MkC p) = rep2 bangPName [p] 2063 2064repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ) 2065repPaspat (MkC s) (MkC p) = rep2 asPName [s, p] 2066 2067repPwild :: DsM (Core TH.PatQ) 2068repPwild = rep2 wildPName [] 2069 2070repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) 2071repPlist (MkC ps) = rep2 listPName [ps] 2072 2073repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ) 2074repPview (MkC e) (MkC p) = rep2 viewPName [e,p] 2075 2076repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) 2077repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] 2078 2079--------------- Expressions ----------------- 2080repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) 2081repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str 2082 | otherwise = repVar str 2083 2084repVar :: Core TH.Name -> DsM (Core TH.ExpQ) 2085repVar (MkC s) = rep2 varEName [s] 2086 2087repCon :: Core TH.Name -> DsM (Core TH.ExpQ) 2088repCon (MkC s) = rep2 conEName [s] 2089 2090repLit :: Core TH.Lit -> DsM (Core TH.ExpQ) 2091repLit (MkC c) = rep2 litEName [c] 2092 2093repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2094repApp (MkC x) (MkC y) = rep2 appEName [x,y] 2095 2096repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ) 2097repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y] 2098 2099repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2100repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e] 2101 2102repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ) 2103repLamCase (MkC ms) = rep2 lamCaseEName [ms] 2104 2105repTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ) 2106repTup (MkC es) = rep2 tupEName [es] 2107 2108repUnboxedTup :: Core [Maybe TH.ExpQ] -> DsM (Core TH.ExpQ) 2109repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] 2110 2111repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ) 2112-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here 2113repUnboxedSum (MkC e) alt arity 2114 = do { dflags <- getDynFlags 2115 ; rep2 unboxedSumEName [ e 2116 , mkIntExprInt dflags alt 2117 , mkIntExprInt dflags arity ] } 2118 2119repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2120repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] 2121 2122repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ) 2123repMultiIf (MkC alts) = rep2 multiIfEName [alts] 2124 2125repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2126repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] 2127 2128repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM (Core TH.ExpQ) 2129repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] 2130 2131repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) 2132repDoE (MkC ss) = rep2 doEName [ss] 2133 2134repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) 2135repMDoE (MkC ss) = rep2 mdoEName [ss] 2136 2137repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ) 2138repComp (MkC ss) = rep2 compEName [ss] 2139 2140repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) 2141repListExp (MkC es) = rep2 listEName [es] 2142 2143repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ) 2144repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t] 2145 2146repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ) 2147repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs] 2148 2149repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ) 2150repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs] 2151 2152repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp)) 2153repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x] 2154 2155repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2156repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] 2157 2158repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2159repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y] 2160 2161repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2162repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y] 2163 2164repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ) 2165repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x] 2166 2167------------ Right hand sides (guarded expressions) ---- 2168repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ) 2169repGuarded (MkC pairs) = rep2 guardedBName [pairs] 2170 2171repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ) 2172repNormal (MkC e) = rep2 normalBName [e] 2173 2174------------ Guards ---- 2175repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn 2176 -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) 2177repLNormalGE g e = do g' <- repLE g 2178 e' <- repLE e 2179 repNormalGE g' e' 2180 2181repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) 2182repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e] 2183 2184repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp))) 2185repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e] 2186 2187------------- Stmts ------------------- 2188repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ) 2189repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e] 2190 2191repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ) 2192repLetSt (MkC ds) = rep2 letSName [ds] 2193 2194repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ) 2195repNoBindSt (MkC e) = rep2 noBindSName [e] 2196 2197repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ) 2198repParSt (MkC sss) = rep2 parSName [sss] 2199 2200repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ) 2201repRecSt (MkC ss) = rep2 recSName [ss] 2202 2203-------------- Range (Arithmetic sequences) ----------- 2204repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ) 2205repFrom (MkC x) = rep2 fromEName [x] 2206 2207repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2208repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y] 2209 2210repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2211repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y] 2212 2213repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) 2214repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z] 2215 2216------------ Match and Clause Tuples ----------- 2217repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ) 2218repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] 2219 2220repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ) 2221repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] 2222 2223-------------- Dec ----------------------------- 2224repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) 2225repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] 2226 2227repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) 2228repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] 2229 2230repData :: Core TH.CxtQ -> Core TH.Name 2231 -> Either (Core [TH.TyVarBndrQ]) 2232 (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ) 2233 -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] 2234 -> DsM (Core TH.DecQ) 2235repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) 2236 = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] 2237repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) 2238 (MkC derivs) 2239 = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] 2240 2241repNewtype :: Core TH.CxtQ -> Core TH.Name 2242 -> Either (Core [TH.TyVarBndrQ]) 2243 (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ) 2244 -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ] 2245 -> DsM (Core TH.DecQ) 2246repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con) 2247 (MkC derivs) 2248 = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] 2249repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con) 2250 (MkC derivs) 2251 = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] 2252 2253repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ] 2254 -> Core TH.TypeQ -> DsM (Core TH.DecQ) 2255repTySyn (MkC nm) (MkC tvs) (MkC rhs) 2256 = rep2 tySynDName [nm, tvs, rhs] 2257 2258repInst :: Core (Maybe TH.Overlap) -> 2259 Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ) 2260repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName 2261 [o, cxt, ty, ds] 2262 2263repDerivStrategy :: Maybe (LDerivStrategy GhcRn) 2264 -> DsM (Core (Maybe TH.DerivStrategyQ)) 2265repDerivStrategy mds = 2266 case mds of 2267 Nothing -> nothing 2268 Just ds -> 2269 case unLoc ds of 2270 StockStrategy -> just =<< repStockStrategy 2271 AnyclassStrategy -> just =<< repAnyclassStrategy 2272 NewtypeStrategy -> just =<< repNewtypeStrategy 2273 ViaStrategy ty -> do ty' <- repLTy (hsSigType ty) 2274 via_strat <- repViaStrategy ty' 2275 just via_strat 2276 where 2277 nothing = coreNothing derivStrategyQTyConName 2278 just = coreJust derivStrategyQTyConName 2279 2280repStockStrategy :: DsM (Core TH.DerivStrategyQ) 2281repStockStrategy = rep2 stockStrategyName [] 2282 2283repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ) 2284repAnyclassStrategy = rep2 anyclassStrategyName [] 2285 2286repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ) 2287repNewtypeStrategy = rep2 newtypeStrategyName [] 2288 2289repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ) 2290repViaStrategy (MkC t) = rep2 viaStrategyName [t] 2291 2292repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap)) 2293repOverlap mb = 2294 case mb of 2295 Nothing -> nothing 2296 Just o -> 2297 case o of 2298 NoOverlap _ -> nothing 2299 Overlappable _ -> just =<< dataCon overlappableDataConName 2300 Overlapping _ -> just =<< dataCon overlappingDataConName 2301 Overlaps _ -> just =<< dataCon overlapsDataConName 2302 Incoherent _ -> just =<< dataCon incoherentDataConName 2303 where 2304 nothing = coreNothing overlapTyConName 2305 just = coreJust overlapTyConName 2306 2307 2308repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] 2309 -> Core [TH.FunDep] -> Core [TH.DecQ] 2310 -> DsM (Core TH.DecQ) 2311repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) 2312 = rep2 classDName [cxt, cls, tvs, fds, ds] 2313 2314repDeriv :: Core (Maybe TH.DerivStrategyQ) 2315 -> Core TH.CxtQ -> Core TH.TypeQ 2316 -> DsM (Core TH.DecQ) 2317repDeriv (MkC ds) (MkC cxt) (MkC ty) 2318 = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty] 2319 2320repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch 2321 -> Core TH.Phases -> DsM (Core TH.DecQ) 2322repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases) 2323 = rep2 pragInlDName [nm, inline, rm, phases] 2324 2325repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases 2326 -> DsM (Core TH.DecQ) 2327repPragSpec (MkC nm) (MkC ty) (MkC phases) 2328 = rep2 pragSpecDName [nm, ty, phases] 2329 2330repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline 2331 -> Core TH.Phases -> DsM (Core TH.DecQ) 2332repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases) 2333 = rep2 pragSpecInlDName [nm, ty, inline, phases] 2334 2335repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ) 2336repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] 2337 2338repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ) 2339repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] 2340 2341repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ]) 2342 -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ 2343 -> Core TH.Phases -> DsM (Core TH.DecQ) 2344repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases) 2345 = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases] 2346 2347repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ) 2348repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] 2349 2350repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ) 2351repTySynInst (MkC eqn) 2352 = rep2 tySynInstDName [eqn] 2353 2354repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ] 2355 -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ) 2356repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) 2357 = rep2 dataFamilyDName [nm, tvs, kind] 2358 2359repOpenFamilyD :: Core TH.Name 2360 -> Core [TH.TyVarBndrQ] 2361 -> Core TH.FamilyResultSigQ 2362 -> Core (Maybe TH.InjectivityAnn) 2363 -> DsM (Core TH.DecQ) 2364repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) 2365 = rep2 openTypeFamilyDName [nm, tvs, result, inj] 2366 2367repClosedFamilyD :: Core TH.Name 2368 -> Core [TH.TyVarBndrQ] 2369 -> Core TH.FamilyResultSigQ 2370 -> Core (Maybe TH.InjectivityAnn) 2371 -> Core [TH.TySynEqnQ] 2372 -> DsM (Core TH.DecQ) 2373repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) 2374 = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] 2375 2376repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) -> 2377 Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) 2378repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs) 2379 = rep2 tySynEqnName [mb_bndrs, lhs, rhs] 2380 2381repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ) 2382repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] 2383 2384repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep) 2385repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys] 2386 2387repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) 2388repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] 2389 2390repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ) 2391repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e] 2392 2393repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) 2394repCtxt (MkC tys) = rep2 cxtName [tys] 2395 2396repDataCon :: Located Name 2397 -> HsConDeclDetails GhcRn 2398 -> DsM (Core TH.ConQ) 2399repDataCon con details 2400 = do con' <- lookupLOcc con -- See Note [Binders and occurrences] 2401 repConstr details Nothing [con'] 2402 2403repGadtDataCons :: [Located Name] 2404 -> HsConDeclDetails GhcRn 2405 -> LHsType GhcRn 2406 -> DsM (Core TH.ConQ) 2407repGadtDataCons cons details res_ty 2408 = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] 2409 repConstr details (Just res_ty) cons' 2410 2411-- Invariant: 2412-- * for plain H98 data constructors second argument is Nothing and third 2413-- argument is a singleton list 2414-- * for GADTs data constructors second argument is (Just return_type) and 2415-- third argument is a non-empty list 2416repConstr :: HsConDeclDetails GhcRn 2417 -> Maybe (LHsType GhcRn) 2418 -> [Core TH.Name] 2419 -> DsM (Core TH.ConQ) 2420repConstr (PrefixCon ps) Nothing [con] 2421 = do arg_tys <- repList bangTypeQTyConName repBangTy ps 2422 rep2 normalCName [unC con, unC arg_tys] 2423 2424repConstr (PrefixCon ps) (Just res_ty) cons 2425 = do arg_tys <- repList bangTypeQTyConName repBangTy ps 2426 res_ty' <- repLTy res_ty 2427 rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] 2428 2429repConstr (RecCon ips) resTy cons 2430 = do args <- concatMapM rep_ip (unLoc ips) 2431 arg_vtys <- coreList varBangTypeQTyConName args 2432 case resTy of 2433 Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] 2434 Just res_ty -> do 2435 res_ty' <- repLTy res_ty 2436 rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, 2437 unC res_ty'] 2438 2439 where 2440 rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) 2441 2442 rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a) 2443 rep_one_ip t n = do { MkC v <- lookupOcc (extFieldOcc $ unLoc n) 2444 ; MkC ty <- repBangTy t 2445 ; rep2 varBangTypeName [v,ty] } 2446 2447repConstr (InfixCon st1 st2) Nothing [con] 2448 = do arg1 <- repBangTy st1 2449 arg2 <- repBangTy st2 2450 rep2 infixCName [unC arg1, unC con, unC arg2] 2451 2452repConstr (InfixCon {}) (Just _) _ = 2453 panic "repConstr: infix GADT constructor should be in a PrefixCon" 2454repConstr _ _ _ = 2455 panic "repConstr: invariant violated" 2456 2457------------ Types ------------------- 2458 2459repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ 2460 -> DsM (Core TH.TypeQ) 2461repTForall (MkC tvars) (MkC ctxt) (MkC ty) 2462 = rep2 forallTName [tvars, ctxt, ty] 2463 2464repTForallVis :: Core [TH.TyVarBndrQ] -> Core TH.TypeQ 2465 -> DsM (Core TH.TypeQ) 2466repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty] 2467 2468repTvar :: Core TH.Name -> DsM (Core TH.TypeQ) 2469repTvar (MkC s) = rep2 varTName [s] 2470 2471repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) 2472repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] 2473 2474repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ) 2475repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki] 2476 2477repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ) 2478repTapps f [] = return f 2479repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } 2480 2481repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ) 2482repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki] 2483 2484repTequality :: DsM (Core TH.TypeQ) 2485repTequality = rep2 equalityTName [] 2486 2487repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ) 2488repTPromotedList [] = repPromotedNilTyCon 2489repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon 2490 ; f <- repTapp tcon t 2491 ; t' <- repTPromotedList ts 2492 ; repTapp f t' 2493 } 2494 2495repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ) 2496repTLit (MkC lit) = rep2 litTName [lit] 2497 2498repTWildCard :: DsM (Core TH.TypeQ) 2499repTWildCard = rep2 wildCardTName [] 2500 2501repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ) 2502repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e] 2503 2504repTStar :: DsM (Core TH.TypeQ) 2505repTStar = rep2 starKName [] 2506 2507repTConstraint :: DsM (Core TH.TypeQ) 2508repTConstraint = rep2 constraintKName [] 2509 2510--------- Type constructors -------------- 2511 2512repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) 2513repNamedTyCon (MkC s) = rep2 conTName [s] 2514 2515repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ 2516 -> DsM (Core TH.TypeQ) 2517repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2] 2518 2519repTupleTyCon :: Int -> DsM (Core TH.TypeQ) 2520-- Note: not Core Int; it's easier to be direct here 2521repTupleTyCon i = do dflags <- getDynFlags 2522 rep2 tupleTName [mkIntExprInt dflags i] 2523 2524repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ) 2525-- Note: not Core Int; it's easier to be direct here 2526repUnboxedTupleTyCon i = do dflags <- getDynFlags 2527 rep2 unboxedTupleTName [mkIntExprInt dflags i] 2528 2529repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ) 2530-- Note: not Core TH.SumArity; it's easier to be direct here 2531repUnboxedSumTyCon arity = do dflags <- getDynFlags 2532 rep2 unboxedSumTName [mkIntExprInt dflags arity] 2533 2534repArrowTyCon :: DsM (Core TH.TypeQ) 2535repArrowTyCon = rep2 arrowTName [] 2536 2537repListTyCon :: DsM (Core TH.TypeQ) 2538repListTyCon = rep2 listTName [] 2539 2540repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ) 2541repPromotedDataCon (MkC s) = rep2 promotedTName [s] 2542 2543repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ) 2544repPromotedTupleTyCon i = do dflags <- getDynFlags 2545 rep2 promotedTupleTName [mkIntExprInt dflags i] 2546 2547repPromotedNilTyCon :: DsM (Core TH.TypeQ) 2548repPromotedNilTyCon = rep2 promotedNilTName [] 2549 2550repPromotedConsTyCon :: DsM (Core TH.TypeQ) 2551repPromotedConsTyCon = rep2 promotedConsTName [] 2552 2553------------ TyVarBndrs ------------------- 2554 2555repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ) 2556repPlainTV (MkC nm) = rep2 plainTVName [nm] 2557 2558repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ) 2559repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] 2560 2561---------------------------------------------------------- 2562-- Type family result signature 2563 2564repNoSig :: DsM (Core TH.FamilyResultSigQ) 2565repNoSig = rep2 noSigName [] 2566 2567repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ) 2568repKindSig (MkC ki) = rep2 kindSigName [ki] 2569 2570repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ) 2571repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] 2572 2573---------------------------------------------------------- 2574-- Literals 2575 2576repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit) 2577repLiteral (HsStringPrim _ bs) 2578 = do dflags <- getDynFlags 2579 word8_ty <- lookupType word8TyConName 2580 let w8s = unpack bs 2581 w8s_expr = map (\w8 -> mkCoreConApps word8DataCon 2582 [mkWordLit dflags (toInteger w8)]) w8s 2583 rep2 stringPrimLName [mkListExpr word8_ty w8s_expr] 2584repLiteral lit 2585 = do lit' <- case lit of 2586 HsIntPrim _ i -> mk_integer i 2587 HsWordPrim _ w -> mk_integer w 2588 HsInt _ i -> mk_integer (il_value i) 2589 HsFloatPrim _ r -> mk_rational r 2590 HsDoublePrim _ r -> mk_rational r 2591 HsCharPrim _ c -> mk_char c 2592 _ -> return lit 2593 lit_expr <- dsLit lit' 2594 case mb_lit_name of 2595 Just lit_name -> rep2 lit_name [lit_expr] 2596 Nothing -> notHandled "Exotic literal" (ppr lit) 2597 where 2598 mb_lit_name = case lit of 2599 HsInteger _ _ _ -> Just integerLName 2600 HsInt _ _ -> Just integerLName 2601 HsIntPrim _ _ -> Just intPrimLName 2602 HsWordPrim _ _ -> Just wordPrimLName 2603 HsFloatPrim _ _ -> Just floatPrimLName 2604 HsDoublePrim _ _ -> Just doublePrimLName 2605 HsChar _ _ -> Just charLName 2606 HsCharPrim _ _ -> Just charPrimLName 2607 HsString _ _ -> Just stringLName 2608 HsRat _ _ _ -> Just rationalLName 2609 _ -> Nothing 2610 2611mk_integer :: Integer -> DsM (HsLit GhcRn) 2612mk_integer i = do integer_ty <- lookupType integerTyConName 2613 return $ HsInteger NoSourceText i integer_ty 2614 2615mk_rational :: FractionalLit -> DsM (HsLit GhcRn) 2616mk_rational r = do rat_ty <- lookupType rationalTyConName 2617 return $ HsRat noExtField r rat_ty 2618mk_string :: FastString -> DsM (HsLit GhcRn) 2619mk_string s = return $ HsString NoSourceText s 2620 2621mk_char :: Char -> DsM (HsLit GhcRn) 2622mk_char c = return $ HsChar NoSourceText c 2623 2624repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit) 2625repOverloadedLiteral (OverLit { ol_val = val}) 2626 = do { lit <- mk_lit val; repLiteral lit } 2627 -- The type Rational will be in the environment, because 2628 -- the smart constructor 'TH.Syntax.rationalL' uses it in its type, 2629 -- and rationalL is sucked in when any TH stuff is used 2630repOverloadedLiteral (XOverLit nec) = noExtCon nec 2631 2632mk_lit :: OverLitVal -> DsM (HsLit GhcRn) 2633mk_lit (HsIntegral i) = mk_integer (il_value i) 2634mk_lit (HsFractional f) = mk_rational f 2635mk_lit (HsIsString _ s) = mk_string s 2636 2637repNameS :: Core String -> DsM (Core TH.Name) 2638repNameS (MkC name) = rep2 mkNameSName [name] 2639 2640--------------- Miscellaneous ------------------- 2641 2642repGensym :: Core String -> DsM (Core (TH.Q TH.Name)) 2643repGensym (MkC lit_str) = rep2 newNameName [lit_str] 2644 2645repBindQ :: Type -> Type -- a and b 2646 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b)) 2647repBindQ ty_a ty_b (MkC x) (MkC y) 2648 = rep2 bindQName [Type ty_a, Type ty_b, x, y] 2649 2650repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a])) 2651repSequenceQ ty_a (MkC list) 2652 = rep2 sequenceQName [Type ty_a, list] 2653 2654repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ) 2655repUnboundVar (MkC name) = rep2 unboundVarEName [name] 2656 2657repOverLabel :: FastString -> DsM (Core TH.ExpQ) 2658repOverLabel fs = do 2659 (MkC s) <- coreStringLit $ unpackFS fs 2660 rep2 labelEName [s] 2661 2662 2663------------ Lists ------------------- 2664-- turn a list of patterns into a single pattern matching a list 2665 2666repList :: Name -> (a -> DsM (Core b)) 2667 -> [a] -> DsM (Core [b]) 2668repList tc_name f args 2669 = do { args1 <- mapM f args 2670 ; coreList tc_name args1 } 2671 2672coreList :: Name -- Of the TyCon of the element type 2673 -> [Core a] -> DsM (Core [a]) 2674coreList tc_name es 2675 = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) } 2676 2677coreList' :: Type -- The element type 2678 -> [Core a] -> Core [a] 2679coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) 2680 2681nonEmptyCoreList :: [Core a] -> Core [a] 2682 -- The list must be non-empty so we can get the element type 2683 -- Otherwise use coreList 2684nonEmptyCoreList [] = panic "coreList: empty argument" 2685nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) 2686 2687coreStringLit :: String -> DsM (Core String) 2688coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } 2689 2690------------------- Maybe ------------------ 2691 2692repMaybe :: Name -> (a -> DsM (Core b)) 2693 -> Maybe a -> DsM (Core (Maybe b)) 2694repMaybe tc_name _ Nothing = coreNothing tc_name 2695repMaybe tc_name f (Just es) = coreJust tc_name =<< f es 2696 2697-- | Construct Core expression for Nothing of a given type name 2698coreNothing :: Name -- ^ Name of the TyCon of the element type 2699 -> DsM (Core (Maybe a)) 2700coreNothing tc_name = 2701 do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) } 2702 2703-- | Construct Core expression for Nothing of a given type 2704coreNothing' :: Type -- ^ The element type 2705 -> Core (Maybe a) 2706coreNothing' elt_ty = MkC (mkNothingExpr elt_ty) 2707 2708-- | Store given Core expression in a Just of a given type name 2709coreJust :: Name -- ^ Name of the TyCon of the element type 2710 -> Core a -> DsM (Core (Maybe a)) 2711coreJust tc_name es 2712 = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) } 2713 2714-- | Store given Core expression in a Just of a given type 2715coreJust' :: Type -- ^ The element type 2716 -> Core a -> Core (Maybe a) 2717coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) 2718 2719------------------- Maybe Lists ------------------ 2720 2721repMaybeList :: Name -> (a -> DsM (Core b)) 2722 -> Maybe [a] -> DsM (Core (Maybe [b])) 2723repMaybeList tc_name _ Nothing = coreNothingList tc_name 2724repMaybeList tc_name f (Just args) 2725 = do { elt_ty <- lookupType tc_name 2726 ; args1 <- mapM f args 2727 ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) } 2728 2729coreNothingList :: Name -> DsM (Core (Maybe [a])) 2730coreNothingList tc_name 2731 = do { elt_ty <- lookupType tc_name 2732 ; return $ coreNothing' (mkListTy elt_ty) } 2733 2734coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a])) 2735coreJustList tc_name args 2736 = do { elt_ty <- lookupType tc_name 2737 ; return $ coreJust' (mkListTy elt_ty) args } 2738 2739------------ Literals & Variables ------------------- 2740 2741coreIntLit :: Int -> DsM (Core Int) 2742coreIntLit i = do dflags <- getDynFlags 2743 return (MkC (mkIntExprInt dflags i)) 2744 2745coreIntegerLit :: Integer -> DsM (Core Integer) 2746coreIntegerLit i = fmap MkC (mkIntegerExpr i) 2747 2748coreVar :: Id -> Core TH.Name -- The Id has type Name 2749coreVar id = MkC (Var id) 2750 2751----------------- Failure ----------------------- 2752notHandledL :: SrcSpan -> String -> SDoc -> DsM a 2753notHandledL loc what doc 2754 | isGoodSrcSpan loc 2755 = putSrcSpanDs loc $ notHandled what doc 2756 | otherwise 2757 = notHandled what doc 2758 2759notHandled :: String -> SDoc -> DsM a 2760notHandled what doc = failWithDs msg 2761 where 2762 msg = hang (text what <+> text "not (yet) handled by Template Haskell") 2763 2 doc 2764