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