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 kind)
 177   = do { (_, tc', tvs', _) <- cvt_tycl_hdr [] tc tvs
 178        ; let kind' = fmap cvtKind kind
 179        ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind')
 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.TyVarBndr]
 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 [PlainTV 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     collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
 249     collect (SigT ty _)         = collect ty
 250
 251 ---------------------------------------------------
 252 --      Data types
 253 -- Can't handle GADTs yet
 254 ---------------------------------------------------
 255
 256 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
 257
 258 cvtConstr (NormalC c strtys)
 259   = do  { c'   <- cNameL c
 260         ; cxt' <- returnL []
 261         ; tys' <- mapM cvt_arg strtys
 262         ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
 263
 264 cvtConstr (RecC c varstrtys)
 265   = do  { c'    <- cNameL c
 266         ; cxt'  <- returnL []
 267         ; args' <- mapM cvt_id_arg varstrtys
 268         ; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
 269
 270 cvtConstr (InfixC st1 c st2)
 271   = do  { c' <- cNameL c
 272         ; cxt' <- returnL []
 273         ; st1' <- cvt_arg st1
 274         ; st2' <- cvt_arg st2
 275         ; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
 276
 277 cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
 278   = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
 279
 280 cvtConstr (ForallC tvs ctxt con)
 281   = do  { L _ con' <- cvtConstr con
 282         ; tvs'  <- cvtTvs tvs
 283         ; ctxt' <- cvtContext ctxt
 284         ; case con' of
 285             ConDecl l _ [] (L _ []) x ResTyH98 _
 286               -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
 287             _ -> panic "ForallC: Can't happen" }
 288
 289 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 290 cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
 291 cvt_arg (NotStrict, ty) = cvtType ty
 292
 293 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
 294 cvt_id_arg (i, str, ty)
 295   = do  { i' <- vNameL i
 296         ; ty' <- cvt_arg (str,ty)
 297         ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
 298
 299 cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
 300 cvtDerivs [] = return Nothing
 301 cvtDerivs cs = do { cs' <- mapM cvt_one cs
 302                   ; return (Just cs') }
 303         where
 304           cvt_one c = do { c' <- tconName c
 305                          ; returnL $ HsPredTy $ HsClassP c' [] }
 306
 307 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
 308 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
 309
 310 noExistentials :: [LHsTyVarBndr RdrName]
 311 noExistentials = []
 312
 313 ------------------------------------------
 314 --      Foreign declarations
 315 ------------------------------------------
 316
 317 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 318 cvtForD (ImportF callconv safety from nm ty)
 319   | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
 320   = do  { nm' <- vNameL nm
 321         ; ty' <- cvtType ty
 322         ; let i = CImport (cvt_conv callconv) safety' c_header cis
 323         ; return $ ForeignImport nm' ty' i }
 324
 325   | otherwise
 326   = failWith $ text (show from)<+> ptext (sLit "is not a valid ccall impent")
 327   where
 328     safety' = case safety of
 329                      Unsafe     -> PlayRisky
 330                      Safe       -> PlaySafe False
 331                      Threadsafe -> PlaySafe True
 332
 333 cvtForD (ExportF callconv as nm ty)
 334   = do  { nm' <- vNameL nm
 335         ; ty' <- cvtType ty
 336         ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
 337         ; return $ ForeignExport nm' ty' e }
 338
 339 cvt_conv :: TH.Callconv -> CCallConv
 340 cvt_conv TH.CCall   = CCallConv
 341 cvt_conv TH.StdCall = StdCallConv
 342
 343 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 344 parse_ccall_impent nm s
 345  = case lex_ccall_impent s of
 346        Just ["dynamic"] -> Just (nilFS, CFunction DynamicTarget)
 347        Just ["wrapper"] -> Just (nilFS, CWrapper)
 348        Just ("static":ts) -> parse_ccall_impent_static nm ts
 349        Just ts -> parse_ccall_impent_static nm ts
 350        Nothing -> Nothing
 351
 352 -- XXX we should be sharing code with RdrHsSyn.parseCImport
 353 parse_ccall_impent_static :: String
 354                           -> [String]
 355                           -> Maybe (FastString, CImportSpec)
 356 parse_ccall_impent_static nm ts
 357  = case ts of
 358      [               ] -> mkFun nilFS                 nm
 359      [       "&", cid] -> mkLbl nilFS                 cid
 360      [fname, "&"     ] -> mkLbl (mkFastString fname)  nm
 361      [fname, "&", cid] -> mkLbl (mkFastString fname)  cid
 362      [       "&"     ] -> mkLbl nilFS                 nm
 363      [fname,      cid] -> mkFun (mkFastString fname)  cid
 364      [            cid]
 365           | is_cid cid -> mkFun nilFS                 cid
 366           | otherwise  -> mkFun (mkFastString cid)    nm
 367            -- tricky case when there's a single string: "foo.h" is a header,
 368            -- but "foo" is a C identifier, and we tell the difference by
 369            -- checking for a valid C identifier (see is_cid below).
 370      _anything_else    -> Nothing
 371
 372     where is_cid :: String -> Bool
 373           is_cid x = all (/= '.') x && (isAlpha (head x) || head x == '_')
 374
 375           mkLbl :: FastString -> String -> Maybe (FastString, CImportSpec)
 376           mkLbl fname lbl  = Just (fname, CLabel (mkFastString lbl))
 377
 378           mkFun :: FastString -> String -> Maybe (FastString, CImportSpec)
 379           mkFun fname lbl  = Just (fname, CFunction (StaticTarget (mkFastString lbl)))
 380
 381 -- This code is tokenising something like "foo.h &bar", eg.
 382 --   ""           -> Just []
 383 --   "foo.h"      -> Just ["foo.h"]
 384 --   "foo.h &bar" -> Just ["foo.h","&","bar"]
 385 --   "&"          -> Just ["&"]
 386 -- Nothing is returned for a parse error.
 387 lex_ccall_impent :: String -> Maybe [String]
 388 lex_ccall_impent "" = Just []
 389 lex_ccall_impent ('&':xs) = fmap ("&":) $ lex_ccall_impent xs
 390 lex_ccall_impent (' ':xs) = lex_ccall_impent xs
 391 lex_ccall_impent ('\t':xs) = lex_ccall_impent xs
 392 lex_ccall_impent xs = case span is_valid xs of
 393                           ("", _) -> Nothing
 394                           (t, xs') -> fmap (t:) $ lex_ccall_impent xs'
 395     where is_valid :: Char -> Bool
 396           is_valid c = isAscii c && (isAlphaNum c || c `elem` "._")
 397
 398 ------------------------------------------
 399 --              Pragmas
 400 ------------------------------------------
 401
 402 cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
 403 cvtPragmaD (InlineP nm ispec)
 404   = do { nm'    <- vNameL nm
 405        ; return $ InlineSig nm' (cvtInlineSpec (Just ispec))
 406        }
 407 cvtPragmaD (SpecialiseP nm ty opt_ispec)
 408   = do { nm'    <- vNameL nm
 409        ; ty'    <- cvtType ty
 410        ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec)
 411        }
 412
 413 cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlineSpec
 414 cvtInlineSpec Nothing
 415   = defaultInlineSpec
 416 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
 417   = mkInlineSpec opt_activation' matchinfo inline
 418   where
 419     matchinfo       = cvtRuleMatchInfo conlike
 420     opt_activation' = fmap cvtActivation opt_activation
 421
 422     cvtRuleMatchInfo False = FunLike
 423     cvtRuleMatchInfo True  = ConLike
 424
 425     cvtActivation (False, phase) = ActiveBefore phase
 426     cvtActivation (True , phase) = ActiveAfter  phase
 427
 428 ---------------------------------------------------
 429 --              Declarations
 430 ---------------------------------------------------
 431
 432 cvtDecs :: [TH.Dec] -> CvtM (HsLocalBinds RdrName)
 433 cvtDecs [] = return EmptyLocalBinds
 434 cvtDecs ds = do { (binds, sigs) <- cvtBindsAndSigs ds
 435                 ; return (HsValBinds (ValBindsIn binds sigs)) }
 436
 437 cvtBindsAndSigs :: [TH.Dec] -> CvtM (Bag (LHsBind RdrName), [LSig RdrName])
 438 cvtBindsAndSigs ds
 439   = do { binds' <- mapM cvtBind binds
 440        ; sigs' <- mapM cvtSig sigs
 441        ; return (listToBag binds', sigs') }
 442   where
 443     (sigs, binds) = partition is_sig ds
 444
 445     is_sig (TH.SigD _ _)  = True
 446     is_sig (TH.PragmaD _) = True
 447     is_sig _              = False
 448
 449 cvtSig :: TH.Dec -> CvtM (LSig RdrName)
 450 cvtSig (TH.SigD nm ty)
 451   = do { nm' <- vNameL nm
 452        ; ty' <- cvtType ty
 453        ; returnL (Hs.TypeSig nm' ty')
 454        }
 455 cvtSig (TH.PragmaD prag)
 456   = do { prag' <- cvtPragmaD prag
 457        ; returnL prag'
 458        }
 459 cvtSig _ = panic "Convert.cvtSig: Signature expected"
 460
 461 cvtBind :: TH.Dec -> CvtM (LHsBind RdrName)
 462 -- Used only for declarations in a 'let/where' clause,
 463 -- not for top level decls
 464 cvtBind (TH.ValD (TH.VarP s) body ds)
 465   = do  { s' <- vNameL s
 466         ; cl' <- cvtClause (Clause [] body ds)
 467         ; returnL $ mkFunBind s' [cl'] }
 468
 469 cvtBind (TH.FunD nm cls)
 470   | null cls
 471   = failWith (ptext (sLit "Function binding for")
 472                     <+> quotes (text (TH.pprint nm))
 473                     <+> ptext (sLit "has no equations"))
 474   | otherwise
 475   = do  { nm' <- vNameL nm
 476         ; cls' <- mapM cvtClause cls
 477         ; returnL $ mkFunBind nm' cls' }
 478
 479 cvtBind (TH.ValD p body ds)
 480   = do  { p' <- cvtPat p
 481         ; g' <- cvtGuard body
 482         ; ds' <- cvtDecs ds
 483         ; returnL $ PatBind { pat_lhs = p', pat_rhs = GRHSs g' ds',
 484                               pat_rhs_ty = void, bind_fvs = placeHolderNames } }
 485
 486 cvtBind d
 487   = failWith (sep [ptext (sLit "Illegal kind of declaration in where clause"),
 488                    nest 2 (text (TH.pprint d))])
 489
 490 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
 491 cvtClause (Clause ps body wheres)
 492   = do  { ps' <- cvtPats ps
 493         ; g'  <- cvtGuard body
 494         ; ds' <- cvtDecs wheres
 495         ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
 496
 497
 498 -------------------------------------------------------------------
 499 --              Expressions
 500 -------------------------------------------------------------------
 501
 502 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
 503 cvtl e = wrapL (cvt e)
 504   where
 505     cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
 506     cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
 507     cvt (LitE l)
 508       | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
 509       | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
 510
 511     cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
 512     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
 513                             ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
 514     cvt (TupE [e])     = cvt e  -- Singleton tuples treated like nothing (just parens)
 515     cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple es' Boxed }
 516     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
 517                             ; return $ HsIf x' y' z' }
 518     cvt (LetE ds e)    = do { ds' <- cvtDecs ds; e' <- cvtl e; return $ HsLet ds' e' }
 519     cvt (CaseE e ms)
 520        | null ms       = failWith (ptext (sLit "Case expression with no alternatives"))
 521        | otherwise     = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
 522                             ; return $ HsCase e' (mkMatchGroup ms') }
 523     cvt (DoE ss)       = cvtHsDo DoExpr ss
 524     cvt (CompE ss)     = cvtHsDo ListComp ss
 525     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
 526     cvt (ListE xs)
 527       | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
 528              -- Note [Converting strings]
 529       | otherwise                    = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
 530     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
 531                                           ; e' <- returnL $ OpApp x' s' undefined y'
 532                                           ; return $ HsPar e' }
 533     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
 534                                           ; sec <- returnL $ SectionR s' y'
 535                                           ; return $ HsPar sec }
 536     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
 537                                           ; sec <- returnL $ SectionL x' s'
 538                                           ; return $ HsPar sec }
 539     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 540
 541     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
 542                               ; return $ ExprWithTySig e' t' }
 543     cvt (RecConE c flds) = do { c' <- cNameL c
 544                               ; flds' <- mapM cvtFld flds
 545                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
 546     cvt (RecUpdE e flds) = do { e' <- cvtl e
 547                               ; flds' <- mapM cvtFld flds
 548                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
 549
 550 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
 551 cvtFld (v,e)
 552   = do  { v' <- vNameL v; e' <- cvtl e
 553         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
 554
 555 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 556 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
 557 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
 558 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 559 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 560
 561 -------------------------------------
 562 --      Do notation and statements
 563 -------------------------------------
 564
 565 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
 566 cvtHsDo do_or_lc stmts
 567   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
 568   | otherwise
 569   = do  { stmts' <- cvtStmts stmts
 570         ; let body = case last stmts' of
 571                         L _ (ExprStmt body _ _) -> body
 572                         _                       -> panic "Malformed body"
 573         ; return $ HsDo do_or_lc (init stmts') body void }
 574
 575 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
 576 cvtStmts = mapM cvtStmt
 577
 578 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
 579 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 580 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 581 cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
 582 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
 583                        where
 584                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 585
 586 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 587 cvtMatch (TH.Match p body decs)
 588   = do  { p' <- cvtPat p
 589         ; g' <- cvtGuard body
 590         ; decs' <- cvtDecs decs
 591         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
 592
 593 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
 594 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 595 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
 596
 597 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
 598 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 599                               ; g' <- returnL $ mkExprStmt ge'
 600                               ; returnL $ GRHS [g'] rhs' }
 601 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 602                               ; returnL $ GRHS gs' rhs' }
 603
 604 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 605 cvtOverLit (IntegerL i)
 606   = do { force i; return $ mkHsIntegral i placeHolderType}
 607 cvtOverLit (RationalL r)
 608   = do { force r; return $ mkHsFractional r placeHolderType}
 609 cvtOverLit (StringL s)
 610   = do { let { s' = mkFastString s }
 611        ; force s'
 612        ; return $ mkHsIsString s' placeHolderType
 613        }
 614 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 615 -- An Integer is like an (overloaded) '3' in a Haskell source program
 616 -- Similarly 3.5 for fractionals
 617
 618 {- Note [Converting strings]
 619 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 620 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
 621 a string literal for "xy".  Of course, we might hope to get
 622 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
 623 if it isn't a literal string
 624 -}
 625
 626 allCharLs :: [TH.Exp] -> Maybe String
 627 -- Note [Converting strings]
 628 allCharLs (LitE (CharL c) : xs)
 629   | Just cs <- allCharLs xs = Just (c:cs)
 630 allCharLs [] = Just []
 631 allCharLs _  = Nothing
 632
 633 cvtLit :: Lit -> CvtM HsLit
 634 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 635 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
 636 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 637 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 638 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 639 cvtLit (StringL s)
 640   = do { let { s' = mkFastString s }
 641        ; force s'
 642        ; return $ HsString s'
 643        }
 644 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
 645
 646 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 647 cvtPats pats = mapM cvtPat pats
 648
 649 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 650 cvtPat pat = wrapL (cvtp pat)
 651
 652 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 653 cvtp (TH.LitP l)
 654   | overloadedLit l   = do { l' <- cvtOverLit l
 655                            ; return (mkNPat l' Nothing) }
 656                                   -- Not right for negative patterns;
 657                                   -- need to think about that!
 658   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 659 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 660 cvtp (TupP [p])       = cvtp p
 661 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 662 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 663 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 664                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 665 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 666 cvtp (BangP p)        = do { p' <- cvtPat p; return $ BangPat p' }
 667 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 668 cvtp TH.WildP         = return $ WildPat void
 669 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 670                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 671 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 672 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 673
 674 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 675 cvtPatFld (s,p)
 676   = do  { s' <- vNameL s; p' <- cvtPat p
 677         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 678
 679 -----------------------------------------------------------
 680 --      Types and type variables
 681
 682 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
 683 cvtTvs tvs = mapM cvt_tv tvs
 684
 685 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 686 cvt_tv (TH.PlainTV nm)
 687   = do { nm' <- tName nm
 688        ; returnL $ UserTyVar nm'
 689        }
 690 cvt_tv (TH.KindedTV nm ki)
 691   = do { nm' <- tName nm
 692        ; returnL $ KindedTyVar nm' (cvtKind ki)
 693        }
 694
 695 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 696 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 697
 698 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
 699 cvtPred (TH.ClassP cla tys)
 700   = do { cla' <- if isVarName cla then tName cla else tconName cla
 701        ; tys' <- mapM cvtType tys
 702        ; returnL $ HsClassP cla' tys'
 703        }
 704 cvtPred (TH.EqualP ty1 ty2)
 705   = do { ty1' <- cvtType ty1
 706        ; ty2' <- cvtType ty2
 707        ; returnL $ HsEqualP ty1' ty2'
 708        }
 709
 710 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
 711 cvtPredTy ty
 712   = do  { (head, tys') <- split_ty_app ty
 713         ; case head of
 714             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 715             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 716             _       -> failWith (ptext (sLit "Malformed predicate") <+>
 717                        text (TH.pprint ty)) }
 718
 719 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 720 cvtType ty
 721   = do { (head_ty, tys') <- split_ty_app ty
 722        ; case head_ty of
 723            TupleT n
 724              | length tys' == n         -- Saturated
 725              -> if n==1 then return (head tys') -- Singleton tuples treated
 726                                                 -- like nothing (ie just parens)
 727                         else returnL (HsTupleTy Boxed tys')
 728              | n == 1
 729              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 730              | otherwise
 731              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 732            ArrowT
 733              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 734              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
 735            ListT
 736              | [x']    <- tys' -> returnL (HsListTy x')
 737              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
 738            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 739            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 740
 741            ForallT tvs cxt ty
 742              | null tys'
 743              -> do { tvs' <- cvtTvs tvs
 744                    ; cxt' <- cvtContext cxt
 745                    ; ty'  <- cvtType ty
 746                    ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
 747                    }
 748
 749            SigT ty ki
 750              -> do { ty' <- cvtType ty
 751                    ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
 752                    }
 753
 754            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 755     }
 756   where
 757     mk_apps head_ty []       = returnL head_ty
 758     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
 759                                   ; mk_apps (HsAppTy head_ty' ty) tys }
 760
 761 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 762 split_ty_app ty = go ty []
 763   where
 764     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 765     go f as           = return (f,as)
 766
 767 cvtKind :: TH.Kind -> Type.Kind
 768 cvtKind StarK          = liftedTypeKind
 769 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
 770
 771 -----------------------------------------------------------
 772
 773
 774 -----------------------------------------------------------
 775 -- some useful things
 776
 777 overloadedLit :: Lit -> Bool
 778 -- True for literals that Haskell treats as overloaded
 779 overloadedLit (IntegerL  _) = True
 780 overloadedLit (RationalL _) = True
 781 overloadedLit _             = False
 782
 783 void :: Type.Type
 784 void = placeHolderType
 785
 786 --------------------------------------------------------------------
 787 --      Turning Name back into RdrName
 788 --------------------------------------------------------------------
 789
 790 -- variable names
 791 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 792 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 793
 794 vNameL n = wrapL (vName n)
 795 vName n = cvtName OccName.varName n
 796
 797 -- Constructor function names; this is Haskell source, hence srcDataName
 798 cNameL n = wrapL (cName n)
 799 cName n = cvtName OccName.dataName n
 800
 801 -- Type variable names
 802 tName n = cvtName OccName.tvName n
 803
 804 -- Type Constructor names
 805 tconNameL n = wrapL (tconName n)
 806 tconName n = cvtName OccName.tcClsName n
 807
 808 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 809 cvtName ctxt_ns (TH.Name occ flavour)
 810   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 811   | otherwise                   = force (thRdrName ctxt_ns occ_str flavour)
 812   where
 813     occ_str = TH.occString occ
 814
 815 okOcc :: OccName.NameSpace -> String -> Bool
 816 okOcc _  []      = False
 817 okOcc ns str@(c:_)
 818   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
 819   | otherwise                 = startsConId c || startsConSym c || str == "[]"
 820
 821 -- Determine the name space of a name in a type
 822 --
 823 isVarName :: TH.Name -> Bool
 824 isVarName (TH.Name occ _)
 825   = case TH.occString occ of
 826       ""    -> False
 827       (c:_) -> startsVarId c || startsVarSym c
 828
 829 badOcc :: OccName.NameSpace -> String -> SDoc
 830 badOcc ctxt_ns occ
 831   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
 832         <+> ptext (sLit "name:") <+> quotes (text occ)
 833
 834 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 835 -- This turns a Name into a RdrName
 836 -- The passed-in name space tells what the context is expecting;
 837 --      use it unless the TH name knows what name-space it comes
 838 --      from, in which case use the latter
 839 --
 840 -- ToDo: we may generate silly RdrNames, by passing a name space
 841 --       that doesn't match the string, like VarName ":+",
 842 --       which will give confusing error messages later
 843 --
 844 -- The strict applications ensure that any buried exceptions get forced
 845 thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
 846 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 847 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 848 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 849 thRdrName ctxt_ns occ TH.NameS
 850   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 851   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 852
 853 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
 854 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 855
 856 thRdrNameGuesses :: TH.Name -> [RdrName]
 857 thRdrNameGuesses (TH.Name occ flavour)
 858   -- This special case for NameG ensures that we don't generate duplicates in the output list
 859   | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
 860   | otherwise                         = [ thRdrName gns occ_str flavour
 861                                         | gns <- guessed_nss]
 862   where
 863     -- guessed_ns are the name spaces guessed from looking at the TH name
 864     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 865                 | otherwise                       = [OccName.varName, OccName.tvName]
 866     occ_str = TH.occString occ
 867
 868 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 869 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 870 -- We must generate an Exact name, just as the parser does
 871 isBuiltInOcc ctxt_ns occ
 872   = case occ of
 873         ":"              -> Just (Name.getName consDataCon)
 874         "[]"             -> Just (Name.getName nilDataCon)
 875         "()"             -> Just (tup_name 0)
 876         '(' : ',' : rest -> go_tuple 2 rest
 877         _                -> Nothing
 878   where
 879     go_tuple n ")"          = Just (tup_name n)
 880     go_tuple n (',' : rest) = go_tuple (n+1) rest
 881     go_tuple _ _            = Nothing
 882
 883     tup_name n
 884         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
 885         | otherwise                        = Name.getName (tupleCon Boxed n)
 886
 887 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 888 mk_uniq_occ ns occ uniq
 889   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 890         -- The idea here is to make a name that
 891         -- a) the user could not possibly write, and
 892         -- b) cannot clash with another NameU
 893         -- Previously I generated an Exact RdrName with mkInternalName.
 894         -- This works fine for local binders, but does not work at all for
 895         -- top-level binders, which must have External Names, since they are
 896         -- rapidly baked into data constructors and the like.  Baling out
 897         -- and generating an unqualified RdrName here is the simple solution
 898
 899 -- The packing and unpacking is rather turgid :-(
 900 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 901 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 902
 903 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 904 mk_ghc_ns TH.DataName  = OccName.dataName
 905 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 906 mk_ghc_ns TH.VarName   = OccName.varName
 907
 908 mk_mod :: TH.ModName -> ModuleName
 909 mk_mod mod = mkModuleName (TH.modString mod)
 910
 911 mk_pkg :: TH.PkgName -> PackageId
 912 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 913
 914 mk_uniq :: Int# -> Unique
 915 mk_uniq u = mkUniqueGrimily (I# u)
 916 \end{code}
 917