import Language.Haskell.TH.Syntax as TH
import HsSyn as Hs
-import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName )
-import Module ( ModuleName, mkModuleName )
-import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData )
-import Name ( mkInternalName )
+import qualified Class (FunDep)
+import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName )
+import Module ( Module, mkModule )
+import RdrHsSyn ( mkClassDecl, mkTyData )
import qualified OccName
-import SrcLoc ( SrcLoc, generatedSrcLoc, noLoc, unLoc, Located(..),
- noSrcSpan, SrcSpan, srcLocSpan, noSrcLoc )
+import SrcLoc ( generatedSrcLoc, noLoc, unLoc, Located(..),
+ SrcSpan, srcLocSpan )
import Type ( Type )
-import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon, falseDataCon )
+import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon )
import BasicTypes( Boxity(..), RecFlag(Recursive) )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
CExportSpec(..))
-import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..),
- ForeignDecl(..) )
-import FastString( FastString, mkFastString, nilFS )
-import Char ( ord, isAscii, isAlphaNum, isAlpha )
+import Char ( isAscii, isAlphaNum, isAlpha )
import List ( partition )
-import Unique ( Unique, mkUniqueGrimily )
+import Unique ( mkUniqueGrimily )
import ErrUtils (Message)
-import GLAEXTS ( Int#, Int(..) )
+import GLAEXTS ( Int(..) )
import Bag ( emptyBag, consBag )
+import FastString
import Outputable
convertToHsDecls :: [TH.Dec] -> [Either (LHsDecl RdrName) Message]
convertToHsDecls ds = map cvt_ltop ds
-mk_con con = L loc0 $ case con of
+mk_con con = L loc0 $ mk_nlcon con
+ where
+ mk_nlcon con = case con of
NormalC c strtys
-> ConDecl (noLoc (cName c)) noExistentials noContext
(PrefixCon (map mk_arg strtys))
InfixC st1 c st2
-> ConDecl (noLoc (cName c)) noExistentials noContext
(InfixCon (mk_arg st1) (mk_arg st2))
- where
+ ForallC tvs ctxt (ForallC tvs' ctxt' con')
+ -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
+ ForallC tvs ctxt con' -> case mk_nlcon con' of
+ ConDecl l [] (L _ []) x ->
+ ConDecl l (cvt_tvs tvs) (cvt_context ctxt) x
+ c -> panic "ForallC: Can't happen"
mk_arg (IsStrict, ty) = noLoc $ HsBangTy HsStrict (cvtType ty)
mk_arg (NotStrict, ty) = cvtType ty
Nothing [mk_con constr]
(mk_derivs derivs))
-cvt_top (ClassD ctxt cl tvs decs)
- = Left $ TyClD (mkClassDecl (cvt_context ctxt, noLoc (tconName cl), cvt_tvs tvs)
- noFunDeps sigs
- binds)
+cvt_top (ClassD ctxt cl tvs fds decs)
+ = Left $ TyClD $ mkClassDecl (cvt_context ctxt,
+ noLoc (tconName cl),
+ cvt_tvs tvs)
+ (map (noLoc . cvt_fundep) fds)
+ sigs
+ binds
where
(binds,sigs) = cvtBindsAndSigs decs
CCall -> CCallConv
StdCall -> StdCallConv
+cvt_fundep :: FunDep -> Class.FunDep RdrName
+cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
+
parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
parse_ccall_impent nm s
= case lex_ccall_impent s of
noContext = noLoc []
noExistentials = []
-noFunDeps = []
-------------------------------------------------------------------
convertToHsExpr :: TH.Exp -> LHsExpr RdrName
-- some useful things
truePat = nlConPat (getRdrName trueDataCon) []
-falsePat = nlConPat (getRdrName falseDataCon) []
overloadedLit :: Lit -> Bool
-- True for literals that Haskell treats as overloaded
thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
-- This turns a Name into a RdrName
--- The last case is slightly interesting. It constructs a
--- unique name from the unique in the TH thingy, so that the renamer
--- won't mess about. I hope. (Another possiblity would be to generate
--- "x_77" etc, but that could conceivably clash.)
-thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
-thRdrName ns (TH.Name occ TH.NameS) = mkDynName ns occ
-thRdrName ns (TH.Name occ (TH.NameU uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
-
-mk_uniq :: Int# -> Unique
-mk_uniq u = mkUniqueGrimily (I# u)
+thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
+thRdrName ns (TH.Name occ TH.NameS) = mkDynName ns occ
+thRdrName ns (TH.Name occ (TH.NameU uniq))
+ = mkRdrUnqual (OccName.mkOccName ns uniq_str)
+ where
+ uniq_str = TH.occString occ ++ '[' : shows (mkUniqueGrimily (I# uniq)) "]"
+ -- The idea here is to make a name that
+ -- a) the user could not possibly write, and
+ -- b) cannot clash with another NameU
+ -- Previously I generated an Exact RdrName with mkInternalName.
+ -- This works fine for local binders, but does not work at all for
+ -- top-level binders, which must have External Names, since they are
+ -- rapidly baked into data constructors and the like. Baling out
+ -- and generating an unqualified RdrName here is the simple solution
-- 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))
-mk_mod :: TH.ModName -> ModuleName
-mk_mod mod = mkModuleName (TH.modString mod)
+mk_mod :: TH.ModName -> Module
+mk_mod mod = mkModule (TH.modString mod)
mkDynName :: OccName.NameSpace -> TH.OccName -> RdrName
-- Parse the string to see if it has a "." in it
split occ (c:rev) = split (c:occ) rev
mk_occ occ = OccName.mkOccFS ns (mkFastString occ)
- mk_mod mod = mkModuleName mod
+ mk_mod mod = mkModule mod
\end{code}
projects / ghc-hetmet.git / blobdiff