X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=162e90fa01b1f2c4b1f9f66281a7910307c6cd66;hb=c5dbdf06b92472ef64b66a01f107ba30b65c3708;hp=5303f9d75319c66884262b74290924d37ba86f19;hpb=9f55c592f7283e5d16dd406c767af352adf30bfc;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 5303f9d..162e90f 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -13,17 +13,9 @@ -- a Royal Pain (triggers other recompilation). ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-unused-imports #-} --- 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 --- The kludge is only needed in this module because of trac #2267. - module DsMeta( dsBracket, templateHaskellNames, qTyConName, nameTyConName, - liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName, + liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName, decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, quoteExpName, quotePatName ) where @@ -33,7 +25,6 @@ module DsMeta( dsBracket, import {-# SOURCE #-} DsExpr ( dsExpr ) import MatchLit -import DsUtils import DsMonad import qualified Language.Haskell.TH as TH @@ -333,7 +324,7 @@ repInstD' (L loc (InstDecl ty binds _ ats)) -- Ignore user pragmas for now (tvs, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty) repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ) -repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis))) +repForD (L loc (ForeignImport name typ (CImport cc s ch cis))) = do MkC name' <- lookupLOcc name MkC typ' <- repLTy typ MkC cc' <- repCCallConv cc @@ -341,7 +332,6 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis))) cis' <- conv_cimportspec cis MkC str <- coreStringLit $ static ++ unpackFS ch ++ " " - ++ unpackFS cn ++ " " ++ cis' dec <- rep2 forImpDName [cc', s', str, name', typ'] return (loc, dec) @@ -358,7 +348,7 @@ repForD decl = notHandled "Foreign declaration" (ppr decl) repCCallConv :: CCallConv -> DsM (Core TH.Callconv) repCCallConv CCallConv = rep2 cCallName [] repCCallConv StdCallConv = rep2 stdCallName [] -repCCallConv CmmCallConv = notHandled "repCCallConv" (ppr CmmCallConv) +repCCallConv callConv = notHandled "repCCallConv" (ppr callConv) repSafety :: Safety -> DsM (Core TH.Safety) repSafety PlayRisky = rep2 unsafeName [] @@ -373,14 +363,14 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") ------------------------------------------------------- repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L _ (ConDecl con _ [] (L _ []) details ResTyH98 _)) +repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] + , con_details = details, con_res = 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 doc)) +repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 })) = addTyVarBinds tvs $ \bndrs -> - do { c' <- repC (L loc (ConDecl con expl [] (L cloc []) details - ResTyH98 doc)) + do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] })) ; ctxt' <- repContext ctxt ; bndrs' <- coreList tyVarBndrTyConName bndrs ; rep2 forallCName [unC bndrs', unC ctxt', unC c'] @@ -597,43 +587,44 @@ repTy (HsForAllTy _ tvs ctxt ty) = repTForall bndrs1 ctxt1 ty1 repTy (HsTyVar n) - | isTvOcc (nameOccName n) = do - tv1 <- lookupTvOcc n - repTvar tv1 - | otherwise = do - tc1 <- lookupOcc n - repNamedTyCon tc1 -repTy (HsAppTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - repTapp f1 a1 -repTy (HsFunTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - tcon <- repArrowTyCon - repTapps tcon [f1, a1] -repTy (HsListTy t) = do - t1 <- repLTy t - tcon <- repListTyCon - repTapp tcon t1 -repTy (HsPArrTy t) = do - t1 <- repLTy t - tcon <- repTy (HsTyVar (tyConName parrTyCon)) - repTapp tcon t1 -repTy (HsTupleTy _ tys) = do - tys1 <- repLTys tys - tcon <- repTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) - `nlHsAppTy` ty2) -repTy (HsParTy t) = repLTy t -repTy (HsPredTy pred) = repPredTy pred -repTy (HsKindSig t k) = do - t1 <- repLTy t - k1 <- repKind k - repTSig t1 k1 -repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) -repTy ty = notHandled "Exotic form of type" (ppr ty) + | isTvOcc (nameOccName n) = do + tv1 <- lookupTvOcc n + repTvar tv1 + | otherwise = do + tc1 <- lookupOcc n + repNamedTyCon tc1 +repTy (HsAppTy f a) = do + f1 <- repLTy f + a1 <- repLTy a + repTapp f1 a1 +repTy (HsFunTy f a) = do + f1 <- repLTy f + a1 <- repLTy a + tcon <- repArrowTyCon + repTapps tcon [f1, a1] +repTy (HsListTy t) = do + t1 <- repLTy t + tcon <- repListTyCon + repTapp tcon t1 +repTy (HsPArrTy t) = do + t1 <- repLTy t + tcon <- repTy (HsTyVar (tyConName parrTyCon)) + repTapp tcon t1 +repTy (HsTupleTy _ tys) = do + tys1 <- repLTys tys + tcon <- repTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) + `nlHsAppTy` ty2) +repTy (HsParTy t) = repLTy t +repTy (HsPredTy pred) = repPredTy pred +repTy (HsKindSig t k) = do + t1 <- repLTy t + k1 <- repKind k + repTSig t1 k1 +repTy (HsSpliceTy splice) = repSplice splice +repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) +repTy ty = notHandled "Exotic form of type" (ppr ty) -- represent a kind -- @@ -650,6 +641,21 @@ repKind ki (ppr k) ----------------------------------------------------------------------------- +-- Splices +----------------------------------------------------------------------------- + +repSplice :: HsSplice Name -> DsM (Core a) +-- See Note [How brackets and nested splices are handled] in TcSplice +-- We return a CoreExpr of any old type; the context should know +repSplice (HsSplice n _) + = do { mb_val <- dsLookupMetaEnv n + ; case mb_val of + Just (Splice e) -> do { e' <- dsExpr e + ; return (MkC e') } + _ -> pprPanic "HsSplice" (ppr n) } + -- Should not happen; statically checked + +----------------------------------------------------------------------------- -- Expressions ----------------------------------------------------------------------------- @@ -722,8 +728,10 @@ repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e) repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) - | isBoxed boxed = do { xs <- repLEs es; repTup xs } - | otherwise = notHandled "Unboxed tuples" (ppr e) + | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e) + | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) + | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs } + repE (RecordCon c _ flds) = do { x <- lookupLOcc c; fs <- repFields flds; @@ -750,14 +758,8 @@ repE (ArithSeq _ aseq) = ds2 <- repLE e2 ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (HsSpliceE (HsSplice n _)) - = do { mb_val <- dsLookupMetaEnv n - ; case mb_val of - Just (Splice e) -> do { e' <- dsExpr e - ; return (MkC e') } - _ -> pprPanic "HsSplice" (ppr n) } - -- Should not happen; statically checked +repE (HsSpliceE splice) = repSplice splice repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) @@ -1757,12 +1759,13 @@ predTyConName = thTc (fsLit "Pred") predTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, - mkNameLName :: Name -returnQName = thFun (fsLit "returnQ") returnQIdKey -bindQName = thFun (fsLit "bindQ") bindQIdKey -sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey + mkNameLName, liftStringName :: Name +returnQName = thFun (fsLit "returnQ") returnQIdKey +bindQName = thFun (fsLit "bindQ") bindQIdKey +sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey newNameName = thFun (fsLit "newName") newNameIdKey -liftName = thFun (fsLit "lift") liftIdKey +liftName = thFun (fsLit "lift") liftIdKey +liftStringName = thFun (fsLit "liftString") liftStringIdKey mkNameName = thFun (fsLit "mkName") mkNameIdKey mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey @@ -2053,6 +2056,9 @@ floatPrimLIdKey = mkPreludeMiscIdUnique 215 doublePrimLIdKey = mkPreludeMiscIdUnique 216 rationalLIdKey = mkPreludeMiscIdUnique 217 +liftStringIdKey :: Unique +liftStringIdKey = mkPreludeMiscIdUnique 218 + -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique @@ -2081,6 +2087,7 @@ matchIdKey = mkPreludeMiscIdUnique 231 clauseIdKey :: Unique clauseIdKey = mkPreludeMiscIdUnique 232 + -- data Exp = ... varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey,