[project @ 2003-03-16 14:15:21 by igloo]
[ghc-hetmet.git] / ghc / compiler / deSugar / DsMeta.hs
index f74202e..4c0d351 100644 (file)
@@ -59,13 +59,14 @@ import Name   ( mkKnownKeyExternalName )
 import OccName   ( mkOccFS )
 import NameEnv
 import NameSet
-import Type       ( Type, TyThing(..), mkGenTyConApp )
-import TcType    ( tcTyConAppArgs )
+import Type       ( Type, mkGenTyConApp )
+import TcType    ( TyThing(..), tcTyConAppArgs )
 import TyCon     ( DataConDetails(..) )
 import TysWiredIn ( stringTy )
 import CoreSyn
 import CoreUtils  ( exprType )
 import SrcLoc    ( noSrcLoc )
+import Maybes    ( orElse )
 import Maybe     ( catMaybes, fromMaybe )
 import Panic     ( panic )
 import Unique    ( mkPreludeTyConUnique, mkPreludeMiscIdUnique )
@@ -73,6 +74,8 @@ import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed )
 
 import Outputable
 import FastString      ( mkFastString )
+
+import Monad ( zipWithM )
  
 -----------------------------------------------------------------------------
 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
@@ -143,7 +146,7 @@ repTopDs group
        --      do { t :: String <- genSym "T" ;
        --           return (Data t [] ...more t's... }
        -- The other important reason is that the output must mention
-       -- only "T", not "Foo.T" where Foo is the current module
+       -- only "T", not "Foo:T" where Foo is the current module
 
        
        decls <- addBinds ss (do {
@@ -155,7 +158,9 @@ repTopDs group
 
        decl_ty <- lookupType declTyConName ;
        let { core_list = coreList' decl_ty decls } ;
-       q_decs  <- repSequenceQ decl_ty core_list ;
+
+       dec_ty <- lookupType decTyConName ;
+       q_decs  <- repSequenceQ dec_ty core_list ;
 
        wrapNongenSyms ss q_decs
        -- Do *not* gensym top-level binders
@@ -195,15 +200,16 @@ in repTyClD and repC.
 
 repTyClD :: TyClDecl Name -> DsM (Maybe (Core M.Decl))
 
-repTyClD (TyData { tcdND = DataType, tcdCtxt = [], 
+repTyClD (TyData { tcdND = DataType, tcdCtxt = cxt, 
                   tcdName = tc, tcdTyVars = tvs, 
                   tcdCons = DataCons cons, tcdDerivs = mb_derivs }) 
  = do { tc1 <- lookupOcc tc ;          -- See note [Binders and occurrences] 
         dec <- addTyVarBinds tvs $ \bndrs -> do {
-              cons1   <- mapM repC cons ;
+              cxt1   <- repContext cxt ;
+               cons1   <- mapM repC cons ;
               cons2   <- coreList consTyConName cons1 ;
               derivs1 <- repDerivs mb_derivs ;
-              repData tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
+              repData cxt1 tc1 (coreList' stringTy bndrs) cons2 derivs1 } ;
         return $ Just dec }
 
 repTyClD (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty })
@@ -214,17 +220,22 @@ repTyClD (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty })
        return (Just dec) }
 
 repTyClD (ClassDecl { tcdCtxt = cxt, tcdName = cls, 
-                     tcdTyVars = tvs, tcdFDs = [], 
-                     tcdSigs = sigs, tcdMeths = Just binds }) =
-  do 
-    cls1 <- lookupOcc cls              -- See note [Binders and occurrences] 
-    dec  <- addTyVarBinds tvs $ \bndrs -> do
-             cxt1   <- repContext cxt
-             sigs1  <- rep_sigs sigs
-             binds1 <- rep_monobind binds
-             decls1 <- coreList declTyConName (sigs1 ++ binds1)
-             repClass cxt1 cls1 (coreList' stringTy bndrs) decls1
-    return $ Just dec
+                     tcdTyVars = tvs, 
+                     tcdFDs = [],      -- We don't understand functional dependencies
+                     tcdSigs = sigs, tcdMeths = mb_meth_binds })
+ = do { cls1 <- lookupOcc cls ;                -- See note [Binders and occurrences] 
+       dec  <- addTyVarBinds tvs $ \bndrs -> do {
+                 cxt1   <- repContext cxt ;
+                 sigs1  <- rep_sigs sigs ;
+                 binds1 <- rep_monobind meth_binds ;
+                 decls1 <- coreList declTyConName (sigs1 ++ binds1) ;
+                 repClass cxt1 cls1 (coreList' stringTy bndrs) decls1 } ;
+       return $ Just dec }
+ where
+       -- If the user quotes a class decl, it'll have default-method 
+       -- bindings; but if we (reifyDecl C) where C is a class, we
+       -- won't be given the default methods (a definite infelicity).
+   meth_binds = mb_meth_binds `orElse` EmptyMonoBinds
 
 -- Un-handled cases
 repTyClD d = do { addDsWarn (hang msg 4 (ppr d)) ;
@@ -251,15 +262,15 @@ repInstD (InstDecl ty binds _ _ loc)
 repC :: ConDecl Name -> DsM (Core M.Cons)
 repC (ConDecl con [] [] details loc)
   = do { con1     <- lookupOcc con ;           -- See note [Binders and occurrences] 
-        arg_tys  <- mapM (repBangTy con) (hsConArgs details) ;
-        arg_tys1 <- coreList typeTyConName arg_tys ;
-        repConstr con1 arg_tys1 }
+        repConstr con1 details }
 
-repBangTy con (BangType NotMarkedStrict ty) = repTy ty
-repBangTy con bty = do { addDsWarn msg ; repTy (getBangType bty) }
-   where
-     msg = ptext SLIT("Ignoring stricness on argument of constructor")
-                <+> quotes (ppr con)
+repBangTy :: BangType Name -> DsM (Core (M.Q (M.Strictness, M.Typ)))
+repBangTy (BangType str ty) = do MkC s <- rep2 strName []
+                                 MkC t <- repTy ty
+                                 rep2 strictTypeName [s, t]
+    where strName = case str of
+                        NotMarkedStrict -> nonstrictName
+                        _ -> strictName
 
 -------------------------------------------------------
 --                     Deriving clause
@@ -293,7 +304,7 @@ rep_sig (ClassOpSig nm _ ty _) = rep_proto nm ty
 rep_sig (Sig nm ty _)         = rep_proto nm ty
 rep_sig other                 = return []
 
-rep_proto nm ty = do { nm1 <- lookupBinder nm ; 
+rep_proto nm ty = do { nm1 <- lookupOcc nm ; 
                       ty1 <- repTy ty ; 
                       sig <- repProto nm1 ty1 ;
                       return [sig] }
@@ -303,16 +314,9 @@ rep_proto nm ty = do { nm1 <- lookupBinder nm ;
 --                     Types
 -------------------------------------------------------
 
--- represent a list of type variables in a usage position that does not need
--- gensym'ing
---
-repTvs :: [HsTyVarBndr Name] -> DsM (Core [String])
-repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ;
-                 return (coreList' stringTy tvs1) } 
-
 -- gensym a list of type variables and enter them into the meta environment;
 -- the computations passed as the second argument is executed in that extended
--- meta environment and gets the *original* names as an argument
+-- meta environment and gets the *new* names on Core-level as an argument
 --
 addTyVarBinds :: [HsTyVarBndr Name]             -- the binders to be added
              -> ([Core String] -> DsM (Core (M.Q a))) -- action in the ext env
@@ -427,12 +431,10 @@ repE (HsLam m)     = repLambda m
 repE (HsApp x y)   = do {a <- repE x; b <- repE y; repApp a b}
 
 repE (OpApp e1 op fix e2) =
-  case op of
-    HsVar op -> do { arg1 <- repE e1; 
-                    arg2 <- repE e2; 
-                    the_op <- lookupOcc op ;
-                    repInfixApp arg1 the_op arg2 } 
-    _        -> panic "DsMeta.repE: Operator is not a variable"
+  do { arg1 <- repE e1; 
+       arg2 <- repE e2; 
+       the_op <- repE op ;
+       repInfixApp arg1 the_op arg2 } 
 repE (NegApp x nm)        = do
                              a         <- repE x
                              negateVar <- lookupOcc negateName >>= repVar
@@ -468,8 +470,14 @@ repE (ExplicitPArr ty es) =
 repE (ExplicitTuple es boxed) 
   | isBoxed boxed         = do { xs <- repEs es; repTup xs }
   | otherwise            = panic "DsMeta.repE: Can't represent unboxed tuples"
-repE (RecordConOut _ _ _) = panic "DsMeta.repE: No record construction yet"
-repE (RecordUpdOut _ _ _ _) = panic "DsMeta.repE: No record update yet"
+repE (RecordCon c flds)
+ = do { x <- lookupOcc c;
+        fs <- repFields flds;
+        repRecCon x fs }
+repE (RecordUpd e flds)
+ = do { x <- repE e;
+        fs <- repFields flds;
+        repRecUpd x fs }
 
 repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 }
 repE (ArithSeqIn aseq) =
@@ -489,6 +497,7 @@ repE (ArithSeqIn aseq) =
                             ds3 <- repE e3
                             repFromThenTo ds1 ds2 ds3
 repE (PArrSeqOut _ aseq)  = panic "DsMeta.repE: parallel array seq.s missing"
+repE (HsCoreAnn _ _)      = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
 repE (HsCCall _ _ _ _ _)  = panic "DsMeta.repE: Can't represent __ccall__"
 repE (HsSCC _ _)          = panic "DsMeta.repE: Can't represent SCC"
 repE (HsBracketOut _ _)   = 
@@ -538,6 +547,13 @@ repGuards other
            = do { x <- repE e1; y <- repE e2; return (x, y) }
     process other = panic "Non Haskell 98 guarded body"
 
+repFields :: [(Name,HsExpr Name)] -> DsM (Core [M.FldE])
+repFields flds = do
+        fnames <- mapM lookupOcc (map fst flds)
+        es <- mapM repE (map snd flds)
+        fs <- zipWithM (\n x -> rep2 fieldName [unC n, unC x]) fnames es
+        coreList fieldTyConName fs
+
 
 -----------------------------------------------------------------------------
 -- Representing Stmt's is tricky, especially if bound variables
@@ -715,7 +731,11 @@ repP (ConPatIn dc details)
  = do { con_str <- lookupOcc dc
       ; case details of
          PrefixCon ps   -> do { qs <- repPs ps; repPcon con_str qs }
-         RecCon pairs   -> error "No records in template haskell yet"
+         RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs)
+                            ; ps <- sequence $ map repP (map snd pairs)
+                            ; fps <- zipWithM (\x y -> rep2 fieldPName [unC x,unC y]) vs ps
+                            ; fps' <- coreList fieldPTyConName fps
+                            ; repPrec con_str fps' }
          InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs }
    }
 repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))"
@@ -878,6 +898,9 @@ repPtup (MkC ps) = rep2 ptupName [ps]
 repPcon   :: Core String -> Core [M.Patt] -> DsM (Core M.Patt)
 repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps]
 
+repPrec   :: Core String -> Core [(String,M.Patt)] -> DsM (Core M.Patt)
+repPrec (MkC c) (MkC rps) = rep2 precName [c,rps]
+
 repPtilde :: Core M.Patt -> DsM (Core M.Patt)
 repPtilde (MkC p) = rep2 ptildeName [p]
 
@@ -931,14 +954,20 @@ repListExp (MkC es) = rep2 listExpName [es]
 repSigExp :: Core M.Expr -> Core M.Type -> DsM (Core M.Expr)
 repSigExp (MkC e) (MkC t) = rep2 sigExpName [e,t]
 
-repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr)
+repRecCon :: Core String -> Core [M.FldE]-> DsM (Core M.Expr)
+repRecCon (MkC c) (MkC fs) = rep2 recConName [c,fs]
+
+repRecUpd :: Core M.Expr -> Core [M.FldE] -> DsM (Core M.Expr)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdName [e,fs]
+
+repInfixApp :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
 repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
 
 repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y]
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
 
 repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr)
-repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y]
+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
 
 ------------ Right hand sides (guarded expressions) ----
 repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs)
