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