path: root/ghc/compiler/deSugar/DsMeta.hs

-----------------------------------------------------------------------------
-- 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.
--
-- 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).
-----------------------------------------------------------------------------


module DsMeta( dsBracket, 
	       templateHaskellNames, qTyConName, nameTyConName,
	       liftName, expQTyConName, decQTyConName, typeQTyConName,
	       decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName
	        ) where

#include "HsVersions.h"

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

import MatchLit	  ( dsLit )
import DsUtils    ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
import DsMonad

import qualified Language.Haskell.TH as TH

import HsSyn
import Class (FunDep)
import PrelNames  ( rationalTyConName, integerTyConName, negateName )
import OccName	  ( isDataOcc, isTvOcc, occNameString )
-- 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

import Module	  ( Module, mkModule, moduleString )
import Id         ( Id, mkLocalId )
import OccName	  ( mkOccNameFS )
import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule, 
		    isExternalName, getSrcLoc )
import NameEnv
import Type       ( Type, mkTyConApp )
import TcType	  ( tcTyConAppArgs )
import TyCon	  ( tyConName )
import TysWiredIn ( parrTyCon )
import CoreSyn
import CoreUtils  ( exprType )
import SrcLoc	  ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
import Maybe	  ( catMaybes )
import Unique	  ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
import BasicTypes ( isBoxed ) 
import Outputable
import Bag	  ( bagToList, unionManyBags )
import FastString ( unpackFS )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )

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

dsBracket brack splices
  = dsExtendMetaEnv new_bit (do_brack brack)
  where
    new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices]

    do_brack (VarBr n)  = do { MkC e1  <- lookupOcc n ; return e1 }
    do_brack (ExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
    do_brack (PatBr p)  = do { MkC p1  <- repLP p     ; return p1 }
    do_brack (TypBr t)  = do { MkC t1  <- repLTy t    ; return t1 }
    do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }

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


-------------------------------------------------------
-- 			Declarations
-------------------------------------------------------

repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
repTopDs group
 = do { let { bndrs = map unLoc (groupBinders group) } ;
	ss <- mkGenSyms bndrs ;

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

	
	decls <- addBinds ss (do {
			val_ds  <- rep_val_binds (hs_valds group) ;
			tycl_ds <- mapM repTyClD (hs_tyclds group) ;
			inst_ds <- mapM repInstD' (hs_instds group) ;
			for_ds <- mapM repForD (hs_fords group) ;
			-- more needed
			return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;

	decl_ty <- lookupType decQTyConName ;
	let { core_list = coreList' decl_ty decls } ;

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

	wrapNongenSyms ss q_decs
	-- Do *not* gensym top-level binders
      }

groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
			hs_fords = foreign_decls })
-- Collect the binders of a Group
  = collectHsValBinders val_decls ++
    [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
    [n | L _ (ForeignImport n _ _ _) <- foreign_decls]


{- 	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.
And we use lookupOcc, rather than lookupBinder
in repTyClD and repC.

-}

repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))

repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, 
		    tcdLName = tc, tcdTyVars = tvs, 
		    tcdCons = cons, tcdDerivs = mb_derivs }))
 = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
        dec <- addTyVarBinds tvs $ \bndrs -> do {
      	       cxt1    <- repLContext cxt ;
               cons1   <- mapM repC cons ;
      	       cons2   <- coreList conQTyConName cons1 ;
      	       derivs1 <- repDerivs mb_derivs ;
	       bndrs1  <- coreList nameTyConName bndrs ;
      	       repData cxt1 tc1 bndrs1 cons2 derivs1 } ;
        return $ Just (loc, dec) }

repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, 
		    tcdLName = tc, tcdTyVars = tvs, 
		    tcdCons = [con], tcdDerivs = mb_derivs }))
 = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
        dec <- addTyVarBinds tvs $ \bndrs -> do {
      	       cxt1   <- repLContext cxt ;
               con1   <- repC con ;
      	       derivs1 <- repDerivs mb_derivs ;
	       bndrs1  <- coreList nameTyConName bndrs ;
      	       repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ;
        return $ Just (loc, dec) }

repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
 = do { tc1 <- lookupLOcc tc ;		-- See note [Binders and occurrences] 
        dec <- addTyVarBinds tvs $ \bndrs -> do {
	       ty1     <- repLTy ty ;
	       bndrs1  <- coreList nameTyConName bndrs ;
	       repTySyn tc1 bndrs1 ty1 } ;
 	return (Just (loc, dec)) }

repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, 
		      tcdTyVars = tvs, 
		      tcdFDs = fds,
		      tcdSigs = sigs, tcdMeths = meth_binds }))
 = do { cls1 <- lookupLOcc cls ;		-- See note [Binders and occurrences] 
    	dec  <- addTyVarBinds tvs $ \bndrs -> do {
 		  cxt1   <- repLContext cxt ;
 		  sigs1  <- rep_sigs sigs ;
 		  binds1 <- rep_binds meth_binds ;
	          fds1 <- repLFunDeps fds;
 		  decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
	          bndrs1 <- coreList nameTyConName bndrs ;
 		  repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
    	return $ Just (loc, dec) }

-- Un-handled cases
repTyClD (L loc d) = putSrcSpanDs loc $
		     do { dsWarn (hang ds_msg 4 (ppr d))
			; return Nothing }

-- represent fundeps
--
repLFunDeps :: [Located (FunDep Name)] -> DsM (Core [TH.FunDep])
repLFunDeps fds = do fds' <- mapM repLFunDep fds
                     fdList <- coreList funDepTyConName fds'
                     return fdList

repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep)
repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
                               ys' <- mapM lookupBinder ys
                               xs_list <- coreList nameTyConName xs'
                               ys_list <- coreList nameTyConName ys'
                               repFunDep xs_list ys_list

repInstD' (L loc (InstDecl ty binds _))		-- Ignore user pragmas for now
 = do	{ i <- addTyVarBinds tvs $ \tv_bndrs ->
		-- We must bring the type variables into scope, so their occurrences
		-- don't fail,  even though the binders don't appear in the resulting 
		-- data structure
		do {  cxt1 <- repContext cxt
		   ; inst_ty1 <- repPred (HsClassP cls tys)
		   ; ss <- mkGenSyms (collectHsBindBinders binds)
		   ; binds1 <- addBinds ss (rep_binds binds)
		   ; decls1 <- coreList decQTyConName binds1
		   ; decls2 <- wrapNongenSyms ss decls1
		   -- wrapNonGenSyms: do not clone the class op names!
		   -- They must be called 'op' etc, not 'op34'
		   ; repInst cxt1 inst_ty1 decls2 }

	; return (loc, i)}
 where
   (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty)

repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)
repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis) _))
 = do MkC name' <- lookupLOcc name
      MkC typ' <- repLTy typ
      MkC cc' <- repCCallConv cc
      MkC s' <- repSafety s
      MkC str <- coreStringLit $ static
                              ++ unpackFS ch ++ " "
                              ++ unpackFS cn ++ " "
                              ++ conv_cimportspec cis
      dec <- rep2 forImpDName [cc', s', str, name', typ']
      return (loc, dec)
 where
    conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled"
    conv_cimportspec (CFunction DynamicTarget) = "dynamic"
    conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs
    conv_cimportspec CWrapper = "wrapper"
    static = case cis of
                 CFunction (StaticTarget _) -> "static "
                 _ -> ""

repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName []

repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName []
repSafety (PlaySafe False) = rep2 safeName []
repSafety (PlaySafe True) = rep2 threadsafeName []

ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")

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

repC :: LConDecl Name -> DsM (Core TH.ConQ)
repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
  = do { con1 <- lookupLOcc con ;		-- See note [Binders and occurrences] 
	 repConstr con1 details }
repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98))
  = do { addTyVarBinds tvs $ \bndrs -> do {
             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
             ctxt' <- repContext ctxt;
             bndrs' <- coreList nameTyConName bndrs;
             rep2 forallCName [unC bndrs', unC ctxt', unC c']
         }
       }
repC (L loc con_decl)		-- GADTs
  = putSrcSpanDs loc $ 
    do	{ dsWarn (hang ds_msg 4 (ppr con_decl))
	; return (panic "DsMeta:repC") }

repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy ty= do 
  MkC s <- rep2 str []
  MkC t <- repLTy ty'
  rep2 strictTypeName [s, t]
  where 
    (str, ty') = case ty of
		   L _ (HsBangTy _ ty) -> (isStrictName,  ty)
		   other	       -> (notStrictName, ty)

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

repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name])
repDerivs Nothing = coreList nameTyConName []
repDerivs (Just ctxt)
  = do { strs <- mapM rep_deriv ctxt ; 
	 coreList nameTyConName strs }
  where
    rep_deriv :: LHsType Name -> DsM (Core TH.Name)
	-- Deriving clauses must have the simple H98 form
    rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls
    rep_deriv other		  		 = panic "rep_deriv"


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

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

rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]
	-- We silently ignore ones we don't recognise
rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
		     return (concat sigs1) }

rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
	-- Singleton => Ok
	-- Empty     => Too hard, signature ignored
rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
rep_sig other		        = return []

rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; 
		       ty1 <- repLTy ty ; 
		       sig <- repProto nm1 ty1 ;
		       return [(loc, sig)] }


-------------------------------------------------------
-- 			Types
-------------------------------------------------------

-- 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
-- meta environment and gets the *new* names on Core-level as an argument
--
addTyVarBinds :: [LHsTyVarBndr Name]	         -- the binders to be added
	      -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env
	      -> DsM (Core (TH.Q a))
addTyVarBinds tvs m =
  do
    let names = map (hsTyVarName.unLoc) tvs
    freshNames <- mkGenSyms names
    term       <- addBinds freshNames $ do
		    bndrs <- mapM lookupBinder names 
		    m bndrs
    wrapGenSyns freshNames term

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

repContext :: HsContext Name -> DsM (Core TH.CxtQ)
repContext ctxt = do 
	            preds    <- mapM repLPred ctxt
		    predList <- coreList typeQTyConName preds
		    repCtxt predList

-- represent a type predicate
--
repLPred :: LHsPred Name -> DsM (Core TH.TypeQ)
repLPred (L _ p) = repPred p

repPred :: HsPred Name -> DsM (Core TH.TypeQ)
repPred (HsClassP cls tys) = do
			       tcon <- repTy (HsTyVar cls)
			       tys1 <- repLTys tys
			       repTapps tcon tys1
repPred (HsIParam _ _)     = 
  panic "DsMeta.repTy: Can't represent predicates with implicit parameters"

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

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

repTy :: HsType Name -> DsM (Core TH.TypeQ)
repTy (HsForAllTy _ tvs ctxt ty)  = 
  addTyVarBinds tvs $ \bndrs -> do
    ctxt1  <- repLContext ctxt
    ty1    <- repLTy ty
    bndrs1 <- coreList nameTyConName bndrs
    repTForall bndrs1 ctxt1 ty1

repTy (HsTyVar n)
  | isTvOcc (nameOccName n)       = do 
				      tv1 <- lookupBinder n
				      repTvar tv1
  | otherwise		          = do 
				      tc1 <- lookupOcc n
				      repNamedTyCon tc1
repTy (HsAppTy f a)               = do 
				      f1 <- repLTy f
				      a1 <- repLTy a
				      repTapp f1 a1
repTy (HsFunTy f a)               = do 
				      f1   <- repLTy f
				      a1   <- repLTy a
				      tcon <- repArrowTyCon
				      repTapps tcon [f1, a1]
repTy (HsListTy t)		  = do
				      t1   <- repLTy t
				      tcon <- repListTyCon
				      repTapp tcon t1
repTy (HsPArrTy t)                = do
				      t1   <- repLTy t
				      tcon <- repTy (HsTyVar (tyConName parrTyCon))
				      repTapp tcon t1
repTy (HsTupleTy tc tys)	  = do
				      tys1 <- repLTys tys 
				      tcon <- repTupleTyCon (length tys)
				      repTapps tcon tys1
repTy (HsOpTy ty1 n ty2) 	  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) 
					   `nlHsAppTy` ty2)
repTy (HsParTy t)  	       	  = repLTy t
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"


-----------------------------------------------------------------------------
-- 		Expressions
-----------------------------------------------------------------------------

repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])
repLEs es = do { es'  <- mapM repLE es ;
		 coreList expQTyConName es' }

-- 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
repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
repLE (L _ e) = repE e

repE :: HsExpr Name -> DsM (Core TH.ExpQ)
repE (HsVar x)            =
  do { mb_val <- dsLookupMetaEnv x 
     ; case mb_val of
	Nothing	         -> do { str <- globalVar x
			       ; repVarOrCon x str }
	Just (Bound y)   -> repVarOrCon x (coreVar y)
	Just (Splice e)  -> do { e' <- dsExpr e
			       ; return (MkC e') } }
repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"

	-- 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 (MatchGroup [m] _)) = repLambda m
repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}

repE (OpApp e1 op fix e2) =
  do { arg1 <- repLE e1; 
       arg2 <- repLE e2; 
       the_op <- repLE op ;
       repInfixApp arg1 the_op arg2 } 
repE (NegApp x nm)        = do
			      a         <- repLE x
			      negateVar <- lookupOcc negateName >>= repVar
			      negateVar `repApp` a
repE (HsPar x)            = repLE x
repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b } 
repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b } 
repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
				       ; ms2 <- mapM repMatchTup ms
				       ; repCaseE arg (nonEmptyCoreList ms2) }
