[project @ 2006-01-06 16:30:17 by simonmar]
[ghc-hetmet.git] / ghc / compiler / deSugar / DsMeta.hs
index 501b2d3..fcbcc78 100644 (file)
@@ -28,17 +28,18 @@ import DsMonad
 import qualified Language.Haskell.TH as TH
 
 import HsSyn
+import Class (FunDep)
 import PrelNames  ( rationalTyConName, integerTyConName, negateName )
-import OccName   ( isDataOcc, isTvOcc, occNameUserString )
+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, mkModuleName, moduleUserString )
+import Module    ( Module, mkModule, moduleString )
 import Id         ( Id, mkLocalId )
-import OccName   ( mkOccFS )
+import OccName   ( mkOccNameFS )
 import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule, 
                    isExternalName, getSrcLoc )
 import NameEnv
@@ -52,12 +53,10 @@ import SrcLoc         ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
 import Maybe     ( catMaybes )
 import Unique    ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
 import BasicTypes ( isBoxed ) 
-import Packages          ( thPackage )
 import Outputable
-import Bag       ( bagToList )
+import Bag       ( bagToList, unionManyBags )
 import FastString ( unpackFS )
-import ForeignCall ( Safety(..), ForeignCall(..), CCallConv(..),
-                     CCallTarget(..) )
+import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
 
 import Monad ( zipWithM )
 import List ( sortBy )
@@ -76,7 +75,7 @@ dsBracket brack 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 (TypBr t)  = do { MkC t1  <- repLTy t    ; return t1 }
     do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
 
 {- -------------- Examples --------------------
@@ -112,12 +111,12 @@ repTopDs group
 
        
        decls <- addBinds ss (do {
-                       val_ds  <- mapM rep_bind_group (hs_valds group) ;
+                       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 $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
+                       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 } ;
@@ -132,7 +131,7 @@ repTopDs group
 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
                        hs_fords = foreign_decls })
 -- Collect the binders of a Group
-  = collectGroupBinders val_decls ++
+  = collectHsValBinders val_decls ++
     [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
     [n | L _ (ForeignImport n _ _ _) <- foreign_decls]
 
@@ -198,23 +197,37 @@ repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty }))
 
 repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, 
                      tcdTyVars = tvs, 
-                     tcdFDs = [],      -- We don't understand functional dependencies
+                     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 decls1 } ;
+                 repClass cxt1 cls1 bndrs1 fds1 decls1 } ;
        return $ Just (loc, dec) }
 
 -- Un-handled cases
-repTyClD (L loc d) = do { dsWarn (loc, hang ds_msg 4 (ppr d)) ;
-                          return Nothing
-                        }
+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 ->
@@ -272,24 +285,31 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
 -------------------------------------------------------
 
 repC :: LConDecl Name -> DsM (Core TH.ConQ)
-repC (L loc (ConDecl con [] (L _ []) details))
+repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
   = do { con1 <- lookupLOcc con ;              -- See note [Binders and occurrences] 
         repConstr con1 details }
-
-repC (L loc con_decl)
-  = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
+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") }
-  where
--- gaw 2004 FIX! Need a case for GadtDecl
 
 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
-repBangTy (L _ (HsBangTy str ty)) = do 
-  MkC s <- rep2 strName []
-  MkC t <- repLTy ty
+repBangTy ty= do 
+  MkC s <- rep2 str []
+  MkC t <- repLTy ty'
   rep2 strictTypeName [s, t]
-  where strName = case str of
-                       HsNoBang -> notStrictName
-                       other    -> isStrictName
+  where 
+    (str, ty') = case ty of
+                  L _ (HsBangTy _ ty) -> (isStrictName,  ty)
+                  other               -> (notStrictName, ty)
 
 -------------------------------------------------------
 --                     Deriving clause
@@ -323,8 +343,8 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
        -- Singleton => Ok
        -- Empty     => Too hard, signature ignored
-rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc
-rep_sig other              = return []
+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 ; 
@@ -490,13 +510,17 @@ repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
                               ; z <- repLetE ds e2
                               ; wrapGenSyns ss z }
 -- FIXME: I haven't got the types here right yet
