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
 379 cvtForD (ExportF callconv as nm ty)
 380   = do  { nm' <- vNameL nm
 381         ; ty' <- cvtType ty
 382         ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
 383         ; return $ ForeignExport nm' ty' e }
 384
 385 cvt_conv :: TH.Callconv -> CCallConv
 386 cvt_conv TH.CCall   = CCallConv
 387 cvt_conv TH.StdCall = StdCallConv
 388
 389 ------------------------------------------
 390 --              Pragmas
 391 ------------------------------------------
 392
 393 cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
 394 cvtPragmaD (InlineP nm ispec)
 395   = do { nm'    <- vNameL nm
 396        ; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) }
 397
 398 cvtPragmaD (SpecialiseP nm ty opt_ispec)
 399   = do { nm' <- vNameL nm
 400        ; ty' <- cvtType ty
 401        ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) }
 402
 403 cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
 404 cvtInlineSpec Nothing
 405   = defaultInlinePragma
 406 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
 407   = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
 408                  , inl_inline = inl_spec, inl_sat = Nothing }
 409   where
 410     matchinfo       = cvtRuleMatchInfo conlike
 411     opt_activation' = cvtActivation opt_activation
 412
 413     cvtRuleMatchInfo False = FunLike
 414     cvtRuleMatchInfo True  = ConLike
 415
 416     inl_spec | inline    = Inline
 417              | otherwise = NoInline
 418              -- Currently we have no way to say Inlinable
 419
 420     cvtActivation Nothing | inline      = AlwaysActive
 421                           | otherwise   = NeverActive
 422     cvtActivation (Just (False, phase)) = ActiveBefore phase
 423     cvtActivation (Just (True , phase)) = ActiveAfter  phase
 424
 425 ---------------------------------------------------
 426 --              Declarations
 427 ---------------------------------------------------
 428
 429 cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
 430 cvtLocalDecs doc ds
 431   | null ds
 432   = return EmptyLocalBinds
 433   | otherwise
 434   = do { ds' <- mapM cvtDec ds
 435        ; let (binds, prob_sigs) = partitionWith is_bind ds'
 436        ; let (sigs, bads) = partitionWith is_sig prob_sigs
 437        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
 438        ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
 439
 440 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
 441 cvtClause (Clause ps body wheres)
 442   = do  { ps' <- cvtPats ps
 443         ; g'  <- cvtGuard body
 444         ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
 445         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
 446
 447
 448 -------------------------------------------------------------------
 449 --              Expressions
 450 -------------------------------------------------------------------
 451
 452 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
 453 cvtl e = wrapL (cvt e)
 454   where
 455     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
 456     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
 457     cvt (LitE l)
 458       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
 459       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
 460
 461     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
 462     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
 463                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
 464     cvt (TupE [e])     = cvt e  -- Singleton tuples treated like nothing (just parens)
 465     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
 466     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
 467                             ; return $ HsIf x' y' z' }
 468     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
 469                             ; e' <- cvtl e; return $ HsLet ds' e' }
 470     cvt (CaseE e ms)
 471        | null ms       = failWith (ptext (sLit "Case expression with no alternatives"))
 472        | otherwise     = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
 473                             ; return $ HsCase e' (mkMatchGroup ms') }
 474     cvt (DoE ss)       = cvtHsDo DoExpr ss
 475     cvt (CompE ss)     = cvtHsDo ListComp ss
 476     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
 477     cvt (ListE xs)
 478       | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
 479              -- Note [Converting strings]
 480       | otherwise                    = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
 481     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
 482                                           ; e' <- returnL $ OpApp x' s' undefined y'
 483                                           ; return $ HsPar e' }
 484     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
 485                                           ; sec <- returnL $ SectionR s' y'
 486                                           ; return $ HsPar sec }
 487     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
 488                                           ; sec <- returnL $ SectionL x' s'
 489                                           ; return $ HsPar sec }
 490     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 491
 492     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
 493                               ; return $ ExprWithTySig e' t' }
 494     cvt (RecConE c flds) = do { c' <- cNameL c
 495                               ; flds' <- mapM cvtFld flds
 496                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
 497     cvt (RecUpdE e flds) = do { e' <- cvtl e
 498                               ; flds' <- mapM cvtFld flds
 499                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
 500
 501 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
 502 cvtFld (v,e)
 503   = do  { v' <- vNameL v; e' <- cvtl e
 504         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
 505
 506 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 507 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
 508 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
 509 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 510 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 511
 512 -------------------------------------
 513 --      Do notation and statements
 514 -------------------------------------
 515
 516 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
 517 cvtHsDo do_or_lc stmts
 518   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
 519   | otherwise
 520   = do  { stmts' <- cvtStmts stmts
 521         ; body <- case last stmts' of
 522                     L _ (ExprStmt body _ _) -> return body
 523                     stmt' -> failWith (bad_last stmt')
 524         ; return $ HsDo do_or_lc (init stmts') body void }
 525   where
 526     bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
 527                          , nest 2 $ Outputable.ppr stmt
 528                          , ptext (sLit "(It should be an expression.)") ]
 529
 530 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
 531 cvtStmts = mapM cvtStmt
 532
 533 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
 534 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 535 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 536 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
 537                             ; returnL $ LetStmt ds' }
 538 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
 539                        where
 540                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 541
 542 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 543 cvtMatch (TH.Match p body decs)
 544   = do  { p' <- cvtPat p
 545         ; g' <- cvtGuard body
 546         ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
 547         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
 548
 549 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
 550 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 551 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
 552
 553 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
 554 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 555                               ; g' <- returnL $ mkExprStmt ge'
 556                               ; returnL $ GRHS [g'] rhs' }
 557 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 558                               ; returnL $ GRHS gs' rhs' }
 559
 560 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 561 cvtOverLit (IntegerL i)
 562   = do { force i; return $ mkHsIntegral i placeHolderType}
 563 cvtOverLit (RationalL r)
 564   = do { force r; return $ mkHsFractional r placeHolderType}
 565 cvtOverLit (StringL s)
 566   = do { let { s' = mkFastString s }
 567        ; force s'
 568        ; return $ mkHsIsString s' placeHolderType
 569        }
 570 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 571 -- An Integer is like an (overloaded) '3' in a Haskell source program
 572 -- Similarly 3.5 for fractionals
 573
 574 {- Note [Converting strings]
 575 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 576 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
 577 a string literal for "xy".  Of course, we might hope to get
 578 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
 579 if it isn't a literal string
 580 -}
 581
 582 allCharLs :: [TH.Exp] -> Maybe String
 583 -- Note [Converting strings]
 584 -- NB: only fire up this setup for a non-empty list, else
 585 --     there's a danger of returning "" for [] :: [Int]!
 586 allCharLs xs
 587   = case xs of
 588       LitE (CharL c) : ys -> go [c] ys
 589       _                   -> Nothing
 590   where
 591     go cs []                    = Just (reverse cs)
 592     go cs (LitE (CharL c) : ys) = go (c:cs) ys
 593     go _  _                     = Nothing
 594
 595 cvtLit :: Lit -> CvtM HsLit
 596 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 597 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
 598 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 599 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 600 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 601 cvtLit (StringL s)     = do { let { s' = mkFastString s }
 602                             ; force s'
 603                             ; return $ HsString s' }
 604 cvtLit (StringPrimL s) = do { let { s' = mkFastString s }
 605                             ; force s'
 606                             ; return $ HsStringPrim s' }
 607 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
 608         -- cvtLit should not be called on IntegerL, RationalL
 609         -- That precondition is established right here in
 610         -- Convert.lhs, hence panic
 611
 612 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 613 cvtPats pats = mapM cvtPat pats
 614
 615 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 616 cvtPat pat = wrapL (cvtp pat)
 617
 618 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 619 cvtp (TH.LitP l)
 620   | overloadedLit l   = do { l' <- cvtOverLit l
 621                            ; return (mkNPat l' Nothing) }
 622                                   -- Not right for negative patterns;
 623                                   -- need to think about that!
 624   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 625 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 626 cvtp (TupP [p])       = cvtp p
 627 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 628 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 629 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 630                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 631 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 632 cvtp (BangP p)        = do { p' <- cvtPat p; return $ BangPat p' }
 633 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 634 cvtp TH.WildP         = return $ WildPat void
 635 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 636                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 637 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 638 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 639
 640 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 641 cvtPatFld (s,p)
 642   = do  { s' <- vNameL s; p' <- cvtPat p
 643         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 644
 645 -----------------------------------------------------------
 646 --      Types and type variables
 647
 648 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
 649 cvtTvs tvs = mapM cvt_tv tvs
 650
 651 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 652 cvt_tv (TH.PlainTV nm)
 653   = do { nm' <- tName nm
 654        ; returnL $ UserTyVar nm' placeHolderKind
 655        }
 656 cvt_tv (TH.KindedTV nm ki)
 657   = do { nm' <- tName nm
 658        ; returnL $ KindedTyVar nm' (cvtKind ki)
 659        }
 660
 661 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 662 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 663
 664 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
 665 cvtPred (TH.ClassP cla tys)
 666   = do { cla' <- if isVarName cla then tName cla else tconName cla
 667        ; tys' <- mapM cvtType tys
 668        ; returnL $ HsClassP cla' tys'
 669        }
 670 cvtPred (TH.EqualP ty1 ty2)
 671   = do { ty1' <- cvtType ty1
 672        ; ty2' <- cvtType ty2
 673        ; returnL $ HsEqualP ty1' ty2'
 674        }
 675
 676 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
 677 cvtPredTy ty
 678   = do  { (head, tys') <- split_ty_app ty
 679         ; case head of
 680             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 681             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 682             _       -> failWith (ptext (sLit "Malformed predicate") <+>
 683                        text (TH.pprint ty)) }
 684
 685 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 686 cvtType ty
 687   = do { (head_ty, tys') <- split_ty_app ty
 688        ; case head_ty of
 689            TupleT n
 690              | length tys' == n         -- Saturated
 691              -> if n==1 then return (head tys') -- Singleton tuples treated
 692                                                 -- like nothing (ie just parens)
 693                         else returnL (HsTupleTy Boxed tys')
 694              | n == 1
 695              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 696              | otherwise
 697              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 698            ArrowT
 699              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 700              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
 701            ListT
 702              | [x']    <- tys' -> returnL (HsListTy x')
 703              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
 704            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 705            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 706
 707            ForallT tvs cxt ty
 708              | null tys'
 709              -> do { tvs' <- cvtTvs tvs
 710                    ; cxt' <- cvtContext cxt
 711                    ; ty'  <- cvtType ty
 712                    ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
 713                    }
 714
 715            SigT ty ki
 716              -> do { ty' <- cvtType ty
 717                    ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
 718                    }
 719
 720            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 721     }
 722   where
 723     mk_apps head_ty []       = returnL head_ty
 724     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
 725                                   ; mk_apps (HsAppTy head_ty' ty) tys }
 726
 727 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 728 split_ty_app ty = go ty []
 729   where
 730     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 731     go f as           = return (f,as)
 732
 733 cvtKind :: TH.Kind -> Type.Kind
 734 cvtKind StarK          = liftedTypeKind
 735 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
 736
 737 -----------------------------------------------------------
 738
 739
 740 -----------------------------------------------------------
 741 -- some useful things
 742
 743 overloadedLit :: Lit -> Bool
 744 -- True for literals that Haskell treats as overloaded
 745 overloadedLit (IntegerL  _) = True
 746 overloadedLit (RationalL _) = True
 747 overloadedLit _             = False
 748
 749 void :: Type.Type
 750 void = placeHolderType
 751
 752 --------------------------------------------------------------------
 753 --      Turning Name back into RdrName
 754 --------------------------------------------------------------------
 755
 756 -- variable names
 757 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 758 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 759
 760 vNameL n = wrapL (vName n)
 761 vName n = cvtName OccName.varName n
 762
 763 -- Constructor function names; this is Haskell source, hence srcDataName
 764 cNameL n = wrapL (cName n)
 765 cName n = cvtName OccName.dataName n
 766
 767 -- Type variable names
 768 tName n = cvtName OccName.tvName n
 769
 770 -- Type Constructor names
 771 tconNameL n = wrapL (tconName n)
 772 tconName n = cvtName OccName.tcClsName n
 773
 774 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 775 cvtName ctxt_ns (TH.Name occ flavour)
 776   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 777   | otherwise                   = force rdr_name >> return rdr_name
 778   where
 779     occ_str = TH.occString occ
 780     rdr_name = thRdrName ctxt_ns occ_str flavour
 781
 782 okOcc :: OccName.NameSpace -> String -> Bool
 783 okOcc _  []      = False
 784 okOcc ns str@(c:_)
 785   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
 786   | otherwise                 = startsConId c || startsConSym c || str == "[]"
 787
 788 -- Determine the name space of a name in a type
 789 --
 790 isVarName :: TH.Name -> Bool
 791 isVarName (TH.Name occ _)
 792   = case TH.occString occ of
 793       ""    -> False
 794       (c:_) -> startsVarId c || startsVarSym c
 795
 796 badOcc :: OccName.NameSpace -> String -> SDoc
 797 badOcc ctxt_ns occ
 798   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
 799         <+> ptext (sLit "name:") <+> quotes (text occ)
 800
 801 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 802 -- This turns a Name into a RdrName
 803 -- The passed-in name space tells what the context is expecting;
 804 --      use it unless the TH name knows what name-space it comes
 805 --      from, in which case use the latter
 806 --
 807 -- ToDo: we may generate silly RdrNames, by passing a name space
 808 --       that doesn't match the string, like VarName ":+",
 809 --       which will give confusing error messages later
 810 --
 811 -- The strict applications ensure that any buried exceptions get forced
 812 thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
 813 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 814 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 815 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 816 thRdrName ctxt_ns occ TH.NameS
 817   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 818   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 819
 820 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
 821 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 822
 823 thRdrNameGuesses :: TH.Name -> [RdrName]
 824 thRdrNameGuesses (TH.Name occ flavour)
 825   -- This special case for NameG ensures that we don't generate duplicates in the output list
 826   | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
 827   | otherwise                         = [ thRdrName gns occ_str flavour
 828                                         | gns <- guessed_nss]
 829   where
 830     -- guessed_ns are the name spaces guessed from looking at the TH name
 831     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 832                 | otherwise                       = [OccName.varName, OccName.tvName]
 833     occ_str = TH.occString occ
 834
 835 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 836 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 837 -- We must generate an Exact name, just as the parser does
 838 isBuiltInOcc ctxt_ns occ
 839   = case occ of
 840         ":"              -> Just (Name.getName consDataCon)
 841         "[]"             -> Just (Name.getName nilDataCon)
 842         "()"             -> Just (tup_name 0)
 843         '(' : ',' : rest -> go_tuple 2 rest
 844         _                -> Nothing
 845   where
 846     go_tuple n ")"          = Just (tup_name n)
 847     go_tuple n (',' : rest) = go_tuple (n+1) rest
 848     go_tuple _ _            = Nothing
 849
 850     tup_name n
 851         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
 852         | otherwise                        = Name.getName (tupleCon Boxed n)
 853
 854 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 855 mk_uniq_occ ns occ uniq
 856   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 857         -- See Note [Unique OccNames from Template Haskell]
 858
 859 -- The packing and unpacking is rather turgid :-(
 860 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 861 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 862
 863 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 864 mk_ghc_ns TH.DataName  = OccName.dataName
 865 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 866 mk_ghc_ns TH.VarName   = OccName.varName
 867
 868 mk_mod :: TH.ModName -> ModuleName
 869 mk_mod mod = mkModuleName (TH.modString mod)
 870
 871 mk_pkg :: TH.PkgName -> PackageId
 872 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 873
 874 mk_uniq :: Int# -> Unique
 875 mk_uniq u = mkUniqueGrimily (I# u)
 876 \end{code}
 877
 878 Note [Unique OccNames from Template Haskell]
 879 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 880 The idea here is to make a name that
 881   a) the user could not possibly write (it has a "["
 882      and letters or digits from the unique)
 883   b) cannot clash with another NameU
 884 Previously I generated an Exact RdrName with mkInternalName.  This
 885 works fine for local binders, but does not work at all for top-level
 886 binders, which must have External Names, since they are rapidly baked
 887 into data constructors and the like.  Baling out and generating an
 888 unqualified RdrName here is the simple solution
 889
 890 See also Note [Suppressing uniques in OccNames] in OccName, which
 891 suppresses the unique when opt_SuppressUniques is on.