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

4
-----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
5 6 7
--
-- (c) The University of Glasgow 2006
--
8 9 10 11
-- 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.
12 13
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
Gabor Greif's avatar
typos  
Gabor Greif committed
14
-- in prelude/PrelNames.  It's much more convenient to do it here, because
15 16
-- otherwise we have to recompile PrelNames whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
17 18
-----------------------------------------------------------------------------

19
module DsMeta( dsBracket ) where
20

21 22
#include "HsVersions.h"

23 24
import GhcPrelude

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

Simon Marlow's avatar
Simon Marlow committed
27
import MatchLit
28 29
import DsMonad

30
import qualified Language.Haskell.TH as TH
31

32
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
33 34 35 36 37 38
import Class
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

Simon Marlow's avatar
Simon Marlow committed
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
Simon Marlow's avatar
Simon Marlow committed
47 48 49
import TcType
import TyCon
import TysWiredIn
50
import CoreSyn
51
import MkCore
Simon Marlow's avatar
Simon Marlow committed
52 53 54 55
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
56
import Outputable
Simon Marlow's avatar
Simon Marlow committed
57
import Bag
58
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
59 60
import FastString
import ForeignCall
61
import Util
62
import Maybes
63
import MonadUtils
64

65
import Data.ByteString ( unpack )
Simon Marlow's avatar
Simon Marlow committed
66 67
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
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
    new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
79

Ben Gamari's avatar
Ben Gamari committed
80 81 82 83 84 85 86
    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 }
87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102

{- -------------- 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))
-}


103
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
104
--                      Declarations
105 106
-------------------------------------------------------

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

112
repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))
113 114 115 116 117 118 119 120 121 122 123 124
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_vects   = vects
                        , hs_docs    = docs })
125 126 127
 = do { let { bndrs  = hsSigTvBinders valds
                       ++ hsGroupBinders group
                       ++ hsPatSynSelectors valds
128
            ; instds = tyclds >>= group_instds } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
129
        ss <- mkGenSyms bndrs ;
130

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
131 132 133 134 135 136
        -- 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
137

138
        decls <- addBinds ss (
139 140
                  do { val_ds   <- rep_val_binds valds
                     ; _        <- mapM no_splice splcds
141
                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
142 143 144 145 146 147
                     ; 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
148 149
                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
                                                           warnds)
150
                     ; ann_ds   <- mapM repAnnD annds
Alan Zimmerman's avatar
Alan Zimmerman committed
151 152
                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
                                                            ruleds)
153 154
                     ; _        <- mapM no_vect vects
                     ; _        <- 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 172 173 174 175 176 177 178 179 180 181 182
  where
    no_splice (L loc _)
      = notHandledL loc "Splices within declaration brackets" empty
    no_default_decl (L loc decl)
      = notHandledL loc "Default declarations" (ppr decl)
    no_warn (L loc (Warning thing _))
      = notHandledL loc "WARNING and DEPRECATION pragmas" $
                    text "Pragma for declaration of" <+> ppr thing
    no_vect (L loc decl)
      = notHandledL loc "Vectorisation pragmas" (ppr decl)
    no_doc (L loc _)
      = notHandledL loc "Haddock documentation" empty
183

184
hsSigTvBinders :: HsValBinds GhcRn -> [Name]
185 186
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
187
  = concatMap get_scoped_tvs sigs
188 189
  where
    sigs = case binds of
Ben Gamari's avatar
Ben Gamari committed
190 191
             ValBindsIn  _ sigs -> sigs
             ValBindsOut _ sigs -> sigs
192

193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212
get_scoped_tvs :: LSig GhcRn -> [Name]
get_scoped_tvs (L _ signature)
  | TypeSig _ sig <- signature
  = get_scoped_tvs_from_sig (hswc_body sig)
  | ClassOpSig _ _ sig <- signature
  = get_scoped_tvs_from_sig sig
  | PatSynSig _ sig <- signature
  = 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
      | HsIB { hsib_vars = implicit_vars
             , hsib_body = hs_ty } <- sig
      , (explicit_vars, _) <- splitLHsForAllTy hs_ty
      = implicit_vars ++ map hsLTyVarName explicit_vars

213 214 215 216 217 218 219 220
{- 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.
221
To achieve this we
222 223 224 225 226 227 228 229

  a) Gensym a binding for 'a' at the same time as we do one for 'f'
     collecting the relevant binders with hsSigTvBinders

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

The relevant places are signposted with references to this Note

230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254
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.

255 256
Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
257 258
When we desugar [d| data T = MkT |]
we want to get
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
259
        Data "T" [] [Con "MkT" []] []
260
and *not*
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
261
        Data "Foo:T" [] [Con "Foo:MkT" []] []
262 263
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
264
        Data "T79" ....
265 266

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

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

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

277 278 279 280 281 282 283 284 285 286 287 288 289
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

Gabor Greif's avatar
Gabor Greif committed
290
Notice that we explicitly quantified the variable `k`! This is quite bad, as the
291 292 293 294 295 296 297
latter declaration requires -XTypeInType, while the former does not. Not to
mention that the latter declaration isn't even what the user wrote in the
first place.

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 306
repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)

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

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

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

