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