DsMeta.hs 56.7 KB
Newer Older
1 2 3 4 5
-----------------------------------------------------------------------------
-- The purpose of this module is to transform an HsExpr into a CoreExpr which
-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
-- input HsExpr. We do this in the DsM monad, which supplies access to
-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
6 7 8 9 10
--
-- It also defines a bunch of knownKeyNames, in the same way as is done
-- in prelude/PrelNames.  It's much more convenient to do it here, becuase
-- otherwise we have to recompile PrelNames whenever we add a Name, which is
-- a Royal Pain (triggers other recompilation).
11 12 13
-----------------------------------------------------------------------------


14
module DsMeta( dsBracket, dsReify,
15
	       templateHaskellNames, qTyConName, 
16 17
	       liftName, expQTyConName, decQTyConName, typeQTyConName,
	       decTyConName, typeTyConName ) where
18 19 20 21 22

#include "HsVersions.h"

import {-# SOURCE #-}	DsExpr ( dsExpr )

23 24
import MatchLit	  ( dsLit )
import DsUtils    ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
25 26 27 28 29 30
import DsMonad

import qualified Language.Haskell.THSyntax as M

import HsSyn  	  ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
		    Match(..), GRHSs(..), GRHS(..), HsBracket(..),
31
                    HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..),
32
		    HsBinds(..), MonoBinds(..), HsConDetails(..),
33
		    TyClDecl(..), HsGroup(..),
34
		    HsReify(..), ReifyFlavour(..), 
35 36 37 38
		    HsType(..), HsContext(..), HsPred(..), HsTyOp(..),
	 	    HsTyVarBndr(..), Sig(..), ForeignDecl(..),
		    InstDecl(..), ConDecl(..), BangType(..),
		    PendingSplice, splitHsInstDeclTy,
39
		    placeHolderType, tyClDeclNames,
40
		    collectHsBinders, collectPatBinders, collectPatsBinders,
41 42
		    hsTyVarName, hsConArgs, getBangType,
		    toHsType
43 44
		  )

chak's avatar
chak committed
45 46
import PrelNames  ( mETA_META_Name, rationalTyConName, negateName,
		    parrTyConName )
47
import MkIface	  ( ifaceTyThing )
48
import Name       ( Name, nameOccName, nameModule, getSrcLoc )
49
import OccName	  ( isDataOcc, isTvOcc, occNameUserString )
50 51 52 53 54 55
-- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName
-- we do this by removing varName from the import of OccName above, making
-- a qualified instance of OccName and using OccNameAlias.varName where varName
-- ws previously used in this file.
import qualified OccName( varName, tcName )

56
import Module	  ( Module, mkThPkgModule, moduleUserString )
57
import Id         ( Id, idType )
58 59
import Name	  ( mkKnownKeyExternalName )
import OccName	  ( mkOccFS )
60
import NameEnv
61
import NameSet
62 63
import Type       ( Type, mkGenTyConApp )
import TcType	  ( TyThing(..), tcTyConAppArgs )
64
import TyCon	  ( DataConDetails(..) )
65 66 67
import TysWiredIn ( stringTy )
import CoreSyn
import CoreUtils  ( exprType )
68
import SrcLoc	  ( noSrcLoc )
69
import Maybes	  ( orElse )
chak's avatar
chak committed
70
import Maybe	  ( catMaybes, fromMaybe )
71
import Panic	  ( panic )
72
import Unique	  ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
chak's avatar
chak committed
73
import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) 
74
import SrcLoc     ( SrcLoc )
75 76 77

import Outputable
import FastString	( mkFastString )
78 79

import Monad ( zipWithM )
80
import List ( sortBy )
81 82 83
 
-----------------------------------------------------------------------------
dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
84
-- Returns a CoreExpr of type M.ExpQ
85 86 87
-- The quoted thing is parameterised over Name, even though it has
-- been type checked.  We don't want all those type decorations!

88 89
dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
90 91 92
  where
    new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices]

93 94 95 96
    do_brack (ExpBr e)  = do { MkC e1  <- repE e      ; return e1 }
    do_brack (PatBr p)  = do { MkC p1  <- repP p      ; return p1 }
    do_brack (TypBr t)  = do { MkC t1  <- repTy t     ; return t1 }
    do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
97

98 99
-----------------------------------------------------------------------------
dsReify :: HsReify Id -> DsM CoreExpr
100
-- Returns a CoreExpr of type 	reifyType --> M.TypeQ
101
--				reifyDecl --> M.DecQ
102
--				reifyFixty --> Q M.Fix
103 104 105 106 107 108 109 110 111 112
dsReify (ReifyOut ReifyType name)
  = do { thing <- dsLookupGlobal name ;
		-- By deferring the lookup until now (rather than doing it
		-- in the type checker) we ensure that all zonking has
		-- been done.
	 case thing of
	    AnId id -> do { MkC e <- repTy (toHsType (idType id)) ;
			    return e }
	    other   -> pprPanic "dsReify: reifyType" (ppr name)
	}
