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