X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=3317ffaa72f54dd2f1139d15fe558b21f203fb00;hp=1406d63c6e396fa9c6577d78b153376354ec806d;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=afef39736dcde6f4947a6f362f9e6b3586933db4 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 1406d63..3317ffa 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 @@ -10,6 +13,12 @@ -- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details module DsMeta( dsBracket, templateHaskellNames, qTyConName, nameTyConName, @@ -21,47 +30,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 @@ -289,12 +293,12 @@ ds_msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98)) +repC (L loc (ConDecl con expl [] (L _ []) details ResTyH98 _)) = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences] repConstr con1 details } -repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98)) +repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98 doc)) = do { addTyVarBinds tvs $ \bndrs -> do { - c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98)); + c' <- repC (L loc (ConDecl con expl [] (L cloc []) details ResTyH98 doc)); ctxt' <- repContext ctxt; bndrs' <- coreList nameTyConName bndrs; rep2 forallCName [unC bndrs', unC ctxt', unC c'] @@ -397,6 +401,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 @@ -532,7 +537,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 } @@ -565,6 +570,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) @@ -613,12 +619,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 :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp]) +repFields (HsRecFields { rec_flds = flds }) + = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds) + ; es <- mapM repLE (map hsRecFieldArg flds) + ; fs <- zipWithM repFieldExp fnames es + ; coreList fieldExpQTyConName fs } ----------------------------------------------------------------------------- @@ -701,8 +707,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 @@ -784,7 +790,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyns ss lam } -repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m) +repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) ----------------------------------------------------------------------------- @@ -814,9 +820,10 @@ repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of - PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } - RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs) - ; ps <- sequence $ map repLP (map snd pairs) + PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } + RecCon rec -> do { let flds = rec_flds rec + ; vs <- sequence $ map lookupLOcc (map hsRecFieldId flds) + ; ps <- sequence $ map repLP (map hsRecFieldArg flds) ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps ; fps' <- coreList fieldPatQTyConName fps ; repPrec con_str fps' } @@ -824,8 +831,8 @@ repP (ConPatIn dc details) p2' <- repLP p2; repPinfix p1' con_str p2' } } -repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a } -repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p) +repP (NPat l Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } +repP p@(NPat l (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) -- The problem is to do with scoped type variables. -- To implement them, we have to implement the scoping rules @@ -1185,15 +1192,15 @@ repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty] repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] -repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name) +repConstr :: Core TH.Name -> HsConDeclDetails Name -> DsM (Core TH.ConQ) repConstr con (PrefixCon ps) = do arg_tys <- mapM repBangTy ps arg_tys1 <- coreList strictTypeQTyConName arg_tys rep2 normalCName [unC con, unC arg_tys1] repConstr con (RecCon ips) - = do arg_vs <- mapM lookupLOcc (map fst ips) - arg_tys <- mapM repBangTy (map snd ips) + = do arg_vs <- mapM lookupLOcc (map cd_fld_name ips) + arg_tys <- mapM repBangTy (map cd_fld_type ips) arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) arg_vs arg_tys arg_vtys' <- coreList varStrictTypeQTyConName arg_vtys @@ -1266,10 +1273,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 (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 +1316,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 +1421,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