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