DsMeta.hs 90.3 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 256
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
                repDataDefn tc1 bndrs Nothing defn
257
       ; return (Just (loc, dec)) }
258

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

277 278 279 280 281 282 283 284 285
-------------------------
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) }

286
-------------------------
287 288
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
289
            -> HsDataDefn Name
290
            -> DsM (Core TH.DecQ)
291 292
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
293
                      , dd_cons = cons, dd_derivs = mb_derivs })
294 295
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
296 297 298 299 300 301 302 303 304 305 306 307 308 309
       ; 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 }
       }
310

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

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

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

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

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

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

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

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

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

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

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

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

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

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
522 523 524 525 526
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
527 528 529

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

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

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

560 561
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
562
ruleBndrNames (L _ (RuleBndrSig n sig))
563 564
  | HsIB { hsib_vars = vars } <- sig
  = unLoc n : vars
565

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

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

592
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
593
--                      Constructors
594 595
-------------------------------------------------------

596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614
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'])
            }
       }
615

616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636
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)
                                                   con_vars) ++ tvs }
       ; 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']) } }
637
  where
638
     gadtDetails = gadtDeclDetails res_ty
639

640 641 642 643 644 645 646 647 648 649 650
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))
651
repBangTy ty = do
652 653 654
  MkC u <- repSrcUnpackedness su'
  MkC s <- repSrcStrictness ss'
  MkC b <- rep2 bangName [u, s]
655
  MkC t <- repLTy ty'
656
  rep2 bangTypeName [b, t]
657
  where
658 659 660
    (su', ss', ty') = case ty of
            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
            _ -> (NoSrcUnpack, NoSrcStrict, ty)
661 662

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
663
--                      Deriving clause
664 665
-------------------------------------------------------

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

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

684
rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
685 686 687
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

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

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

707
rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name
708
           -> DsM (SrcSpan, Core TH.DecQ)
709
rep_ty_sig mk_sig loc sig_ty nm
710
  = do { nm1 <- lookupLOcc nm
711
       ; ty1 <- repHsSigType sig_ty
712
       ; sig <- repProto mk_sig nm1 ty1
713
       ; return (loc, sig) }
714 715 716

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

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

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

764
rep_specialiseInst :: LHsSigType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
765
rep_specialiseInst ty loc
766
  = do { ty1    <- repHsSigType ty
767 768 769
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

770 771 772 773 774 775
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

776 777 778
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
779

780
repPhases :: Activation -> DsM (Core TH.Phases)
781 782 783 784 785
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
786 787

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
788
--                      Types
789
-------------------------------------------------------
790

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

806 807 808 809
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
810
       ; term <- addBinds fresh_names $
811 812
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr
                                     (exp_tvs `zip` fresh_exp_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
813
                    ; m kbs }
814
       ; wrapGenSyms fresh_names term }
815 816
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
817

818
addTyClTyVarBinds :: LHsQTyVars Name
819 820
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
821 822 823 824 825 826 827

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
834
       ; term <- addBinds freshNames $
835
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvExplicit tvs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
836
                    ; m kbs }
837 838 839

       ; wrapGenSyms freshNames term }
  where
840
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
841
                       ; repTyVarBndrWithKind tv v }
842 843 844

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

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

860 861
-- represent a type context
--
862 863 864
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

869 870 871 872
repHsSigType :: LHsSigType Name -> DsM (Core TH.TypeQ)
repHsSigType ty = repLTy (hsSigType ty)

repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
873
repHsSigWcType (HsIB { hsib_vars = vars
874 875
                     , hsib_body = sig1 })
  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
876 877 878
  = addTyVarBinds (HsQTvs { hsq_implicit = []
                          , hsq_explicit = map (noLoc . UserTyVar . noLoc) vars ++
                                           explicit_tvs })
879 880 881
                  $ \ th_tvs ->
    do { th_ctxt <- repLContext ctxt
       ; th_ty   <- repLTy ty
882
       ; if null vars && null explicit_tvs && null (unLoc ctxt)
883 884 885
         then return th_ty
         else repTForall th_tvs th_ctxt th_ty }

886 887
-- yield the representation of a list of types
--
888 889
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys
890

