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