@@ -984,8 +1013,8 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds]
 repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl)  
 repFun (MkC nm) (MkC b) = rep2 funName [nm, b]
 
-repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
-repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs]
+repData :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl)
+repData (MkC cxt) (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, cons, derivs]
 
 repTySyn :: Core String -> Core [String] -> Core M.Type -> DsM (Core M.Decl)
 repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs]
@@ -1002,8 +1031,23 @@ repProto (MkC s) (MkC ty) = rep2 protoName [s, ty]
 repCtxt :: Core [M.Type] -> DsM (Core M.Ctxt)
 repCtxt (MkC tys) = rep2 ctxtName [tys]
 
-repConstr :: Core String -> Core [M.Type] -> DsM (Core M.Cons)
-repConstr (MkC con) (MkC tys) = rep2 constrName [con, tys]
+repConstr :: Core String -> HsConDetails Name (BangType Name)
+          -> DsM (Core M.Cons)
+repConstr con (PrefixCon ps)
+    = do arg_tys  <- mapM repBangTy ps
+         arg_tys1 <- coreList strTypeTyConName arg_tys
+         rep2 constrName [unC con, unC arg_tys1]
+repConstr con (RecCon ips)
+    = do arg_vs   <- mapM lookupOcc (map fst ips)
+         arg_tys  <- mapM repBangTy (map snd ips)
+         arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y])
+                              arg_vs arg_tys
+         arg_vtys' <- coreList varStrTypeTyConName arg_vtys
+         rep2 recConstrName [unC con, unC arg_vtys']
+repConstr con (InfixCon st1 st2)
+    = do arg1 <- repBangTy st1
+         arg2 <- repBangTy st2
+         rep2 infixConstrName [unC arg1, unC con, unC arg2]
 
 ------------ Types -------------------
 
@@ -1137,11 +1181,15 @@ templateHaskellNames
                matchName, clauseName, funName, valName, tySynDName, dataDName, classDName,
                instName, protoName, tforallName, tvarName, tconName, tappName,
                arrowTyConName, tupleTyConName, listTyConName, namedTyConName,
-               ctxtName, constrName,
+               ctxtName, constrName, recConstrName, infixConstrName,
                exprTyConName, declTyConName, pattTyConName, mtchTyConName, 
                clseTyConName, stmtTyConName, consTyConName, typeTyConName,
+        strTypeTyConName, varStrTypeTyConName,
                qTyConName, expTyConName, matTyConName, clsTyConName,
-               decTyConName, typTyConName ]
+               decTyConName, typTyConName, strictTypeName, varStrictTypeName,
+        recConName, recUpdName, precName,
+        fieldName, fieldTyConName, fieldPName, fieldPTyConName,
+        strictName, nonstrictName ]
 
 
 varQual  = mk_known_key_name OccName.varName
