DsMeta.hs 112 KB
Newer Older
1
{-# LANGUAGE CPP, TypeFamilies #-}
2
{-# LANGUAGE FlexibleContexts #-}
3
{-# LANGUAGE ViewPatterns #-}
4

5
-----------------------------------------------------------------------------
6 7 8
--
-- (c) The University of Glasgow 2006
--
9 10 11 12
-- The purpose of this module is to transform an HsExpr into a CoreExpr which
-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
13 14
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
Gabor Greif's avatar
Gabor Greif committed
15
-- in prelude/PrelNames.  It's much more convenient to do it here, because
16 17
-- otherwise we have to recompile PrelNames whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
18 19
-----------------------------------------------------------------------------

20
module DsMeta( dsBracket ) where
21

22 23
#include "HsVersions.h"

24 25
import GhcPrelude

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
26
import {-# SOURCE #-}   DsExpr ( dsExpr )
27

28
import MatchLit
29 30
import DsMonad

31
import qualified Language.Haskell.TH as TH
32

33
import HsSyn
34 35 36 37 38
import PrelNames
-- To avoid clashes with DsMeta.varName we must make a local alias for
-- OccName.varName we do this by removing varName from the import of
-- OccName above, making a qualified instance of OccName and using
-- OccNameAlias.varName where varName ws previously used in this file.
39
import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
40

41 42
import Module
import Id
43
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
44
import THNames
45
import NameEnv
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
46
import NameSet
47 48 49
import TcType
import TyCon
import TysWiredIn
50
import CoreSyn
51
import MkCore
52 53 54 55
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
56
import Outputable
57
import Bag
58
import DynFlags
59 60
import FastString
import ForeignCall
61
import Util
62
import Maybes
63
import MonadUtils
64

65
import Data.ByteString ( unpack )
66 67
import Control.Monad
import Data.List
68

69
-----------------------------------------------------------------------------
70
dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
71
-- Returns a CoreExpr of type TH.ExpQ
72 73 74
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

75 76
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
77
  where
78 79
    new_bit = mkNameEnv [(n, DsSplice (unLoc e))
                        | PendingTcSplice n e <- splices]
80

81 82 83 84 85 86 87 88
    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
    do_brack (ExpBr _ e)   = do { MkC e1  <- repLE e     ; return e1 }
    do_brack (PatBr _ p)   = do { MkC p1  <- repTopP p   ; return p1 }
    do_brack (TypBr _ t)   = do { MkC t1  <- repLTy t    ; return t1 }
    do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"
    do_brack (TExpBr _ e)  = do { MkC e1  <- repLE e     ; return e1 }
    do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104

{- -------------- Examples --------------------

  [| \x -> x |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (var x1)


  [| \x -> $(f [| x |]) |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (f (var x1))
-}


105
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
106
--                      Declarations
107 108
-------------------------------------------------------

109
repTopP :: LPat GhcRn -> DsM (Core TH.PatQ)
110
repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
111
                 ; pat' <- addBinds ss (repLP pat)
112
                 ; wrapGenSyms ss pat' }
113

114
repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))
115 116 117 118 119 120 121 122 123 124 125
repTopDs group@(HsGroup { hs_valds   = valds
                        , hs_splcds  = splcds
                        , hs_tyclds  = tyclds
                        , hs_derivds = derivds
                        , hs_fixds   = fixds
                        , hs_defds   = defds
                        , hs_fords   = fords
                        , hs_warnds  = warnds
                        , hs_annds   = annds
                        , hs_ruleds  = ruleds
                        , hs_docs    = docs })
126
 = do { let { bndrs  = hsScopedTvBinders valds
127 128
                       ++ hsGroupBinders group
                       ++ hsPatSynSelectors valds
129
            ; instds = tyclds >>= group_instds } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
130
        ss <- mkGenSyms bndrs ;
131

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
132 133 134 135 136 137
        -- Bind all the names mainly to avoid repeated use of explicit strings.
        -- Thus we get
        --      do { t :: String <- genSym "T" ;
        --           return (Data t [] ...more t's... }
        -- The other important reason is that the output must mention
        -- only "T", not "Foo:T" where Foo is the current module
138

139
        decls <- addBinds ss (
140 141
                  do { val_ds   <- rep_val_binds valds
                     ; _        <- mapM no_splice splcds
142
                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
143 144 145 146 147 148
                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
                     ; inst_ds  <- mapM repInstD instds
                     ; deriv_ds <- mapM repStandaloneDerivD derivds
                     ; fix_ds   <- mapM repFixD fixds
                     ; _        <- mapM no_default_decl defds
                     ; for_ds   <- mapM repForD fords
Alan Zimmerman's avatar
Alan Zimmerman committed
149 150
                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
                                                           warnds)
151
                     ; ann_ds   <- mapM repAnnD annds
Alan Zimmerman's avatar
Alan Zimmerman committed
152 153
                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
                                                            ruleds)
154
                     ; _        <- mapM no_doc docs
155

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
156
                        -- more needed
157
                     ;  return (de_loc $ sort_by_loc $
158 159
                                val_ds ++ catMaybes tycl_ds ++ role_ds
                                       ++ (concat fix_ds)
160
                                       ++ inst_ds ++ rule_ds ++ for_ds
161
                                       ++ ann_ds ++ deriv_ds) }) ;
162

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
163 164
        decl_ty <- lookupType decQTyConName ;
        let { core_list = coreList' decl_ty decls } ;
165

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
166 167
        dec_ty <- lookupType decTyConName ;
        q_decs  <- repSequenceQ dec_ty core_list ;
168

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
169
        wrapGenSyms ss q_decs
170
      }
171
  where
172
    no_splice (dL->L loc _)
173
      = notHandledL loc "Splices within declaration brackets" empty
174
    no_default_decl (dL->L loc decl)
175
      = notHandledL loc "Default declarations" (ppr decl)
176
    no_warn (dL->L loc (Warning _ thing _))
177 178
      = notHandledL loc "WARNING and DEPRECATION pragmas" $
                    text "Pragma for declaration of" <+> ppr thing
179 180
    no_warn _ = panic "repTopDs"
    no_doc (dL->L loc _)
181
      = notHandledL loc "Haddock documentation" empty
182
repTopDs (XHsGroup _) = panic "repTopDs"
183

184
hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
185
-- See Note [Scoped type variables in bindings]
186
hsScopedTvBinders binds
187
  = concatMap get_scoped_tvs sigs
188 189
  where
    sigs = case binds of
190 191
             ValBinds           _ _ sigs  -> sigs
             XValBindsLR (NValBinds _ sigs) -> sigs
192

193
get_scoped_tvs :: LSig GhcRn -> [Name]
194
get_scoped_tvs (dL->L _ signature)
195
  | TypeSig _ _ sig <- signature
196
  = get_scoped_tvs_from_sig (hswc_body sig)
197
  | ClassOpSig _ _ _ sig <- signature
198
  = get_scoped_tvs_from_sig sig
199
  | PatSynSig _ _ sig <- signature
200 201 202 203 204 205 206 207
  = get_scoped_tvs_from_sig sig
  | otherwise
  = []
  where
    get_scoped_tvs_from_sig sig
      -- Both implicit and explicit quantified variables
      -- We need the implicit ones for   f :: forall (a::k). blah
      --    here 'k' scopes too
208
      | HsIB { hsib_ext = implicit_vars
209 210 211
             , hsib_body = hs_ty } <- sig
      , (explicit_vars, _) <- splitLHsForAllTy hs_ty
      = implicit_vars ++ map hsLTyVarName explicit_vars
212 213
    get_scoped_tvs_from_sig (XHsImplicitBndrs _)
      = panic "get_scoped_tvs_from_sig"
214

215 216 217 218 219 220 221 222
{- Notes

Note [Scoped type variables in bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   f :: forall a. a -> a
   f x = x::a
Here the 'forall a' brings 'a' into scope over the binding group.
223
To achieve this we
224 225

  a) Gensym a binding for 'a' at the same time as we do one for 'f'
226
     collecting the relevant binders with hsScopedTvBinders
227 228 229 230 231

  b) When processing the 'forall', don't gensym

The relevant places are signposted with references to this Note

232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256
Note [Scoped type variables in class and instance declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Scoped type variables may occur in default methods and default
signatures. We need to bring the type variables in 'foralls'
into the scope of the method bindings.

Consider
   class Foo a where
     foo :: forall (b :: k). a -> Proxy b -> Proxy b
     foo _ x = (x :: Proxy b)

We want to ensure that the 'b' in the type signature and the default
implementation are the same, so we do the following:

  a) Before desugaring the signature and binding of 'foo', use
     get_scoped_tvs to collect type variables in 'forall' and
     create symbols for them.
  b) Use 'addBinds' to bring these symbols into the scope of the type
     signatures and bindings.
  c) Use these symbols to generate Core for the class/instance declaration.

Note that when desugaring the signatures, we lookup the type variables
from the scope rather than recreate symbols for them. See more details
in "rep_ty_sig" and in Trac#14885.

257 258
Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
259 260
When we desugar [d| data T = MkT |]
we want to get
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
261
        Data "T" [] [Con "MkT" []] []
262
and *not*
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
263
        Data "Foo:T" [] [Con "Foo:MkT" []] []
264 265
That is, the new data decl should fit into whatever new module it is
asked to fit in.   We do *not* clone, though; no need for this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
266
        Data "T79" ....
267 268

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
269 270
        data T = MkT
        foo = reifyDecl T
271 272

then we must desugar to
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
273
        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
274

275 276
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
277 278
in repTyClD and repC.

279 280 281 282 283 284 285 286 287 288 289 290 291
Note [Don't quantify implicit type variables in quotes]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you're not careful, it's suprisingly easy to take this quoted declaration:

  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b
      idProxy x = x
    |]

and have Template Haskell turn it into this:

  idProxy :: forall k proxy (b :: k). proxy b -> proxy b
  idProxy x = x

292 293
Notice that we explicitly quantified the variable `k`! The latter declaration
isn't what the user wrote in the first place.
294 295 296 297

Usually, the culprit behind these bugs is taking implicitly quantified type
variables (often from the hsib_vars field of HsImplicitBinders) and putting
them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
298 299
-}

300 301
-- represent associated family instances
--
302
repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
303

304 305
repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $
                                                  repFamilyDecl (L loc fam)
306

307
repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
308 309 310
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
311
       ; return (Just (loc, dec)) }
312

313 314 315
repTyClD (dL->L loc (DataDecl { tcdLName = tc
                              , tcdTyVars = tvs
                              , tcdDataDefn = defn }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
316
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
317
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
318
                repDataDefn tc1 (Left bndrs) defn
319
       ; return (Just (loc, dec)) }
320

321
repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
322 323
                             tcdTyVars = tvs, tcdFDs = fds,
                             tcdSigs = sigs, tcdMeths = meth_binds,
324
                             tcdATs = ats, tcdATDefs = atds }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
325 326
  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
       ; dec  <- addTyVarBinds tvs $ \bndrs ->
327
           do { cxt1   <- repLContext cxt
328
          -- See Note [Scoped type variables in class and instance declarations]
329
              ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
330
              ; fds1   <- repLFunDeps fds
331
              ; ats1   <- repFamilyDecls ats
332
              ; atds1  <- repAssocTyFamDefaults atds
333 334 335
              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)
              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
              ; wrapGenSyms ss decls2 }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
