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