336
-------------------------
337
repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
338 339 340 341 342 343 344
repRoleD (L loc (RoleAnnotDecl tycon roles))
  = do { tycon1 <- lookupLOcc tycon
       ; roles1 <- mapM repRole roles
       ; roles2 <- coreList roleTyConName roles1
       ; dec <- repRoleAnnotD tycon1 roles2
       ; return (loc, dec) }

345
-------------------------
Ryan Scott's avatar
Ryan Scott committed
346
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ]
347
            -> Maybe (Core [TH.TypeQ])
348
            -> HsDataDefn GhcRn
349
            -> DsM (Core TH.DecQ)
350 351
repDataDefn tc bndrs opt_tys
          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
352
                      , dd_cons = cons, dd_derivs = mb_derivs })
353 354
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
355 356
       ; case (new_or_data, cons) of
           (NewType, [con])  -> do { con'  <- repC con
Ryan Scott's avatar
Ryan Scott committed
357
                                   ; ksig' <- repMaybeLTy ksig
358 359 360 361 362
                                   ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
                                                derivs1 }
           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
                                       <+> pprQuotedList
                                       (getConNames $ unLoc $ head cons))
Ryan Scott's avatar
Ryan Scott committed
363
           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
364 365 366 367 368
                               ; consL <- mapM repC cons
                               ; cons1 <- coreList conQTyConName consL
                               ; repData cxt1 tc bndrs opt_tys ksig' cons1
                                         derivs1 }
       }
369

Ryan Scott's avatar
Ryan Scott committed
370
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
371
           -> LHsType GhcRn
372
           -> DsM (Core TH.DecQ)
373
repSynDecl tc bndrs ty
374
  = do { ty1 <- repLTy ty
375 376
       ; repTySyn tc bndrs ty1 }

377
repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
Jan Stolarek's avatar
Jan Stolarek committed
378 379 380 381 382
repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info,
                                        fdLName     = tc,
                                        fdTyVars    = tvs,
                                        fdResultSig = L _ resultSig,
                                        fdInjectivityAnn = injectivity }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
383
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
384
       ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
385 386
             mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs
                                   , hsq_dependent = emptyNameSet }
Jan Stolarek's avatar
Jan Stolarek committed
387 388 389
             resTyVar = case resultSig of
                     TyVarSig bndr -> mkHsQTvs [bndr]
                     _             -> mkHsQTvs []
390
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
391 392 393 394 395
                addTyClTyVarBinds resTyVar $ \_ ->
           case info of
             ClosedTypeFamily Nothing ->
                 notHandled "abstract closed type family" (ppr decl)
             ClosedTypeFamily (Just eqns) ->
396
               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
Jan Stolarek's avatar
Jan Stolarek committed
397 398 399 400 401 402 403 404 405 406 407
                  ; 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 }
408 409 410
       ; return (loc, dec)
       }

