[project @ 2002-11-09 09:58:56 by chak]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsMeta.hs

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 3414ab7..3f00e7f 100644 (file)
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -42,7 +42,7 @@ import HsSyn            ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..),
                    toHsType
                  )
 
-import PrelNames  ( mETA_META_Name, rationalTyConName )
+import PrelNames  ( mETA_META_Name, rationalTyConName, negateName )
 import MkIface   ( ifaceTyThing )
 import Name       ( Name, nameOccName, nameModule )
 import OccName   ( isDataOcc, isTvOcc, occNameUserString )
@@ -370,7 +370,10 @@ repE (OpApp e1 op fix e2) =
                     the_op <- lookupOcc op ;
                     repInfixApp arg1 the_op arg2 } 
     _        -> panic "DsMeta.repE: Operator is not a variable"
-repE (NegApp x nm)        = repE x >>= repNeg
+repE (NegApp x nm)        = do
+                             a         <- repE x
+                             negateVar <- lookupOcc negateName >>= repVar
+                             negateVar `repApp` a
 repE (HsPar x)            = repE x
 repE (SectionL x y)       = do { a <- repE x; b <- repE y; repSectionL a b } 
 repE (SectionR x y)       = do { a <- repE x; b <- repE y; repSectionR a b } 
@@ -387,16 +390,15 @@ repE (HsLet bs e)         = do { (ss,ds) <- repBinds bs
                               ; z <- repLetE ds e2
                               ; wrapGenSyns expTyConName ss z }
 -- FIXME: I haven't got the types here right yet
-repE (HsDo ctxt sts _ ty loc) 
-  | isComprCtxt ctxt      = do { (ss,zs) <- repSts sts; 
-                                e       <- repDoE (nonEmptyCoreList zs);
-                                wrapGenSyns expTyConName ss e }
-  | otherwise             = 
-    panic "DsMeta.repE: Can't represent mdo and [: :] yet"
-  where
-    isComprCtxt ListComp = True
-    isComprCtxt DoExpr  = True
-    isComprCtxt _       = False
+repE (HsDo DoExpr sts _ ty loc) 
+ = do { (ss,zs) <- repSts sts; 
+        e       <- repDoE (nonEmptyCoreList zs);
+        wrapGenSyns expTyConName ss e }
+repE (HsDo ListComp sts _ ty loc) 
+ = do { (ss,zs) <- repSts sts; 
+        e       <- repComp (nonEmptyCoreList zs);
+        wrapGenSyns expTyConName ss e }
+repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet"
 repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } 
 repE (ExplicitPArr ty es) = 
   panic "DsMeta.repE: No explicit parallel arrays yet"
@@ -849,9 +851,6 @@ repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
 repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
 
-repNeg :: Core M.Expr -> DsM (Core M.Expr)
-repNeg (MkC x) = rep2 negName [x]
-
 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
 
@@ -953,16 +952,16 @@ repLiteral lit
   = do { lit_expr <- dsLit lit; rep2 lit_name [lit_expr] }
   where
     lit_name = case lit of
-                HsInt _    -> intLName
-                HsChar _   -> charLName
-                HsString _ -> stringLName
-                HsRat _ _  -> rationalLName
-                other      -> uh_oh
+                HsInteger _ -> integerLName
+                HsChar _    -> charLName
+                HsString _  -> stringLName
+                HsRat _ _   -> rationalLName
+                other       -> uh_oh
     uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal"
                    (ppr lit)
 
 repOverloadedLiteral :: HsOverLit -> DsM (Core M.Lit)
-repOverloadedLiteral (HsIntegral i _)   = repLiteral (HsInt i)
+repOverloadedLiteral (HsIntegral i _)   = repLiteral (HsInteger i)
 repOverloadedLiteral (HsFractional f _) = do { rat_ty <- lookupType rationalTyConName ;
                                               repLiteral (HsRat f rat_ty) }
        -- The type Rational will be in the environment, becuase 
@@ -1031,13 +1030,13 @@ templateHaskellNames :: NameSet
 -- The names that are implicitly mentioned by ``bracket''
 -- Should stay in sync with the import list of DsMeta
 templateHaskellNames
-  = mkNameSet [ intLName,charLName, stringLName, rationalLName,
+  = mkNameSet [ integerLName,charLName, stringLName, rationalLName,
                plitName, pvarName, ptupName, 
                pconName, ptildeName, paspatName, pwildName, 
                 varName, conName, litName, appName, infixEName, lamName,
                 tupName, doEName, compName, 
                 listExpName, sigExpName, condName, letEName, caseEName,
-                infixAppName, negName, sectionLName, sectionRName,
+                infixAppName, sectionLName, sectionRName,
                 guardedName, normalName, 
                bindStName, letStName, noBindStName, parStName,
                fromName, fromThenName, fromToName, fromThenToName,
@@ -1063,7 +1062,7 @@ thModule = mkThPkgModule mETA_META_Name
 mk_known_key_name space str uniq 
   = mkKnownKeyExternalName thModule (mkOccFS space str) uniq 
 
-intLName       = varQual FSLIT("intL")          intLIdKey
+integerLName   = varQual FSLIT("integerL")      integerLIdKey
 charLName      = varQual FSLIT("charL")         charLIdKey
 stringLName    = varQual FSLIT("stringL")       stringLIdKey
 rationalLName  = varQual FSLIT("rationalL")     rationalLIdKey
@@ -1089,7 +1088,6 @@ condName       = varQual FSLIT("cond")          condIdKey
 letEName       = varQual FSLIT("letE")          letEIdKey
 caseEName      = varQual FSLIT("caseE")         caseEIdKey
 infixAppName   = varQual FSLIT("infixApp")      infixAppIdKey
-negName        = varQual FSLIT("neg")           negIdKey
 sectionLName   = varQual FSLIT("sectionL")      sectionLIdKey
 sectionRName   = varQual FSLIT("sectionR")      sectionRIdKey
 guardedName    = varQual FSLIT("guarded")       guardedIdKey
@@ -1187,7 +1185,7 @@ valIdKey        = mkPreludeMiscIdUnique 209
 protoIdKey      = mkPreludeMiscIdUnique 210
 matchIdKey      = mkPreludeMiscIdUnique 211
 clauseIdKey     = mkPreludeMiscIdUnique 212
-intLIdKey       = mkPreludeMiscIdUnique 213
+integerLIdKey   = mkPreludeMiscIdUnique 213
 charLIdKey      = mkPreludeMiscIdUnique 214
 
 classDIdKey     = mkPreludeMiscIdUnique 215
@@ -1217,7 +1215,7 @@ condIdKey       = mkPreludeMiscIdUnique 238
 letEIdKey       = mkPreludeMiscIdUnique 239
 caseEIdKey      = mkPreludeMiscIdUnique 240
 infixAppIdKey   = mkPreludeMiscIdUnique 241
-negIdKey       = mkPreludeMiscIdUnique 242
+-- 242 unallocated
 sectionLIdKey   = mkPreludeMiscIdUnique 243
 sectionRIdKey   = mkPreludeMiscIdUnique 244
 guardedIdKey    = mkPreludeMiscIdUnique 245