@@ -1165,6 +1213,7 @@ pconName       = varQual FSLIT("pcon")          pconIdKey
 ptildeName     = varQual FSLIT("ptilde")        ptildeIdKey
 paspatName     = varQual FSLIT("paspat")        paspatIdKey
 pwildName      = varQual FSLIT("pwild")         pwildIdKey
+precName       = varQual FSLIT("prec")          precIdKey
 varName        = varQual FSLIT("var")           varIdKey
 conName        = varQual FSLIT("con")           conIdKey
 litName        = varQual FSLIT("lit")           litIdKey
@@ -1182,6 +1231,8 @@ caseEName      = varQual FSLIT("caseE")         caseEIdKey
 infixAppName   = varQual FSLIT("infixApp")      infixAppIdKey
 sectionLName   = varQual FSLIT("sectionL")      sectionLIdKey
 sectionRName   = varQual FSLIT("sectionR")      sectionRIdKey
+recConName     = varQual FSLIT("recCon")        recConIdKey
+recUpdName     = varQual FSLIT("recUpd")        recUpdIdKey
 guardedName    = varQual FSLIT("guarded")       guardedIdKey
 normalName     = varQual FSLIT("normal")        normalIdKey
 bindStName     = varQual FSLIT("bindSt")        bindStIdKey