repE (HsIf x y z)         = do
			      a <- repLE x
			      b <- repLE y
			      c <- repLE z
			      repCond a b c
repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
			       ; e2 <- addBinds ss (repLE e)
			       ; z <- repLetE ds e2
			       ; wrapGenSyns ss z }
-- FIXME: I haven't got the types here right yet
repE (HsDo DoExpr sts body ty) 
 = do { (ss,zs) <- repLSts sts; 
	body'	<- addBinds ss $ repLE body;
	ret	<- repNoBindSt body';	
        e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
        wrapGenSyns ss e }
repE (HsDo ListComp sts body ty) 
 = do { (ss,zs) <- repLSts sts; 
	body'	<- addBinds ss $ repLE body;
	ret	<- repNoBindSt body';	
        e       <- repComp (nonEmptyCoreList (zs ++ [ret]));
        wrapGenSyns ss e }
repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } 
repE (ExplicitPArr ty es) = 
  panic "DsMeta.repE: No explicit parallel arrays yet"
repE (ExplicitTuple es boxed) 
  | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
  | otherwise		  = panic "DsMeta.repE: Can't represent unboxed tuples"
repE (RecordCon c _ flds)
 = do { x <- lookupLOcc c;
        fs <- repFields flds;
        repRecCon x fs }
repE (RecordUpd e flds _ _)
 = do { x <- repLE e;
        fs <- repFields flds;
        repRecUpd x fs }

repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }
repE (ArithSeq _ aseq) =
  case aseq of
    From e              -> do { ds1 <- repLE e; repFrom ds1 }
    FromThen e1 e2      -> do 
		             ds1 <- repLE e1
			     ds2 <- repLE e2
			     repFromThen ds1 ds2
    FromTo   e1 e2      -> do 
			     ds1 <- repLE e1
			     ds2 <- repLE e2
			     repFromTo ds1 ds2
    FromThenTo e1 e2 e3 -> do 
			     ds1 <- repLE e1
			     ds2 <- repLE e2
			     ds3 <- repLE e3
			     repFromThenTo ds1 ds2 ds3
repE (PArrSeq _ aseq)     = panic "DsMeta.repE: parallel array seq.s missing"
repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
repE (HsBracketOut _ _)   = panic "DsMeta.repE: Can't represent Oxford brackets"
repE (HsSpliceE (HsSplice n _)) 
  = 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 e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)

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

repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ) 
repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
  do { ss1 <- mkGenSyms (collectPatBinders p) 
     ; addBinds ss1 $ do {
     ; p1 <- repLP p
     ; (ss2,ds) <- repBinds wheres
     ; addBinds ss2 $ do {
     ; gs    <- repGuards guards
     ; match <- repMatch p1 gs ds
     ; wrapGenSyns (ss1++ss2) match }}}

repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
  do { ss1 <- mkGenSyms (collectPatsBinders ps) 
     ; addBinds ss1 $ do {
       ps1 <- repLPs ps
     ; (ss2,ds) <- repBinds wheres
     ; addBinds ss2 $ do {
       gs <- repGuards guards
     ; clause <- repClause ps1 gs ds
     ; wrapGenSyns (ss1++ss2) clause }}}

repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
repGuards [L _ (GRHS [] e)]
  = do {a <- repLE e; repNormal a }
repGuards other 
  = do { zs <- mapM process other;
     let {(xs, ys) = unzip zs};
	 gd <- repGuarded (nonEmptyCoreList ys);
     wrapGenSyns (concat xs) gd }
  where 
    process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
    process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
           = do { x <- repLNormalGE e1 e2;
                  return ([], x) }
    process (L _ (GRHS ss rhs))
           = do (gs, ss') <- repLSts ss
		rhs' <- addBinds gs $ repLE rhs
                g <- repPatGE (nonEmptyCoreList ss') rhs'
                return (gs, g)

repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
repFields flds = do
        fnames <- mapM lookupLOcc (map fst flds)
        es <- mapM repLE (map snd flds)
        fs <- zipWithM repFieldExp fnames es
        coreList fieldExpQTyConName fs


-----------------------------------------------------------------------------
-- Representing Stmt's is tricky, especially if bound variables
-- shadow 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.

repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
repLSts stmts = repSts (map unLoc stmts)

repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
repSts (BindStmt p e _ _ : ss) =
   do { e2 <- repLE e 
      ; ss1 <- mkGenSyms (collectPatBinders p) 
      ; addBinds ss1 $ do {
      ; p1 <- repLP p; 
      ; (ss2,zs) <- repSts ss
      ; z <- repBindSt p1 e2
      ; return (ss1++ss2, z : zs) }}
repSts (LetStmt bs : ss) =
   do { (ss1,ds) <- repBinds bs
      ; z <- repLetSt ds
      ; (ss2,zs) <- addBinds ss1 (repSts ss)
      ; return (ss1++ss2, z : zs) } 
repSts (ExprStmt e _ _ : ss) =       
   do { e2 <- repLE e
      ; z <- repNoBindSt e2 
      ; (ss2,zs) <- repSts ss
      ; return (ss2, z : zs) }
repSts [] = return ([],[])
repSts other = panic "Exotic Stmt in meta brackets"      


-----------------------------------------------------------
--			Bindings
-----------------------------------------------------------

repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) 
repBinds EmptyLocalBinds
  = do	{ core_list <- coreList decQTyConName []
	; return ([], core_list) }

repBinds (HsIPBinds _)
  = panic "DsMeta:repBinds: can't do implicit parameters"

repBinds (HsValBinds decs)
 = do	{ let { bndrs = map unLoc (collectHsValBinders decs) }
		-- No need to worrry about detailed scopes within
		-- the binding group, because we are talking Names
		-- here, so we can safely treat it as a mutually 
		-- recursive group
	; ss        <- mkGenSyms bndrs
	; prs       <- addBinds ss (rep_val_binds decs)
	; core_list <- coreList decQTyConName 
				(de_loc (sort_by_loc prs))
	; return (ss, core_list) }

rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
-- Assumes: all the binders of the binding are alrady in the meta-env
rep_val_binds (ValBindsOut binds sigs)
 = do { core1 <- rep_binds' (unionManyBags (map snd binds))
      ;	core2 <- rep_sigs' sigs
      ;	return (core1 ++ core2) }

rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
rep_binds binds = do { binds_w_locs <- rep_binds' binds
		     ; return (de_loc (sort_by_loc binds_w_locs)) }

rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
rep_binds' binds = mapM rep_bind (bagToList binds)

rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
-- Assumes: all the binders of the binding are alrady in the meta-env

-- 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
rep_bind (L loc (FunBind { fun_id = fn, 
			   fun_matches = MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _ }))
 = do { (ss,wherecore) <- repBinds wheres
	; guardcore <- addBinds ss (repGuards guards)
	; fn'  <- lookupLBinder fn
	; p    <- repPvar fn'
	; ans  <- repVal p guardcore wherecore
	; ans' <- wrapGenSyns ss ans
	; return (loc, ans') }

rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MatchGroup ms _ }))
 =   do { ms1 <- mapM repClauseTup ms
	; fn' <- lookupLBinder fn
        ; ans <- repFun fn' (nonEmptyCoreList ms1)
        ; return (loc, ans) }

rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
 =   do { patcore <- repLP pat 
        ; (ss,wherecore) <- repBinds wheres
	; guardcore <- addBinds ss (repGuards guards)
        ; ans  <- repVal patcore guardcore wherecore
	; ans' <- wrapGenSyns ss ans
        ; return (loc, ans') }

rep_bind (L loc (VarBind { var_id = v, var_rhs = e}))
 =   do { v' <- lookupBinder v 
	; e2 <- repLE e
        ; x <- repNormal e2
        ; patcore <- repPvar v'
	; empty_decls <- coreList decQTyConName [] 
        ; ans <- repVal patcore x empty_decls
        ; return (srcLocSpan (getSrcLoc v), ans) }

-----------------------------------------------------------------------------
-- Since everything in a Bind 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


-----------------------------------------------------------------------------
-- GHC allows a more general form of lambda abstraction than specified
-- 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.  

repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
 = do { let bndrs = collectPatsBinders ps ;
      ; ss  <- mkGenSyms bndrs
      ; lam <- addBinds ss (
		do { xs <- repLPs ps; body <- repLE e; repLam xs body })
      ; wrapGenSyns ss lam }

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

  
-----------------------------------------------------------------------------
--			Patterns
-- 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
repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])
repLPs ps = do { ps' <- mapM repLP ps ;
		 coreList patQTyConName ps' }

repLP :: LPat Name -> DsM (Core TH.PatQ)
repLP (L _ p) = repP p

repP :: Pat Name -> DsM (Core TH.PatQ)
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 <- repLP p; repPtilde p1 }
repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
repP (ParPat p)        = repLP p 
repP (ListPat ps _)    = do { qs <- repLPs ps; repPlist qs }
repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
repP (ConPatIn dc details)
 = do { con_str <- lookupLOcc dc
      ; case details of
         PrefixCon ps   -> do { qs <- repLPs ps; repPcon con_str qs }
         RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs)
                            ; ps <- sequence $ map repLP (map snd pairs)
                            ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
                            ; fps' <- coreList fieldPatQTyConName fps
                            ; repPrec con_str fps' }
         InfixCon p1 p2 -> do { p1' <- repLP p1;
                                p2' <- repLP p2;
                                repPinfix p1' con_str p2' }
   }
repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))"
repP (NPat l Nothing _ _)  = do { a <- repOverloadedLiteral l; repPlit a }
repP (SigPatIn p t)  = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }
repP other = panic "Exotic pattern inside meta brackets"

----------------------------------------------------------
-- Declaration ordering helpers

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

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

----------------------------------------------------------
--	The meta-environment

-- A name/identifier association for fresh names of locally bound entities
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 ...

-- Generate a fresh name for a locally bound entity

mkGenSyms :: [Name] -> DsM [GenSymBind]
-- We can use the existing name.  For example:
--	[| \x_77 -> x_77 + x_77 |]
-- desugars to
--	do { x_77 <- genSym "x"; .... }
-- We use the same x_77 in the desugared program, but with the type Bndr
-- instead of Int
--
-- We do make it an Internal name, though (hence localiseName)
--
-- Nevertheless, it's monadic because we have to generate nameTy
mkGenSyms ns = do { var_ty <- lookupType nameTyConName
		  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }

	     
addBinds :: [GenSymBind] -> DsM a -> DsM a
-- 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 bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m

-- Look up a locally bound name
--
lookupLBinder :: Located Name -> DsM (Core TH.Name)
lookupLBinder (L _ n) = lookupBinder n

lookupBinder :: Name -> DsM (Core TH.Name)
lookupBinder n 
  = do { mb_val <- dsLookupMetaEnv n;
	 case mb_val of
	    Just (Bound x) -> return (coreVar x)
	    other	   -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) }

-- 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
--
lookupLOcc :: Located Name -> DsM (Core TH.Name)
-- Lookup an occurrence; it can't be a splice.
-- Use the in-scope bindings if they exist
lookupLOcc (L _ n) = lookupOcc n

lookupOcc :: Name -> DsM (Core TH.Name)
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 TH.Name)
-- Not bound by the meta-env
-- Could be top-level; or could be local
--	f x = $(g [| x |])
-- Here the x will be local
globalVar name
  | isExternalName name
  = do	{ MkC mod <- coreStringLit name_mod
	; MkC occ <- occNameLit name
	; rep2 mk_varg [mod,occ] }
  | otherwise
  = do 	{ MkC occ <- occNameLit name
	; MkC uni <- coreIntLit (getKey (getUnique name))
	; rep2 mkNameLName [occ,uni] }
  where
      name_mod = moduleString (nameModule name)
      name_occ = nameOccName name
      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
	      | OccName.isVarOcc  name_occ = mkNameG_vName
	      | OccName.isTcOcc   name_occ = mkNameG_tcName
	      | otherwise 	           = pprPanic "DsMeta.globalVar" (ppr name)

lookupType :: Name 	-- Name of type constructor (e.g. TH.ExpQ)
	   -> DsM Type	-- The type
lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
		          return (mkTyConApp tc []) }

wrapGenSyns :: [GenSymBind] 
	    -> Core (TH.Q a) -> DsM (Core (TH.Q a))
-- wrapGenSyns [(nm1,id1), (nm2,id2)] y 
--	--> bindQ (gensym nm1) (\ id1 -> 
--	    bindQ (gensym nm2 (\ id2 -> 
--	    y))

wrapGenSyns binds body@(MkC b)
  = do  { var_ty <- lookupType nameTyConName
	; go var_ty binds }
  where
    [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 var_ty [] = return body
    go var_ty ((name,id) : binds)
      = do { MkC body'  <- go var_ty binds
	   ; lit_str    <- occNameLit name
	   ; gensym_app <- repGensym lit_str
	   ; repBindQ var_ty elt_ty 
		      gensym_app (MkC (Lam id body')) }

-- Just like wrapGenSym, but don't actually do the gensym
-- Instead use the existing name:
--	let x = "x" in ...
-- Only used for [Decl], and for the class ops in class 
-- and instance decls
wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
wrapNongenSyms binds (MkC body)
  = do { binds' <- mapM do_one binds ;
	 return (MkC (mkLets binds' body)) }
  where
    do_one (name,id) 
	= do { MkC lit_str <- occNameLit name
	     ; MkC var <- rep2 mkNameName [lit_str]
	     ; return (NonRec id var) }

occNameLit :: Name -> DsM (Core String)
occNameLit n = coreStringLit (occNameString (nameOccName n))


-- %*********************************************************************
-- %*									*
--		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 -----------------
repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ) 
repPlit (MkC l) = rep2 litPName [l]

repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
repPvar (MkC s) = rep2 varPName [s]

repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPtup (MkC ps) = rep2 tupPName [ps]

repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]

repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]

repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]

repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
repPtilde (MkC p) = rep2 tildePName [p]

repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]

repPwild  :: DsM (Core TH.PatQ)
repPwild = rep2 wildPName []

repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
repPlist (MkC ps) = rep2 listPName [ps]

repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]

--------------- Expressions -----------------
repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
	           | otherwise 		        = repVar str

repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
repVar (MkC s) = rep2 varEName [s] 

repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
repCon (MkC s) = rep2 conEName [s] 

repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
repLit (MkC c) = rep2 litEName [c] 

repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repApp (MkC x) (MkC y) = rep2 appEName [x,y] 

repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]

repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repTup (MkC es) = rep2 tupEName [es]

repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repCond (MkC x) (MkC y) (MkC z) =  rep2 condEName [x,y,z] 

repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] 

repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]

repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
repDoE (MkC ss) = rep2 doEName [ss]

repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
repComp (MkC ss) = rep2 compEName [ss]

repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
repListExp (MkC es) = rep2 listEName [es]

repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]

repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]

repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]

repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]

repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]

repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]

repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]

------------ Right hand sides (guarded expressions) ----
repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
repGuarded (MkC pairs) = rep2 guardedBName [pairs]

repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
repNormal (MkC e) = rep2 normalBName [e]

------------ Guards ----
repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
repLNormalGE g e = do g' <- repLE g
                      e' <- repLE e
                      repNormalGE g' e'

repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]

repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]

------------- Stmts -------------------
repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]

repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
repLetSt (MkC ds) = rep2 letSName [ds]

repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
repNoBindSt (MkC e) = rep2 noBindSName [e]

-------------- Range (Arithmetic sequences) -----------
repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
repFrom (MkC x) = rep2 fromEName [x]

repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]

repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]

repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]

------------ Match and Clause Tuples -----------
repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]

repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]

-------------- Dec -----------------------------
repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]

repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)  
repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]

repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)
repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs)
    = rep2 dataDName [cxt, nm, tvs, cons, derivs]

repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)
repNewtype (MkC cxt) (MkC nm) (MkC tvs) (MkC con) (MkC derivs)
    = rep2 newtypeDName [cxt, nm, tvs, con, derivs]

repTySyn :: Core TH.Name -> Core [TH.Name] -> Core TH.TypeQ -> DsM (Core TH.DecQ)
repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]

repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]

repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.Name] -> Core [TH.FunDep] -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) = rep2 classDName [cxt, cls, tvs, fds, ds]

repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]

repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]

repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ)
repCtxt (MkC tys) = rep2 cxtName [tys]

repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name)
          -> DsM (Core TH.ConQ)
repConstr con (PrefixCon ps)
    = do arg_tys  <- mapM repBangTy ps
         arg_tys1 <- coreList strictTypeQTyConName arg_tys
         rep2 normalCName [unC con, unC arg_tys1]
repConstr con (RecCon ips)
    = do arg_vs   <- mapM lookupLOcc (map fst ips)
         arg_tys  <- mapM repBangTy (map snd ips)
         arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
                              arg_vs arg_tys
         arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
         rep2 recCName [unC con, unC arg_vtys']
repConstr con (InfixCon st1 st2)
    = do arg1 <- repBangTy st1
         arg2 <- repBangTy st2
         rep2 infixCName [unC arg1, unC con, unC arg2]

------------ Types -------------------

repTForall :: Core [TH.Name] -> Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
repTForall (MkC tvars) (MkC ctxt) (MkC ty)
    = rep2 forallTName [tvars, ctxt, ty]

repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
repTvar (MkC s) = rep2 varTName [s]

repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
repTapp (MkC t1) (MkC t2) = rep2 appTName [t1,t2]

repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
repTapps f []     = return f
repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }

--------- Type constructors --------------

repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
repNamedTyCon (MkC s) = rep2 conTName [s]

repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
-- Note: not Core Int; it's easier to be direct here
repTupleTyCon i = rep2 tupleTName [mkIntExpr (fromIntegral i)]

repArrowTyCon :: DsM (Core TH.TypeQ)
repArrowTyCon = rep2 arrowTName []

repListTyCon :: DsM (Core TH.TypeQ)
repListTyCon = rep2 listTName []


----------------------------------------------------------
--		Literals

repLiteral :: HsLit -> DsM (Core TH.Lit)
repLiteral lit 
  = do lit' <- case lit of
                   HsIntPrim i    -> mk_integer i
                   HsInt i        -> mk_integer i
                   HsFloatPrim r  -> mk_rational r
                   HsDoublePrim r -> mk_rational r
                   _ -> return lit
       lit_expr <- dsLit lit'
       rep2 lit_name [lit_expr]
  where
    lit_name = case lit of
		 HsInteger _ _  -> integerLName
		 HsInt     _    -> integerLName
		 HsIntPrim _    -> intPrimLName
		 HsFloatPrim _  -> floatPrimLName
		 HsDoublePrim _ -> doublePrimLName
		 HsChar _       -> charLName
		 HsString _     -> stringLName
		 HsRat _ _      -> rationalLName
		 other 	        -> uh_oh
    uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
		    (ppr lit)

mk_integer  i = do integer_ty <- lookupType integerTyConName
                   return $ HsInteger i integer_ty
mk_rational r = do rat_ty <- lookupType rationalTyConName
                   return $ HsRat r rat_ty

repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
repOverloadedLiteral (HsIntegral i _)   = do { lit <- mk_integer  i; repLiteral lit }
repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
	-- The type Rational will be in the environment, becuase 
	-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
	-- and rationalL is sucked in when any TH stuff is used
              
--------------- Miscellaneous -------------------

repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
repGensym (MkC lit_str) = rep2 newNameName [lit_str]

repBindQ :: Type -> Type	-- a and b
	 -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
repBindQ ty_a ty_b (MkC x) (MkC y) 
  = rep2 bindQName [Type ty_a, Type ty_b, x, y] 

repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
repSequenceQ ty_a (MkC list)
  = rep2 sequenceQName [Type ty_a, list]

------------ Lists and Tuples -------------------
-- turn a list of patterns into a single pattern matching a list

coreList :: Name	-- Of the TyCon of the element type
	 -> [Core a] -> DsM (Core [a])
coreList tc_name es 
  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }

coreList' :: Type 	-- The element type
	  -> [Core a] -> Core [a]
coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))

nonEmptyCoreList :: [Core a] -> Core [a]
  -- The list must be non-empty so we can get the element type
  -- Otherwise use coreList
