DsMeta.hs 118 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,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
19 20
               templateHaskellNames, qTyConName, nameTyConName,
               liftName, liftStringName, expQTyConName, patQTyConName,
21
               decQTyConName, decsQTyConName, typeQTyConName,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
22
               decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,
23
               quoteExpName, quotePatName, quoteDecName, quoteTypeName,
24 25
               tExpTyConName, tExpDataConName, unTypeName, unTypeQName,
               unsafeTExpCoerceName
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
26
                ) where
27

28 29
#include "HsVersions.h"

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

Simon Marlow's avatar
Simon Marlow committed
32
import MatchLit
33 34
import DsMonad

35
import qualified Language.Haskell.TH as TH
36

37
import HsSyn
Simon Marlow's avatar
Simon Marlow committed
38 39 40 41 42 43
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.
44
import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName )
45

Simon Marlow's avatar
Simon Marlow committed
46 47
import Module
import Id
48
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
49
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
50 51 52
import TcType
import TyCon
import TysWiredIn
53
import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
54
import CoreSyn
55
import MkCore
Simon Marlow's avatar
Simon Marlow committed
56 57 58 59
import CoreUtils
import SrcLoc
import Unique
import BasicTypes
60
import Outputable
Simon Marlow's avatar
Simon Marlow committed
61
import Bag
62
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
63 64
import FastString
import ForeignCall
65
import Util
66
import MonadUtils
67

Simon Marlow's avatar
Simon Marlow committed
68 69 70
import Data.Maybe
import Control.Monad
import Data.List
Ian Lynagh's avatar
Ian Lynagh committed
71

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

78 79
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
80
  where
81
    new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices]
82

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

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


106
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
107
--                      Declarations
108 109
-------------------------------------------------------

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

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

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
158
                        -- more needed
159
                     ;  return (de_loc $ sort_by_loc $
160 161
                                val_ds ++ catMaybes tycl_ds ++ role_ds
                                       ++ (concat fix_ds)
162
                                       ++ inst_ds ++ rule_ds ++ for_ds
163
                                       ++ ann_ds ++ deriv_ds) }) ;
164

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

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

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
171
        wrapGenSyms ss q_decs
172
      }
173 174 175 176 177 178 179 180 181 182 183 184
  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
185

186 187 188
hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings]
hsSigTvBinders binds
thomasw's avatar
thomasw committed
189
  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs
190
                     , tv <- hsQTvBndrs qtvs]
191 192
  where
    sigs = case binds of
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
193 194
             ValBindsIn  _ sigs -> sigs
             ValBindsOut _ sigs -> sigs
195 196 197 198 199 200 201 202 203 204


{- 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.
205
To achieve this we
206 207 208 209 210 211 212 213 214 215

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

But if we see this:
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
226 227
        data T = MkT
        foo = reifyDecl T
228 229

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

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

-}

238 239
-- represent associated family instances
--
240
repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
241

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

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

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

-- Un-handled cases
275
repTyClD (L loc d) = putSrcSpanDs loc $
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
276 277
                     do { warnDs (hang ds_msg 4 (ppr d))
                        ; return Nothing }
278

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

288
-------------------------
289 290 291 292 293 294
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]
            -> Maybe (Core [TH.TypeQ])
            -> [Name] -> HsDataDefn Name
            -> DsM (Core TH.DecQ)
repDataDefn tc bndrs opt_tys tv_names
          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
295
                      , dd_cons = cons, dd_derivs = mb_derivs })