Jan Stolarek's avatar
Jan Stolarek committed
411
-- | Represent result signature of a type family
Ryan Scott's avatar
Ryan Scott committed
412
repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
Jan Stolarek's avatar
Jan Stolarek committed
413
repFamilyResultSig  NoSig          = repNoSig
Ryan Scott's avatar
Ryan Scott committed
414
repFamilyResultSig (KindSig ki)    = do { ki' <- repLTy ki
Jan Stolarek's avatar
Jan Stolarek committed
415 416 417 418 419 420 421
                                        ; repKindSig ki' }
repFamilyResultSig (TyVarSig bndr) = do { bndr' <- repTyVarBndr bndr
                                        ; repTyVarSig bndr' }

-- | 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.
422
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
Ryan Scott's avatar
Ryan Scott committed
423
                              -> DsM (Core (Maybe TH.KindQ))
Jan Stolarek's avatar
Jan Stolarek committed
424
repFamilyResultSigToMaybeKind NoSig =
Ryan Scott's avatar
Ryan Scott committed
425
    do { coreNothing kindQTyConName }
Jan Stolarek's avatar
Jan Stolarek committed
426
repFamilyResultSigToMaybeKind (KindSig ki) =
Ryan Scott's avatar
Ryan Scott committed
427 428
    do { ki' <- repLTy ki
       ; coreJust kindQTyConName ki' }
Jan Stolarek's avatar
Jan Stolarek committed
429 430 431
repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"

-- | Represent injectivity annotation of a type family
432
repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
Jan Stolarek's avatar
Jan Stolarek committed
433 434 435 436 437 438 439 440 441 442
                  -> DsM (Core (Maybe TH.InjectivityAnn))
repInjectivityAnn Nothing =
    do { coreNothing injAnnTyConName }
repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =
    do { lhs'   <- lookupBinder (unLoc lhs)
       ; rhs1   <- mapM (lookupBinder . unLoc) rhs
       ; rhs2   <- coreList nameTyConName rhs1
       ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]
       ; coreJust injAnnTyConName injAnn }

443
repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
444
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
445

446
repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ]
447 448 449
repAssocTyFamDefaults = mapM rep_deflt
  where
     -- very like repTyFamEqn, but different in the details
450
    rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
451 452 453
    rep_deflt (L _ (FamEqn { feqn_tycon = tc
                           , feqn_pats  = bndrs
                           , feqn_rhs   = rhs }))
454 455 456 457 458 459 460 461
      = addTyClTyVarBinds bndrs $ \ _ ->
        do { tc1  <- lookupLOcc tc
           ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
           ; tys2 <- coreList typeQTyConName tys1
           ; rhs1 <- repLTy rhs
           ; eqn1 <- repTySynEqn tys2 rhs1
           ; repTySynInst tc1 eqn1 }

462
-------------------------
463 464
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
465
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
466
repLFunDeps fds = repList funDepTyConName repLFunDep fds
467

Alan Zimmerman's avatar
Alan Zimmerman committed
468 469 470 471 472
repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys))
   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
        repFunDep xs' ys'
473

474 475
-- Represent instance declarations
--
476
repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
477 478 479 480 481 482 483 484
repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
  = do { dec <- repTyFamInstD fi_decl
       ; return (loc, dec) }
repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
  = do { dec <- repDataFamInstD fi_decl
       ; return (loc, dec) }
repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
  = do { dec <- repClsInstD cls_decl
485
       ; return (loc, dec) }
486

487
repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
488
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
489
                         , cid_sigs = sigs, cid_tyfam_insts = ats
490 491 492
                         , cid_datafam_insts = adts
                         , cid_overlap_mode = overlap
                         })
493
  = addSimpleTyVarBinds tvs $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
494 495
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
496
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
497 498 499 500 501 502
            --
            -- 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)
            --
503
            do { cxt1     <- repLContext cxt
504
               ; inst_ty1 <- repLTy inst_ty
505 506 507 508 509 510 511 512
               -- See Note [Scoped type variables in class and instance declarations]
               ; (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 }
513
 where
514
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
515

516
repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
Ryan Scott's avatar
Ryan Scott committed
517 518
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
                                      , deriv_type     = ty }))
