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         ; let Just (stmts'', last') = snocView stmts'
 526
 527         ; last'' <- case last' of
 528                       L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
 529                       _ -> failWith (bad_last last')
 530
 531         ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
 532   where
 533     bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
 534                          , nest 2 $ Outputable.ppr stmt
 535                          , ptext (sLit "(It should be an expression.)") ]
 536
 537 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
 538 cvtStmts = mapM cvtStmt
 539
 540 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
 541 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 542 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 543 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
 544                             ; returnL $ LetStmt ds' }
 545 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr }
 546                        where
 547                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 548
 549 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 550 cvtMatch (TH.Match p body decs)
 551   = do  { p' <- cvtPat p
 552         ; g' <- cvtGuard body
 553         ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
 554         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
 555
 556 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
 557 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 558 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
 559
 560 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
 561 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 562                               ; g' <- returnL $ mkExprStmt ge'
 563                               ; returnL $ GRHS [g'] rhs' }
 564 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 565                               ; returnL $ GRHS gs' rhs' }
 566
 567 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 568 cvtOverLit (IntegerL i)
 569   = do { force i; return $ mkHsIntegral i placeHolderType}
 570 cvtOverLit (RationalL r)
 571   = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
 572 cvtOverLit (StringL s)
 573   = do { let { s' = mkFastString s }
 574        ; force s'
 575        ; return $ mkHsIsString s' placeHolderType
 576        }
 577 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 578 -- An Integer is like an (overloaded) '3' in a Haskell source program
 579 -- Similarly 3.5 for fractionals
 580
 581 {- Note [Converting strings]
 582 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 583 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
 584 a string literal for "xy".  Of course, we might hope to get
 585 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
 586 if it isn't a literal string
 587 -}
 588
 589 allCharLs :: [TH.Exp] -> Maybe String
 590 -- Note [Converting strings]
 591 -- NB: only fire up this setup for a non-empty list, else
 592 --     there's a danger of returning "" for [] :: [Int]!
 593 allCharLs xs
 594   = case xs of
 595       LitE (CharL c) : ys -> go [c] ys
 596       _                   -> Nothing
 597   where
 598     go cs []                    = Just (reverse cs)
 599     go cs (LitE (CharL c) : ys) = go (c:cs) ys
 600     go _  _                     = Nothing
 601
 602 cvtLit :: Lit -> CvtM HsLit
 603 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 604 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
 605 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
 606 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
 607 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 608 cvtLit (StringL s)     = do { let { s' = mkFastString s }
 609                             ; force s'
 610                             ; return $ HsString s' }
 611 cvtLit (StringPrimL s) = do { let { s' = mkFastString s }
 612                             ; force s'
 613                             ; return $ HsStringPrim s' }
 614 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
 615         -- cvtLit should not be called on IntegerL, RationalL
 616         -- That precondition is established right here in
 617         -- Convert.lhs, hence panic
 618
 619 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 620 cvtPats pats = mapM cvtPat pats
 621
 622 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 623 cvtPat pat = wrapL (cvtp pat)
 624
 625 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 626 cvtp (TH.LitP l)
 627   | overloadedLit l   = do { l' <- cvtOverLit l
 628                            ; return (mkNPat l' Nothing) }
 629                                   -- Not right for negative patterns;
 630                                   -- need to think about that!
 631   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 632 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 633 cvtp (TupP [p])       = cvtp p
 634 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 635 cvtp (UnboxedTupP [p]) = cvtp p
 636 cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
 637 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 638 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 639                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 640 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 641 cvtp (BangP p)        = do { p' <- cvtPat p; return $ BangPat p' }
 642 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 643 cvtp TH.WildP         = return $ WildPat void
 644 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 645                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 646 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 647 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 648 cvtp (ViewP e p)      = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
 649
 650 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 651 cvtPatFld (s,p)
 652   = do  { s' <- vNameL s; p' <- cvtPat p
 653         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 654
 655 -----------------------------------------------------------
 656 --      Types and type variables
 657
 658 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
 659 cvtTvs tvs = mapM cvt_tv tvs
 660
 661 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 662 cvt_tv (TH.PlainTV nm)
 663   = do { nm' <- tName nm
 664        ; returnL $ UserTyVar nm' placeHolderKind
 665        }
 666 cvt_tv (TH.KindedTV nm ki)
 667   = do { nm' <- tName nm
 668        ; returnL $ KindedTyVar nm' (cvtKind ki)
 669        }
 670
 671 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 672 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 673
 674 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
 675 cvtPred (TH.ClassP cla tys)
 676   = do { cla' <- if isVarName cla then tName cla else tconName cla
 677        ; tys' <- mapM cvtType tys
 678        ; returnL $ HsClassP cla' tys'
 679        }
 680 cvtPred (TH.EqualP ty1 ty2)
 681   = do { ty1' <- cvtType ty1
 682        ; ty2' <- cvtType ty2
 683        ; returnL $ HsEqualP ty1' ty2'
 684        }
 685
 686 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
 687 cvtPredTy ty
 688   = do  { (head, tys') <- split_ty_app ty
 689         ; case head of
 690             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 691             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 692             _       -> failWith (ptext (sLit "Malformed predicate") <+>
 693                        text (TH.pprint ty)) }
 694
 695 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 696 cvtType ty
 697   = do { (head_ty, tys') <- split_ty_app ty
 698        ; case head_ty of
 699            TupleT n
 700              | length tys' == n         -- Saturated
 701              -> if n==1 then return (head tys') -- Singleton tuples treated
 702                                                 -- like nothing (ie just parens)
 703                         else returnL (HsTupleTy Boxed tys')
 704              | n == 1
 705              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 706              | otherwise
 707              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 708            UnboxedTupleT n
 709              | length tys' == n         -- Saturated
 710              -> if n==1 then return (head tys') -- Singleton tuples treated
 711                                                 -- like nothing (ie just parens)
 712                         else returnL (HsTupleTy Unboxed tys')
 713              | n == 1
 714              -> failWith (ptext (sLit "Illegal 1-unboxed-tuple type constructor"))
 715              | otherwise
 716              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
 717            ArrowT
 718              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 719              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
 720            ListT
 721              | [x']    <- tys' -> returnL (HsListTy x')
 722              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
 723            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 724            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 725
 726            ForallT tvs cxt ty
 727              | null tys'
 728              -> do { tvs' <- cvtTvs tvs
 729                    ; cxt' <- cvtContext cxt
 730                    ; ty'  <- cvtType ty
 731                    ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
 732                    }
 733
 734            SigT ty ki
 735              -> do { ty' <- cvtType ty
 736                    ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
 737                    }
 738
 739            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 740     }
 741   where
 742     mk_apps head_ty []       = returnL head_ty
 743     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
 744                                   ; mk_apps (HsAppTy head_ty' ty) tys }
 745
 746 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 747 split_ty_app ty = go ty []
 748   where
 749     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 750     go f as           = return (f,as)
 751
 752 cvtKind :: TH.Kind -> Type.Kind
 753 cvtKind StarK          = liftedTypeKind
 754 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
 755
 756 -----------------------------------------------------------
 757
 758
 759 -----------------------------------------------------------
 760 -- some useful things
 761
 762 overloadedLit :: Lit -> Bool
 763 -- True for literals that Haskell treats as overloaded
 764 overloadedLit (IntegerL  _) = True
 765 overloadedLit (RationalL _) = True
 766 overloadedLit _             = False
 767
 768 void :: Type.Type
 769 void = placeHolderType
 770
 771 cvtFractionalLit :: Rational -> FractionalLit
 772 cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
 773
 774 --------------------------------------------------------------------
 775 --      Turning Name back into RdrName
 776 --------------------------------------------------------------------
 777
 778 -- variable names
 779 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 780 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 781
 782 vNameL n = wrapL (vName n)
 783 vName n = cvtName OccName.varName n
 784
 785 -- Constructor function names; this is Haskell source, hence srcDataName
 786 cNameL n = wrapL (cName n)
 787 cName n = cvtName OccName.dataName n
 788
 789 -- Type variable names
 790 tName n = cvtName OccName.tvName n
 791
 792 -- Type Constructor names
 793 tconNameL n = wrapL (tconName n)
 794 tconName n = cvtName OccName.tcClsName n
 795
 796 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 797 cvtName ctxt_ns (TH.Name occ flavour)
 798   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 799   | otherwise                   = force rdr_name >> return rdr_name
 800   where
 801     occ_str = TH.occString occ
 802     rdr_name = thRdrName ctxt_ns occ_str flavour
 803
 804 okOcc :: OccName.NameSpace -> String -> Bool
 805 okOcc _  []      = False
 806 okOcc ns str@(c:_)
 807   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
 808   | otherwise                 = startsConId c || startsConSym c || str == "[]"
 809
 810 -- Determine the name space of a name in a type
 811 --
 812 isVarName :: TH.Name -> Bool
 813 isVarName (TH.Name occ _)
 814   = case TH.occString occ of
 815       ""    -> False
 816       (c:_) -> startsVarId c || startsVarSym c
 817
 818 badOcc :: OccName.NameSpace -> String -> SDoc
 819 badOcc ctxt_ns occ
 820   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
 821         <+> ptext (sLit "name:") <+> quotes (text occ)
 822
 823 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 824 -- This turns a Name into a RdrName
 825 -- The passed-in name space tells what the context is expecting;
 826 --      use it unless the TH name knows what name-space it comes
 827 --      from, in which case use the latter
 828 --
 829 -- ToDo: we may generate silly RdrNames, by passing a name space
 830 --       that doesn't match the string, like VarName ":+",
 831 --       which will give confusing error messages later
 832 --
 833 -- The strict applications ensure that any buried exceptions get forced
 834 thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
 835 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 836 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 837 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 838 thRdrName ctxt_ns occ TH.NameS
 839   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 840   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 841
 842 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
 843 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 844
 845 thRdrNameGuesses :: TH.Name -> [RdrName]
 846 thRdrNameGuesses (TH.Name occ flavour)
 847   -- This special case for NameG ensures that we don't generate duplicates in the output list
 848   | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
 849   | otherwise                         = [ thRdrName gns occ_str flavour
 850                                         | gns <- guessed_nss]
 851   where
 852     -- guessed_ns are the name spaces guessed from looking at the TH name
 853     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 854                 | otherwise                       = [OccName.varName, OccName.tvName]
 855     occ_str = TH.occString occ
 856
 857 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 858 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 859 -- We must generate an Exact name, just as the parser does
 860 isBuiltInOcc ctxt_ns occ
 861   = case occ of
 862         ":"              -> Just (Name.getName consDataCon)
 863         "[]"             -> Just (Name.getName nilDataCon)
 864         "()"             -> Just (tup_name 0)
 865         '(' : ',' : rest -> go_tuple 2 rest
 866         _                -> Nothing
 867   where
 868     go_tuple n ")"          = Just (tup_name n)
 869     go_tuple n (',' : rest) = go_tuple (n+1) rest
 870     go_tuple _ _            = Nothing
 871
 872     tup_name n
 873         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
 874         | otherwise                        = Name.getName (tupleCon Boxed n)
 875
 876 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 877 mk_uniq_occ ns occ uniq
 878   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 879         -- See Note [Unique OccNames from Template Haskell]
 880
 881 -- The packing and unpacking is rather turgid :-(
 882 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 883 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 884
 885 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 886 mk_ghc_ns TH.DataName  = OccName.dataName
 887 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 888 mk_ghc_ns TH.VarName   = OccName.varName
 889
 890 mk_mod :: TH.ModName -> ModuleName
 891 mk_mod mod = mkModuleName (TH.modString mod)
 892
 893 mk_pkg :: TH.PkgName -> PackageId
 894 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 895
 896 mk_uniq :: Int# -> Unique
 897 mk_uniq u = mkUniqueGrimily (I# u)
 898 \end{code}
 899
 900 Note [Unique OccNames from Template Haskell]
 901 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 902 The idea here is to make a name that
 903   a) the user could not possibly write (it has a "["
 904      and letters or digits from the unique)
 905   b) cannot clash with another NameU
 906 Previously I generated an Exact RdrName with mkInternalName.  This
 907 works fine for local binders, but does not work at all for top-level
 908 binders, which must have External Names, since they are rapidly baked
 909 into data constructors and the like.  Baling out and generating an
 910 unqualified RdrName here is the simple solution
 911
 912 See also Note [Suppressing uniques in OccNames] in OccName, which
 913 suppresses the unique when opt_SuppressUniques is on.