compiler/hsSyn/Convert.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 This module converts Template Haskell syntax into HsSyn
   7
   8 \begin{code}
   9 module Convert( convertToHsExpr, convertToHsDecls,
  10                 convertToHsType, thRdrName ) where
  11
  12 #include "HsVersions.h"
  13
  14 import HsSyn as Hs
  15 import qualified Class
  16 import RdrName
  17 import qualified Name
  18 import Module
  19 import RdrHsSyn
  20 import qualified OccName
  21 import PackageConfig
  22 import OccName
  23 import SrcLoc
  24 import Type
  25 import TysWiredIn
  26 import BasicTypes
  27 import ForeignCall
  28 import Char
  29 import List
  30 import Unique
  31 import ErrUtils
  32 import Bag
  33 import FastString
  34 import Outputable
  35
  36 import Language.Haskell.TH as TH hiding (sigP)
  37 import Language.Haskell.TH.Syntax as TH
  38
  39 import GHC.Exts
  40
  41 -------------------------------------------------------------------
  42 --              The external interface
  43
  44 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
  45 convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds)
  46
  47 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
  48 convertToHsExpr loc e
  49   = case initCvt loc (cvtl e) of
  50         Left msg  -> Left (msg $$ (ptext SLIT("When converting TH expression")
  51                                     <+> text (show e)))
  52         Right res -> Right res
  53
  54 convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
  55 convertToHsType loc t = initCvt loc (cvtType t)
  56
  57
  58 -------------------------------------------------------------------
  59 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
  60         -- Push down the source location;
  61         -- Can fail, with a single error message
  62
  63 -- NB: If the conversion succeeds with (Right x), there should
  64 --     be no exception values hiding in x
  65 -- Reason: so a (head []) in TH code doesn't subsequently
  66 --         make GHC crash when it tries to walk the generated tree
  67
  68 -- Use the loc everywhere, for lack of anything better
  69 -- In particular, we want it on binding locations, so that variables bound in
  70 -- the spliced-in declarations get a location that at least relates to the splice point
  71
  72 instance Monad CvtM where
  73   return x       = CvtM $ \loc -> Right x
  74   (CvtM m) >>= k = CvtM $ \loc -> case m loc of
  75                                     Left err -> Left err
  76                                     Right v  -> unCvtM (k v) loc
  77
  78 initCvt :: SrcSpan -> CvtM a -> Either Message a
  79 initCvt loc (CvtM m) = m loc
  80
  81 force :: a -> CvtM a
  82 force a = a `seq` return a
  83
  84 failWith :: Message -> CvtM a
  85 failWith m = CvtM (\loc -> Left full_msg)
  86    where
  87      full_msg = m $$ ptext SLIT("When splicing generated code into the program")
  88
  89 returnL :: a -> CvtM (Located a)
  90 returnL x = CvtM (\loc -> Right (L loc x))
  91
  92 wrapL :: CvtM a -> CvtM (Located a)
  93 wrapL (CvtM m) = CvtM (\loc -> case m loc of
  94                           Left err -> Left err
  95                           Right v  -> Right (L loc v))
  96
  97 -------------------------------------------------------------------
  98 cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName)
  99 cvtTop d@(TH.ValD _ _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
 100 cvtTop d@(TH.FunD _ _)   = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
 101 cvtTop (TH.SigD nm typ)  = do  { nm' <- vNameL nm
 102                                 ; ty' <- cvtType typ
 103                                 ; returnL $ Hs.SigD (TypeSig nm' ty') }
 104
 105 cvtTop (TySynD tc tvs rhs)
 106   = do  { tc' <- tconNameL tc
 107         ; tvs' <- cvtTvs tvs
 108         ; rhs' <- cvtType rhs
 109         ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
 110
 111 cvtTop (DataD ctxt tc tvs constrs derivs)
 112   = do  { stuff <- cvt_tycl_hdr ctxt tc tvs
 113         ; cons' <- mapM cvtConstr constrs
 114         ; derivs' <- cvtDerivs derivs
 115         ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') }
 116
 117
 118 cvtTop (NewtypeD ctxt tc tvs constr derivs)
 119   = do  { stuff <- cvt_tycl_hdr ctxt tc tvs
 120         ; con' <- cvtConstr constr
 121         ; derivs' <- cvtDerivs derivs
 122         ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') }
 123
 124 cvtTop (ClassD ctxt cl tvs fds decs)
 125   = do  { (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
 126         ; fds'  <- mapM cvt_fundep fds
 127         ; (binds', sigs') <- cvtBindsAndSigs decs
 128         ; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] []
 129                                                     -- no ATs or docs in TH ^^ ^^
 130         }
 131
 132 cvtTop (InstanceD tys ty decs)
 133   = do  { (binds', sigs') <- cvtBindsAndSigs decs
 134         ; ctxt' <- cvtContext tys
 135         ; L loc pred' <- cvtPred ty
 136         ; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
 137         ; returnL $ InstD (InstDecl inst_ty' binds' sigs' [])
 138                                                        -- ^^no ATs in TH
 139         }
 140
 141 cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
 142
 143 cvt_tycl_hdr cxt tc tvs
 144   = do  { cxt' <- cvtContext cxt
 145         ; tc'  <- tconNameL tc
 146         ; tvs' <- cvtTvs tvs
 147         ; return (cxt', tc', tvs', Nothing) }
 148
 149 ---------------------------------------------------
 150 --      Data types
 151 -- Can't handle GADTs yet
 152 ---------------------------------------------------
 153
 154 cvtConstr (NormalC c strtys)
 155   = do  { c'   <- cNameL c
 156         ; cxt' <- returnL []
 157         ; tys' <- mapM cvt_arg strtys
 158         ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
 159
 160 cvtConstr (RecC c varstrtys)
 161   = do  { c'    <- cNameL c
 162         ; cxt'  <- returnL []
 163         ; args' <- mapM cvt_id_arg varstrtys
 164         ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
 165
 166 cvtConstr (InfixC st1 c st2)
 167   = do  { c' <- cNameL c
 168         ; cxt' <- returnL []
 169         ; st1' <- cvt_arg st1
 170         ; st2' <- cvt_arg st2
 171         ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
 172
 173 cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
 174   = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
 175
 176 cvtConstr (ForallC tvs ctxt con)
 177   = do  { L _ con' <- cvtConstr con
 178         ; tvs'  <- cvtTvs tvs
 179         ; ctxt' <- cvtContext ctxt
 180         ; case con' of
 181             ConDecl l _ [] (L _ []) x ResTyH98 _
 182               -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
 183             c -> panic "ForallC: Can't happen" }
 184
 185 cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
 186 cvt_arg (NotStrict, ty) = cvtType ty
 187
 188 cvt_id_arg (i, str, ty) = do { i' <- vNameL i
 189                              ; ty' <- cvt_arg (str,ty)
 190                              ; return (mkRecField i' ty') }
 191
 192 cvtDerivs [] = return Nothing
 193 cvtDerivs cs = do { cs' <- mapM cvt_one cs
 194                   ; return (Just cs') }
 195         where
 196           cvt_one c = do { c' <- tconName c
 197                          ; returnL $ HsPredTy $ HsClassP c' [] }
 198
 199 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
 200 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
 201
 202 noExistentials = []
 203
 204 ------------------------------------------
 205 --      Foreign declarations
 206 ------------------------------------------
 207
 208 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 209 cvtForD (ImportF callconv safety from nm ty)
 210   | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
 211   = do  { nm' <- vNameL nm
 212         ; ty' <- cvtType ty
 213         ; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis
 214         ; return $ ForeignImport nm' ty' i }
 215
 216   | otherwise
 217   = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent")
 218   where
 219     safety' = case safety of
 220                      Unsafe     -> PlayRisky
 221                      Safe       -> PlaySafe False
 222                      Threadsafe -> PlaySafe True
 223
 224 cvtForD (ExportF callconv as nm ty)
 225   = do  { nm' <- vNameL nm
 226         ; ty' <- cvtType ty
 227         ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
 228         ; return $ ForeignExport nm' ty' e }
 229
 230 cvt_conv TH.CCall   = CCallConv
 231 cvt_conv TH.StdCall = StdCallConv
 232
 233 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 234 parse_ccall_impent nm s
 235  = case lex_ccall_impent s of
 236        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
 237        Just ["wrapper"] -> Just (nilFS, CWrapper)
 238        Just ("static":ts) -> parse_ccall_impent_static nm ts
 239        Just ts -> parse_ccall_impent_static nm ts
 240        Nothing -> Nothing
 241
 242 parse_ccall_impent_static :: String
 243                           -> [String]
 244                           -> Maybe (FastString, CImportSpec)
 245 parse_ccall_impent_static nm ts
 246  = let ts' = case ts of
 247                  [       "&", cid] -> [       cid]
 248                  [fname, "&"     ] -> [fname     ]
 249                  [fname, "&", cid] -> [fname, cid]
 250                  _                 -> ts
 251    in case ts' of
 252           [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
 253           [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
 254           [          ]              -> Just (nilFS,              mk_cid nm)
 255           [fname     ]              -> Just (mkFastString fname, mk_cid nm)
 256           _                         -> Nothing
 257     where is_cid :: String -> Bool
 258           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
 259           mk_cid :: String -> CImportSpec
 260           mk_cid  = CFunction . StaticTarget . mkFastString
 261
 262 lex_ccall_impent :: String -> Maybe [String]
 263 lex_ccall_impent "" = Just []
 264 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
 265 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
 266 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
 267 lex_ccall_impent xs = case span is_valid xs of
 268                           ("", _) -> Nothing
 269                           (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
 270     where is_valid :: Char -> Bool
 271           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
 272
 273
 274 ---------------------------------------------------
 275 --              Declarations
 276 ---------------------------------------------------
 277
 278 cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName)
 279 cvtDecs [] = return EmptyLocalBinds
 280 cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds
 281                 ; return (HsValBinds (ValBindsIn binds sigs)) }
 282
 283 cvtBindsAndSigs ds
 284   = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs
 285        ; return (listToBag binds', sigs') }
 286   where
 287     (sigs, binds) = partition is_sig ds
 288
 289     is_sig (TH.SigD _ _) = True
 290     is_sig other         = False
 291
 292 cvtSig (TH.SigD nm ty)
 293   = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') }
 294
 295 cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
 296 -- Used only for declarations in a 'let/where' clause,
 297 -- not for top level decls
 298 cvtBind (TH.ValD (TH.VarP s) body ds)
 299   = do  { s' <- vNameL s
 300         ; cl' <- cvtClause (Clause [] body ds)
 301         ; returnL $ mkFunBind s' [cl'] }
 302
 303 cvtBind (TH.FunD nm cls)
 304   = do  { nm' <- vNameL nm
 305         ; cls' <- mapM cvtClause cls
 306         ; returnL $ mkFunBind nm' cls' }
 307
 308 cvtBind (TH.ValD p body ds)
 309   = do  { p' <- cvtPat p
 310         ; g' <- cvtGuard body
 311         ; ds' <- cvtDecs ds
 312         ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds',
 313                               pat_rhs_ty = void, bind_fvs = placeHolderNames } }
 314
 315 cvtBind d
 316   = failWith (sep [ptext SLIT("Illegal kind of declaration in where clause"),
 317                    nest 2 (text (TH.pprint d))])
 318
 319 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
 320 cvtClause (Clause ps body wheres)
 321   = do  { ps' <- cvtPats ps
 322         ; g'  <- cvtGuard body
 323         ; ds' <- cvtDecs wheres
 324         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
 325
 326
 327 -------------------------------------------------------------------
 328 --              Expressions
 329 -------------------------------------------------------------------
 330
 331 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
 332 cvtl e = wrapL (cvt e)
 333   where
 334     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
 335     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
 336     cvt (LitE l)
 337       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
 338       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
 339
 340     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
 341     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
 342                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
 343     cvt (TupE [e])     = cvt e
 344     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
 345     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
 346                             ; return $ HsIf x' y' z' }
 347     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
 348     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
 349                             ; return $ HsCase e' (mkMatchGroup ms') }
 350     cvt (DoE ss)       = cvtHsDo DoExpr ss
 351     cvt (CompE ss)     = cvtHsDo ListComp ss
 352     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
 353     cvt (ListE xs)     = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
 354     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
 355                                           ; e' <- returnL $ OpApp x' s' undefined y'
 356                                           ; return $ HsPar e' }
 357     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
 358                                           ; return $ SectionR s' y' }
 359     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
 360                                           ; return $ SectionL x' s' }
 361     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 362
 363     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
 364                               ; return $ ExprWithTySig e' t' }
 365     cvt (RecConE c flds) = do { c' <- cNameL c
 366                               ; flds' <- mapM cvtFld flds
 367                               ; return $ RecordCon c' noPostTcExpr flds' }
 368     cvt (RecUpdE e flds) = do { e' <- cvtl e
 369                               ; flds' <- mapM cvtFld flds
 370                               ; return $ RecordUpd e' flds' placeHolderType placeHolderType }
 371
 372 cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') }
 373
 374 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 375 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
 376 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
 377 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 378 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 379
 380 -------------------------------------
 381 --      Do notation and statements
 382 -------------------------------------
 383
 384 cvtHsDo do_or_lc stmts
 385   = do  { stmts' <- cvtStmts stmts
 386         ; let body = case last stmts' of
 387                         L _ (ExprStmt body _ _) -> body
 388         ; return $ HsDo do_or_lc (init stmts') body void }
 389
 390 cvtStmts = mapM cvtStmt
 391
 392 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
 393 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 394 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 395 cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
 396 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
 397                        where
 398                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 399
 400 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 401 cvtMatch (TH.Match p body decs)
 402   = do  { p' <- cvtPat p
 403         ; g' <- cvtGuard body
 404         ; decs' <- cvtDecs decs
 405         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
 406
 407 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
 408 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 409 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
 410
 411 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
 412 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 413                               ; g' <- returnL $ mkBindStmt truePat ge'
 414                               ; returnL $ GRHS [g'] rhs' }
 415 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 416                               ; returnL $ GRHS gs' rhs' }
 417
 418 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 419 cvtOverLit (IntegerL i)  = do { force i; return $ mkHsIntegral i }
 420 cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r }
 421 -- An Integer is like an an (overloaded) '3' in a Haskell source program
 422 -- Similarly 3.5 for fractionals
 423
 424 cvtLit :: Lit -> CvtM HsLit
 425 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 426 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 427 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 428 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 429 cvtLit (StringL s)     = do { let { s' = mkFastString s }; force s'; return $ HsString s' }
 430
 431 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 432 cvtPats pats = mapM cvtPat pats
 433
 434 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 435 cvtPat pat = wrapL (cvtp pat)
 436
 437 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 438 cvtp (TH.LitP l)
 439   | overloadedLit l   = do { l' <- cvtOverLit l
 440                            ; return (mkNPat l' Nothing) }
 441                                   -- Not right for negative patterns;
 442                                   -- need to think about that!
 443   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 444 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 445 cvtp (TupP [p])       = cvtp p
 446 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 447 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 448 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 449                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 450 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 451 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 452 cvtp TH.WildP         = return $ WildPat void
 453 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 454                            ; return $ ConPatIn c' $ Hs.RecCon fs' }
 455 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 456 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 457
 458 cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (mkRecField s' p') }
 459
 460 -----------------------------------------------------------
 461 --      Types and type variables
 462
 463 cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName]
 464 cvtTvs tvs = mapM cvt_tv tvs
 465
 466 cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }
 467
 468 cvtContext :: Cxt -> CvtM (LHsContext RdrName)
 469 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 470
 471 cvtPred :: TH.Type -> CvtM (LHsPred RdrName)
 472 cvtPred ty
 473   = do  { (head, tys') <- split_ty_app ty
 474         ; case head of
 475             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 476             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 477             other   -> failWith (ptext SLIT("Malformed predicate") <+> text (TH.pprint ty)) }
 478
 479 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 480 cvtType ty = do { (head, tys') <- split_ty_app ty
 481                 ; case head of
 482                     TupleT n | length tys' == n -> returnL (HsTupleTy Boxed tys')
 483                              | n == 0    -> mk_apps (HsTyVar (getRdrName unitTyCon)) tys'
 484                              | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 485                     ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 486                     ListT  | [x']    <- tys' -> returnL (HsListTy x')
 487                     VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 488                     ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 489
 490                     ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs
 491                                                          ; cxt' <- cvtContext cxt
 492                                                          ; ty'  <- cvtType ty
 493                                                          ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' }
 494                     otherwise -> failWith (ptext SLIT("Malformed type") <+> text (show ty))
 495              }
 496   where
 497     mk_apps head []       = returnL head
 498     mk_apps head (ty:tys) = do { head' <- returnL head; mk_apps (HsAppTy head' ty) tys }
 499
 500 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 501 split_ty_app ty = go ty []
 502   where
 503     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 504     go f as           = return (f,as)
 505
 506 -----------------------------------------------------------
 507
 508
 509 -----------------------------------------------------------
 510 -- some useful things
 511
 512 truePat  = nlConPat (getRdrName trueDataCon)  []
 513
 514 overloadedLit :: Lit -> Bool
 515 -- True for literals that Haskell treats as overloaded
 516 overloadedLit (IntegerL  l) = True
 517 overloadedLit (RationalL l) = True
 518 overloadedLit l             = False
 519
 520 void :: Type.Type
 521 void = placeHolderType
 522
 523 --------------------------------------------------------------------
 524 --      Turning Name back into RdrName
 525 --------------------------------------------------------------------
 526
 527 -- variable names
 528 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 529 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 530
 531 vNameL n = wrapL (vName n)
 532 vName n = cvtName OccName.varName n
 533
 534 -- Constructor function names; this is Haskell source, hence srcDataName
 535 cNameL n = wrapL (cName n)
 536 cName n = cvtName OccName.dataName n
 537
 538 -- Type variable names
 539 tName n = cvtName OccName.tvName n
 540
 541 -- Type Constructor names
 542 tconNameL n = wrapL (tconName n)
 543 tconName n = cvtName OccName.tcClsName n
 544
 545 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 546 cvtName ctxt_ns (TH.Name occ flavour)
 547   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 548   | otherwise                   = force (thRdrName ctxt_ns occ_str flavour)
 549   where
 550     occ_str = TH.occString occ
 551
 552 okOcc :: OccName.NameSpace -> String -> Bool
 553 okOcc _  []      = False
 554 okOcc ns str@(c:_)
 555   | OccName.isVarName ns = startsVarId c || startsVarSym c
 556   | otherwise            = startsConId c || startsConSym c || str == "[]"
 557
 558 badOcc :: OccName.NameSpace -> String -> SDoc
 559 badOcc ctxt_ns occ
 560   = ptext SLIT("Illegal") <+> pprNameSpace ctxt_ns
 561         <+> ptext SLIT("name:") <+> quotes (text occ)
 562
 563 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 564 -- This turns a Name into a RdrName
 565 -- The passed-in name space tells what the context is expecting;
 566 --      use it unless the TH name knows what name-space it comes
 567 --      from, in which case use the latter
 568 --
 569 -- ToDo: we may generate silly RdrNames, by passing a name space
 570 --       that doesn't match the string, like VarName ":+",
 571 --       which will give confusing error messages later
 572 --
 573 -- The strict applications ensure that any buried exceptions get forced
 574 thRdrName ctxt_ns occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 575 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcLoc)
 576 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 577 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 578 thRdrName ctxt_ns occ TH.NameS
 579   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 580   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 581
 582 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 583 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 584 -- We must generate an Exact name, just as the parser does
 585 isBuiltInOcc ctxt_ns occ
 586   = case occ of
 587         ":"              -> Just (Name.getName consDataCon)
 588         "[]"             -> Just (Name.getName nilDataCon)
 589         "()"             -> Just (tup_name 0)
 590         '(' : ',' : rest -> go_tuple 2 rest
 591         other            -> Nothing
 592   where
 593     go_tuple n ")"          = Just (tup_name n)
 594     go_tuple n (',' : rest) = go_tuple (n+1) rest
 595     go_tuple n other        = Nothing
 596
 597     tup_name n
 598         | OccName.isTcClsName ctxt_ns = Name.getName (tupleTyCon Boxed n)
 599         | otherwise                   = Name.getName (tupleCon Boxed n)
 600
 601 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 602 mk_uniq_occ ns occ uniq
 603   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 604         -- The idea here is to make a name that
 605         -- a) the user could not possibly write, and
 606         -- b) cannot clash with another NameU
 607         -- Previously I generated an Exact RdrName with mkInternalName.
 608         -- This works fine for local binders, but does not work at all for
 609         -- top-level binders, which must have External Names, since they are
 610         -- rapidly baked into data constructors and the like.  Baling out
 611         -- and generating an unqualified RdrName here is the simple solution
 612
 613 -- The packing and unpacking is rather turgid :-(
 614 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 615 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 616
 617 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 618 mk_ghc_ns TH.DataName  = OccName.dataName
 619 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 620 mk_ghc_ns TH.VarName   = OccName.varName
 621
 622 mk_mod :: TH.ModName -> ModuleName
 623 mk_mod mod = mkModuleName (TH.modString mod)
 624
 625 mk_pkg :: TH.ModName -> PackageId
 626 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 627
 628 mk_uniq :: Int# -> Unique
 629 mk_uniq u = mkUniqueGrimily (I# u)
 630 \end{code}
 631