519 520
  = do { dec <- addSimpleTyVarBinds tvs $
                do { cxt'     <- repLContext cxt
Ryan Scott's avatar
Ryan Scott committed
521
                   ; strat'   <- repDerivStrategy strat
522
                   ; inst_ty' <- repLTy inst_ty
Ryan Scott's avatar
Ryan Scott committed
523
                   ; repDeriv strat' cxt' inst_ty' }
524 525
       ; return (loc, dec) }
  where
526
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
527

528
repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
529
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
530
  = do { let tc_name = tyFamInstDeclLName decl
531
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
532 533
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
534

535 536 537 538
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (HsIB { hsib_vars = var_names
                  , hsib_body = FamEqn { feqn_pats = tys
                                       , feqn_rhs  = rhs }})
539
  = do { let hs_tvs = HsQTvs { hsq_implicit = var_names
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
540 541
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
542 543 544 545 546 547
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
         do { tys1 <- repLTys tys
            ; tys2 <- coreList typeQTyConName tys1
            ; rhs1 <- repLTy rhs
            ; repTySynEqn tys2 rhs1 } }

548
repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
549 550 551 552 553
repDataFamInstD (DataFamInstDecl { dfid_eqn =
                  (HsIB { hsib_vars = var_names
                        , hsib_body = FamEqn { feqn_tycon = tc_name
                                             , feqn_pats  = tys
                                             , feqn_rhs   = defn }})})
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
554
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
555
       ; let hs_tvs = HsQTvs { hsq_implicit = var_names
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
556 557
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
558
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
559
         do { tys1 <- repList typeQTyConName repLTy tys
560
            ; repDataDefn tc bndrs (Just tys1) defn } }
561

562
repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
563 564
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
565
 = do MkC name' <- lookupLOcc name
566
      MkC typ' <- repHsSigType typ
567 568
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
569
      cis' <- conv_cimportspec cis
570
      MkC str <- coreStringLit (static ++ chStr ++ cis')
571 572 573
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
574 575
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
576 577 578 579
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
580
    conv_cimportspec CWrapper = return "wrapper"
581 582
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
583
    static = case cis of
584
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
585
                 _ -> ""
586
    chStr = case mch of
587 588
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
589
repForD decl = notHandled "Foreign declaration" (ppr decl)
590 591

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
592 593 594 595 596
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
597 598 599

repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName []
600
repSafety PlayInterruptible = rep2 interruptibleName []
Ian Lynagh's avatar
Ian Lynagh committed
601
repSafety PlaySafe = rep2 safeName []
602

603
repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
604
repFixD (L loc (FixitySig names (Fixity _ prec dir)))
605
  = do { MkC prec' <- coreIntLit prec
606
       ; let rep_fn = case dir of
607 608 609
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
610 611 612 613 614
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
615

616
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
617
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
618 619 620 621
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
622
                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
623 624 625 626 627 628 629
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

630
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
631
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
632
ruleBndrNames (L _ (RuleBndrSig n sig))
633
  | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig
634
  = unLoc n : vars
635

636
repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
637
repRuleBndr (L _ (RuleBndr n))
638
  = do { MkC n' <- lookupLBinder n
639
       ; rep2 ruleVarName [n'] }
640
repRuleBndr (L _ (RuleBndrSig n sig))
641
  = do { MkC n'  <- lookupLBinder n
642
       ; MkC ty' <- repLTy (hsSigWcType sig)
643 644
       ; rep2 typedRuleVarName [n', ty'] }

645
repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
646
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
647 648 649 650 651 652
  = do { target <- repAnnProv ann_prov
       ; exp'   <- repE exp
       ; dec    <- repPragAnn target exp'
       ; return (loc, dec) }

repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
Alan Zimmerman's avatar
Alan Zimmerman committed
653
repAnnProv (ValueAnnProvenance (L _ n))
654 655
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
656
repAnnProv (TypeAnnProvenance (L _ n))
657 658 659 660 661
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

662
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
663
--                      Constructors
664 665
-------------------------------------------------------

666
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
667
repC (L _ (ConDeclH98 { con_name = con
668 669 670 671
                      , con_forall = False
                      , con_mb_cxt = Nothing
                      , con_args = args }))
  = repDataCon con args
672 673

repC (L _ (ConDeclH98 { con_name = con
674 675 676 677 678 679 680 681
                      , con_forall = is_existential
                      , con_ex_tvs = con_tvs
                      , con_mb_cxt = mcxt
                      , con_args = args }))
  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
         do { c'    <- repDataCon con args
            ; ctxt' <- repMbContext mcxt
            ; if not is_existential && isNothing mcxt
682 683 684 685
              then return c'
              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
            }
       }
686

687
repC (L _ (ConDeclGADT { con_names = cons
688 689 690 691 692 693 694 695 696
                       , con_qvars = qtvs, con_mb_cxt = mcxt
                       , con_args = args, con_res_ty = res_ty }))
  | 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 ->
697
             -- See Note [Don't quantify implicit type variables in quotes]
698 699 700
    do { c'    <- repGadtDataCons cons args res_ty
       ; ctxt' <- repMbContext mcxt
       ; if null (hsQTvExplicit qtvs) && isNothing mcxt
701
         then return c'
702 703 704 705 706
         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }

repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
repMbContext Nothing          = repContext []
repMbContext (Just (L _ cxt)) = repContext cxt
707

708 709 710 711 712 713 714 715 716 717
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 []

718
repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))
719
repBangTy ty = do
720 721 722
  MkC u <- repSrcUnpackedness su'
  MkC s <- repSrcStrictness ss'
  MkC b <- rep2 bangName [u, s]
723
  MkC t <- repLTy ty'
724
  rep2 bangTypeName [b, t]
725
  where
726
    (su', ss', ty') = case ty of
Ben Gamari's avatar
Ben Gamari committed
727
            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
728
            _ -> (NoSrcUnpack, NoSrcStrict, ty)
729 730

-------------------------------------------------------
Ryan Scott's avatar
Ryan Scott committed
731
--                      Deriving clauses
732 733
-------------------------------------------------------

734
repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
Ryan Scott's avatar
Ryan Scott committed
735 736
repDerivs (L _ clauses) = repList derivClauseQTyConName repDerivClause clauses

737
repDerivClause :: LHsDerivingClause GhcRn
Ryan Scott's avatar
Ryan Scott committed
738 739 740 741 742 743
               -> DsM (Core TH.DerivClauseQ)
repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs
                                      , deriv_clause_tys      = L _ dct }))
  = do MkC dcs' <- repDerivStrategy dcs
       MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
       rep2 derivClauseName [dcs',dct']
744
  where
745
    rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
Ryan Scott's avatar
Ryan Scott committed
746
    rep_deriv_ty (L _ ty) = repTy ty
747

748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763
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))) }

