-----------------------------------------------------------------------------
+--
+-- (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
import {-# SOURCE #-} DsExpr ( dsExpr )
-import MatchLit ( dsLit )
-import DsUtils ( mkListExpr, mkStringExpr, mkCoreTup, 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
+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
+-- 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 OccName
+import Name
import NameEnv
-import Type ( Type, mkTyConApp )
-import TcType ( tcTyConAppArgs )
-import TyCon ( tyConName )
-import TysWiredIn ( parrTyCon )
+import Type
+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
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
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 }
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)
= 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
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
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