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