296 297 298 299
  = do { cxt1     <- repLContext cxt
       ; derivs1  <- repDerivs mb_derivs
       ; case new_or_data of
           NewType  -> do { con1 <- repC tv_names (head cons)
300 301 302 303 304 305 306 307 308
                          ; case con1 of
                             [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1
                             _cs -> failWithDs (ptext
                                     (sLit "Multiple constructors for newtype:")
                                      <+> pprQuotedList
                                                (con_names $ unLoc $ head cons))
                          }
           DataType -> do { consL <- concatMapM (repC tv_names) cons
                          ; cons1 <- coreList conQTyConName consL
309
                          ; repData cxt1 tc bndrs opt_tys 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)
319
repFamilyDecl (L loc (FamilyDecl { fdInfo    = info,
320
                                   fdLName   = tc,
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
321 322 323
                                   fdTyVars  = tvs,
                                   fdKindSig = opt_kind }))
  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
324
       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
325
           case (opt_kind, info) of
326 327 328 329 330 331 332 333
                  (Nothing, ClosedTypeFamily eqns) ->
                    do { eqns1 <- mapM repTyFamEqn eqns
                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
                       ; repClosedFamilyNoKind tc1 bndrs eqns2 }
                  (Just ki, ClosedTypeFamily eqns) ->
                    do { eqns1 <- mapM repTyFamEqn eqns
                       ; eqns2 <- coreList tySynEqnQTyConName eqns1
                       ; ki1 <- repLKind ki
334
                       ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }
335 336 337 338 339
                  (Nothing, _) ->
                    do { info' <- repFamilyInfo info
                       ; repFamilyNoKind info' tc1 bndrs }
                  (Just ki, _) ->
                    do { info' <- repFamilyInfo info
340
                       ; ki1 <- repLKind ki
341
                       ; repFamilyKind info' tc1 bndrs ki1 }
342 343 344 345 346
       ; return (loc, dec)
       }

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

-------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
349
mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
350
             -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)
351 352 353
-- If there is a kind signature it must be of form
--    k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
354
mk_extra_tvs tc tvs defn
355
  | HsDataDefn { dd_kindSig = Just hs_kind } <- defn
356
  = do { extra_tvs <- go hs_kind
357
       ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }
358 359
  | otherwise
  = return tvs
360 361 362 363 364 365
  where
    go :: LHsKind Name -> DsM [LHsTyVarBndr Name]
    go (L loc (HsFunTy kind rest))
      = do { uniq <- newUnique
           ; let { occ = mkTyVarOccFS (fsLit "t")
                 ; nm = mkInternalName uniq occ loc
Alan Zimmerman's avatar
Alan Zimmerman committed
366
                 ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }
367 368 369 370 371 372
           ; hs_tvs <- go rest
           ; return (hs_tv : hs_tvs) }

    go (L _ (HsTyVar n))
      | n == liftedTypeKindTyConName
      = return []
373

374
    go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)
375 376

-------------------------
377 378
-- represent fundeps
--
Alan Zimmerman's avatar
Alan Zimmerman committed
379
repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])
380
repLFunDeps fds = repList funDepTyConName repLFunDep fds
381

Alan Zimmerman's avatar
Alan Zimmerman committed
382 383 384 385 386
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'
387

388 389
-- represent family declaration flavours
--
390 391 392 393
repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)
repFamilyInfo OpenTypeFamily      = rep2 typeFamName []
repFamilyInfo DataFamily          = rep2 dataFamName []
repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"
394

395 396 397
-- Represent instance declarations
--
repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)
398 399 400 401 402 403 404 405
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
406
       ; return (loc, dec) }
407

408 409 410 411 412
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 })
  = addTyVarBinds tvs $ \_ ->
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
413 414
            -- We must bring the type variables into scope, so their
            -- occurrences don't fail, even though the binders don't
415
            -- appear in the resulting data structure
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
416 417 418 419 420 421
            --
            -- 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)
            --
422
            do { cxt1 <- repContext cxt
423
               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
batterseapower's avatar
batterseapower committed
424 425
               ; cls_tys <- repLTys tys
               ; inst_ty1 <- repTapps cls_tcon cls_tys
426
               ; binds1 <- rep_binds binds
427
               ; prags1 <- rep_sigs prags
428 429 430
               ; ats1 <- mapM (repTyFamInstD . unLoc) ats
               ; adts1 <- mapM (repDataFamInstD . unLoc) adts
               ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)
431
               ; repInst cxt1 inst_ty1 decls }
432
 where
433
   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
434

