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