336
       ; return $ Just (loc, dec)
337
       }
338

339
repTyClD _ = panic "repTyClD"
340

341
-------------------------
342
repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
343
repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles))
344 345 346 347 348
  = do { tycon1 <- lookupLOcc tycon
       ; roles1 <- mapM repRole roles
       ; roles2 <- coreList roleTyConName roles1
       ; dec <- repRoleAnnotD tycon1 roles2
       ; return (loc, dec) }
349
repRoleD _ = panic "repRoleD"
350

351
-------------------------
352 353 354
repDataDefn :: Core TH.Name
            -> Either (Core [TH.TyVarBndrQ])
                        -- the repTyClD case
My Nguyen's avatar
My Nguyen committed
355
                      (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
356
                        -- the repDataFamInstD case
357
            -> HsDataDefn GhcRn
358
            -> DsM (Core TH.DecQ)
359
repDataDefn tc opts
360
          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
361
                      , dd_cons = cons, dd_derivs = mb_derivs })
362 363
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
364 365
       ; case (new_or_data, cons) of
           (NewType, [con])  -> do { con'  <- repC con
366
                                   ; ksig' <- repMaybeLTy ksig
367
                                   ; repNewtype cxt1 tc opts ksig' con'
368 369 370 371
                                                derivs1 }
           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
                                       <+> pprQuotedList
                                       (getConNames $ unLoc $ head cons))