nonEmptyCoreList [] 	      = panic "coreList: empty argument"
nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))

corePair :: (Core a, Core b) -> Core (a,b)
corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])

coreStringLit :: String -> DsM (Core String)
coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }

coreIntLit :: Int -> DsM (Core Int)
coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))

coreVar :: Id -> Core TH.Name	-- The Id has type Name
coreVar id = MkC (Var id)



-- %************************************************************************
-- %*									*
--		The known-key names for Template Haskell
-- %*									*
-- %************************************************************************

-- To add a name, do three things
-- 
--  1) Allocate a key
--  2) Make a "Name"
--  3) Add the name to knownKeyNames

templateHaskellNames :: [Name]
-- The names that are implicitly mentioned by ``bracket''
-- Should stay in sync with the import list of DsMeta

templateHaskellNames = [
    returnQName, bindQName, sequenceQName, newNameName, liftName,
    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, 

    -- Lit
    charLName, stringLName, integerLName, intPrimLName,
    floatPrimLName, doublePrimLName, rationalLName,
    -- Pat
    litPName, varPName, tupPName, conPName, tildePName, infixPName,
    asPName, wildPName, recPName, listPName, sigPName,
    -- FieldPat
    fieldPatName,
    -- Match
    matchName,
    -- Clause
    clauseName,
    -- Exp
    varEName, conEName, litEName, appEName, infixEName,
    infixAppName, sectionLName, sectionRName, lamEName, tupEName,
    condEName, letEName, caseEName, doEName, compEName,
    fromEName, fromThenEName, fromToEName, fromThenToEName,
    listEName, sigEName, recConEName, recUpdEName,
    -- FieldExp
    fieldExpName,
    -- Body
    guardedBName, normalBName,
    -- Guard
    normalGEName, patGEName,
    -- Stmt
    bindSName, letSName, noBindSName, parSName,
    -- Dec
    funDName, valDName, dataDName, newtypeDName, tySynDName,
    classDName, instanceDName, sigDName, forImpDName,
    -- Cxt
    cxtName,
    -- Strict
    isStrictName, notStrictName,
    -- Con
    normalCName, recCName, infixCName, forallCName,
    -- StrictType
    strictTypeName,
    -- VarStrictType
    varStrictTypeName,
    -- Type
    forallTName, varTName, conTName, appTName,
    tupleTName, arrowTName, listTName,
    -- Callconv
    cCallName, stdCallName,
    -- Safety
    unsafeName,
    safeName,
    threadsafeName,
    -- FunDep
    funDepName,

    -- And the tycons
    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
    clauseQTyConName, expQTyConName, fieldExpTyConName, stmtQTyConName,
    decQTyConName, conQTyConName, strictTypeQTyConName,
    varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
    typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
    fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]

thSyn :: Module
thSyn = mkModule "Language.Haskell.TH.Syntax"
thLib = mkModule "Language.Haskell.TH.Lib"

mk_known_key_name mod space str uniq 
  = mkExternalName uniq mod (mkOccNameFS space str) 
	           Nothing noSrcLoc

libFun = mk_known_key_name thLib OccName.varName
libTc  = mk_known_key_name thLib OccName.tcName
thFun  = mk_known_key_name thSyn OccName.varName
thTc   = mk_known_key_name thSyn OccName.tcName

-------------------- TH.Syntax -----------------------
qTyConName        = thTc FSLIT("Q")            qTyConKey
nameTyConName     = thTc FSLIT("Name")         nameTyConKey
fieldExpTyConName = thTc FSLIT("FieldExp")     fieldExpTyConKey
patTyConName      = thTc FSLIT("Pat")          patTyConKey
fieldPatTyConName = thTc FSLIT("FieldPat")     fieldPatTyConKey
expTyConName      = thTc FSLIT("Exp")          expTyConKey
decTyConName      = thTc FSLIT("Dec")          decTyConKey
typeTyConName     = thTc FSLIT("Type")         typeTyConKey
matchTyConName    = thTc FSLIT("Match")        matchTyConKey
clauseTyConName   = thTc FSLIT("Clause")       clauseTyConKey
funDepTyConName   = thTc FSLIT("FunDep")       funDepTyConKey

returnQName   = thFun FSLIT("returnQ")   returnQIdKey
bindQName     = thFun FSLIT("bindQ")     bindQIdKey
sequenceQName = thFun FSLIT("sequenceQ") sequenceQIdKey
newNameName    = thFun FSLIT("newName")   newNameIdKey
liftName      = thFun FSLIT("lift")      liftIdKey
mkNameName     = thFun FSLIT("mkName")     mkNameIdKey
mkNameG_vName  = thFun FSLIT("mkNameG_v")  mkNameG_vIdKey
mkNameG_dName  = thFun FSLIT("mkNameG_d")  mkNameG_dIdKey
mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
mkNameLName    = thFun FSLIT("mkNameL")    mkNameLIdKey


-------------------- TH.Lib -----------------------
-- data Lit = ...
charLName       = libFun FSLIT("charL")       charLIdKey
stringLName     = libFun FSLIT("stringL")     stringLIdKey
integerLName    = libFun FSLIT("integerL")    integerLIdKey
intPrimLName    = libFun FSLIT("intPrimL")    intPrimLIdKey
floatPrimLName  = libFun FSLIT("floatPrimL")  floatPrimLIdKey
doublePrimLName = libFun FSLIT("doublePrimL") doublePrimLIdKey
rationalLName   = libFun FSLIT("rationalL")     rationalLIdKey

-- data Pat = ...
litPName   = libFun FSLIT("litP")   litPIdKey
varPName   = libFun FSLIT("varP")   varPIdKey
tupPName   = libFun FSLIT("tupP")   tupPIdKey
conPName   = libFun FSLIT("conP")   conPIdKey
infixPName = libFun FSLIT("infixP") infixPIdKey
tildePName = libFun FSLIT("tildeP") tildePIdKey
asPName    = libFun FSLIT("asP")    asPIdKey
wildPName  = libFun FSLIT("wildP")  wildPIdKey
recPName   = libFun FSLIT("recP")   recPIdKey
listPName  = libFun FSLIT("listP")  listPIdKey
sigPName   = libFun FSLIT("sigP")   sigPIdKey

-- type FieldPat = ...
fieldPatName = libFun FSLIT("fieldPat") fieldPatIdKey

-- data Match = ...
matchName = libFun FSLIT("match") matchIdKey

-- data Clause = ...	 
clauseName = libFun FSLIT("clause") clauseIdKey

