DsMeta.hs 92.9 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

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

18
module DsMeta( dsBracket ) where
19

20 21
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
24
import MatchLit
25 26
import DsMonad

27
import qualified Language.Haskell.TH as TH
28

29
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
30 31 32 33 34 35
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.
36
import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
37

Simon Marlow's avatar
Simon Marlow committed
38 39
import Module
import Id
40
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
41
import THNames
42
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
43 44 45
import TcType
import TyCon
import TysWiredIn
46
import CoreSyn
47
import MkCore
Simon Marlow's avatar
Simon Marlow committed
48 49 50 51
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
52
import Outputable
Simon Marlow's avatar
Simon Marlow committed
53
import Bag
54
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
55 56
import FastString
import ForeignCall
57
import Util
58
import Maybes
59
import MonadUtils
60

61
import Data.ByteString ( unpack )
Simon Marlow's avatar
Simon Marlow committed
62 63
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
64

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

71 72
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
73
  where
74
    new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
75

dreixel's avatar
dreixel committed
76
    do_brack (VarBr _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
77 78 79 80 81
    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"
82
    do_brack (TExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98

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


99
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
100
--                      Declarations
101 102
-------------------------------------------------------

103
repTopP :: LPat Name -> DsM (Core TH.PatQ)
104
repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
105
                 ; pat' <- addBinds ss (repLP pat)
106
                 ; wrapGenSyms ss pat' }
107

108
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
109 110 111 112 113 114 115 116 117 118 119 120 121 122
repTopDs group@(HsGroup { hs_valds   = valds
                        , hs_splcds  = splcds
                        , hs_tyclds  = tyclds
                        , hs_instds  = instds
                        , 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 })
 = do { let { tv_bndrs = hsSigTvBinders valds
123
            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
124
        ss <- mkGenSyms bndrs ;
125

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
126 127 128 129 130 131
        -- 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
132

133
        decls <- addBinds ss (
134 135 136 137 138 139 140 141 142
                  do { val_ds   <- rep_val_binds valds
                     ; _        <- mapM no_splice splcds
                     ; tycl_ds  <- mapM repTyClD (tyClGroupConcat tyclds)
                     ; 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
143 144
                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
                                                           warnds)
145
                     ; ann_ds   <- mapM repAnnD annds
Alan Zimmerman's avatar
Alan Zimmerman committed
146 147
                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
                                                            ruleds)
148 149
                     ; _        <- mapM no_vect vects
                     ; _        <- mapM no_doc docs
150

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
151
                        -- more needed
152
                     ;  return (de_loc $ sort_by_loc $
153 154
                                val_ds ++ catMaybes tycl_ds ++ role_ds
                                       ++ (concat fix_ds)
155
                                       ++ inst_ds ++ rule_ds ++ for_ds
156
                                       ++ ann_ds ++ deriv_ds) }) ;
157

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
158 159
        decl_ty <- lookupType decQTyConName ;
        let { core_list = coreList' decl_ty decls } ;
160

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
161 162
        dec_ty <- lookupType decTyConName ;
        q_decs  <- repSequenceQ dec_ty core_list ;
163

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
164
        wrapGenSyms ss q_decs
165
      }
166 167 168 169 170 171 172 173 174 175 176 177
  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
178

179 180 181
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
182
  = concatMap get_scoped_tvs sigs
183
  where
184 185 186 187 188
    get_scoped_tvs :: LSig Name -> [Name]
    -- Both implicit and explicit quantified variables
    -- We need the implicit ones for   f :: forall (a::k). blah
    --    here 'k' scopes too
    get_scoped_tvs (L _ (TypeSig _ sig))
189
       | HsIB { hsib_vars = implicit_vars
190
              , hsib_body = sig1 } <- sig
191 192
       , (explicit_vars, _) <- splitLHsForAllTy (hswc_body sig1)
       = implicit_vars ++ map hsLTyVarName explicit_vars
193 194
    get_scoped_tvs _ = []

195
    sigs = case binds of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
196 197
             ValBindsIn  _ sigs -> sigs
             ValBindsOut _ sigs -> sigs
198 199 200 201 202 203 204 205 206 207


{- 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.
208
To achieve this we
209 210 211 212 213 214 215 216 217 218

  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

Note [Binders and occurrences]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
219 220
When we desugar [d| data T = MkT |]
we want to get
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
221
        Data "T" [] [Con "MkT" []] []
222
and *not*
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
223
        Data "Foo:T" [] [Con "Foo:MkT" []] []
224 225
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
226
        Data "T79" ....
227 228

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
229 230
        data T = MkT
        foo = reifyDecl T
231 232

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

235 236
So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
And we use lookupOcc, rather than lookupBinder
237 238 239 240
in repTyClD and repC.

-}

241 242
-- represent associated family instances
--
243
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
244

245 246 247
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
248 249 250
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repSynDecl tc1 bndrs rhs
251
       ; return (Just (loc, dec)) }
252

253
repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
254
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
255
       ; tc_tvs <- mk_extra_tvs tc tvs defn
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
256
       ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->
257
                repDataDefn tc1 bndrs Nothing (map hsLTyVarName $ hsQTvExplicit tc_tvs) defn
258
       ; return (Just (loc, dec)) }