372
           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
373 374
                               ; consL <- mapM repC cons
                               ; cons1 <- coreList conQTyConName consL
375
                               ; repData cxt1 tc opts ksig' cons1
376 377
                                         derivs1 }
       }
378
repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"
379

380
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
381
           -> LHsType GhcRn
382
           -> DsM (Core TH.DecQ)
383
repSynDecl tc bndrs ty
384
  = do { ty1 <- repLTy ty
385 386
       ; repTySyn tc bndrs ty1 }

387
repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
388 389 390 391 392
repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo      = info
                                          , fdLName     = tc
                                          , fdTyVars    = tvs
                                          , fdResultSig = dL->L _ resultSig
                                          , fdInjectivityAnn = injectivity }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
393
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
394
       ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
395 396 397 398
             mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn
                                                { hsq_implicit = []
                                                , hsq_dependent = emptyNameSet }
                                   , hsq_explicit = tvs }
Jan Stolarek's avatar
Jan Stolarek committed
399
             resTyVar = case resultSig of
400 401
                     TyVarSig _ bndr -> mkHsQTvs [bndr]
                     _               -> mkHsQTvs []
402
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
403 404 405 406 407
                addTyClTyVarBinds resTyVar $ \_ ->
           case info of
             ClosedTypeFamily Nothing ->
                 notHandled "abstract closed type family" (ppr decl)
             ClosedTypeFamily (Just eqns) ->
408
               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
Jan Stolarek's avatar
Jan Stolarek committed
409 410 411 412 413 414 415 416 417 418 419
                  ; eqns2  <- coreList tySynEqnQTyConName eqns1
                  ; result <- repFamilyResultSig resultSig
                  ; inj    <- repInjectivityAnn injectivity
                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }
             OpenTypeFamily ->
               do { result <- repFamilyResultSig resultSig
                  ; inj    <- repInjectivityAnn injectivity
                  ; repOpenFamilyD tc1 bndrs result inj }
             DataFamily ->
               do { kind <- repFamilyResultSigToMaybeKind resultSig
                  ; repDataFamilyD tc1 bndrs kind }
420 421
       ; return (loc, dec)
       }