-- data Exp = ...
varEName        = libFun FSLIT("varE")        varEIdKey
conEName        = libFun FSLIT("conE")        conEIdKey
litEName        = libFun FSLIT("litE")        litEIdKey
appEName        = libFun FSLIT("appE")        appEIdKey
infixEName      = libFun FSLIT("infixE")      infixEIdKey
infixAppName    = libFun FSLIT("infixApp")    infixAppIdKey
sectionLName    = libFun FSLIT("sectionL")    sectionLIdKey
sectionRName    = libFun FSLIT("sectionR")    sectionRIdKey
lamEName        = libFun FSLIT("lamE")        lamEIdKey
tupEName        = libFun FSLIT("tupE")        tupEIdKey
condEName       = libFun FSLIT("condE")       condEIdKey
letEName        = libFun FSLIT("letE")        letEIdKey
caseEName       = libFun FSLIT("caseE")       caseEIdKey
doEName         = libFun FSLIT("doE")         doEIdKey
compEName       = libFun FSLIT("compE")       compEIdKey
-- ArithSeq skips a level
fromEName       = libFun FSLIT("fromE")       fromEIdKey
fromThenEName   = libFun FSLIT("fromThenE")   fromThenEIdKey
fromToEName     = libFun FSLIT("fromToE")     fromToEIdKey
fromThenToEName = libFun FSLIT("fromThenToE") fromThenToEIdKey
-- end ArithSeq
listEName       = libFun FSLIT("listE")       listEIdKey
sigEName        = libFun FSLIT("sigE")        sigEIdKey
recConEName     = libFun FSLIT("recConE")     recConEIdKey
recUpdEName     = libFun FSLIT("recUpdE")     recUpdEIdKey

-- type FieldExp = ...
fieldExpName = libFun FSLIT("fieldExp") fieldExpIdKey

-- data Body = ...
guardedBName = libFun FSLIT("guardedB") guardedBIdKey
normalBName  = libFun FSLIT("normalB")  normalBIdKey

-- data Guard = ...
normalGEName = libFun FSLIT("normalGE") normalGEIdKey
patGEName    = libFun FSLIT("patGE")    patGEIdKey

-- data Stmt = ...
bindSName   = libFun FSLIT("bindS")   bindSIdKey
letSName    = libFun FSLIT("letS")    letSIdKey
noBindSName = libFun FSLIT("noBindS") noBindSIdKey
parSName    = libFun FSLIT("parS")    parSIdKey

-- data Dec = ...
funDName      = libFun FSLIT("funD")      funDIdKey
valDName      = libFun FSLIT("valD")      valDIdKey
dataDName     = libFun FSLIT("dataD")     dataDIdKey
newtypeDName  = libFun FSLIT("newtypeD")  newtypeDIdKey
tySynDName    = libFun FSLIT("tySynD")    tySynDIdKey
classDName    = libFun FSLIT("classD")    classDIdKey
instanceDName = libFun FSLIT("instanceD") instanceDIdKey
sigDName      = libFun FSLIT("sigD")      sigDIdKey
forImpDName   = libFun FSLIT("forImpD")   forImpDIdKey

-- type Ctxt = ...
cxtName = libFun FSLIT("cxt") cxtIdKey

-- data Strict = ...
isStrictName      = libFun  FSLIT("isStrict")      isStrictKey
notStrictName     = libFun  FSLIT("notStrict")     notStrictKey

-- data Con = ...	 
normalCName = libFun FSLIT("normalC") normalCIdKey
recCName    = libFun FSLIT("recC")    recCIdKey
infixCName  = libFun FSLIT("infixC")  infixCIdKey
forallCName  = libFun FSLIT("forallC")  forallCIdKey
			 
-- type StrictType = ...
strictTypeName    = libFun  FSLIT("strictType")    strictTKey

-- type VarStrictType = ...
varStrictTypeName = libFun  FSLIT("varStrictType") varStrictTKey

-- data Type = ...
forallTName = libFun FSLIT("forallT") forallTIdKey
varTName    = libFun FSLIT("varT")    varTIdKey
conTName    = libFun FSLIT("conT")    conTIdKey
tupleTName  = libFun FSLIT("tupleT") tupleTIdKey
arrowTName  = libFun FSLIT("arrowT") arrowTIdKey
listTName   = libFun FSLIT("listT")  listTIdKey
appTName    = libFun FSLIT("appT")    appTIdKey
			 
-- data Callconv = ...
cCallName = libFun FSLIT("cCall") cCallIdKey
stdCallName = libFun FSLIT("stdCall") stdCallIdKey

-- data Safety = ...
unsafeName     = libFun FSLIT("unsafe") unsafeIdKey
safeName       = libFun FSLIT("safe") safeIdKey
threadsafeName = libFun FSLIT("threadsafe") threadsafeIdKey
             
-- data FunDep = ...
funDepName     = libFun FSLIT("funDep") funDepIdKey

matchQTyConName         = libTc FSLIT("MatchQ")        matchQTyConKey
clauseQTyConName        = libTc FSLIT("ClauseQ")       clauseQTyConKey
expQTyConName           = libTc FSLIT("ExpQ")          expQTyConKey
stmtQTyConName          = libTc FSLIT("StmtQ")         stmtQTyConKey
decQTyConName           = libTc FSLIT("DecQ")          decQTyConKey
conQTyConName           = libTc FSLIT("ConQ")          conQTyConKey
strictTypeQTyConName    = libTc FSLIT("StrictTypeQ")    strictTypeQTyConKey
varStrictTypeQTyConName = libTc FSLIT("VarStrictTypeQ") varStrictTypeQTyConKey
typeQTyConName          = libTc FSLIT("TypeQ")          typeQTyConKey
fieldExpQTyConName      = libTc FSLIT("FieldExpQ")      fieldExpQTyConKey
patQTyConName           = libTc FSLIT("PatQ")           patQTyConKey
fieldPatQTyConName      = libTc FSLIT("FieldPatQ")      fieldPatQTyConKey

--	TyConUniques available: 100-129
-- 	Check in PrelNames if you want to change this

expTyConKey             = mkPreludeTyConUnique 100
matchTyConKey           = mkPreludeTyConUnique 101
clauseTyConKey          = mkPreludeTyConUnique 102
qTyConKey               = mkPreludeTyConUnique 103
expQTyConKey            = mkPreludeTyConUnique 104
decQTyConKey            = mkPreludeTyConUnique 105
patTyConKey             = mkPreludeTyConUnique 106
matchQTyConKey          = mkPreludeTyConUnique 107
clauseQTyConKey         = mkPreludeTyConUnique 108
stmtQTyConKey           = mkPreludeTyConUnique 109
conQTyConKey            = mkPreludeTyConUnique 110
typeQTyConKey           = mkPreludeTyConUnique 111
typeTyConKey            = mkPreludeTyConUnique 112
decTyConKey             = mkPreludeTyConUnique 113
varStrictTypeQTyConKey  = mkPreludeTyConUnique 114
strictTypeQTyConKey     = mkPreludeTyConUnique 115
fieldExpTyConKey        = mkPreludeTyConUnique 116
fieldPatTyConKey        = mkPreludeTyConUnique 117
nameTyConKey            = mkPreludeTyConUnique 118
patQTyConKey            = mkPreludeTyConUnique 119
fieldPatQTyConKey       = mkPreludeTyConUnique 120
fieldExpQTyConKey       = mkPreludeTyConUnique 121
funDepTyConKey          = mkPreludeTyConUnique 122

