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