compiler/hsSyn/Convert.lhs

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