[project @ 2000-10-30 09:52:14 by simonpj]

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

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index c21a2d3..c2bd453 100644 (file)
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -14,12 +14,11 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
 module HsCore (
        UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
        UfBinding(..), UfConAlt(..),
-       HsIdInfo(..), 
-       IfaceSig(..),
+       HsIdInfo(..), pprHsIdInfo, 
 
        eq_ufExpr, eq_ufBinders, pprUfExpr,
 
-       toUfExpr, toUfBndr
+       toUfExpr, toUfBndr, ufBinderName
     ) where
 
 #include "HsVersions.h"
@@ -34,11 +33,10 @@ import HsTypes              ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType,
 -- others:
 import Id              ( idArity, idType, isDataConId_maybe, isPrimOpId_maybe )
 import Var             ( varType, isId )
-import IdInfo          ( ArityInfo, UpdateInfo, InlinePragInfo, 
+import IdInfo          ( ArityInfo, InlinePragInfo, 
                          pprInlinePragInfo, ppArityInfo, ppStrictnessInfo
                        )
-import RdrName         ( RdrName )
-import Name            ( toRdrName )
+import Name            ( Name, getName )
 import CoreSyn
 import CostCentre      ( pprCostCentreCore )
 import PrimOp          ( PrimOp(CCallOp) )
@@ -49,7 +47,6 @@ import DataCon                ( dataConTyCon )
 import TyCon           ( isTupleTyCon, tupleTyConBoxity )
 import Type            ( Kind )
 import CostCentre
-import SrcLoc          ( SrcLoc )
 import Outputable
 \end{code}
 
@@ -94,6 +91,10 @@ data UfBinding name
 data UfBinder name
   = UfValBinder        name (HsType name)
   | UfTyBinder name Kind
+
+ufBinderName :: UfBinder name -> name
+ufBinderName (UfValBinder n _) = n
+ufBinderName (UfTyBinder  n _) = n
 \end{code}
 
 
@@ -104,7 +105,7 @@ data UfBinder name
 %************************************************************************
 
 \begin{code}
-toUfExpr :: CoreExpr -> UfExpr RdrName
+toUfExpr :: CoreExpr -> UfExpr Name
 toUfExpr (Var v) = toUfVar v
 toUfExpr (Lit l) = case maybeLitLit l of
                        Just (s,ty) -> UfLitLit s (toHsType ty)
@@ -112,7 +113,7 @@ toUfExpr (Lit l) = case maybeLitLit l of
 toUfExpr (Type ty) = UfType (toHsType ty)
 toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
 toUfExpr (App f a) = toUfApp f [a]
-toUfExpr (Case s x as) = UfCase (toUfExpr s) (toRdrName x) (map toUfAlt as)
+toUfExpr (Case s x as) = UfCase (toUfExpr s) (getName x) (map toUfAlt as)
 toUfExpr (Let b e)     = UfLet (toUfBind b) (toUfExpr e)
 toUfExpr (Note n e)    = UfNote (toUfNote n) (toUfExpr e)
 
@@ -127,11 +128,11 @@ toUfBind (NonRec b r) = UfNonRec (toUfBndr b) (toUfExpr r)
 toUfBind (Rec prs)    = UfRec [(toUfBndr b, toUfExpr r) | (b,r) <- prs]
 
 ---------------------
-toUfAlt (c,bs,r) = (toUfCon c, map toRdrName bs, toUfExpr r)
+toUfAlt (c,bs,r) = (toUfCon c, map getName bs, toUfExpr r)
 
 ---------------------
-toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (toRdrName dc) (tupleTyConBoxity tc))
-                    | otherwise       = UfDataAlt (toRdrName dc)
+toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (HsTupCon (getName dc) (tupleTyConBoxity tc))
+                    | otherwise       = UfDataAlt (getName dc)
                     where
                       tc = dataConTyCon dc
 
@@ -141,15 +142,15 @@ toUfCon (LitAlt l)   = case maybeLitLit l of
 toUfCon DEFAULT             = UfDefault
 
 ---------------------
-toUfBndr x | isId x    = UfValBinder (toRdrName x) (toHsType (varType x))
-          | otherwise = UfTyBinder  (toRdrName x) (varType x)
+toUfBndr x | isId x    = UfValBinder (getName x) (toHsType (varType x))
+          | otherwise = UfTyBinder  (getName x) (varType x)
 
 ---------------------
 toUfApp (App f a) as = toUfApp f (a:as)
 toUfApp (Var v) as
   = case isDataConId_maybe v of
        -- We convert the *worker* for tuples into UfTuples
-       Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (toRdrName dc) (tupleTyConBoxity tc)) tup_args
+       Just dc | isTupleTyCon tc && saturated -> UfTuple (HsTupCon (getName dc) (tupleTyConBoxity tc)) tup_args
          where
            val_args  = dropWhile isTypeArg as
            saturated = length val_args == idArity v
@@ -167,7 +168,7 @@ mkUfApps = foldl (\f a -> UfApp f (toUfExpr a))
 toUfVar v = case isPrimOpId_maybe v of
                -- Ccalls has special syntax
                Just (CCallOp cc) -> UfCCall cc (toHsType (idType v))
-               other             -> UfVar (toRdrName v)
+               other             -> UfVar (getName v)
 \end{code}
 
 
@@ -190,7 +191,7 @@ pprUfExpr :: Outputable name => (SDoc -> SDoc) -> UfExpr name -> SDoc
 
 pprUfExpr add_par (UfVar v)       = ppr v
 pprUfExpr add_par (UfLit l)       = ppr l
-pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprFSAsString l, pprParendHsType ty])
+pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
 pprUfExpr add_par (UfCCall cc ty) = braces (pprCCallOp cc <+> ppr ty)
 pprUfExpr add_par (UfType ty)     = char '@' <+> pprParendHsType ty
 
@@ -238,7 +239,7 @@ instance Outputable name => Outputable (UfNote name) where
 instance Outputable name => Outputable (UfConAlt name) where
     ppr UfDefault         = text "__DEFAULT"
     ppr (UfLitAlt l)       = ppr l
-    ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprFSAsString l, pprParendHsType ty])
+    ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
     ppr (UfDataAlt d)     = ppr d
 
 instance Outputable name => Outputable (UfBinder name) where
@@ -318,23 +319,6 @@ eq_ufConAlt env _ _ = False
 
 %************************************************************************
 %*                                                                     *
-\subsection{Signatures in interface files}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-data IfaceSig name = IfaceSig name (HsType name) [HsIdInfo name] SrcLoc
-
-instance Ord name => Eq (IfaceSig name) where
-  (==) (IfaceSig n1 t1 i1 _) (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2
-
-instance (Outputable name) => Outputable (IfaceSig name) where
-    ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
 \subsection{Rules in interface files}
 %*                                                                     *
 %************************************************************************
@@ -347,7 +331,6 @@ data HsIdInfo name
   = HsArity            ArityInfo
   | HsStrictness       StrictnessInfo
   | HsUnfold           InlinePragInfo (UfExpr name)
-  | HsUpdate           UpdateInfo
   | HsNoCafRefs
   | HsCprInfo
   | HsWorker           name            -- Worker, if any