X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=83eff557bff9e25f97977214af3b293623fc4a57;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hp=d859d86b301aa2f421dc4f5cb81eb6a4baa536d6;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d859d86..83eff55 100644 --- 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 :: 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 } ----------------------------------------------------------------------------- @@ -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 @@ -815,9 +814,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 hsRecFieldId pairs) - ; ps <- sequence $ map repLP (map hsRecFieldArg 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' } @@ -1186,15 +1186,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 hsRecFieldId ips) - arg_tys <- mapM repBangTy (map hsRecFieldArg 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 @@ -1267,10 +1267,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 @@ -1412,14 +1415,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