259

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
260 261 262
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
                             tcdTyVars = tvs, tcdFDs = fds,
                             tcdSigs = sigs, tcdMeths = meth_binds,
263
                             tcdATs = ats, tcdATDefs = atds }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
264 265
  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
       ; dec  <- addTyVarBinds tvs $ \bndrs ->
266
           do { cxt1   <- repLContext cxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
267 268 269
              ; sigs1  <- rep_sigs sigs
              ; binds1 <- rep_binds meth_binds
              ; fds1   <- repLFunDeps fds
270
              ; ats1   <- repFamilyDecls ats
271 272
              ; atds1  <- repAssocTyFamDefaults atds
              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs1 ++ binds1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
273
              ; repClass cxt1 cls1 bndrs fds1 decls1
274
              }
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
275
       ; return $ Just (loc, dec)
276
       }
277

278 279 280 281 282 283 284 285 286
-------------------------
repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)
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) }

287
-------------------------
288 289 290 291 292 293
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
            -> [Name] -> HsDataDefn Name
            -> DsM (Core TH.DecQ)
repDataDefn tc bndrs opt_tys tv_names
          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
294
                      , dd_cons = cons, dd_derivs = mb_derivs })
295 296 297 298
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
       ; case new_or_data of
           NewType  -> do { con1 <- repC tv_names (head cons)
299 300 301 302 303
                          ; case con1 of
                             [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
                             _cs -> failWithDs (ptext
                                     (sLit "Multiple constructors for newtype:")
                                      <+> pprQuotedList
Alan Zimmerman's avatar
Alan Zimmerman committed
304
                                              (getConNames $ unLoc $ head cons))
305 306 307
                          }
           DataType -> do { consL <- concatMapM (repC tv_names) cons
                          ; cons1 <- coreList conQTyConName consL
308
                          ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }
309

310 311 312 313
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
          -> LHsType Name
          -> DsM (Core TH.DecQ)
repSynDecl tc bndrs ty
314
  = do { ty1 <- repLTy ty
315 316 317
       ; repTySyn tc bndrs ty1 }

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Jan Stolarek's avatar
Jan Stolarek committed
318 319 320 321 322
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
323
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
324
       ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name
325
             mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs }
Jan Stolarek's avatar
Jan Stolarek committed
326 327 328
             resTyVar = case resultSig of
                     TyVarSig bndr -> mkHsQTvs [bndr]
                     _             -> mkHsQTvs []
329
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346
                addTyClTyVarBinds resTyVar $ \_ ->
           case info of
             ClosedTypeFamily Nothing ->
                 notHandled "abstract closed type family" (ppr decl)
             ClosedTypeFamily (Just eqns) ->
               do { eqns1  <- mapM repTyFamEqn eqns
                  ; 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 }
