Add several new record features

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

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index f246412..5b624fb 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -33,7 +33,6 @@ import qualified Language.Haskell.TH as TH
 import HsSyn
 import Class
 import PrelNames
-import OccName
 -- To avoid clashes with DsMeta.varName we must make a local alias for
 -- OccName.varName we do this by removing varName from the import of
 -- OccName above, making a qualified instance of OccName and using
@@ -42,10 +41,8 @@ import qualified OccName
 
 import Module
 import Id
-import OccName
 import Name
 import NameEnv
-import Type
 import TcType
 import TyCon
 import TysWiredIn
@@ -398,6 +395,7 @@ repPred (HsClassP cls tys) = do
                               tcon <- repTy (HsTyVar cls)
                               tys1 <- repLTys tys
                               repTapps tcon tys1
+repPred p@(HsEqualP _ _) = notHandled "Equational constraint" (ppr p)
 repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p)
 
 -- yield the representation of a list of types
@@ -533,7 +531,7 @@ repE (RecordCon c _ flds)
  = do { x <- lookupLOcc c;
         fs <- repFields flds;
         repRecCon x fs }
-repE (RecordUpd e flds _ _)
+repE (RecordUpd e flds _ _ _)
  = do { x <- repLE e;
         fs <- repFields flds;
         repRecUpd x fs }
@@ -566,6 +564,7 @@ repE (HsSpliceE (HsSplice n _))
 repE e@(PArrSeq {})      = notHandled "Parallel arrays" (ppr e)
 repE e@(HsCoreAnn {})    = notHandled "Core annotations" (ppr e)
 repE e@(HsSCC {})        = notHandled "Cost centres" (ppr e)
+repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
 repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e)
 repE e                          = notHandled "Expression form" (ppr e)
 
@@ -614,12 +613,12 @@ repGuards other
                 g <- repPatGE (nonEmptyCoreList ss') rhs'
                 return (gs, g)
 
-repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
-repFields flds = do
-        fnames <- mapM lookupLOcc (map fst flds)
-        es <- mapM repLE (map snd flds)
-        fs <- zipWithM repFieldExp fnames es
-        coreList fieldExpQTyConName fs
+repFields :: [HsRecField Name (LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
+repFields flds
+  = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
+       ; es <- mapM repLE (map hsRecFieldArg flds)
+       ; fs <- zipWithM repFieldExp fnames es
+       ; coreList fieldExpQTyConName fs }
 
 
 -----------------------------------------------------------------------------
@@ -702,8 +701,8 @@ rep_val_binds (ValBindsOut binds sigs)
  = do { core1 <- rep_binds' (unionManyBags (map snd binds))
       ;        core2 <- rep_sigs' sigs
       ;        return (core1 ++ core2) }
-rep_val_binds (ValBindsOut binds sigs)
- = panic "rep_val_binds: ValBindsOut"
+rep_val_binds (ValBindsIn binds sigs)
+ = panic "rep_val_binds: ValBindsIn"
 
 rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]
 rep_binds binds = do { binds_w_locs <- rep_binds' binds
@@ -1267,10 +1266,13 @@ mk_integer  i = do integer_ty <- lookupType integerTyConName
                    return $ HsInteger i integer_ty
 mk_rational r = do rat_ty <- lookupType rationalTyConName
                    return $ HsRat r rat_ty
+mk_string s   = do string_ty <- lookupType stringTyConName
+                   return $ HsString s
 
 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
 repOverloadedLiteral (HsIntegral i _)   = do { lit <- mk_integer  i; repLiteral lit }
 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
+repOverloadedLiteral (HsIsString s _)   = do { lit <- mk_string   s; repLiteral lit }
        -- The type Rational will be in the environment, becuase 
        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
        -- and rationalL is sucked in when any TH stuff is used