113

114 115
dsReify r@(ReifyOut ReifyDecl name)
  = do { thing <- dsLookupGlobal name ;
116
	 mb_d <- repTyClD (ifaceTyThing True{-omit pragmas-} thing) ;
117 118 119 120 121
	 case mb_d of
	   Just (MkC d) -> return d 
	   Nothing	-> pprPanic "dsReify" (ppr r)
	}

122 123 124 125 126 127 128 129 130 131 132 133 134 135 136
{- -------------- Examples --------------------

  [| \x -> x |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (var x1)


  [| \x -> $(f [| x |]) |]
====>
  gensym (unpackString "x"#) `bindQ` \ x1::String ->
  lam (pvar x1) (f (var x1))
-}


137 138 139 140
-------------------------------------------------------
-- 			Declarations
-------------------------------------------------------

141
repTopDs :: HsGroup Name -> DsM (Core (M.Q [M.Dec]))
142 143 144 145
repTopDs group
 = do { let { bndrs = groupBinders group } ;
	ss    <- mkGenSyms bndrs ;

146 147 148 149 150
	-- Bind all the names mainly to avoid repeated use of explicit strings.
	-- Thus	we get
	--	do { t :: String <- genSym "T" ;
	--	     return (Data t [] ...more t's... }
	-- The other important reason is that the output must mention
151
	-- only "T", not "Foo:T" where Foo is the current module
152 153

	
154
	decls <- addBinds ss (do {
155 156 157
			val_ds <- rep_binds' (hs_valds group) ;
			tycl_ds <- mapM repTyClD' (hs_tyclds group) ;
			inst_ds <- mapM repInstD' (hs_instds group) ;
158
			-- more needed
159
			return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ;
160

161
	decl_ty <- lookupType decQTyConName ;
162
	let { core_list = coreList' decl_ty decls } ;
163 164 165

	dec_ty <- lookupType decTyConName ;
	q_decs  <- repSequenceQ dec_ty core_list ;
166 167

	wrapNongenSyms ss q_decs
168 169 170 171 172
	-- Do *not* gensym top-level binders
      }

groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
			hs_fords = foreign_decls })
173
-- Collect the binders of a Group
174 175 176 177 178
  = collectHsBinders val_decls ++
    [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++
    [n | ForeignImport n _ _ _ _ <- foreign_decls]


179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
{- 	Note [Binders and occurrences]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we desugar [d| data T = MkT |]
we want to get
	Data "T" [] [Con "MkT" []] []
and *not*
	Data "Foo:T" [] [Con "Foo:MkT" []] []
That is, the new data decl should fit into whatever new module it is
asked to fit in.   We do *not* clone, though; no need for this:
	Data "T79" ....

But if we see this:
	data T = MkT 
	foo = reifyDecl T

then we must desugar to
	foo = Data "Foo:T" [] [Con "Foo:MkT" []] []

So in repTopDs we bring the binders into scope with mkGenSyms and addBinds,
but in dsReify we do not.  And we use lookupOcc, rather than lookupBinder
in repTyClD and repC.

-}

203 204 205
repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.DecQ))
repTyClD decl = do x <- repTyClD' decl
                   return (fmap snd x)
206

207 208 209
repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core M.DecQ))

repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, 
210
		   tcdName = tc, tcdTyVars = tvs, 
211 212
		   tcdCons = DataCons cons, tcdDerivs = mb_derivs,
           tcdLoc = loc}) 
213 214
 = do { tc1 <- lookupOcc tc ;		-- See note [Binders and occurrences] 
        dec <- addTyVarBinds tvs $ \bndrs -> do {
215 216
      	       cxt1   <- repContext cxt ;
               cons1   <- mapM repC cons ;
217
      	       cons2   <- coreList conQTyConName cons1 ;
218
      	       derivs1 <- repDerivs mb_derivs ;
219
      	       repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
220
        return $ Just (loc, dec) }
221

222 223 224 225 226 227 228 229 230 231 232 233
repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt, 
		   tcdName = tc, tcdTyVars = tvs, 
		   tcdCons = DataCons [con], tcdDerivs = mb_derivs,
           tcdLoc = loc}) 
 = do { tc1 <- lookupOcc tc ;		-- See note [Binders and occurrences] 
        dec <- addTyVarBinds tvs $ \bndrs -> do {
      	       cxt1   <- repContext cxt ;
               con1   <- repC con ;
      	       derivs1 <- repDerivs mb_derivs ;
      	       repNewtype cxt1 tc1 (coreList' stringTy bndrs) con1 derivs1 } ;
        return $ Just (loc, dec) }

234 235
repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty,
           tcdLoc = loc})
