compiler/hsSyn/Convert.lhs

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