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