422
repFamilyDecl _ = panic "repFamilyDecl"
423

Jan Stolarek's avatar
Jan Stolarek committed
424
-- | Represent result signature of a type family
425
repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
426 427 428 429 430 431
repFamilyResultSig (NoSig _)         = repNoSig
repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
                                          ; repKindSig ki' }
repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
                                          ; repTyVarSig bndr' }
repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"
Jan Stolarek's avatar
Jan Stolarek committed
432 433 434 435

-- | Represent result signature using a Maybe Kind. Used with data families,
-- where the result signature can be either missing or a kind but never a named
-- result variable.
436
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
437
                              -> DsM (Core (Maybe TH.KindQ))
438
repFamilyResultSigToMaybeKind (NoSig _) =
439
    do { coreNothing kindQTyConName }
440
repFamilyResultSigToMaybeKind (KindSig _ ki) =
441 442
    do { ki' <- repLTy ki
       ; coreJust kindQTyConName ki' }
Jan Stolarek's avatar
Jan Stolarek committed
443 444 445
repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"

-- | Represent injectivity annotation of a type family
446
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
Jan Stolarek's avatar
Jan Stolarek committed
447 448 449
                  -> DsM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn Nothing =
    do { coreNothing injAnnTyConName }
450
repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) =
Jan Stolarek's avatar
Jan Stolarek committed
451 452 453 454 455 456
    do { lhs'   <- lookupBinder (unLoc lhs)
       ; rhs1   <- mapM (lookupBinder . unLoc) rhs
       ; rhs2   <- coreList nameTyConName rhs1
       ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]
       ; coreJust injAnnTyConName injAnn }

457
repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
458
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
459

460
repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ]
461 462 463
repAssocTyFamDefaults = mapM rep_deflt
  where
     -- very like repTyFamEqn, but different in the details
464
    rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
465 466 467
    rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc
                               , feqn_bndrs = bndrs
                               , feqn_pats  = tys
My Nguyen's avatar
My Nguyen committed
468
                               , feqn_fixity = fixity
469
                               , feqn_rhs   = rhs }))
470
      = addTyClTyVarBinds tys $ \ _ ->
471
        do { tc1  <- lookupLOcc tc
472 473 474
           ; no_bndrs <- ASSERT( isNothing bndrs )
                         coreNothingList tyVarBndrQTyConName
           ; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
My Nguyen's avatar
My Nguyen committed
475 476 477 478 479 480
           ; lhs <- case fixity of
                      Prefix -> do { head_ty <- repNamedTyCon tc1
                                   ; repTapps head_ty tys1 }
                      Infix -> do { (t1:t2:args) <- checkTys tys1
                                  ; head_ty <- repTInfix t1 tc1 t2
                                  ; repTapps head_ty args }
481
           ; rhs1 <- repLTy rhs
My Nguyen's avatar
My Nguyen committed
482 483
           ; eqn1 <- repTySynEqn no_bndrs lhs rhs1
           ; repTySynInst eqn1 }
484
    rep_deflt _ = panic "repAssocTyFamDefaults"
485

My Nguyen's avatar
My Nguyen committed
486 487 488 489
    checkTys :: [Core TH.TypeQ] -> DsM [Core TH.TypeQ]
    checkTys tys@(_:_:_) = return tys
    checkTys _ = panic "repAssocTyFamDefaults:checkTys"

490
-------------------------
491 492
-- represent fundeps
--
493
repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
494
repLFunDeps fds = repList funDepTyConName repLFunDep fds
495

496
repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
497
repLFunDep (dL->L _ (xs, ys))
Alan Zimmerman's avatar
Alan Zimmerman committed
498 499 500
   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
        repFunDep xs' ys'
501

502 503
-- Represent instance declarations
--
504
repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
505
repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl }))
506 507
  = do { dec <- repTyFamInstD fi_decl
       ; return (loc, dec) }
508
repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl }))
509 510
  = do { dec <- repDataFamInstD fi_decl
       ; return (loc, dec) }
511
repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl }))
512
  = do { dec <- repClsInstD cls_decl
513
       ; return (loc, dec) }
514
repInstD _ = panic "repInstD"
515

516
repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
517
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
518
                         , cid_sigs = sigs, cid_tyfam_insts = ats
519 520 521
                         , cid_datafam_insts = adts
                         , cid_overlap_mode = overlap
                         })
522
  = addSimpleTyVarBinds tvs $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
523 524
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
525
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
526 527 528 529 530 531
            --
            -- But we do NOT bring the binders of 'binds' into scope
            -- because they are properly regarded as occurrences
            -- For example, the method names should be bound to
            -- the selector Ids, not to fresh names (Trac #5410)
            --
532
            do { cxt1     <- repLContext cxt
533
               ; inst_ty1 <- repLTy inst_ty
534
          -- See Note [Scoped type variables in class and instance declarations]
535 536 537 538 539 540 541
               ; (ss, sigs_binds) <- rep_sigs_binds sigs binds
               ; ats1   <- mapM (repTyFamInstD . unLoc) ats
               ; adts1  <- mapM (repDataFamInstD . unLoc) adts
               ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds)
               ; rOver  <- repOverlap (fmap unLoc overlap)
               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
               ; wrapGenSyms ss decls2 }
