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