-repE (HsDo DoExpr sts _ ty) 
+repE (HsDo DoExpr sts body ty) 
  = do { (ss,zs) <- repLSts sts; 
-        e       <- repDoE (nonEmptyCoreList zs);
+       body'   <- addBinds ss $ repLE body;
+       ret     <- repNoBindSt body';   
+        e       <- repDoE (nonEmptyCoreList (zs ++ [ret]));
         wrapGenSyns ss e }
-repE (HsDo ListComp sts _ ty) 
+repE (HsDo ListComp sts body ty) 
  = do { (ss,zs) <- repLSts sts; 
-        e       <- repComp (nonEmptyCoreList zs);
+       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 } 
@@ -505,17 +529,17 @@ repE (ExplicitPArr ty es) =
 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)
+repE (RecordCon c _ flds)
  = do { x <- lookupLOcc c;
         fs <- repFields flds;
         repRecCon x fs }
-repE (RecordUpd e flds)
+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 (ArithSeqIn aseq) =
+repE (ArithSeq _ aseq) =
   case aseq of
     From e              -> do { ds1 <- repLE e; repFrom ds1 }
     FromThen e1 e2      -> do 
@@ -531,7 +555,7 @@ repE (ArithSeqIn aseq) =
                             ds2 <- repLE e2
                             ds3 <- repLE e3
                             repFromThenTo ds1 ds2 ds3
-repE (PArrSeqOut _ aseq)  = panic "DsMeta.repE: parallel array seq.s missing"
+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"
@@ -570,7 +594,7 @@ repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
      ; wrapGenSyns (ss1++ss2) clause }}}
 
 repGuards ::  [LGRHS Name] ->  DsM (Core TH.BodyQ)
-repGuards [L _ (GRHS [L _ (ResultStmt e)])]
+repGuards [L _ (GRHS [] e)]
   = do {a <- repLE e; repNormal a }
 repGuards other 
   = do { zs <- mapM process other;
@@ -579,14 +603,13 @@ repGuards other
      wrapGenSyns (concat xs) gd }
   where 
     process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
-    process (L _ (GRHS [])) = panic "No guards in guarded body"
-    process (L _ (GRHS [L _ (ExprStmt e1 ty),
-                       L _ (ResultStmt e2)]))
+    process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
            = do { x <- repLNormalGE e1 e2;
                   return ([], x) }
-    process (L _ (GRHS ss))
+    process (L _ (GRHS ss rhs))
            = do (gs, ss') <- repLSts ss
-                g <- repPatGE (nonEmptyCoreList 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])
@@ -626,11 +649,7 @@ repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
 repLSts stmts = repSts (map unLoc stmts)
 
 repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ])
