[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 9c31331..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,14 +162,15 @@ 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)
 
 cvt (App x y)     = HsApp (cvt x) (cvt y)
 cvt (Lam ps e)    = HsLam (mkSimpleMatch (map cvtp ps) (cvt e) void loc0)
+cvt (Tup [e])    = cvt e
 cvt (Tup es)     = ExplicitTuple(map cvt es) Boxed
 cvt (Cond x y z)  = HsIf (cvt x) (cvt y) (cvt z) loc0
 cvt (Let ds e)   = HsLet (cvtdecs ds) (cvt e)
@@ -167,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
@@ -194,7 +207,7 @@ cvtd :: Meta.Dec -> MonoBinds RdrName
 -- Used only for declarations in a 'let/where' clause,
 -- not for top level decls
 cvtd (Val (Pvar s) body ds) = FunMonoBind (vName s) False 
-                                         (panic "what now?") loc0
+                                         [cvtclause (Clause [] body ds)] loc0
 cvtd (Fun nm cls)          = FunMonoBind (vName nm) False (map cvtclause cls) loc0
 cvtd (Val p body ds)       = PatMonoBind (cvtp p) (GRHSs (cvtguard body) 
                                                          (cvtdecs ds) 
@@ -253,6 +266,7 @@ cvtp (Plit l)
                                                        -- about that!
   | otherwise      = LitPat (cvtLit l)
 cvtp (Pvar s)     = VarPat(vName s)
+cvtp (Ptup [p])   = cvtp p
 cvtp (Ptup ps)    = TuplePat (map cvtp ps) Boxed
 cvtp (Pcon s ps)  = ConPatIn (cName s) (PrefixCon (map cvtp ps))
 cvtp (Ptilde p)   = LazyPat (cvtp p)
@@ -270,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
@@ -286,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 "[]"
@@ -326,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