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