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, thRdrName ) 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                                           ; return $ SectionR s' y' }
 392     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
 393                                           ; return $ SectionL x' s' }
 394     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 395
 396     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
 397                               ; return $ ExprWithTySig e' t' }
 398     cvt (RecConE c flds) = do { c' <- cNameL c
 399                               ; flds' <- mapM cvtFld flds
 400                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
 401     cvt (RecUpdE e flds) = do { e' <- cvtl e
 402                               ; flds' <- mapM cvtFld flds
 403                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
 404
 405 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
 406 cvtFld (v,e)
 407   = do  { v' <- vNameL v; e' <- cvtl e
 408         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
 409
 410 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 411 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
 412 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
 413 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 414 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 415
 416 -------------------------------------
 417 --      Do notation and statements
 418 -------------------------------------
 419
 420 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
 421 cvtHsDo do_or_lc stmts
 422   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
 423   | otherwise
 424   = do  { stmts' <- cvtStmts stmts
 425         ; let body = case last stmts' of
 426                         L _ (ExprStmt body _ _) -> body
 427         ; return $ HsDo do_or_lc (init stmts') body void }
 428
 429 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
 430 cvtStmts = mapM cvtStmt
 431
 432 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
 433 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 434 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 435 cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
 436 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
 437                        where
 438                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 439
 440 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 441 cvtMatch (TH.Match p body decs)
 442   = do  { p' <- cvtPat p
 443         ; g' <- cvtGuard body
 444         ; decs' <- cvtDecs decs
 445         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
 446
 447 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
 448 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 449 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
 450
 451 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
 452 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 453                               ; g' <- returnL $ mkExprStmt ge'
 454                               ; returnL $ GRHS [g'] rhs' }
 455 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 456                               ; returnL $ GRHS gs' rhs' }
 457
 458 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 459 cvtOverLit (IntegerL i)  = do { force i; return $ mkHsIntegral i placeHolderType}
 460 cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r placeHolderType}
 461 cvtOverLit (StringL s)   = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' placeHolderType }
 462 -- An Integer is like an an (overloaded) '3' in a Haskell source program
 463 -- Similarly 3.5 for fractionals
 464
 465 cvtLit :: Lit -> CvtM HsLit
 466 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 467 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
 468 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 469 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 470 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 471 cvtLit (StringL s)     = do { let { s' = mkFastString s }; force s'; return $ HsString s' }
 472
 473 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 474 cvtPats pats = mapM cvtPat pats
 475
 476 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 477 cvtPat pat = wrapL (cvtp pat)
 478
 479 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 480 cvtp (TH.LitP l)
 481   | overloadedLit l   = do { l' <- cvtOverLit l
 482                            ; return (mkNPat l' Nothing) }
 483                                   -- Not right for negative patterns;
 484                                   -- need to think about that!
 485   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 486 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 487 cvtp (TupP [p])       = cvtp p
 488 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 489 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 490 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 491                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 492 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 493 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 494 cvtp TH.WildP         = return $ WildPat void
 495 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 496                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 497 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 498 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 499
 500 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 501 cvtPatFld (s,p)
 502   = do  { s' <- vNameL s; p' <- cvtPat p
 503         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 504
 505 -----------------------------------------------------------
 506 --      Types and type variables
 507
 508 cvtTvs :: [TH.Name] -> CvtM [LHsTyVarBndr RdrName]
 509 cvtTvs tvs = mapM cvt_tv tvs
 510
 511 cvt_tv :: TH.Name -> CvtM (LHsTyVarBndr RdrName)
 512 cvt_tv tv = do { tv' <- tName tv; returnL $ UserTyVar tv' }
 513
 514 cvtContext :: Cxt -> CvtM (LHsContext RdrName)
 515 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 516
 517 cvtPred :: TH.Type -> CvtM (LHsPred RdrName)
 518 cvtPred ty
 519   = do  { (head, tys') <- split_ty_app ty
 520         ; case head of
 521             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 522             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 523             _       -> failWith (ptext (sLit "Malformed predicate") <+> text (TH.pprint ty)) }
 524
 525 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 526 cvtType ty = do { (head_ty, tys') <- split_ty_app ty
 527                 ; case head_ty of
 528                     TupleT n | length tys' == n         -- Saturated
 529                              -> if n==1 then return (head tys') -- Singleton tuples treated
 530                                                                 -- like nothing (ie just parens)
 531                                         else returnL (HsTupleTy Boxed tys')
 532                              | n == 1    -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 533                              | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 534                     ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 535                     ListT  | [x']    <- tys' -> returnL (HsListTy x')
 536                     VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 537                     ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 538
 539                     ForallT tvs cxt ty | null tys' -> do { tvs' <- cvtTvs tvs
 540                                                          ; cxt' <- cvtContext cxt
 541                                                          ; ty'  <- cvtType ty
 542                                                          ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' }
 543                     _       -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 544              }
 545   where
 546     mk_apps head_ty []       = returnL head_ty
 547     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
 548                                   ; mk_apps (HsAppTy head_ty' ty) tys }
 549
 550 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 551 split_ty_app ty = go ty []
 552   where
 553     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 554     go f as           = return (f,as)
 555
 556 -----------------------------------------------------------
 557
 558
 559 -----------------------------------------------------------
 560 -- some useful things
 561
 562 overloadedLit :: Lit -> Bool
 563 -- True for literals that Haskell treats as overloaded
 564 overloadedLit (IntegerL  _) = True
 565 overloadedLit (RationalL _) = True
 566 overloadedLit _             = False
 567
 568 void :: Type.Type
 569 void = placeHolderType
 570
 571 --------------------------------------------------------------------
 572 --      Turning Name back into RdrName
 573 --------------------------------------------------------------------
 574
 575 -- variable names
 576 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 577 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 578
 579 vNameL n = wrapL (vName n)
 580 vName n = cvtName OccName.varName n
 581
 582 -- Constructor function names; this is Haskell source, hence srcDataName
 583 cNameL n = wrapL (cName n)
 584 cName n = cvtName OccName.dataName n
 585
 586 -- Type variable names
 587 tName n = cvtName OccName.tvName n
 588
 589 -- Type Constructor names
 590 tconNameL n = wrapL (tconName n)
 591 tconName n = cvtName OccName.tcClsName n
 592
 593 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 594 cvtName ctxt_ns (TH.Name occ flavour)
 595   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 596   | otherwise                   = force (thRdrName ctxt_ns occ_str flavour)
 597   where
 598     occ_str = TH.occString occ
 599
 600 okOcc :: OccName.NameSpace -> String -> Bool
 601 okOcc _  []      = False
 602 okOcc ns str@(c:_)
 603   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
 604   | otherwise                 = startsConId c || startsConSym c || str == "[]"
 605
 606 badOcc :: OccName.NameSpace -> String -> SDoc
 607 badOcc ctxt_ns occ
 608   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
 609         <+> ptext (sLit "name:") <+> quotes (text occ)
 610
 611 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 612 -- This turns a Name into a RdrName
 613 -- The passed-in name space tells what the context is expecting;
 614 --      use it unless the TH name knows what name-space it comes
 615 --      from, in which case use the latter
 616 --
 617 -- ToDo: we may generate silly RdrNames, by passing a name space
 618 --       that doesn't match the string, like VarName ":+",
 619 --       which will give confusing error messages later
 620 --
 621 -- The strict applications ensure that any buried exceptions get forced
 622 thRdrName _       occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 623 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 624 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 625 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 626 thRdrName ctxt_ns occ TH.NameS
 627   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 628   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 629
 630 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 631 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 632 -- We must generate an Exact name, just as the parser does
 633 isBuiltInOcc ctxt_ns occ
 634   = case occ of
 635         ":"              -> Just (Name.getName consDataCon)
 636         "[]"             -> Just (Name.getName nilDataCon)
 637         "()"             -> Just (tup_name 0)
 638         '(' : ',' : rest -> go_tuple 2 rest
 639         _                -> Nothing
 640   where
 641     go_tuple n ")"          = Just (tup_name n)
 642     go_tuple n (',' : rest) = go_tuple (n+1) rest
 643     go_tuple _ _            = Nothing
 644
 645     tup_name n
 646         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
 647         | otherwise                        = Name.getName (tupleCon Boxed n)
 648
 649 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 650 mk_uniq_occ ns occ uniq
 651   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 652         -- The idea here is to make a name that
 653         -- a) the user could not possibly write, and
 654         -- b) cannot clash with another NameU
 655         -- Previously I generated an Exact RdrName with mkInternalName.
 656         -- This works fine for local binders, but does not work at all for
 657         -- top-level binders, which must have External Names, since they are
 658         -- rapidly baked into data constructors and the like.  Baling out
 659         -- and generating an unqualified RdrName here is the simple solution
 660
 661 -- The packing and unpacking is rather turgid :-(
 662 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 663 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 664
 665 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 666 mk_ghc_ns TH.DataName  = OccName.dataName
 667 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 668 mk_ghc_ns TH.VarName   = OccName.varName
 669
 670 mk_mod :: TH.ModName -> ModuleName
 671 mk_mod mod = mkModuleName (TH.modString mod)
 672
 673 mk_pkg :: TH.ModName -> PackageId
 674 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 675
 676 mk_uniq :: Int# -> Unique
 677 mk_uniq u = mkUniqueGrimily (I# u)
 678 \end{code}
 679