X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=3f7f4d02f864ad8d1e22b809f98c3b4b41796ac6;hb=f69bf6be6101d6b5d7952c384dd5eeb1917b4cdb;hp=7718e4f9dbc4517abce4f6b63094f63ae1f95e2a;hpb=6f8ff0bbad3b9fa389c960ad1b5a267a1ae502f1;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7718e4f..3f7f4d0 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -106,7 +106,7 @@ repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
 
 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 repTopDs group
- = do { let { bndrs = map unLoc (groupBinders group) } ;
+ = do { let { bndrs = groupBinders group } ;
 	ss <- mkGenSyms bndrs ;
 
 	-- Bind all the names mainly to avoid repeated use of explicit strings.
@@ -135,13 +135,13 @@ repTopDs group
 	-- Do *not* gensym top-level binders
       }
 
-groupBinders :: HsGroup Name -> [Located Name]
+groupBinders :: HsGroup Name -> [Name]
 groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
                         hs_instds = inst_decls, hs_fords = foreign_decls })
 -- Collect the binders of a Group
   = collectHsValBinders val_decls ++
-    [n | d <- tycl_decls ++ assoc_tycl_decls, n <- tyClDeclNames (unLoc d)] ++
-    [n | L _ (ForeignImport n _ _) <- foreign_decls]
+    [n | d <- tycl_decls ++ assoc_tycl_decls, L _ n <- tyClDeclNames (unLoc d)] ++
+    [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
   where
     assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
 
@@ -317,7 +317,7 @@ repInstD' (L loc (InstDecl ty binds _ ats))	-- Ignore user pragmas for now
                 -- appear in the resulting data structure
 		do { cxt1 <- repContext cxt
 		   ; inst_ty1 <- repPredTy (HsClassP cls tys)
-		   ; ss <- mkGenSyms (collectHsBindBinders binds)
+		   ; ss <- mkGenSyms (collectHsBindsBinders binds)
 		   ; binds1 <- addBinds ss (rep_binds binds)
                    ; ats1   <- repLAssocFamInst ats
 		   ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
@@ -536,9 +536,10 @@ lookupTyVarBinds tvs m =
 --
 repTyVarBndrWithKind :: LHsTyVarBndr Name 
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
-repTyVarBndrWithKind (L _ (UserTyVar _))      = repPlainTV
-repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) = 
-  \nm -> repKind ki >>= repKindedTV nm
+repTyVarBndrWithKind (L _ (UserTyVar {})) nm
+  = repPlainTV nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
+  = repKind ki >>= repKindedTV nm
 
 -- represent a type context
 --
@@ -632,9 +633,9 @@ repTy (HsKindSig t k)       = do
                                 t1 <- repLTy t
                                 k1 <- repKind k
                                 repTSig t1 k1
-repTy (HsSpliceTy splice)   = repSplice splice
-repTy ty@(HsNumTy _)        = notHandled "Number types (for generics)" (ppr ty)
-repTy ty		    = notHandled "Exotic form of type" (ppr ty)
+repTy (HsSpliceTy splice _ _) = repSplice splice
+repTy ty@(HsNumTy _)          = notHandled "Number types (for generics)" (ppr ty)
+repTy ty		      = notHandled "Exotic form of type" (ppr ty)
 
 -- represent a kind
 --
@@ -643,7 +644,7 @@ repKind ki
   = do { let (kis, ki') = splitKindFunTys ki
        ; kis_rep <- mapM repKind kis
        ; ki'_rep <- repNonArrowKind ki'
-       ; foldlM repArrowK ki'_rep kis_rep
+       ; foldrM repArrowK ki'_rep kis_rep
        }
   where
     repNonArrowKind k | isLiftedTypeKind k = repStarK
@@ -899,7 +900,7 @@ repBinds EmptyLocalBinds
 repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)
 
 repBinds (HsValBinds decs)
- = do	{ let { bndrs = map unLoc (collectHsValBinders decs) }
+ = do	{ let { bndrs = 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