347 348 349
       ; return (loc, dec)
       }

Jan Stolarek's avatar
Jan Stolarek committed
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381
-- | Represent result signature of a type family
repFamilyResultSig :: FamilyResultSig Name -> DsM (Core TH.FamilyResultSig)
repFamilyResultSig  NoSig          = repNoSig
repFamilyResultSig (KindSig ki)    = do { ki' <- repLKind ki
                                        ; 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.
repFamilyResultSigToMaybeKind :: FamilyResultSig Name
                              -> DsM (Core (Maybe TH.Kind))
repFamilyResultSigToMaybeKind NoSig =
    do { coreNothing kindTyConName }
repFamilyResultSigToMaybeKind (KindSig ki) =
    do { ki' <- repLKind ki
       ; coreJust kindTyConName ki' }
repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"

-- | Represent injectivity annotation of a type family
repInjectivityAnn :: Maybe (LInjectivityAnn Name)
                  -> 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 }

382 383
repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
384

385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400
repAssocTyFamDefaults :: [LTyFamDefltEqn Name] -> DsM [Core TH.DecQ]
repAssocTyFamDefaults = mapM rep_deflt
  where
     -- very like repTyFamEqn, but different in the details
    rep_deflt :: LTyFamDefltEqn Name -> DsM (Core TH.DecQ)
    rep_deflt (L _ (TyFamEqn { tfe_tycon = tc
                             , tfe_pats  = bndrs
                             , tfe_rhs   = rhs }))
      = addTyClTyVarBinds bndrs $ \ _ ->
        do { tc1  <- lookupLOcc tc
           ; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
           ; tys2 <- coreList typeQTyConName tys1
           ; rhs1 <- repLTy rhs
           ; eqn1 <- repTySynEqn tys2 rhs1
           ; repTySynInst tc1 eqn1 }

401
-------------------------
402 403
mk_extra_tvs :: Located Name -> LHsQTyVars Name
             -> HsDataDefn Name -> DsM (LHsQTyVars Name)
404 405 406
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
407
mk_extra_tvs tc tvs defn
408
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
409
  = do { extra_tvs <- go hs_kind
410
       ; return (tvs { hsq_explicit = hsq_explicit tvs ++ extra_tvs }) }
411 412
  | otherwise
  = return tvs
413 414 415 416 417 418
  where
    go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
    go (L loc (HsFunTy kind rest))
      = do { uniq <- newUnique
           ; let { occ = mkTyVarOccFS (fsLit "t")
                 ; nm = mkInternalName uniq occ loc
Alan Zimmerman's avatar
Alan Zimmerman committed
419
                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
420 421 422
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

423
    go (L _ (HsTyVar (L _ n)))
424
      |  isLiftedTypeKindTyConName n
425
      = return []
426

427
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
428 429

-------------------------
430 431
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
432
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
433
repLFunDeps fds = repList funDepTyConName repLFunDep fds
434

Alan Zimmerman's avatar
Alan Zimmerman committed
435 436 437 438 439
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'
440

441 442 443
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
444 445 446 447 448 449 450 451
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
452
       ; return (loc, dec) }
453

454 455 456 457
repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)
repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
                         , cid_sigs = prags, cid_tyfam_insts = ats
                         , cid_datafam_insts = adts })
458
  = addSimpleTyVarBinds tvs $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
459 460
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
461
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
462 463 464 465 466 467
            --
            -- 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)
            --
468 469
            do { cxt1 <- repLContext cxt
               ; inst_ty1 <- repLTy inst_ty
470
               ; binds1 <- rep_binds binds
471
               ; prags1 <- rep_sigs prags
472 473 474
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
475
               ; repInst cxt1 inst_ty1 decls }
476
 where
477
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
478