764 765 766 767
-------------------------------------------------------
--   Signatures in a class decl, or a group of bindings
-------------------------------------------------------

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

772
rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
773
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms
774
rep_sig (L loc (PatSynSig nms ty))    = mapM (rep_patsyn_ty_sig loc ty) nms
775 776 777
rep_sig (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
778 779
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
780
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
781
rep_sig (L loc (SpecSig nm tys ispec))
782
  = concatMapM (\t -> rep_specialise nm t ispec loc) tys
Alan Zimmerman's avatar
Alan Zimmerman committed
783
rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
784
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
785
rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
786 787
rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc

788
rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
789
           -> DsM (SrcSpan, Core TH.DecQ)
790 791 792
-- 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]
793
rep_ty_sig mk_sig loc sig_ty nm
794 795
  | HsIB { hsib_body = hs_ty } <- sig_ty
  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
796
  = do { nm1 <- lookupLOcc nm
797 798 799 800 801 802 803 804 805 806 807 808 809 810
       ; 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
811
       ; return (loc, sig) }
812

813
rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
814
                  -> DsM (SrcSpan, Core TH.DecQ)
815 816
-- represents a pattern synonym type signature;
-- see Note [Pattern synonym type signatures and Template Haskell] in Convert
817 818 819 820
--
-- 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]
821
rep_patsyn_ty_sig loc sig_ty nm
822 823
  | HsIB { hsib_body = hs_ty } <- sig_ty
  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
824 825 826
  = do { nm1 <- lookupLOcc nm
       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                     ; repTyVarBndrWithKind tv name }
827 828 829
       ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs
       ; th_exis  <- repList tyVarBndrQTyConName rep_in_scope_tv exis

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

833 834 835 836 837 838
       ; 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
839
       ; return (loc, sig) }
840

841 842 843 844 845
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

846
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
847
           -> InlinePragma      -- Never defaultInlinePragma
848
           -> SrcSpan
849 850
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
851 852 853 854 855
  = 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
856 857 858
       ; return [(loc, pragma)]
       }

859 860
rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
               -> SrcSpan
