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)     = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
 512     cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
 513                                           ; e' <- returnL $ OpApp x' s' undefined y'
 514                                           ; return $ HsPar e' }
 515     cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
 516                                           ; sec <- returnL $ SectionR s' y'
 517                                           ; return $ HsPar sec }
 518     cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
 519                                           ; sec <- returnL $ SectionL x' s'
 520                                           ; return $ HsPar sec }
 521     cvt (InfixE Nothing  s Nothing ) = cvt s    -- Can I indicate this is an infix thing?
 522
 523     cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
 524                               ; return $ ExprWithTySig e' t' }
 525     cvt (RecConE c flds) = do { c' <- cNameL c
 526                               ; flds' <- mapM cvtFld flds
 527                               ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
 528     cvt (RecUpdE e flds) = do { e' <- cvtl e
 529                               ; flds' <- mapM cvtFld flds
 530                               ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
 531
 532 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
 533 cvtFld (v,e)
 534   = do  { v' <- vNameL v; e' <- cvtl e
 535         ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
 536
 537 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
 538 cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
 539 cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
 540 cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
 541 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
 542
 543 -------------------------------------
 544 --      Do notation and statements
 545 -------------------------------------
 546
 547 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
 548 cvtHsDo do_or_lc stmts
 549   | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
 550   | otherwise
 551   = do  { stmts' <- cvtStmts stmts
 552         ; let body = case last stmts' of
 553                         L _ (ExprStmt body _ _) -> body
 554                         _                       -> panic "Malformed body"
 555         ; return $ HsDo do_or_lc (init stmts') body void }
 556
 557 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
 558 cvtStmts = mapM cvtStmt
 559
 560 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
 561 cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 562 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 563 cvtStmt (TH.LetS ds)   = do { ds' <- cvtDecs ds; returnL $ LetStmt ds' }
 564 cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
 565                        where
 566                          cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
 567
 568 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 569 cvtMatch (TH.Match p body decs)
 570   = do  { p' <- cvtPat p
 571         ; g' <- cvtGuard body
 572         ; decs' <- cvtDecs decs
 573         ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
 574
 575 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
 576 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
 577 cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
 578
 579 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
 580 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
 581                               ; g' <- returnL $ mkExprStmt ge'
 582                               ; returnL $ GRHS [g'] rhs' }
 583 cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 584                               ; returnL $ GRHS gs' rhs' }
 585
 586 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 587 cvtOverLit (IntegerL i)
 588   = do { force i; return $ mkHsIntegral i placeHolderType}
 589 cvtOverLit (RationalL r)
 590   = do { force r; return $ mkHsFractional r placeHolderType}
 591 cvtOverLit (StringL s)
 592   = do { let { s' = mkFastString s }
 593        ; force s'
 594        ; return $ mkHsIsString s' placeHolderType
 595        }
 596 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
 597 -- An Integer is like an (overloaded) '3' in a Haskell source program
 598 -- Similarly 3.5 for fractionals
 599
 600 cvtLit :: Lit -> CvtM HsLit
 601 cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
 602 cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
 603 cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim f }
 604 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
 605 cvtLit (CharL c)       = do { force c; return $ HsChar c }
 606 cvtLit (StringL s)
 607   = do { let { s' = mkFastString s }
 608        ; force s'
 609        ; return $ HsString s'
 610        }
 611 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
 612
 613 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
 614 cvtPats pats = mapM cvtPat pats
 615
 616 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
 617 cvtPat pat = wrapL (cvtp pat)
 618
 619 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
 620 cvtp (TH.LitP l)
 621   | overloadedLit l   = do { l' <- cvtOverLit l
 622                            ; return (mkNPat l' Nothing) }
 623                                   -- Not right for negative patterns;
 624                                   -- need to think about that!
 625   | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' }
 626 cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' }
 627 cvtp (TupP [p])       = cvtp p
 628 cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
 629 cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
 630 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
 631                            ; return $ ConPatIn s' (InfixCon p1' p2') }
 632 cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' }
 633 cvtp (BangP p)        = do { p' <- cvtPat p; return $ BangPat p' }
 634 cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 635 cvtp TH.WildP         = return $ WildPat void
 636 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 637                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 638 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 639 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 640
 641 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 642 cvtPatFld (s,p)
 643   = do  { s' <- vNameL s; p' <- cvtPat p
 644         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 645
 646 -----------------------------------------------------------
 647 --      Types and type variables
 648
 649 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
 650 cvtTvs tvs = mapM cvt_tv tvs
 651
 652 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 653 cvt_tv (TH.PlainTV nm)
 654   = do { nm' <- tName nm
 655        ; returnL $ UserTyVar nm'
 656        }
 657 cvt_tv (TH.KindedTV nm ki)
 658   = do { nm' <- tName nm
 659        ; returnL $ KindedTyVar nm' (cvtKind ki)
 660        }
 661
 662 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 663 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 664
 665 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
 666 cvtPred (TH.ClassP cla tys)
 667   = do { cla' <- if isVarName cla then tName cla else tconName cla
 668        ; tys' <- mapM cvtType tys
 669        ; returnL $ HsClassP cla' tys'
 670        }
 671 cvtPred (TH.EqualP ty1 ty2)
 672   = do { ty1' <- cvtType ty1
 673        ; ty2' <- cvtType ty2
 674        ; returnL $ HsEqualP ty1' ty2'
 675        }
 676
 677 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
 678 cvtPredTy ty
 679   = do  { (head, tys') <- split_ty_app ty
 680         ; case head of
 681             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 682             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 683             _       -> failWith (ptext (sLit "Malformed predicate") <+>
 684                        text (TH.pprint ty)) }
 685
 686 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 687 cvtType ty
 688   = do { (head_ty, tys') <- split_ty_app ty
 689        ; case head_ty of
 690            TupleT n
 691              | length tys' == n         -- Saturated
 692              -> if n==1 then return (head tys') -- Singleton tuples treated
 693                                                 -- like nothing (ie just parens)
 694                         else returnL (HsTupleTy Boxed tys')
 695              | n == 1
 696              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 697              | otherwise
 698              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 699            ArrowT
 700              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 701              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
 702            ListT
 703              | [x']    <- tys' -> returnL (HsListTy x')
 704              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
 705            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 706            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 707
 708            ForallT tvs cxt ty
 709              | null tys'
 710              -> do { tvs' <- cvtTvs tvs
 711                    ; cxt' <- cvtContext cxt
 712                    ; ty'  <- cvtType ty
 713                    ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
 714                    }
 715
 716            SigT ty ki
 717              -> do { ty' <- cvtType ty
 718                    ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
 719                    }
 720
 721            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 722     }
 723   where
 724     mk_apps head_ty []       = returnL head_ty
 725     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
 726                                   ; mk_apps (HsAppTy head_ty' ty) tys }
 727
 728 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 729 split_ty_app ty = go ty []
 730   where
 731     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 732     go f as           = return (f,as)
 733
 734 cvtKind :: TH.Kind -> Type.Kind
 735 cvtKind StarK          = liftedTypeKind
 736 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
 737
 738 -----------------------------------------------------------
 739
 740
 741 -----------------------------------------------------------
 742 -- some useful things
 743
 744 overloadedLit :: Lit -> Bool
 745 -- True for literals that Haskell treats as overloaded
 746 overloadedLit (IntegerL  _) = True
 747 overloadedLit (RationalL _) = True
 748 overloadedLit _             = False
 749
 750 void :: Type.Type
 751 void = placeHolderType
 752
 753 --------------------------------------------------------------------
 754 --      Turning Name back into RdrName
 755 --------------------------------------------------------------------
 756
 757 -- variable names
 758 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 759 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 760
 761 vNameL n = wrapL (vName n)
 762 vName n = cvtName OccName.varName n
 763
 764 -- Constructor function names; this is Haskell source, hence srcDataName
 765 cNameL n = wrapL (cName n)
 766 cName n = cvtName OccName.dataName n
 767
 768 -- Type variable names
 769 tName n = cvtName OccName.tvName n
 770
 771 -- Type Constructor names
 772 tconNameL n = wrapL (tconName n)
 773 tconName n = cvtName OccName.tcClsName n
 774
 775 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 776 cvtName ctxt_ns (TH.Name occ flavour)
 777   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 778   | otherwise                   = force (thRdrName ctxt_ns occ_str flavour)
 779   where
 780     occ_str = TH.occString occ
 781
 782 okOcc :: OccName.NameSpace -> String -> Bool
 783 okOcc _  []      = False
 784 okOcc ns str@(c:_)
 785   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
 786   | otherwise                 = startsConId c || startsConSym c || str == "[]"
 787
 788 -- Determine the name space of a name in a type
 789 --
 790 isVarName :: TH.Name -> Bool
 791 isVarName (TH.Name occ _)
 792   = case TH.occString occ of
 793       ""    -> False
 794       (c:_) -> startsVarId c || startsVarSym c
 795
 796 badOcc :: OccName.NameSpace -> String -> SDoc
 797 badOcc ctxt_ns occ
 798   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
 799         <+> ptext (sLit "name:") <+> quotes (text occ)
 800
 801 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 802 -- This turns a Name into a RdrName
 803 -- The passed-in name space tells what the context is expecting;
 804 --      use it unless the TH name knows what name-space it comes
 805 --      from, in which case use the latter
 806 --
 807 -- ToDo: we may generate silly RdrNames, by passing a name space
 808 --       that doesn't match the string, like VarName ":+",
 809 --       which will give confusing error messages later
 810 --
 811 -- The strict applications ensure that any buried exceptions get forced
 812 thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
 813 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 814 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 815 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 816 thRdrName ctxt_ns occ TH.NameS
 817   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 818   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 819
 820 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
 821 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 822
 823 thRdrNameGuesses :: TH.Name -> [RdrName]
 824 thRdrNameGuesses (TH.Name occ flavour)
 825   -- This special case for NameG ensures that we don't generate duplicates in the output list
 826   | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
 827   | otherwise                         = [ thRdrName gns occ_str flavour
 828                                         | gns <- guessed_nss]
 829   where
 830     -- guessed_ns are the name spaces guessed from looking at the TH name
 831     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 832                 | otherwise                       = [OccName.varName, OccName.tvName]
 833     occ_str = TH.occString occ
 834
 835 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 836 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 837 -- We must generate an Exact name, just as the parser does
 838 isBuiltInOcc ctxt_ns occ
 839   = case occ of
 840         ":"              -> Just (Name.getName consDataCon)
 841         "[]"             -> Just (Name.getName nilDataCon)
 842         "()"             -> Just (tup_name 0)
 843         '(' : ',' : rest -> go_tuple 2 rest
 844         _                -> Nothing
 845   where
 846     go_tuple n ")"          = Just (tup_name n)
 847     go_tuple n (',' : rest) = go_tuple (n+1) rest
 848     go_tuple _ _            = Nothing
 849
 850     tup_name n
 851         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
 852         | otherwise                        = Name.getName (tupleCon Boxed n)
 853
 854 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 855 mk_uniq_occ ns occ uniq
 856   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 857         -- The idea here is to make a name that
 858         -- a) the user could not possibly write, and
 859         -- b) cannot clash with another NameU
 860         -- Previously I generated an Exact RdrName with mkInternalName.
 861         -- This works fine for local binders, but does not work at all for
 862         -- top-level binders, which must have External Names, since they are
 863         -- rapidly baked into data constructors and the like.  Baling out
 864         -- and generating an unqualified RdrName here is the simple solution
 865
 866 -- The packing and unpacking is rather turgid :-(
 867 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 868 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 869
 870 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 871 mk_ghc_ns TH.DataName  = OccName.dataName
 872 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 873 mk_ghc_ns TH.VarName   = OccName.varName
 874
 875 mk_mod :: TH.ModName -> ModuleName
 876 mk_mod mod = mkModuleName (TH.modString mod)
 877
 878 mk_pkg :: TH.PkgName -> PackageId
 879 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 880
 881 mk_uniq :: Int# -> Unique
 882 mk_uniq u = mkUniqueGrimily (I# u)
 883 \end{code}
 884