542
 where
543
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
544
repClsInstD (XClsInstDecl _) = panic "repClsInstD"
545

546
repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
547 548
repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat
                                          , deriv_type     = ty }))
549 550
  = do { dec <- addSimpleTyVarBinds tvs $
                do { cxt'     <- repLContext cxt
551
                   ; strat'   <- repDerivStrategy strat
552
                   ; inst_ty' <- repLTy inst_ty
553
                   ; repDeriv strat' cxt' inst_ty' }
554 555
       ; return (loc, dec) }
  where
556
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
557
repStandaloneDerivD _ = panic "repStandaloneDerivD"
558

559
repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
My Nguyen's avatar
My Nguyen committed
560 561 562
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
  = do { eqn1 <- repTyFamEqn eqn
       ; repTySynInst eqn1 }
563

564
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
565
repTyFamEqn (HsIB { hsib_ext = var_names
My Nguyen's avatar
My Nguyen committed
566 567
                  , hsib_body = FamEqn { feqn_tycon = tc_name
                                       , feqn_bndrs = mb_bndrs
568
                                       , feqn_pats = tys
My Nguyen's avatar
My Nguyen committed
569
                                       , feqn_fixity = fixity
570
                                       , feqn_rhs  = rhs }})
My Nguyen's avatar
My Nguyen committed
571 572
  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]
       ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
573 574
                               { hsq_implicit = var_names
                               , hsq_dependent = emptyNameSet }   -- Yuk
575
                             , hsq_explicit = fromMaybe [] mb_bndrs }
576
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
577 578 579
         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
                                        repTyVarBndr
                                        mb_bndrs
My Nguyen's avatar
My Nguyen committed
580 581 582 583 584 585
            ; tys1 <- case fixity of
                        Prefix -> repTyArgs (repNamedTyCon tc) tys
                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
                                     ; t1' <- repLTy t1
                                     ; t2'  <- repLTy t2
                                     ; repTyArgs (repTInfix t1' tc t2') args }
586
            ; rhs1 <- repLTy rhs
My Nguyen's avatar
My Nguyen committed
587 588 589 590
            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }
     where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
           checkTys tys@(HsValArg _:HsValArg _:_) = return tys
           checkTys _ = panic "repTyFamEqn:checkTys"
591 592
repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
593

My Nguyen's avatar
My Nguyen committed
594 595 596 597 598 599 600 601 602 603
repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ)
repTyArgs f [] = f
repTyArgs f (HsValArg ty : as) = do { f' <- f
                                    ; ty' <- repLTy ty
                                    ; repTyArgs (repTapp f' ty') as }
repTyArgs f (HsTypeArg ki : as) = do { f' <- f
                                     ; ki' <- repLTy ki
                                     ; repTyArgs (repTappKind f' ki') as }
repTyArgs f (HsArgPar _ : as) = repTyArgs f as

604
repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
605
repDataFamInstD (DataFamInstDecl { dfid_eqn =
606
                  (HsIB { hsib_ext = var_names
607
                        , hsib_body = FamEqn { feqn_tycon = tc_name
608
                                             , feqn_bndrs = mb_bndrs
609
                                             , feqn_pats  = tys
My Nguyen's avatar
My Nguyen committed
610
                                             , feqn_fixity = fixity
611
                                             , feqn_rhs   = defn }})})
My Nguyen's avatar
My Nguyen committed
612
  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]
613 614 615
       ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
                                 { hsq_implicit = var_names
                                 , hsq_dependent = emptyNameSet }   -- Yuk
616 617 618 619 620
                             , hsq_explicit = fromMaybe [] mb_bndrs }
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
                                        repTyVarBndr
                                        mb_bndrs
My Nguyen's avatar
My Nguyen committed
621 622 623 624 625 626
            ; tys1 <- case fixity of
                        Prefix -> repTyArgs (repNamedTyCon tc) tys
                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
                                     ; t1' <- repLTy t1
                                     ; t2'  <- repLTy t2
                                     ; repTyArgs (repTInfix t1' tc t2') args }
627
            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
My Nguyen's avatar
My Nguyen committed
628 629 630 631 632

      where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
            checkTys tys@(HsValArg _: HsValArg _: _) = return tys
            checkTys _ = panic "repDataFamInstD:checkTys"

633 634 635 636
repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
  = panic "repDataFamInstD"
repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
  = panic "repDataFamInstD"
637

638
repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
639 640 641
repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
                                  , fd_fi = CImport (dL->L _ cc)
                                                    (dL->L _ s) mch cis _ }))
642
 = do MkC name' <- lookupLOcc name
643
      MkC typ' <- repHsSigType typ
644 645
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
646
      cis' <- conv_cimportspec cis