435 436 437 438 439 440 441 442 443 444 445 446
repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
  = do { dec <- addTyVarBinds tvs $ \_ ->
                do { cxt' <- repContext cxt
                   ; cls_tcon <- repTy (HsTyVar (unLoc cls))
                   ; cls_tys <- repLTys tys
                   ; inst_ty <- repTapps cls_tcon cls_tys
                   ; repDeriv cxt' inst_ty }
       ; return (loc, dec) }
  where
    Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty

447
repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
448
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
449
  = do { let tc_name = tyFamInstDeclLName decl
450
       ; tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
451 452
       ; eqn1 <- repTyFamEqn eqn
       ; repTySynInst tc eqn1 }
453 454

repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)
455 456 457 458
repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys
                                               , hswb_kvs = kv_names
                                               , hswb_tvs = tv_names }
                                 , tfe_rhs = rhs }))
459 460 461 462 463 464 465 466 467 468 469 470
  = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names
                             , hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
       ; 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
                                 , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
                                 , dfid_defn = defn })
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
471
  = do { tc <- lookupLOcc tc_name               -- See note [Binders and occurrences]
472
       ; let loc = getLoc tc_name
473
             hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names }   -- Yuk
474
       ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
475
         do { tys1 <- repList typeQTyConName repLTy tys
476
            ; repDataDefn tc bndrs (Just tys1) tv_names defn } }
477

478
repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
479
repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
480 481 482 483
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
484
      cis' <- conv_cimportspec cis
485
      MkC str <- coreStringLit (static ++ chStr ++ cis')
486 487 488
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
489 490
    conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
491 492
    conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
    conv_cimportspec (CFunction (StaticTarget _  _ False)) = panic "conv_cimportspec: values not supported yet"
493
    conv_cimportspec CWrapper = return "wrapper"
494
    static = case cis of
495
                 CFunction (StaticTarget _ _ _) -> "static "
496
                 _ -> ""
497 498 499
    chStr = case mch of
            Nothing -> ""
            Just (Header h) -> unpackFS h ++ " "
500
repForD decl = notHandled "Foreign declaration" (ppr decl)
501 502

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
503 504 505 506 507
repCCallConv CCallConv          = rep2 cCallName []
repCCallConv StdCallConv        = rep2 stdCallName []
repCCallConv CApiConv           = rep2 cApiCallName []
repCCallConv PrimCallConv       = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
508 509 510

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

514 515 516
repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]
repFixD (L loc (FixitySig names (Fixity prec dir)))
  = do { MkC prec' <- coreIntLit prec
517
       ; let rep_fn = case dir of
518 519 520
                        InfixL -> infixLDName
                        InfixR -> infixRDName
                        InfixN -> infixNDName
521 522 523 524 525
       ; let do_one name
              = do { MkC name' <- lookupLOcc name
                   ; dec <- rep2 rep_fn [prec', name']
                   ; return (loc,dec) }
       ; mapM do_one names }
526

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
527 528
repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
529 530 531 532
  = do { let bndr_names = concatMap ruleBndrNames bndrs
       ; ss <- mkGenSyms bndr_names
       ; rule1 <- addBinds ss $
                  do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
533
                     ; n'   <- coreStringLit $ unpackFS $ unLoc n
534 535 536 537 538 539 540
                     ; act' <- repPhases act
                     ; lhs' <- repLE lhs
                     ; rhs' <- repLE rhs
                     ; repPragRule n' bndrs' lhs' rhs' act' }
       ; rule2 <- wrapGenSyms ss rule1
       ; return (loc, rule2) }

541 542 543
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n))      = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))
544
  = unLoc n : kvs ++ tvs
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
545

546 547
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
repRuleBndr (L _ (RuleBndr n))
548
  = do { MkC n' <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
549
       ; rep2 ruleVarName [n'] }
550
repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))
551
  = do { MkC n'  <- lookupLBinder n
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
552 553 554
       ; MkC ty' <- repLTy ty
       ; rep2 typedRuleVarName [n', ty'] }

555
repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)
Alan Zimmerman's avatar
Alan Zimmerman committed
556
repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
557 558 559 560 561 562
  = 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
563
repAnnProv (ValueAnnProvenance (L _ n))
564 565
  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
       ; rep2 valueAnnotationName [ n' ] }
Alan Zimmerman's avatar
Alan Zimmerman committed
566
repAnnProv (TypeAnnProvenance (L _ n))
567 568 569 570 571
  = do { MkC n' <- globalVar n
       ; rep2 typeAnnotationName [ n' ] }
repAnnProv ModuleAnnProvenance
  = rep2 moduleAnnotationName []

Ian Lynagh's avatar
Ian Lynagh committed
572
ds_msg :: SDoc
Ian Lynagh's avatar
Ian Lynagh committed
573
ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
574

575
-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
576
--                      Constructors
577 578
-------------------------------------------------------

579 580
repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]
repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []
581
                     , con_details = details, con_res = ResTyH98 }))