236 237 238 239
 = do { tc1 <- lookupOcc tc ;		-- See note [Binders and occurrences] 
        dec <- addTyVarBinds tvs $ \bndrs -> do {
	       ty1 <- repTy ty ;
	       repTySyn tc1 (coreList' stringTy bndrs) ty1 } ;
240
 	return (Just (loc, dec)) }
241

242
repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls, 
243 244
		      tcdTyVars = tvs, 
		      tcdFDs = [], 	-- We don't understand functional dependencies
245 246
		      tcdSigs = sigs, tcdMeths = mb_meth_binds,
              tcdLoc = loc})
247 248 249 250 251
 = do { cls1 <- lookupOcc cls ;		-- See note [Binders and occurrences] 
    	dec  <- addTyVarBinds tvs $ \bndrs -> do {
 		  cxt1   <- repContext cxt ;
 		  sigs1  <- rep_sigs sigs ;
 		  binds1 <- rep_monobind meth_binds ;
252
 		  decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
253
 		  repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
254
    	return $ Just (loc, dec) }
255 256 257 258 259
 where
	-- If the user quotes a class decl, it'll have default-method 
	-- bindings; but if we (reifyDecl C) where C is a class, we
	-- won't be given the default methods (a definite infelicity).
   meth_binds = mb_meth_binds `orElse` EmptyMonoBinds
260 261

-- Un-handled cases
262
repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ;
263 264 265 266
	          return Nothing
	     }
  where
    msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
267

268
repInstD' (InstDecl ty binds _ _ loc)
269
	-- Ignore user pragmas for now
chak's avatar
chak committed
270
 = do { cxt1 <- repContext cxt ;
271 272
	inst_ty1 <- repPred (HsClassP cls tys) ;
	binds1 <- rep_monobind binds ;
273
	decls1 <- coreList decQTyConName binds1 ;
274 275
	i <- repInst cxt1 inst_ty1 decls1;
    return (loc, i)}
276 277 278
 where
   (tvs, cxt, cls, tys) = splitHsInstDeclTy ty

279 280 281 282 283

-------------------------------------------------------
-- 			Constructors
-------------------------------------------------------

284
repC :: ConDecl Name -> DsM (Core M.ConQ)
285
repC (ConDecl con [] [] details loc)
286
  = do { con1     <- lookupOcc con ;		-- See note [Binders and occurrences] 
287
	 repConstr con1 details }
288

289
repBangTy :: BangType Name -> DsM (Core (M.StrictTypeQ))
290 291
repBangTy (BangType str ty) = do MkC s <- rep2 strName []
                                 MkC t <- repTy ty
292
                                 rep2 strictTypeName [s, t]
293
    where strName = case str of
294 295
                        NotMarkedStrict -> notStrictName
                        _ -> isStrictName
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316

-------------------------------------------------------
-- 			Deriving clause
-------------------------------------------------------

repDerivs :: Maybe (HsContext Name) -> DsM (Core [String])
repDerivs Nothing = return (coreList' stringTy [])
repDerivs (Just ctxt)
  = do { strs <- mapM rep_deriv ctxt ; 
	 return (coreList' stringTy strs) }
  where
    rep_deriv :: HsPred Name -> DsM (Core String)
	-- Deriving clauses must have the simple H98 form
    rep_deriv (HsClassP cls []) = lookupOcc cls
    rep_deriv other		= panic "rep_deriv"


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

317 318 319 320 321
rep_sigs :: [Sig Name] -> DsM [Core M.DecQ]
rep_sigs sigs = do locs_cores <- rep_sigs' sigs
                   return $ de_loc $ sort_by_loc locs_cores

rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core M.DecQ)]
322
	-- We silently ignore ones we don't recognise
323
rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
324 325
		     return (concat sigs1) }

326
rep_sig :: Sig Name -> DsM [(SrcLoc, Core M.DecQ)]
327 328
	-- Singleton => Ok
	-- Empty     => Too hard, signature ignored
329 330
rep_sig (ClassOpSig nm _ ty loc) = rep_proto nm ty loc
rep_sig (Sig nm ty loc)	       = rep_proto nm ty loc
331 332
rep_sig other		       = return []

333 334
rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core M.DecQ)]
rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; 
335 336
		       ty1 <- repTy ty ; 
		       sig <- repProto nm1 ty1 ;
337
		       return [(loc, sig)] }
338 339 340 341 342


-------------------------------------------------------
-- 			Types
-------------------------------------------------------
343

chak's avatar
chak committed
344 345
-- gensym a list of type variables and enter them into the meta environment;
-- the computations passed as the second argument is executed in that extended
chak's avatar
chak committed
346
-- meta environment and gets the *new* names on Core-level as an argument
chak's avatar
chak committed
347
--
348
addTyVarBinds :: [HsTyVarBndr Name]	         -- the binders to be added
chak's avatar
chak committed
349 350
	      -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
	      -> DsM (Core (M.Q a))
351
addTyVarBinds tvs m =
chak's avatar
chak committed
352 353 354 355 356 357
  do
    let names = map hsTyVarName tvs
    freshNames <- mkGenSyms names
    term       <- addBinds freshNames $ do
		    bndrs <- mapM lookupBinder names 
		    m bndrs
