DsMeta.hs 90.7 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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
43
import NameSet
Simon Marlow's avatar
Simon Marlow committed
44 45 46
import TcType
import TyCon
import TysWiredIn
47
import CoreSyn
48
import MkCore
Simon Marlow's avatar
Simon Marlow committed
49 50 51 52
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
53
import Outputable
Simon Marlow's avatar
Simon Marlow committed
54
import Bag
55
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
56 57
import FastString
import ForeignCall
58
import Util
59
import Maybes
60
import MonadUtils
61

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

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

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

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

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


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

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

109
repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
110 111 112 113 114 115 116 117 118 119 120 121 122 123
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
124
            ; bndrs = tv_bndrs ++ hsGroupBinders group } ;
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
125
        ss <- mkGenSyms bndrs ;
126

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

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

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

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

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

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

180 181 182
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
183
  = concatMap get_scoped_tvs sigs
184
  where
185 186 187 188 189
    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))
190
       | HsIB { hsib_vars = implicit_vars
191
              , hsib_body = sig1 } <- sig
192 193
       , (explicit_vars, _) <- splitLHsForAllTy (hswc_body sig1)
       = implicit_vars ++ map hsLTyVarName explicit_vars
194 195
    get_scoped_tvs _ = []

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


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

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

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

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

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

-}

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

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

254
repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
255
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
256 257
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repDataDefn tc1 bndrs Nothing 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
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
290
            -> HsDataDefn Name
291
            -> DsM (Core TH.DecQ)
292 293
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
294
                      , dd_cons = cons, dd_derivs = mb_derivs })
295 296
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
297 298 299 300 301 302 303 304 305 306 307 308 309 310
       ; case (new_or_data, cons) of
           (NewType, [con])  -> do { con'  <- repC con
                                   ; ksig' <- repMaybeLKind ksig
                                   ; repNewtype cxt1 tc bndrs opt_tys ksig' con'
                                                derivs1 }
           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
                                       <+> pprQuotedList
                                       (getConNames $ unLoc $ head cons))
           (DataType, _) -> do { ksig' <- repMaybeLKind ksig
                               ; consL <- mapM repC cons
                               ; cons1 <- coreList conQTyConName consL
                               ; repData cxt1 tc bndrs opt_tys ksig' cons1
                                         derivs1 }
       }
311

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

repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Jan Stolarek's avatar
Jan Stolarek committed
320 321 322 323 324
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
325
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
326
       ; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
327 328
             mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs
                                   , hsq_dependent = emptyNameSet }
Jan Stolarek's avatar
Jan Stolarek committed
329 330 331
             resTyVar = case resultSig of
                     TyVarSig bndr -> mkHsQTvs [bndr]
                     _             -> mkHsQTvs []
332
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
Jan Stolarek's avatar
Jan Stolarek committed
333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349
                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 }
350 351 352
       ; return (loc, dec)
       }

Jan Stolarek's avatar
Jan Stolarek committed
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 382 383 384
-- | 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 }

385 386
repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]
repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
387

388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403
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 }

404
-------------------------
405 406
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
407
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
408
repLFunDeps fds = repList funDepTyConName repLFunDep fds
409

Alan Zimmerman's avatar
Alan Zimmerman committed
410 411 412 413 414
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'
415

416 417 418
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
419 420 421 422 423 424 425 426
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
427
       ; return (loc, dec) }
428

429 430 431 432
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 })
433
  = addSimpleTyVarBinds tvs $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
434 435
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
436
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
437 438 439 440 441 442
            --
            -- 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)
            --
443 444
            do { cxt1 <- repLContext cxt
               ; inst_ty1 <- repLTy inst_ty
445
               ; binds1 <- rep_binds binds
446
               ; prags1 <- rep_sigs prags
447 448 449
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
450
               ; repInst cxt1 inst_ty1 decls }
451
 where
452
   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
453

454 455
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
456 457 458 459
  = do { dec <- addSimpleTyVarBinds tvs $
                do { cxt'     <- repLContext cxt
                   ; inst_ty' <- repLTy inst_ty
                   ; repDeriv cxt' inst_ty' }
460 461
       ; return (loc, dec) }
  where
462
    (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
463

464
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
465
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
466
  = do { let tc_name = tyFamInstDeclLName decl
467
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
468 469
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
470 471

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
472 473 474 475
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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
476 477
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
478 479 480 481 482 483 484 485
       ; 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
486
                                 , dfid_pats = HsIB { hsib_body = tys, hsib_vars = var_names }
487
                                 , dfid_defn = defn })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
