There are some unused things, but I am not sure if the intention is that
they will be used in the future. Names implied they were related to
splicing in patterns and types.
TcSplice: Template Haskell splices
\begin{code}
TcSplice: Template Haskell splices
\begin{code}
+{-# OPTIONS -fno-warn-unused-imports -fno-warn-unused-binds #-}
-- 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
-- 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
import Var
import Module
import TcRnMonad
import Var
import Module
import TcRnMonad
import Class
import TyCon
import DataCon
import Class
import TyCon
import DataCon
import SrcLoc
import Outputable
import Unique
import SrcLoc
import Outputable
import Unique
-import DynFlags
-import PackageConfig
import Maybe
import BasicTypes
import Panic
import Maybe
import BasicTypes
import Panic
import qualified Language.Haskell.TH.Syntax as TH
import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
import qualified Language.Haskell.TH.Syntax as TH
import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
-import Control.Monad ( liftM )
import qualified Control.Exception as Exception( userErrors )
\end{code}
import qualified Control.Exception as Exception( userErrors )
\end{code}
runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
#ifndef GHCI
runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
#ifndef GHCI
-tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
-tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
+tcSpliceExpr _ e _ = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
+tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e)
-runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
-runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
+runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
+runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
| otherwise
-> do { checkTc (use_lvl == bind_lvl)
(quotedNameStageErr name) }
| otherwise
-> do { checkTc (use_lvl == bind_lvl)
(quotedNameStageErr name) }
- other -> pprPanic "th_bracket" (ppr name)
+ _ -> pprPanic "th_bracket" (ppr name)
; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
}
; tcMetaTy nameTyConName -- Result type is Var (not Q-monadic)
}
-tc_bracket use_lvl (ExpBr expr)
+tc_bracket _ (ExpBr expr)
= do { any_ty <- newFlexiTyVarTy liftedTypeKind
; tcMonoExpr expr any_ty
; tcMetaTy expQTyConName }
-- Result type is Expr (= Q Exp)
= do { any_ty <- newFlexiTyVarTy liftedTypeKind
; tcMonoExpr expr any_ty
; tcMetaTy expQTyConName }
-- Result type is Expr (= Q Exp)
-tc_bracket use_lvl (TypBr typ)
+tc_bracket _ (TypBr typ)
= do { tcHsSigType ExprSigCtxt typ
; tcMetaTy typeQTyConName }
-- Result type is Type (= Q Typ)
= do { tcHsSigType ExprSigCtxt typ
; tcMetaTy typeQTyConName }
-- Result type is Type (= Q Typ)
-tc_bracket use_lvl (DecBr decls)
+tc_bracket _ (DecBr decls)
= do { tcTopSrcDecls emptyModDetails decls
-- Typecheck the declarations, dicarding the result
-- We'll get all that stuff later, when we splice it in
= do { tcTopSrcDecls emptyModDetails decls
-- Typecheck the declarations, dicarding the result
-- We'll get all that stuff later, when we splice it in
-- Result type is Q [Dec]
}
-- Result type is Q [Dec]
}
-tc_bracket use_lvl (PatBr _)
= failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
= failWithTc (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
+quotedNameStageErr :: Name -> SDoc
quotedNameStageErr v
= sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
, ptext (sLit "must be used at the same stage at which is is bound")]
quotedNameStageErr v
= sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr (VarBr v)
, ptext (sLit "must be used at the same stage at which is is bound")]
writeMutVar ps_var ((name,expr') : ps)
return (panic "tcSpliceExpr") -- The returned expression is ignored
writeMutVar ps_var ((name,expr') : ps)
return (panic "tcSpliceExpr") -- The returned expression is ignored
+
+ ; Splice {} -> panic "tcSpliceExpr Splice"
}}
-- tcTopSplice used to have this:
}}
-- tcTopSplice used to have this:
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
- (exp3, fvs) <- checkNoErrs (rnLExpr expr2)
+ (exp3, _fvs) <- checkNoErrs (rnLExpr expr2)
-> Name -- Name of th_syn type
-> (SrcSpan -> th_syn -> Either Message hs_syn)
-> TcM hs_syn
-> Name -- Name of th_syn type
-> (SrcSpan -> th_syn -> Either Message hs_syn)
-> TcM hs_syn
-runQuasiQuote (HsQuasiQuote name quoter q_span quote) quote_selector desc meta_ty convert
+runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ty convert
= do { -- Check that the quoter is not locally defined, otherwise the TH
-- machinery will not be able to run the quasiquote.
; this_mod <- getModule
= do { -- Check that the quoter is not locally defined, otherwise the TH
-- machinery will not be able to run the quasiquote.
; this_mod <- getModule
runQuasiQuotePat quasiquote
= runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
runQuasiQuotePat quasiquote
= runQuasiQuote quasiquote quotePatName "pattern" patQTyConName convertToPat
+quoteStageError :: Name -> SDoc
quoteStageError quoter
= sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
quoteStageError quoter
= sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
-- but $(h 4) :: forall a.a i.e. any kind
; kind <- newKindVar
; return (panic "kcSpliceType", kind) -- The returned type is ignored
-- but $(h 4) :: forall a.a i.e. any kind
; kind <- newKindVar
; return (panic "kcSpliceType", kind) -- The returned type is ignored
+ }
+ ; Splice {} -> panic "kcSpliceType Splice"
+ }}}}
kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
kcTopSpliceType expr
kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind)
kcTopSpliceType expr
zonked_q_expr
(ppr (getLoc expr) $$ (vcat (map ppr decls)))
; return decls }
zonked_q_expr
(ppr (getLoc expr) $$ (vcat (map ppr decls)))
; return decls }
-
- where handleErrors :: [Either a Message] -> TcM [a]
- handleErrors [] = return []
- handleErrors (Left x:xs) = liftM (x:) (handleErrors xs)
- handleErrors (Right m:xs) = do addErrTc m
- handleErrors xs
text "======>",
nest 2 after])])
text "======>",
nest 2 after])])
+illegalBracket :: ThStage -> SDoc
illegalBracket level
= ptext (sLit "Illegal bracket at level") <+> ppr level
illegalBracket level
= ptext (sLit "Illegal bracket at level") <+> ppr level
+illegalSplice :: ThStage -> SDoc
illegalSplice level
= ptext (sLit "Illegal splice at level") <+> ppr level
illegalSplice level
= ptext (sLit "Illegal splice at level") <+> ppr level
ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
+ ppr_ns _ = panic "reify/ppr_ns"
lookupThName :: TH.Name -> TcM Name
lookupThName th_name@(TH.Name occ flavour)
lookupThName :: TH.Name -> TcM Name
lookupThName th_name@(TH.Name occ flavour)
; let v = reifyName id
; case globalIdDetails id of
ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
; let v = reifyName id
; case globalIdDetails id of
ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
- other -> return (TH.VarI v ty Nothing fix)
+ _ -> return (TH.VarI v ty Nothing fix)
}
reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
}
reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
; ty2 <- reifyType ty1
; return (TH.TyVarI (reifyName tv) ty2) }
; ty2 <- reifyType ty1
; return (TH.TyVarI (reifyName tv) ty2) }
+reifyThing (AThing {}) = panic "reifyThing AThing"
+
------------------------------
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
------------------------------
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
where
(tvs, cxt, tau) = tcSplitSigmaTy ty
; return (TH.ForallT (reifyTyVars tvs) cxt' tau') }
where
(tvs, cxt, tau) = tcSplitSigmaTy ty
+reifyType (PredTy {}) = panic "reifyType PredTy"
+
+reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
reifyTypes = mapM reifyType
+reifyCxt :: [PredType] -> TcM [TH.Type]
reifyCxt = mapM reifyPred
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyCxt = mapM reifyPred
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyPred :: TypeRep.PredType -> TcM TH.Type
reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
reifyPred :: TypeRep.PredType -> TcM TH.Type
reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
+reifyPred (EqPred {}) = panic "reifyPred EqPred"
------------------------------
------------------------------