[project @ 2003-03-16 14:15:21 by igloo]
[ghc-hetmet.git] / ghc / compiler / deSugar / DsMeta.hs
index 3414ab7..4c0d351 100644 (file)
@@ -42,7 +42,8 @@ import HsSyn            ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
                    toHsType
                  )
 
-import PrelNames  ( mETA_META_Name, rationalTyConName )
+import PrelNames  ( mETA_META_Name, rationalTyConName, negateName,
+                   parrTyConName )
 import MkIface   ( ifaceTyThing )
 import Name       ( Name, nameOccName, nameModule )
 import OccName   ( isDataOcc, isTvOcc, occNameUserString )
@@ -58,19 +59,23 @@ import Name   ( mkKnownKeyExternalName )
 import OccName   ( mkOccFS )
 import NameEnv
 import NameSet
-import Type       ( Type, TyThing(..), mkGenTyConApp )
+import Type       ( Type, mkGenTyConApp )
+import TcType    ( TyThing(..), tcTyConAppArgs )
 import TyCon     ( DataConDetails(..) )
 import TysWiredIn ( stringTy )
 import CoreSyn
 import CoreUtils  ( exprType )
 import SrcLoc    ( noSrcLoc )
-import Maybe     ( catMaybes )
+import Maybes    ( orElse )
+import Maybe     ( catMaybes, fromMaybe )
 import Panic     ( panic )
 import Unique    ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
 import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) 
 
 import Outputable
 import FastString      ( mkFastString )
+
+import Monad ( zipWithM )
  
 -----------------------------------------------------------------------------
 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
@@ -141,7 +146,7 @@ repTopDs group
        --      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
