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, convertToPat, convertToHsDecls,
  10                 convertToHsType, thRdrNameGuesses ) where
  11
  12 import HsSyn as Hs
  13 import qualified Class
  14 import RdrName
  15 import qualified Name
  16 import Module
  17 import RdrHsSyn
  18 import qualified OccName
  19 import OccName
  20 import SrcLoc
  21 import Type
  22 import TysWiredIn
  23 import BasicTypes as Hs
  24 import ForeignCall
  25 import Char
  26 import List
  27 import Unique
  28 import MonadUtils
  29 import ErrUtils
  30 import Bag
  31 import FastString
  32 import Outputable
  33
  34 import Language.Haskell.TH as TH hiding (sigP)
  35 import Language.Haskell.TH.Syntax as TH
  36
  37 import GHC.Exts
  38
  39 -------------------------------------------------------------------
  40 --              The external interface
  41
  42 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
  43 convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds)
  44
  45 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
  46 convertToHsExpr loc e
  47   = case initCvt loc (cvtl e) of
  48         Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH expression:")
  49                                     <+> text (show e)))
  50         Right res -> Right res
  51
  52 convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
  53 convertToPat loc e
  54   = case initCvt loc (cvtPat e) of
  55         Left msg  -> Left (msg $$ (ptext (sLit "When splicing TH pattern:")
  56                                     <+> text (show e)))
  57         Right res -> Right res
  58
  59 convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
  60 convertToHsType loc t = initCvt loc (cvtType t)
  61
  62
  63 -------------------------------------------------------------------
  64 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
  65         -- Push down the source location;
  66         -- Can fail, with a single error message
  67
  68 -- NB: If the conversion succeeds with (Right x), there should
  69 --     be no exception values hiding in x
  70 -- Reason: so a (head []) in TH code doesn't subsequently
  71 --         make GHC crash when it tries to walk the generated tree
  72
  73 -- Use the loc everywhere, for lack of anything better
  74 -- In particular, we want it on binding locations, so that variables bound in
  75 -- the spliced-in declarations get a location that at least relates to the splice point
  76
  77 instance Monad CvtM where
  78   return x       = CvtM $ \_   -> Right x
  79   (CvtM m) >>= k = CvtM $ \loc -> case m loc of
  80                                     Left err -> Left err
  81                                     Right v  -> unCvtM (k v) loc
  82
  83 initCvt :: SrcSpan -> CvtM a -> Either Message a
  84 initCvt loc (CvtM m) = m loc
  85
  86 force :: a -> CvtM a
  87 force a = a `seq` return a
  88
  89 failWith :: Message -> CvtM a
  90 failWith m = CvtM (\_ -> Left full_msg)
  91    where
  92      full_msg = m $$ ptext (sLit "When splicing generated code into the program")
  93
  94 returnL :: a -> CvtM (Located a)
  95 returnL x = CvtM (\loc -> Right (L loc x))
  96
  97 wrapL :: CvtM a -> CvtM (Located a)
  98 wrapL (CvtM m) = CvtM (\loc -> case m loc of
  99                           Left err -> Left err
 100                           Right v  -> Right (L loc v))
 101
 102 -------------------------------------------------------------------
 103 cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName)
 104 cvtTop d@(TH.ValD _ _ _)
 105   = do { L loc d' <- cvtBind d
 106        ; return (L loc $ Hs.ValD d') }
 107
 108 cvtTop d@(TH.FunD _ _)
 109   = do { L loc d' <- cvtBind d
 110        ; return (L loc $ Hs.ValD d') }
 111
 112 cvtTop (TH.SigD nm typ)
 113   = do  { nm' <- vNameL nm
 114         ; ty' <- cvtType typ
 115         ; returnL $ Hs.SigD (TypeSig nm' ty') }
 116
 117 cvtTop (TySynD tc tvs rhs)
 118   = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
 119         ; rhs' <- cvtType rhs
 120         ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
 121
 122 cvtTop (DataD ctxt tc tvs constrs derivs)
 123   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
 124         ; cons' <- mapM cvtConstr constrs
 125         ; derivs' <- cvtDerivs derivs
 126         ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
 127                                   , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
 128                                   , tcdCons = cons', tcdDerivs = derivs' }) }
 129
 130 cvtTop (NewtypeD ctxt tc tvs constr derivs)
 131   = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
 132         ; con' <- cvtConstr constr
 133         ; derivs' <- cvtDerivs derivs
 134         ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
 135                                   , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
 136                                   , tcdCons = [con'], tcdDerivs = 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         ; let (ats, bind_sig_decs) = partition isFamilyD decs
 142         ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
 143         ; ats' <- mapM cvtTop ats
 144         ; let ats'' = map unTyClD ats'
 145         ; returnL $
 146             TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
 147                               , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
 148                               , tcdATs = ats'', tcdDocs = [] }
 149                                                         -- no docs in TH ^^
 150         }
 151   where
 152     isFamilyD (FamilyD _ _ _ _) = True
 153     isFamilyD _                 = False
 154
 155 cvtTop (InstanceD ctxt ty decs)
 156   = do  { let (ats, bind_sig_decs) = partition isFamInstD decs
 157         ; (binds', sigs') <- cvtBindsAndSigs bind_sig_decs
 158         ; ats' <- mapM cvtTop ats
 159         ; let ats'' = map unTyClD ats'
 160         ; ctxt' <- cvtContext ctxt
 161         ; L loc pred' <- cvtPredTy ty
 162         ; inst_ty' <- returnL $
 163                         mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
 164         ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats'')
 165         }
 166   where
 167     isFamInstD (DataInstD _ _ _ _ _)    = True
 168     isFamInstD (NewtypeInstD _ _ _ _ _) = True
 169     isFamInstD (TySynInstD _ _ _)       = True
 170     isFamInstD _                        = False
 171
 172 cvtTop (ForeignD ford)
 173   = do { ford' <- cvtForD ford
 174        ; returnL $ ForD ford'
 175        }
 176
 177 cvtTop (PragmaD prag)
 178   = do { prag' <- cvtPragmaD prag
 179        ; returnL $ Hs.SigD prag'
 180        }
 181
 182 cvtTop (FamilyD flav tc tvs kind)
 183   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
 184        ; let kind' = fmap cvtKind kind
 185        ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind')
 186        }
 187   where
 188     cvtFamFlavour TypeFam = TypeFamily
 189     cvtFamFlavour DataFam = DataFamily
 190
 191 cvtTop (DataInstD ctxt tc tys constrs derivs)
 192   = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
 193        ; cons' <- mapM cvtConstr constrs
 194        ; derivs' <- cvtDerivs derivs
 195        ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
 196                                   , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
 197                                   , tcdCons = cons', tcdDerivs = derivs' })
 198        }
 199
 200 cvtTop (NewtypeInstD ctxt tc tys constr derivs)
 201   = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
 202        ; con' <- cvtConstr constr
 203        ; derivs' <- cvtDerivs derivs
 204        ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
 205                                   , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
 206                                   , tcdCons = [con'], tcdDerivs = derivs' })
 207        }
 208
 209 cvtTop (TySynInstD tc tys rhs)
 210   = do  { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
 211         ; rhs' <- cvtType rhs
 212         ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
 213
 214 -- FIXME: This projection is not nice, but to remove it, cvtTop should be
 215 --        refactored.
 216 unTyClD :: LHsDecl a -> LTyClDecl a
 217 unTyClD (L l (TyClD d)) = L l d
 218 unTyClD _               = panic "Convert.unTyClD: internal error"
 219
 220 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
 221              -> CvtM ( LHsContext RdrName
 222                      , Located RdrName
 223                      , [LHsTyVarBndr RdrName])
 224 cvt_tycl_hdr cxt tc tvs
 225   = do { cxt' <- cvtContext cxt
 226        ; tc'  <- tconNameL tc
 227        ; tvs' <- cvtTvs tvs
 228        ; return (cxt', tc', tvs')
 229        }
 230
 231 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
 232                -> CvtM ( LHsContext RdrName
 233                        , Located RdrName
 234                        , [LHsTyVarBndr RdrName]
 235                        , Maybe [LHsType RdrName])
 236 cvt_tyinst_hdr cxt tc tys
 237   = do { cxt' <- cvtContext cxt
 238        ; tc'  <- tconNameL tc
 239        ; tvs  <- concatMapM collect tys
 240        ; tvs' <- cvtTvs tvs
 241        ; tys' <- mapM cvtType tys
 242        ; return (cxt', tc', tvs', Just tys')
 243        }
 244   where
 245     collect (ForallT _ _ _)
 246       = failWith $ text "Forall type not allowed as type parameter"
 247     collect (VarT tv)    = return [PlainTV tv]
 248     collect (ConT _)     = return []
 249     collect (TupleT _)   = return []
 250     collect ArrowT       = return []
 251     collect ListT        = return []
 252     collect (AppT t1 t2)
 253       = do { tvs1 <- collect t1
 254            ; tvs2 <- collect t2
 255            ; return $ tvs1 ++ tvs2
 256            }
 257     collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
 258     collect (SigT ty _)         = collect ty
 259
 260 ---------------------------------------------------
 261 --      Data types
 262 -- Can't handle GADTs yet
 263 ---------------------------------------------------
 264
 265 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
 266
 267 cvtConstr (NormalC c strtys)
 268   = do  { c'   <- cNameL c
 269         ; cxt' <- returnL []
 270         ; tys' <- mapM cvt_arg strtys
 271         ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
 272
 273 cvtConstr (RecC c varstrtys)
 274   = do  { c'    <- cNameL c
 275         ; cxt'  <- returnL []
 276         ; args' <- mapM cvt_id_arg varstrtys
 277         ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
 278
 279 cvtConstr (InfixC st1 c st2)
 280   = do  { c' <- cNameL c
 281         ; cxt' <- returnL []
 282         ; st1' <- cvt_arg st1
 283         ; st2' <- cvt_arg st2
 284         ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
 285
 286 cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
 287   = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
 288
 289 cvtConstr (ForallC tvs ctxt con)
 290   = do  { L _ con' <- cvtConstr con
 291         ; tvs'  <- cvtTvs tvs
 292         ; ctxt' <- cvtContext ctxt
 293         ; case con' of
 294             ConDecl { con_qvars = [], con_cxt = L _ [] }
 295               -> returnL $ con' { con_qvars = tvs', con_cxt = ctxt' }
 296             _ -> panic "ForallC: Can't happen" }
 297
 298 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 299 cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
 300 cvt_arg (NotStrict, ty) = cvtType ty
 301
 302 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
 303 cvt_id_arg (i, str, ty)
 304   = do  { i' <- vNameL i
 305         ; ty' <- cvt_arg (str,ty)
 306         ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
 307
 308 cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
 309 cvtDerivs [] = return Nothing
 310 cvtDerivs cs = do { cs' <- mapM cvt_one cs
 311                   ; return (Just cs') }
 312         where
 313           cvt_one c = do { c' <- tconName c
 314                          ; returnL $ HsPredTy $ HsClassP c' [] }
 315
 316 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
 317 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
 318
 319 noExistentials :: [LHsTyVarBndr RdrName]
 320 noExistentials = []
 321
 322 ------------------------------------------
 323 --      Foreign declarations
 324 ------------------------------------------
 325
 326 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 327 cvtForD (ImportF callconv safety from nm ty)
 328   | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
 329   = do  { nm' <- vNameL nm
 330         ; ty' <- cvtType ty
 331         ; let i = CImport (cvt_conv callconv) safety' c_header cis
 332         ; return $ ForeignImport nm' ty' i }
 333
 334   | otherwise
 335   = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent")
 336   where
 337     safety' = case safety of
 338                      Unsafe     -> PlayRisky
 339                      Safe       -> PlaySafe False
 340                      Threadsafe -> PlaySafe True
 341
 342 cvtForD (ExportF callconv as nm ty)
 343   = do  { nm' <- vNameL nm
 344         ; ty' <- cvtType ty
 345         ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
 346         ; return $ ForeignExport nm' ty' e }
 347
 348 cvt_conv :: TH.Callconv -> CCallConv
 349 cvt_conv TH.CCall   = CCallConv
 350 cvt_conv TH.StdCall = StdCallConv
 351
 352 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 353 parse_ccall_impent nm s
 354  = case lex_ccall_impent s of
 355        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
 356        Just ["wrapper"] -> Just (nilFS, CWrapper)
 357        Just ("static":ts) -> parse_ccall_impent_static nm ts
 358        Just ts -> parse_ccall_impent_static nm ts
 359        Nothing -> Nothing
 360
 361 -- XXX we should be sharing code with RdrHsSyn.parseCImport
 362 parse_ccall_impent_static :: String
 363                           -> [String]
 364                           -> Maybe (FastString, CImportSpec)
 365 parse_ccall_impent_static nm ts
 366  = case ts of
 367      [               ] -> mkFun nilFS                 nm
 368      [       "&", cid] -> mkLbl nilFS                 cid
 369      [fname, "&"     ] -> mkLbl (mkFastString fname)  nm
 370      [fname, "&", cid] -> mkLbl (mkFastString fname)  cid
 371      [       "&"     ] -> mkLbl nilFS                 nm
 372      [fname,      cid] -> mkFun (mkFastString fname)  cid
 373      [            cid]
 374           | is_cid cid -> mkFun nilFS                 cid
 375           | otherwise  -> mkFun (mkFastString cid)    nm
 376            -- tricky case when there's a single string: "foo.h" is a header,
 377            -- but "foo" is a C identifier, and we tell the difference by
 378            -- checking for a valid C identifier (see is_cid below).
 379      _anything_else    -> Nothing
 380
 381     where is_cid :: String -> Bool
 382           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
 383
 384           mkLbl :: FastString -> String -> Maybe (FastString, CImportSpec)
 385           mkLbl fname lbl  = Just (fname, CLabel (mkFastString lbl))
 386
 387           mkFun :: FastString -> String -> Maybe (FastString, CImportSpec)
 388           mkFun fname lbl  = Just (fname, CFunction (StaticTarget (mkFastString lbl)))
 389
 390 -- This code is tokenising something like "foo.h &bar", eg.
 391 --   ""           -> Just []
 392 --   "foo.h"      -> Just ["foo.h"]
 393 --   "foo.h &bar" -> Just ["foo.h","&","bar"]
 394 --   "&"          -> Just ["&"]
 395 -- Nothing is returned for a parse error.
 396 lex_ccall_impent :: String -> Maybe [String]
 397 lex_ccall_impent "" = Just []
 398 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
 399 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
 400 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
 401 lex_ccall_impent xs = case span is_valid xs of
 402                           ("", _) -> Nothing
 403                           (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
 404     where is_valid :: Char -> Bool
 405           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
 406
 407 ------------------------------------------
 408 --              Pragmas
 409 ------------------------------------------
 410
 411 cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
 412 cvtPragmaD (InlineP nm ispec)
 413   = do { nm'    <- vNameL nm
 414        ; return $ InlineSig nm' (cvtInlineSpec (Just ispec))
 415        }
 416 cvtPragmaD (SpecialiseP nm ty opt_ispec)
 417   = do { nm'    <- vNameL nm
 418        ; ty'    <- cvtType ty
 419        ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec)
 420        }
 421
 422 cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlineSpec
 423 cvtInlineSpec Nothing
 424   = defaultInlineSpec
 425 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
 426   = mkInlineSpec opt_activation' matchinfo inline
 427   where
 428     matchinfo       = cvtRuleMatchInfo conlike
 429     opt_activation' = fmap cvtActivation opt_activation
 430
 431     cvtRuleMatchInfo False = FunLike
 432     cvtRuleMatchInfo True  = ConLike
 433
 434     cvtActivation (False, phase) = ActiveBefore phase
 435     cvtActivation (True , phase) = ActiveAfter  phase
 436
 437 ---------------------------------------------------
 438 --              Declarations
 439 ---------------------------------------------------
 440
 441 cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName)
 442 cvtDecs [] = return EmptyLocalBinds
 443 cvtDecs ds = do { (binds, sigs) <- cvtBindsAndSigs ds
 444                 ; return (HsValBinds (ValBindsIn binds sigs)) }
 445
 446 cvtBindsAndSigs :: [TH.Dec] -> CvtM (Bag (LHsBind RdrName), [LSig RdrName])
 447 cvtBindsAndSigs ds
 448   = do { binds' <- mapM cvtBind binds
 449        ; sigs' <- mapM cvtSig sigs
 450        ; return (listToBag binds', sigs') }
 451   where
 452     (sigs, binds) = partition is_sig ds
 453
 454     is_sig (TH.SigD _ _)  = True
 455     is_sig (TH.PragmaD _) = True
 456     is_sig _              = False
 457
 458 cvtSig :: TH.Dec -> CvtM (LSig RdrName)
 459 cvtSig (TH.SigD nm ty)
 460   = do { nm' <- vNameL nm
 461        ; ty' <- cvtType ty
 462        ; returnL (Hs.TypeSig nm' ty')
 463        }
 464 cvtSig (TH.PragmaD prag)
 465   = do { prag' <- cvtPragmaD prag
 466        ; returnL prag'
 467        }
 468 cvtSig _ = panic "Convert.cvtSig: Signature expected"
 469
 470 cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
 471 -- Used only for declarations in a 'let/where' clause,
 472 -- not for top level decls
 473 cvtBind (TH.ValD (TH.VarP s) body ds)
 474   = do  { s' <- vNameL s
 475         ; cl' <- cvtClause (Clause [] body ds)
 476         ; returnL $ mkFunBind s' [cl'] }
 477
 478 cvtBind (TH.FunD nm cls)
 479   | null cls
 480   = failWith (ptext (sLit "Function binding for")
 481                     <+> quotes (text (TH.pprint nm))
 482                     <+> ptext (sLit "has no equations"))
 483   | otherwise
 484   = do  { nm' <- vNameL nm
 485         ; cls' <- mapM cvtClause cls
 486         ; returnL $ mkFunBind nm' cls' }
 487
 488 cvtBind (TH.ValD p body ds)
 489   = do  { p' <- cvtPat p
 490         ; g' <- cvtGuard body
 491         ; ds' <- cvtDecs ds
 492         ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds',
 493                               pat_rhs_ty = void, bind_fvs = placeHolderNames } }
 494
 495 cvtBind d
 496   = failWith (sep [ptext (sLit "Illegal kind of declaration in where clause"),
 497                    nest 2 (text (TH.pprint d))])
 498
 499 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
 500 cvtClause (Clause ps body wheres)
 501   = do  { ps' <- cvtPats ps
 502         ; g'  <- cvtGuard body
 503         ; ds' <- cvtDecs wheres
 504         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
 505
 506
 507 -------------------------------------------------------------------
 508 --              Expressions
 509 -------------------------------------------------------------------
 510
 511 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
 512 cvtl e = wrapL (cvt e)
 513   where
 514     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
 515     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
 516     cvt (LitE l)
 517       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
 518       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
 519
 520     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
 521     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
 522                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
 523     cvt (TupE [e])     = cvt e  -- Singleton tuples treated like nothing (just parens)
 524     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
 525     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
 526                             ; return $ HsIf x' y' z' }
 527     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
 528     cvt (CaseE e ms)
 529        | null ms       = failWith (ptext (sLit "Case expression with no alternatives"))
 530        | otherwise     = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
 531                             ; return $ HsCase e' (mkMatchGroup ms') }
 532     cvt (DoE ss)       = cvtHsDo DoExpr ss
 533     cvt (CompE ss)     = cvtHsDo ListComp ss
 534     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
 535     cvt (ListE xs)
 536       | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
 537              -- Note [Converting strings]
 538       | otherwise                    = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
 539     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
 540                                           ; e' <- returnL $ OpApp x' s' undefined y'
 541                                           ; return $ HsPar e' }
 542     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
 543                                           ; sec <- returnL $ SectionR s' y'
 544                                           ; return $ HsPar sec }
 545     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
 546                                           ; sec <- returnL $ SectionL x' s'
 547                                           ; return $ HsPar sec }
 548     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 549
 550     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
 551                               ; return $ ExprWithTySig e' t' }
 552     cvt (RecConE c flds) = do { c' <- cNameL c
 553                               ; flds' <- mapM cvtFld flds
 554                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
 555     cvt (RecUpdE e flds) = do { e' <- cvtl e
 556                               ; flds' <- mapM cvtFld flds
 557                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
 558
 559 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
 560 cvtFld (v,e)
 561   = do  { v' <- vNameL v; e' <- cvtl e
 562         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
 563
 564 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 565 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
 566 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
 567 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 568 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 569
 570 -------------------------------------
 571 --      Do notation and statements
 572 -------------------------------------
 573
 574 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
 575 cvtHsDo do_or_lc stmts
 576   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
 577   | otherwise
 578   = do  { stmts' <- cvtStmts stmts
 579         ; let body = case last stmts' of
 580                         L _ (ExprStmt body _ _) -> body
 581                         _                       -> panic "Malformed body"
 582         ; return $ HsDo do_or_lc (init stmts') body void }
 583
 584 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
 585 cvtStmts = mapM cvtStmt
 586
 587 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
 588 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 589 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 590 cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
 591 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
 592                        where
 593                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 594
 595 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 596 cvtMatch (TH.Match p body decs)
 597   = do  { p' <- cvtPat p
 598         ; g' <- cvtGuard body
 599         ; decs' <- cvtDecs decs
 600         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
 601
 602 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
 603 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 604 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
 605
 606 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
 607 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 608                               ; g' <- returnL $ mkExprStmt ge'
 609                               ; returnL $ GRHS [g'] rhs' }
 610 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 611                               ; returnL $ GRHS gs' rhs' }
 612
 613 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 614 cvtOverLit (IntegerL i)
 615   = do { force i; return $ mkHsIntegral i placeHolderType}
 616 cvtOverLit (RationalL r)
 617   = do { force r; return $ mkHsFractional r placeHolderType}
 618 cvtOverLit (StringL s)
 619   = do { let { s' = mkFastString s }
 620        ; force s'
 621        ; return $ mkHsIsString s' placeHolderType
 622        }
 623 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 624 -- An Integer is like an (overloaded) '3' in a Haskell source program
 625 -- Similarly 3.5 for fractionals
 626
 627 {- Note [Converting strings]
 628 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 629 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
 630 a string literal for "xy".  Of course, we might hope to get
 631 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
 632 if it isn't a literal string
 633 -}
 634
 635 allCharLs :: [TH.Exp] -> Maybe String
 636 -- Note [Converting strings]
 637 allCharLs (LitE (CharL c) : xs)
 638   | Just cs <- allCharLs xs = Just (c:cs)
 639 allCharLs [] = Just []
 640 allCharLs _  = Nothing
 641
 642 cvtLit :: Lit -> CvtM HsLit
 643 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 644 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
 645 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 646 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 647 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 648 cvtLit (StringL s)
 649   = do { let { s' = mkFastString s }
 650        ; force s'
 651        ; return $ HsString s'
 652        }
 653 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
 654
 655 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 656 cvtPats pats = mapM cvtPat pats
 657
 658 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 659 cvtPat pat = wrapL (cvtp pat)
 660
 661 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 662 cvtp (TH.LitP l)
 663   | overloadedLit l   = do { l' <- cvtOverLit l
 664                            ; return (mkNPat l' Nothing) }
 665                                   -- Not right for negative patterns;
 666                                   -- need to think about that!
 667   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 668 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 669 cvtp (TupP [p])       = cvtp p
 670 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 671 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 672 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 673                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 674 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 675 cvtp (BangP p)        = do { p' <- cvtPat p; return $ BangPat p' }
 676 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 677 cvtp TH.WildP         = return $ WildPat void
 678 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 679                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 680 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 681 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 682
 683 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 684 cvtPatFld (s,p)
 685   = do  { s' <- vNameL s; p' <- cvtPat p
 686         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 687
 688 -----------------------------------------------------------
 689 --      Types and type variables
 690
 691 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
 692 cvtTvs tvs = mapM cvt_tv tvs
 693
 694 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 695 cvt_tv (TH.PlainTV nm)
 696   = do { nm' <- tName nm
 697        ; returnL $ UserTyVar nm'
 698        }
 699 cvt_tv (TH.KindedTV nm ki)
 700   = do { nm' <- tName nm
 701        ; returnL $ KindedTyVar nm' (cvtKind ki)
 702        }
 703
 704 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 705 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 706
 707 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
 708 cvtPred (TH.ClassP cla tys)
 709   = do { cla' <- if isVarName cla then tName cla else tconName cla
 710        ; tys' <- mapM cvtType tys
 711        ; returnL $ HsClassP cla' tys'
 712        }
 713 cvtPred (TH.EqualP ty1 ty2)
 714   = do { ty1' <- cvtType ty1
 715        ; ty2' <- cvtType ty2
 716        ; returnL $ HsEqualP ty1' ty2'
 717        }
 718
 719 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
 720 cvtPredTy ty
 721   = do  { (head, tys') <- split_ty_app ty
 722         ; case head of
 723             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 724             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 725             _       -> failWith (ptext (sLit "Malformed predicate") <+>
 726                        text (TH.pprint ty)) }
 727
 728 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 729 cvtType ty
 730   = do { (head_ty, tys') <- split_ty_app ty
 731        ; case head_ty of
 732            TupleT n
 733              | length tys' == n         -- Saturated
 734              -> if n==1 then return (head tys') -- Singleton tuples treated
 735                                                 -- like nothing (ie just parens)
 736                         else returnL (HsTupleTy Boxed tys')
 737              | n == 1
 738              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 739              | otherwise
 740              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 741            ArrowT
 742              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 743              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
 744            ListT
 745              | [x']    <- tys' -> returnL (HsListTy x')
 746              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
 747            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 748            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 749
 750            ForallT tvs cxt ty
 751              | null tys'
 752              -> do { tvs' <- cvtTvs tvs
 753                    ; cxt' <- cvtContext cxt
 754                    ; ty'  <- cvtType ty
 755                    ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
 756                    }
 757
 758            SigT ty ki
 759              -> do { ty' <- cvtType ty
 760                    ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
 761                    }
 762
 763            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 764     }
 765   where
 766     mk_apps head_ty []       = returnL head_ty
 767     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
 768                                   ; mk_apps (HsAppTy head_ty' ty) tys }
 769
 770 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 771 split_ty_app ty = go ty []
 772   where
 773     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 774     go f as           = return (f,as)
 775
 776 cvtKind :: TH.Kind -> Type.Kind
 777 cvtKind StarK          = liftedTypeKind
 778 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
 779
 780 -----------------------------------------------------------
 781
 782
 783 -----------------------------------------------------------
 784 -- some useful things
 785
 786 overloadedLit :: Lit -> Bool
 787 -- True for literals that Haskell treats as overloaded
 788 overloadedLit (IntegerL  _) = True
 789 overloadedLit (RationalL _) = True
 790 overloadedLit _             = False
 791
 792 void :: Type.Type
 793 void = placeHolderType
 794
 795 --------------------------------------------------------------------
 796 --      Turning Name back into RdrName
 797 --------------------------------------------------------------------
 798
 799 -- variable names
 800 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 801 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 802
 803 vNameL n = wrapL (vName n)
 804 vName n = cvtName OccName.varName n
 805
 806 -- Constructor function names; this is Haskell source, hence srcDataName
 807 cNameL n = wrapL (cName n)
 808 cName n = cvtName OccName.dataName n
 809
 810 -- Type variable names
 811 tName n = cvtName OccName.tvName n
 812
 813 -- Type Constructor names
 814 tconNameL n = wrapL (tconName n)
 815 tconName n = cvtName OccName.tcClsName n
 816
 817 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 818 cvtName ctxt_ns (TH.Name occ flavour)
 819   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 820   | otherwise                   = force (thRdrName ctxt_ns occ_str flavour)
 821   where
 822     occ_str = TH.occString occ
 823
 824 okOcc :: OccName.NameSpace -> String -> Bool
 825 okOcc _  []      = False
 826 okOcc ns str@(c:_)
 827   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
 828   | otherwise                 = startsConId c || startsConSym c || str == "[]"
 829
 830 -- Determine the name space of a name in a type
 831 --
 832 isVarName :: TH.Name -> Bool
 833 isVarName (TH.Name occ _)
 834   = case TH.occString occ of
 835       ""    -> False
 836       (c:_) -> startsVarId c || startsVarSym c
 837
 838 badOcc :: OccName.NameSpace -> String -> SDoc
 839 badOcc ctxt_ns occ
 840   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
 841         <+> ptext (sLit "name:") <+> quotes (text occ)
 842
 843 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 844 -- This turns a Name into a RdrName
 845 -- The passed-in name space tells what the context is expecting;
 846 --      use it unless the TH name knows what name-space it comes
 847 --      from, in which case use the latter
 848 --
 849 -- ToDo: we may generate silly RdrNames, by passing a name space
 850 --       that doesn't match the string, like VarName ":+",
 851 --       which will give confusing error messages later
 852 --
 853 -- The strict applications ensure that any buried exceptions get forced
 854 thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
 855 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 856 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 857 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 858 thRdrName ctxt_ns occ TH.NameS
 859   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 860   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 861
 862 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
 863 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 864
 865 thRdrNameGuesses :: TH.Name -> [RdrName]
 866 thRdrNameGuesses (TH.Name occ flavour)
 867   -- This special case for NameG ensures that we don't generate duplicates in the output list
 868   | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
 869   | otherwise                         = [ thRdrName gns occ_str flavour
 870                                         | gns <- guessed_nss]
 871   where
 872     -- guessed_ns are the name spaces guessed from looking at the TH name
 873     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 874                 | otherwise                       = [OccName.varName, OccName.tvName]
 875     occ_str = TH.occString occ
 876
 877 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 878 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 879 -- We must generate an Exact name, just as the parser does
 880 isBuiltInOcc ctxt_ns occ
 881   = case occ of
 882         ":"              -> Just (Name.getName consDataCon)
 883         "[]"             -> Just (Name.getName nilDataCon)
 884         "()"             -> Just (tup_name 0)
 885         '(' : ',' : rest -> go_tuple 2 rest
 886         _                -> Nothing
 887   where
 888     go_tuple n ")"          = Just (tup_name n)
 889     go_tuple n (',' : rest) = go_tuple (n+1) rest
 890     go_tuple _ _            = Nothing
 891
 892     tup_name n
 893         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
 894         | otherwise                        = Name.getName (tupleCon Boxed n)
 895
 896 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 897 mk_uniq_occ ns occ uniq
 898   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 899         -- The idea here is to make a name that
 900         -- a) the user could not possibly write, and
 901         -- b) cannot clash with another NameU
 902         -- Previously I generated an Exact RdrName with mkInternalName.
 903         -- This works fine for local binders, but does not work at all for
 904         -- top-level binders, which must have External Names, since they are
 905         -- rapidly baked into data constructors and the like.  Baling out
 906         -- and generating an unqualified RdrName here is the simple solution
 907
 908 -- The packing and unpacking is rather turgid :-(
 909 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 910 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 911
 912 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 913 mk_ghc_ns TH.DataName  = OccName.dataName
 914 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 915 mk_ghc_ns TH.VarName   = OccName.varName
 916
 917 mk_mod :: TH.ModName -> ModuleName
 918 mk_mod mod = mkModuleName (TH.modString mod)
 919
 920 mk_pkg :: TH.PkgName -> PackageId
 921 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 922
 923 mk_uniq :: Int# -> Unique
 924 mk_uniq u = mkUniqueGrimily (I# u)
 925 \end{code}
 926