[project @ 2004-11-18 00:56:18 by igloo]

[ghc-hetmet.git] / ghc / compiler / hsSyn / Convert.lhs

diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 34da7bd..7343a8b 100644 (file)
--- 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