861 862 863
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
864
       ; ty1 <- repHsSigType ty
865 866
       ; phases <- repPhases $ inl_act ispec
       ; let inline = inl_inline ispec
867
       ; pragma <- if noUserInlineSpec inline
868 869 870 871 872
                   then -- SPECIALISE
                     repPragSpec nm1 ty1 phases
                   else -- SPECIALISE INLINE
                     do { inline1 <- repInline inline
                        ; repPragSpecInl nm1 ty1 inline1 phases }
873 874
       ; return [(loc, pragma)]
       }
875

876 877
rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
                   -> DsM [(SrcSpan, Core TH.DecQ)]
878
rep_specialiseInst ty loc
879
  = do { ty1    <- repHsSigType ty
880 881 882
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

883 884 885 886 887 888
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

889 890 891
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
892

893
repPhases :: Activation -> DsM (Core TH.Phases)
894 895 896 897 898
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
899

900 901 902 903 904 905 906 907 908 909 910 911 912 913 914
rep_complete_sig :: Located [Located Name]
                 -> Maybe (Located Name)
                 -> SrcSpan
                 -> DsM [(SrcSpan, Core TH.DecQ)]
rep_complete_sig (L _ cls) mty loc
  = do { mty' <- rep_maybe_name mty
       ; cls' <- repList nameTyConName lookupLOcc cls
       ; sig <- repPragComplete cls' mty'
       ; return [(loc, sig)] }
  where
    rep_maybe_name Nothing = coreNothing nameTyConName
    rep_maybe_name (Just n) = do
      cn <- lookupLOcc n
      coreJust nameTyConName cn

915
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
916
--                      Types
917
-------------------------------------------------------
918

919 920 921 922 923 924 925 926
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 }

927 928 929 930 931 932 933 934 935 936 937 938 939
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)

940
addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
Ryan Scott's avatar
Ryan Scott committed
941
              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
942
              -> DsM (Core (TH.Q a))
943 944
-- 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
945
-- meta environment and gets the *new* names on Core-level as an argument
946 947 948 949 950
addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs })
              thing_inside
  = addSimpleTyVarBinds imp_tvs $
    addHsTyVarBinds exp_tvs $
    thing_inside
951

952
addTyClTyVarBinds :: LHsQTyVars GhcRn
Ryan Scott's avatar
Ryan Scott committed
953
                  -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
954
                  -> DsM (Core (TH.Q a))
955 956 957 958 959 960 961

-- Used for data/newtype declarations, and family instances,
-- so that the nested type variables work right
--    instance C (T a) where
--      type W (T a) = blah
-- The 'a' in the type instance is the one bound by the instance decl
addTyClTyVarBinds tvs m
962
  = do { let tv_names = hsAllLTyVarNames tvs
963 964
       ; env <- dsGetMetaEnv
       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
965
            -- Make fresh names for the ones that are not already in scope
966 967
            -- This makes things work for family declarations

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
968
       ; term <- addBinds freshNames $
Ryan Scott's avatar
Ryan Scott committed
969 970
                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
                                     (hsQTvExplicit tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
971
                    ; m kbs }
972 973 974

       ; wrapGenSyms freshNames term }
  where
Ryan Scott's avatar
Ryan Scott committed
975
    mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
976
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
977
                       ; repTyVarBndrWithKind tv v }
978 979 980

-- Produce kinded binder constructors from the Haskell tyvar binders
--
981
repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
Ryan Scott's avatar
Ryan Scott committed
982
                     -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
Ben Gamari's avatar
Ben Gamari committed
983
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
984
  = repPlainTV nm
Ben Gamari's avatar
Ben Gamari committed
985
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
Ryan Scott's avatar
Ryan Scott committed
986
  = repLTy ki >>= repKindedTV nm
987

Jan Stolarek's avatar
Jan Stolarek committed
988
-- | Represent a type variable binder
Ryan Scott's avatar
Ryan Scott committed
989
repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
Ben Gamari's avatar
Ben Gamari committed
990 991 992 993 994
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
                                             ; repPlainTV nm' }
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
                                                  ; ki' <- repLTy ki
                                                  ; repKindedTV nm' ki' }
Jan Stolarek's avatar
Jan Stolarek committed
995