ghc/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
   8
   9 module DsMeta( dsBracket ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-}   DsExpr ( dsExpr )
  14
  15 import DsUtils    ( mkListExpr, mkStringLit, mkCoreTup,
  16                     mkIntExpr, mkCharExpr )
  17 import DsMonad
  18
  19 import qualified Language.Haskell.THSyntax as M
  20
  21 import HsSyn      ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
  22                     Match(..), GRHSs(..), GRHS(..), HsBracket(..),
  23                     HsDoContext(ListComp,DoExpr), ArithSeqInfo(..),
  24                     HsBinds(..), MonoBinds(..), HsConDetails(..),
  25                     HsDecl(..), TyClDecl(..), ForeignDecl(..),
  26                     PendingSplice,
  27                     placeHolderType, tyClDeclNames,
  28                     collectHsBinders, collectMonoBinders,
  29                     collectPatBinders, collectPatsBinders
  30                   )
  31
  32 import Name       ( Name, nameOccName, nameModule )
  33 import OccName    ( isDataOcc, occNameUserString )
  34 import Module     ( moduleUserString )
  35 import PrelNames  ( intLName,charLName,
  36                     plitName, pvarName, ptupName, pconName,
  37                     ptildeName, paspatName, pwildName,
  38                     varName, conName, litName, appName, lamName,
  39                     tupName, doEName, compName,
  40                     listExpName, condName, letEName, caseEName,
  41                     infixAppName, guardedName, normalName,
  42                     bindStName, letStName, noBindStName,
  43                     fromName, fromThenName, fromToName, fromThenToName,
  44                     funName, valName, matchName, clauseName,
  45                     liftName, gensymName, bindQName,
  46                     matTyConName, expTyConName, clsTyConName,
  47                     pattTyConName, exprTyConName, declTyConName
  48                   )
  49
  50 import Id         ( Id )
  51 import NameEnv
  52 import Type       ( Type, mkGenTyConApp )
  53 import TysWiredIn ( stringTy )
  54 import CoreSyn
  55 import CoreUtils  ( exprType )
  56 import Panic      ( panic )
  57
  58 import Outputable
  59 import FastString       ( mkFastString )
  60
  61 -----------------------------------------------------------------------------
  62 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
  63 -- Returns a CoreExpr of type M.Expr
  64 -- The quoted thing is parameterised over Name, even though it has
  65 -- been type checked.  We don't want all those type decorations!
  66
  67 dsBracket (ExpBr e) splices
  68   = dsExtendMetaEnv new_bit (repE e)    `thenDs` \ (MkC new_e) ->
  69     returnDs new_e
  70   where
  71     new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]
  72
  73
  74 {- -------------- Examples --------------------
  75
  76   [| \x -> x |]
  77 ====>
  78   gensym (unpackString "x"#) `bindQ` \ x1::String ->
  79   lam (pvar x1) (var x1)
  80
  81
  82   [| \x -> $(f [| x |]) |]
  83 ====>
  84   gensym (unpackString "x"#) `bindQ` \ x1::String ->
  85   lam (pvar x1) (f (var x1))
  86 -}
  87
  88
  89 -----------------------------------------------------------------------------
  90 --                              repD
  91
  92 {-
  93 repDs :: [HsDecl Name] -> DsM (Core [M.Decl])
  94 repDs decls
  95   = do { ds' <- mapM repD ds ;
  96          coreList declTyConName ds' }
  97
  98 repD :: HsDecl Name -> DsM (Core M.Decl)
  99 repD (TyClD (TyData { tcdND = DataType, tcdCtxt = [],
 100                       tcdName = tc, tcdTyVars = tvs,
 101                       tcdCons = cons, tcdDerivs = mb_derivs }))
 102  = do { tc1  <- localVar tc ;
 103         cons1 <- mapM repCon cons ;
 104         tvs1  <- repTvs tvs ;
 105         cons2 <- coreList consTyConName cons1 ;
 106         derivs1 <- repDerivs mb_derivs ;
 107         derivs2 <- coreList stringTyConName derivs1 ;
 108         repData tc1 tvs1 cons2 derivs2 }
 109
 110 repD (TyClD (ClassD { tcdCtxt = cxt, tcdName = cls,
 111                       tcdTyVars = tvs, tcdFDs = [],
 112                       tcdSigs = sigs, tcdMeths = Just decls
 113         }))
 114  = do { cls1 <- localVar cls ;
 115         tvs1 <- repTvs tvs ;
 116         cxt1 <- repCtxt cxt ;
 117         sigs1 <- repSigs sigs ;
 118         repClass cxt1 cls1 tvs1 sigs1 }
 119
 120 repD (InstD (InstDecl ty binds _ _ loc))
 121         -- Ignore user pragmas for now
 122  = do { cls1 <- localVar cls ;
 123         cxt1 <- repCtxt cxt ;
 124         tys1 <- repTys tys ;
 125         binds1 <- repMonoBind binds ;
 126         binds2 <- coreList declTyConName binds1 ;
 127         repInst ... binds2 }
 128  where
 129    (tvs, cxt, cls, tys) = splitHsInstDeclTy ty
 130
 131 -- Un-handled cases
 132 repD d = do { dsWarn (hang (ptext SLIT("Cannot desugar this Template Haskell declaration:"))
 133                      4  (ppr d)) ;
 134               return (ValD EmptyBinds)  -- A sort of empty decl
 135          }
 136
 137 repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
 138 repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
 139                   coreList stringTyConName tvs1 }
 140
 141 repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
 142 repCtxt ctxt
 143  = do {
 144
 145 repTy :: HsType Name -> DsM (Core M.Type)
 146 repTy ty@(HsForAllTy _ cxt ty)
 147   = pprPanic "repTy" (ppr ty)
 148
 149 repTy (HsTyVar tv)
 150   = do { tv1 <- localVar tv ; repTvar tv1 }
 151
 152 repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a2 }
 153 repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
 154 repTy (HsListTy t)  = do { t1 <- repTy t ; list <- repListTyCon ; repTapp tcon t1 }
 155
 156 repTy (HsTupleTy tc tys)
 157   = do
 158 repTy (HsOpTy ty1 HsArrow ty2)    = repTy (HsFunTy ty1 ty2)
 159 repTy (HsOpTy ty1 (HsTyOp n)      = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
 160 repTy (HsParTy t)                 = repTy t
 161 repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsApp (HsTyVar c) tys)
 162
 163   | HsTupleTy           HsTupCon
 164                         [HsType name]   -- Element types (length gives arity)
 165
 166   | HsKindSig           (HsType name)   -- (ty :: kind)
 167                         Kind            -- A type with a kind signature
 168 -}
 169
 170 -----------------------------------------------------------------------------
 171 -- Using the phantom type constructors "repConstructor" we define repE
 172 -- This ensures we keep the types of the CoreExpr objects we build are
 173 -- consistent with their real types.
 174
 175 repEs :: [HsExpr Name] -> DsM (Core [M.Expr])
 176 repEs es = do { es'  <- mapM repE es ;
 177                 coreList exprTyConName es' }
 178
 179 repE :: HsExpr Name -> DsM (Core M.Expr)
 180 repE (HsVar x)
 181   = do { mb_val <- dsLookupMetaEnv x
 182        ; case mb_val of
 183           Nothing          -> do { str <- globalVar x
 184                                  ; if constructor x then
 185                                         repCon str
 186                                    else
 187                                         repVar str }
 188           Just (Bound y)   -> repVar (coreVar y)
 189           Just (Splice e)  -> do { e' <- dsExpr e
 190                                  ; return (MkC e') } }
 191
 192 repE (HsIPVar x)    = panic "Can't represent implicit parameters"
 193 repE (HsLit l)      = do { a <- repLiteral l;           repLit a }
 194 repE (HsOverLit l)  = do { a <- repOverloadedLiteral l; repLit a }
 195
 196 repE (HsSplice n e)
 197   = do { mb_val <- dsLookupMetaEnv n
 198        ; case mb_val of
 199              Just (Splice e) -> do { e' <- dsExpr e
 200                                    ; return (MkC e') }
 201              other           -> pprPanic "HsSplice" (ppr n) }
 202
 203
 204 repE (HsLam m)      = repLambda m
 205 repE (HsApp x y)    = do {a <- repE x; b <- repE y; repApp a b}
 206 repE (NegApp x nm)  = panic "No negate yet"
 207 repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b }
 208 repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b }
 209
 210 repE (OpApp e1 (HsVar op) fix e2) =
 211      do { arg1 <- repE e1;
 212           arg2 <- repE e2;
 213           mb_val <- dsLookupMetaEnv op;
 214           the_op <- case mb_val of {
 215                         Nothing        -> globalVar op ;
 216                         Just (Bound x) -> return (coreVar x) ;
 217                         other          -> pprPanic "repE:OpApp" (ppr op) } ;
 218           repInfixApp arg1 the_op arg2 }
 219
 220 repE (HsCase e ms loc)
 221   = do { arg <- repE e
 222        ; ms2 <- mapM repMatchTup ms
 223        ; repCaseE arg (nonEmptyCoreList ms2) }
 224
 225 --      I havn't got the types here right yet
 226 repE (HsDo DoExpr sts _ ty loc)      = do { (ss,zs) <- repSts sts;
 227                                             e       <- repDoE (nonEmptyCoreList zs);
 228                                             combine expTyConName ss e }
 229 repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts;
 230                                           e       <- repComp (nonEmptyCoreList zs);
 231                                           combine expTyConName ss e }
 232
 233 repE (ArithSeqIn (From e))              = do { ds1 <- repE e; repFrom ds1 }
 234 repE (ArithSeqIn (FromThen e1 e2))      = do { ds1 <- repE e1; ds2 <- repE e2;
 235                                                repFromThen ds1 ds2 }
 236 repE (ArithSeqIn (FromTo   e1 e2))      = do { ds1 <- repE e1; ds2 <- repE e2;
 237                                                repFromTo   ds1 ds2 }
 238 repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2;
 239                                                ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 }
 240
 241 repE (HsIf x y z loc)
 242   = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c }
 243
 244 repE (HsLet bs e) =
 245    do { (ss,ds) <- repDecs bs
 246       ; e2 <- addBinds ss (repE e)
 247       ; z <- repLetE ds e2
 248       ; combine expTyConName ss z }
 249 repE (HsWith _ _ _) = panic "No with for implicit parameters yet"
 250 repE (ExplicitList ty es) =
 251      do { xs <- repEs es; repListExp xs }
 252 repE (ExplicitTuple es boxed) =
 253      do { xs <- repEs es; repTup xs }
 254 repE (ExplicitPArr ty es) = panic "No parallel arrays yet"
 255 repE (RecordConOut _ _ _) = panic "No record construction yet"
 256 repE (RecordUpdOut _ _ _ _) = panic "No record update yet"
 257 repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet"
 258
 259
 260 -----------------------------------------------------------------------------
 261 -- Building representations of auxillary structures like Match, Clause, Stmt,
 262
 263 repMatchTup ::  Match Name -> DsM (Core M.Mtch)
 264 repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
 265   do { ss1 <- mkGenSyms (collectPatBinders p)
 266      ; addBinds ss1 $ do {
 267      ; p1 <- repP p
 268      ; (ss2,ds) <- repDecs wheres
 269      ; addBinds ss2 $ do {
 270      ; gs    <- repGuards guards
 271      ; match <- repMatch p1 gs ds
 272      ; combine matTyConName (ss1++ss2) match }}}
 273
 274 repClauseTup ::  Match Name -> DsM (Core M.Clse)
 275 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
 276   do { ss1 <- mkGenSyms (collectPatsBinders ps)
 277      ; addBinds ss1 $ do {
 278        ps1 <- repPs ps
 279      ; (ss2,ds) <- repDecs wheres
 280      ; addBinds ss2 $ do {
 281        gs <- repGuards guards
 282      ; clause <- repClause ps1 gs ds
 283      ; combine clsTyConName (ss1++ss2) clause }}}
 284
 285 repGuards ::  [GRHS Name] ->  DsM (Core M.Rihs)
 286 repGuards [GRHS[ResultStmt e loc] loc2]
 287   = do {a <- repE e; repNormal a }
 288 repGuards other
 289   = do { zs <- mapM process other;
 290          repGuarded (nonEmptyCoreList (map corePair zs)) }
 291   where
 292     process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
 293            = do { x <- repE e1; y <- repE e2; return (x, y) }
 294     process other = panic "Non Haskell 98 guarded body"
 295
 296
 297 -----------------------------------------------------------------------------
 298 -- Representing Stmt's is tricky, especially if bound variables
 299 -- shaddow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
 300 -- First gensym new names for every variable in any of the patterns.
 301 -- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
 302 -- if variables didn't shaddow, the static gensym wouldn't be necessary
 303 -- and we could reuse the original names (x and x).
 304 --
 305 -- do { x'1 <- gensym "x"
 306 --    ; x'2 <- gensym "x"
 307 --    ; doE [ BindSt (pvar x'1) [| f 1 |]
 308 --          , BindSt (pvar x'2) [| f x |]
 309 --          , NoBindSt [| g x |]
 310 --          ]
 311 --    }
 312
 313 -- The strategy is to translate a whole list of do-bindings by building a
 314 -- bigger environment, and a bigger set of meta bindings
 315 -- (like:  x'1 <- gensym "x" ) and then combining these with the translations
 316 -- of the expressions within the Do
 317
 318 -----------------------------------------------------------------------------
 319 -- The helper function repSts computes the translation of each sub expression
 320 -- and a bunch of prefix bindings denoting the dynamic renaming.
 321
 322 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt])
 323 repSts [ResultStmt e loc] =
 324    do { a <- repE e
 325       ; e1 <- repNoBindSt a
 326       ; return ([], [e1]) }
 327 repSts (BindStmt p e loc : ss) =
 328    do { e2 <- repE e
 329       ; ss1 <- mkGenSyms (collectPatBinders p)
 330       ; addBinds ss1 $ do {
 331       ; p1 <- repP p;
 332       ; (ss2,zs) <- repSts ss
 333       ; z <- repBindSt p1 e2
 334       ; return (ss1++ss2, z : zs) }}
 335 repSts (LetStmt bs : ss) =
 336    do { (ss1,ds) <- repDecs bs
 337       ; z <- repLetSt ds
 338       ; (ss2,zs) <- addBinds ss1 (repSts ss)
 339       ; return (ss1++ss2, z : zs) }
 340 repSts (ExprStmt e ty loc : ss) =
 341    do { e2 <- repE e
 342       ; z <- repNoBindSt e2
 343       ; (ss2,zs) <- repSts ss
 344       ; return (ss2, z : zs) }
 345 repSts other = panic "Exotic Stmt in meta brackets"
 346
 347
 348
 349 repDecs :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl])
 350 repDecs decs
 351  = do { let { bndrs = collectHsBinders decs } ;
 352         ss <- mkGenSyms bndrs ;
 353         core <- addBinds ss (rep_decs decs) ;
 354         core_list <- coreList declTyConName core ;
 355         return (ss, core_list) }
 356
 357 rep_decs :: HsBinds Name -> DsM [Core M.Decl]
 358 rep_decs EmptyBinds = return []
 359 rep_decs (ThenBinds x y)
 360  = do { core1 <- rep_decs x
 361       ; core2 <- rep_decs y
 362       ; return (core1 ++ core2) }
 363 rep_decs (MonoBind bs sigs _)
 364  = do { core1 <- repMonoBind bs
 365       ; core2 <- rep_sigs sigs
 366       ; return (core1 ++ core2) }
 367
 368 rep_sigs sigs = return []       -- Incomplete!
 369
 370 repMonoBind :: MonoBinds Name -> DsM [Core M.Decl]
 371 repMonoBind EmptyMonoBinds     = return []
 372 repMonoBind (AndMonoBinds x y) = do { x1 <- repMonoBind x;
 373                                         y1 <- repMonoBind y;
 374                                         return (x1 ++ y1) }
 375
 376 -- Note GHC treats declarations of a variable (not a pattern)
 377 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
 378 -- with an empty list of patterns
 379 repMonoBind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc)
 380  = do { (ss,wherecore) <- repDecs wheres
 381         ; guardcore <- addBinds ss (repGuards guards)
 382         ; fn' <- lookupBinder fn
 383         ; p   <- repPvar fn'
 384         ; ans <- repVal p guardcore wherecore
 385         ; return [ans] }
 386
 387 repMonoBind (FunMonoBind fn infx ms loc)
 388  =   do { ms1 <- mapM repClauseTup ms
 389         ; fn' <- lookupBinder fn
 390         ; ans <- repFun fn' (nonEmptyCoreList ms1)
 391         ; return [ans] }
 392
 393 repMonoBind (PatMonoBind pat (GRHSs guards wheres ty2) loc)
 394  =   do { patcore <- repP pat
 395         ; (ss,wherecore) <- repDecs wheres
 396         ; guardcore <- addBinds ss (repGuards guards)
 397         ; ans <- repVal patcore guardcore wherecore
 398         ; return [ans] }
 399
 400 repMonoBind (VarMonoBind v e)
 401  =   do { v' <- lookupBinder v
 402         ; e2 <- repE e
 403         ; x <- repNormal e2
 404         ; patcore <- repPvar v'
 405         ; empty_decls <- coreList declTyConName []
 406         ; ans <- repVal patcore x empty_decls
 407         ; return [ans] }
 408
 409 -----------------------------------------------------------------------------
 410 -- Since everything in a MonoBind is mutually recursive we need rename all
 411 -- all the variables simultaneously. For example:
 412 -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
 413 -- do { f'1 <- gensym "f"
 414 --    ; g'2 <- gensym "g"
 415 --    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
 416 --        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
 417 --      ]}
 418 -- This requires collecting the bindings (f'1 <- gensym "f"), and the
 419 -- environment ( f |-> f'1 ) from each binding, and then unioning them
 420 -- together. As we do this we collect GenSymBinds's which represent the renamed
 421 -- variables bound by the Bindings. In order not to lose track of these
 422 -- representations we build a shadow datatype MB with the same structure as
 423 -- MonoBinds, but which has slots for the representations
 424
 425 -----------------------------------------------------------------------------
 426 --      Gathering binders
 427
 428 hsDeclsBinders :: [HsDecl Name] -> [Name]
 429 hsDeclsBinders ds = concat (map hsDeclBinders ds)
 430
 431 hsDeclBinders (ValD b)  = collectHsBinders b
 432 hsDeclBinders (TyClD d) = map fst (tyClDeclNames d)
 433 hsDeclBinders (ForD d)  = forDeclBinders d
 434 hsDeclBinders other     = []
 435
 436 forDeclBinders (ForeignImport n _ _ _ _) = [n]
 437 forDeclBinders other                     = []
 438
 439
 440 -----------------------------------------------------------------------------
 441 -- GHC seems to allow a more general form of lambda abstraction than specified
 442 -- by Haskell 98. In particular it allows guarded lambda's like :
 443 -- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
 444 -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
 445 -- (\ p1 .. pn -> exp) by causing an error.
 446
 447 repLambda :: Match Name -> DsM (Core M.Expr)
 448 repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
 449                              EmptyBinds _))
 450  = do { let bndrs = collectPatsBinders ps ;
 451       ; ss <- mkGenSyms bndrs
 452       ; lam <- addBinds ss (
 453                 do { xs <- repPs ps; body <- repE e; repLam xs body })
 454       ; combine expTyConName ss lam }
 455
 456 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"
 457
 458
 459 -----------------------------------------------------------------------------
 460 --                      repP
 461 -- repP deals with patterns.  It assumes that we have already
 462 -- walked over the pattern(s) once to collect the binders, and
 463 -- have extended the environment.  So every pattern-bound
 464 -- variable should already appear in the environment.
 465
 466 -- Process a list of patterns
 467 repPs :: [Pat Name] -> DsM (Core [M.Patt])
 468 repPs ps = do { ps' <- mapM repP ps ;
 469                 coreList pattTyConName ps' }
 470
 471 repP :: Pat Name -> DsM (Core M.Patt)
 472 repP (WildPat _)     = repPwild
 473 repP (LitPat l)      = do { l2 <- repLiteral l; repPlit l2 }
 474 repP (VarPat x)      = do { x' <- lookupBinder x; repPvar x' }
 475 repP (LazyPat p)     = do { p1 <- repP p; repPtilde p1 }
 476 repP (AsPat x p)     = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
 477 repP (ParPat p)      = repP p
 478 repP (ListPat ps _)  = repListPat ps
 479 repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
 480 repP (ConPatIn dc details)
 481  = do { con_str <- globalVar dc
 482       ; case details of
 483          PrefixCon ps   -> do { qs <- repPs ps; repPcon con_str qs }
 484          RecCon pairs   -> error "No records in template haskell yet"
 485          InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
 486    }
 487 repP other = panic "Exotic pattern inside meta brackets"
 488
 489 repListPat :: [Pat Name] -> DsM (Core M.Patt)
 490 repListPat []     = do { nil_con <- coreStringLit "[]"
 491                        ; nil_args <- coreList pattTyConName []
 492                        ; repPcon nil_con nil_args }
 493 repListPat (p:ps) = do { p2 <- repP p
 494                        ; ps2 <- repListPat ps
 495                        ; cons_con <- coreStringLit ":"
 496                        ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) }
 497
 498
 499 ----------------------------------------------------------
 500 --              Literals
 501
 502 repLiteral :: HsLit -> DsM (Core M.Lit)
 503 repLiteral (HsInt i)  = rep2 intLName [mkIntExpr i]
 504 repLiteral (HsChar c) = rep2 charLName [mkCharExpr c]
 505 repLiteral x = panic "trying to represent exotic literal"
 506
 507 repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit)
 508 repOverloadedLiteral (HsIntegral i _)   = rep2 intLName [mkIntExpr i]
 509 repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet"
 510
 511
 512 ----------------------------------------------------------
 513 --      The meta-environment
 514
 515 type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
 516                                 -- I.e.         (x, x_id) means
 517                                 --      let x_id = gensym "x" in ...
 518
 519 addBinds :: [GenSymBind] -> DsM a -> DsM a
 520 addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
 521
 522 lookupBinder :: Name -> DsM (Core String)
 523 lookupBinder n
 524   = do { mb_val <- dsLookupMetaEnv n;
 525          case mb_val of
 526             Just (Bound id) -> return (MkC (Var id))
 527             other           -> pprPanic "Failed binder lookup:" (ppr n) }
 528
 529 mkGenSym :: Name -> DsM GenSymBind
 530 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
 531
 532 mkGenSyms :: [Name] -> DsM [GenSymBind]
 533 mkGenSyms ns = mapM mkGenSym ns
 534
 535 lookupType :: Name      -- Name of type constructor (e.g. M.Expr)
 536            -> DsM Type  -- The type
 537 lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
 538                           return (mkGenTyConApp tc []) }
 539
 540 -- combine[ x1 <- e1, x2 <- e2 ] y
 541 --      --> bindQ e1 (\ x1 -> bindQ e2 (\ x2 -> y))
 542
 543 combine :: Name         -- Name of the type (consructor) for 'a'
 544         -> [GenSymBind]
 545         -> Core (M.Q a) -> DsM (Core (M.Q a))
 546 combine tc_name binds body@(MkC b)
 547   = do { elt_ty <- lookupType tc_name
 548        ; go elt_ty binds }
 549   where
 550     go elt_ty [] = return body
 551     go elt_ty ((name,id) : binds)
 552       = do { MkC body'  <- go elt_ty binds
 553            ; lit_str    <- localVar name
 554            ; gensym_app <- repGensym lit_str
 555            ; repBindQ stringTy elt_ty
 556                       gensym_app (MkC (Lam id body')) }
 557
 558 constructor :: Name -> Bool
 559 constructor x = isDataOcc (nameOccName x)
 560
 561 void = placeHolderType
 562
 563 string :: String -> HsExpr Id
 564 string s = HsLit (HsString (mkFastString s))
 565
 566
 567 -- %*********************************************************************
 568 -- %*                                                                   *
 569 --              Constructing code
 570 -- %*                                                                   *
 571 -- %*********************************************************************
 572
 573 -----------------------------------------------------------------------------
 574 -- PHANTOM TYPES for consistency. In order to make sure we do this correct
 575 -- we invent a new datatype which uses phantom types.
 576
 577 newtype Core a = MkC CoreExpr
 578 unC (MkC x) = x
 579
 580 rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
 581 rep2 n xs = do { id <- dsLookupGlobalId n
 582                ; return (MkC (foldl App (Var id) xs)) }
 583
 584 -- Then we make "repConstructors" which use the phantom types for each of the
 585 -- smart constructors of the Meta.Meta datatypes.
 586
 587
 588 -- %*********************************************************************
 589 -- %*                                                                   *
 590 --              The 'smart constructors'
 591 -- %*                                                                   *
 592 -- %*********************************************************************
 593
 594 --------------- Patterns -----------------
 595 repPlit   :: Core M.Lit -> DsM (Core M.Patt)
 596 repPlit (MkC l) = rep2 plitName [l]
 597
 598 repPvar :: Core String -> DsM (Core M.Patt)
 599 repPvar (MkC s) = rep2 pvarName [s]
 600
 601 repPtup :: Core [M.Patt] -> DsM (Core M.Patt)
 602 repPtup (MkC ps) = rep2 ptupName [ps]
 603
 604 repPcon   :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
 605 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
 606
 607 repPtilde :: Core M.Patt -> DsM (Core M.Patt)
 608 repPtilde (MkC p) = rep2 ptildeName [p]
 609
 610 repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt)
 611 repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p]
 612
 613 repPwild  :: DsM (Core M.Patt)
 614 repPwild = rep2 pwildName []
 615
 616 --------------- Expressions -----------------
 617 repVar :: Core String -> DsM (Core M.Expr)
 618 repVar (MkC s) = rep2 varName [s]
 619
 620 repCon :: Core String -> DsM (Core M.Expr)
 621 repCon (MkC s) = rep2 conName [s]
 622
 623 repLit :: Core M.Lit -> DsM (Core M.Expr)
 624 repLit (MkC c) = rep2 litName [c]
 625
 626 repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 627 repApp (MkC x) (MkC y) = rep2 appName [x,y]
 628
 629 repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr)
 630 repLam (MkC ps) (MkC e) = rep2 lamName [ps, e]
 631
 632 repTup :: Core [M.Expr] -> DsM (Core M.Expr)
 633 repTup (MkC es) = rep2 tupName [es]
 634
 635 repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 636 repCond (MkC x) (MkC y) (MkC z) =  rep2 condName [x,y,z]
 637
 638 repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr)
 639 repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
 640
 641 repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr)
 642 repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
 643
 644 repDoE :: Core [M.Stmt] -> DsM (Core M.Expr)
 645 repDoE (MkC ss) = rep2 doEName [ss]
 646
 647 repComp :: Core [M.Stmt] -> DsM (Core M.Expr)
 648 repComp (MkC ss) = rep2 compName [ss]
 649
 650 repListExp :: Core [M.Expr] -> DsM (Core M.Expr)
 651 repListExp (MkC es) = rep2 listExpName [es]
 652
 653 repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
 654 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
 655
 656 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 657 repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
 658
 659 repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 660 repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
 661
 662 ------------ Right hand sides (guarded expressions) ----
 663 repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
 664 repGuarded (MkC pairs) = rep2 guardedName [pairs]
 665
 666 repNormal :: Core M.Expr -> DsM (Core M.Rihs)
 667 repNormal (MkC e) = rep2 normalName [e]
 668
 669 ------------- Statements -------------------
 670 repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt)
 671 repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e]
 672
 673 repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt)
 674 repLetSt (MkC ds) = rep2 letStName [ds]
 675
 676 repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt)
 677 repNoBindSt (MkC e) = rep2 noBindStName [e]
 678
 679 -------------- DotDot (Arithmetic sequences) -----------
 680 repFrom :: Core M.Expr -> DsM (Core M.Expr)
 681 repFrom (MkC x) = rep2 fromName [x]
 682
 683 repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 684 repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y]
 685
 686 repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 687 repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y]
 688
 689 repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 690 repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z]
 691
 692 ------------ Match and Clause Tuples -----------
 693 repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch)
 694 repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
 695
 696 repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse)
 697 repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
 698
 699 -------------- Dec -----------------------------
 700 repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl)
 701 repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
 702
 703 repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)
 704 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
 705
 706 repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
 707 repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
 708
 709 repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl]
 710 repInst (MkC cxt) (MkC ty) (Core ds) = rep2 instanceDName [cxt, ty, ds]
 711
 712 repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl)
 713 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds]
 714
 715 repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
 716 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
 717
 718 ------------ Types -------------------
 719
 720 repTvar :: Core String -> DsM (Core M.Type)
 721 repTvar (MkC s) = rep2 tvarName [s]
 722
 723 repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type)
 724 repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2]
 725
 726 repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type)
 727 repTapps f []     = return f
 728 repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
 729
 730
 731 repNamedTyCon :: Core String -> DsM (Core M.Type)
 732 repNamedTyCon (MkC s) = rep2 namedTyConName [s]
 733
 734 repTupleTyCon :: Core Int -> DsM (Core M.Tag)
 735 repTupleTyCon (MkC i) = rep2 tupleTyConName [i]
 736
 737 repArrowTyCon :: DsM (Core M.Type)
 738 repArrowTyCon = rep2 arrowTyConName []
 739
 740 repListTyCon :: DsM (Core M.Tag)
 741 repListTyCon = rep2 listTyConName []
 742
 743
 744 --------------- Miscellaneous -------------------
 745
 746 repLift :: Core e -> DsM (Core M.Expr)
 747 repLift (MkC x) = rep2 liftName [x]
 748
 749 repGensym :: Core String -> DsM (Core (M.Q String))
 750 repGensym (MkC lit_str) = rep2 gensymName [lit_str]
 751
 752 repBindQ :: Type -> Type        -- a and b
 753          -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b))
 754 repBindQ ty_a ty_b (MkC x) (MkC y)
 755   = rep2 bindQName [Type ty_a, Type ty_b, x, y]
 756
 757 ------------ Lists and Tuples -------------------
 758 -- turn a list of patterns into a single pattern matching a list
 759
 760 coreList :: Name        -- Of the TyCon of the element type
 761          -> [Core a] -> DsM (Core [a])
 762 coreList tc_name es
 763   = do { elt_ty <- lookupType tc_name
 764        ; let es' = map unC es
 765        ; return (MkC (mkListExpr elt_ty es')) }
 766
 767 nonEmptyCoreList :: [Core a] -> Core [a]
 768   -- The list must be non-empty so we can get the element type
 769   -- Otherwise use coreList
 770 nonEmptyCoreList []           = panic "coreList: empty argument"
 771 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
 772
 773 corePair :: (Core a, Core b) -> Core (a,b)
 774 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
 775
 776 globalVar :: Name -> DsM (Core String)
 777 globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
 778             where
 779               name_mod = moduleUserString (nameModule n)
 780               name_occ = occNameUserString (nameOccName n)
 781
 782 localVar :: Name -> DsM (Core String)
 783 localVar n = coreStringLit (occNameUserString (nameOccName n))
 784
 785 coreStringLit :: String -> DsM (Core String)
 786 coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
 787
 788 coreVar :: Id -> Core String    -- The Id has type String
 789 coreVar id = MkC (Var id)