@@ -1230,6 +1281,8 @@ ctxtName       = varQual FSLIT("ctxt")          ctxtIdKey
                         
 -- data Con = ...       
 constrName     = varQual FSLIT("constr")        constrIdKey
+recConstrName  = varQual FSLIT("recConstr")     recConstrIdKey
+infixConstrName = varQual FSLIT("infixConstr")  infixConstrIdKey
                         
 exprTyConName  = tcQual  FSLIT("Expr")                exprTyConKey
 declTyConName  = tcQual  FSLIT("Decl")                declTyConKey
@@ -1239,7 +1292,12 @@ clseTyConName  = tcQual  FSLIT("Clse")          clseTyConKey
 stmtTyConName  = tcQual  FSLIT("Stmt")                stmtTyConKey
 consTyConName  = tcQual  FSLIT("Cons")                consTyConKey
 typeTyConName  = tcQual  FSLIT("Type")                typeTyConKey
-                        
+strTypeTyConName  = tcQual  FSLIT("StrType")       strTypeTyConKey
+varStrTypeTyConName  = tcQual  FSLIT("VarStrType")       varStrTypeTyConKey
+
+fieldTyConName = tcQual FSLIT("FldE")              fieldTyConKey
+fieldPTyConName = tcQual FSLIT("FldP")             fieldPTyConKey
+
 qTyConName     = tcQual  FSLIT("Q")           qTyConKey
 expTyConName   = tcQual  FSLIT("Exp")                 expTyConKey
 decTyConName   = tcQual  FSLIT("Dec")                 decTyConKey