-repSts [ResultStmt e] = 
-   do { a <- repLE e
-      ; e1 <- repNoBindSt a
-      ; return ([], [e1]) }
-repSts (BindStmt p e : ss) =
+repSts (BindStmt p e _ _ : ss) =
    do { e2 <- repLE e 
       ; ss1 <- mkGenSyms (collectPatBinders p) 
       ; addBinds ss1 $ do {
@@ -643,12 +662,12 @@ repSts (LetStmt bs : ss) =
       ; z <- repLetSt ds
       ; (ss2,zs) <- addBinds ss1 (repSts ss)
       ; return (ss1++ss2, z : zs) } 
-repSts (ExprStmt e ty : ss) =       
+repSts (ExprStmt e _ _ : ss) =       
    do { e2 <- repLE e
       ; z <- repNoBindSt e2 
       ; (ss2,zs) <- repSts ss
       ; return (ss2, z : zs) }
-repSts [] = panic "repSts ran out of statements"      
+repSts [] = return ([],[])
 repSts other = panic "Exotic Stmt in meta brackets"      
 
 
@@ -656,38 +675,39 @@ repSts other = panic "Exotic Stmt in meta brackets"
 --                     Bindings
 -----------------------------------------------------------
 
-repBinds :: [HsBindGroup Name] -> DsM ([GenSymBind], Core [TH.DecQ]) 
-repBinds decs
- = do  { let { bndrs = map unLoc (collectGroupBinders decs) }
+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
-       ; core      <- addBinds ss (rep_bind_groups decs)
-       ; core_list <- coreList decQTyConName core 
+       ; prs       <- addBinds ss (rep_val_binds decs)
+       ; core_list <- coreList decQTyConName 
+                               (de_loc (sort_by_loc prs))
        ; return (ss, core_list) }
 
-rep_bind_groups :: [HsBindGroup Name] -> DsM [Core TH.DecQ]
--- Assumes: all the binders of the binding are alrady in the meta-env
-rep_bind_groups binds = do 
-  locs_cores_s <- mapM rep_bind_group binds
-  return $ de_loc $ sort_by_loc (concat locs_cores_s)
-
-rep_bind_group :: HsBindGroup Name -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
 -- Assumes: all the binders of the binding are alrady in the meta-env
-rep_bind_group (HsBindGroup bs sigs _)
- = do { core1 <- mapM rep_bind (bagToList bs)
+rep_val_binds (ValBindsOut binds sigs)
+ = do { core1 <- rep_binds' (unionManyBags (map snd binds))
       ;        core2 <- rep_sigs' sigs
       ;        return (core1 ++ core2) }
-rep_bind_group (HsIPBinds _)
-  = panic "DsMeta:repBinds: can't do implicit parameters"
 
 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
--- Assumes: all the binders of the binding are alrady in the meta-env
-rep_binds binds = do 
-  locs_cores <- mapM rep_bind (bagToList binds)
-  return $ de_loc $ sort_by_loc locs_cores
+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
@@ -695,7 +715,7 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 -- 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 fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _)))
+rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _) _))
  = do { (ss,wherecore) <- repBinds wheres
        ; guardcore <- addBinds ss (repGuards guards)
        ; fn'  <- lookupLBinder fn
@@ -704,13 +724,13 @@ rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards whe
        ; ans' <- wrapGenSyns ss ans
        ; return (loc, ans') }
 
-rep_bind (L loc (FunBind fn infx (MatchGroup ms _)))
+rep_bind (L loc (FunBind fn infx (MatchGroup ms _) _))
  =   do { ms1 <- mapM repClauseTup ms
        ; fn' <- lookupLBinder fn
         ; ans <- repFun fn' (nonEmptyCoreList ms1)
         ; return (loc, ans) }
 
-rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2))
+rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2 _))
  =   do { patcore <- repLP pat 
         ; (ss,wherecore) <- repBinds wheres
        ; guardcore <- addBinds ss (repGuards guards)
@@ -752,7 +772,7 @@ rep_bind (L loc (VarBind v e))
 -- (\ p1 .. pn -> exp) by causing an error.  
 
 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [])))
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
  = do { let bndrs = collectPatsBinders ps ;
       ; ss  <- mkGenSyms bndrs
       ; lam <- addBinds ss (
@@ -799,8 +819,8 @@ repP (ConPatIn dc details)
                                 p2' <- repLP p2;
                                 repPinfix p1' con_str p2' }
    }
-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 }
+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"
 
@@ -855,11 +875,11 @@ lookupBinder n
   = do { mb_val <- dsLookupMetaEnv n;
         case mb_val of
            Just (Bound x) -> return (coreVar x)
-           other          -> pprPanic "Failed binder lookup:" (ppr n) }
+           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,
+--  * 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)
@@ -889,9 +909,9 @@ globalVar name
   | otherwise
   = do         { MkC occ <- occNameLit name
        ; MkC uni <- coreIntLit (getKey (getUnique name))
-       ; rep2 mkNameUName [occ,uni] }
+       ; rep2 mkNameLName [occ,uni] }
   where
-      name_mod = moduleUserString (nameModule name)
+      name_mod = moduleString (nameModule name)
       name_occ = nameOccName name
       mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
              | OccName.isVarOcc  name_occ = mkNameG_vName
@@ -943,7 +963,7 @@ wrapNongenSyms binds (MkC body)
             ; return (NonRec id var) }
 
 occNameLit :: Name -> DsM (Core String)
-occNameLit n = coreStringLit (occNameUserString (nameOccName n))
+occNameLit n = coreStringLit (occNameString (nameOccName n))
 
 
 -- %*********************************************************************