-- 	IdUniques available: 200-399
-- 	If you want to change this, make sure you check in PrelNames

returnQIdKey        = mkPreludeMiscIdUnique 200
bindQIdKey          = mkPreludeMiscIdUnique 201
sequenceQIdKey      = mkPreludeMiscIdUnique 202
liftIdKey           = mkPreludeMiscIdUnique 203
newNameIdKey         = mkPreludeMiscIdUnique 204
mkNameIdKey          = mkPreludeMiscIdUnique 205
mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
mkNameLIdKey         = mkPreludeMiscIdUnique 209


-- data Lit = ...
charLIdKey        = mkPreludeMiscIdUnique 210
stringLIdKey      = mkPreludeMiscIdUnique 211
integerLIdKey     = mkPreludeMiscIdUnique 212
intPrimLIdKey     = mkPreludeMiscIdUnique 213
floatPrimLIdKey   = mkPreludeMiscIdUnique 214
doublePrimLIdKey  = mkPreludeMiscIdUnique 215
rationalLIdKey    = mkPreludeMiscIdUnique 216

-- data Pat = ...
litPIdKey         = mkPreludeMiscIdUnique 220
varPIdKey         = mkPreludeMiscIdUnique 221
tupPIdKey         = mkPreludeMiscIdUnique 222
conPIdKey         = mkPreludeMiscIdUnique 223
infixPIdKey       = mkPreludeMiscIdUnique 312
tildePIdKey       = mkPreludeMiscIdUnique 224
asPIdKey          = mkPreludeMiscIdUnique 225
wildPIdKey        = mkPreludeMiscIdUnique 226
recPIdKey         = mkPreludeMiscIdUnique 227
listPIdKey        = mkPreludeMiscIdUnique 228
sigPIdKey         = mkPreludeMiscIdUnique 229

-- type FieldPat = ...
fieldPatIdKey       = mkPreludeMiscIdUnique 230

-- data Match = ...
matchIdKey          = mkPreludeMiscIdUnique 231

-- data Clause = ...
clauseIdKey         = mkPreludeMiscIdUnique 232

-- data Exp = ...
varEIdKey         = mkPreludeMiscIdUnique 240
conEIdKey         = mkPreludeMiscIdUnique 241
litEIdKey         = mkPreludeMiscIdUnique 242
appEIdKey         = mkPreludeMiscIdUnique 243
infixEIdKey       = mkPreludeMiscIdUnique 244
infixAppIdKey       = mkPreludeMiscIdUnique 245
sectionLIdKey       = mkPreludeMiscIdUnique 246
sectionRIdKey       = mkPreludeMiscIdUnique 247
lamEIdKey         = mkPreludeMiscIdUnique 248
tupEIdKey         = mkPreludeMiscIdUnique 249
condEIdKey        = mkPreludeMiscIdUnique 250
letEIdKey         = mkPreludeMiscIdUnique 251
caseEIdKey        = mkPreludeMiscIdUnique 252
doEIdKey          = mkPreludeMiscIdUnique 253
compEIdKey        = mkPreludeMiscIdUnique 254
fromEIdKey        = mkPreludeMiscIdUnique 255
fromThenEIdKey    = mkPreludeMiscIdUnique 256
fromToEIdKey      = mkPreludeMiscIdUnique 257
fromThenToEIdKey  = mkPreludeMiscIdUnique 258
listEIdKey        = mkPreludeMiscIdUnique 259
sigEIdKey         = mkPreludeMiscIdUnique 260
recConEIdKey      = mkPreludeMiscIdUnique 261
recUpdEIdKey      = mkPreludeMiscIdUnique 262

-- type FieldExp = ...
fieldExpIdKey       = mkPreludeMiscIdUnique 265

-- data Body = ...
guardedBIdKey     = mkPreludeMiscIdUnique 266
normalBIdKey      = mkPreludeMiscIdUnique 267

-- data Guard = ...
normalGEIdKey     = mkPreludeMiscIdUnique 310
patGEIdKey        = mkPreludeMiscIdUnique 311

-- data Stmt = ...
bindSIdKey       = mkPreludeMiscIdUnique 268
letSIdKey        = mkPreludeMiscIdUnique 269
noBindSIdKey     = mkPreludeMiscIdUnique 270
parSIdKey        = mkPreludeMiscIdUnique 271

-- data Dec = ...
funDIdKey         = mkPreludeMiscIdUnique 272
valDIdKey         = mkPreludeMiscIdUnique 273
dataDIdKey        = mkPreludeMiscIdUnique 274
newtypeDIdKey     = mkPreludeMiscIdUnique 275
tySynDIdKey       = mkPreludeMiscIdUnique 276
classDIdKey       = mkPreludeMiscIdUnique 277
instanceDIdKey    = mkPreludeMiscIdUnique 278
sigDIdKey         = mkPreludeMiscIdUnique 279
forImpDIdKey      = mkPreludeMiscIdUnique 297

-- type Cxt = ...
cxtIdKey            = mkPreludeMiscIdUnique 280

-- data Strict = ...
isStrictKey         = mkPreludeMiscIdUnique 281
notStrictKey        = mkPreludeMiscIdUnique 282

-- data Con = ...
normalCIdKey      = mkPreludeMiscIdUnique 283
recCIdKey         = mkPreludeMiscIdUnique 284
infixCIdKey       = mkPreludeMiscIdUnique 285
forallCIdKey      = mkPreludeMiscIdUnique 288

-- type StrictType = ...
strictTKey        = mkPreludeMiscIdUnique 286

-- type VarStrictType = ...
varStrictTKey     = mkPreludeMiscIdUnique 287

-- data Type = ...
forallTIdKey      = mkPreludeMiscIdUnique 290
varTIdKey         = mkPreludeMiscIdUnique 291
conTIdKey         = mkPreludeMiscIdUnique 292
tupleTIdKey       = mkPreludeMiscIdUnique 294
arrowTIdKey       = mkPreludeMiscIdUnique 295
listTIdKey        = mkPreludeMiscIdUnique 296
appTIdKey         = mkPreludeMiscIdUnique 293

-- data Callconv = ...
cCallIdKey      = mkPreludeMiscIdUnique 300
stdCallIdKey    = mkPreludeMiscIdUnique 301

-- data Safety = ...
unsafeIdKey     = mkPreludeMiscIdUnique 305
safeIdKey       = mkPreludeMiscIdUnique 306
threadsafeIdKey = mkPreludeMiscIdUnique 307

-- data FunDep = ...
funDepIdKey = mkPreludeMiscIdUnique 320