358
    wrapGenSyns freshNames term
chak's avatar
chak committed
359

chak's avatar
chak committed
360 361
-- represent a type context
--
362
repContext :: HsContext Name -> DsM (Core M.CxtQ)
chak's avatar
chak committed
363 364
repContext ctxt = do 
	            preds    <- mapM repPred ctxt
365
		    predList <- coreList typeQTyConName preds
chak's avatar
chak committed
366
		    repCtxt predList
367

chak's avatar
chak committed
368 369
-- represent a type predicate
--
370
repPred :: HsPred Name -> DsM (Core M.TypeQ)
chak's avatar
chak committed
371 372 373 374 375 376 377 378 379
repPred (HsClassP cls tys) = do
			       tcon <- repTy (HsTyVar cls)
			       tys1 <- repTys tys
			       repTapps tcon tys1
repPred (HsIParam _ _)     = 
  panic "DsMeta.repTy: Can't represent predicates with implicit parameters"

-- yield the representation of a list of types
--
380
repTys :: [HsType Name] -> DsM [Core M.TypeQ]
381
repTys tys = mapM repTy tys
382

chak's avatar
chak committed
383 384
-- represent a type
--
385
repTy :: HsType Name -> DsM (Core M.TypeQ)
chak's avatar
chak committed
386
repTy (HsForAllTy bndrs ctxt ty)  = 
387
  addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do
chak's avatar
chak committed
388 389 390
    ctxt'  <- repContext ctxt
    ty'    <- repTy ty
    repTForall (coreList' stringTy bndrs') ctxt' ty'
391

392
repTy (HsTyVar n)
chak's avatar
chak committed
393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419
  | isTvOcc (nameOccName n)       = do 
				      tv1 <- lookupBinder n
				      repTvar tv1
  | otherwise		          = do 
				      tc1 <- lookupOcc n
				      repNamedTyCon tc1
repTy (HsAppTy f a)               = do 
				      f1 <- repTy f
				      a1 <- repTy a
				      repTapp f1 a1
repTy (HsFunTy f a)               = do 
				      f1   <- repTy f
				      a1   <- repTy a
				      tcon <- repArrowTyCon
				      repTapps tcon [f1, a1]
repTy (HsListTy t)		  = do
				      t1   <- repTy t
				      tcon <- repListTyCon
				      repTapp tcon t1
repTy (HsPArrTy t)                = do
				      t1   <- repTy t
				      tcon <- repTy (HsTyVar parrTyConName)
				      repTapp tcon t1
repTy (HsTupleTy tc tys)	  = do
				      tys1 <- repTys tys 
				      tcon <- repTupleTyCon (length tys)
				      repTapps tcon tys1
420
repTy (HsOpTy ty1 HsArrow ty2) 	  = repTy (HsFunTy ty1 ty2)
chak's avatar
chak committed
421 422
repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) 
					   `HsAppTy` ty2)
423
repTy (HsParTy t)  	       	  = repTy t
chak's avatar
chak committed
424 425 426 427 428
repTy (HsNumTy i)                 =
  panic "DsMeta.repTy: Can't represent number types (for generics)"
repTy (HsPredTy pred)             = repPred pred
repTy (HsKindSig ty kind)	  = 
  panic "DsMeta.repTy: Can't represent explicit kind signatures yet"
429 430


chak's avatar
chak committed
431
-----------------------------------------------------------------------------
432
-- 		Expressions
chak's avatar
chak committed
433
-----------------------------------------------------------------------------
434