647
      MkC str <- coreStringLit (static ++ chStr ++ cis')
648 649 650
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
651 652
    conv_cimportspec (CLabel cls)
      = notHandled "Foreign label" (doubleQuotes (ppr cls))
653
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
654 655 656 657
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
658
    conv_cimportspec CWrapper = return "wrapper"
659 660
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
661
    static = case cis of
662
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
663
                 _ -> ""
664
    chStr = case mch of
665 666
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
667
repForD decl = notHandled "Foreign declaration" (ppr decl)
668 669

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
670 671 672 673 674
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
675 676 677

repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName []
678
repSafety PlayInterruptible = rep2 interruptibleName []
679
repSafety PlaySafe = rep2 safeName []
680

681
repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
682
repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))
683
  = do { MkC prec' <- coreIntLit prec
684
       ; let rep_fn = case dir of
685 686 687
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
688 689 690 691 692
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
693
repFixD _ = panic "repFixD"
694

695
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
696 697 698 699 700 701
repRuleD (dL->L loc (HsRule { rd_name = n
                            , rd_act = act
                            , rd_tyvs = ty_bndrs
                            , rd_tmvs = tm_bndrs
                            , rd_lhs = lhs
                            , rd_rhs = rhs }))
702 703 704 705 706 707
  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
            ; ss <- mkGenSyms tm_bndr_names
            ; rule <- addBinds ss $
                      do { ty_bndrs' <- case ty_bndrs of
                             Nothing -> coreNothingList tyVarBndrQTyConName
708 709
                             Just _  -> coreJustList tyVarBndrQTyConName
                                          ex_bndrs
710 711 712 713 714 715 716 717 718 719
                         ; tm_bndrs' <- repList ruleBndrQTyConName
                                                repRuleBndr
                                                tm_bndrs
                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
                         ; act' <- repPhases act
                         ; lhs' <- repLE lhs
                         ; rhs' <- repLE rhs
                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
           ; wrapGenSyms ss rule  }
       ; return (loc, rule) }
720
repRuleD _ = panic "repRuleD"
721

722
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
723 724
ruleBndrNames (dL->L _ (RuleBndr _ n))      = [unLoc n]
ruleBndrNames (dL->L _ (RuleBndrSig _ n sig))
725
  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
726
  = unLoc n : vars
727
ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
728
  = panic "ruleBndrNames"
729
ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
730
  = panic "ruleBndrNames"
731 732
ruleBndrNames (dL->L _ (XRuleBndr _)) = panic "ruleBndrNames"
ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884
733

734
repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
735
repRuleBndr (dL->L _ (RuleBndr _ n))
736
  = do { MkC n' <- lookupLBinder n
737
       ; rep2 ruleVarName [n'] }
738
repRuleBndr (dL->L _ (RuleBndrSig _ n sig))
739
  = do { MkC n'  <- lookupLBinder n
740
       ; MkC ty' <- repLTy (hsSigWcType sig)
741
       ; rep2 typedRuleVarName [n', ty'] }
742
repRuleBndr _ = panic "repRuleBndr"
743

744
repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
745
repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))
746 747 748 749
  = do { target <- repAnnProv ann_prov
       ; exp'   <- repE exp
       ; dec    <- repPragAnn target exp'
       ; return (loc, dec) }
750
repAnnD _ = panic "repAnnD"
751 752

repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
753
repAnnProv (ValueAnnProvenance (dL->L _ n))
754 755
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
756
repAnnProv (TypeAnnProvenance (dL->L _ n))
757 758 759 760 761
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

762
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
763
--                      Constructors
764 765
-------------------------------------------------------

766
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
767 768 769 770
repC (dL->L _ (ConDeclH98 { con_name   = con
                          , con_forall = (dL->L _ False)
                          , con_mb_cxt = Nothing
                          , con_args   = args }))
771
  = repDataCon con args
772

773 774 775 776 777
repC (dL->L _ (ConDeclH98 { con_name = con
                          , con_forall = (dL->L _ is_existential)
                          , con_ex_tvs = con_tvs
                          , con_mb_cxt = mcxt
                          , con_args = args }))
778 779 780 781
  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
         do { c'    <- repDataCon con args
            ; ctxt' <- repMbContext mcxt
            ; if not is_existential && isNothing mcxt
782 783 784 785
              then return c'
              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
            }
       }
786

787 788 789 790 791
repC (dL->L _ (ConDeclGADT { con_names  = cons
                           , con_qvars  = qtvs
                           , con_mb_cxt = mcxt
                           , con_args   = args
                           , con_res_ty = res_ty }))
792 793 794 795 796 797 798
  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables
  , Nothing <- mcxt      -- No context
                         -- ==> no need for a forall
  = repGadtDataCons cons args res_ty

  | otherwise
  = addTyVarBinds qtvs $ \ ex_bndrs ->