488
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
489
       ; let hs_tvs = HsQTvs { hsq_implicit = var_names
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
490 491
                             , hsq_explicit = []
                             , hsq_dependent = emptyNameSet }   -- Yuk
492
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
493
         do { tys1 <- repList typeQTyConName repLTy tys
494
            ; repDataDefn tc bndrs (Just tys1) defn } }
495

496
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
497 498
repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
                              , fd_fi = CImport (L _ cc) (L _ s) mch cis _ }))
499
 = do MkC name' <- lookupLOcc name
500
      MkC typ' <- repHsSigType typ
501 502
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
503
      cis' <- conv_cimportspec cis
504
      MkC str <- coreStringLit (static ++ chStr ++ cis')
505 506 507
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
508 509
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
510 511 512 513
    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
                            = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                            = panic "conv_cimportspec: values not supported yet"
514
    conv_cimportspec CWrapper = return "wrapper"
515 516
    -- these calling conventions do not support headers and the static keyword
    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
517
    static = case cis of
518
                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
519
                 _ -> ""
520
    chStr = case mch of
521 522
            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
            _ -> ""
523
repForD decl = notHandled "Foreign declaration" (ppr decl)
524 525

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
526 527 528 529 530
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
531 532 533

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

537
repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
538
repFixD (L loc (FixitySig names (Fixity _ prec dir)))
539
  = do { MkC prec' <- coreIntLit prec
540
       ; let rep_fn = case dir of
541 542 543
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
544 545 546 547 548
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
549

550 551
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
552 553 554 555
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
556
                     ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
557 558 559 560 561 562 563
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

564 565
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
566
ruleBndrNames (L _ (RuleBndrSig n sig))
567 568
  | HsIB { hsib_vars = vars } <- sig
  = unLoc n : vars
569

570 571
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
572
  = do { MkC n' <- lookupLBinder n
573
       ; rep2 ruleVarName [n'] }
574
repRuleBndr (L _ (RuleBndrSig n sig))
575
  = do { MkC n'  <- lookupLBinder n
576
       ; MkC ty' <- repLTy (hsSigWcType sig)
577 578
       ; rep2 typedRuleVarName [n', ty'] }

579
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
580
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
581 582 583 584 585 586
  = 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
587
repAnnProv (ValueAnnProvenance (L _ n))
588 589
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
590
repAnnProv (TypeAnnProvenance (L _ n))
591 592 593 594 595
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

596
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
597
--                      Constructors
598 599
-------------------------------------------------------

600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618
repC :: LConDecl Name -> DsM (Core TH.ConQ)
repC (L _ (ConDeclH98 { con_name = con
                      , con_qvars = Nothing, con_cxt = Nothing
                      , con_details = details }))
  = repDataCon con details

repC (L _ (ConDeclH98 { con_name = con
                      , con_qvars = mcon_tvs, con_cxt = mcxt
                      , con_details = details }))
  = do { let con_tvs = fromMaybe emptyLHsQTvs mcon_tvs
             ctxt    = unLoc $ fromMaybe (noLoc []) mcxt
       ; addTyVarBinds con_tvs $ \ ex_bndrs ->
         do { c'    <- repDataCon con details
            ; ctxt' <- repContext ctxt
            ; if isEmptyLHsQTvs con_tvs && null ctxt
              then return c'
              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
            }
       }
619

620 621 622 623 624 625 626 627 628 629 630 631 632 633
repC (L _ (ConDeclGADT { con_names = cons
                       , con_type = res_ty@(HsIB { hsib_vars = con_vars })}))
  | (details, res_ty', L _ [] , []) <- gadtDetails
  , [] <- con_vars
    -- no implicit or explicit variables, no context = no need for a forall
  = do { let doc = text "In the constructor for " <+> ppr (head cons)
       ; (hs_details, gadt_res_ty) <-
           updateGadtResult failWithDs doc details res_ty'
       ; repGadtDataCons cons hs_details gadt_res_ty }

  | (details,res_ty',ctxt, tvs) <- gadtDetails
  = do { let doc = text "In the constructor for " <+> ppr (head cons)
             con_tvs = HsQTvs { hsq_implicit = []
                              , hsq_explicit = (map (noLoc . UserTyVar . noLoc)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
634 635
                                                   con_vars) ++ tvs
                              , hsq_dependent = emptyNameSet }
636 637 638 639 640 641
       ; addTyVarBinds con_tvs $ \ ex_bndrs -> do
       { (hs_details, gadt_res_ty) <-
           updateGadtResult failWithDs doc details res_ty'
       ; c'    <- repGadtDataCons cons hs_details gadt_res_ty
       ; ctxt' <- repContext (unLoc ctxt)
       ; rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } }
642
  where
643
     gadtDetails = gadtDeclDetails res_ty
644

645 646 647 648 649 650 651 652 653 654 655
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 []

repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ))
656
repBangTy ty = do
657 658 659
  MkC u <- repSrcUnpackedness su'
  MkC s <- repSrcStrictness ss'
  MkC b <- rep2 bangName [u, s]
660
  MkC t <- repLTy ty'
661
  rep2 bangTypeName [b, t]
662
  where
663 664 665
    (su', ss', ty') = case ty of
            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
            _ -> (NoSrcUnpack, NoSrcStrict, ty)
666 667

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
668
--                      Deriving clause
669 670
-------------------------------------------------------

671 672
repDerivs :: HsDeriving Name -> DsM (Core TH.CxtQ)
repDerivs deriv = do
673 674 675
    let clauses = case deriv of
                    Nothing         -> []
                    Just (L _ ctxt) -> ctxt
676 677 678 679 680
    tys <- repList typeQTyConName
                   (rep_deriv . hsSigType)
                   clauses
           :: DsM (Core [TH.PredQ])
    repCtxt tys
681
  where
682 683
    rep_deriv :: LHsType Name -> DsM (Core TH.TypeQ)
    rep_deriv (L _ ty) = repTy ty
684 685 686 687 688

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

689
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
690 691 692
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

698
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
699
rep_sig (L loc (TypeSig nms ty))      = mapM (rep_wc_ty_sig sigDName loc ty) nms
700
rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
701 702 703
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
704 705
rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
706
rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
707 708
rep_sig (L loc (SpecSig nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec loc) tys
Alan Zimmerman's avatar
Alan Zimmerman committed
709
rep_sig (L loc (SpecInstSig _ ty))    = rep_specialiseInst ty loc
710
rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
711

712
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
713
           -> DsM (SrcSpan, Core TH.DecQ)
714
rep_ty_sig mk_sig loc sig_ty nm
715
  = do { nm1 <- lookupLOcc nm
716
       ; ty1 <- repHsSigType sig_ty
717
       ; sig <- repProto mk_sig nm1 ty1
718
       ; return (loc, sig) }
719 720 721

rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
              -> DsM (SrcSpan, Core TH.DecQ)
722 723
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
724
rep_wc_ty_sig mk_sig loc sig_ty nm
725
  | HsIB { hsib_vars = implicit_tvs, hsib_body = sig1 } <- sig_ty
726 727 728 729 730 731 732 733 734 735 736 737 738
  , (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) }
739

740
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
741
           -> InlinePragma      -- Never defaultInlinePragma
742
           -> SrcSpan
743 744
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
745 746 747 748 749
  = 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
750 751 752
       ; return [(loc, pragma)]
       }

753
rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan
754 755 756
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
757
       ; ty1 <- repHsSigType ty
758 759 760 761 762 763 764 765
       ; 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 }
766 767
       ; return [(loc, pragma)]
       }
768

769
rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
770
rep_specialiseInst ty loc
771
  = do { ty1    <- repHsSigType ty
772 773 774
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

775 776 777 778 779 780
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

781 782 783
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
784

785
repPhases :: Activation -> DsM (Core TH.Phases)
786 787 788 789 790
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
791 792

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
793
--                      Types
794
-------------------------------------------------------
795

796 797 798 799 800 801 802 803 804
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
805 806
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
807 808
-- 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
809
-- meta environment and gets the *new* names on Core-level as an argument
810

811 812 813 814
addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) m
  = do { fresh_imp_names <- mkGenSyms imp_tvs
       ; fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
       ; let fresh_names = fresh_imp_names ++ fresh_exp_names
815
       ; term <- addBinds fresh_names $
816 817
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr
                                     (exp_tvs `zip` fresh_exp_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
818
                    ; m kbs }
819
       ; wrapGenSyms fresh_names term }
820 821
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
822

823
addTyClTyVarBinds :: LHsQTyVars Name
824 825
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
826 827 828 829 830 831 832

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
839
       ; term <- addBinds freshNames $
840
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
841
                    ; m kbs }
842 843 844

       ; wrapGenSyms freshNames term }
  where