435
repEs :: [HsExpr Name] -> DsM (Core [M.ExpQ])
436
repEs es = do { es'  <- mapM repE es ;
437
		coreList expQTyConName es' }
438

chak's avatar
chak committed
439 440 441
-- FIXME: some of these panics should be converted into proper error messages
--	  unless we can make sure that constructs, which are plainly not
--	  supported in TH already lead to error messages at an earlier stage
442
repE :: HsExpr Name -> DsM (Core M.ExpQ)
chak's avatar
chak committed
443 444 445
repE (HsVar x)            =
  do { mb_val <- dsLookupMetaEnv x 
     ; case mb_val of
chak's avatar
chak committed
446
	Nothing	         -> do { str <- globalVar x
chak's avatar
chak committed
447 448 449 450
			       ; repVarOrCon x str }
	Just (Bound y)   -> repVarOrCon x (coreVar y)
	Just (Splice e)  -> do { e' <- dsExpr e
			       ; return (MkC e') } }
451
repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
452 453 454 455 456 457 458

	-- Remember, we're desugaring renamer output here, so
	-- HsOverlit can definitely occur
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
repE (HsLam m)     = repLambda m
repE (HsApp x y)   = do {a <- repE x; b <- repE y; repApp a b}
459

chak's avatar
chak committed
460
repE (OpApp e1 op fix e2) =
461 462 463 464
  do { arg1 <- repE e1; 
       arg2 <- repE e2; 
       the_op <- repE op ;
       repInfixApp arg1 the_op arg2 } 
chak's avatar
chak committed
465 466 467 468
repE (NegApp x nm)        = do
			      a         <- repE x
			      negateVar <- lookupOcc negateName >>= repVar
			      negateVar `repApp` a
chak's avatar
chak committed
469 470 471 472 473 474 475 476 477 478 479 480 481 482
repE (HsPar x)            = repE x
repE (SectionL x y)       = do { a <- repE x; b <- repE y; repSectionL a b } 
repE (SectionR x y)       = do { a <- repE x; b <- repE y; repSectionR a b } 
repE (HsCase e ms loc)    = do { arg <- repE e
			       ; ms2 <- mapM repMatchTup ms
			       ; repCaseE arg (nonEmptyCoreList ms2) }
repE (HsIf x y z loc)     = do
			      a <- repE x
			      b <- repE y
			      c <- repE z
			      repCond a b c
repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
			       ; e2 <- addBinds ss (repE e)
			       ; z <- repLetE ds e2
483
			       ; wrapGenSyns ss z }
chak's avatar
chak committed
484
-- FIXME: I haven't got the types here right yet
485 486 487
repE (HsDo DoExpr sts _ ty loc) 
 = do { (ss,zs) <- repSts sts; 
        e       <- repDoE (nonEmptyCoreList zs);
488
        wrapGenSyns ss e }
489 490 491
repE (HsDo ListComp sts _ ty loc) 
 = do { (ss,zs) <- repSts sts; 
        e       <- repComp (nonEmptyCoreList zs);
492
        wrapGenSyns ss e }
493
repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
chak's avatar
chak committed
494 495 496 497 498 499
repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } 
repE (ExplicitPArr ty es) = 
  panic "DsMeta.repE: No explicit parallel arrays yet"
repE (ExplicitTuple es boxed) 
  | isBoxed boxed         = do { xs <- repEs es; repTup xs }
  | otherwise		  = panic "DsMeta.repE: Can't represent unboxed tuples"
500 501 502 503 504 505 506 507
repE (RecordCon c flds)
 = do { x <- lookupOcc c;
        fs <- repFields flds;
        repRecCon x fs }
repE (RecordUpd e flds)
 = do { x <- repE e;
        fs <- repFields flds;
        repRecUpd x fs }
508 509

repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
510
repE (ArithSeqIn aseq) =
chak's avatar
chak committed
511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526
  case aseq of
    From e              -> do { ds1 <- repE e; repFrom ds1 }
    FromThen e1 e2      -> do 
		             ds1 <- repE e1
			     ds2 <- repE e2
			     repFromThen ds1 ds2
    FromTo   e1 e2      -> do 
			     ds1 <- repE e1
			     ds2 <- repE e2
			     repFromTo ds1 ds2
    FromThenTo e1 e2 e3 -> do 
			     ds1 <- repE e1
			     ds2 <- repE e2
			     ds3 <- repE e3
			     repFromThenTo ds1 ds2 ds3
repE (PArrSeqOut _ aseq)  = panic "DsMeta.repE: parallel array seq.s missing"
527
repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
chak's avatar
chak committed
528 529 530 531 532 533 534 535 536 537 538
repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
repE (HsBracketOut _ _)   = 
  panic "DsMeta.repE: Can't represent Oxford brackets"
repE (HsSplice n e loc)   = do { mb_val <- dsLookupMetaEnv n
			       ; case mb_val of
				 Just (Splice e) -> do { e' <- dsExpr e
						       ; return (MkC e') }
				 other	     -> pprPanic "HsSplice" (ppr n) }
repE (HsReify _)          = panic "DsMeta.repE: Can't represent reification"
repE e                    = 
  pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
539 540 541 542

-----------------------------------------------------------------------------
-- Building representations of auxillary structures like Match, Clause, Stmt, 

543
repMatchTup ::  Match Name -> DsM (Core M.MatchQ) 
544 545 546 547
repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = 
  do { ss1 <- mkGenSyms (collectPatBinders p) 
     ; addBinds ss1 $ do {
     ; p1 <- repP p
548
     ; (ss2,ds) <- repBinds wheres
549 550 551
     ; addBinds ss2 $ do {
     ; gs    <- repGuards guards
     ; match <- repMatch p1 gs ds
552
     ; wrapGenSyns (ss1++ss2) match }}}
553

554
repClauseTup ::  Match Name -> DsM (Core M.ClauseQ)
555 556 557 558
repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = 
  do { ss1 <- mkGenSyms (collectPatsBinders ps) 
     ; addBinds ss1 $ do {
       ps1 <- repPs ps
559
     ; (ss2,ds) <- repBinds wheres
560 561 562
     ; addBinds ss2 $ do {
       gs <- repGuards guards
     ; clause <- repClause ps1 gs ds
563
     ; wrapGenSyns (ss1++ss2) clause }}}
564

565
repGuards ::  [GRHS Name] ->  DsM (Core M.BodyQ)
566
repGuards [GRHS [ResultStmt e loc] loc2] 
567 568 569 570 571 572 573 574 575
  = do {a <- repE e; repNormal a }
repGuards other 
  = do { zs <- mapM process other; 
	 repGuarded (nonEmptyCoreList (map corePair zs)) }
  where 
    process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _)
           = do { x <- repE e1; y <- repE e2; return (x, y) }
    process other = panic "Non Haskell 98 guarded body"

576
repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FieldExp])
577 578 579
repFields flds = do
        fnames <- mapM lookupOcc (map fst flds)
        es <- mapM repE (map snd flds)
580 581
        fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es
        coreList fieldExpTyConName fs
582

583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608

-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
-- shaddow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
-- First gensym new names for every variable in any of the patterns.
-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
-- if variables didn't shaddow, the static gensym wouldn't be necessary
-- and we could reuse the original names (x and x).
--
-- do { x'1 <- gensym "x"
--    ; x'2 <- gensym "x"   
--    ; doE [ BindSt (pvar x'1) [| f 1 |]
--          , BindSt (pvar x'2) [| f x |] 
--          , NoBindSt [| g x |] 
--          ]
--    }

-- The strategy is to translate a whole list of do-bindings by building a
-- bigger environment, and a bigger set of meta bindings 
-- (like:  x'1 <- gensym "x" ) and then combining these with the translations
-- of the expressions within the Do
      
-----------------------------------------------------------------------------
-- The helper function repSts computes the translation of each sub expression
-- and a bunch of prefix bindings denoting the dynamic renaming.

609
repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.StmtQ])
610 611 612 613 614 615 616 617 618 619 620 621 622
repSts [ResultStmt e loc] = 
   do { a <- repE e
      ; e1 <- repNoBindSt a
      ; return ([], [e1]) }
repSts (BindStmt p e loc : ss) =
   do { e2 <- repE e 
      ; ss1 <- mkGenSyms (collectPatBinders p) 
      ; addBinds ss1 $ do {
      ; p1 <- repP p; 
      ; (ss2,zs) <- repSts ss
      ; z <- repBindSt p1 e2
      ; return (ss1++ss2, z : zs) }}
repSts (LetStmt bs : ss) =
623
   do { (ss1,ds) <- repBinds bs
624 625 626 627 628 629 630 631 632 633 634
      ; z <- repLetSt ds
      ; (ss2,zs) <- addBinds ss1 (repSts ss)
      ; return (ss1++ss2, z : zs) } 
repSts (ExprStmt e ty loc : ss) =       
   do { e2 <- repE e
      ; z <- repNoBindSt e2 
      ; (ss2,zs) <- repSts ss
      ; return (ss2, z : zs) }
repSts other = panic "Exotic Stmt in meta brackets"      


635 636 637
-----------------------------------------------------------
--			Bindings
-----------------------------------------------------------
638

639
repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [M.DecQ]) 
640
repBinds decs
641
 = do { let { bndrs = collectHsBinders decs } ;
642 643
	ss	  <- mkGenSyms bndrs ;
	core      <- addBinds ss (rep_binds decs) ;
644
	core_list <- coreList decQTyConName core ;
645 646
	return (ss, core_list) }

647 648 649 650 651 652 653 654 655
rep_binds :: HsBinds Name -> DsM [Core M.DecQ]
rep_binds binds = do locs_cores <- rep_binds' binds
                     return $ de_loc $ sort_by_loc locs_cores

rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
rep_binds' EmptyBinds = return []
rep_binds' (ThenBinds x y)
 = do { core1 <- rep_binds' x
      ; core2 <- rep_binds' y
656
      ; return (core1 ++ core2) }
657 658 659
rep_binds' (MonoBind bs sigs _)
 = do { core1 <- rep_monobind' bs
      ;	core2 <- rep_sigs' sigs
660
      ;	return (core1 ++ core2) }
661
rep_binds' (IPBinds _ _)
662
  = panic "DsMeta:repBinds: can't do implicit parameters"
663

664 665 666 667 668 669 670 671
rep_monobind :: MonoBinds Name -> DsM [Core M.DecQ]
rep_monobind binds = do locs_cores <- rep_monobind' binds
                        return $ de_loc $ sort_by_loc locs_cores

rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core M.DecQ)]
rep_monobind' EmptyMonoBinds     = return []
rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x; 
				       y1 <- rep_monobind' y; 
672
				       return (x1 ++ y1) }
673 674 675 676

-- Note GHC treats declarations of a variable (not a pattern) 
-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match 
-- with an empty list of patterns
677
rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) 
678
 = do { (ss,wherecore) <- repBinds wheres
679 680 681 682
	; guardcore <- addBinds ss (repGuards guards)
	; fn' <- lookupBinder fn
	; p   <- repPvar fn'
	; ans <- repVal p guardcore wherecore
683
	; return [(loc, ans)] }
684

685
rep_monobind' (FunMonoBind fn infx ms loc)
686 687 688
 =   do { ms1 <- mapM repClauseTup ms
	; fn' <- lookupBinder fn
        ; ans <- repFun fn' (nonEmptyCoreList ms1)
689
        ; return [(loc, ans)] }
690

691
rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc)
692
 =   do { patcore <- repP pat 
693
        ; (ss,wherecore) <- repBinds wheres
694 695
	; guardcore <- addBinds ss (repGuards guards)
        ; ans <- repVal patcore guardcore wherecore
696
        ; return [(loc, ans)] }
697

698
rep_monobind' (VarMonoBind v e)  
699 700 701 702
 =   do { v' <- lookupBinder v 
	; e2 <- repE e
        ; x <- repNormal e2
        ; patcore <- repPvar v'
703
	; empty_decls <- coreList decQTyConName [] 
704
        ; ans <- repVal patcore x empty_decls
705
        ; return [(getSrcLoc v, ans)] }
