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