479 480
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
481 482 483 484
  = do { dec <- addSimpleTyVarBinds tvs $
                do { cxt'     <- repLContext cxt
                   ; inst_ty' <- repLTy inst_ty
                   ; repDeriv cxt' inst_ty' }
485 486
       ; return (loc, dec) }
  where
487
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
488

489
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
490
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
491
  = do { let tc_name = tyFamInstDeclLName decl
492
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
493 494
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
495 496

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
497 498 499 500 501
repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
                                             , hsib_vars = var_names }
                           , tfe_rhs = rhs }))
  = do { let hs_tvs = HsQTvs { hsq_implicit = var_names
                             , hsq_explicit = [] }   -- Yuk
502 503 504 505 506 507 508 509
       ; addTyClTyVarBinds hs_tvs $ \ _ ->
         do { tys1 <- repLTys tys
            ; tys2 <- coreList typeQTyConName tys1
            ; rhs1 <- repLTy rhs
            ; repTySynEqn tys2 rhs1 } }

repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
510
                                 , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names }
511
                                 , dfid_defn = defn })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
512
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
513 514
       ; let hs_tvs = HsQTvs { hsq_implicit = var_names
                             , hsq_explicit = [] }   -- Yuk
515
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
516
         do { tys1 <- repList typeQTyConName repLTy tys
517
            ; repDataDefn tc bndrs (Just tys1) var_names defn } }
518

519
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
520 521
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
522
 = do MkC name' <- lookupLOcc name
523
      MkC typ' <- repHsSigType typ
524 525
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
526
      cis' <- conv_cimportspec cis