+       -- only "T", not "Foo:T" where Foo is the current module
 
        
        decls <- addBinds ss (do {
@@ -153,7 +158,9 @@ repTopDs group
 
        decl_ty <- lookupType declTyConName ;
        let { core_list = coreList' decl_ty decls } ;
-       q_decs  <- repSequenceQ decl_ty core_list ;
+
+       dec_ty <- lookupType decTyConName ;
+       q_decs  <- repSequenceQ dec_ty core_list ;
 
        wrapNongenSyms ss q_decs
        -- Do *not* gensym top-level binders
@@ -193,29 +200,42 @@ in repTyClD and repC.
 
 repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
 
-repTyClD (TyData { tcdND = DataType, tcdCtxt = [], 
+repTyClD (TyData { tcdND = DataType, tcdCtxt = cxt, 
                   tcdName = tc, tcdTyVars = tvs, 
                   tcdCons = DataCons cons, tcdDerivs = mb_derivs }) 
- = do { tc1  <- lookupOcc tc ;         -- See note [Binders and occurrences] 
-       tvs1  <- repTvs tvs ;
-       cons1 <- mapM repC cons ;
-       cons2 <- coreList consTyConName cons1 ;
-       derivs1 <- repDerivs mb_derivs ;
-       dec <- repData tc1 tvs1 cons2 derivs1 ;
-       return (Just dec) }
+ = do { tc1 <- lookupOcc tc ;          -- See note [Binders and occurrences] 
+        dec <- addTyVarBinds tvs $ \bndrs -> do {
+              cxt1   <- repContext cxt ;
+               cons1   <- mapM repC cons ;
+              cons2   <- coreList consTyConName cons1 ;
+              derivs1 <- repDerivs mb_derivs ;
+              repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
+        return $ Just dec }
+
+repTyClD (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty })
+ = do { tc1 <- lookupOcc tc ;          -- See note [Binders and occurrences] 
+        dec <- addTyVarBinds tvs $ \bndrs -> do {
+              ty1 <- repTy ty ;
+              repTySyn tc1 (coreList' stringTy bndrs) ty1 } ;
+       return (Just dec) }
 
 repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls, 
-                     tcdTyVars = tvs, tcdFDs = [], 
-                     tcdSigs = sigs, tcdMeths = Just binds
-       })
+                     tcdTyVars = tvs, 
+                     tcdFDs = [],      -- We don't understand functional dependencies
+                     tcdSigs = sigs, tcdMeths = mb_meth_binds })
  = do { cls1 <- lookupOcc cls ;                -- See note [Binders and occurrences] 
-       tvs1 <- repTvs tvs ;
-       cxt1 <- repCtxt cxt ;
-       sigs1  <- rep_sigs sigs ;
-       binds1 <- rep_monobind binds ;
-       decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
-       dec <- repClass cxt1 cls1 tvs1 decls1 ;
-       return (Just dec) }
+       dec  <- addTyVarBinds tvs $ \bndrs -> do {
+                 cxt1   <- repContext cxt ;
+                 sigs1  <- rep_sigs sigs ;
+                 binds1 <- rep_monobind meth_binds ;
+                 decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
+                 repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
+       return $ Just dec }
+ where
+       -- If the user quotes a class decl, it'll have default-method 
+       -- bindings; but if we (reifyDecl C) where C is a class, we
+       -- won't be given the default methods (a definite infelicity).
+   meth_binds = mb_meth_binds `orElse` EmptyMonoBinds
 
 -- Un-handled cases
 repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
@@ -226,7 +246,7 @@ repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
 
 repInstD (InstDecl ty binds _ _ loc)
        -- Ignore user pragmas for now
- = do { cxt1 <- repCtxt cxt ;
+ = do { cxt1 <- repContext cxt ;
        inst_ty1 <- repPred (HsClassP cls tys) ;
        binds1 <- rep_monobind binds ;
        decls1 <- coreList declTyConName binds1 ;
@@ -242,15 +262,15 @@ repInstD (InstDecl ty binds _ _ loc)
 repC :: ConDecl Name -> DsM (Core M.Cons)
 repC (ConDecl con [] [] details loc)
   = do { con1     <- lookupOcc con ;           -- See note [Binders and occurrences] 
-        arg_tys  <- mapM (repBangTy con) (hsConArgs details) ;
-        arg_tys1 <- coreList typeTyConName arg_tys ;
-        repConstr con1 arg_tys1 }
+        repConstr con1 details }
 
-repBangTy con (BangType NotMarkedStrict ty) = repTy ty
-repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) }
-   where
-     msg = ptext SLIT("Ignoring stricness on argument of constructor")
-                <+> quotes (ppr con)
+repBangTy :: BangType Name -> DsM (Core (M.Q (M.Strictness, M.Typ)))
+repBangTy (BangType str ty) = do MkC s <- rep2 strName []
+                                 MkC t <- repTy ty
+                                 rep2 strictTypeName [s, t]
+    where strName = case str of
+                        NotMarkedStrict -> nonstrictName
+                        _ -> strictName
 
 -------------------------------------------------------
 --                     Deriving clause
@@ -284,7 +304,7 @@ rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty
 rep_sig (Sig nm ty _)         = rep_proto nm ty
 rep_sig other                 = return []
 
-rep_proto nm ty = do { nm1 <- lookupBinder nm ; 
+rep_proto nm ty = do { nm1 <- lookupOcc nm ; 
                       ty1 <- repTy ty ; 
                       sig <- repProto nm1 ty1 ;
                       return [sig] }
@@ -294,45 +314,92 @@ rep_proto nm ty = do { nm1 <- lookupBinder nm ;
 --                     Types
 -------------------------------------------------------
 
-repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
-repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
-                 return (coreList' stringTy tvs1) } 
-
------------------
-repCtxt :: HsContext Name -> DsM (Core M.Ctxt)
-repCtxt ctxt = do { preds <- mapM repPred ctxt; 
-                   coreList typeTyConName preds }
+-- 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 :: [HsTyVarBndr Name]             -- the binders to be added
+             -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
+             -> DsM (Core (M.Q a))
+addTyVarBinds tvs m =
+  do
+    let names = map hsTyVarName tvs
+    freshNames <- mkGenSyms names
+    term       <- addBinds freshNames $ do
+                   bndrs <- mapM lookupBinder names 
+                   m bndrs
+    wrapGenSyns freshNames term
+
+-- represent a type context
+--
+repContext :: HsContext Name -> DsM (Core M.Ctxt)
+repContext ctxt = do 
+                   preds    <- mapM repPred ctxt
+                   predList <- coreList typeTyConName preds
+                   repCtxt predList
 
------------------
+-- represent a type predicate
+--
 repPred :: HsPred Name -> DsM (Core M.Type)
-repPred (HsClassP cls tys)
-  = do { tc1 <- lookupOcc cls; tcon <- repNamedTyCon tc1;
-        tys1 <- repTys tys; repTapps tcon tys1 }
-repPred (HsIParam _ _) = panic "No implicit parameters yet"
-
------------------
+repPred (HsClassP cls tys) = do
+                              tcon <- repTy (HsTyVar cls)
+                              tys1 <- repTys tys
+                              repTapps tcon tys1
+repPred (HsIParam _ _)     = 
+  panic "DsMeta.repTy: Can't represent predicates with implicit parameters"
+
+-- yield the representation of a list of types
+--
 repTys :: [HsType Name] -> DsM [Core M.Type]
 repTys tys = mapM repTy tys
 
------------------
+-- represent a type
+--
 repTy :: HsType Name -> DsM (Core M.Type)
+repTy (HsForAllTy bndrs ctxt ty)  = 
+  addTyVarBinds (fromMaybe [] bndrs) $ \bndrs' -> do
+    ctxt'  <- repContext ctxt
+    ty'    <- repTy ty
+    repTForall (coreList' stringTy bndrs') ctxt' ty'
 
 repTy (HsTyVar n)
-  | isTvOcc (nameOccName n) = do { tv1 <- localVar n ; repTvar tv1 }
-  | otherwise              = do { tc1 <- lookupOcc n; repNamedTyCon tc1 }
-repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a1 }
-repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; 
-                          tcon <- repArrowTyCon ; repTapps tcon [f1,a1] }
-repTy (HsListTy t)  = do { t1 <- repTy t ; tcon <- repListTyCon ; repTapp tcon t1 }
-repTy (HsTupleTy tc tys)         = do { tys1 <- repTys tys; 
-                                        tcon <- repTupleTyCon (length tys);
-                                        repTapps tcon tys1 }
+  | isTvOcc (nameOccName n)       = do 
+                                     tv1 <- lookupBinder n
+                                     repTvar tv1
+  | otherwise                    = do 
+                                     tc1 <- lookupOcc n
+                                     repNamedTyCon tc1
+repTy (HsAppTy f a)               = do 
+                                     f1 <- repTy f
+                                     a1 <- repTy a
+                                     repTapp f1 a1
+repTy (HsFunTy f a)               = do 
+                                     f1   <- repTy f
+                                     a1   <- repTy a
+                                     tcon <- repArrowTyCon
+                                     repTapps tcon [f1, a1]
+repTy (HsListTy t)               = do
+                                     t1   <- repTy t
+                                     tcon <- repListTyCon
+                                     repTapp tcon t1
+repTy (HsPArrTy t)                = do
+                                     t1   <- repTy t
+                                     tcon <- repTy (HsTyVar parrTyConName)
+                                     repTapp tcon t1
+repTy (HsTupleTy tc tys)         = do
+                                     tys1 <- repTys tys 
+                                     tcon <- repTupleTyCon (length tys)
+                                     repTapps tcon tys1
 repTy (HsOpTy ty1 HsArrow ty2)           = repTy (HsFunTy ty1 ty2)
-repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2)
+repTy (HsOpTy ty1 (HsTyOp n) ty2) = repTy ((HsTyVar n `HsAppTy` ty1) 
+                                          `HsAppTy` ty2)
 repTy (HsParTy t)                = repTy t
-repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsAppTy (HsTyVar c) tys)
+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"
 
-repTy other_ty = pprPanic "repTy" (ppr other_ty)       -- HsForAllTy, HsKindSig
 
 -----------------------------------------------------------------------------
 --             Expressions
@@ -364,13 +431,14 @@ repE (HsLam m)     = repLambda m
 repE (HsApp x y)   = do {a <- repE x; b <- repE y; repApp a b}
 
 repE (OpApp e1 op fix e2) =
-  case op of
-    HsVar op -> do { arg1 <- repE e1; 
-                    arg2 <- repE e2; 
-                    the_op <- lookupOcc op ;
-                    repInfixApp arg1 the_op arg2 } 
-    _        -> panic "DsMeta.repE: Operator is not a variable"
-repE (NegApp x nm)        = repE x >>= repNeg
+  do { arg1 <- repE e1; 
+       arg2 <- repE e2; 
+       the_op <- repE op ;
+       repInfixApp arg1 the_op arg2 } 
+repE (NegApp x nm)        = do
+                             a         <- repE x
+                             negateVar <- lookupOcc negateName >>= repVar
+                             negateVar `repApp` a
 repE (HsPar x)            = repE x
 repE (SectionL x y)       = do { a <- repE x; b <- repE y; repSectionL a b } 
 repE (SectionR x y)       = do { a <- repE x; b <- repE y; repSectionR a b } 
@@ -385,26 +453,31 @@ repE (HsIf x y z loc)     = do
 repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
                               ; e2 <- addBinds ss (repE e)
                               ; z <- repLetE ds e2
-                              ; wrapGenSyns expTyConName ss z }
+                              ; wrapGenSyns ss z }
 -- FIXME: I haven't got the types here right yet
