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