706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724

-----------------------------------------------------------------------------
-- Since everything in a MonoBind is mutually recursive we need rename all
-- all the variables simultaneously. For example: 
-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
-- do { f'1 <- gensym "f"
--    ; g'2 <- gensym "g"
--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
--      ]}
-- This requires collecting the bindings (f'1 <- gensym "f"), and the 
-- environment ( f |-> f'1 ) from each binding, and then unioning them 
-- together. As we do this we collect GenSymBinds's which represent the renamed 
-- variables bound by the Bindings. In order not to lose track of these 
-- representations we build a shadow datatype MB with the same structure as 
-- MonoBinds, but which has slots for the representations


-----------------------------------------------------------------------------
725
-- GHC allows a more general form of lambda abstraction than specified
726 727 728 729 730
-- by Haskell 98. In particular it allows guarded lambda's like : 
-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
-- (\ p1 .. pn -> exp) by causing an error.  

731
repLambda :: Match Name -> DsM (Core M.ExpQ)
732 733 734 735 736 737
repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ] 
		             EmptyBinds _))
 = do { let bndrs = collectPatsBinders ps ;
      ; ss <- mkGenSyms bndrs
      ; lam <- addBinds ss (
		do { xs <- repPs ps; body <- repE e; repLam xs body })
738
      ; wrapGenSyns ss lam }
739 740 741 742 743

repLambda z = panic "Can't represent a guarded lambda in Template Haskell"  

  
-----------------------------------------------------------------------------
744
--			Patterns
745 746 747 748 749 750
-- repP deals with patterns.  It assumes that we have already
-- walked over the pattern(s) once to collect the binders, and 
-- have extended the environment.  So every pattern-bound 
-- variable should already appear in the environment.

-- Process a list of patterns
751
repPs :: [Pat Name] -> DsM (Core [M.Pat])
752
repPs ps = do { ps' <- mapM repP ps ;
753
		coreList patTyConName ps' }
754

755
repP :: Pat Name -> DsM (Core M.Pat)
756 757 758 759 760 761
repP (WildPat _)     = repPwild 
repP (LitPat l)      = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat x)      = do { x' <- lookupBinder x; repPvar x' }
repP (LazyPat p)     = do { p1 <- repP p; repPtilde p1 }
repP (AsPat x p)     = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 }
repP (ParPat p)      = repP p 
762
repP (ListPat ps _)  = do { qs <- repPs ps; repPlist qs }
763 764
repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs }
repP (ConPatIn dc details)
765
 = do { con_str <- lookupOcc dc
766 767
      ; case details of
         PrefixCon ps   -> do { qs <- repPs ps; repPcon con_str qs }
768 769
         RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
                            ; ps <- sequence $ map repP (map snd pairs)
770 771
                            ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
                            ; fps' <- coreList fieldPatTyConName fps
772
                            ; repPrec con_str fps' }
773 774
         InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
   }
775 776
repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a }
777 778
repP other = panic "Exotic pattern inside meta brackets"

779 780 781 782 783 784 785 786 787 788
----------------------------------------------------------
-- Declaration ordering helpers

sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)]
sort_by_loc xs = sortBy comp xs
    where comp x y = compare (fst x) (fst y)

de_loc :: [(SrcLoc, a)] -> [a]
de_loc = map snd

789 790 791
----------------------------------------------------------
--	The meta-environment

chak's avatar
chak committed
792 793
-- A name/identifier association for fresh names of locally bound entities
--
794 795 796 797
type GenSymBind = (Name, Id)	-- Gensym the string and bind it to the Id
				-- I.e.		(x, x_id) means
				--	let x_id = gensym "x" in ...

chak's avatar
chak committed
798 799
-- Generate a fresh name for a locally bound entity
--
800 801 802
mkGenSym :: Name -> DsM GenSymBind
mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }

chak's avatar
chak committed
803 804
-- Ditto for a list of names
--
805 806 807
mkGenSyms :: [Name] -> DsM [GenSymBind]
mkGenSyms ns = mapM mkGenSym ns
	     
