[project @ 2003-04-17 15:22:38 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 aa3454d..e31ed47 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 )
@@ -54,17 +54,29 @@ cvt_top d@(Fun _ _)   = Left $ ValD (cvtd d)
 cvt_top (TySyn tc tvs rhs)
   = Left $ TyClD (TySynonym (tconName tc) (cvt_tvs tvs) (cvtType rhs) loc0)
 
-cvt_top (Data tc tvs constrs derivs)
+cvt_top (Data ctxt tc tvs constrs derivs)
   = Left $ TyClD (mkTyData DataType 
-                           (noContext, tconName tc, cvt_tvs tvs)
+                           (cvt_context ctxt, tconName tc, cvt_tvs tvs)
                            (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
+                 (Hs.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,11 +180,13 @@ 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)
+cvt (Meta.RecCon c flds) = RecordCon (cName c) (map (\(x,y) -> (vName x, cvt y)) flds)
+cvt (RecUpd e flds) = RecordUpd (cvt e) (map (\(x,y) -> (vName x, cvt y)) flds)
 
 cvtdecs :: [Meta.Dec] -> HsBinds RdrName
 cvtdecs [] = EmptyBinds
@@ -253,11 +268,13 @@ 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)
 cvtp (Paspat s p) = AsPat (vName s) (cvtp p)
 cvtp Pwild        = WildPat void
+cvtp (Prec c fs)  = ConPatIn (cName c) $ Hs.RecCon (map (\(s,p) -> (vName s,cvtp p)) fs)
 
 -----------------------------------------------------------
 --     Types and type variables
@@ -270,7 +287,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 +303,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 +347,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