X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FConvert.lhs;h=7343a8baa49f7203a8433a00be9baac60ed85c39;hb=ff845ab59d1d465d874d3908fd0cdd61b8594da2;hp=34da7bd5f0193faf4e6cf35f8bbedf29a9a481cd;hpb=cafceec49550e38ee039fc03e3b07c64bdd00c23;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 34da7bd..7343a8b 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -14,6 +14,7 @@ import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
 
 import HsSyn as Hs
+import qualified Class (FunDep)
 import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName )
 import Module   ( ModuleName, mkModuleName )
 import RdrHsSyn	( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
@@ -42,7 +43,9 @@ import Outputable
 convertToHsDecls :: [TH.Dec] -> [Either (LHsDecl RdrName) Message]
 convertToHsDecls ds = map cvt_ltop ds
 
-mk_con con = L loc0 $ case con of
+mk_con con = L loc0 $ mk_nlcon con
+  where
+    mk_nlcon con = case con of
 	NormalC c strtys
 	 -> ConDecl (noLoc (cName c)) noExistentials noContext
 		  (PrefixCon (map mk_arg strtys))
@@ -52,7 +55,12 @@ mk_con con = L loc0 $ case con of
 	InfixC st1 c st2
 	 -> ConDecl (noLoc (cName c)) noExistentials noContext
 		  (InfixCon (mk_arg st1) (mk_arg st2))
-  where
+	ForallC tvs ctxt (ForallC tvs' ctxt' con')
+	 -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
+	ForallC tvs ctxt con' -> case mk_nlcon con' of
+				ConDecl l [] (L _ []) x ->
+				    ConDecl l (cvt_tvs tvs) (cvt_context ctxt) x
+				c -> panic "ForallC: Can't happen"
     mk_arg (IsStrict, ty)  = noLoc $ HsBangTy HsStrict (cvtType ty)
     mk_arg (NotStrict, ty) = cvtType ty
 
@@ -88,10 +96,13 @@ cvt_top (NewtypeD ctxt tc tvs constr derivs)
                            Nothing [mk_con constr]
                            (mk_derivs derivs))
 
-cvt_top (ClassD ctxt cl tvs decs)
-  = Left $ TyClD (mkClassDecl (cvt_context ctxt, noLoc (tconName cl), cvt_tvs tvs)
-                              noFunDeps sigs
-			      binds)
+cvt_top (ClassD ctxt cl tvs fds decs)
+  = Left $ TyClD $ mkClassDecl (cvt_context ctxt,
+                                noLoc (tconName cl),
+                                cvt_tvs tvs)
+                               (map (noLoc . cvt_fundep) fds)
+                               sigs
+                               binds
   where
     (binds,sigs) = cvtBindsAndSigs decs
 
@@ -126,6 +137,9 @@ cvt_top (ForeignD (ExportF callconv as nm typ))
                           CCall -> CCallConv
                           StdCall -> StdCallConv
 
+cvt_fundep :: FunDep -> Class.FunDep RdrName
+cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
+
 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 parse_ccall_impent nm s
  = case lex_ccall_impent s of
@@ -168,7 +182,6 @@ lex_ccall_impent xs = case span is_valid xs of
 
 noContext      = noLoc []
 noExistentials = []
-noFunDeps      = []
 
 -------------------------------------------------------------------
 convertToHsExpr :: TH.Exp -> LHsExpr RdrName