Commit bd0d2652 authored by simonpj's avatar simonpj
Browse files

[project @ 2005-01-31 15:48:13 by simonpj]

---------------------------
	Some Template Haskell fixes
	---------------------------

* Tidy up conversion from TH.Name to RdrName.RdrName. It was partly
  duplicated between Convert.thRdrName and TcSplice.lookupThName.
  Now it's all in one place: Convert.thRdrName

* Fix a bug in TH.tupleTypeName/TH.tupleDataName (GHC.Tuple -> Data.Tuple)

* Export appEs from Language.Haskell.TH
parent 34fa81c4
......@@ -6,7 +6,7 @@ This module converts Template Haskell syntax into HsSyn
\begin{code}
module Convert( convertToHsExpr, convertToHsDecls, convertToHsType ) where
module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where
#include "HsVersions.h"
......@@ -404,15 +404,18 @@ tconName = thRdrName OccName.tcName
thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
-- This turns a Name into a RdrName
thRdrName ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameQ mod)) = mkRdrQual (mk_mod mod) (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameL uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
thRdrName ns (TH.Name occ (TH.NameU uniq))
= mkRdrUnqual (OccName.mkOccName ns uniq_str)
where
uniq_str = TH.occString occ ++ '[' : shows (mk_uniq uniq) "]"
-- The passed-in name space tells what the context is expecting;
-- use it unless the TH name knows what name-space it comes
-- from, in which case use the latter
thRdrName ctxt_ns (TH.Name occ (TH.NameG th_ns mod)) = mkOrig (mk_mod mod) (mk_occ (mk_ghc_ns th_ns) occ)
thRdrName ctxt_ns (TH.Name occ (TH.NameL uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ctxt_ns occ) noSrcLoc)
thRdrName ctxt_ns (TH.Name occ (TH.NameQ mod)) = mkRdrQual (mk_mod mod) (mk_occ ctxt_ns occ)
thRdrName ctxt_ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ctxt_ns occ)
thRdrName ctxt_ns (TH.Name occ (TH.NameU uniq)) = mkRdrUnqual (mk_uniq_occ ctxt_ns occ uniq)
mk_uniq_occ :: OccName.NameSpace -> TH.OccName -> Int# -> OccName.OccName
mk_uniq_occ ns occ uniq
= OccName.mkOccName ns (TH.occString occ ++ '[' : shows (mk_uniq uniq) "]")
-- The idea here is to make a name that
-- a) the user could not possibly write, and
-- b) cannot clash with another NameU
......@@ -422,6 +425,11 @@ thRdrName ns (TH.Name occ (TH.NameU uniq))
-- rapidly baked into data constructors and the like. Baling out
-- and generating an unqualified RdrName here is the simple solution
mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
mk_ghc_ns DataName = OccName.dataName
mk_ghc_ns TH.TcClsName = OccName.tcClsName
mk_ghc_ns TH.VarName = OccName.varName
-- The packing and unpacking is rather turgid :-(
mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
......
......@@ -25,8 +25,7 @@ import TcRnMonad
import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
unifyFunTys, zapToListTy, zapToTyConApp )
import BasicTypes ( isMarkedStrict )
import Inst ( InstOrigin(..),
newOverloadedLit, newMethodFromName, newIPDict,
import Inst ( newOverloadedLit, newMethodFromName, newIPDict,
newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookup, tcLookupId, checkProcLevel,
......@@ -776,7 +775,8 @@ tcId id_name -- Look up the Id and instantiate its type
-> do { checkProcLevel id proc_level
; tc_local_id id th_level }
; other -> pprPanic "tcId" (ppr id_name $$ ppr thing)
-- THis
; other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
}
where
......
......@@ -409,9 +409,10 @@ data TcTyThing
-- tycons and clases in this recursive group
instance Outputable TcTyThing where -- Debugging only
ppr (AGlobal g) = text "AGlobal" <+> ppr g
ppr (ATcId g tl pl) = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl
ppr (ATyVar tv ty) = text "ATyVar" <+> ppr tv <+> pprParendType ty
ppr (AGlobal g) = ppr g
ppr (ATcId g tl pl) = text "Identifier" <>
ifPprDebug (brackets (ppr g <> comma <> ppr tl <> comma <> ppr pl))
ppr (ATyVar tv ty) = text "Type variable" <+> quotes (ppr tv) <+> pprParendType ty
ppr (AThing k) = text "AThing" <+> ppr k
\end{code}
......
......@@ -19,10 +19,10 @@ import qualified Language.Haskell.TH.Syntax as TH
import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl,
HsType, LHsType )
import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType )
import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName )
import RnExpr ( rnLExpr )
import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe )
import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, lookupLocalRdrEnv )
import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName )
import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, lookupLocalRdrEnv, isSrcRdrName )
import RnTypes ( rnLHsType )
import TcExpr ( tcCheckRho, tcMonoExpr )
import TcHsSyn ( mkHsLet, zonkTopLExpr )
......@@ -452,44 +452,37 @@ reify th_name
; thing <- tcLookupTh name
-- ToDo: this tcLookup could fail, which would give a
-- rather unhelpful error message
; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
; reifyThing thing
}
where
ppr_ns (TH.Name _ (TH.NameG TH.DataName mod)) = text "data"
ppr_ns (TH.Name _ (TH.NameG TH.TcClsName mod)) = text "tc"
ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var"
lookupThName :: TH.Name -> TcM Name
lookupThName (TH.Name occ (TH.NameG th_ns mod))
= lookupOrig (mkModule (TH.modString mod))
(OccName.mkOccName ghc_ns (TH.occString occ))
where
ghc_ns = case th_ns of
TH.DataName -> dataName
TH.TcClsName -> tcClsName
TH.VarName -> varName
lookupThName th_name
= do { let rdr_name = thRdrName guessed_ns th_name
lookupThName (TH.Name occ (TH.NameU uniq))
= return (mkInternalName (mk_uniq uniq) (OccName.mkOccFS bogus_ns occ_fs) noSrcLoc)
where
occ_fs = mkFastString (TH.occString occ)
bogus_ns = OccName.varName -- Not yet recorded in the TH name
-- but only the unique matters
lookupThName th_name@(TH.Name occ flavour) -- NameS or NameQ
= do { let occ = OccName.mkOccFS ns occ_fs
rdr_name = case flavour of
TH.NameS -> mkRdrUnqual occ
TH.NameQ m -> mkRdrQual (mkModule (TH.modString m)) occ
-- Repeat much of lookupOccRn, becase we want
-- to report errors in a TH-relevant way
; rdr_env <- getLocalRdrEnv
; case lookupLocalRdrEnv rdr_env rdr_name of
Just name -> return name
Nothing -> do
{ mb_name <- lookupSrcOcc_maybe rdr_name
; case mb_name of
Just name -> return name ;
Nothing -> failWithTc (notInScope th_name)
}}
Just name -> return name
Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
-> lookupImportedName rdr_name
| otherwise -- Unqual, Qual
-> do {
mb_name <- lookupSrcOcc_maybe rdr_name
; case mb_name of
Just name -> return name ;
Nothing -> failWithTc (notInScope th_name) }
}
where
ns | isLexCon occ_fs = OccName.dataName
| otherwise = OccName.varName
occ_fs = mkFastString (TH.occString occ)
-- guessed_ns is the name space guessed from looking at the TH name
guessed_ns | isLexCon occ_fs = OccName.dataName
| otherwise = OccName.varName
occ_fs = mkFastString (TH.nameBase th_name)
tcLookupTh :: Name -> TcM TcTyThing
-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
......
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