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

5
-----------------------------------------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
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
typos  
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

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

31
import qualified Language.Haskell.TH as TH
32

Sylvain Henry's avatar
Sylvain Henry committed
33
import GHC.Hs
Simon Marlow's avatar
Simon Marlow committed
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

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

64
import Data.ByteString ( unpack )
Simon Marlow's avatar
Simon Marlow committed
65 66
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
67

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

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

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
    do_brack (XBracket nec) = noExtCon nec
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103

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


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

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

113
repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))
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_docs    = docs })
125
 = do { let { bndrs  = hsScopedTvBinders valds
126 127
                       ++ 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
                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
143
                     ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
144 145 146 147 148
                     ; 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
                                val_ds ++ catMaybes tycl_ds ++ role_ds
159
                                       ++ kisig_ds
160
                                       ++ (concat fix_ds)
161
                                       ++ inst_ds ++ rule_ds ++ for_ds
162
                                       ++ ann_ds ++ deriv_ds) }) ;
163

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

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

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

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

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

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

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

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

The relevant places are signposted with references to this Note

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

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

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

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

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

280 281 282 283 284 285 286 287 288 289 290 291 292
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

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

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.
299 300
-}

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

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

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

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

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

340
repTyClD _ = panic "repTyClD"
341

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

352 353 354 355 356 357 358
-------------------------
repKiSigD :: LStandaloneKindSig GhcRn -> DsM (SrcSpan, Core TH.DecQ)
repKiSigD (dL->L loc kisig) =
  case kisig of
    StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v
    XStandaloneKindSig nec -> noExtCon nec

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

Ryan Scott's avatar
Ryan Scott committed
388
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
389
           -> LHsType GhcRn
390
           -> DsM (Core TH.DecQ)
391
repSynDecl tc bndrs ty
392
  = do { ty1 <- repLTy ty
393 394
       ; repTySyn tc bndrs ty1 }

395
repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
396 397 398 399 400
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
401
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
402
       ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
403
             mkHsQTvs tvs = HsQTvs { hsq_ext = []
404
                                   , hsq_explicit = tvs }
Jan Stolarek's avatar
Jan Stolarek committed
405
             resTyVar = case resultSig of
406 407
                     TyVarSig _ bndr -> mkHsQTvs [bndr]
                     _               -> mkHsQTvs []
408
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
409 410 411 412 413
                addTyClTyVarBinds resTyVar $ \_ ->
           case info of
             ClosedTypeFamily Nothing ->
                 notHandled "abstract closed type family" (ppr decl)
             ClosedTypeFamily (Just eqns) ->
414
               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
Jan Stolarek's avatar
Jan Stolarek committed
415 416 417 418 419 420 421 422 423 424 425
                  ; 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 }
426 427
       ; return (loc, dec)
       }
428
repFamilyDecl _ = panic "repFamilyDecl"
429

Jan Stolarek's avatar
Jan Stolarek committed
430
-- | Represent result signature of a type family
Ryan Scott's avatar
Ryan Scott committed
431
repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
432 433 434 435 436
repFamilyResultSig (NoSig _)         = repNoSig
repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
                                          ; repKindSig ki' }
repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
                                          ; repTyVarSig bndr' }
437
repFamilyResultSig (XFamilyResultSig nec) = noExtCon nec
Jan Stolarek's avatar
Jan Stolarek committed
438 439 440 441

-- | 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.
442
repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
Ryan Scott's avatar
Ryan Scott committed
443
                              -> DsM (Core (Maybe TH.KindQ))
444
repFamilyResultSigToMaybeKind (NoSig _) =
Ryan Scott's avatar
Ryan Scott committed
445
    do { coreNothing kindQTyConName }
446
repFamilyResultSigToMaybeKind (KindSig _ ki) =
Ryan Scott's avatar
Ryan Scott committed
447 448
    do { ki' <- repLTy ki
       ; coreJust kindQTyConName ki' }
Jan Stolarek's avatar
Jan Stolarek committed
449 450 451
repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"

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

463
repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
464
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
465

466 467
repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ)
repAssocTyFamDefaultD = repTyFamInstD
My Nguyen's avatar
My Nguyen committed
468