582
  | null (hsQTvBndrs con_tvs)
583 584
  = do { con1 <- mapM lookupLOcc con       -- See Note [Binders and occurrences]
       ; mapM (\c -> repConstr c details) con1  }
585

586
repC tvs (L _ (ConDecl { con_names = cons
587 588 589 590
                       , con_qvars = con_tvs, con_cxt = L _ ctxt
                       , con_details = details
                       , con_res = res_ty }))
  = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
591 592 593
       ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)
                             , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
594
       ; binds <- mapM dupBinder con_tv_subst
595
       ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
596
         addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
597 598
    do { cons1     <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
       ; c'        <- mapM (\c -> repConstr c details) cons1
599
       ; ctxt'     <- repContext (eq_ctxt ++ ctxt)
600 601 602
       ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }
    ; return [b]
    }
603

604 605 606
in_subst :: [(Name,Name)] -> Name -> Bool
in_subst []          _ = False
in_subst ((n',_):ns) n = n==n' || in_subst ns n
607

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
608
mkGadtCtxt :: [Name]            -- Tyvars of the data type
609
           -> ResType (LHsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
610
           -> DsM (HsContext Name, [(Name,Name)])
611 612
-- Given a data type in GADT syntax, figure out the equality
-- context, so that we can represent it with an explicit
613 614 615
-- equality context, because that is the only way to express
-- the GADT in TH syntax
--
616
-- Example:
617 618
-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e
--     mkGadtCtxt [a,b,c] [d,e] (T d [e] e)
619 620 621
--   returns
--     (b~[e], c~e), [d->a]
--
622 623 624
-- This function is fiddly, but not really hard
mkGadtCtxt _ ResTyH98
  = return ([], [])
Alan Zimmerman's avatar
Alan Zimmerman committed
625
mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
626
  | Just (_, tys) <- hsTyGetAppHead_maybe res_ty
627 628 629
  , data_tvs `equalLength` tys
  = return (go [] [] (data_tvs `zip` tys))

630
  | otherwise
631
  = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)
632 633 634 635 636
  where
    go cxt subst [] = (cxt, subst)
    go cxt subst ((data_tv, ty) : rest)
       | Just con_tv <- is_hs_tyvar ty
       , isTyVarName con_tv
637
       , not (in_subst subst con_tv)
638 639 640 641 642
       = go cxt ((con_tv, data_tv) : subst) rest
       | otherwise
       = go (eq_pred : cxt) subst rest
       where
         loc = getLoc ty
batterseapower's avatar
batterseapower committed
643
         eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
644 645 646 647 648

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

649

650
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
651
repBangTy ty= do
652 653
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
654
  rep2 strictTypeName [s, t]
655
  where
656
    (str, ty') = case ty of
Alan Zimmerman's avatar
Alan Zimmerman committed
657 658 659
         L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName,  ty)
         L _ (HsBangTy (HsSrcBang _ _     True) ty)       -> (isStrictName,  ty)
         _                                                -> (notStrictName, ty)
660 661

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

665
repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])
666
repDerivs Nothing = coreList nameTyConName []
667
repDerivs (Just (L _ ctxt))
668
  = repList nameTyConName rep_deriv ctxt
669
  where
670
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
671
        -- Deriving clauses must have the simple H98 form
batterseapower's avatar
batterseapower committed
672 673 674 675 676
    rep_deriv ty
      | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)
      = lookupOcc cls
      | otherwise
      = notHandled "Non-H98 deriving clause" (ppr ty)
677 678 679 680 681 682


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

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

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

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

704
rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
705
           -> DsM (SrcSpan, Core TH.DecQ)
706
rep_ty_sig mk_sig loc (L _ ty) nm
707 708
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- rep_ty ty
709
       ; sig <- repProto mk_sig nm1 ty1
710
       ; return (loc, sig) }
711
  where
