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 (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
 634 cvtp TH.WildP         = return $ WildPat void
 635 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 636                            ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 637 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 638 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 639
 640 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
 641 cvtPatFld (s,p)
 642   = do  { s' <- vNameL s; p' <- cvtPat p
 643         ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
 644
 645 -----------------------------------------------------------
 646 --      Types and type variables
 647
 648 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
 649 cvtTvs tvs = mapM cvt_tv tvs
 650
 651 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 652 cvt_tv (TH.PlainTV nm)
 653   = do { nm' <- tName nm
 654        ; returnL $ UserTyVar nm'
 655        }
 656 cvt_tv (TH.KindedTV nm ki)
 657   = do { nm' <- tName nm
 658        ; returnL $ KindedTyVar nm' (cvtKind ki)
 659        }
 660
 661 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 662 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
 663
 664 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
 665 cvtPred (TH.ClassP cla tys)
 666   = do { cla' <- if isVarName cla then tName cla else tconName cla
 667        ; tys' <- mapM cvtType tys
 668        ; returnL $ HsClassP cla' tys'
 669        }
 670 cvtPred (TH.EqualP ty1 ty2)
 671   = do { ty1' <- cvtType ty1
 672        ; ty2' <- cvtType ty2
 673        ; returnL $ HsEqualP ty1' ty2'
 674        }
 675
 676 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
 677 cvtPredTy ty
 678   = do  { (head, tys') <- split_ty_app ty
 679         ; case head of
 680             ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
 681             VarT tv -> do { tv' <- tName tv;    returnL $ HsClassP tv' tys' }
 682             _       -> failWith (ptext (sLit "Malformed predicate") <+>
 683                        text (TH.pprint ty)) }
 684
 685 cvtType :: TH.Type -> CvtM (LHsType RdrName)
 686 cvtType ty
 687   = do { (head_ty, tys') <- split_ty_app ty
 688        ; case head_ty of
 689            TupleT n
 690              | length tys' == n         -- Saturated
 691              -> if n==1 then return (head tys') -- Singleton tuples treated
 692                                                 -- like nothing (ie just parens)
 693                         else returnL (HsTupleTy Boxed tys')
 694              | n == 1
 695              -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
 696              | otherwise
 697              -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
 698            ArrowT
 699              | [x',y'] <- tys' -> returnL (HsFunTy x' y')
 700              | otherwise       -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
 701            ListT
 702              | [x']    <- tys' -> returnL (HsListTy x')
 703              | otherwise       -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
 704            VarT nm -> do { nm' <- tName nm;    mk_apps (HsTyVar nm') tys' }
 705            ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
 706
 707            ForallT tvs cxt ty
 708              | null tys'
 709              -> do { tvs' <- cvtTvs tvs
 710                    ; cxt' <- cvtContext cxt
 711                    ; ty'  <- cvtType ty
 712                    ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
 713                    }
 714
 715            SigT ty ki
 716              -> do { ty' <- cvtType ty
 717                    ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
 718                    }
 719
 720            _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
 721     }
 722   where
 723     mk_apps head_ty []       = returnL head_ty
 724     mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
 725                                   ; mk_apps (HsAppTy head_ty' ty) tys }
 726
 727 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
 728 split_ty_app ty = go ty []
 729   where
 730     go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
 731     go f as           = return (f,as)
 732
 733 cvtKind :: TH.Kind -> Type.Kind
 734 cvtKind StarK          = liftedTypeKind
 735 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
 736
 737 -----------------------------------------------------------
 738
 739
 740 -----------------------------------------------------------
 741 -- some useful things
 742
 743 overloadedLit :: Lit -> Bool
 744 -- True for literals that Haskell treats as overloaded
 745 overloadedLit (IntegerL  _) = True
 746 overloadedLit (RationalL _) = True
 747 overloadedLit _             = False
 748
 749 void :: Type.Type
 750 void = placeHolderType
 751
 752 --------------------------------------------------------------------
 753 --      Turning Name back into RdrName
 754 --------------------------------------------------------------------
 755
 756 -- variable names
 757 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 758 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 759
 760 vNameL n = wrapL (vName n)
 761 vName n = cvtName OccName.varName n
 762
 763 -- Constructor function names; this is Haskell source, hence srcDataName
 764 cNameL n = wrapL (cName n)
 765 cName n = cvtName OccName.dataName n
 766
 767 -- Type variable names
 768 tName n = cvtName OccName.tvName n
 769
 770 -- Type Constructor names
 771 tconNameL n = wrapL (tconName n)
 772 tconName n = cvtName OccName.tcClsName n
 773
 774 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
 775 cvtName ctxt_ns (TH.Name occ flavour)
 776   | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
 777   | otherwise                   = force (thRdrName ctxt_ns occ_str flavour)
 778   where
 779     occ_str = TH.occString occ
 780
 781 okOcc :: OccName.NameSpace -> String -> Bool
 782 okOcc _  []      = False
 783 okOcc ns str@(c:_)
 784   | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
 785   | otherwise                 = startsConId c || startsConSym c || str == "[]"
 786
 787 -- Determine the name space of a name in a type
 788 --
 789 isVarName :: TH.Name -> Bool
 790 isVarName (TH.Name occ _)
 791   = case TH.occString occ of
 792       ""    -> False
 793       (c:_) -> startsVarId c || startsVarSym c
 794
 795 badOcc :: OccName.NameSpace -> String -> SDoc
 796 badOcc ctxt_ns occ
 797   = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
 798         <+> ptext (sLit "name:") <+> quotes (text occ)
 799
 800 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 801 -- This turns a Name into a RdrName
 802 -- The passed-in name space tells what the context is expecting;
 803 --      use it unless the TH name knows what name-space it comes
 804 --      from, in which case use the latter
 805 --
 806 -- ToDo: we may generate silly RdrNames, by passing a name space
 807 --       that doesn't match the string, like VarName ":+",
 808 --       which will give confusing error messages later
 809 --
 810 -- The strict applications ensure that any buried exceptions get forced
 811 thRdrName _       occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
 812 thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 813 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 814 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 815 thRdrName ctxt_ns occ TH.NameS
 816   | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
 817   | otherwise                              = mkRdrUnqual $! (mk_occ ctxt_ns occ)
 818
 819 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
 820 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
 821
 822 thRdrNameGuesses :: TH.Name -> [RdrName]
 823 thRdrNameGuesses (TH.Name occ flavour)
 824   -- This special case for NameG ensures that we don't generate duplicates in the output list
 825   | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
 826   | otherwise                         = [ thRdrName gns occ_str flavour
 827                                         | gns <- guessed_nss]
 828   where
 829     -- guessed_ns are the name spaces guessed from looking at the TH name
 830     guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
 831                 | otherwise                       = [OccName.varName, OccName.tvName]
 832     occ_str = TH.occString occ
 833
 834 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
 835 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
 836 -- We must generate an Exact name, just as the parser does
 837 isBuiltInOcc ctxt_ns occ
 838   = case occ of
 839         ":"              -> Just (Name.getName consDataCon)
 840         "[]"             -> Just (Name.getName nilDataCon)
 841         "()"             -> Just (tup_name 0)
 842         '(' : ',' : rest -> go_tuple 2 rest
 843         _                -> Nothing
 844   where
 845     go_tuple n ")"          = Just (tup_name n)
 846     go_tuple n (',' : rest) = go_tuple (n+1) rest
 847     go_tuple _ _            = Nothing
 848
 849     tup_name n
 850         | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
 851         | otherwise                        = Name.getName (tupleCon Boxed n)
 852
 853 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 854 mk_uniq_occ ns occ uniq
 855   = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
 856         -- The idea here is to make a name that
 857         -- a) the user could not possibly write, and
 858         -- b) cannot clash with another NameU
 859         -- Previously I generated an Exact RdrName with mkInternalName.
 860         -- This works fine for local binders, but does not work at all for
 861         -- top-level binders, which must have External Names, since they are
 862         -- rapidly baked into data constructors and the like.  Baling out
 863         -- and generating an unqualified RdrName here is the simple solution
 864
 865 -- The packing and unpacking is rather turgid :-(
 866 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
 867 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
 868
 869 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
 870 mk_ghc_ns TH.DataName  = OccName.dataName
 871 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 872 mk_ghc_ns TH.VarName   = OccName.varName
 873
 874 mk_mod :: TH.ModName -> ModuleName
 875 mk_mod mod = mkModuleName (TH.modString mod)
 876
 877 mk_pkg :: TH.ModName -> PackageId
 878 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 879
 880 mk_uniq :: Int# -> Unique
 881 mk_uniq u = mkUniqueGrimily (I# u)
 882 \end{code}
 883