@@ -1085,8 +1105,8 @@ repLNormalGE g e = do g' <- repLE g
 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] -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
-repPatGE (MkC ss) = rep2 patGEName [ss]
+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)
@@ -1139,8 +1159,11 @@ 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.DecQ] -> DsM (Core TH.DecQ)
-repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, 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]
@@ -1230,7 +1253,7 @@ mk_integer  i = do integer_ty <- lookupType integerTyConName
 mk_rational r = do rat_ty <- lookupType rationalTyConName
                    return $ HsRat r rat_ty
 
-repOverloadedLiteral :: HsOverLit -> DsM (Core TH.Lit)
+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 
@@ -1301,7 +1324,7 @@ templateHaskellNames :: [Name]
 
 templateHaskellNames = [
     returnQName, bindQName, sequenceQName, newNameName, liftName,
-    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName, 
+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, 
 
     -- Lit
     charLName, stringLName, integerLName, intPrimLName,
@@ -1337,7 +1360,7 @@ templateHaskellNames = [
     -- Strict
     isStrictName, notStrictName,
     -- Con
-    normalCName, recCName, infixCName,
+    normalCName, recCName, infixCName, forallCName,
     -- StrictType
     strictTypeName,
     -- VarStrictType
@@ -1351,6 +1374,8 @@ templateHaskellNames = [
     unsafeName,
     safeName,
     threadsafeName,
+    -- FunDep
+    funDepName,
 
     -- And the tycons
     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
@@ -1358,18 +1383,14 @@ templateHaskellNames = [
     decQTyConName, conQTyConName, strictTypeQTyConName,
     varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
     typeTyConName, matchTyConName, clauseTyConName, patQTyConName,
-    fieldPatQTyConName, fieldExpQTyConName]
-
-tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax"
-tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib"
+    fieldPatQTyConName, fieldExpQTyConName, funDepTyConName]
 
 thSyn :: Module
--- NB: the TH.Syntax module comes from the "template-haskell" package
-thSyn = mkModule thPackage  tH_SYN_Name
-thLib = mkModule thPackage  tH_LIB_Name
+thSyn = mkModule "Language.Haskell.TH.Syntax"
+thLib = mkModule "Language.Haskell.TH.Lib"
 
 mk_known_key_name mod space str uniq 
-  = mkExternalName uniq mod (mkOccFS space str) 
+  = mkExternalName uniq mod (mkOccNameFS space str) 
                   Nothing noSrcLoc
 
 libFun = mk_known_key_name thLib OccName.varName
@@ -1378,16 +1399,17 @@ 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
+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
@@ -1398,7 +1420,7 @@ 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
-mkNameUName    = thFun FSLIT("mkNameU")    mkNameUIdKey
+mkNameLName    = thFun FSLIT("mkNameL")    mkNameLIdKey
 
 
 -------------------- TH.Lib -----------------------
@@ -1499,6 +1521,7 @@ notStrictName     = libFun  FSLIT("notStrict")     notStrictKey
 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
@@ -1524,6 +1547,9 @@ 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
@@ -1562,6 +1588,7 @@ 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
@@ -1575,7 +1602,7 @@ mkNameIdKey          = mkPreludeMiscIdUnique 205
 mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
-mkNameUIdKey         = mkPreludeMiscIdUnique 209
+mkNameLIdKey         = mkPreludeMiscIdUnique 209
 
 
 -- data Lit = ...
@@ -1673,6 +1700,7 @@ notStrictKey        = mkPreludeMiscIdUnique 282
 normalCIdKey      = mkPreludeMiscIdUnique 283
 recCIdKey         = mkPreludeMiscIdUnique 284
 infixCIdKey       = mkPreludeMiscIdUnique 285
+forallCIdKey      = mkPreludeMiscIdUnique 288
 
 -- type StrictType = ...
 strictTKey        = mkPreludeMiscIdUnique 286
@@ -1698,3 +1726,6 @@ unsafeIdKey     = mkPreludeMiscIdUnique 305
 safeIdKey       = mkPreludeMiscIdUnique 306
 threadsafeIdKey = mkPreludeMiscIdUnique 307
 
+-- data FunDep = ...
+funDepIdKey = mkPreludeMiscIdUnique 320
+