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 -- NB: only fire up this setup for a non-empty list, else
 572 --     there's a danger of returning "" for [] :: [Int]!
 573 allCharLs xs
 574   = case xs of
 575       LitE (CharL c) : ys -> go [c] ys
 576       _                   -> Nothing
 577   where
 578     go cs []                    = Just (reverse cs)
 579     go cs (LitE (CharL c) : ys) = go (c:cs) ys
 580     go _  _                     = Nothing
 581
 582 cvtLit :: Lit -> CvtM HsLit
 583 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 584 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
 585 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 586 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 587 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 588 cvtLit (StringL s)
 589   = do { let { s' = mkFastString s }
 590        ; force s'
 591        ; return $ HsString s'
 592        }
 593 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
 594         -- cvtLit should not be called on IntegerL, RationalL
 595         -- That precondition is established right here in
 596         -- Convert.lhs, hence panic
 597
 598 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 599 cvtPats pats = mapM cvtPat pats
 600
 601 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 602 cvtPat pat = wrapL (cvtp pat)
 603
 604 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 605 cvtp (TH.LitP l)
 606   | overloadedLit l   = do { l' <- cvtOverLit l
 607                            ; return (mkNPat l' Nothing) }
 608                                   -- Not right for negative patterns;
 609                                   -- need to think about that!
 610   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 611 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 612 cvtp (TupP [p])       = cvtp p
 613 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 614 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 615 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 616                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 617 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 618 cvtp (BangP p)        = do { p' <- cvtPat p; return $ BangPat p' }
 619 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 620 cvtp TH.WildP         = return $ WildPat void
 621 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 622                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 623 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 624 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 625
 626 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 627 cvtPatFld (s,p)
 628   = do  { s' <- vNameL s; p' <- cvtPat p
 629         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 630
 631 -----------------------------------------------------------
 632 --      Types and type variables
 633
 634 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
 635 cvtTvs tvs = mapM cvt_tv tvs
 636
 637 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 638 cvt_tv (TH.PlainTV nm)
 639   = do { nm' <- tName nm
 640        ; returnL $ UserTyVar nm'
 641        }
 642 cvt_tv (TH.KindedTV nm ki)
 643   = do { nm' <- tName nm
 644        ; returnL $ KindedTyVar nm' (cvtKind ki)
 645        }
 646
 647 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 648 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 649
 650 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
 651 cvtPred (TH.ClassP cla tys)
 652   = do { cla' <- if isVarName cla then tName cla else tconName cla
 653        ; tys' <- mapM cvtType tys
 654        ; returnL $ HsClassP cla' tys'
 655        }
 656 cvtPred (TH.EqualP ty1 ty2)
 657   = do { ty1' <- cvtType ty1
 658        ; ty2' <- cvtType ty2
 659        ; returnL $ HsEqualP ty1' ty2'
 660        }
 661
 662 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
 663 cvtPredTy ty
 664   = do  { (head, tys') <- split_ty_app ty
 665         ; case head of
 666             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 667             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 668             _       -> failWith (ptext (sLit "Malformed predicate") <+>
 669                        text (TH.pprint ty)) }
 670
 671 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 672 cvtType ty
 673   = do { (head_ty, tys') <- split_ty_app ty
 674        ; case head_ty of
 675            TupleT n
 676              | length tys' == n         -- Saturated
 677              -> if n==1 then return (head tys') -- Singleton tuples treated
 678                                                 -- like nothing (ie just parens)
 679                         else returnL (HsTupleTy Boxed tys')
 680              | n == 1
 681              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 682              | otherwise
 683              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 684            ArrowT
 685              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 686              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
 687            ListT
 688              | [x']    <- tys' -> returnL (HsListTy x')
 689              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
 690            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 691            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 692
 693            ForallT tvs cxt ty
 694              | null tys'
 695              -> do { tvs' <- cvtTvs tvs
 696                    ; cxt' <- cvtContext cxt
 697                    ; ty'  <- cvtType ty
 698                    ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
 699                    }
 700
 701            SigT ty ki
 702              -> do { ty' <- cvtType ty
 703                    ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
 704                    }
 705
 706            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 707     }
 708   where
 709     mk_apps head_ty []       = returnL head_ty
 710     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
 711                                   ; mk_apps (HsAppTy head_ty' ty) tys }
 712
 713 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 714 split_ty_app ty = go ty []
 715   where
 716     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 717     go f as           = return (f,as)
 718
 719 cvtKind :: TH.Kind -> Type.Kind
 720 cvtKind StarK          = liftedTypeKind
 721 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
 722
 723 -----------------------------------------------------------
 724
 725
 726 -----------------------------------------------------------
 727 -- some useful things
 728
 729 overloadedLit :: Lit -> Bool
 730 -- True for literals that Haskell treats as overloaded
 731 overloadedLit (IntegerL  _) = True
 732 overloadedLit (RationalL _) = True
 733 overloadedLit _             = False
 734
 735 void :: Type.Type
 736 void = placeHolderType
 737
 738 --------------------------------------------------------------------
 739 --      Turning Name back into RdrName
 740 --------------------------------------------------------------------
 741
 742 -- variable names
 743 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 744 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 745
 746 vNameL n = wrapL (vName n)
 747 vName n = cvtName OccName.varName n
 748
 749 -- Constructor function names; this is Haskell source, hence srcDataName
 750 cNameL n = wrapL (cName n)
 751 cName n = cvtName OccName.dataName n
 752
 753 -- Type variable names
 754 tName n = cvtName OccName.tvName n
 755
 756 -- Type Constructor names
 757 tconNameL n = wrapL (tconName n)
 758 tconName n = cvtName OccName.tcClsName n
 759
 760 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 761 cvtName ctxt_ns (TH.Name occ flavour)
 762   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 763   | otherwise                   = force rdr_name >> return rdr_name
 764   where
 765     occ_str = TH.occString occ
 766     rdr_name = thRdrName ctxt_ns occ_str flavour
 767
 768 okOcc :: OccName.NameSpace -> String -> Bool
 769 okOcc _  []      = False
 770 okOcc ns str@(c:_)
 771   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
 772   | otherwise                 = startsConId c || startsConSym c || str == "[]"
 773
 774 -- Determine the name space of a name in a type
 775 --
 776 isVarName :: TH.Name -> Bool
 777 isVarName (TH.Name occ _)
 778   = case TH.occString occ of
 779       ""    -> False
 780       (c:_) -> startsVarId c || startsVarSym c
 781
 782 badOcc :: OccName.NameSpace -> String -> SDoc
 783 badOcc ctxt_ns occ
 784   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
 785         <+> ptext (sLit "name:") <+> quotes (text occ)
 786
 787 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 788 -- This turns a Name into a RdrName
 789 -- The passed-in name space tells what the context is expecting;
 790 --      use it unless the TH name knows what name-space it comes
 791 --      from, in which case use the latter
 792 --
 793 -- ToDo: we may generate silly RdrNames, by passing a name space
 794 --       that doesn't match the string, like VarName ":+",
 795 --       which will give confusing error messages later
 796 --
 797 -- The strict applications ensure that any buried exceptions get forced
 798 thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
 799 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 800 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 801 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 802 thRdrName ctxt_ns occ TH.NameS
 803   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 804   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 805
 806 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
 807 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 808
 809 thRdrNameGuesses :: TH.Name -> [RdrName]
 810 thRdrNameGuesses (TH.Name occ flavour)
 811   -- This special case for NameG ensures that we don't generate duplicates in the output list
 812   | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
 813   | otherwise                         = [ thRdrName gns occ_str flavour
 814                                         | gns <- guessed_nss]
 815   where
 816     -- guessed_ns are the name spaces guessed from looking at the TH name
 817     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 818                 | otherwise                       = [OccName.varName, OccName.tvName]
 819     occ_str = TH.occString occ
 820
 821 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 822 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 823 -- We must generate an Exact name, just as the parser does
 824 isBuiltInOcc ctxt_ns occ
 825   = case occ of
 826         ":"              -> Just (Name.getName consDataCon)
 827         "[]"             -> Just (Name.getName nilDataCon)
 828         "()"             -> Just (tup_name 0)
 829         '(' : ',' : rest -> go_tuple 2 rest
 830         _                -> Nothing
 831   where
 832     go_tuple n ")"          = Just (tup_name n)
 833     go_tuple n (',' : rest) = go_tuple (n+1) rest
 834     go_tuple _ _            = Nothing
 835
 836     tup_name n
 837         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
 838         | otherwise                        = Name.getName (tupleCon Boxed n)
 839
 840 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 841 mk_uniq_occ ns occ uniq
 842   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 843         -- The idea here is to make a name that
 844         -- a) the user could not possibly write, and
 845         -- b) cannot clash with another NameU
 846         -- Previously I generated an Exact RdrName with mkInternalName.
 847         -- This works fine for local binders, but does not work at all for
 848         -- top-level binders, which must have External Names, since they are
 849         -- rapidly baked into data constructors and the like.  Baling out
 850         -- and generating an unqualified RdrName here is the simple solution
 851
 852 -- The packing and unpacking is rather turgid :-(
 853 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 854 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 855
 856 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 857 mk_ghc_ns TH.DataName  = OccName.dataName
 858 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 859 mk_ghc_ns TH.VarName   = OccName.varName
 860
 861 mk_mod :: TH.ModName -> ModuleName
 862 mk_mod mod = mkModuleName (TH.modString mod)
 863
 864 mk_pkg :: TH.PkgName -> PackageId
 865 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 866
 867 mk_uniq :: Int# -> Unique
 868 mk_uniq u = mkUniqueGrimily (I# u)
 869 \end{code}
 870