891 892
-- represent a type
--
893 894 895
repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
repLTy (L _ ty) = repTy ty

896 897 898 899
repForall :: HsType Name -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty
 | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
900
 = addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs}) $ \bndrs ->
901 902 903
   do { ctxt1  <- repLContext ctxt
      ; ty1    <- repLTy tau
      ; repTForall bndrs ctxt1 ty1 }
thomasw's avatar
thomasw committed
904

905 906 907
repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy ty@(HsForAllTy {}) = repForall ty
repTy ty@(HsQualTy {})   = repForall ty
908

909
repTy (HsTyVar (L _ n))
910
  | isTvOcc occ   = do tv1 <- lookupOcc n
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
911
                       repTvar tv1
912
  | isDataOcc occ = do tc1 <- lookupOcc n
913 914
                       repPromotedDataCon tc1
  | n == eqTyConName = repTequality
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
915 916
  | otherwise     = do tc1 <- lookupOcc n
                       repNamedTyCon tc1
917 918
  where
    occ = nameOccName n
919

920
repTy (HsAppTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
921 922 923
                                f1 <- repLTy f
                                a1 <- repLTy a
                                repTapp f1 a1
924
repTy (HsFunTy f a)         = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
925 926 927 928 929 930 931 932
                                f1   <- repLTy f
                                a1   <- repLTy a
                                tcon <- repArrowTyCon
                                repTapps tcon [f1, a1]
repTy (HsListTy t)          = do
                                t1   <- repLTy t
                                tcon <- repListTyCon
                                repTapp tcon t1
933 934 935 936
repTy (HsPArrTy t)     = do
                           t1   <- repLTy t
                           tcon <- repTy (HsTyVar (noLoc (tyConName parrTyCon)))
                           repTapp tcon t1
batterseapower's avatar
batterseapower committed
937
repTy (HsTupleTy HsUnboxedTuple tys) = do
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
938 939 940
                                tys1 <- repLTys tys
                                tcon <- repUnboxedTupleTyCon (length tys)
                                repTapps tcon tys1
941
repTy (HsTupleTy _ tys)     = do tys1 <- repLTys tys
942 943
                                 tcon <- repTupleTyCon (length tys)
                                 repTapps tcon tys1
944
repTy (HsOpTy ty1 n ty2)    = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
945 946
                                   `nlHsAppTy` ty2)
repTy (HsParTy t)           = repLTy t
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
947 948 949 950 951
repTy (HsEqTy t1 t2) = do
                         t1' <- repLTy t1
                         t2' <- repLTy t2
                         eq  <- repTequality
                         repTapps eq [t1', t2']
952 953
repTy (HsKindSig t k)       = do
                                t1 <- repLTy t
954
                                k1 <- repLKind k
955
                                repTSig t1 k1
956
repTy (HsSpliceTy splice _)     = repSplice splice
957 958 959 960 961 962 963 964 965 966
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
967
repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
thomasw's avatar
thomasw committed
968

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

971
repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
972 973 974 975 976
repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
                            rep2 numTyLitName [iExpr]
repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
                            ; rep2 strTyLitName [s']
                            }
977

978 979
-- represent a kind
--
980 981
repLKind :: LHsKind Name -> DsM (Core TH.Kind)
repLKind ki
dreixel's avatar
dreixel committed
982
  = do { let (kis, ki') = splitHsFunType ki
983 984 985 986 987
       ; 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
988
       }
989

990 991 992 993 994 995 996 997 998
-- | Represent a kind wrapped in a Maybe
repMaybeLKind :: Maybe (LHsKind Name)
              -> DsM (Core (Maybe TH.Kind))
repMaybeLKind Nothing =
    do { coreNothing kindTyConName }
repMaybeLKind (Just ki) =
    do { ki' <- repLKind ki
       ; coreJust kindTyConName ki' }

999 1000 1001 1002
repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
repNonArrowLKind (L _ ki) = repNonArrowKind ki

repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
1003
repNonArrowKind (HsTyVar (L _ name))
1004 1005
  | isLiftedTypeKindTyConName name       = repKStar
  | name `hasKey` constraintKindTyConKey = repKConstraint
1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020
  | isTvOcc (nameOccName name)      = lookupOcc name >>= repKVar
  |