chak's avatar
chak committed
808 809 810 811 812 813 814 815 816
-- Add a list of fresh names for locally bound entities to the meta
-- environment (which is part of the state carried around by the desugarer
-- monad) 
--
addBinds :: [GenSymBind] -> DsM a -> DsM a
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m

-- Look up a locally bound name
--
817 818 819 820 821 822 823
lookupBinder :: Name -> DsM (Core String)
lookupBinder n 
  = do { mb_val <- dsLookupMetaEnv n;
	 case mb_val of
	    Just (Bound x) -> return (coreVar x)
	    other	   -> pprPanic "Failed binder lookup:" (ppr n) }

chak's avatar
chak committed
824 825 826 827 828
-- Look up a name that is either locally bound or a global name
--
-- * If it is a global name, generate the "original name" representation (ie,
--   the <module>:<name> form) for the associated entity
--
829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848
lookupOcc :: Name -> DsM (Core String)
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
lookupOcc n
  = do {  mb_val <- dsLookupMetaEnv n ;
          case mb_val of
		Nothing         -> globalVar n
		Just (Bound x)  -> return (coreVar x)
		Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) 
    }

globalVar :: Name -> DsM (Core String)
globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ)
 	    where
	      name_mod = moduleUserString (nameModule n)
	      name_occ = occNameUserString (nameOccName n)

localVar :: Name -> DsM (Core String)
localVar n = coreStringLit (occNameUserString (nameOccName n))

849
lookupType :: Name 	-- Name of type constructor (e.g. M.ExpQ)
850 851 852 853
	   -> DsM Type	-- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
		          return (mkGenTyConApp tc []) }

854 855 856 857
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y 
--	--> bindQ (gensym nm1) (\ id1 -> 
--	    bindQ (gensym nm2 (\ id2 -> 
--	    y))
858

859
wrapGenSyns :: [GenSymBind] 
860
	    -> Core (M.Q a) -> DsM (Core (M.Q a))
861 862
wrapGenSyns binds body@(MkC b)
  = go binds
863
  where
864 865 866 867 868 869 870 871
    [elt_ty] = tcTyConAppArgs (exprType b) 
	-- b :: Q a, so we can get the type 'a' by looking at the
	-- argument type. NB: this relies on Q being a data/newtype,
	-- not a type synonym

    go [] = return body
    go ((name,id) : binds)
      = do { MkC body'  <- go binds
872 873 874 875 876
	   ; lit_str    <- localVar name
	   ; gensym_app <- repGensym lit_str
	   ; repBindQ stringTy elt_ty 
		      gensym_app (MkC (Lam id body')) }

877 878 879
-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name
-- Only used for [Decl]
880 881 882 883
wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
wrapNongenSyms binds (MkC body)
  = do { binds' <- mapM do_one binds ;
	 return (MkC (mkLets binds' body)) }
884
  where
885 886 887
    do_one (name,id) 
	= do { MkC lit_str <- localVar name	-- No gensym
	     ; return (NonRec id lit_str) }
888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922

void = placeHolderType

string :: String -> HsExpr Id
string s = HsLit (HsString (mkFastString s))


-- %*********************************************************************
-- %*									*
--		Constructing code
-- %*									*
-- %*********************************************************************

-----------------------------------------------------------------------------
-- PHANTOM TYPES for consistency. In order to make sure we do this correct 
-- we invent a new datatype which uses phantom types.

newtype Core a = MkC CoreExpr
unC (MkC x) = x

rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
rep2 n xs = do { id <- dsLookupGlobalId n
               ; return (MkC (foldl App (Var id) xs)) }

-- Then we make "repConstructors" which use the phantom types for each of the
-- smart constructors of the Meta.Meta datatypes.


-- %*********************************************************************
-- %*									*
--		The 'smart constructors'
-- %*									*
-- %*********************************************************************

--------------- Patterns -----------------
923
repPlit   :: Core M.Lit -> DsM (Core M.Pat) 
924
repPlit (MkC l) = rep2 litPName [l]
925

926
repPvar :: Core String -> DsM (Core M.Pat)
927
repPvar (MkC s) = rep2 varPName [s]
928

929
repPtup :: Core [M.Pat] -> DsM (Core M.Pat)
930
repPtup (MkC ps) = rep2 tupPName [ps]
931

932
repPcon   :: Core String -> Core [M.Pat] -> DsM (Core M.Pat)
933
repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
934

935
repPrec   :: Core String -> Core [(String,M.Pat)] -> DsM (Core M.Pat)
936
repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
937

938
repPtilde :: Core M.Pat -> DsM (Core M.Pat)
939
repPtilde (MkC p) = rep2 tildePName [p]
940

941
repPaspat :: Core String -> Core M.Pat -> DsM (Core M.Pat)
942
repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
943

944
repPwild  :: DsM (Core M.Pat)
945
repPwild = rep2 wildPName []
946

947 948 949
repPlist :: Core [M.Pat] -> DsM (Core M.Pat)
repPlist (MkC ps) = rep2 listPName [ps]