Interface file optimisation and removal of nameParent

[ghc-hetmet.git] / compiler / deSugar / DsMeta.hs

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index d85782b..6c04002 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -22,7 +22,7 @@ module DsMeta( dsBracket,
 import {-# SOURCE #-}  DsExpr ( dsExpr )
 
 import MatchLit          ( dsLit )
-import DsUtils    ( mkListExpr, mkStringExpr, mkIntExpr )
+import DsUtils    ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
 import DsMonad
 
 import qualified Language.Haskell.TH as TH
@@ -231,7 +231,7 @@ repLFunDep (L _ (xs, ys)) = do xs' <- mapM lookupBinder xs
                                ys_list <- coreList nameTyConName ys'
                                repFunDep xs_list ys_list
 
-repInstD' (L loc (InstDecl ty binds _))                -- Ignore user pragmas for now
+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 
@@ -289,12 +289,12 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:")
 -------------------------------------------------------
 
 repC :: LConDecl Name -> DsM (Core TH.ConQ)
-repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98))
+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))
+repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc))
   = do { addTyVarBinds tvs $ \bndrs -> do {
-             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98));
+             c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc));
              ctxt' <- repContext ctxt;
              bndrs' <- coreList nameTyConName bndrs;
              rep2 forallCName [unC bndrs', unC ctxt', unC c']
@@ -815,8 +815,8 @@ 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)
+         RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map hsRecFieldId pairs)
+                            ; ps <- sequence $ map repLP (map hsRecFieldArg pairs)
                             ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps
                             ; fps' <- coreList fieldPatQTyConName fps
                             ; repPrec con_str fps' }
@@ -1192,8 +1192,8 @@ repConstr con (PrefixCon 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)
+    = do arg_vs   <- mapM lookupLOcc (map hsRecFieldId ips)
+         arg_tys  <- mapM repBangTy (map hsRecFieldArg ips)
          arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
                               arg_vs arg_tys
          arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys
@@ -1306,6 +1306,9 @@ nonEmptyCoreList :: [Core a] -> Core [a]
 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) }