-repE (HsDo ctxt sts _ ty loc) 
-  | isComprCtxt ctxt      = do { (ss,zs) <- repSts sts; 
-                                e       <- repDoE (nonEmptyCoreList zs);
-                                wrapGenSyns expTyConName ss e }
-  | otherwise             = 
-    panic "DsMeta.repE: Can't represent mdo and [: :] yet"
-  where
-    isComprCtxt ListComp = True
-    isComprCtxt DoExpr  = True
-    isComprCtxt _       = False
+repE (HsDo DoExpr sts _ ty loc) 
+ = do { (ss,zs) <- repSts sts; 
+        e       <- repDoE (nonEmptyCoreList zs);
+        wrapGenSyns ss e }
+repE (HsDo ListComp sts _ ty loc) 
+ = do { (ss,zs) <- repSts sts; 
+        e       <- repComp (nonEmptyCoreList zs);
+        wrapGenSyns ss e }
+repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } 
 repE (ExplicitPArr ty es) = 
   panic "DsMeta.repE: No explicit parallel arrays yet"
 repE (ExplicitTuple es boxed) 
   | isBoxed boxed         = do { xs <- repEs es; repTup xs }
   | otherwise            = panic "DsMeta.repE: Can't represent unboxed tuples"
-repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
-repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
+repE (RecordCon c flds)
+ = do { x <- lookupOcc c;
+        fs <- repFields flds;
+        repRecCon x fs }
+repE (RecordUpd e flds)
+ = do { x <- repE e;
+        fs <- repFields flds;
+        repRecUpd x fs }
 
 repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
 repE (ArithSeqIn aseq) =