712 713
    -- We must special-case the top-level explicit for-all of a TypeSig
    -- See Note [Scoped type variables in bindings]
thomasw's avatar
thomasw committed
714
    rep_ty (HsForAllTy Explicit _ tvs ctxt ty)
715 716
      = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                         ; repTyVarBndrWithKind tv name }
717
           ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)
718 719
           ; ctxt1  <- repLContext ctxt
           ; ty1    <- repLTy ty
720
           ; repTForall bndrs1 ctxt1 ty1 }
721

722
    rep_ty ty = repTy ty
723

724
rep_inline :: Located Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
725
           -> InlinePragma      -- Never defaultInlinePragma
726
           -> SrcSpan
727 728
           -> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
729 730 731 732 733
  = 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
734 735 736
       ; return [(loc, pragma)]
       }

737
rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
738 739 740 741
               -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
  = do { nm1 <- lookupLOcc nm
       ; ty1 <- repLTy ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
742 743 744 745 746 747 748 749
       ; 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 }
750 751
       ; return [(loc, pragma)]
       }
752

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
753 754 755 756 757 758
rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialiseInst ty loc
  = do { ty1    <- repLTy ty
       ; pragma <- repPragSpecInst ty1
       ; return [(loc, pragma)] }

759 760 761 762 763 764
repInline :: InlineSpec -> DsM (Core TH.Inline)
repInline NoInline  = dataCon noInlineDataConName
repInline Inline    = dataCon inlineDataConName
repInline Inlinable = dataCon inlinableDataConName
repInline spec      = notHandled "repInline" (ppr spec)

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
765 766 767
repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
repRuleMatch ConLike = dataCon conLikeDataConName
repRuleMatch FunLike = dataCon funLikeDataConName
768

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
769 770 771 772 773 774
repPhases :: Activation -> DsM (Core TH.Phases)
repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i
                                ; dataCon' beforePhaseDataConName [arg] }
repPhases (ActiveAfter i)  = do { MkC arg <- coreIntLit i
                                ; dataCon' fromPhaseDataConName [arg] }
repPhases _                = dataCon allPhasesDataConName
775 776

-------------------------------------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
777
--                      Types
778
-------------------------------------------------------
779

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
780
addTyVarBinds :: LHsTyVarBndrs Name                            -- the binders to be added
781 782
              -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
              -> DsM (Core (TH.Q a))
chak's avatar
chak committed
783 784
-- 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
chak's avatar
chak committed
785
-- meta environment and gets the *new* names on Core-level as an argument
786

787 788 789 790 791 792
addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m
  = do { fresh_kv_names <- mkGenSyms kvs
       ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)
       ; let fresh_names = fresh_kv_names ++ fresh_tv_names
       ; term <- addBinds fresh_names $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
793
                    ; m kbs }
794
       ; wrapGenSyms fresh_names term }
795 796
  where
    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
chak's avatar
chak committed
797

798
addTyClTyVarBinds :: LHsTyVarBndrs Name
799 800
                  -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                  -> DsM (Core (TH.Q a))
801 802 803 804 805 806 807

-- 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
808
  = do { let tv_names = hsLKiTyVarNames tvs
809 810
       ; env <- dsGetMetaEnv
       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
811
            -- Make fresh names for the ones that are not already in scope
812 813
            -- This makes things work for family declarations

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
814 815 816
       ; term <- addBinds freshNames $
                 do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)
                    ; m kbs }
817 818 819

       ; wrapGenSyms freshNames term }
  where
820
    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
821
                       ; repTyVarBndrWithKind tv v }
822 823 824

-- Produce kinded binder constructors from the Haskell tyvar binders
--
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
825
repTyVarBndrWithKind :: LHsTyVarBndr Name
826
                     -> Core TH.Name -> DsM (Core TH.TyVarBndr)
827
repTyVarBndrWithKind (L _ (UserTyVar _)) nm
828
  = repPlainTV nm
829
repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
830
  = repLKind ki >>= repKindedTV nm
831

chak's avatar
chak committed
832 833
-- represent a type context
--
834 835 836
repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
repLContext (L _ ctxt) = repContext ctxt

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

chak's avatar
chak committed
841 842
-- yield the representation of a list of types
--
843 844
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
repLTys tys = mapM repLTy tys