469
-------------------------
470 471
-- represent fundeps
--
472
repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
473
repLFunDeps fds = repList funDepTyConName repLFunDep fds
474

475
repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
476
repLFunDep (dL->L _ (xs, ys))
Alan Zimmerman's avatar
Alan Zimmerman committed
477 478 479
   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
        repFunDep xs' ys'
480

481 482
-- Represent instance declarations
--
483
repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
484
repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl }))
485 486
  = do { dec <- repTyFamInstD fi_decl
       ; return (loc, dec) }
487
repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl }))
488 489
  = do { dec <- repDataFamInstD fi_decl
       ; return (loc, dec) }
490
repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl }))
491
  = do { dec <- repClsInstD cls_decl
492
       ; return (loc, dec) }
493
repInstD _ = panic "repInstD"
494

495
repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
496
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
497
                         , cid_sigs = sigs, cid_tyfam_insts = ats
498 499 500
                         , cid_datafam_insts = adts
                         , cid_overlap_mode = overlap
                         })
501
  = addSimpleTyVarBinds tvs $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
502 503
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
504
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
505 506 507 508
            --
            -- 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
509
            -- the selector Ids, not to fresh names (#5410)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
510
            --
511
            do { cxt1     <- repLContext cxt
512
               ; inst_ty1 <- repLTy inst_ty
513
          -- See Note [Scoped type variables in class and instance declarations]
514 515 516 517 518 519 520
               ; (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 }
521
 where
522
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
523
repClsInstD (XClsInstDecl nec) = noExtCon nec
524

525
repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
526 527
repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat
                                          , deriv_type     = ty }))
528 529
  = do { dec <- addSimpleTyVarBinds tvs $
                do { cxt'     <- repLContext cxt
Ryan Scott's avatar
Ryan Scott committed
530
                   ; strat'   <- repDerivStrategy strat
531
                   ; inst_ty' <- repLTy inst_ty
Ryan Scott's avatar
Ryan Scott committed
532
                   ; repDeriv strat' cxt' inst_ty' }
533 534
       ; return (loc, dec) }
  where
535
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
536
repStandaloneDerivD _ = panic "repStandaloneDerivD"
537

538
repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
My Nguyen's avatar
My Nguyen committed
539 540 541
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
  = do { eqn1 <- repTyFamEqn eqn
       ; repTySynInst eqn1 }
542

543
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
544
repTyFamEqn (HsIB { hsib_ext = var_names
My Nguyen's avatar
My Nguyen committed
545 546
                  , hsib_body = FamEqn { feqn_tycon = tc_name
                                       , feqn_bndrs = mb_bndrs
547
                                       , feqn_pats = tys
My Nguyen's avatar
My Nguyen committed
548
                                       , feqn_fixity = fixity
549
                                       , feqn_rhs  = rhs }})
My Nguyen's avatar
My Nguyen committed
550
  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]
551
       ; let hs_tvs = HsQTvs { hsq_ext = var_names
552
                             , hsq_explicit = fromMaybe [] mb_bndrs }
553
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
554 555 556
         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
                                        repTyVarBndr
                                        mb_bndrs
My Nguyen's avatar
My Nguyen committed
557 558 559 560 561 562
            ; 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 }
563
            ; rhs1 <- repLTy rhs
My Nguyen's avatar
My Nguyen committed
564 565 566 567
            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }
     where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
           checkTys tys@(HsValArg _:HsValArg _:_) = return tys
           checkTys _ = panic "repTyFamEqn:checkTys"
568 569
repTyFamEqn (XHsImplicitBndrs nec) = noExtCon nec
repTyFamEqn (HsIB _ (XFamEqn nec)) = noExtCon nec
570

My Nguyen's avatar
My Nguyen committed
571 572 573 574 575
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 }
576 577 578
repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
                                       ; ki' <- repLTy ki
                                       ; repTyArgs (repTappKind f' ki') as }
My Nguyen's avatar
My Nguyen committed
579 580
repTyArgs f (HsArgPar _ : as) = repTyArgs f as