@@ -424,6 +497,7 @@ repE (ArithSeqIn aseq) =
                             ds3 <- repE e3
                             repFromThenTo ds1 ds2 ds3
 repE (PArrSeqOut _ aseq)  = panic "DsMeta.repE: parallel array seq.s missing"
+repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
 repE (HsCCall _ _ _ _ _)  = panic "DsMeta.repE: Can't represent __ccall__"
 repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
 repE (HsBracketOut _ _)   = 
@@ -449,7 +523,7 @@ repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) =
      ; addBinds ss2 $ do {
      ; gs    <- repGuards guards
      ; match <- repMatch p1 gs ds
-     ; wrapGenSyns matTyConName (ss1++ss2) match }}}
+     ; wrapGenSyns (ss1++ss2) match }}}
 
 repClauseTup ::  Match Name -> DsM (Core M.Clse)
 repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = 
@@ -460,7 +534,7 @@ repClauseTup (Match ps ty (GRHSs guards wheres ty2)) =
      ; addBinds ss2 $ do {
        gs <- repGuards guards
      ; clause <- repClause ps1 gs ds
-     ; wrapGenSyns clsTyConName (ss1++ss2) clause }}}
+     ; wrapGenSyns (ss1++ss2) clause }}}
 
 repGuards ::  [GRHS Name] ->  DsM (Core M.Rihs)
 repGuards [GRHS [ResultStmt e loc] loc2] 
@@ -473,6 +547,13 @@ repGuards other
            = do { x <- repE e1; y <- repE e2; return (x, y) }
     process other = panic "Non Haskell 98 guarded body"
 
+repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FldE])
+repFields flds = do
+        fnames <- mapM lookupOcc (map fst flds)
+        es <- mapM repE (map snd flds)
+        fs <- zipWithM (\n x -> rep2 fieldName [unC n, unC x]) fnames es
+        coreList fieldTyConName fs
+
 
 -----------------------------------------------------------------------------
 -- Representing Stmt's is tricky, especially if bound variables
@@ -620,7 +701,7 @@ repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ]
       ; ss <- mkGenSyms bndrs
       ; lam <- addBinds ss (
                do { xs <- repPs ps; body <- repE e; repLam xs body })
-      ; wrapGenSyns expTyConName ss lam }
+      ; wrapGenSyns ss lam }
 
 repLambda z = panic "Can't represent a guarded lambda in Template Haskell"  
 
@@ -650,7 +731,11 @@ repP (ConPatIn dc details)
  = do { con_str <- lookupOcc dc
       ; case details of
          PrefixCon ps   -> do { qs <- repPs ps; repPcon con_str qs }
-         RecCon pairs   -> error "No records in template haskell yet"
+         RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
+                            ; ps <- sequence $ map repP (map snd pairs)
+                            ; fps <- zipWithM (\x y -> rep2 fieldPName [unC x,unC y]) vs ps
+                            ; fps' <- coreList fieldPTyConName fps
+                            ; repPrec con_str fps' }
          InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
    }
 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
@@ -670,19 +755,31 @@ repListPat (p:ps) = do { p2 <- repP p
 ----------------------------------------------------------
 --     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 ...
 
-addBinds :: [GenSymBind] -> DsM a -> DsM a
-addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
-
+-- Generate a fresh name for a locally bound entity
+--
 mkGenSym :: Name -> DsM GenSymBind
 mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) }
 
+-- Ditto for a list of names
+--
 mkGenSyms :: [Name] -> DsM [GenSymBind]
 mkGenSyms ns = mapM mkGenSym ns
             