845
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
846
                       ; repTyVarBndrWithKind tv v }
847 848 849

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
850
repTyVarBndrWithKind :: LHsTyVarBndr Name
851
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
852
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
853
  = repPlainTV nm
854
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
855
  = repLKind ki >>= repKindedTV nm
856

Jan Stolarek's avatar
Jan Stolarek committed
857 858
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
859 860
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
                                             ; repPlainTV nm' }
Jan Stolarek's avatar
Jan Stolarek committed
861 862 863 864
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
                                                  ; ki' <- repLKind ki
                                                  ; repKindedTV nm' ki' }

865 866
-- represent a type context
--
867 868 869
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

874
repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
875 876 877
repHsSigType (HsIB { hsib_vars = vars
                   , hsib_body = body })
  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
878 879
  = addTyVarBinds (HsQTvs { hsq_implicit = []
                          , hsq_explicit = map (noLoc . UserTyVar . noLoc) vars ++
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
880 881
                                           explicit_tvs
                          , hsq_dependent = emptyNameSet })
882 883 884
                  $ \ th_tvs ->
    do { th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
885
       ; if null vars && null explicit_tvs && null (unLoc ctxt)
886 887 888
         then return th_ty
         else repTForall th_tvs th_ctxt th_ty }

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
889 890 891 892
repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
repHsSigWcType ib_ty@(HsIB { hsib_body = sig1 })
  = repHsSigType (ib_ty { hsib_body = hswc_body sig1 })

