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