+-- Add a list of fresh names for locally bound entities to the meta
+-- environment (which is part of the state carried around by the desugarer
+-- monad) 
+--
+addBinds :: [GenSymBind] -> DsM a -> DsM a
+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
+
+-- Look up a locally bound name
+--
 lookupBinder :: Name -> DsM (Core String)
 lookupBinder n 
   = do { mb_val <- dsLookupMetaEnv n;
@@ -690,6 +787,11 @@ lookupBinder n
            Just (Bound x) -> return (coreVar x)
            other          -> pprPanic "Failed binder lookup:" (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
+--
 lookupOcc :: Name -> DsM (Core String)
 -- Lookup an occurrence; it can't be a splice.
 -- Use the in-scope bindings if they exist
@@ -720,16 +822,19 @@ lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
 --         bindQ (gensym nm2 (\ id2 -> 
 --         y))
 
-wrapGenSyns :: Name    -- Name of the type (consructor) for 'a'
-           -> [GenSymBind] 
+wrapGenSyns :: [GenSymBind] 
            -> Core (M.Q a) -> DsM (Core (M.Q a))
-wrapGenSyns tc_name binds body@(MkC b)
-  = do { elt_ty <- lookupType tc_name
-       ; go elt_ty binds }
+wrapGenSyns binds body@(MkC b)
+  = go binds
   where
-    go elt_ty [] = return body
-    go elt_ty ((name,id) : binds)
-      = do { MkC body'  <- go elt_ty binds
+    [elt_ty] = tcTyConAppArgs (exprType b) 
+       -- b :: Q a, so we can get the type 'a' by looking at the
+       -- argument type. NB: this relies on Q being a data/newtype,
+       -- not a type synonym
+
+    go [] = return body
+    go ((name,id) : binds)
+      = do { MkC body'  <- go binds
           ; lit_str    <- localVar name
           ; gensym_app <- repGensym lit_str
           ; repBindQ stringTy elt_ty 
@@ -793,6 +898,9 @@ repPtup (MkC ps) = rep2 ptupName [ps]
 repPcon   :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
 
+repPrec   :: Core String -> Core [(String,M.Patt)] -> DsM (Core M.Patt)
+repPrec (MkC c) (MkC rps) = rep2 precName [c,rps]
+
 repPtilde :: Core M.Patt -> DsM (Core M.Patt)
 repPtilde (MkC p) = rep2 ptildeName [p]
 
@@ -846,17 +954,20 @@ repListExp (MkC es) = rep2 listExpName [es]
 repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
 repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
 
-repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
-repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+repRecCon :: Core String -> Core [M.FldE]-> DsM (Core M.Expr)
+repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs]
 
-repNeg :: Core M.Expr -> DsM (Core M.Expr)
-repNeg (MkC x) = rep2 negName [x]
+repRecUpd :: Core M.Expr -> Core [M.FldE] -> DsM (Core M.Expr)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs]
+
+repInfixApp :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
 
 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
 
 repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
 
 ------------ Right hand sides (guarded expressions) ----
 repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
@@ -902,8 +1013,11 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
 repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)  
 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
 
-repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
-repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
+repData :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
+repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs]
+
+repTySyn :: Core String -> Core [String] -> Core M.Type -> DsM (Core M.Decl)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
 
 repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] -> DsM (Core M.Decl)
 repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instName [cxt, ty, ds]
@@ -914,11 +1028,32 @@ repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs
 repProto :: Core String -> Core M.Type -> DsM (Core M.Decl)
 repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
 
-repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
-repConstr (MkC con) (MkC tys) = rep2 constrName [con,tys]
+repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt)
+repCtxt (MkC tys) = rep2 ctxtName [tys]
+
+repConstr :: Core String -> HsConDetails Name (BangType Name)
+          -> DsM (Core M.Cons)
+repConstr con (PrefixCon ps)
+    = do arg_tys  <- mapM repBangTy ps
+         arg_tys1 <- coreList strTypeTyConName arg_tys
+         rep2 constrName [unC con, unC arg_tys1]
+repConstr con (RecCon ips)
+    = do arg_vs   <- mapM lookupOcc (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 varStrTypeTyConName arg_vtys
+         rep2 recConstrName [unC con, unC arg_vtys']
+repConstr con (InfixCon st1 st2)
+    = do arg1 <- repBangTy st1
+         arg2 <- repBangTy st2
+         rep2 infixConstrName [unC arg1, unC con, unC arg2]
 
 ------------ Types -------------------
 
+repTForall :: Core [String] -> Core M.Ctxt -> Core M.Type -> DsM (Core M.Type)
+repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 tforallName [tvars, ctxt, ty]
+
 repTvar :: Core String -> DsM (Core M.Type)
 repTvar (MkC s) = rep2 tvarName [s]
 
@@ -953,16 +1088,16 @@ repLiteral lit
   = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
   where
     lit_name = case lit of
-                HsInt _    -> intLName
-                HsChar _   -> charLName
-                HsString _ -> stringLName
-                HsRat _ _  -> rationalLName
-                other      -> uh_oh
+                HsInteger _ -> integerLName
+                HsChar _    -> charLName
+                HsString _  -> stringLName
+                HsRat _ _   -> rationalLName
+                other       -> uh_oh
     uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
                    (ppr lit)
 
 repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
-repOverloadedLiteral (HsIntegral i _)   = repLiteral (HsInt i)
+repOverloadedLiteral (HsIntegral i _)   = repLiteral (HsInteger i)
 repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
                                               repLiteral (HsRat f rat_ty) }
        -- The type Rational will be in the environment, becuase 
@@ -1031,26 +1166,30 @@ templateHaskellNames :: NameSet
 -- The names that are implicitly mentioned by ``bracket''
 -- Should stay in sync with the import list of DsMeta
 templateHaskellNames
-  = mkNameSet [ intLName,charLName, stringLName, rationalLName,
+  = mkNameSet [ integerLName,charLName, stringLName, rationalLName,
                plitName, pvarName, ptupName, 
                pconName, ptildeName, paspatName, pwildName, 
                 varName, conName, litName, appName, infixEName, lamName,
                 tupName, doEName, compName, 
                 listExpName, sigExpName, condName, letEName, caseEName,
-                infixAppName, negName, sectionLName, sectionRName,
+                infixAppName, sectionLName, sectionRName,
                 guardedName, normalName, 
                bindStName, letStName, noBindStName, parStName,
                fromName, fromThenName, fromToName, fromThenToName,
                funName, valName, liftName,
                gensymName, returnQName, bindQName, sequenceQName,
-               matchName, clauseName, funName, valName, dataDName, classDName,
-               instName, protoName, tvarName, tconName, tappName, 
+               matchName, clauseName, funName, valName, tySynDName, dataDName, classDName,
+               instName, protoName, tforallName, tvarName, tconName, tappName,
                arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
-               constrName,
+               ctxtName, constrName, recConstrName, infixConstrName,
                exprTyConName, declTyConName, pattTyConName, mtchTyConName, 
                clseTyConName, stmtTyConName, consTyConName, typeTyConName,
+        strTypeTyConName, varStrTypeTyConName,
                qTyConName, expTyConName, matTyConName, clsTyConName,
-               decTyConName, typTyConName ]
+               decTyConName, typTyConName, strictTypeName, varStrictTypeName,
+        recConName, recUpdName, precName,
+        fieldName, fieldTyConName, fieldPName, fieldPTyConName,
+        strictName, nonstrictName ]
 
 
 varQual  = mk_known_key_name OccName.varName
@@ -1063,7 +1202,7 @@ thModule = mkThPkgModule mETA_META_Name
 mk_known_key_name space str uniq 
   = mkKnownKeyExternalName thModule (mkOccFS space str) uniq 
 
-intLName       = varQual FSLIT("intL")          intLIdKey
+integerLName   = varQual FSLIT("integerL")      integerLIdKey
 charLName      = varQual FSLIT("charL")         charLIdKey
 stringLName    = varQual FSLIT("stringL")       stringLIdKey
 rationalLName  = varQual FSLIT("rationalL")     rationalLIdKey
@@ -1074,6 +1213,7 @@ pconName       = varQual FSLIT("pcon")          pconIdKey
 ptildeName     = varQual FSLIT("ptilde")        ptildeIdKey
 paspatName     = varQual FSLIT("paspat")        paspatIdKey
 pwildName      = varQual FSLIT("pwild")         pwildIdKey
+precName       = varQual FSLIT("prec")          precIdKey
 varName        = varQual FSLIT("var")           varIdKey
 conName        = varQual FSLIT("con")           conIdKey
 litName        = varQual FSLIT("lit")           litIdKey
@@ -1089,9 +1229,10 @@ condName       = varQual FSLIT("cond")          condIdKey
 letEName       = varQual FSLIT("letE")          letEIdKey
 caseEName      = varQual FSLIT("caseE")         caseEIdKey
 infixAppName   = varQual FSLIT("infixApp")      infixAppIdKey
-negName        = varQual FSLIT("neg")           negIdKey
 sectionLName   = varQual FSLIT("sectionL")      sectionLIdKey
 sectionRName   = varQual FSLIT("sectionR")      sectionRIdKey
+recConName     = varQual FSLIT("recCon")        recConIdKey
+recUpdName     = varQual FSLIT("recUpd")        recUpdIdKey
 guardedName    = varQual FSLIT("guarded")       guardedIdKey
 normalName     = varQual FSLIT("normal")        normalIdKey
 bindStName     = varQual FSLIT("bindSt")        bindStIdKey
@@ -1118,23 +1259,30 @@ clauseName     = varQual FSLIT("clause")        clauseIdKey
 funName        = varQual FSLIT("fun")           funIdKey
 valName        = varQual FSLIT("val")           valIdKey
 dataDName      = varQual FSLIT("dataD")         dataDIdKey
+tySynDName     = varQual FSLIT("tySynD")        tySynDIdKey
 classDName     = varQual FSLIT("classD")        classDIdKey
 instName       = varQual FSLIT("inst")          instIdKey
 protoName      = varQual FSLIT("proto")         protoIdKey
                         
 -- data Typ = ...       
+tforallName    = varQual FSLIT("tforall")       tforallIdKey
 tvarName       = varQual FSLIT("tvar")          tvarIdKey
 tconName       = varQual FSLIT("tcon")          tconIdKey
 tappName       = varQual FSLIT("tapp")          tappIdKey
                         
 -- data Tag = ...       
-arrowTyConName = varQual FSLIT("arrowTyCon")   arrowIdKey
-tupleTyConName = varQual FSLIT("tupleTyCon")   tupleIdKey
-listTyConName  = varQual FSLIT("listTyCon")    listIdKey
-namedTyConName = varQual FSLIT("namedTyCon")   namedTyConIdKey
+arrowTyConName = varQual FSLIT("arrowTyCon")    arrowIdKey
+tupleTyConName = varQual FSLIT("tupleTyCon")    tupleIdKey
+listTyConName  = varQual FSLIT("listTyCon")     listIdKey
+namedTyConName = varQual FSLIT("namedTyCon")    namedTyConIdKey
+
+-- type Ctxt = ...
+ctxtName       = varQual FSLIT("ctxt")          ctxtIdKey
                         
 -- data Con = ...       
 constrName     = varQual FSLIT("constr")        constrIdKey
+recConstrName  = varQual FSLIT("recConstr")     recConstrIdKey
+infixConstrName = varQual FSLIT("infixConstr")  infixConstrIdKey
                         
 exprTyConName  = tcQual  FSLIT("Expr")                exprTyConKey
 declTyConName  = tcQual  FSLIT("Decl")                declTyConKey
@@ -1144,7 +1292,12 @@ clseTyConName  = tcQual  FSLIT("Clse")          clseTyConKey
 stmtTyConName  = tcQual  FSLIT("Stmt")                stmtTyConKey
 consTyConName  = tcQual  FSLIT("Cons")                consTyConKey
 typeTyConName  = tcQual  FSLIT("Type")                typeTyConKey
-                        
+strTypeTyConName  = tcQual  FSLIT("StrType")       strTypeTyConKey
+varStrTypeTyConName  = tcQual  FSLIT("VarStrType")       varStrTypeTyConKey
+
+fieldTyConName = tcQual FSLIT("FldE")              fieldTyConKey
+fieldPTyConName = tcQual FSLIT("FldP")             fieldPTyConKey
+
 qTyConName     = tcQual  FSLIT("Q")           qTyConKey
 expTyConName   = tcQual  FSLIT("Exp")                 expTyConKey
 decTyConName   = tcQual  FSLIT("Dec")                 decTyConKey
@@ -1152,6 +1305,14 @@ typTyConName   = tcQual  FSLIT("Typ")           typTyConKey
 matTyConName   = tcQual  FSLIT("Mat")                 matTyConKey
 clsTyConName   = tcQual  FSLIT("Cls")                 clsTyConKey
 
+strictTypeName = varQual  FSLIT("strictType")   strictTypeKey
+varStrictTypeName = varQual  FSLIT("varStrictType")   varStrictTypeKey
+strictName     = varQual  FSLIT("strict")       strictKey
+nonstrictName  = varQual  FSLIT("nonstrict")    nonstrictKey
+
+fieldName = varQual FSLIT("field")              fieldKey
+fieldPName = varQual FSLIT("fieldP")            fieldPKey
+
 --     TyConUniques available: 100-119
 --     Check in PrelNames if you want to change this
 
@@ -1169,6 +1330,10 @@ consTyConKey = mkPreludeTyConUnique 110
 typeTyConKey = mkPreludeTyConUnique 111
 typTyConKey  = mkPreludeTyConUnique 112
 decTyConKey  = mkPreludeTyConUnique 113
+varStrTypeTyConKey = mkPreludeTyConUnique 114
+strTypeTyConKey = mkPreludeTyConUnique 115
+fieldTyConKey = mkPreludeTyConUnique 116
+fieldPTyConKey = mkPreludeTyConUnique 117
 
 
 
@@ -1187,7 +1352,7 @@ valIdKey        = mkPreludeMiscIdUnique 209
 protoIdKey      = mkPreludeMiscIdUnique 210
 matchIdKey      = mkPreludeMiscIdUnique 211
 clauseIdKey     = mkPreludeMiscIdUnique 212
-intLIdKey       = mkPreludeMiscIdUnique 213
+integerLIdKey   = mkPreludeMiscIdUnique 213
 charLIdKey      = mkPreludeMiscIdUnique 214
 
 classDIdKey     = mkPreludeMiscIdUnique 215
@@ -1195,6 +1360,7 @@ instIdKey       = mkPreludeMiscIdUnique 216
 dataDIdKey      = mkPreludeMiscIdUnique 217
 
 sequenceQIdKey  = mkPreludeMiscIdUnique 218
+tySynDIdKey      = mkPreludeMiscIdUnique 219
 
 plitIdKey       = mkPreludeMiscIdUnique 220
 pvarIdKey       = mkPreludeMiscIdUnique 221
@@ -1217,7 +1383,7 @@ condIdKey       = mkPreludeMiscIdUnique 238
 letEIdKey       = mkPreludeMiscIdUnique 239
 caseEIdKey      = mkPreludeMiscIdUnique 240
 infixAppIdKey   = mkPreludeMiscIdUnique 241
-negIdKey       = mkPreludeMiscIdUnique 242
+-- 242 unallocated
 sectionLIdKey   = mkPreludeMiscIdUnique 243
 sectionRIdKey   = mkPreludeMiscIdUnique 244
 guardedIdKey    = mkPreludeMiscIdUnique 245
@@ -1227,22 +1393,38 @@ letStIdKey      = mkPreludeMiscIdUnique 248
 noBindStIdKey   = mkPreludeMiscIdUnique 249
 parStIdKey      = mkPreludeMiscIdUnique 250
 
-tvarIdKey      = mkPreludeMiscIdUnique 251
-tconIdKey      = mkPreludeMiscIdUnique 252
-tappIdKey      = mkPreludeMiscIdUnique 253
+tforallIdKey   = mkPreludeMiscIdUnique 251
+tvarIdKey      = mkPreludeMiscIdUnique 252
+tconIdKey      = mkPreludeMiscIdUnique 253
+tappIdKey      = mkPreludeMiscIdUnique 254
+
+arrowIdKey     = mkPreludeMiscIdUnique 255
+tupleIdKey     = mkPreludeMiscIdUnique 256
+listIdKey      = mkPreludeMiscIdUnique 257
+namedTyConIdKey        = mkPreludeMiscIdUnique 258
+
+ctxtIdKey      = mkPreludeMiscIdUnique 259
+
+constrIdKey    = mkPreludeMiscIdUnique 260
 
-arrowIdKey     = mkPreludeMiscIdUnique 254
-tupleIdKey     = mkPreludeMiscIdUnique 255
-listIdKey      = mkPreludeMiscIdUnique 256
-namedTyConIdKey        = mkPreludeMiscIdUnique 257
+stringLIdKey   = mkPreludeMiscIdUnique 261
+rationalLIdKey = mkPreludeMiscIdUnique 262
 
-constrIdKey    = mkPreludeMiscIdUnique 258
+sigExpIdKey     = mkPreludeMiscIdUnique 263
 
-stringLIdKey   = mkPreludeMiscIdUnique 259
-rationalLIdKey = mkPreludeMiscIdUnique 260
+strictTypeKey = mkPreludeMiscIdUnique 264
+strictKey = mkPreludeMiscIdUnique 265
+nonstrictKey = mkPreludeMiscIdUnique 266
+varStrictTypeKey = mkPreludeMiscIdUnique 267
 
-sigExpIdKey     = mkPreludeMiscIdUnique 261
+recConstrIdKey = mkPreludeMiscIdUnique 268
+infixConstrIdKey       = mkPreludeMiscIdUnique 269
 
+recConIdKey     = mkPreludeMiscIdUnique 270
+recUpdIdKey     = mkPreludeMiscIdUnique 271
+precIdKey       = mkPreludeMiscIdUnique 272
+fieldKey        = mkPreludeMiscIdUnique 273
+fieldPKey       = mkPreludeMiscIdUnique 274
 
 
 -- %************************************************************************
@@ -1253,4 +1435,4 @@ sigExpIdKey     = mkPreludeMiscIdUnique 261
 
 -- It is rather usatisfactory that we don't have a SrcLoc
 addDsWarn :: SDoc -> DsM ()
-addDsWarn msg = dsWarn (noSrcLoc, msg)
\ No newline at end of file
+addDsWarn msg = dsWarn (noSrcLoc, msg)