add -fsimpleopt-before-flatten

[ghc-hetmet.git] / compiler / deSugar / DsExpr.lhs

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 4084310..5b566a0 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -216,6 +216,16 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)             = dsLExpr e
+
+dsExpr (HsHetMetBrak c   e)   = do { e' <- dsExpr (unLoc e)
+                                 ; brak <- dsLookupGlobalId hetmet_brak_name
+                                 ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] }
+dsExpr (HsHetMetEsc  c t e)   = do { e' <- dsExpr (unLoc e)
+                                 ; esc <- dsLookupGlobalId hetmet_esc_name
+                                 ; return $ mkApps (Var esc)  [ (Type c), (Type t), e'] }
+dsExpr (HsHetMetCSP  c   e)   = do { e' <- dsExpr (unLoc e)
+                                 ; csp <- dsLookupGlobalId hetmet_csp_name
+                                 ; return $ mkApps (Var csp)  [ (Type c), (Type $ exprType e'), e'] }
 dsExpr (ExprWithTySigOut e _) = dsLExpr e
 dsExpr (HsVar var)                   = return (Var var)
 dsExpr (HsIPVar ip)                  = return (Var (ipNameName ip))
@@ -368,11 +378,11 @@ dsExpr (ExplicitList elt_ty xs)
 --   singletonP x1 +:+ ... +:+ singletonP xn
 --
 dsExpr (ExplicitPArr ty []) = do
-    emptyP <- dsLookupGlobalId emptyPName
+    emptyP <- dsLookupDPHId emptyPName
     return (Var emptyP `App` Type ty)
 dsExpr (ExplicitPArr ty xs) = do
-    singletonP <- dsLookupGlobalId singletonPName
-    appP       <- dsLookupGlobalId appPName
+    singletonP <- dsLookupDPHId singletonPName
+    appP       <- dsLookupDPHId appPName
     xs'        <- mapM dsLExpr xs
     return . foldr1 (binary appP) $ map (unary singletonP) xs'
   where