@@ -1247,6 +1305,14 @@ typTyConName   = tcQual  FSLIT("Typ")           typTyConKey
 matTyConName   = tcQual  FSLIT("Mat")                 matTyConKey
 clsTyConName   = tcQual  FSLIT("Cls")                 clsTyConKey
 
+strictTypeName = varQual  FSLIT("strictType")   strictTypeKey
+varStrictTypeName = varQual  FSLIT("varStrictType")   varStrictTypeKey
+strictName     = varQual  FSLIT("strict")       strictKey
+nonstrictName  = varQual  FSLIT("nonstrict")    nonstrictKey
+
+fieldName = varQual FSLIT("field")              fieldKey
+fieldPName = varQual FSLIT("fieldP")            fieldPKey
+
 --     TyConUniques available: 100-119
 --     Check in PrelNames if you want to change this
 
@@ -1264,6 +1330,10 @@ consTyConKey = mkPreludeTyConUnique 110
 typeTyConKey = mkPreludeTyConUnique 111
 typTyConKey  = mkPreludeTyConUnique 112
 decTyConKey  = mkPreludeTyConUnique 113
+varStrTypeTyConKey = mkPreludeTyConUnique 114
+strTypeTyConKey = mkPreludeTyConUnique 115
+fieldTyConKey = mkPreludeTyConUnique 116
+fieldPTyConKey = mkPreludeTyConUnique 117
 
 
 
@@ -1342,6 +1412,19 @@ rationalLIdKey   = mkPreludeMiscIdUnique 262
 
 sigExpIdKey     = mkPreludeMiscIdUnique 263
 
+strictTypeKey = mkPreludeMiscIdUnique 264
+strictKey = mkPreludeMiscIdUnique 265
+nonstrictKey = mkPreludeMiscIdUnique 266
+varStrictTypeKey = mkPreludeMiscIdUnique 267
+
+recConstrIdKey = mkPreludeMiscIdUnique 268
+infixConstrIdKey       = mkPreludeMiscIdUnique 269
+
+recConIdKey     = mkPreludeMiscIdUnique 270
+recUpdIdKey     = mkPreludeMiscIdUnique 271
+precIdKey       = mkPreludeMiscIdUnique 272
+fieldKey        = mkPreludeMiscIdUnique 273
+fieldPKey       = mkPreludeMiscIdUnique 274
 
 
 -- %************************************************************************
@@ -1352,4 +1435,4 @@ sigExpIdKey     = mkPreludeMiscIdUnique 263
 
 -- It is rather usatisfactory that we don't have a SrcLoc
 addDsWarn :: SDoc -> DsM ()
-addDsWarn msg = dsWarn (noSrcLoc, msg)
\ No newline at end of file
+addDsWarn msg = dsWarn (noSrcLoc, msg)