Commit 87998beb authored by simonpj's avatar simonpj

[project @ 2005-11-12 21:41:12 by simonpj]

Better TH -> HsSyn conversion

	Merge to stable (attempt)

This commit monad-ises the TH syntax -> HS syntax conversion.
This means that error messages can be reported in a more civilised
way.  It also ensures that the entire structure is converted eagerly.
That means that any exceptions buried inside it are triggered 
during conversion, and caught by the exception handler in TcSplice.
Before, they could be triggered later, and looked like comiler
crashes.
parent 84b434c5
......@@ -162,8 +162,8 @@ nameSpaceString TcClsName = "Type constructor or class"
\begin{code}
data OccName = OccName
{ occNameSpace :: NameSpace
, occNameFS :: EncodedFS
{ occNameSpace :: !NameSpace
, occNameFS :: !EncodedFS
}
\end{code}
......
This diff is collapsed.
......@@ -500,6 +500,18 @@ instance Outputable NewOrData where
\begin{code}
type LConDecl name = Located (ConDecl name)
-- data T b = forall a. Eq a => MkT a b
-- MkT :: forall b a. Eq a => MkT a b
-- data T b where
-- MkT1 :: Int -> T Int
-- data T = Int `MkT` Int
-- | MkT2
-- data T a where
-- Int `MkT` Int :: T Int
data ConDecl name
= ConDecl
{ con_name :: Located name -- Constructor name; this is used for the
......
......@@ -458,17 +458,17 @@ tycl_decl :: { LTyClDecl RdrName }
| 'data' tycl_hdr constrs deriving
{ L (comb4 $1 $2 $3 $4) -- We need the location on tycl_hdr
-- in case constrs and deriving are both empty
(mkTyData DataType $2 Nothing (reverse (unLoc $3)) (unLoc $4)) }
(mkTyData DataType (unLoc $2) Nothing (reverse (unLoc $3)) (unLoc $4)) }
| 'data' tycl_hdr opt_kind_sig
'where' gadt_constrlist
deriving
{ L (comb4 $1 $2 $4 $5)
(mkTyData DataType $2 $3 (reverse (unLoc $5)) (unLoc $6)) }
(mkTyData DataType (unLoc $2) $3 (reverse (unLoc $5)) (unLoc $6)) }
| 'newtype' tycl_hdr '=' newconstr deriving
{ L (comb3 $1 $4 $5)
(mkTyData NewType $2 Nothing [$4] (unLoc $5)) }
(mkTyData NewType (unLoc $2) Nothing [$4] (unLoc $5)) }
| 'class' tycl_hdr fds where
{ let
......
......@@ -83,10 +83,10 @@ tdefs :: { [TyClDecl RdrName] }
tdef :: { TyClDecl RdrName }
: '%data' q_tc_name tv_bndrs '=' '{' cons1 '}'
{ mkTyData DataType (noLoc (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3)) Nothing $6 Nothing }
{ mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) Nothing $6 Nothing }
| '%newtype' q_tc_name tv_bndrs trep
{ let tc_rdr = ifaceExtRdrName $2 in
mkTyData NewType (noLoc (noLoc [], noLoc tc_rdr, map toHsTvBndr $3)) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) Nothing ($4 (rdrNameOcc tc_rdr)) Nothing }
-- For a newtype we have to invent a fake data constructor name
-- It doesn't matter what it is, because it won't be used
......
......@@ -158,7 +158,7 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds
tcdMeths = mbinds
}
mkTyData new_or_data (L _ (context, tname, tyvars)) ksig data_cons maybe_deriv
mkTyData new_or_data (context, tname, tyvars) ksig data_cons maybe_deriv
= TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname,
tcdTyVars = tyvars, tcdCons = data_cons,
tcdKindSig = ksig, tcdDerivs = maybe_deriv }
......
......@@ -56,7 +56,7 @@ import IdInfo ( GlobalIdDetails(..) )
import TysWiredIn ( mkListTy )
import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
import ErrUtils ( Message )
import SrcLoc ( noLoc, unLoc, getLoc )
import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc )
import Outputable
import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
......@@ -207,14 +207,8 @@ tcTopSplice expr res_ty
-- Run the expression
traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
runMetaE zonked_q_expr `thenM` \ simple_expr ->
runMetaE convertToHsExpr zonked_q_expr `thenM` \ expr2 ->
let
-- simple_expr :: TH.Exp
expr2 :: LHsExpr RdrName
expr2 = convertToHsExpr (getLoc expr) simple_expr
in
traceTc (text "Got result" <+> ppr expr2) `thenM_`
showSplice "expression"
......@@ -297,12 +291,8 @@ kcTopSpliceType expr
-- Run the expression
; traceTc (text "About to run" <+> ppr zonked_q_expr)
; simple_ty <- runMetaT zonked_q_expr
; hs_ty2 <- runMetaT convertToHsType zonked_q_expr
; let -- simple_ty :: TH.Type
hs_ty2 :: LHsType RdrName
hs_ty2 = convertToHsType (getLoc expr) simple_ty
; traceTc (text "Got result" <+> ppr hs_ty2)
; showSplice "type" zonked_q_expr (ppr hs_ty2)
......@@ -333,11 +323,8 @@ tcSpliceDecls expr
-- Run the expression
; traceTc (text "About to run" <+> ppr zonked_q_expr)
; simple_expr <- runMetaD zonked_q_expr
; decls <- runMetaD convertToHsDecls zonked_q_expr
-- simple_expr :: [TH.Dec]
-- decls :: [RdrNameHsDecl]
; decls <- handleErrors (convertToHsDecls (getLoc expr) simple_expr)
; traceTc (text "Got result" <+> vcat (map ppr decls))
; showSplice "declarations"
zonked_q_expr
......@@ -359,21 +346,25 @@ tcSpliceDecls expr
%************************************************************************
\begin{code}
runMetaE :: LHsExpr Id -- Of type (Q Exp)
-> TcM TH.Exp -- Of type Exp
runMetaE e = runMeta e
runMetaT :: LHsExpr Id -- Of type (Q Type)
-> TcM TH.Type -- Of type Type
runMetaT e = runMeta e
runMetaD :: LHsExpr Id -- Of type Q [Dec]
-> TcM [TH.Dec] -- Of type [Dec]
runMetaD e = runMeta e
runMeta :: LHsExpr Id -- Of type X
-> TcM t -- Of type t
runMeta expr
runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
-> LHsExpr Id -- Of type (Q Exp)
-> TcM (LHsExpr RdrName)
runMetaE = runMeta
runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
-> LHsExpr Id -- Of type (Q Type)
-> TcM (LHsType RdrName)
runMetaT = runMeta
runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
-> LHsExpr Id -- Of type Q [Dec]
-> TcM [LHsDecl RdrName]
runMetaD = runMeta
runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
-> LHsExpr Id -- Of type X
-> TcM hs_syn -- Of type t
runMeta convert expr
= do { hsc_env <- getTopEnv
; tcg_env <- getGblEnv
; this_mod <- getModule
......@@ -392,11 +383,21 @@ runMeta expr
{ -- Coerce it to Q t, and run it
-- Running might fail if it throws an exception of any kind (hence tryAllM)
-- including, say, a pattern-match exception in the code we are running
either_tval <- tryAllM (TH.runQ (unsafeCoerce# hval))
--
-- We also do the TH -> HS syntax conversion inside the same
-- exception-cacthing thing so that if there are any lurking
-- exceptions in the data structure returned by hval, we'll
-- encounter them inside the tryALlM
either_tval <- tryAllM $ do
{ th_syn <- TH.runQ (unsafeCoerce# hval)
; case convert (getLoc expr) th_syn of
Left err -> do { addErrTc err; return Nothing }
Right hs_syn -> return (Just hs_syn) }
; case either_tval of
Left exn -> failWithTc (mk_msg "run" exn)
Right v -> returnM v
Right (Just v) -> return v
Right Nothing -> failM -- Error already in Tc monad
Left exn -> failWithTc (mk_msg "run" exn) -- Exception
}}}
where
mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment