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)
 189   = do  { i' <- vNameL i
 190         ; ty' <- cvt_arg (str,ty)
 191         ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
 192
 193 cvtDerivs [] = return Nothing
 194 cvtDerivs cs = do { cs' <- mapM cvt_one cs
 195                   ; return (Just cs') }
 196         where
 197           cvt_one c = do { c' <- tconName c
 198                          ; returnL $ HsPredTy $ HsClassP c' [] }
 199
 200 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
 201 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
 202
 203 noExistentials = []
 204
 205 ------------------------------------------
 206 --      Foreign declarations
 207 ------------------------------------------
 208
 209 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 210 cvtForD (ImportF callconv safety from nm ty)
 211   | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
 212   = do  { nm' <- vNameL nm
 213         ; ty' <- cvtType ty
 214         ; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis
 215         ; return $ ForeignImport nm' ty' i }
 216
 217   | otherwise
 218   = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent")
 219   where
 220     safety' = case safety of
 221                      Unsafe     -> PlayRisky
 222                      Safe       -> PlaySafe False
 223                      Threadsafe -> PlaySafe True
 224
 225 cvtForD (ExportF callconv as nm ty)
 226   = do  { nm' <- vNameL nm
 227         ; ty' <- cvtType ty
 228         ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
 229         ; return $ ForeignExport nm' ty' e }
 230
 231 cvt_conv TH.CCall   = CCallConv
 232 cvt_conv TH.StdCall = StdCallConv
 233
 234 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 235 parse_ccall_impent nm s
 236  = case lex_ccall_impent s of
 237        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
 238        Just ["wrapper"] -> Just (nilFS, CWrapper)
 239        Just ("static":ts) -> parse_ccall_impent_static nm ts
 240        Just ts -> parse_ccall_impent_static nm ts
 241        Nothing -> Nothing
 242
 243 parse_ccall_impent_static :: String
 244                           -> [String]
 245                           -> Maybe (FastString, CImportSpec)
 246 parse_ccall_impent_static nm ts
 247  = let ts' = case ts of
 248                  [       "&", cid] -> [       cid]
 249                  [fname, "&"     ] -> [fname     ]
 250                  [fname, "&", cid] -> [fname, cid]
 251                  _                 -> ts
 252    in case ts' of
 253           [       cid] | is_cid cid -> Just (nilFS,              mk_cid cid)
 254           [fname, cid] | is_cid cid -> Just (mkFastString fname, mk_cid cid)
 255           [          ]              -> Just (nilFS,              mk_cid nm)
 256           [fname     ]              -> Just (mkFastString fname, mk_cid nm)
 257           _                         -> Nothing
 258     where is_cid :: String -> Bool
 259           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
 260           mk_cid :: String -> CImportSpec
 261           mk_cid  = CFunction . StaticTarget . mkFastString
 262
 263 lex_ccall_impent :: String -> Maybe [String]
 264 lex_ccall_impent "" = Just []
 265 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
 266 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
 267 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
 268 lex_ccall_impent xs = case span is_valid xs of
 269                           ("", _) -> Nothing
 270                           (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
 271     where is_valid :: Char -> Bool
 272           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
 273
 274
 275 ---------------------------------------------------
 276 --              Declarations
 277 ---------------------------------------------------
 278
 279 cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName)
 280 cvtDecs [] = return EmptyLocalBinds
 281 cvtDecs ds = do { (binds,sigs) <- cvtBindsAndSigs ds
 282                 ; return (HsValBinds (ValBindsIn binds sigs)) }
 283
 284 cvtBindsAndSigs ds
 285   = do { binds' <- mapM cvtBind binds; sigs' <- mapM cvtSig sigs
 286        ; return (listToBag binds', sigs') }
 287   where
 288     (sigs, binds) = partition is_sig ds
 289
 290     is_sig (TH.SigD _ _) = True
 291     is_sig other         = False
 292
 293 cvtSig (TH.SigD nm ty)
 294   = do { nm' <- vNameL nm; ty' <- cvtType ty; returnL (Hs.TypeSig nm' ty') }
 295
 296 cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
 297 -- Used only for declarations in a 'let/where' clause,
 298 -- not for top level decls
 299 cvtBind (TH.ValD (TH.VarP s) body ds)
 300   = do  { s' <- vNameL s
 301         ; cl' <- cvtClause (Clause [] body ds)
 302         ; returnL $ mkFunBind s' [cl'] }
 303
 304 cvtBind (TH.FunD nm cls)
 305   = do  { nm' <- vNameL nm
 306         ; cls' <- mapM cvtClause cls
 307         ; returnL $ mkFunBind nm' cls' }
 308
 309 cvtBind (TH.ValD p body ds)
 310   = do  { p' <- cvtPat p
 311         ; g' <- cvtGuard body
 312         ; ds' <- cvtDecs ds
 313         ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds',
 314                               pat_rhs_ty = void, bind_fvs = placeHolderNames } }
 315
 316 cvtBind d
 317   = failWith (sep [ptext SLIT("Illegal kind of declaration in where clause"),
 318                    nest 2 (text (TH.pprint d))])
 319
 320 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
 321 cvtClause (Clause ps body wheres)
 322   = do  { ps' <- cvtPats ps
 323         ; g'  <- cvtGuard body
 324         ; ds' <- cvtDecs wheres
 325         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
 326
 327
 328 -------------------------------------------------------------------
 329 --              Expressions
 330 -------------------------------------------------------------------
 331
 332 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
 333 cvtl e = wrapL (cvt e)
 334   where
 335     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
 336     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
 337     cvt (LitE l)
 338       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
 339       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
 340
 341     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
 342     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
 343                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
 344     cvt (TupE [e])     = cvt e
 345     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
 346     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
 347                             ; return $ HsIf x' y' z' }
 348     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
 349     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
 350                             ; return $ HsCase e' (mkMatchGroup ms') }
 351     cvt (DoE ss)       = cvtHsDo DoExpr ss
 352     cvt (CompE ss)     = cvtHsDo ListComp ss
 353     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
 354     cvt (ListE xs)     = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
 355     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
 356                                           ; e' <- returnL $ OpApp x' s' undefined y'
 357                                           ; return $ HsPar e' }
 358     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
 359                                           ; return $ SectionR s' y' }
 360     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
 361                                           ; return $ SectionL x' s' }
 362     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 363
 364     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
 365                               ; return $ ExprWithTySig e' t' }
 366     cvt (RecConE c flds) = do { c' <- cNameL c
 367                               ; flds' <- mapM cvtFld flds
 368                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
 369     cvt (RecUpdE e flds) = do { e' <- cvtl e
 370                               ; flds' <- mapM cvtFld flds
 371                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
 372
 373 cvtFld (v,e)
 374   = do  { v' <- vNameL v; e' <- cvtl e
 375         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
 376
 377 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 378 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
 379 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
 380 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 381 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 382
 383 -------------------------------------
 384 --      Do notation and statements
 385 -------------------------------------
 386
 387 cvtHsDo do_or_lc stmts
 388   = do  { stmts' <- cvtStmts stmts
 389         ; let body = case last stmts' of
 390                         L _ (ExprStmt body _ _) -> body
 391         ; return $ HsDo do_or_lc (init stmts') body void }
 392
 393 cvtStmts = mapM cvtStmt
 394
 395 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
 396 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 397 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 398 cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
 399 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
 400                        where
 401                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 402
 403 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 404 cvtMatch (TH.Match p body decs)
 405   = do  { p' <- cvtPat p
 406         ; g' <- cvtGuard body
 407         ; decs' <- cvtDecs decs
 408         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
 409
 410 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
 411 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 412 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
 413
 414 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
 415 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 416                               ; g' <- returnL $ mkBindStmt truePat ge'
 417                               ; returnL $ GRHS [g'] rhs' }
 418 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 419                               ; returnL $ GRHS gs' rhs' }
 420
 421 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 422 cvtOverLit (IntegerL i)  = do { force i; return $ mkHsIntegral i }
 423 cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r }
 424 cvtOverLit (StringL s)   = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' }
 425 -- An Integer is like an an (overloaded) '3' in a Haskell source program
 426 -- Similarly 3.5 for fractionals
 427
 428 cvtLit :: Lit -> CvtM HsLit
 429 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 430 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 431 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 432 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 433 cvtLit (StringL s)     = do { let { s' = mkFastString s }; force s'; return $ HsString s' }
 434
 435 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 436 cvtPats pats = mapM cvtPat pats
 437
 438 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 439 cvtPat pat = wrapL (cvtp pat)
 440
 441 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 442 cvtp (TH.LitP l)
 443   | overloadedLit l   = do { l' <- cvtOverLit l
 444                            ; return (mkNPat l' Nothing) }
 445                                   -- Not right for negative patterns;
 446                                   -- need to think about that!
 447   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 448 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 449 cvtp (TupP [p])       = cvtp p
 450 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 451 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 452 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 453                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 454 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 455 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 456 cvtp TH.WildP         = return $ WildPat void
 457 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 458                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 459 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 460 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 461
 462 cvtPatFld (s,p)
 463   = do  { s' <- vNameL s; p' <- cvtPat p
 464         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 465
 466 -----------------------------------------------------------
 467 --      Types and type variables
 468
 469 cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName]
 470 cvtTvs tvs = mapM cvt_tv tvs
 471
 472 cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }
 473
 474 cvtContext :: Cxt -> CvtM (LHsContext RdrName)
 475 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 476
 477 cvtPred :: TH.Type -> CvtM (LHsPred RdrName)
 478 cvtPred ty
 479   = do  { (head, tys') <- split_ty_app ty
 480         ; case head of
 481             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 482             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 483             other   -> failWith (ptext SLIT("Malformed predicate") <+> text (TH.pprint ty)) }
 484
 485 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 486 cvtType ty = do { (head, tys') <- split_ty_app ty
 487                 ; case head of
 488                     TupleT n | length tys' == n -> returnL (HsTupleTy Boxed tys')
 489                              | n == 0    -> mk_apps (HsTyVar (getRdrName unitTyCon)) tys'
 490                              | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 491                     ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 492                     ListT  | [x']    <- tys' -> returnL (HsListTy x')
 493                     VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 494                     ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 495
 496                     ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs
 497                                                          ; cxt' <- cvtContext cxt
 498                                                          ; ty'  <- cvtType ty
 499                                                          ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' }
 500                     otherwise -> failWith (ptext SLIT("Malformed type") <+> text (show ty))
 501              }
 502   where
 503     mk_apps head []       = returnL head
 504     mk_apps head (ty:tys) = do { head' <- returnL head; mk_apps (HsAppTy head' ty) tys }
 505
 506 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 507 split_ty_app ty = go ty []
 508   where
 509     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 510     go f as           = return (f,as)
 511
 512 -----------------------------------------------------------
 513
 514
 515 -----------------------------------------------------------
 516 -- some useful things
 517
 518 truePat  = nlConPat (getRdrName trueDataCon)  []
 519
 520 overloadedLit :: Lit -> Bool
 521 -- True for literals that Haskell treats as overloaded
 522 overloadedLit (IntegerL  l) = True
 523 overloadedLit (RationalL l) = True
 524 overloadedLit l             = False
 525
 526 void :: Type.Type
 527 void = placeHolderType
 528
 529 --------------------------------------------------------------------
 530 --      Turning Name back into RdrName
 531 --------------------------------------------------------------------
 532
 533 -- variable names
 534 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 535 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 536
 537 vNameL n = wrapL (vName n)
 538 vName n = cvtName OccName.varName n
 539
 540 -- Constructor function names; this is Haskell source, hence srcDataName
 541 cNameL n = wrapL (cName n)
 542 cName n = cvtName OccName.dataName n
 543
 544 -- Type variable names
 545 tName n = cvtName OccName.tvName n
 546
 547 -- Type Constructor names
 548 tconNameL n = wrapL (tconName n)
 549 tconName n = cvtName OccName.tcClsName n
 550
 551 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 552 cvtName ctxt_ns (TH.Name occ flavour)
 553   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 554   | otherwise                   = force (thRdrName ctxt_ns occ_str flavour)
 555   where
 556     occ_str = TH.occString occ
 557
 558 okOcc :: OccName.NameSpace -> String -> Bool
 559 okOcc _  []      = False
 560 okOcc ns str@(c:_)
 561   | OccName.isVarName ns = startsVarId c || startsVarSym c
 562   | otherwise            = startsConId c || startsConSym c || str == "[]"
 563
 564 badOcc :: OccName.NameSpace -> String -> SDoc
 565 badOcc ctxt_ns occ
 566   = ptext SLIT("Illegal") <+> pprNameSpace ctxt_ns
 567         <+> ptext SLIT("name:") <+> quotes (text occ)
 568
 569 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 570 -- This turns a Name into a RdrName
 571 -- The passed-in name space tells what the context is expecting;
 572 --      use it unless the TH name knows what name-space it comes
 573 --      from, in which case use the latter
 574 --
 575 -- ToDo: we may generate silly RdrNames, by passing a name space
 576 --       that doesn't match the string, like VarName ":+",
 577 --       which will give confusing error messages later
 578 --
 579 -- The strict applications ensure that any buried exceptions get forced
 580 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)
 581 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 582 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 583 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 584 thRdrName ctxt_ns occ TH.NameS
 585   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 586   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 587
 588 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 589 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 590 -- We must generate an Exact name, just as the parser does
 591 isBuiltInOcc ctxt_ns occ
 592   = case occ of
 593         ":"              -> Just (Name.getName consDataCon)
 594         "[]"             -> Just (Name.getName nilDataCon)
 595         "()"             -> Just (tup_name 0)
 596         '(' : ',' : rest -> go_tuple 2 rest
 597         other            -> Nothing
 598   where
 599     go_tuple n ")"          = Just (tup_name n)
 600     go_tuple n (',' : rest) = go_tuple (n+1) rest
 601     go_tuple n other        = Nothing
 602
 603     tup_name n
 604         | OccName.isTcClsName ctxt_ns = Name.getName (tupleTyCon Boxed n)
 605         | otherwise                   = Name.getName (tupleCon Boxed n)
 606
 607 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 608 mk_uniq_occ ns occ uniq
 609   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 610         -- The idea here is to make a name that
 611         -- a) the user could not possibly write, and
 612         -- b) cannot clash with another NameU
 613         -- Previously I generated an Exact RdrName with mkInternalName.
 614         -- This works fine for local binders, but does not work at all for
 615         -- top-level binders, which must have External Names, since they are
 616         -- rapidly baked into data constructors and the like.  Baling out
 617         -- and generating an unqualified RdrName here is the simple solution
 618
 619 -- The packing and unpacking is rather turgid :-(
 620 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 621 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 622
 623 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 624 mk_ghc_ns TH.DataName  = OccName.dataName
 625 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 626 mk_ghc_ns TH.VarName   = OccName.varName
 627
 628 mk_mod :: TH.ModName -> ModuleName
 629 mk_mod mod = mkModuleName (TH.modString mod)
 630
 631 mk_pkg :: TH.ModName -> PackageId
 632 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 633
 634 mk_uniq :: Int# -> Unique
 635 mk_uniq u = mkUniqueGrimily (I# u)
 636 \end{code}
 637