\begin{code}
-module Convert( convertToHsExpr, convertToHsDecls, convertToHsType ) where
+module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where
#include "HsVersions.h"
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 qualified Class (FunDep)
+import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName )
import Name ( mkInternalName )
+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 ErrUtils (Message)
-import GLAEXTS ( Int#, Int(..) )
+import GLAEXTS ( Int(..), Int# )
+import SrcLoc ( noSrcLoc )
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) = noLoc $ HsBangTy HsNoBang (cvtType ty)
+ mk_arg (NotStrict, ty) = cvtType ty
mk_id_arg (i, IsStrict, ty)
= (noLoc (vName i), noLoc $ HsBangTy HsStrict (cvtType ty))
mk_id_arg (i, NotStrict, ty)
- = (noLoc (vName i), noLoc $ HsBangTy HsNoBang (cvtType ty))
+ = (noLoc (vName i), cvtType ty)
mk_derivs [] = Nothing
mk_derivs cs = Just [noLoc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
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
cvt (AppE x y) = HsApp (cvtl x) (cvtl y)
cvt (LamE ps e) = HsLam (mkMatchGroup [mkSimpleMatch (map cvtlp ps) (cvtl e)])
-cvt (TupE [e]) = cvt e
-cvt (TupE es) = ExplicitTuple(map cvtl es) Boxed
+cvt (TupE [e]) = cvt e
+cvt (TupE es) = ExplicitTuple(map cvtl es) Boxed
cvt (CondE x y z) = HsIf (cvtl x) (cvtl y) (cvtl z)
-cvt (LetE ds e) = HsLet (cvtdecs ds) (cvtl e)
+cvt (LetE ds e) = HsLet (cvtdecs ds) (cvtl e)
cvt (CaseE e ms) = HsCase (cvtl e) (mkMatchGroup (map cvtm ms))
-cvt (DoE ss) = HsDo DoExpr (cvtstmts ss) [] void
-cvt (CompE ss) = HsDo ListComp (cvtstmts ss) [] void
-cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd)
-cvt (ListE xs) = ExplicitList void (map cvtl xs)
+cvt (DoE ss) = cvtHsDo DoExpr ss
+cvt (CompE ss) = cvtHsDo ListComp ss
+cvt (ArithSeqE dd) = ArithSeq noPostTcExpr (cvtdd dd)
+cvt (ListE xs) = ExplicitList void (map cvtl xs)
cvt (InfixE (Just x) s (Just y))
= HsPar (noLoc $ OpApp (cvtl x) (cvtl s) undefined (cvtl y))
cvt (InfixE Nothing s (Just y)) = SectionR (cvtl s) (cvtl y)
cvt (InfixE (Just x) s Nothing ) = SectionL (cvtl x) (cvtl s)
cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
cvt (SigE e t) = ExprWithTySig (cvtl e) (cvtType t)
-cvt (RecConE c flds) = RecordCon (noLoc (cName c)) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
+cvt (RecConE c flds) = RecordCon (noLoc (cName c)) noPostTcExpr
+ (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
cvt (RecUpdE e flds) = RecordUpd (cvtl e) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds)
+ placeHolderType placeHolderType
+
+cvtHsDo do_or_lc stmts
+ = HsDo do_or_lc (init stmts') body void
+ where
+ stmts' = cvtstmts stmts
+ body = case last stmts' of
+ L _ (ExprStmt body _ _) -> body
cvtdecs :: [TH.Dec] -> [HsBindGroup RdrName]
cvtdecs [] = []
cvtstmts :: [TH.Stmt] -> [Hs.LStmt RdrName]
-cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt
-cvtstmts [NoBindS e] = [nlResultStmt (cvtl e)] -- when its the last element use ResultStmt
-cvtstmts (NoBindS e : ss) = nlExprStmt (cvtl e) : cvtstmts ss
-cvtstmts (TH.BindS p e : ss) = nlBindStmt (cvtlp p) (cvtl e) : cvtstmts ss
-cvtstmts (TH.LetS ds : ss) = nlLetStmt (cvtdecs ds) : cvtstmts ss
-cvtstmts (TH.ParS dss : ss) = nlParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss
+cvtstmts [] = []
+cvtstmts (NoBindS e : ss) = noLoc (mkExprStmt (cvtl e)) : cvtstmts ss
+cvtstmts (TH.BindS p e : ss) = noLoc (mkBindStmt (cvtlp p) (cvtl e)) : cvtstmts ss
+cvtstmts (TH.LetS ds : ss) = noLoc (LetStmt (cvtdecs ds)) : cvtstmts ss
+cvtstmts (TH.ParS dss : ss) = noLoc (ParStmt [(cvtstmts ds, undefined) | ds <- dss]) : cvtstmts ss
cvtm :: TH.Match -> Hs.LMatch RdrName
cvtm (TH.Match p body wheres)
cvtguard :: TH.Body -> [LGRHS RdrName]
cvtguard (GuardedB pairs) = map cvtpair pairs
-cvtguard (NormalB e) = [noLoc (GRHS [ nlResultStmt (cvtl e) ])]
+cvtguard (NormalB e) = [noLoc (GRHS [] (cvtl e))]
cvtpair :: (TH.Guard,TH.Exp) -> LGRHS RdrName
-cvtpair (NormalG x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x),
- nlResultStmt (cvtl y)])
-cvtpair (PatG x,y) = noLoc (GRHS (cvtstmts x ++ [nlResultStmt (cvtl y)]))
+cvtpair (NormalG x,y) = noLoc (GRHS [noLoc $ mkBindStmt truePat (cvtl x)]
+ (cvtl y))
+cvtpair (PatG x,y) = noLoc (GRHS (cvtstmts x) (cvtl y))
-cvtOverLit :: Lit -> HsOverLit
+cvtOverLit :: Lit -> HsOverLit RdrName
cvtOverLit (IntegerL i) = mkHsIntegral i
cvtOverLit (RationalL r) = mkHsFractional r
-- An Integer is like an an (overloaded) '3' in a Haskell source program
cvtp :: TH.Pat -> Hs.Pat RdrName
cvtp (TH.LitP l)
- | overloadedLit l = NPatIn (cvtOverLit l) Nothing -- Not right for negative
+ | overloadedLit l = mkNPat (cvtOverLit l) Nothing -- Not right for negative
-- patterns; need to think
-- about that!
| otherwise = Hs.LitPat (cvtLit l)
-- 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)
+-- 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
+ -- 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
+
+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))
-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
--- so we know whether to generate a qualified or unqualified name
--- It's a bit tricky because we need to parse
--- Foo.Baz.x as Qual Foo.Baz x
--- So we parse it from back to front
-
-mkDynName ns th_occ
- = split [] (reverse (TH.occString th_occ))
- where
- split occ [] = mkRdrUnqual (mk_occ occ)
- split occ ('.':rev) = mkRdrQual (mk_mod (reverse rev)) (mk_occ occ)
- split occ (c:rev) = split (c:occ) rev
-
- mk_occ occ = OccName.mkOccFS ns (mkFastString occ)
- mk_mod mod = mkModuleName mod
+mk_uniq :: Int# -> Unique
+mk_uniq u = mkUniqueGrimily (I# u)
\end{code}
projects / ghc-hetmet.git / blobdiff