[project @ 2004-11-03 01:10:53 by igloo]

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

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 23117b0..71a17b3 100644 (file)
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -22,7 +22,7 @@ module DsMeta( dsBracket,
 import {-# SOURCE #-}  DsExpr ( dsExpr )
 
 import MatchLit          ( dsLit )
-import DsUtils    ( mkListExpr, mkStringLit, mkCoreTup, mkIntExpr )
+import DsUtils    ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr )
 import DsMonad
 
 import qualified Language.Haskell.TH as TH
@@ -76,7 +76,7 @@ dsBracket brack splices
     do_brack (VarBr n)  = do { MkC e1  <- lookupOcc n ; return e1 }
     do_brack (ExpBr e)  = do { MkC e1  <- repLE e     ; return e1 }
     do_brack (PatBr p)  = do { MkC p1  <- repLP p     ; return p1 }
-    do_brack (TypBr t)  = do { MkC t1  <- repLTy t     ; return t1 }
+    do_brack (TypBr t)  = do { MkC t1  <- repLTy t    ; return t1 }
     do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 }
 
 {- -------------- Examples --------------------
@@ -275,21 +275,29 @@ repC :: LConDecl Name -> DsM (Core TH.ConQ)
 repC (L loc (ConDecl con [] (L _ []) details))
   = do { con1 <- lookupLOcc con ;              -- See note [Binders and occurrences] 
         repConstr con1 details }
-
+repC (L loc (ConDecl con tvs (L cloc ctxt) details))
+  = do { addTyVarBinds tvs $ \bndrs -> do {
+             c' <- repC (L loc (ConDecl con [] (L cloc []) details));
+             ctxt' <- repContext ctxt;
+             bndrs' <- coreList nameTyConName bndrs;
+             rep2 forallCName [unC bndrs', unC ctxt', unC c']
+         }
+       }
 repC (L loc con_decl)
   = do { dsWarn (loc, hang ds_msg 4 (ppr con_decl))
        ; return (panic "DsMeta:repC") }
   where
-
+-- gaw 2004 FIX! Need a case for GadtDecl
 
 repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
-repBangTy (L _ (BangType str ty)) = do 
-  MkC s <- rep2 strName []
-  MkC t <- repLTy ty
+repBangTy ty= do 
+  MkC s <- rep2 str []
+  MkC t <- repLTy ty'
   rep2 strictTypeName [s, t]
-  where strName = case str of
-                       HsNoBang -> notStrictName
-                       other    -> isStrictName
+  where 
+    (str, ty') = case ty of
+                  L _ (HsBangTy _ ty) -> (isStrictName,  ty)
+                  other               -> (notStrictName, ty)
 
 -------------------------------------------------------
 --                     Deriving clause
@@ -462,7 +470,7 @@ repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters"
        -- HsOverlit can definitely occur
 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
-repE (HsLam m)     = repLambda m
+repE (HsLam (MatchGroup [m] _)) = repLambda m
 repE (HsApp x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
 
 repE (OpApp e1 op fix e2) =
@@ -477,9 +485,9 @@ repE (NegApp x nm)        = do
 repE (HsPar x)            = repLE x
 repE (SectionL x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b } 
 repE (SectionR x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b } 
-repE (HsCase e ms)        = do { arg <- repLE e
-                              ; ms2 <- mapM repMatchTup ms
-                              ; repCaseE arg (nonEmptyCoreList ms2) }
+repE (HsCase e (MatchGroup ms _)) = do { arg <- repLE e
+                                      ; ms2 <- mapM repMatchTup ms
+                                      ; repCaseE arg (nonEmptyCoreList ms2) }
 repE (HsIf x y z)         = do
                              a <- repLE x
                              b <- repLE y
@@ -548,7 +556,7 @@ repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e)
 -- Building representations of auxillary structures like Match, Clause, Stmt, 
 
 repMatchTup ::  LMatch Name -> DsM (Core TH.MatchQ) 
-repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) =
+repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) =
   do { ss1 <- mkGenSyms (collectPatBinders p) 
      ; addBinds ss1 $ do {
      ; p1 <- repLP p
@@ -559,7 +567,7 @@ repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) =
      ; wrapGenSyns (ss1++ss2) match }}}
 
 repClauseTup ::  LMatch Name -> DsM (Core TH.ClauseQ)
