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