893 894
-- yield the representation of a list of types
--
895 896
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
897

898 899
-- represent a type
--
900 901 902
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

903 904 905 906
repForall :: HsType Name -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty
 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
907 908
 = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs
                         , hsq_dependent = emptyNameSet }) $ \bndrs ->
909 910 911
   do { ctxt1  <- repLContext ctxt
      ; ty1    <- repLTy tau
      ; repTForall bndrs ctxt1 ty1 }
thomasw's avatar
thomasw committed
912

913 914 915
repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {}) = repForall ty
repTy ty@(HsQualTy {})   = repForall ty
916

917
repTy (HsTyVar (L _ n))
918
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
919
                       repTvar tv1
920
  | isDataOcc occ = do tc1 <- lookupOcc n
921 922
                       repPromotedDataCon tc1
  | n == eqTyConName = repTequality
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
923 924
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
925 926
  where
    occ = nameOccName n
927

928
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
929 930 931
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
932
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
933 934 935 936 937 938 939 940
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
941 942 943 944
repTy (HsPArrTy t)     = do
                           t1   <- repLTy t
                           tcon <- repTy (HsTyVar (noLoc (tyConName parrTyCon)))
                           repTapp tcon t1
batterseapower's avatar
batterseapower committed
945
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
946 947 948
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
949
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
950 951
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
952
repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
953 954
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
955 956 957 958 959
repTy (HsEqTy t1 t2) = do
                         t1' <- repLTy t1
                         t2' <- repLTy t2
                         eq  <- repTequality
                         repTapps eq [t1', t2']
960 961
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
962
                                k1 <- repLKind k
963
                                repTSig t1 k1
964
repTy (HsSpliceTy splice _)     = repSplice splice
965 966 967 968 969 970 971 972 973 974
repTy (HsExplicitListTy _ tys)  = do
                                    tys1 <- repLTys tys
                                    repTPromotedList tys1
repTy (HsExplicitTupleTy _ tys) = do
                                    tys1 <- repLTys tys
                                    tcon <- repPromotedTupleTyCon (length tys)
                                    repTapps tcon tys1
repTy (HsTyLit lit) = do
                        lit' <- repTyLit lit
                        repTLit lit'
thomasw's avatar
thomasw committed
975
repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
thomasw's avatar
thomasw committed
976

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
977
repTy ty                      = notHandled "Exotic form of type" (ppr ty)
978

979
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
980 981 982 983 984
repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
                            rep2 numTyLitName [iExpr]
repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
                            ; rep2 strTyLitName [s']
                            }
985

986 987
-- represent a kind
--
988 989
repLKind :: LHsKind Name -> DsM (Core TH.Kind)
repLKind ki
dreixel's avatar
dreixel committed
990
  = do { let (kis, ki') = splitHsFunType ki
991 992 993 994 995
       ; kis_rep <- mapM repLKind kis
       ; ki'_rep <- repNonArrowLKind ki'
       ; kcon <- repKArrow
       ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2
       ; foldrM f ki'_rep kis_rep
996
       }
997

998 999 1000 1001 1002