[project @ 2003-02-19 13:05:45 by simonpj]

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

diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 033f255..e6e3a2a 100644 (file)
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -21,7 +21,7 @@ import HsSyn as Hs
                Pat(..), HsConDetails(..), HsOverLit, BangType(..),
                placeHolderType, HsType(..), HsTupCon(..),
                HsTyVarBndr(..), HsContext,
-               mkSimpleMatch
+               mkSimpleMatch, mkHsForAllTy
        ) 
 
 import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig )
@@ -60,11 +60,23 @@ cvt_top (Data tc tvs constrs derivs)
                            (DataCons (map mk_con constrs))
                            (mk_derivs derivs) loc0)
   where
-    mk_con (Constr c tys)
+    mk_con (Constr c strtys)
        = ConDecl (cName c) noExistentials noContext
-                   (PrefixCon (map mk_arg tys)) loc0
+                 (PrefixCon (map mk_arg strtys)) loc0
+    mk_con (RecConstr c varstrtys)
+       = ConDecl (cName c) noExistentials noContext
+                 (RecCon (map mk_id_arg varstrtys)) loc0
+    mk_con (InfixConstr st1 c st2)
+       = ConDecl (cName c) noExistentials noContext
+                 (InfixCon (mk_arg st1) (mk_arg st2)) loc0
 
-    mk_arg ty = BangType NotMarkedStrict (cvtType ty)
+    mk_arg (Strict, ty) = BangType MarkedUserStrict (cvtType ty)
+    mk_arg (NonStrict, ty) = BangType NotMarkedStrict (cvtType ty)
+
+    mk_id_arg (i, Strict, ty)
+        = (vName i, BangType MarkedUserStrict (cvtType ty))
+    mk_id_arg (i, NonStrict, ty)
+        = (vName i, BangType NotMarkedStrict (cvtType ty))
 
     mk_derivs [] = Nothing
     mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs]
@@ -150,8 +162,8 @@ noFunDeps      = []
 convertToHsExpr :: Meta.Exp -> HsExpr RdrName
 convertToHsExpr = cvt
 
-cvt (Var s)      = HsVar(vName s)
-cvt (Con s)      = HsVar(cName s)
+cvt (Var s)      = HsVar (vName s)
+cvt (Con s)      = HsVar (cName s)
 cvt (Lit l) 
   | overloadedLit l = HsOverLit (cvtOverLit l)
   | otherwise      = HsLit (cvtLit l)
@@ -168,10 +180,10 @@ cvt (Comp ss)     = HsDo ListComp (cvtstmts ss) [] void loc0
 cvt (ArithSeq dd) = ArithSeqIn (cvtdd dd)
 cvt (ListExp xs)  = ExplicitList void (map cvt xs)
 cvt (Infix (Just x) s (Just y))
-    = HsPar (OpApp (cvt x) (HsVar(vName s)) undefined (cvt y))
-cvt (Infix Nothing  s (Just y)) = SectionR (HsVar(vName s)) (cvt y)
-cvt (Infix (Just x) s Nothing ) = SectionL (cvt x) (HsVar(vName s))
-cvt (Infix Nothing  s Nothing ) = HsVar(vName s) -- Can I indicate this is an infix thing?
+    = HsPar (OpApp (cvt x) (cvt s) undefined (cvt y))
+cvt (Infix Nothing  s (Just y)) = SectionR (cvt s) (cvt y)
+cvt (Infix (Just x) s Nothing ) = SectionL (cvt x) (cvt s)
+cvt (Infix Nothing  s Nothing ) = cvt s        -- Can I indicate this is an infix thing?
 cvt (SigExp e t)               = ExprWithTySig (cvt e) (cvtType t)
 
 cvtdecs :: [Meta.Dec] -> HsBinds RdrName
@@ -272,7 +284,7 @@ cvt_context tys = map cvt_pred tys
 
 cvt_pred :: Typ -> HsPred RdrName
 cvt_pred ty = case split_ty_app ty of
-               (Tvar tc, tys) -> HsClassP (tconName tc) (map cvtType tys)
+               (Tcon (TconName tc), tys) -> HsClassP (tconName tc) (map cvtType tys)
                other -> panic "Malformed predicate"
 
 cvtType :: Meta.Typ -> HsType RdrName
@@ -288,6 +300,10 @@ cvtType ty = trans (root ty [])
        trans (Tvar nm, args)       = foldl HsAppTy (HsTyVar (tName nm)) args
         trans (Tcon tc, args)       = foldl HsAppTy (HsTyVar (tc_name tc)) args
 
+       trans (TForall tvs cxt ty, []) = mkHsForAllTy (Just (cvt_tvs tvs))
+                                                     (cvt_context cxt)
+                                                     (cvtType ty)
+
        tc_name (TconName nm) = tconName nm
        tc_name Arrow         = tconName "->"
        tc_name List          = tconName "[]"
@@ -328,9 +344,9 @@ loc0 = generatedSrcLoc
 vName :: String -> RdrName
 vName = mkName varName
 
--- Constructor function names
+-- Constructor function names; this is Haskell source, hence srcDataName
 cName :: String -> RdrName
-cName = mkName dataName
+cName = mkName srcDataName
 
 -- Type variable names
 tName :: String -> RdrName