581
repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
582
repDataFamInstD (DataFamInstDecl { dfid_eqn =
583
                  (HsIB { hsib_ext = var_names
584
                        , hsib_body = FamEqn { feqn_tycon = tc_name
585
                                             , feqn_bndrs = mb_bndrs
586
                                             , feqn_pats  = tys
My Nguyen's avatar
My Nguyen committed
587
                                             , feqn_fixity = fixity
588
                                             , feqn_rhs   = defn }})})
My Nguyen's avatar
My Nguyen committed
589
  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]
590
       ; let hs_tvs = HsQTvs { hsq_ext = var_names
591 592 593 594 595
                             , hsq_explicit = fromMaybe [] mb_bndrs }
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
                                        repTyVarBndr
                                        mb_bndrs
My Nguyen's avatar
My Nguyen committed
596 597 598 599 600 601
            ; 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 }
602
            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
My Nguyen's avatar
My Nguyen committed
603 604 605 606 607

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

608 609 610 611
repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs nec))
  = noExtCon nec
repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn nec)))
  = noExtCon nec
612

613
repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
614 615 616
repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
                                  , fd_fi = CImport (dL->L _ cc)
                                                    (dL->L _ s) mch cis _ }))
617
 = do MkC name' <- lookupLOcc name
618
      MkC typ' <- repHsSigType typ
619 620
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
621
      cis' <- conv_cimportspec cis
622
      MkC str <- coreStringLit (static ++ chStr ++ cis')
623 624 625
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
626 627
    conv_cimportspec (CLabel cls)
      = notHandled "Foreign label" (doubleQuotes (ppr cls))
628
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
629 630 631 632
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
633
    conv_cimportspec CWrapper = return "wrapper"
634 635
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
636
    static = case cis of
637
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
638
                 _ -> ""
639
    chStr = case mch of
640 641
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
642
repForD decl = notHandled "Foreign declaration" (ppr decl)
643 644

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
645 646 647 648 649
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
650 651 652

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

656
repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
657
repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))
658
  = do { MkC prec' <- coreIntLit prec
659
       ; let rep_fn = case dir of
660 661 662
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
663 664 665 666 667
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
668
repFixD _ = panic "repFixD"
669

670
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
671 672 673 674 675 676
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 }))
677 678 679 680 681 682
  = 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
683 684
                             Just _  -> coreJustList tyVarBndrQTyConName
                                          ex_bndrs
685 686 687 688 689 690 691 692 693 694
                         ; 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) }
695
repRuleD _ = panic "repRuleD"
696

697
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
698 699
ruleBndrNames (dL->L _ (RuleBndr _ n))      = [unLoc n]
ruleBndrNames (dL->L _ (RuleBndrSig _ n sig))
700
  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
701
  = unLoc n : vars
702
ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
703
  = panic "ruleBndrNames"
704
ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
705
  = panic "ruleBndrNames"
706
ruleBndrNames (dL->L _ (XRuleBndr nec)) = noExtCon nec
707
ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
708

709
repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
710
repRuleBndr (dL->L _ (RuleBndr _ n))
711
  = do { MkC n' <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
712
       ; rep2 ruleVarName [n'] }
713
repRuleBndr (dL->L _ (RuleBndrSig _ n sig))
714
  = do { MkC n'  <- lookupLBinder n
715
       ; MkC ty' <- repLTy (hsSigWcType sig)
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
716
       ; rep2 typedRuleVarName [n', ty'] }
717
repRuleBndr _ = panic "repRuleBndr"
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
718

719
repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
720
repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))
721 722 723 724
  = do { target <- repAnnProv ann_prov
       ; exp'   <- repE exp
       ; dec    <- repPragAnn target exp'
       ; return (loc, dec) }
725
repAnnD _ = panic "repAnnD"
726 727

repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
728
repAnnProv (ValueAnnProvenance (dL->L _ n))
729 730
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
731
repAnnProv (TypeAnnProvenance (dL->L _ n))
732 733 734 735 736
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

737
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
738
--                      Constructors
739 740
-------------------------------------------------------

741
repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)