799
             -- See Note [Don't quantify implicit type variables in quotes]
800 801 802
    do { c'    <- repGadtDataCons cons args res_ty
       ; ctxt' <- repMbContext mcxt
       ; if null (hsQTvExplicit qtvs) && isNothing mcxt
803
         then return c'
804 805
         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }

806
repC _ = panic "repC"
807 808


809 810
repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
repMbContext Nothing          = repContext []
811
repMbContext (Just (dL->L _ cxt)) = repContext cxt
812

813 814 815 816 817 818 819 820 821 822
repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []
repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []

repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)
repSrcStrictness SrcLazy     = rep2 sourceLazyName         []
repSrcStrictness SrcStrict   = rep2 sourceStrictName       []
repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []

823
repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))
824
repBangTy ty = do
825 826 827
  MkC u <- repSrcUnpackedness su'
  MkC s <- repSrcStrictness ss'
  MkC b <- rep2 bangName [u, s]
828
  MkC t <- repLTy ty'
829
  rep2 bangTypeName [b, t]
830
  where
831 832
    (su', ss', ty') = case unLoc ty of
            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)
833
            _ -> (NoSrcUnpack, NoSrcStrict, ty)
834 835

-------------------------------------------------------
836
--                      Deriving clauses
837 838
-------------------------------------------------------

839
repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
840 841
repDerivs (dL->L _ clauses)
  = repList derivClauseQTyConName repDerivClause clauses
842

843
repDerivClause :: LHsDerivingClause GhcRn
844
               -> DsM (Core TH.DerivClauseQ)
845 846 847
repDerivClause (dL->L _ (HsDerivingClause
                          { deriv_clause_strategy = dcs
                          , deriv_clause_tys      = (dL->L _ dct) }))
848 849 850
  = do MkC dcs' <- repDerivStrategy dcs
       MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
       rep2 derivClauseName [dcs',dct']
851
  where
852
    rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
853 854
    rep_deriv_ty ty = repLTy ty
repDerivClause _ = panic "repDerivClause"
855

856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871
rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
               -> DsM ([GenSymBind], [Core TH.DecQ])
-- Represent signatures and methods in class/instance declarations.
-- See Note [Scoped type variables in class and instance declarations]
--
-- Why not use 'repBinds': we have already created symbols for methods in
-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
-- these fun_id via 'collectHsValBinders decs', which would lead to the
-- instance declarations failing in TH.
rep_sigs_binds sigs binds
  = do { let tvs = concatMap get_scoped_tvs sigs
       ; ss <- mkGenSyms tvs
       ; sigs1 <- addBinds ss $ rep_sigs sigs
       ; binds1 <- addBinds ss $ rep_binds binds
       ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }

872 873 874 875
-------------------------------------------------------
--   Signatures in a class decl, or a group of bindings
-------------------------------------------------------

876
rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
877
        -- We silently ignore ones we don't recognise
878
rep_sigs = concatMapM rep_sig
879

880
rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
881 882 883 884 885 886 887 888 889 890 891
rep_sig (dL->L loc (TypeSig _ nms ty))
  = mapM (rep_wc_ty_sig sigDName loc ty) nms
rep_sig (dL->L loc (PatSynSig _ nms ty))
  = mapM (rep_patsyn_ty_sig loc ty) nms
rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty))
  | is_deflt     = mapM (rep_ty_sig defaultSigDName loc ty) nms
  | otherwise    = mapM (rep_ty_sig sigDName loc ty) nms
