compiler/deSugar/DsMeta.hs

   1 -----------------------------------------------------------------------------
   2 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
   3 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
   4 -- input HsExpr. We do this in the DsM monad, which supplies access to
   5 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
   6 --
   7 -- It also defines a bunch of knownKeyNames, in the same way as is done
   8 -- in prelude/PrelNames.  It's much more convenient to do it here, becuase
   9 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
  10 -- a Royal Pain (triggers other recompilation).
  11 -----------------------------------------------------------------------------
  12
  13
  14 module DsMeta( dsBracket,
  15                templateHaskellNames, qTyConName, nameTyConName,
  16                liftName, expQTyConName, decQTyConName, typeQTyConName,
  17                decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
  18                 ) where
  19
  20 #include "HsVersions.h"
  21
  22 import {-# SOURCE #-}   DsExpr ( dsExpr )
  23
  24 import MatchLit   ( dsLit )
  25 import DsUtils    ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
  26 import DsMonad
  27
  28 import qualified Language.Haskell.TH as TH
  29
  30 import HsSyn
  31 import Class (FunDep)
  32 import PrelNames  ( rationalTyConName, integerTyConName, negateName )
  33 import OccName    ( isDataOcc, isTvOcc, occNameString )
  34 -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
  35 -- we do this by removing varName from the import of OccName above, making
  36 -- a qualified instance of OccName and using OccNameAlias.varName where varName
  37 -- ws previously used in this file.
  38 import qualified OccName
  39
  40 import Module     ( Module, mkModule, moduleString )
  41 import Id         ( Id, mkLocalId )
  42 import OccName    ( mkOccNameFS )
  43 import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule,
  44                     isExternalName, getSrcLoc )
  45 import NameEnv
  46 import Type       ( Type, mkTyConApp )
  47 import TcType     ( tcTyConAppArgs )
  48 import TyCon      ( tyConName )
  49 import TysWiredIn ( parrTyCon )
  50 import CoreSyn
  51 import CoreUtils  ( exprType )
  52 import SrcLoc     ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
  53 import Maybe      ( catMaybes )
  54 import Unique     ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
  55 import BasicTypes ( isBoxed )
  56 import Outputable
  57 import Bag        ( bagToList, unionManyBags )
  58 import FastString ( unpackFS )
  59 import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
  60
  61 import Monad ( zipWithM )
  62 import List ( sortBy )
  63
  64 -----------------------------------------------------------------------------
  65 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
  66 -- Returns a CoreExpr of type TH.ExpQ
  67 -- The quoted thing is parameterised over Name, even though it has
  68 -- been type checked.  We don't want all those type decorations!
  69
  70 dsBracket brack splices
  71   = dsExtendMetaEnv new_bit (do_brack brack)
  72   where
  73     new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]
  74
  75     do_brack (VarBr n)  = do { MkC e1  <- lookupOcc n ; return e1 }
  76     do_brack (ExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
  77     do_brack (PatBr p)  = do { MkC p1  <- repLP p     ; return p1 }
  78     do_brack (TypBr t)  = do { MkC t1  <- repLTy t    ; return t1 }
  79     do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
  80
  81 {- -------------- Examples --------------------
  82
  83   [| \x -> x |]
  84 ====>
  85   gensym (unpackString "x"#) `bindQ` \ x1::String ->
  86   lam (pvar x1) (var x1)
  87
  88
  89   [| \x -> $(f [| x |]) |]
  90 ====>
  91   gensym (unpackString "x"#) `bindQ` \ x1::String ->
  92   lam (pvar x1) (f (var x1))
  93 -}
  94
  95
  96 -------------------------------------------------------
  97 --                      Declarations
  98 -------------------------------------------------------
  99
 100 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 101 repTopDs group
 102  = do { let { bndrs = map unLoc (groupBinders group) } ;
 103         ss <- mkGenSyms bndrs ;
 104
 105         -- Bind all the names mainly to avoid repeated use of explicit strings.
 106         -- Thus we get
 107         --      do { t :: String <- genSym "T" ;
 108         --           return (Data t [] ...more t's... }
 109         -- The other important reason is that the output must mention
 110         -- only "T", not "Foo:T" where Foo is the current module
 111
 112
 113         decls <- addBinds ss (do {
 114                         val_ds  <- rep_val_binds (hs_valds group) ;
 115                         tycl_ds <- mapM repTyClD (hs_tyclds group) ;
 116                         inst_ds <- mapM repInstD' (hs_instds group) ;
 117                         for_ds <- mapM repForD (hs_fords group) ;
 118                         -- more needed
 119                         return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
 120
 121         decl_ty <- lookupType decQTyConName ;
 122         let { core_list = coreList' decl_ty decls } ;
 123
 124         dec_ty <- lookupType decTyConName ;
 125         q_decs  <- repSequenceQ dec_ty core_list ;
 126
 127         wrapNongenSyms ss q_decs
 128         -- Do *not* gensym top-level binders
 129       }
 130
 131 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
 132                         hs_fords = foreign_decls })
 133 -- Collect the binders of a Group
 134   = collectHsValBinders val_decls ++
 135     [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
 136     [n | L _ (ForeignImport n _ _ _) <- foreign_decls]
 137
 138
 139 {-      Note [Binders and occurrences]
 140         ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 141 When we desugar [d| data T = MkT |]
 142 we want to get
 143         Data "T" [] [Con "MkT" []] []
 144 and *not*
 145         Data "Foo:T" [] [Con "Foo:MkT" []] []
 146 That is, the new data decl should fit into whatever new module it is
 147 asked to fit in.   We do *not* clone, though; no need for this:
 148         Data "T79" ....
 149
 150 But if we see this:
 151         data T = MkT
 152         foo = reifyDecl T
 153
 154 then we must desugar to
 155         foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
 156
 157 So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
 158 And we use lookupOcc, rather than lookupBinder
 159 in repTyClD and repC.
 160
 161 -}
 162
 163 repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))
 164
 165 repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt,
 166                     tcdLName = tc, tcdTyVars = tvs,
 167                     tcdCons = cons, tcdDerivs = mb_derivs }))
 168  = do { tc1 <- lookupLOcc tc ;          -- See note [Binders and occurrences]
 169         dec <- addTyVarBinds tvs $ \bndrs -> do {
 170                cxt1    <- repLContext cxt ;
 171                cons1   <- mapM repC cons ;
 172                cons2   <- coreList conQTyConName cons1 ;
 173                derivs1 <- repDerivs mb_derivs ;
 174                bndrs1  <- coreList nameTyConName bndrs ;
 175                repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
 176         return $ Just (loc, dec) }
 177
 178 repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt,
 179                     tcdLName = tc, tcdTyVars = tvs,
 180                     tcdCons = [con], tcdDerivs = mb_derivs }))
 181  = do { tc1 <- lookupLOcc tc ;          -- See note [Binders and occurrences]
 182         dec <- addTyVarBinds tvs $ \bndrs -> do {
 183                cxt1   <- repLContext cxt ;
 184                con1   <- repC con ;
 185                derivs1 <- repDerivs mb_derivs ;
 186                bndrs1  <- coreList nameTyConName bndrs ;
 187                repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
 188         return $ Just (loc, dec) }
 189
 190 repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
 191  = do { tc1 <- lookupLOcc tc ;          -- See note [Binders and occurrences]
 192         dec <- addTyVarBinds tvs $ \bndrs -> do {
 193                ty1     <- repLTy ty ;
 194                bndrs1  <- coreList nameTyConName bndrs ;
 195                repTySyn tc1 bndrs1 ty1 } ;
 196         return (Just (loc, dec)) }
 197
 198 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
 199                       tcdTyVars = tvs,
 200                       tcdFDs = fds,
 201                       tcdSigs = sigs, tcdMeths = meth_binds }))
 202  = do { cls1 <- lookupLOcc cls ;                -- See note [Binders and occurrences]
 203         dec  <- addTyVarBinds tvs $ \bndrs -> do {
 204                   cxt1   <- repLContext cxt ;
 205                   sigs1  <- rep_sigs sigs ;
 206                   binds1 <- rep_binds meth_binds ;
 207                   fds1 <- repLFunDeps fds;
 208                   decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
 209                   bndrs1 <- coreList nameTyConName bndrs ;
 210                   repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
 211         return $ Just (loc, dec) }
 212
 213 -- Un-handled cases
 214 repTyClD (L loc d) = putSrcSpanDs loc $
 215                      do { dsWarn (hang ds_msg 4 (ppr d))
 216                         ; return Nothing }
 217
 218 -- represent fundeps
 219 --
 220 repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
 221 repLFunDeps fds = do fds' <- mapM repLFunDep fds
 222                      fdList <- coreList funDepTyConName fds'
 223                      return fdList
 224
 225 repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
 226 repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
 227                                ys' <- mapM lookupBinder ys
 228                                xs_list <- coreList nameTyConName xs'
 229                                ys_list <- coreList nameTyConName ys'
 230                                repFunDep xs_list ys_list
 231
 232 repInstD' (L loc (InstDecl ty binds _))         -- Ignore user pragmas for now
 233  = do   { i <- addTyVarBinds tvs $ \tv_bndrs ->
 234                 -- We must bring the type variables into scope, so their occurrences
 235                 -- don't fail,  even though the binders don't appear in the resulting
 236                 -- data structure
 237                 do {  cxt1 <- repContext cxt
 238                    ; inst_ty1 <- repPred (HsClassP cls tys)
 239                    ; ss <- mkGenSyms (collectHsBindBinders binds)
 240                    ; binds1 <- addBinds ss (rep_binds binds)
 241                    ; decls1 <- coreList decQTyConName binds1
 242                    ; decls2 <- wrapNongenSyms ss decls1
 243                    -- wrapNonGenSyms: do not clone the class op names!
 244                    -- They must be called 'op' etc, not 'op34'
 245                    ; repInst cxt1 inst_ty1 decls2 }
 246
 247         ; return (loc, i)}
 248  where
 249    (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)
 250
 251 repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
 252 repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis) _))
 253  = do MkC name' <- lookupLOcc name
 254       MkC typ' <- repLTy typ
 255       MkC cc' <- repCCallConv cc
 256       MkC s' <- repSafety s
 257       MkC str <- coreStringLit $ static
 258                               ++ unpackFS ch ++ " "
 259                               ++ unpackFS cn ++ " "
 260                               ++ conv_cimportspec cis
 261       dec <- rep2 forImpDName [cc', s', str, name', typ']
 262       return (loc, dec)
 263  where
 264     conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
 265     conv_cimportspec (CFunction DynamicTarget) = "dynamic"
 266     conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
 267     conv_cimportspec CWrapper = "wrapper"
 268     static = case cis of
 269                  CFunction (StaticTarget _) -> "static "
 270                  _ -> ""
 271
 272 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
 273 repCCallConv CCallConv = rep2 cCallName []
 274 repCCallConv StdCallConv = rep2 stdCallName []
 275
 276 repSafety :: Safety -> DsM (Core TH.Safety)
 277 repSafety PlayRisky = rep2 unsafeName []
 278 repSafety (PlaySafe False) = rep2 safeName []
 279 repSafety (PlaySafe True) = rep2 threadsafeName []
 280
 281 ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
 282
 283 -------------------------------------------------------
 284 --                      Constructors
 285 -------------------------------------------------------
 286
 287 repC :: LConDecl Name -> DsM (Core TH.ConQ)
 288 repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
 289   = do { con1 <- lookupLOcc con ;               -- See note [Binders and occurrences]
 290          repConstr con1 details }
 291 repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
 292   = do { addTyVarBinds tvs $ \bndrs -> do {
 293              c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
 294              ctxt' <- repContext ctxt;
 295              bndrs' <- coreList nameTyConName bndrs;
 296              rep2 forallCName [unC bndrs', unC ctxt', unC c']
 297          }
 298        }
 299 repC (L loc con_decl)           -- GADTs
 300   = putSrcSpanDs loc $
 301     do  { dsWarn (hang ds_msg 4 (ppr con_decl))
 302         ; return (panic "DsMeta:repC") }
 303
 304 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
 305 repBangTy ty= do
 306   MkC s <- rep2 str []
 307   MkC t <- repLTy ty'
 308   rep2 strictTypeName [s, t]
 309   where
 310     (str, ty') = case ty of
 311                    L _ (HsBangTy _ ty) -> (isStrictName,  ty)
 312                    other               -> (notStrictName, ty)
 313
 314 -------------------------------------------------------
 315 --                      Deriving clause
 316 -------------------------------------------------------
 317
 318 repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
 319 repDerivs Nothing = coreList nameTyConName []
 320 repDerivs (Just ctxt)
 321   = do { strs <- mapM rep_deriv ctxt ;
 322          coreList nameTyConName strs }
 323   where
 324     rep_deriv :: LHsType Name -> DsM (Core TH.Name)
 325         -- Deriving clauses must have the simple H98 form
 326     rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
 327     rep_deriv other                              = panic "rep_deriv"
 328
 329
 330 -------------------------------------------------------
 331 --   Signatures in a class decl, or a group of bindings
 332 -------------------------------------------------------
 333
 334 rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]
 335 rep_sigs sigs = do locs_cores <- rep_sigs' sigs
 336                    return $ de_loc $ sort_by_loc locs_cores
 337
 338 rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
 339         -- We silently ignore ones we don't recognise
 340 rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 341                      return (concat sigs1) }
 342
 343 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
 344         -- Singleton => Ok
 345         -- Empty     => Too hard, signature ignored
 346 rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
 347 rep_sig other                   = return []
 348
 349 rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
 350 rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
 351                        ty1 <- repLTy ty ;
 352                        sig <- repProto nm1 ty1 ;
 353                        return [(loc, sig)] }
 354
 355
 356 -------------------------------------------------------
 357 --                      Types
 358 -------------------------------------------------------
 359
 360 -- gensym a list of type variables and enter them into the meta environment;
 361 -- the computations passed as the second argument is executed in that extended
 362 -- meta environment and gets the *new* names on Core-level as an argument
 363 --
 364 addTyVarBinds :: [LHsTyVarBndr Name]             -- the binders to be added
 365               -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
 366               -> DsM (Core (TH.Q a))
 367 addTyVarBinds tvs m =
 368   do
 369     let names = map (hsTyVarName.unLoc) tvs
 370     freshNames <- mkGenSyms names
 371     term       <- addBinds freshNames $ do
 372                     bndrs <- mapM lookupBinder names
 373                     m bndrs
 374     wrapGenSyns freshNames term
 375
 376 -- represent a type context
 377 --
 378 repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)
 379 repLContext (L _ ctxt) = repContext ctxt
 380
 381 repContext :: HsContext Name -> DsM (Core TH.CxtQ)
 382 repContext ctxt = do
 383                     preds    <- mapM repLPred ctxt
 384                     predList <- coreList typeQTyConName preds
 385                     repCtxt predList
 386
 387 -- represent a type predicate
 388 --
 389 repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
 390 repLPred (L _ p) = repPred p
 391
 392 repPred :: HsPred Name -> DsM (Core TH.TypeQ)
 393 repPred (HsClassP cls tys) = do
 394                                tcon <- repTy (HsTyVar cls)
 395                                tys1 <- repLTys tys
 396                                repTapps tcon tys1
 397 repPred (HsIParam _ _)     =
 398   panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
 399
 400 -- yield the representation of a list of types
 401 --
 402 repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
 403 repLTys tys = mapM repLTy tys
 404
 405 -- represent a type
 406 --
 407 repLTy :: LHsType Name -> DsM (Core TH.TypeQ)
 408 repLTy (L _ ty) = repTy ty
 409
 410 repTy :: HsType Name -> DsM (Core TH.TypeQ)
 411 repTy (HsForAllTy _ tvs ctxt ty)  =
 412   addTyVarBinds tvs $ \bndrs -> do
 413     ctxt1  <- repLContext ctxt
 414     ty1    <- repLTy ty
 415     bndrs1 <- coreList nameTyConName bndrs
 416     repTForall bndrs1 ctxt1 ty1
 417
 418 repTy (HsTyVar n)
 419   | isTvOcc (nameOccName n)       = do
 420                                       tv1 <- lookupBinder n
 421                                       repTvar tv1
 422   | otherwise                     = do
 423                                       tc1 <- lookupOcc n
 424                                       repNamedTyCon tc1
 425 repTy (HsAppTy f a)               = do
 426                                       f1 <- repLTy f
 427                                       a1 <- repLTy a
 428                                       repTapp f1 a1
 429 repTy (HsFunTy f a)               = do
 430                                       f1   <- repLTy f
 431                                       a1   <- repLTy a
 432                                       tcon <- repArrowTyCon
 433                                       repTapps tcon [f1, a1]
 434 repTy (HsListTy t)                = do
 435                                       t1   <- repLTy t
 436                                       tcon <- repListTyCon
 437                                       repTapp tcon t1
 438 repTy (HsPArrTy t)                = do
 439                                       t1   <- repLTy t
 440                                       tcon <- repTy (HsTyVar (tyConName parrTyCon))
 441                                       repTapp tcon t1
 442 repTy (HsTupleTy tc tys)          = do
 443                                       tys1 <- repLTys tys
 444                                       tcon <- repTupleTyCon (length tys)
 445                                       repTapps tcon tys1
 446 repTy (HsOpTy ty1 n ty2)          = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
 447                                            `nlHsAppTy` ty2)
 448 repTy (HsParTy t)                 = repLTy t
 449 repTy (HsNumTy i)                 =
 450   panic "DsMeta.repTy: Can't represent number types (for generics)"
 451 repTy (HsPredTy pred)             = repPred pred
 452 repTy (HsKindSig ty kind)         =
 453   panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
 454
 455
 456 -----------------------------------------------------------------------------
 457 --              Expressions
 458 -----------------------------------------------------------------------------
 459
 460 repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
 461 repLEs es = do { es'  <- mapM repLE es ;
 462                  coreList expQTyConName es' }
 463
 464 -- FIXME: some of these panics should be converted into proper error messages
 465 --        unless we can make sure that constructs, which are plainly not
 466 --        supported in TH already lead to error messages at an earlier stage
 467 repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
 468 repLE (L _ e) = repE e
 469
 470 repE :: HsExpr Name -> DsM (Core TH.ExpQ)
 471 repE (HsVar x)            =
 472   do { mb_val <- dsLookupMetaEnv x
 473      ; case mb_val of
 474         Nothing          -> do { str <- globalVar x
 475                                ; repVarOrCon x str }
 476         Just (Bound y)   -> repVarOrCon x (coreVar y)
 477         Just (Splice e)  -> do { e' <- dsExpr e
 478                                ; return (MkC e') } }
 479 repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
 480
 481         -- Remember, we're desugaring renamer output here, so
 482         -- HsOverlit can definitely occur
 483 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 484 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 485 repE (HsLam (MatchGroup [m] _)) = repLambda m
 486 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 487
 488 repE (OpApp e1 op fix e2) =
 489   do { arg1 <- repLE e1;
 490        arg2 <- repLE e2;
 491        the_op <- repLE op ;
 492        repInfixApp arg1 the_op arg2 }
 493 repE (NegApp x nm)        = do
 494                               a         <- repLE x
 495                               negateVar <- lookupOcc negateName >>= repVar
 496                               negateVar `repApp` a
 497 repE (HsPar x)            = repLE x
 498 repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
 499 repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
 500 repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
 501                                        ; ms2 <- mapM repMatchTup ms
 502                                        ; repCaseE arg (nonEmptyCoreList ms2) }
 503 repE (HsIf x y z)         = do
 504                               a <- repLE x
 505                               b <- repLE y
 506                               c <- repLE z
 507                               repCond a b c
 508 repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
 509                                ; e2 <- addBinds ss (repLE e)
 510                                ; z <- repLetE ds e2
 511                                ; wrapGenSyns ss z }
 512 -- FIXME: I haven't got the types here right yet
 513 repE (HsDo DoExpr sts body ty)
 514  = do { (ss,zs) <- repLSts sts;
 515         body'   <- addBinds ss $ repLE body;
 516         ret     <- repNoBindSt body';
 517         e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
 518         wrapGenSyns ss e }
 519 repE (HsDo ListComp sts body ty)
 520  = do { (ss,zs) <- repLSts sts;
 521         body'   <- addBinds ss $ repLE body;
 522         ret     <- repNoBindSt body';
 523         e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
 524         wrapGenSyns ss e }
 525 repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
 526 repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs }
 527 repE (ExplicitPArr ty es) =
 528   panic "DsMeta.repE: No explicit parallel arrays yet"
 529 repE (ExplicitTuple es boxed)
 530   | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
 531   | otherwise             = panic "DsMeta.repE: Can't represent unboxed tuples"
 532 repE (RecordCon c _ flds)
 533  = do { x <- lookupLOcc c;
 534         fs <- repFields flds;
 535         repRecCon x fs }
 536 repE (RecordUpd e flds _ _)
 537  = do { x <- repLE e;
 538         fs <- repFields flds;
 539         repRecUpd x fs }
 540
 541 repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
 542 repE (ArithSeq _ aseq) =
 543   case aseq of
 544     From e              -> do { ds1 <- repLE e; repFrom ds1 }
 545     FromThen e1 e2      -> do
 546                              ds1 <- repLE e1
 547                              ds2 <- repLE e2
 548                              repFromThen ds1 ds2
 549     FromTo   e1 e2      -> do
 550                              ds1 <- repLE e1
 551                              ds2 <- repLE e2
 552                              repFromTo ds1 ds2
 553     FromThenTo e1 e2 e3 -> do
 554                              ds1 <- repLE e1
 555                              ds2 <- repLE e2
 556                              ds3 <- repLE e3
 557                              repFromThenTo ds1 ds2 ds3
 558 repE (PArrSeq _ aseq)     = panic "DsMeta.repE: parallel array seq.s missing"
 559 repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
 560 repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
 561 repE (HsBracketOut _ _)   = panic "DsMeta.repE: Can't represent Oxford brackets"
 562 repE (HsSpliceE (HsSplice n _))
 563   = do { mb_val <- dsLookupMetaEnv n
 564        ; case mb_val of
 565                  Just (Splice e) -> do { e' <- dsExpr e
 566                                        ; return (MkC e') }
 567                  other       -> pprPanic "HsSplice" (ppr n) }
 568
 569 repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
 570
 571 -----------------------------------------------------------------------------
 572 -- Building representations of auxillary structures like Match, Clause, Stmt,
 573
 574 repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ)
 575 repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
 576   do { ss1 <- mkGenSyms (collectPatBinders p)
 577      ; addBinds ss1 $ do {
 578      ; p1 <- repLP p
 579      ; (ss2,ds) <- repBinds wheres
 580      ; addBinds ss2 $ do {
 581      ; gs    <- repGuards guards
 582      ; match <- repMatch p1 gs ds
 583      ; wrapGenSyns (ss1++ss2) match }}}
 584
 585 repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
 586 repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
 587   do { ss1 <- mkGenSyms (collectPatsBinders ps)
 588      ; addBinds ss1 $ do {
 589        ps1 <- repLPs ps
 590      ; (ss2,ds) <- repBinds wheres
 591      ; addBinds ss2 $ do {
 592        gs <- repGuards guards
 593      ; clause <- repClause ps1 gs ds
 594      ; wrapGenSyns (ss1++ss2) clause }}}
 595
 596 repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
 597 repGuards [L _ (GRHS [] e)]
 598   = do {a <- repLE e; repNormal a }
 599 repGuards other
 600   = do { zs <- mapM process other;
 601      let {(xs, ys) = unzip zs};
 602          gd <- repGuarded (nonEmptyCoreList ys);
 603      wrapGenSyns (concat xs) gd }
 604   where
 605     process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
 606     process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
 607            = do { x <- repLNormalGE e1 e2;
 608                   return ([], x) }
 609     process (L _ (GRHS ss rhs))
 610            = do (gs, ss') <- repLSts ss
 611                 rhs' <- addBinds gs $ repLE rhs
 612                 g <- repPatGE (nonEmptyCoreList ss') rhs'
 613                 return (gs, g)
 614
 615 repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
 616 repFields flds = do
 617         fnames <- mapM lookupLOcc (map fst flds)
 618         es <- mapM repLE (map snd flds)
 619         fs <- zipWithM repFieldExp fnames es
 620         coreList fieldExpQTyConName fs
 621
 622
 623 -----------------------------------------------------------------------------
 624 -- Representing Stmt's is tricky, especially if bound variables
 625 -- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 626 -- First gensym new names for every variable in any of the patterns.
 627 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 628 -- if variables didn't shaddow, the static gensym wouldn't be necessary
 629 -- and we could reuse the original names (x and x).
 630 --
 631 -- do { x'1 <- gensym "x"
 632 --    ; x'2 <- gensym "x"
 633 --    ; doE [ BindSt (pvar x'1) [| f 1 |]
 634 --          , BindSt (pvar x'2) [| f x |]
 635 --          , NoBindSt [| g x |]
 636 --          ]
 637 --    }
 638
 639 -- The strategy is to translate a whole list of do-bindings by building a
 640 -- bigger environment, and a bigger set of meta bindings
 641 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 642 -- of the expressions within the Do
 643
 644 -----------------------------------------------------------------------------
 645 -- The helper function repSts computes the translation of each sub expression
 646 -- and a bunch of prefix bindings denoting the dynamic renaming.
 647
 648 repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 649 repLSts stmts = repSts (map unLoc stmts)
 650
 651 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 652 repSts (BindStmt p e _ _ : ss) =
 653    do { e2 <- repLE e
 654       ; ss1 <- mkGenSyms (collectPatBinders p)
 655       ; addBinds ss1 $ do {
 656       ; p1 <- repLP p;
 657       ; (ss2,zs) <- repSts ss
 658       ; z <- repBindSt p1 e2
 659       ; return (ss1++ss2, z : zs) }}
 660 repSts (LetStmt bs : ss) =
 661    do { (ss1,ds) <- repBinds bs
 662       ; z <- repLetSt ds
 663       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 664       ; return (ss1++ss2, z : zs) }
 665 repSts (ExprStmt e _ _ : ss) =
 666    do { e2 <- repLE e
 667       ; z <- repNoBindSt e2
 668       ; (ss2,zs) <- repSts ss
 669       ; return (ss2, z : zs) }
 670 repSts [] = return ([],[])
 671 repSts other = panic "Exotic Stmt in meta brackets"
 672
 673
 674 -----------------------------------------------------------
 675 --                      Bindings
 676 -----------------------------------------------------------
 677
 678 repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])
 679 repBinds EmptyLocalBinds
 680   = do  { core_list <- coreList decQTyConName []
 681         ; return ([], core_list) }
 682
 683 repBinds (HsIPBinds _)
 684   = panic "DsMeta:repBinds: can't do implicit parameters"
 685
 686 repBinds (HsValBinds decs)
 687  = do   { let { bndrs = map unLoc (collectHsValBinders decs) }
 688                 -- No need to worrry about detailed scopes within
 689                 -- the binding group, because we are talking Names
 690                 -- here, so we can safely treat it as a mutually
 691                 -- recursive group
 692         ; ss        <- mkGenSyms bndrs
 693         ; prs       <- addBinds ss (rep_val_binds decs)
 694         ; core_list <- coreList decQTyConName
 695                                 (de_loc (sort_by_loc prs))
 696         ; return (ss, core_list) }
 697
 698 rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 699 -- Assumes: all the binders of the binding are alrady in the meta-env
 700 rep_val_binds (ValBindsOut binds sigs)
 701  = do { core1 <- rep_binds' (unionManyBags (map snd binds))
 702       ; core2 <- rep_sigs' sigs
 703       ; return (core1 ++ core2) }
 704
 705 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
 706 rep_binds binds = do { binds_w_locs <- rep_binds' binds
 707                      ; return (de_loc (sort_by_loc binds_w_locs)) }
 708
 709 rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 710 rep_binds' binds = mapM rep_bind (bagToList binds)
 711
 712 rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 713 -- Assumes: all the binders of the binding are alrady in the meta-env
 714
 715 -- Note GHC treats declarations of a variable (not a pattern)
 716 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 717 -- with an empty list of patterns
 718 rep_bind (L loc (FunBind { fun_id = fn,
 719                            fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
 720  = do { (ss,wherecore) <- repBinds wheres
 721         ; guardcore <- addBinds ss (repGuards guards)
 722         ; fn'  <- lookupLBinder fn
 723         ; p    <- repPvar fn'
 724         ; ans  <- repVal p guardcore wherecore
 725         ; ans' <- wrapGenSyns ss ans
 726         ; return (loc, ans') }
 727
 728 rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
 729  =   do { ms1 <- mapM repClauseTup ms
 730         ; fn' <- lookupLBinder fn
 731         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 732         ; return (loc, ans) }
 733
 734 rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
 735  =   do { patcore <- repLP pat
 736         ; (ss,wherecore) <- repBinds wheres
 737         ; guardcore <- addBinds ss (repGuards guards)
 738         ; ans  <- repVal patcore guardcore wherecore
 739         ; ans' <- wrapGenSyns ss ans
 740         ; return (loc, ans') }
 741
 742 rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
 743  =   do { v' <- lookupBinder v
 744         ; e2 <- repLE e
 745         ; x <- repNormal e2
 746         ; patcore <- repPvar v'
 747         ; empty_decls <- coreList decQTyConName []
 748         ; ans <- repVal patcore x empty_decls
 749         ; return (srcLocSpan (getSrcLoc v), ans) }
 750
 751 -----------------------------------------------------------------------------
 752 -- Since everything in a Bind is mutually recursive we need rename all
 753 -- all the variables simultaneously. For example:
 754 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 755 -- do { f'1 <- gensym "f"
 756 --    ; g'2 <- gensym "g"
 757 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 758 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 759 --      ]}
 760 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 761 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 762 -- together. As we do this we collect GenSymBinds's which represent the renamed
 763 -- variables bound by the Bindings. In order not to lose track of these
 764 -- representations we build a shadow datatype MB with the same structure as
 765 -- MonoBinds, but which has slots for the representations
 766
 767
 768 -----------------------------------------------------------------------------
 769 -- GHC allows a more general form of lambda abstraction than specified
 770 -- by Haskell 98. In particular it allows guarded lambda's like :
 771 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 772 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 773 -- (\ p1 .. pn -> exp) by causing an error.
 774
 775 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
 776 repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
 777  = do { let bndrs = collectPatsBinders ps ;
 778       ; ss  <- mkGenSyms bndrs
 779       ; lam <- addBinds ss (
 780                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })
 781       ; wrapGenSyns ss lam }
 782
 783 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
 784
 785
 786 -----------------------------------------------------------------------------
 787 --                      Patterns
 788 -- repP deals with patterns.  It assumes that we have already
 789 -- walked over the pattern(s) once to collect the binders, and
 790 -- have extended the environment.  So every pattern-bound
 791 -- variable should already appear in the environment.
 792
 793 -- Process a list of patterns
 794 repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
 795 repLPs ps = do { ps' <- mapM repLP ps ;
 796                  coreList patQTyConName ps' }
 797
 798 repLP :: LPat Name -> DsM (Core TH.PatQ)
 799 repLP (L _ p) = repP p
 800
 801 repP :: Pat Name -> DsM (Core TH.PatQ)
 802 repP (WildPat _)       = repPwild
 803 repP (LitPat l)        = do { l2 <- repLiteral l; repPlit l2 }
 804 repP (VarPat x)        = do { x' <- lookupBinder x; repPvar x' }
 805 repP (LazyPat p)       = do { p1 <- repLP p; repPtilde p1 }
 806 repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
 807 repP (ParPat p)        = repLP p
 808 repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
 809 repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
 810 repP (ConPatIn dc details)
 811  = do { con_str <- lookupLOcc dc
 812       ; case details of
 813          PrefixCon ps   -> do { qs <- repLPs ps; repPcon con_str qs }
 814          RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
 815                             ; ps <- sequence $ map repLP (map snd pairs)
 816                             ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
 817                             ; fps' <- coreList fieldPatQTyConName fps
 818                             ; repPrec con_str fps' }
 819          InfixCon p1 p2 -> do { p1' <- repLP p1;
 820                                 p2' <- repLP p2;
 821                                 repPinfix p1' con_str p2' }
 822    }
 823 repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
 824 repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
 825 repP (SigPatIn p t)  = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
 826 repP other = panic "Exotic pattern inside meta brackets"
 827
 828 ----------------------------------------------------------
 829 -- Declaration ordering helpers
 830
 831 sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
 832 sort_by_loc xs = sortBy comp xs
 833     where comp x y = compare (fst x) (fst y)
 834
 835 de_loc :: [(a, b)] -> [b]
 836 de_loc = map snd
 837
 838 ----------------------------------------------------------
 839 --      The meta-environment
 840
 841 -- A name/identifier association for fresh names of locally bound entities
 842 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
 843                                 -- I.e.         (x, x_id) means
 844                                 --      let x_id = gensym "x" in ...
 845
 846 -- Generate a fresh name for a locally bound entity
 847
 848 mkGenSyms :: [Name] -> DsM [GenSymBind]
 849 -- We can use the existing name.  For example:
 850 --      [| \x_77 -> x_77 + x_77 |]
 851 -- desugars to
 852 --      do { x_77 <- genSym "x"; .... }
 853 -- We use the same x_77 in the desugared program, but with the type Bndr
 854 -- instead of Int
 855 --
 856 -- We do make it an Internal name, though (hence localiseName)
 857 --
 858 -- Nevertheless, it's monadic because we have to generate nameTy
 859 mkGenSyms ns = do { var_ty <- lookupType nameTyConName
 860                   ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
 861
 862
 863 addBinds :: [GenSymBind] -> DsM a -> DsM a
 864 -- Add a list of fresh names for locally bound entities to the
 865 -- meta environment (which is part of the state carried around
 866 -- by the desugarer monad)
 867 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
 868
 869 -- Look up a locally bound name
 870 --
 871 lookupLBinder :: Located Name -> DsM (Core TH.Name)
 872 lookupLBinder (L _ n) = lookupBinder n
 873
 874 lookupBinder :: Name -> DsM (Core TH.Name)
 875 lookupBinder n
 876   = do { mb_val <- dsLookupMetaEnv n;
 877          case mb_val of
 878             Just (Bound x) -> return (coreVar x)
 879             other          -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }
 880
 881 -- Look up a name that is either locally bound or a global name
 882 --
 883 --  * If it is a global name, generate the "original name" representation (ie,
 884 --   the <module>:<name> form) for the associated entity
 885 --
 886 lookupLOcc :: Located Name -> DsM (Core TH.Name)
 887 -- Lookup an occurrence; it can't be a splice.
 888 -- Use the in-scope bindings if they exist
 889 lookupLOcc (L _ n) = lookupOcc n
 890
 891 lookupOcc :: Name -> DsM (Core TH.Name)
 892 lookupOcc n
 893   = do {  mb_val <- dsLookupMetaEnv n ;
 894           case mb_val of
 895                 Nothing         -> globalVar n
 896                 Just (Bound x)  -> return (coreVar x)
 897                 Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
 898     }
 899
 900 globalVar :: Name -> DsM (Core TH.Name)
 901 -- Not bound by the meta-env
 902 -- Could be top-level; or could be local
 903 --      f x = $(g [| x |])
 904 -- Here the x will be local
 905 globalVar name
 906   | isExternalName name
 907   = do  { MkC mod <- coreStringLit name_mod
 908         ; MkC occ <- occNameLit name
 909         ; rep2 mk_varg [mod,occ] }
 910   | otherwise
 911   = do  { MkC occ <- occNameLit name
 912         ; MkC uni <- coreIntLit (getKey (getUnique name))
 913         ; rep2 mkNameLName [occ,uni] }
 914   where
 915       name_mod = moduleString (nameModule name)
 916       name_occ = nameOccName name
 917       mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
 918               | OccName.isVarOcc  name_occ = mkNameG_vName
 919               | OccName.isTcOcc   name_occ = mkNameG_tcName
 920               | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)
 921
 922 lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)
 923            -> DsM Type  -- The type
 924 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
 925                           return (mkTyConApp tc []) }
 926
 927 wrapGenSyns :: [GenSymBind]
 928             -> Core (TH.Q a) -> DsM (Core (TH.Q a))
 929 -- wrapGenSyns [(nm1,id1), (nm2,id2)] y
 930 --      --> bindQ (gensym nm1) (\ id1 ->
 931 --          bindQ (gensym nm2 (\ id2 ->
 932 --          y))
 933
 934 wrapGenSyns binds body@(MkC b)
 935   = do  { var_ty <- lookupType nameTyConName
 936         ; go var_ty binds }
 937   where
 938     [elt_ty] = tcTyConAppArgs (exprType b)
 939         -- b :: Q a, so we can get the type 'a' by looking at the
 940         -- argument type. NB: this relies on Q being a data/newtype,
 941         -- not a type synonym
 942
 943     go var_ty [] = return body
 944     go var_ty ((name,id) : binds)
 945       = do { MkC body'  <- go var_ty binds
 946            ; lit_str    <- occNameLit name
 947            ; gensym_app <- repGensym lit_str
 948            ; repBindQ var_ty elt_ty
 949                       gensym_app (MkC (Lam id body')) }
 950
 951 -- Just like wrapGenSym, but don't actually do the gensym
 952 -- Instead use the existing name:
 953 --      let x = "x" in ...
 954 -- Only used for [Decl], and for the class ops in class
 955 -- and instance decls
 956 wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
 957 wrapNongenSyms binds (MkC body)
 958   = do { binds' <- mapM do_one binds ;
 959          return (MkC (mkLets binds' body)) }
 960   where
 961     do_one (name,id)
 962         = do { MkC lit_str <- occNameLit name
 963              ; MkC var <- rep2 mkNameName [lit_str]
 964              ; return (NonRec id var) }
 965
 966 occNameLit :: Name -> DsM (Core String)
 967 occNameLit n = coreStringLit (occNameString (nameOccName n))
 968
 969
 970 -- %*********************************************************************
 971 -- %*                                                                   *
 972 --              Constructing code
 973 -- %*                                                                   *
 974 -- %*********************************************************************
 975
 976 -----------------------------------------------------------------------------
 977 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
 978 -- we invent a new datatype which uses phantom types.
 979
 980 newtype Core a = MkC CoreExpr
 981 unC (MkC x) = x
 982
 983 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
 984 rep2 n xs = do { id <- dsLookupGlobalId n
 985                ; return (MkC (foldl App (Var id) xs)) }
 986
 987 -- Then we make "repConstructors" which use the phantom types for each of the
 988 -- smart constructors of the Meta.Meta datatypes.
 989
 990
 991 -- %*********************************************************************
 992 -- %*                                                                   *
 993 --              The 'smart constructors'
 994 -- %*                                                                   *
 995 -- %*********************************************************************
 996
 997 --------------- Patterns -----------------
 998 repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)
 999 repPlit (MkC l) = rep2 litPName [l]
1000
1001 repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
1002 repPvar (MkC s) = rep2 varPName [s]
1003
1004 repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1005 repPtup (MkC ps) = rep2 tupPName [ps]
1006
1007 repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
1008 repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
1009
1010 repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
1011 repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
1012
1013 repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1014 repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
1015
1016 repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
1017 repPtilde (MkC p) = rep2 tildePName [p]
1018
1019 repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
1020 repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
1021
1022 repPwild  :: DsM (Core TH.PatQ)
1023 repPwild = rep2 wildPName []
1024
1025 repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
1026 repPlist (MkC ps) = rep2 listPName [ps]
1027
1028 repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
1029 repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
1030
1031 --------------- Expressions -----------------
1032 repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
1033 repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
1034                    | otherwise                  = repVar str
1035
1036 repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
1037 repVar (MkC s) = rep2 varEName [s]
1038
1039 repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
1040 repCon (MkC s) = rep2 conEName [s]
1041
1042 repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
1043 repLit (MkC c) = rep2 litEName [c]
1044
1045 repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1046 repApp (MkC x) (MkC y) = rep2 appEName [x,y]
1047
1048 repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1049 repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
1050
1051 repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1052 repTup (MkC es) = rep2 tupEName [es]
1053
1054 repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1055 repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z]
1056
1057 repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1058 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
1059
1060 repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
1061 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
1062
1063 repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1064 repDoE (MkC ss) = rep2 doEName [ss]
1065
1066 repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
1067 repComp (MkC ss) = rep2 compEName [ss]
1068
1069 repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
1070 repListExp (MkC es) = rep2 listEName [es]
1071
1072 repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
1073 repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
1074
1075 repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
1076 repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
1077
1078 repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
1079 repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
1080
1081 repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
1082 repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
1083
1084 repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1085 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
1086
1087 repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1088 repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
1089
1090 repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1091 repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
1092
1093 ------------ Right hand sides (guarded expressions) ----
1094 repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
1095 repGuarded (MkC pairs) = rep2 guardedBName [pairs]
1096
1097 repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
1098 repNormal (MkC e) = rep2 normalBName [e]
1099
1100 ------------ Guards ----
1101 repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1102 repLNormalGE g e = do g' <- repLE g
1103                       e' <- repLE e
1104                       repNormalGE g' e'
1105
1106 repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1107 repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
1108
1109 repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
1110 repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
1111
1112 ------------- Stmts -------------------
1113 repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
1114 repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
1115
1116 repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
1117 repLetSt (MkC ds) = rep2 letSName [ds]
1118
1119 repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
1120 repNoBindSt (MkC e) = rep2 noBindSName [e]
1121
1122 -------------- Range (Arithmetic sequences) -----------
1123 repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
1124 repFrom (MkC x) = rep2 fromEName [x]
1125
1126 repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1127 repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
1128
1129 repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1130 repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
1131
1132 repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
1133 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
1134
1135 ------------ Match and Clause Tuples -----------
1136 repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
1137 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
1138
1139 repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
1140 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
1141
1142 -------------- Dec -----------------------------
1143 repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1144 repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
1145
1146 repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
1147 repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
1148
1149 repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
1150 repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
1151     = rep2 dataDName [cxt, nm, tvs, cons, derivs]
1152
1153 repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
1154 repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
1155     = rep2 newtypeDName [cxt, nm, tvs, con, derivs]
1156
1157 repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1158 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
1159
1160 repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1161 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]
1162
1163 repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
1164 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]
1165
1166 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
1167 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
1168
1169 repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
1170 repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
1171
1172 repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
1173 repCtxt (MkC tys) = rep2 cxtName [tys]
1174
1175 repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
1176           -> DsM (Core TH.ConQ)
1177 repConstr con (PrefixCon ps)
1178     = do arg_tys  <- mapM repBangTy ps
1179          arg_tys1 <- coreList strictTypeQTyConName arg_tys
1180          rep2 normalCName [unC con, unC arg_tys1]
1181 repConstr con (RecCon ips)
1182     = do arg_vs   <- mapM lookupLOcc (map fst ips)
1183          arg_tys  <- mapM repBangTy (map snd ips)
1184          arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
1185                               arg_vs arg_tys
1186          arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
1187          rep2 recCName [unC con, unC arg_vtys']
1188 repConstr con (InfixCon st1 st2)
1189     = do arg1 <- repBangTy st1
1190          arg2 <- repBangTy st2
1191          rep2 infixCName [unC arg1, unC con, unC arg2]
1192
1193 ------------ Types -------------------
1194
1195 repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1196 repTForall (MkC tvars) (MkC ctxt) (MkC ty)
1197     = rep2 forallTName [tvars, ctxt, ty]
1198
1199 repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
1200 repTvar (MkC s) = rep2 varTName [s]
1201
1202 repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
1203 repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]
1204
1205 repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
1206 repTapps f []     = return f
1207 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
1208
1209 --------- Type constructors --------------
1210
1211 repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
1212 repNamedTyCon (MkC s) = rep2 conTName [s]
1213
1214 repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
1215 -- Note: not Core Int; it's easier to be direct here
1216 repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]
1217
1218 repArrowTyCon :: DsM (Core TH.TypeQ)
1219 repArrowTyCon = rep2 arrowTName []
1220
1221 repListTyCon :: DsM (Core TH.TypeQ)
1222 repListTyCon = rep2 listTName []
1223
1224
1225 ----------------------------------------------------------
1226 --              Literals
1227
1228 repLiteral :: HsLit -> DsM (Core TH.Lit)
1229 repLiteral lit
1230   = do lit' <- case lit of
1231                    HsIntPrim i    -> mk_integer i
1232                    HsInt i        -> mk_integer i
1233                    HsFloatPrim r  -> mk_rational r
1234                    HsDoublePrim r -> mk_rational r
1235                    _ -> return lit
1236        lit_expr <- dsLit lit'
1237        rep2 lit_name [lit_expr]
1238   where
1239     lit_name = case lit of
1240                  HsInteger _ _  -> integerLName
1241                  HsInt     _    -> integerLName
1242                  HsIntPrim _    -> intPrimLName
1243                  HsFloatPrim _  -> floatPrimLName
1244                  HsDoublePrim _ -> doublePrimLName
1245                  HsChar _       -> charLName
1246                  HsString _     -> stringLName
1247                  HsRat _ _      -> rationalLName
1248                  other          -> uh_oh
1249     uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
1250                     (ppr lit)
1251
1252 mk_integer  i = do integer_ty <- lookupType integerTyConName
1253                    return $ HsInteger i integer_ty
1254 mk_rational r = do rat_ty <- lookupType rationalTyConName
1255                    return $ HsRat r rat_ty
1256
1257 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
1258 repOverloadedLiteral (HsIntegral i _)   = do { lit <- mk_integer  i; repLiteral lit }
1259 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
1260         -- The type Rational will be in the environment, becuase
1261         -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
1262         -- and rationalL is sucked in when any TH stuff is used
1263
1264 --------------- Miscellaneous -------------------
1265
1266 repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
1267 repGensym (MkC lit_str) = rep2 newNameName [lit_str]
1268
1269 repBindQ :: Type -> Type        -- a and b
1270          -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
1271 repBindQ ty_a ty_b (MkC x) (MkC y)
1272   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
1273
1274 repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
1275 repSequenceQ ty_a (MkC list)
1276   = rep2 sequenceQName [Type ty_a, list]
1277
1278 ------------ Lists and Tuples -------------------
1279 -- turn a list of patterns into a single pattern matching a list
1280
1281 coreList :: Name        -- Of the TyCon of the element type
1282          -> [Core a] -> DsM (Core [a])
1283 coreList tc_name es
1284   = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
1285
1286 coreList' :: Type       -- The element type
1287           -> [Core a] -> Core [a]
1288 coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
1289
1290 nonEmptyCoreList :: [Core a] -> Core [a]
1291   -- The list must be non-empty so we can get the element type
1292   -- Otherwise use coreList
1293 nonEmptyCoreList []           = panic "coreList: empty argument"
1294 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
1295
1296 corePair :: (Core a, Core b) -> Core (a,b)
1297 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
1298
1299 coreStringLit :: String -> DsM (Core String)
1300 coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
1301
1302 coreIntLit :: Int -> DsM (Core Int)
1303 coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
1304
1305 coreVar :: Id -> Core TH.Name   -- The Id has type Name
1306 coreVar id = MkC (Var id)
1307
1308
1309
1310 -- %************************************************************************
1311 -- %*                                                                   *
1312 --              The known-key names for Template Haskell
1313 -- %*                                                                   *
1314 -- %************************************************************************
1315
1316 -- To add a name, do three things
1317 --
1318 --  1) Allocate a key
1319 --  2) Make a "Name"
1320 --  3) Add the name to knownKeyNames
1321
1322 templateHaskellNames :: [Name]
1323 -- The names that are implicitly mentioned by ``bracket''
1324 -- Should stay in sync with the import list of DsMeta
1325
1326 templateHaskellNames = [
1327     returnQName, bindQName, sequenceQName, newNameName, liftName,
1328     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
1329
1330     -- Lit
1331     charLName, stringLName, integerLName, intPrimLName,
1332     floatPrimLName, doublePrimLName, rationalLName,
1333     -- Pat
1334     litPName, varPName, tupPName, conPName, tildePName, infixPName,
1335     asPName, wildPName, recPName, listPName, sigPName,
1336     -- FieldPat
1337     fieldPatName,
1338     -- Match
1339     matchName,
1340     -- Clause
1341     clauseName,
1342     -- Exp
1343     varEName, conEName, litEName, appEName, infixEName,
1344     infixAppName, sectionLName, sectionRName, lamEName, tupEName,
1345     condEName, letEName, caseEName, doEName, compEName,
1346     fromEName, fromThenEName, fromToEName, fromThenToEName,
1347     listEName, sigEName, recConEName, recUpdEName,
1348     -- FieldExp
1349     fieldExpName,
1350     -- Body
1351     guardedBName, normalBName,
1352     -- Guard
1353     normalGEName, patGEName,
1354     -- Stmt
1355     bindSName, letSName, noBindSName, parSName,
1356     -- Dec
1357     funDName, valDName, dataDName, newtypeDName, tySynDName,
1358     classDName, instanceDName, sigDName, forImpDName,
1359     -- Cxt
1360     cxtName,
1361     -- Strict
1362     isStrictName, notStrictName,
1363     -- Con
1364     normalCName, recCName, infixCName, forallCName,
1365     -- StrictType
1366     strictTypeName,
1367     -- VarStrictType
1368     varStrictTypeName,
1369     -- Type
1370     forallTName, varTName, conTName, appTName,
1371     tupleTName, arrowTName, listTName,
1372     -- Callconv
1373     cCallName, stdCallName,
1374     -- Safety
1375     unsafeName,
1376     safeName,
1377     threadsafeName,
1378     -- FunDep
1379     funDepName,
1380
1381     -- And the tycons
1382     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
1383     clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
1384     decQTyConName, conQTyConName, strictTypeQTyConName,
1385     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
1386     typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
1387     fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
1388
1389 thSyn :: Module
1390 thSyn = mkModule "Language.Haskell.TH.Syntax"
1391 thLib = mkModule "Language.Haskell.TH.Lib"
1392
1393 mk_known_key_name mod space str uniq
1394   = mkExternalName uniq mod (mkOccNameFS space str)
1395                    Nothing noSrcLoc
1396
1397 libFun = mk_known_key_name thLib OccName.varName
1398 libTc  = mk_known_key_name thLib OccName.tcName
1399 thFun  = mk_known_key_name thSyn OccName.varName
1400 thTc   = mk_known_key_name thSyn OccName.tcName
1401
1402 -------------------- TH.Syntax -----------------------
1403 qTyConName        = thTc FSLIT("Q")            qTyConKey
1404 nameTyConName     = thTc FSLIT("Name")         nameTyConKey
1405 fieldExpTyConName = thTc FSLIT("FieldExp")     fieldExpTyConKey
1406 patTyConName      = thTc FSLIT("Pat")          patTyConKey
1407 fieldPatTyConName = thTc FSLIT("FieldPat")     fieldPatTyConKey
1408 expTyConName      = thTc FSLIT("Exp")          expTyConKey
1409 decTyConName      = thTc FSLIT("Dec")          decTyConKey
1410 typeTyConName     = thTc FSLIT("Type")         typeTyConKey
1411 matchTyConName    = thTc FSLIT("Match")        matchTyConKey
1412 clauseTyConName   = thTc FSLIT("Clause")       clauseTyConKey
1413 funDepTyConName   = thTc FSLIT("FunDep")       funDepTyConKey
1414
1415 returnQName   = thFun FSLIT("returnQ")   returnQIdKey
1416 bindQName     = thFun FSLIT("bindQ")     bindQIdKey
1417 sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
1418 newNameName    = thFun FSLIT("newName")   newNameIdKey
1419 liftName      = thFun FSLIT("lift")      liftIdKey
1420 mkNameName     = thFun FSLIT("mkName")     mkNameIdKey
1421 mkNameG_vName  = thFun FSLIT("mkNameG_v")  mkNameG_vIdKey
1422 mkNameG_dName  = thFun FSLIT("mkNameG_d")  mkNameG_dIdKey
1423 mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
1424 mkNameLName    = thFun FSLIT("mkNameL")    mkNameLIdKey
1425
1426
1427 -------------------- TH.Lib -----------------------
1428 -- data Lit = ...
1429 charLName       = libFun FSLIT("charL")       charLIdKey
1430 stringLName     = libFun FSLIT("stringL")     stringLIdKey
1431 integerLName    = libFun FSLIT("integerL")    integerLIdKey
1432 intPrimLName    = libFun FSLIT("intPrimL")    intPrimLIdKey
1433 floatPrimLName  = libFun FSLIT("floatPrimL")  floatPrimLIdKey
1434 doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
1435 rationalLName   = libFun FSLIT("rationalL")     rationalLIdKey
1436
1437 -- data Pat = ...
1438 litPName   = libFun FSLIT("litP")   litPIdKey
1439 varPName   = libFun FSLIT("varP")   varPIdKey
1440 tupPName   = libFun FSLIT("tupP")   tupPIdKey
1441 conPName   = libFun FSLIT("conP")   conPIdKey
1442 infixPName = libFun FSLIT("infixP") infixPIdKey
1443 tildePName = libFun FSLIT("tildeP") tildePIdKey
1444 asPName    = libFun FSLIT("asP")    asPIdKey
1445 wildPName  = libFun FSLIT("wildP")  wildPIdKey
1446 recPName   = libFun FSLIT("recP")   recPIdKey
1447 listPName  = libFun FSLIT("listP")  listPIdKey
1448 sigPName   = libFun FSLIT("sigP")   sigPIdKey
1449
1450 -- type FieldPat = ...
1451 fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey
1452
1453 -- data Match = ...
1454 matchName = libFun FSLIT("match") matchIdKey
1455
1456 -- data Clause = ...
1457 clauseName = libFun FSLIT("clause") clauseIdKey
1458
1459 -- data Exp = ...
1460 varEName        = libFun FSLIT("varE")        varEIdKey
1461 conEName        = libFun FSLIT("conE")        conEIdKey
1462 litEName        = libFun FSLIT("litE")        litEIdKey
1463 appEName        = libFun FSLIT("appE")        appEIdKey
1464 infixEName      = libFun FSLIT("infixE")      infixEIdKey
1465 infixAppName    = libFun FSLIT("infixApp")    infixAppIdKey
1466 sectionLName    = libFun FSLIT("sectionL")    sectionLIdKey
1467 sectionRName    = libFun FSLIT("sectionR")    sectionRIdKey
1468 lamEName        = libFun FSLIT("lamE")        lamEIdKey
1469 tupEName        = libFun FSLIT("tupE")        tupEIdKey
1470 condEName       = libFun FSLIT("condE")       condEIdKey
1471 letEName        = libFun FSLIT("letE")        letEIdKey
1472 caseEName       = libFun FSLIT("caseE")       caseEIdKey
1473 doEName         = libFun FSLIT("doE")         doEIdKey
1474 compEName       = libFun FSLIT("compE")       compEIdKey
1475 -- ArithSeq skips a level
1476 fromEName       = libFun FSLIT("fromE")       fromEIdKey
1477 fromThenEName   = libFun FSLIT("fromThenE")   fromThenEIdKey
1478 fromToEName     = libFun FSLIT("fromToE")     fromToEIdKey
1479 fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
1480 -- end ArithSeq
1481 listEName       = libFun FSLIT("listE")       listEIdKey
1482 sigEName        = libFun FSLIT("sigE")        sigEIdKey
1483 recConEName     = libFun FSLIT("recConE")     recConEIdKey
1484 recUpdEName     = libFun FSLIT("recUpdE")     recUpdEIdKey
1485
1486 -- type FieldExp = ...
1487 fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey
1488
1489 -- data Body = ...
1490 guardedBName = libFun FSLIT("guardedB") guardedBIdKey
1491 normalBName  = libFun FSLIT("normalB")  normalBIdKey
1492
1493 -- data Guard = ...
1494 normalGEName = libFun FSLIT("normalGE") normalGEIdKey
1495 patGEName    = libFun FSLIT("patGE")    patGEIdKey
1496
1497 -- data Stmt = ...
1498 bindSName   = libFun FSLIT("bindS")   bindSIdKey
1499 letSName    = libFun FSLIT("letS")    letSIdKey
1500 noBindSName = libFun FSLIT("noBindS") noBindSIdKey
1501 parSName    = libFun FSLIT("parS")    parSIdKey
1502
1503 -- data Dec = ...
1504 funDName      = libFun FSLIT("funD")      funDIdKey
1505 valDName      = libFun FSLIT("valD")      valDIdKey
1506 dataDName     = libFun FSLIT("dataD")     dataDIdKey
1507 newtypeDName  = libFun FSLIT("newtypeD")  newtypeDIdKey
1508 tySynDName    = libFun FSLIT("tySynD")    tySynDIdKey
1509 classDName    = libFun FSLIT("classD")    classDIdKey
1510 instanceDName = libFun FSLIT("instanceD") instanceDIdKey
1511 sigDName      = libFun FSLIT("sigD")      sigDIdKey
1512 forImpDName   = libFun FSLIT("forImpD")   forImpDIdKey
1513
1514 -- type Ctxt = ...
1515 cxtName = libFun FSLIT("cxt") cxtIdKey
1516
1517 -- data Strict = ...
1518 isStrictName      = libFun  FSLIT("isStrict")      isStrictKey
1519 notStrictName     = libFun  FSLIT("notStrict")     notStrictKey
1520
1521 -- data Con = ...
1522 normalCName = libFun FSLIT("normalC") normalCIdKey
1523 recCName    = libFun FSLIT("recC")    recCIdKey
1524 infixCName  = libFun FSLIT("infixC")  infixCIdKey
1525 forallCName  = libFun FSLIT("forallC")  forallCIdKey
1526
1527 -- type StrictType = ...
1528 strictTypeName    = libFun  FSLIT("strictType")    strictTKey
1529
1530 -- type VarStrictType = ...
1531 varStrictTypeName = libFun  FSLIT("varStrictType") varStrictTKey
1532
1533 -- data Type = ...
1534 forallTName = libFun FSLIT("forallT") forallTIdKey
1535 varTName    = libFun FSLIT("varT")    varTIdKey
1536 conTName    = libFun FSLIT("conT")    conTIdKey
1537 tupleTName  = libFun FSLIT("tupleT") tupleTIdKey
1538 arrowTName  = libFun FSLIT("arrowT") arrowTIdKey
1539 listTName   = libFun FSLIT("listT")  listTIdKey
1540 appTName    = libFun FSLIT("appT")    appTIdKey
1541
1542 -- data Callconv = ...
1543 cCallName = libFun FSLIT("cCall") cCallIdKey
1544 stdCallName = libFun FSLIT("stdCall") stdCallIdKey
1545
1546 -- data Safety = ...
1547 unsafeName     = libFun FSLIT("unsafe") unsafeIdKey
1548 safeName       = libFun FSLIT("safe") safeIdKey
1549 threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
1550
1551 -- data FunDep = ...
1552 funDepName     = libFun FSLIT("funDep") funDepIdKey
1553
1554 matchQTyConName         = libTc FSLIT("MatchQ")        matchQTyConKey
1555 clauseQTyConName        = libTc FSLIT("ClauseQ")       clauseQTyConKey
1556 expQTyConName           = libTc FSLIT("ExpQ")          expQTyConKey
1557 stmtQTyConName          = libTc FSLIT("StmtQ")         stmtQTyConKey
1558 decQTyConName           = libTc FSLIT("DecQ")          decQTyConKey
1559 conQTyConName           = libTc FSLIT("ConQ")          conQTyConKey
1560 strictTypeQTyConName    = libTc FSLIT("StrictTypeQ")    strictTypeQTyConKey
1561 varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
1562 typeQTyConName          = libTc FSLIT("TypeQ")          typeQTyConKey
1563 fieldExpQTyConName      = libTc FSLIT("FieldExpQ")      fieldExpQTyConKey
1564 patQTyConName           = libTc FSLIT("PatQ")           patQTyConKey
1565 fieldPatQTyConName      = libTc FSLIT("FieldPatQ")      fieldPatQTyConKey
1566
1567 --      TyConUniques available: 100-129
1568 --      Check in PrelNames if you want to change this
1569
1570 expTyConKey             = mkPreludeTyConUnique 100
1571 matchTyConKey           = mkPreludeTyConUnique 101
1572 clauseTyConKey          = mkPreludeTyConUnique 102
1573 qTyConKey               = mkPreludeTyConUnique 103
1574 expQTyConKey            = mkPreludeTyConUnique 104
1575 decQTyConKey            = mkPreludeTyConUnique 105
1576 patTyConKey             = mkPreludeTyConUnique 106
1577 matchQTyConKey          = mkPreludeTyConUnique 107
1578 clauseQTyConKey         = mkPreludeTyConUnique 108
1579 stmtQTyConKey           = mkPreludeTyConUnique 109
1580 conQTyConKey            = mkPreludeTyConUnique 110
1581 typeQTyConKey           = mkPreludeTyConUnique 111
1582 typeTyConKey            = mkPreludeTyConUnique 112
1583 decTyConKey             = mkPreludeTyConUnique 113
1584 varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
1585 strictTypeQTyConKey     = mkPreludeTyConUnique 115
1586 fieldExpTyConKey        = mkPreludeTyConUnique 116
1587 fieldPatTyConKey        = mkPreludeTyConUnique 117
1588 nameTyConKey            = mkPreludeTyConUnique 118
1589 patQTyConKey            = mkPreludeTyConUnique 119
1590 fieldPatQTyConKey       = mkPreludeTyConUnique 120
1591 fieldExpQTyConKey       = mkPreludeTyConUnique 121
1592 funDepTyConKey          = mkPreludeTyConUnique 122
1593
1594 --      IdUniques available: 200-399
1595 --      If you want to change this, make sure you check in PrelNames
1596
1597 returnQIdKey        = mkPreludeMiscIdUnique 200
1598 bindQIdKey          = mkPreludeMiscIdUnique 201
1599 sequenceQIdKey      = mkPreludeMiscIdUnique 202
1600 liftIdKey           = mkPreludeMiscIdUnique 203
1601 newNameIdKey         = mkPreludeMiscIdUnique 204
1602 mkNameIdKey          = mkPreludeMiscIdUnique 205
1603 mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
1604 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
1605 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
1606 mkNameLIdKey         = mkPreludeMiscIdUnique 209
1607
1608
1609 -- data Lit = ...
1610 charLIdKey        = mkPreludeMiscIdUnique 210
1611 stringLIdKey      = mkPreludeMiscIdUnique 211
1612 integerLIdKey     = mkPreludeMiscIdUnique 212
1613 intPrimLIdKey     = mkPreludeMiscIdUnique 213
1614 floatPrimLIdKey   = mkPreludeMiscIdUnique 214
1615 doublePrimLIdKey  = mkPreludeMiscIdUnique 215
1616 rationalLIdKey    = mkPreludeMiscIdUnique 216
1617
1618 -- data Pat = ...
1619 litPIdKey         = mkPreludeMiscIdUnique 220
1620 varPIdKey         = mkPreludeMiscIdUnique 221
1621 tupPIdKey         = mkPreludeMiscIdUnique 222
1622 conPIdKey         = mkPreludeMiscIdUnique 223
1623 infixPIdKey       = mkPreludeMiscIdUnique 312
1624 tildePIdKey       = mkPreludeMiscIdUnique 224
1625 asPIdKey          = mkPreludeMiscIdUnique 225
1626 wildPIdKey        = mkPreludeMiscIdUnique 226
1627 recPIdKey         = mkPreludeMiscIdUnique 227
1628 listPIdKey        = mkPreludeMiscIdUnique 228
1629 sigPIdKey         = mkPreludeMiscIdUnique 229
1630
1631 -- type FieldPat = ...
1632 fieldPatIdKey       = mkPreludeMiscIdUnique 230
1633
1634 -- data Match = ...
1635 matchIdKey          = mkPreludeMiscIdUnique 231
1636
1637 -- data Clause = ...
1638 clauseIdKey         = mkPreludeMiscIdUnique 232
1639
1640 -- data Exp = ...
1641 varEIdKey         = mkPreludeMiscIdUnique 240
1642 conEIdKey         = mkPreludeMiscIdUnique 241
1643 litEIdKey         = mkPreludeMiscIdUnique 242
1644 appEIdKey         = mkPreludeMiscIdUnique 243
1645 infixEIdKey       = mkPreludeMiscIdUnique 244
1646 infixAppIdKey       = mkPreludeMiscIdUnique 245
1647 sectionLIdKey       = mkPreludeMiscIdUnique 246
1648 sectionRIdKey       = mkPreludeMiscIdUnique 247
1649 lamEIdKey         = mkPreludeMiscIdUnique 248
1650 tupEIdKey         = mkPreludeMiscIdUnique 249
1651 condEIdKey        = mkPreludeMiscIdUnique 250
1652 letEIdKey         = mkPreludeMiscIdUnique 251
1653 caseEIdKey        = mkPreludeMiscIdUnique 252
1654 doEIdKey          = mkPreludeMiscIdUnique 253
1655 compEIdKey        = mkPreludeMiscIdUnique 254
1656 fromEIdKey        = mkPreludeMiscIdUnique 255
1657 fromThenEIdKey    = mkPreludeMiscIdUnique 256
1658 fromToEIdKey      = mkPreludeMiscIdUnique 257
1659 fromThenToEIdKey  = mkPreludeMiscIdUnique 258
1660 listEIdKey        = mkPreludeMiscIdUnique 259
1661 sigEIdKey         = mkPreludeMiscIdUnique 260
1662 recConEIdKey      = mkPreludeMiscIdUnique 261
1663 recUpdEIdKey      = mkPreludeMiscIdUnique 262
1664
1665 -- type FieldExp = ...
1666 fieldExpIdKey       = mkPreludeMiscIdUnique 265
1667
1668 -- data Body = ...
1669 guardedBIdKey     = mkPreludeMiscIdUnique 266
1670 normalBIdKey      = mkPreludeMiscIdUnique 267
1671
1672 -- data Guard = ...
1673 normalGEIdKey     = mkPreludeMiscIdUnique 310
1674 patGEIdKey        = mkPreludeMiscIdUnique 311
1675
1676 -- data Stmt = ...
1677 bindSIdKey       = mkPreludeMiscIdUnique 268
1678 letSIdKey        = mkPreludeMiscIdUnique 269
1679 noBindSIdKey     = mkPreludeMiscIdUnique 270
1680 parSIdKey        = mkPreludeMiscIdUnique 271
1681
1682 -- data Dec = ...
1683 funDIdKey         = mkPreludeMiscIdUnique 272
1684 valDIdKey         = mkPreludeMiscIdUnique 273
1685 dataDIdKey        = mkPreludeMiscIdUnique 274
1686 newtypeDIdKey     = mkPreludeMiscIdUnique 275
1687 tySynDIdKey       = mkPreludeMiscIdUnique 276
1688 classDIdKey       = mkPreludeMiscIdUnique 277
1689 instanceDIdKey    = mkPreludeMiscIdUnique 278
1690 sigDIdKey         = mkPreludeMiscIdUnique 279
1691 forImpDIdKey      = mkPreludeMiscIdUnique 297
1692
1693 -- type Cxt = ...
1694 cxtIdKey            = mkPreludeMiscIdUnique 280
1695
1696 -- data Strict = ...
1697 isStrictKey         = mkPreludeMiscIdUnique 281
1698 notStrictKey        = mkPreludeMiscIdUnique 282
1699
1700 -- data Con = ...
1701 normalCIdKey      = mkPreludeMiscIdUnique 283
1702 recCIdKey         = mkPreludeMiscIdUnique 284
1703 infixCIdKey       = mkPreludeMiscIdUnique 285
1704 forallCIdKey      = mkPreludeMiscIdUnique 288
1705
1706 -- type StrictType = ...
1707 strictTKey        = mkPreludeMiscIdUnique 286
1708
1709 -- type VarStrictType = ...
1710 varStrictTKey     = mkPreludeMiscIdUnique 287
1711
1712 -- data Type = ...
1713 forallTIdKey      = mkPreludeMiscIdUnique 290
1714 varTIdKey         = mkPreludeMiscIdUnique 291
1715 conTIdKey         = mkPreludeMiscIdUnique 292
1716 tupleTIdKey       = mkPreludeMiscIdUnique 294
1717 arrowTIdKey       = mkPreludeMiscIdUnique 295
1718 listTIdKey        = mkPreludeMiscIdUnique 296
1719 appTIdKey         = mkPreludeMiscIdUnique 293
1720
1721 -- data Callconv = ...
1722 cCallIdKey      = mkPreludeMiscIdUnique 300
1723 stdCallIdKey    = mkPreludeMiscIdUnique 301
1724
1725 -- data Safety = ...
1726 unsafeIdKey     = mkPreludeMiscIdUnique 305
1727 safeIdKey       = mkPreludeMiscIdUnique 306
1728 threadsafeIdKey = mkPreludeMiscIdUnique 307
1729
1730 -- data FunDep = ...
1731 funDepIdKey = mkPreludeMiscIdUnique 320
1732