527
      MkC str <- coreStringLit (static ++ chStr ++ cis')
528 529 530
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
531 532
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
533 534 535 536
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
537
    conv_cimportspec CWrapper = return "wrapper"
538 539
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
540
    static = case cis of
541
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
542
                 _ -> ""
543
    chStr = case mch of
544 545
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
546
repForD decl = notHandled "Foreign declaration" (ppr decl)
547 548

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
549 550 551 552 553
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
554 555 556

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

560 561 562
repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
repFixD (L loc (FixitySig names (Fixity prec dir)))
  = do { MkC prec' <- coreIntLit prec
563
       ; let rep_fn = case dir of
564 565 566
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
567 568 569 570 571
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
572

573 574
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
575 576 577 578
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
579
                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
580 581 582 583 584 585 586
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

587 588
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
589
ruleBndrNames (L _ (RuleBndrSig n sig))
590 591
  | HsIB { hsib_vars = vars } <- sig
  = unLoc n : vars
592

593 594
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
595
  = do { MkC n' <- lookupLBinder n
596
       ; rep2 ruleVarName [n'] }
597
repRuleBndr (L _ (RuleBndrSig n sig))
598
  = do { MkC n'  <- lookupLBinder n
599
       ; MkC ty' <- repLTy (hsSigWcType sig)
600 601
       ; rep2 typedRuleVarName [n', ty'] }

602
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
603
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
604 605 606 607 608 609
  = 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
610
repAnnProv (ValueAnnProvenance (L _ n))
611 612
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
613
repAnnProv (TypeAnnProvenance (L _ n))
614 615 616 617 618
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

619
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
620
--                      Constructors
621 622
-------------------------------------------------------

623
repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
Alan Zimmerman's avatar
Alan Zimmerman committed
624 625 626 627 628 629 630 631 632 633 634 635 636
repC _ (L _ (ConDeclH98 { con_name = con
                        , con_qvars = Nothing, con_cxt = Nothing
                        , con_details = details }))
  = do { con1 <- lookupLOcc con
                 -- See Note [Binders and occurrences]
       ; mapM (\c -> repConstr c details) [con1] }

repC _ (L _ (ConDeclH98 { con_name = con
                        , con_qvars = mcon_tvs, con_cxt = mcxt
                        , con_details = details }))
  = do { let (eq_ctxt, con_tv_subst) = ([], [])
       ; let con_tvs = fromMaybe (HsQTvs [] []) mcon_tvs
       ; let ctxt = unLoc $ fromMaybe (noLoc []) mcxt
637 638
       ; let ex_tvs = HsQTvs { hsq_implicit = filterOut (in_subst con_tv_subst) (hsq_implicit con_tvs)
                             , hsq_explicit = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_explicit con_tvs) }
639

Alan Zimmerman's avatar
Alan Zimmerman committed
640
       ; let binds = []
641
       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
642
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
Alan Zimmerman's avatar
Alan Zimmerman committed
643 644
    do { con1     <- lookupLOcc con -- See Note [Binders and occurrences]
       ; c'        <- repConstr con1 details
645
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
646
       ; if (null (hsq_implicit ex_tvs) && null (hsq_explicit ex_tvs)
Alan Zimmerman's avatar
Alan Zimmerman committed
647 648 649 650 651 652
             && null (eq_ctxt ++ ctxt))
            then return c'
            else rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ [unC c']) }
    ; return [b]
    }
repC tvs (L _ (ConDeclGADT { con_names = cons
653
                           , con_type = res_ty@(HsIB { hsib_vars = con_vars })}))
Alan Zimmerman's avatar
Alan Zimmerman committed
654 655
  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
       ; let ex_tvs
656 657 658 659 660
               = HsQTvs { hsq_implicit = []
                        , hsq_explicit = map (noLoc . UserTyVar . noLoc) $
                                         filterOut
                                          (in_subst con_tv_subst)
                                          con_vars }
Alan Zimmerman's avatar
Alan Zimmerman committed
661 662 663 664 665 666 667 668 669 670

       ; binds <- mapM dupBinder con_tv_subst
       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
    do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
       ; let (details,res_ty',_,_) = gadtDeclDetails res_ty
       ; let doc = ptext (sLit "In the constructor for ") <+> ppr (head cons)
       ; (hs_details,_res_ty) <- update_con_result doc details res_ty'
       ; c'        <- mapM (\c -> repConstr c hs_details) cons1
       ; ctxt'     <- repContext eq_ctxt
671 672 673
       ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
    ; return [b]
    }
674

675 676 677
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
678

Alan Zimmerman's avatar
Alan Zimmerman committed
679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707
update_con_result :: SDoc
            -> HsConDetails (LHsType Name) (Located [LConDeclField Name])
                    -- Original details
            -> LHsType Name -- The original result type
            -> DsM (HsConDetails (LHsType Name) (Located [LConDeclField Name]),
                    LHsType Name)
update_con_result doc details ty
  = do {  let (arg_tys, res_ty) = splitHsFunType ty
                -- We can finally split it up,
                -- now the renamer has dealt with fixities
                -- See Note [Sorting out the result type] in RdrHsSyn

       ; case details of
           InfixCon {}  -> pprPanic "update_con_result" (ppr ty)
           -- See Note [Sorting out the result type] in RdrHsSyn

           RecCon {}    -> do { unless (null arg_tys)
                                       (failWithDs (badRecResTy doc))
                                -- AZ: This error used to be reported during
                                --     renaming, will now be reported in type
                                --     checking. Is this a problem?
                              ; return (details, res_ty) }

           PrefixCon {} -> return (PrefixCon arg_tys, res_ty)}
    where
        badRecResTy :: SDoc -> SDoc
        badRecResTy ctxt = ctxt <+>
                        ptext (sLit "Malformed constructor signature")

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
708
mkGadtCtxt :: [Name]            -- Tyvars of the data type
Alan Zimmerman's avatar
Alan Zimmerman committed
709
           -> LHsSigType Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
710
           -> DsM (HsContext Name, [(Name,Name)])
711 712
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
713 714 715
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
716
-- Example:
717 718
-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
--     mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
719 720 721
--   returns
--     (b~[e], c~e), [d->a]
--
722
-- This function is fiddly, but not really hard
Alan Zimmerman's avatar
Alan Zimmerman committed
723 724
mkGadtCtxt data_tvs res_ty
  | Just (_, tys) <- hsTyGetAppHead_maybe ty
725 726 727
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

728
  | otherwise
729
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
730
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
731 732
    (_,ty',_,_) = gadtDeclDetails res_ty
    (_arg_tys,ty) = splitHsFunType ty'
733 734 735 736
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
737
       , not (in_subst subst con_tv)
738 739 740 741 742
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
743
         eq_pred = L loc (HsEqTy (L loc (HsTyVar (L loc data_tv))) ty)
744

745 746 747
    is_hs_tyvar (L _ (HsTyVar (L _ n))) = Just n  -- Type variables *and* tycons
    is_hs_tyvar (L _ (HsParTy ty))      = is_hs_tyvar ty
    is_hs_tyvar _                       = Nothing
748

749
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
750
repBangTy ty = do
751 752
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
753
  rep2 strictTypeName [s, t]
754
  where
755
    (str, ty') = case ty of
756 757 758 759 760
         L _ (HsBangTy (HsSrcBang _ SrcUnpack SrcStrict) ty)
           -> (unpackedName,  ty)
         L _ (HsBangTy (HsSrcBang _ _         SrcStrict) ty)
           -> (isStrictName,  ty)
         _ -> (notStrictName, ty)
761 762

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
763
--                      Deriving clause
764 765
-------------------------------------------------------

766 767 768 769 770 771 772 773 774 775
repDerivs :: HsDeriving Name -> DsM (Core TH.CxtQ)
repDerivs deriv = do
    let clauses
          | Nothing <- deriv         = []
          | Just (L _ ctxt) <- deriv = ctxt
    tys <- repList typeQTyConName
                   (rep_deriv . hsSigType)
                   clauses
           :: DsM (Core [TH.PredQ])
    repCtxt tys
776
  where
777 778
    rep_deriv :: LHsType Name -> DsM (Core TH.TypeQ)
    rep_deriv (L _ ty) = repTy ty
779 780 781 782 783

-------------------------------------------------------
--   Signatures in a class decl, or a group of bindings
-------------------------------------------------------

784
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
785 786 787
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

788
rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
789
        -- We silently ignore ones we don't recognise
790
rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
791
                     return (concat sigs1) }
792

793
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
794
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms
795
rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
796 797 798
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
799 800
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
801
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
802 803
rep_sig (L loc (SpecSig nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
Alan Zimmerman's avatar
Alan Zimmerman committed
804
rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
805
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
806

807
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
808
           -> DsM (SrcSpan, Core TH.DecQ)
809
rep_ty_sig mk_sig loc sig_ty nm
810
  = do { nm1 <- lookupLOcc nm
811
       ; ty1 <- repHsSigType sig_ty
812
       ; sig <- repProto mk_sig nm1 ty1
813
       ; return (loc, sig) }
814 815 816

rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
              -> DsM (SrcSpan, Core TH.DecQ)
817 818
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
819
rep_wc_ty_sig mk_sig loc sig_ty nm
820
  | HsIB { hsib_vars = implicit_tvs, hsib_body = sig1 } <- sig_ty
821 822 823 824 825 826 827 828 829 830 831 832 833
  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
  = do { nm1 <- lookupLOcc nm
       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                     ; repTyVarBndrWithKind tv name }
             all_tvs = map (noLoc . UserTyVar . noLoc) implicit_tvs ++ explicit_tvs
       ; th_tvs  <- repList tyVarBndrTyConName rep_in_scope_tv all_tvs
       ; th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
       ; ty1 <- if null all_tvs && null (unLoc ctxt)
                then return th_ty
                else repTForall th_tvs th_ctxt th_ty
       ; sig <- repProto mk_sig nm1 ty1
       ; return (loc, sig) }
834

835
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
836
           -> InlinePragma      -- Never defaultInlinePragma
837
           -> SrcSpan
838 839
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
840 841 842 843 844
  = 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
845 846 847
       ; return [(loc, pragma)]
       }

848
rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan
849 850 851
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
852
       ; ty1 <- repHsSigType ty
853 854 855 856 857 858 859 860
       ; phases <- repPhases $ inl_act ispec
       ; let inline = inl_inline ispec
       ; pragma <- if isEmptyInlineSpec inline
                   then -- SPECIALISE
                     repPragSpec nm1 ty1 phases
                   else -- SPECIALISE INLINE
                     do { inline1 <- repInline inline
                        ; repPragSpecInl nm1 ty1 inline1 phases }
861 862
       ; return [(loc, pragma)]
       }
863

864
rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
865
rep_specialiseInst ty loc
866
  = do { ty1    <- repHsSigType ty
867 868 869
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

870 871 872 873 874 875
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

876 877 878
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
879

880 881 882 883 884 885
repPhases :: Activation -> DsM (Core TH.Phases)
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
886 887

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
888
--                      Types
889
-------------------------------------------------------
890

891 892 893 894 895 896 897 898 899
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 }

addTyVarBinds :: LHsQTyVars Name                            -- the binders to be added
900 901
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
902 903
-- 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
904
-- meta environment and gets the *new* names on Core-level as an argument
905

906
addTyVarBinds (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) m
907 908 909 910 911
  = do { fresh_kv_names <- mkGenSyms kvs
       ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)
       ; let fresh_names = fresh_kv_names ++ fresh_tv_names
       ; term <- addBinds fresh_names $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
912
                    ; m kbs }
913
       ; wrapGenSyms fresh_names term }
914 915
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
916

917
addTyClTyVarBinds :: LHsQTyVars Name
918 919
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
920 921 922 923 924 925 926

-- 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
927
  = do { let tv_names = hsAllLTyVarNames tvs
928 929
       ; env <- dsGetMetaEnv
       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
930
            -- Make fresh names for the ones that are not already in scope
931 932
            -- This makes things work for family declarations

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
933
       ; term <- addBinds freshNames $
934
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
935
                    ; m kbs }
936 937 938

       ; wrapGenSyms freshNames term }
  where
939
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
940
                       ; repTyVarBndrWithKind tv v }
941 942 943

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
944
repTyVarBndrWithKind :: LHsTyVarBndr Name
945
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
946
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
947
  = repPlainTV nm
948
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
949
  = repLKind ki >>= repKindedTV nm
950

Jan Stolarek's avatar
Jan Stolarek committed
951 952
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
953 954
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
                                             ; repPlainTV nm' }
Jan Stolarek's avatar
Jan Stolarek committed
955 956 957 958
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
                                                  ; ki' <- repLKind ki
                                                  ; repKindedTV nm' ki' }

959 960
-- represent a type context
--
961 962 963
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

964
repContext :: HsContext Name -> DsM (Core TH.CxtQ)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
965
repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
966
                     repCtxt preds
967

968 969 970 971
repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
repHsSigType ty = repLTy (hsSigType ty)

repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
972
repHsSigWcType (HsIB { hsib_vars = vars
973 974
                     , hsib_body = sig1 })
  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
975 976 977
  = addTyVarBinds (HsQTvs { hsq_implicit = []
                          , hsq_explicit = map (noLoc . UserTyVar . noLoc) vars ++
                                           explicit_tvs })
978 979 980
                  $ \ th_tvs ->
    do { th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
981
       ; if null vars && null explicit_tvs && null (unLoc ctxt)
982 983 984
         then return th_ty
         else repTForall th_tvs th_ctxt th_ty }

985 986
-- yield the representation of a list of types
--
987 988
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
989

990 991
-- represent a type
--
992 993 994
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

995 996 997 998
repForall :: HsType Name -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty
 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
999
 = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs}) $ \bndrs ->
1000 1001 1002
   do { ctxt1  <- repLContext ctxt
      ; ty1    <- repLTy tau
      ; repTForall bndrs ctxt1 ty1 }
thomasw's avatar