rep_sig d@(dL->L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (dL->L _   (FixSig {}))          = return [] -- fixity sigs at top level
rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
rep_sig (dL->L loc (SpecSig _ nm tys ispec))
892
  = concatMapM (\t -> rep_specialise nm t ispec loc) tys
893 894 895 896 897 898
rep_sig (dL->L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc
rep_sig (dL->L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
rep_sig (dL->L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty))
  = rep_complete_sig cls mty loc
rep_sig _ = panic "rep_sig"
899

900
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
901
           -> DsM (SrcSpan, Core TH.DecQ)
902 903 904
-- Don't create the implicit and explicit variables when desugaring signatures,
-- see Note [Scoped type variables in class and instance declarations].
-- and Note [Don't quantify implicit type variables in quotes]
905
rep_ty_sig mk_sig loc sig_ty nm
906 907
  | HsIB { hsib_body = hs_ty } <- sig_ty
  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
908
  = do { nm1 <- lookupLOcc nm
909 910 911 912 913 914 915 916 917 918 919 920 921 922
       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                     ; repTyVarBndrWithKind tv name }
       ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
                                    explicit_tvs

         -- NB: Don't pass any implicit type variables to repList above
         -- See Note [Don't quantify implicit type variables in quotes]

       ; th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
       ; ty1     <- if null explicit_tvs && null (unLoc ctxt)
                       then return th_ty
                       else repTForall th_explicit_tvs th_ctxt th_ty
       ; sig     <- repProto mk_sig nm1 ty1
923
       ; return (loc, sig) }
924
rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"
925

926
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
927
                  -> DsM (SrcSpan, Core TH.DecQ)
928 929
-- represents a pattern synonym type signature;
-- see Note [Pattern synonym type signatures and Template Haskell] in Convert
930 931 932 933
--
-- Don't create the implicit and explicit variables when desugaring signatures,
-- see Note [Scoped type variables in class and instance declarations]
-- and Note [Don't quantify implicit type variables in quotes]
934
rep_patsyn_ty_sig loc sig_ty nm
935 936
  | HsIB { hsib_body = hs_ty } <- sig_ty
  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
937 938 939
  = do { nm1 <- lookupLOcc nm
       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                     ; repTyVarBndrWithKind tv name }
940 941 942
       ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs
       ; th_exis  <- repList tyVarBndrQTyConName rep_in_scope_tv exis

943 944 945
         -- NB: Don't pass any implicit type variables to repList above
         -- See Note [Don't quantify implicit type variables in quotes]

946 947 948 949 950 951
       ; th_reqs  <- repLContext reqs
       ; th_provs <- repLContext provs
       ; th_ty    <- repLTy ty
       ; ty1      <- repTForall th_univs th_reqs =<<
                       repTForall th_exis th_provs th_ty
       ; sig      <- repProto patSynSigDName nm1 ty1
952
       ; return (loc, sig) }
953
rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"
954

955 956 957 958 959
rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
              -> DsM (SrcSpan, Core TH.DecQ)
rep_wc_ty_sig mk_sig loc sig_ty nm
  = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm

960
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
961
           -> InlinePragma      -- Never defaultInlinePragma
962
           -> SrcSpan
963 964
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
965 966 967 968 969
  = do { nm1    <- lookupLOcc nm
       ; inline <- repInline $ inl_inline ispec
       ; rm     <- repRuleMatch $ inl_rule ispec
       ; phases <- repPhases $ inl_act ispec
       ; pragma <- repPragInl nm1 inline rm phases
970 971 972
       ; return [(loc, pragma)]
       }

973 974
rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
               -> SrcSpan
975 976 977
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
978
       ; ty1 <- repHsSigType ty
979 980
       ; phases <- repPhases $ inl_act ispec
       ; let inline = inl_inline ispec
981
       ; pragma <- if noUserInlineSpec inline
982 983 984 985 986
                   then -- SPECIALISE
                     repPragSpec nm1 ty1 phases
                   else -- SPECIALISE INLINE
                     do { inline1 <- repInline inline
                        ; repPragSpecInl nm1 ty1 inline1 phases }
987 988
       ; return [(loc, pragma)]
       }
989

990 991
rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
                   -> DsM [(SrcSpan, Core TH.DecQ)]
992
rep_specialiseInst ty loc
993
  = do { ty1    <- repHsSigType ty
994 995 996
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

997 998 999 1000 1001 1002
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

1003 1004 1005
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
1006

1007
repPhases :: Activation -> DsM (Core TH.Phases)
1008 1009 1010 1011 1012
repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
                                  ; dataCon' beforePhaseDataConName [arg] }
repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i
                                  ; dataCon' fromPhaseDataConName [arg] }
repPhases _                  = dataCon allPhasesDataConName
1013

1014 1015 1016 1017
rep_complete_sig :: Located [Located Name]
                 -> Maybe (Located Name)
                 -> SrcSpan
                 -> DsM [(SrcSpan, Core TH.DecQ)]
1018
rep_complete_sig (dL->L _ cls) mty loc
1019
  = do { mty' <- repMaybe nameTyConName lookupLOcc mty
1020 1021 1022 1023
       ; cls' <- repList nameTyConName lookupLOcc cls
       ; sig <- repPragComplete cls' mty'
       ; return [(loc, sig)] }

1024
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1025
--                      Types
1026
-------------------------------------------------------
1027

1028 1029 1030 1031 1032 1033 1034 1035
addSimpleTyVarBinds :: [Name]                -- the binders to be added
                    -> DsM (Core (TH.Q a))   -- action in the ext env
                    -> DsM (Core (TH.Q a))
addSimpleTyVarBinds names thing_inside
  = do { fresh_names <- mkGenSyms names
       ; term <- addBinds fresh_names thing_inside
       ; wrapGenSyms fresh_names term }

1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048
addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added
                -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
                -> DsM (Core (TH.Q a))
addHsTyVarBinds exp_tvs thing_inside
  = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
       ; term <- addBinds fresh_exp_names $
                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
                                     (exp_tvs `zip` fresh_exp_names)
                    ; thing_inside kbs }
       ; wrapGenSyms fresh_exp_names term }
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)

1049
addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
1050
              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
1051
              -> DsM (Core (TH.Q a))
1052 1053
-- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended
1054
-- meta environment and gets the *new* names on Core-level as an argument
1055 1056
addTyVarBinds (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_tvs}
                      , hsq_explicit = exp_tvs })
1057 1058 1059 1060
              thing_inside
  = addSimpleTyVarBinds imp_tvs $
    addHsTyVarBinds exp_tvs $
    thing_inside
1061
addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"
1062

1063
addTyClTyVarBinds :: LHsQTyVars GhcRn
1064
                  -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
1065
                  -> DsM (Core (TH.Q a))
1066 1067 1068 1069 1070 1071 10