-- 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, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName,
import {-# SOURCE #-} DsExpr ( dsExpr )
import MatchLit
-import DsUtils
import DsMonad
import qualified Language.Haskell.TH as TH
-- 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 qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName )
import Module
import Id
-import Name
+import Name hiding( isVarOcc, isTcOcc, varName, tcName )
import NameEnv
import TcType
import TyCon
(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
cis' <- conv_cimportspec cis
MkC str <- coreStringLit $ static
++ unpackFS ch ++ " "
- ++ unpackFS cn ++ " "
++ cis'
dec <- rep2 forImpDName [cc', s', str, name', typ']
return (loc, dec)
where
conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
- conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs)
+ conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
conv_cimportspec CWrapper = return "wrapper"
static = case cis of
- CFunction (StaticTarget _) -> "static "
+ CFunction (StaticTarget _ _) -> "static "
_ -> ""
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 []
-------------------------------------------------------
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']
; return [(loc, sig)]
}
-rep_inline :: Located Name -> InlineSpec -> SrcSpan
+rep_inline :: Located Name
+ -> InlinePragma -- Never defaultInlinePragma
+ -> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
rep_inline nm ispec loc
= do { nm1 <- lookupLOcc nm
- ; (_, ispec1) <- rep_InlineSpec ispec
+ ; ispec1 <- rep_InlinePrag ispec
; pragma <- repPragInl nm1 ispec1
; return [(loc, pragma)]
}
-rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan
+rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
rep_specialise nm ty ispec loc
= do { nm1 <- lookupLOcc nm
; ty1 <- repLTy ty
- ; (hasSpec, ispec1) <- rep_InlineSpec ispec
- ; pragma <- if hasSpec
- then repPragSpecInl nm1 ty1 ispec1
- else repPragSpec nm1 ty1
+ ; pragma <- if isDefaultInlinePragma ispec
+ then repPragSpec nm1 ty1 -- SPECIALISE
+ else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE
+ ; repPragSpecInl nm1 ty1 ispec1 }
; return [(loc, pragma)]
}
--- extract all the information needed to build a TH.InlineSpec
+-- Extract all the information needed to build a TH.InlinePrag
--
-rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ)
-rep_InlineSpec (Inline (InlinePragma activation match) inline)
+rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma
+ -> DsM (Core TH.InlineSpecQ)
+rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline })
| Nothing <- activation1
- = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1
+ = repInlineSpecNoPhase inline1 match1
| Just (flag, phase) <- activation1
- = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase
+ = repInlineSpecPhase inline1 match1 flag phase
| otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec"
where
match1 = coreBool (rep_RuleMatchInfo match)
rep_RuleMatchInfo FunLike = False
rep_RuleMatchInfo ConLike = True
- rep_Activation NeverActive = Nothing
- rep_Activation AlwaysActive = Nothing
+ rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive
+ rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive
rep_Activation (ActiveBefore phase) = Just (coreBool False,
MkC $ mkIntExprInt phase)
rep_Activation (ActiveAfter phase) = Just (coreBool True,
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
--
(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
-----------------------------------------------------------------------------
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;
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)
repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
repP (ParPat p) = repLP p
repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs }
-repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs }
+repP p@(TuplePat ps boxed _)
+ | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p)
+ | otherwise = do { qs <- repLPs ps; repPtup qs }
repP (ConPatIn dc details)
= do { con_str <- lookupLOcc dc
; case details of
projects / ghc-hetmet.git / blobdiff