X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=fa7fafe2a2e8fcfdf4c5cf143a181c86b6306995;hb=49ae18be5dbd124c59a13e7ccb7338525e68ad4d;hp=b4ecf01eb5671dc4f32e968d38b35611076f07d6;hpb=190f24892156953d73b55401d0467a6f1a88ce5d;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index b4ecf01..fa7fafe 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1,4 +1,7 @@
 -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2006
+--
 -- The purpose of this module is to transform an HsExpr into a CoreExpr which
 -- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
 -- input HsExpr. We do this in the DsM monad, which supplies access to
@@ -21,47 +24,42 @@ module DsMeta( dsBracket,
 
 import {-# SOURCE #-}	DsExpr ( dsExpr )
 
-import MatchLit	  ( dsLit )
-import DsUtils    ( mkListExpr, mkStringExpr, mkIntExpr )
+import MatchLit
+import DsUtils
 import DsMonad
 
 import qualified Language.Haskell.TH as TH
 
 import HsSyn
-import Class (FunDep)
-import PrelNames  ( rationalTyConName, integerTyConName, negateName )
-import OccName	  ( isDataOcc, isTvOcc, occNameString )
--- 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 OccNameAlias.varName where varName
--- ws previously used in this file.
+import Class
+import PrelNames
+-- 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
+-- OccNameAlias.varName where varName ws previously used in this file.
 import qualified OccName
 
-import Module	  ( Module, mkModule, moduleNameString, moduleName,
-                    modulePackageId, mkModuleNameFS )
-import Id         ( Id, mkLocalId )
-import OccName	  ( mkOccNameFS )
-import Name       ( Name, mkExternalName, localiseName, nameOccName, nameModule, 
-		    isExternalName, getSrcLoc )
+import Module
+import Id
+import Name
 import NameEnv
-import Type       ( Type, mkTyConApp )
-import TcType	  ( tcTyConAppArgs )
-import TyCon	  ( tyConName )
-import TysWiredIn ( parrTyCon )
+import TcType
+import TyCon
+import TysWiredIn
 import CoreSyn
-import CoreUtils  ( exprType )
-import SrcLoc	  ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan )
-import PackageConfig ( thPackageId, packageIdString )
-import Unique	  ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
-import BasicTypes ( isBoxed ) 
+import CoreUtils
+import SrcLoc
+import PackageConfig
+import Unique
+import BasicTypes
 import Outputable
-import Bag	  ( bagToList, unionManyBags )
-import FastString ( unpackFS )
-import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
+import Bag
+import FastString
+import ForeignCall
 
-import Maybe	  ( catMaybes )
-import Monad ( zipWithM )
-import List ( sortBy )
+import Data.Maybe
+import Control.Monad
+import Data.List
  
 -----------------------------------------------------------------------------
 dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr
@@ -397,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
@@ -528,11 +527,11 @@ repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e)
 repE e@(ExplicitTuple es boxed) 
   | isBoxed boxed         = do { xs <- repLEs es; repTup xs }
   | otherwise		  = notHandled "Unboxed tuples" (ppr e)
-repE (RecordCon c _ flds)
+repE (RecordCon c _ (HsRecordBinds flds))
  = do { x <- lookupLOcc c;
         fs <- repFields flds;
         repRecCon x fs }
-repE (RecordUpd e flds _ _)
+repE (RecordUpd e (HsRecordBinds flds) _ _)
  = do { x <- repLE e;
         fs <- repFields flds;
         repRecUpd x fs }
@@ -565,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)
 
@@ -701,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
@@ -1266,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
@@ -1306,6 +1309,9 @@ nonEmptyCoreList :: [Core a] -> Core [a]
 nonEmptyCoreList [] 	      = panic "coreList: empty argument"
 nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
 
+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 <- mkStringExpr s; return(MkC z) }
 
@@ -1408,14 +1414,10 @@ thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib")
 
 mkTHModule m = mkModule thPackageId (mkModuleNameFS m)
 
-mk_known_key_name mod space str uniq 
-  = mkExternalName uniq mod (mkOccNameFS space str) 
-	           Nothing noSrcLoc
-
-libFun = mk_known_key_name thLib OccName.varName
-libTc  = mk_known_key_name thLib OccName.tcName
-thFun  = mk_known_key_name thSyn OccName.varName
-thTc   = mk_known_key_name thSyn OccName.tcName
+libFun = mk_known_key_name OccName.varName thLib
+libTc  = mk_known_key_name OccName.tcName  thLib
+thFun  = mk_known_key_name OccName.varName thSyn
+thTc   = mk_known_key_name OccName.tcName  thSyn
 
 -------------------- TH.Syntax -----------------------
 qTyConName        = thTc FSLIT("Q")            qTyConKey