-repClauseTup (L _ (Match ps ty (GRHSs guards wheres ty2))) =
+repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) =
   do { ss1 <- mkGenSyms (collectPatsBinders ps) 
      ; addBinds ss1 $ do {
        ps1 <- repLPs ps
@@ -695,7 +703,7 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
 -- Note GHC treats declarations of a variable (not a pattern) 
 -- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match 
 -- with an empty list of patterns
-rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))]))
+rep_bind (L loc (FunBind fn infx (MatchGroup [L _ (Match [] ty (GRHSs guards wheres))] _)))
  = do { (ss,wherecore) <- repBinds wheres
        ; guardcore <- addBinds ss (repGuards guards)
        ; fn'  <- lookupLBinder fn
@@ -704,13 +712,13 @@ rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))]))
        ; ans' <- wrapGenSyns ss ans
        ; return (loc, ans') }
 
-rep_bind (L loc (FunBind fn infx ms))
+rep_bind (L loc (FunBind fn infx (MatchGroup ms _)))
  =   do { ms1 <- mapM repClauseTup ms
        ; fn' <- lookupLBinder fn
         ; ans <- repFun fn' (nonEmptyCoreList ms1)
         ; return (loc, ans) }
 
-rep_bind (L loc (PatBind pat (GRHSs guards wheres ty2)))
+rep_bind (L loc (PatBind pat (GRHSs guards wheres) ty2))
  =   do { patcore <- repLP pat 
         ; (ss,wherecore) <- repBinds wheres
        ; guardcore <- addBinds ss (repGuards guards)
@@ -752,7 +760,7 @@ rep_bind (L loc (VarBind v e))
 -- (\ p1 .. pn -> exp) by causing an error.  
 
 repLambda :: LMatch Name -> DsM (Core TH.ExpQ)
-repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [] _)))
+repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [])))
  = do { let bndrs = collectPatsBinders ps ;
       ; ss  <- mkGenSyms bndrs
       ; lam <- addBinds ss (
@@ -1273,7 +1281,7 @@ corePair :: (Core a, Core b) -> Core (a,b)
 corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y])
 
 coreStringLit :: String -> DsM (Core String)
-coreStringLit s = do { z <- mkStringLit s; return(MkC z) }
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
 
 coreIntLit :: Int -> DsM (Core Int)
 coreIntLit i = return (MkC (mkIntExpr (fromIntegral i)))
@@ -1337,7 +1345,7 @@ templateHaskellNames = [
     -- Strict
     isStrictName, notStrictName,
     -- Con
-    normalCName, recCName, infixCName,
+    normalCName, recCName, infixCName, forallCName,
     -- StrictType
     strictTypeName,
     -- VarStrictType
@@ -1499,6 +1507,7 @@ notStrictName     = libFun  FSLIT("notStrict")     notStrictKey
 normalCName = libFun FSLIT("normalC") normalCIdKey
 recCName    = libFun FSLIT("recC")    recCIdKey
 infixCName  = libFun FSLIT("infixC")  infixCIdKey
+forallCName  = libFun FSLIT("forallC")  forallCIdKey
                         
 -- type StrictType = ...
 strictTypeName    = libFun  FSLIT("strictType")    strictTKey
@@ -1673,6 +1682,7 @@ notStrictKey        = mkPreludeMiscIdUnique 282
 normalCIdKey      = mkPreludeMiscIdUnique 283
 recCIdKey         = mkPreludeMiscIdUnique 284
 infixCIdKey       = mkPreludeMiscIdUnique 285
+forallCIdKey      = mkPreludeMiscIdUnique 288
 
 -- type StrictType = ...
 strictTKey        = mkPreludeMiscIdUnique 286