b28432f3d8699063776e331fe33eddc4bbfaf111
[ghc.git] / compiler / hsSyn / Convert.hs
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
9 {-# LANGUAGE ScopedTypeVariables #-}
10
11 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
12 convertToHsType,
13 thRdrNameGuesses ) where
14
15 import HsSyn as Hs
16 import qualified Class
17 import RdrName
18 import qualified Name
19 import Module
20 import RdrHsSyn
21 import qualified OccName
22 import OccName
23 import SrcLoc
24 import Type
25 import qualified Coercion ( Role(..) )
26 import TysWiredIn
27 import TysPrim (eqPrimTyCon)
28 import BasicTypes as Hs
29 import ForeignCall
30 import Unique
31 import ErrUtils
32 import Bag
33 import Lexeme
34 import Util
35 import FastString
36 import Outputable
37 import MonadUtils ( foldrM )
38
39 import qualified Data.ByteString as BS
40 import Control.Monad( unless, liftM, ap )
41
42 import Data.Char ( chr )
43 import Data.Word ( Word8 )
44 import Data.Maybe( catMaybes, fromMaybe, isNothing )
45 import Language.Haskell.TH as TH hiding (sigP)
46 import Language.Haskell.TH.Syntax as TH
47
48 -------------------------------------------------------------------
49 -- The external interface
50
51 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]
52 convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
53 where
54 cvt_dec d = wrapMsg "declaration" d (cvtDec d)
55
56 convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName)
57 convertToHsExpr loc e
58 = initCvt loc $ wrapMsg "expression" e $ cvtl e
59
60 convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName)
61 convertToPat loc p
62 = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
63
64 convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName)
65 convertToHsType loc t
66 = initCvt loc $ wrapMsg "type" t $ cvtType t
67
68 -------------------------------------------------------------------
69 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
70 -- Push down the source location;
71 -- Can fail, with a single error message
72
73 -- NB: If the conversion succeeds with (Right x), there should
74 -- be no exception values hiding in x
75 -- Reason: so a (head []) in TH code doesn't subsequently
76 -- make GHC crash when it tries to walk the generated tree
77
78 -- Use the loc everywhere, for lack of anything better
79 -- In particular, we want it on binding locations, so that variables bound in
80 -- the spliced-in declarations get a location that at least relates to the splice point
81
82 instance Functor CvtM where
83 fmap = liftM
84
85 instance Applicative CvtM where
86 pure x = CvtM $ \loc -> Right (loc,x)
87 (<*>) = ap
88
89 instance Monad CvtM where
90 (CvtM m) >>= k = CvtM $ \loc -> case m loc of
91 Left err -> Left err
92 Right (loc',v) -> unCvtM (k v) loc'
93
94 initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
95 initCvt loc (CvtM m) = fmap snd (m loc)
96
97 force :: a -> CvtM ()
98 force a = a `seq` return ()
99
100 failWith :: MsgDoc -> CvtM a
101 failWith m = CvtM (\_ -> Left m)
102
103 getL :: CvtM SrcSpan
104 getL = CvtM (\loc -> Right (loc,loc))
105
106 setL :: SrcSpan -> CvtM ()
107 setL loc = CvtM (\_ -> Right (loc, ()))
108
109 returnL :: a -> CvtM (Located a)
110 returnL x = CvtM (\loc -> Right (loc, L loc x))
111
112 returnJustL :: a -> CvtM (Maybe (Located a))
113 returnJustL = fmap Just . returnL
114
115 wrapParL :: (Located a -> a) -> a -> CvtM a
116 wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))
117
118 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
119 -- E.g wrapMsg "declaration" dec thing
120 wrapMsg what item (CvtM m)
121 = CvtM (\loc -> case m loc of
122 Left err -> Left (err $$ getPprStyle msg)
123 Right v -> Right v)
124 where
125 -- Show the item in pretty syntax normally,
126 -- but with all its constructors if you say -dppr-debug
127 msg sty = hang (ptext (sLit "When splicing a TH") <+> text what <> colon)
128 2 (if debugStyle sty
129 then text (show item)
130 else text (pprint item))
131
132 wrapL :: CvtM a -> CvtM (Located a)
133 wrapL (CvtM m) = CvtM (\loc -> case m loc of
134 Left err -> Left err
135 Right (loc',v) -> Right (loc',L loc v))
136
137 -------------------------------------------------------------------
138 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName]
139 cvtDecs = fmap catMaybes . mapM cvtDec
140
141 cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
142 cvtDec (TH.ValD pat body ds)
143 | TH.VarP s <- pat
144 = do { s' <- vNameL s
145 ; cl' <- cvtClause (Clause [] body ds)
146 ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
147
148 | otherwise
149 = do { pat' <- cvtPat pat
150 ; body' <- cvtGuard body
151 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
152 ; returnJustL $ Hs.ValD $
153 PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
154 , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
155 , pat_ticks = ([],[]) } }
156
157 cvtDec (TH.FunD nm cls)
158 | null cls
159 = failWith (ptext (sLit "Function binding for")
160 <+> quotes (text (TH.pprint nm))
161 <+> ptext (sLit "has no equations"))
162 | otherwise
163 = do { nm' <- vNameL nm
164 ; cls' <- mapM cvtClause cls
165 ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
166
167 cvtDec (TH.SigD nm typ)
168 = do { nm' <- vNameL nm
169 ; ty' <- cvtType typ
170 ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
171
172 cvtDec (TH.InfixD fx nm)
173 -- Fixity signatures are allowed for variables, constructors, and types
174 -- the renamer automatically looks for types during renaming, even when
175 -- the RdrName says it's a variable or a constructor. So, just assume
176 -- it's a variable or constructor and proceed.
177 = do { nm' <- vcNameL nm
178 ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
179
180 cvtDec (PragmaD prag)
181 = cvtPragmaD prag
182
183 cvtDec (TySynD tc tvs rhs)
184 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
185 ; rhs' <- cvtType rhs
186 ; returnJustL $ TyClD $
187 SynDecl { tcdLName = tc'
188 , tcdTyVars = tvs', tcdFVs = placeHolderNames
189 , tcdRhs = rhs' } }
190
191 cvtDec (DataD ctxt tc tvs ksig constrs derivs)
192 = do { let isGadtCon (GadtC _ _ _ _) = True
193 isGadtCon (RecGadtC _ _ _ _) = True
194 isGadtCon (ForallC _ _ c ) = isGadtCon c
195 isGadtCon _ = False
196 isGadtDecl = all isGadtCon constrs
197 isH98Decl = all (not . isGadtCon) constrs
198 ; unless (isGadtDecl || isH98Decl)
199 (failWith (text "Cannot mix GADT constructors with Haskell 98"
200 <+> text "constructors"))
201 ; unless (isNothing ksig || isGadtDecl)
202 (failWith (text "Kind signatures are only allowed on GADTs"))
203 ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
204 ; ksig' <- cvtKind `traverse` ksig
205 ; cons' <- mapM cvtConstr constrs
206 ; derivs' <- cvtDerivs derivs
207 ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
208 , dd_ctxt = ctxt'
209 , dd_kindSig = ksig'
210 , dd_cons = cons', dd_derivs = derivs' }
211 ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
212 , tcdDataDefn = defn
213 , tcdFVs = placeHolderNames }) }
214
215 cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
216 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
217 ; ksig' <- cvtKind `traverse` ksig
218 ; con' <- cvtConstr constr
219 ; derivs' <- cvtDerivs derivs
220 ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
221 , dd_ctxt = ctxt'
222 , dd_kindSig = ksig'
223 , dd_cons = [con']
224 , dd_derivs = derivs' }
225 ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
226 , tcdDataDefn = defn
227 , tcdFVs = placeHolderNames }) }
228
229 cvtDec (ClassD ctxt cl tvs fds decs)
230 = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
231 ; fds' <- mapM cvt_fundep fds
232 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
233 ; unless (null adts')
234 (failWith $ (text "Default data instance declarations"
235 <+> text "are not allowed:")
236 $$ (Outputable.ppr adts'))
237 ; at_defs <- mapM cvt_at_def ats'
238 ; returnJustL $ TyClD $
239 ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
240 , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
241 , tcdMeths = binds'
242 , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
243 , tcdFVs = placeHolderNames }
244 -- no docs in TH ^^
245 }
246 where
247 cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName)
248 -- Very similar to what happens in RdrHsSyn.mkClassDecl
249 cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
250 Right def -> return def
251 Left (_, msg) -> failWith msg
252
253 cvtDec (InstanceD ctxt ty decs)
254 = do { let doc = ptext (sLit "an instance declaration")
255 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
256 ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
257 ; ctxt' <- cvtContext ctxt
258 ; L loc ty' <- cvtType ty
259 ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' }
260 ; returnJustL $ InstD $ ClsInstD $
261 ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
262 , cid_binds = binds'
263 , cid_sigs = Hs.mkClassOpSigs sigs'
264 , cid_tyfam_insts = ats', cid_datafam_insts = adts'
265 , cid_overlap_mode = Nothing } }
266
267 cvtDec (ForeignD ford)
268 = do { ford' <- cvtForD ford
269 ; returnJustL $ ForD ford' }
270
271 cvtDec (DataFamilyD tc tvs kind)
272 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
273 ; result <- cvtMaybeKindToFamilyResultSig kind
274 ; returnJustL $ TyClD $ FamDecl $
275 FamilyDecl DataFamily tc' tvs' result Nothing }
276
277 cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
278 = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
279 ; ksig' <- cvtKind `traverse` ksig
280 ; cons' <- mapM cvtConstr constrs
281 ; derivs' <- cvtDerivs derivs
282 ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
283 , dd_ctxt = ctxt'
284 , dd_kindSig = ksig'
285 , dd_cons = cons', dd_derivs = derivs' }
286
287 ; returnJustL $ InstD $ DataFamInstD
288 { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
289 , dfid_defn = defn
290 , dfid_fvs = placeHolderNames } }}
291
292 cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
293 = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
294 ; ksig' <- cvtKind `traverse` ksig
295 ; con' <- cvtConstr constr
296 ; derivs' <- cvtDerivs derivs
297 ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
298 , dd_ctxt = ctxt'
299 , dd_kindSig = ksig'
300 , dd_cons = [con'], dd_derivs = derivs' }
301 ; returnJustL $ InstD $ DataFamInstD
302 { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
303 , dfid_defn = defn
304 , dfid_fvs = placeHolderNames } }}
305
306 cvtDec (TySynInstD tc eqn)
307 = do { tc' <- tconNameL tc
308 ; eqn' <- cvtTySynEqn tc' eqn
309 ; returnJustL $ InstD $ TyFamInstD
310 { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
311 , tfid_fvs = placeHolderNames } } }
312
313 cvtDec (OpenTypeFamilyD head)
314 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
315 ; returnJustL $ TyClD $ FamDecl $
316 FamilyDecl OpenTypeFamily tc' tyvars' result' injectivity' }
317
318 cvtDec (ClosedTypeFamilyD head eqns)
319 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
320 ; eqns' <- mapM (cvtTySynEqn tc') eqns
321 ; returnJustL $ TyClD $ FamDecl $
322 FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' result'
323 injectivity' }
324
325 cvtDec (TH.RoleAnnotD tc roles)
326 = do { tc' <- tconNameL tc
327 ; let roles' = map (noLoc . cvtRole) roles
328 ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
329
330 cvtDec (TH.StandaloneDerivD cxt ty)
331 = do { cxt' <- cvtContext cxt
332 ; L loc ty' <- cvtType ty
333 ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
334 ; returnJustL $ DerivD $
335 DerivDecl { deriv_type = mkLHsSigType inst_ty', deriv_overlap_mode = Nothing } }
336
337 cvtDec (TH.DefaultSigD nm typ)
338 = do { nm' <- vNameL nm
339 ; ty' <- cvtType typ
340 ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
341 ----------------
342 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
343 cvtTySynEqn tc (TySynEqn lhs rhs)
344 = do { lhs' <- mapM cvtType lhs
345 ; rhs' <- cvtType rhs
346 ; returnL $ TyFamEqn { tfe_tycon = tc
347 , tfe_pats = mkHsImplicitBndrs lhs'
348 , tfe_rhs = rhs' } }
349
350 ----------------
351 cvt_ci_decs :: MsgDoc -> [TH.Dec]
352 -> CvtM (LHsBinds RdrName,
353 [LSig RdrName],
354 [LFamilyDecl RdrName],
355 [LTyFamInstDecl RdrName],
356 [LDataFamInstDecl RdrName])
357 -- Convert the declarations inside a class or instance decl
358 -- ie signatures, bindings, and associated types
359 cvt_ci_decs doc decs
360 = do { decs' <- cvtDecs decs
361 ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
362 ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs'
363 ; let (sigs', prob_binds') = partitionWith is_sig no_ats'
364 ; let (binds', prob_fams') = partitionWith is_bind prob_binds'
365 ; let (fams', bads) = partitionWith is_fam_decl prob_fams'
366 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
367 --We use FromSource as the origin of the bind
368 -- because the TH declaration is user-written
369 ; return (listToBag binds', sigs', fams', ats', adts') }
370
371 ----------------
372 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
373 -> CvtM ( LHsContext RdrName
374 , Located RdrName
375 , LHsQTyVars RdrName)
376 cvt_tycl_hdr cxt tc tvs
377 = do { cxt' <- cvtContext cxt
378 ; tc' <- tconNameL tc
379 ; tvs' <- cvtTvs tvs
380 ; return (cxt', tc', tvs')
381 }
382
383 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
384 -> CvtM ( LHsContext RdrName
385 , Located RdrName
386 , HsImplicitBndrs RdrName [LHsType RdrName])
387 cvt_tyinst_hdr cxt tc tys
388 = do { cxt' <- cvtContext cxt
389 ; tc' <- tconNameL tc
390 ; tys' <- mapM cvtType tys
391 ; return (cxt', tc', mkHsImplicitBndrs tys') }
392
393 ----------------
394 cvt_tyfam_head :: TypeFamilyHead
395 -> CvtM ( Located RdrName
396 , LHsQTyVars RdrName
397 , Hs.LFamilyResultSig RdrName
398 , Maybe (Hs.LInjectivityAnn RdrName))
399
400 cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
401 = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
402 ; result' <- cvtFamilyResultSig result
403 ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
404 ; return (tc', tyvars', result', injectivity') }
405
406 -------------------------------------------------------------------
407 -- Partitioning declarations
408 -------------------------------------------------------------------
409
410 is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
411 is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
412 is_fam_decl decl = Right decl
413
414 is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName)
415 is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
416 is_tyfam_inst decl = Right decl
417
418 is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName)
419 is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
420 is_datafam_inst decl = Right decl
421
422 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
423 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
424 is_sig decl = Right decl
425
426 is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
427 is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
428 is_bind decl = Right decl
429
430 mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
431 mkBadDecMsg doc bads
432 = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
433 , nest 2 (vcat (map Outputable.ppr bads)) ]
434
435 ---------------------------------------------------
436 -- Data types
437 ---------------------------------------------------
438
439 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
440
441 cvtConstr (NormalC c strtys)
442 = do { c' <- cNameL c
443 ; cxt' <- returnL []
444 ; tys' <- mapM cvt_arg strtys
445 ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
446
447 cvtConstr (RecC c varstrtys)
448 = do { c' <- cNameL c
449 ; cxt' <- returnL []
450 ; args' <- mapM cvt_id_arg varstrtys
451 ; returnL $ mkConDeclH98 c' Nothing cxt'
452 (RecCon (noLoc args')) }
453
454 cvtConstr (InfixC st1 c st2)
455 = do { c' <- cNameL c
456 ; cxt' <- returnL []
457 ; st1' <- cvt_arg st1
458 ; st2' <- cvt_arg st2
459 ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
460
461 cvtConstr (ForallC tvs ctxt con)
462 = do { tvs' <- cvtTvs tvs
463 ; L loc ctxt' <- cvtContext ctxt
464 ; L _ con' <- cvtConstr con
465 ; returnL $ case con' of
466 ConDeclGADT { con_type = conT } ->
467 con' { con_type =
468 HsIB PlaceHolder
469 (noLoc $ HsForAllTy (hsq_explicit tvs') $
470 (noLoc $ HsQualTy (L loc ctxt') (hsib_body conT))) }
471 ConDeclH98 {} ->
472 let qvars = case (tvs, con_qvars con') of
473 ([], Nothing) -> Nothing
474 (_ , m_qvs ) -> Just $
475 mkHsQTvs (hsQTvExplicit tvs' ++
476 maybe [] hsQTvExplicit m_qvs)
477 in con' { con_qvars = qvars
478 , con_cxt = Just $
479 L loc (ctxt' ++
480 unLoc (fromMaybe (noLoc [])
481 (con_cxt con'))) } }
482
483 cvtConstr (GadtC c strtys ty idx)
484 = do { c' <- mapM cNameL c
485 ; args <- mapM cvt_arg strtys
486 ; idx' <- mapM cvtType idx
487 ; ty' <- tconNameL ty
488 ; L _ ret_ty <- mk_apps (HsTyVar ty') idx'
489 ; c_ty <- mk_arr_apps args ret_ty
490 ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
491
492 cvtConstr (RecGadtC c varstrtys ty idx)
493 = do { c' <- mapM cNameL c
494 ; ty' <- tconNameL ty
495 ; rec_flds <- mapM cvt_id_arg varstrtys
496 ; idx' <- mapM cvtType idx
497 ; ret_ty <- mk_apps (HsTyVar ty') idx'
498 ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ret_ty)
499 ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
500
501 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
502 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
503 cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack
504 cvtSrcUnpackedness SourceUnpack = SrcUnpack
505
506 cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
507 cvtSrcStrictness NoSourceStrictness = NoSrcStrict
508 cvtSrcStrictness SourceLazy = SrcLazy
509 cvtSrcStrictness SourceStrict = SrcStrict
510
511 cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName)
512 cvt_arg (Bang su ss, ty)
513 = do { ty' <- cvtType ty
514 ; let su' = cvtSrcUnpackedness su
515 ; let ss' = cvtSrcStrictness ss
516 ; returnL $ HsBangTy (HsSrcBang Nothing su' ss') ty' }
517
518 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName)
519 cvt_id_arg (i, str, ty)
520 = do { L li i' <- vNameL i
521 ; ty' <- cvt_arg (str,ty)
522 ; return $ noLoc (ConDeclField
523 { cd_fld_names
524 = [L li $ FieldOcc (L li i') PlaceHolder]
525 , cd_fld_type = ty'
526 , cd_fld_doc = Nothing}) }
527
528 cvtDerivs :: TH.Cxt -> CvtM (HsDeriving RdrName)
529 cvtDerivs [] = return Nothing
530 cvtDerivs cs = fmap (Just . mkSigTypes) (cvtContext cs)
531 where
532 mkSigTypes :: Located (HsContext RdrName) -> Located [LHsSigType RdrName]
533 mkSigTypes = fmap (map mkLHsSigType)
534
535 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
536 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
537 ; ys' <- mapM tNameL ys
538 ; returnL (xs', ys') }
539
540
541 ------------------------------------------
542 -- Foreign declarations
543 ------------------------------------------
544
545 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
546 cvtForD (ImportF callconv safety from nm ty)
547 -- the prim and javascript calling conventions do not support headers
548 -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
549 | callconv == TH.Prim || callconv == TH.JavaScript
550 = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
551 (CFunction (StaticTarget from (mkFastString from) Nothing
552 True))
553 (noLoc from))
554 | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
555 (mkFastString (TH.nameBase nm))
556 from (noLoc from)
557 = mk_imp impspec
558 | otherwise
559 = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
560 where
561 mk_imp impspec
562 = do { nm' <- vNameL nm
563 ; ty' <- cvtType ty
564 ; return (ForeignImport { fd_name = nm'
565 , fd_sig_ty = mkLHsSigType ty'
566 , fd_co = noForeignImportCoercionYet
567 , fd_fi = impspec })
568 }
569 safety' = case safety of
570 Unsafe -> PlayRisky
571 Safe -> PlaySafe
572 Interruptible -> PlayInterruptible
573
574 cvtForD (ExportF callconv as nm ty)
575 = do { nm' <- vNameL nm
576 ; ty' <- cvtType ty
577 ; let e = CExport (noLoc (CExportStatic as
578 (mkFastString as)
579 (cvt_conv callconv)))
580 (noLoc as)
581 ; return $ ForeignExport { fd_name = nm'
582 , fd_sig_ty = mkLHsSigType ty'
583 , fd_co = noForeignExportCoercionYet
584 , fd_fe = e } }
585
586 cvt_conv :: TH.Callconv -> CCallConv
587 cvt_conv TH.CCall = CCallConv
588 cvt_conv TH.StdCall = StdCallConv
589 cvt_conv TH.CApi = CApiConv
590 cvt_conv TH.Prim = PrimCallConv
591 cvt_conv TH.JavaScript = JavaScriptCallConv
592
593 ------------------------------------------
594 -- Pragmas
595 ------------------------------------------
596
597 cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
598 cvtPragmaD (InlineP nm inline rm phases)
599 = do { nm' <- vNameL nm
600 ; let dflt = dfltActivation inline
601 ; let ip = InlinePragma { inl_src = "{-# INLINE"
602 , inl_inline = cvtInline inline
603 , inl_rule = cvtRuleMatch rm
604 , inl_act = cvtPhases phases dflt
605 , inl_sat = Nothing }
606 ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
607
608 cvtPragmaD (SpecialiseP nm ty inline phases)
609 = do { nm' <- vNameL nm
610 ; ty' <- cvtType ty
611 ; let (inline', dflt) = case inline of
612 Just inline1 -> (cvtInline inline1, dfltActivation inline1)
613 Nothing -> (EmptyInlineSpec, AlwaysActive)
614 ; let ip = InlinePragma { inl_src = "{-# INLINE"
615 , inl_inline = inline'
616 , inl_rule = Hs.FunLike
617 , inl_act = cvtPhases phases dflt
618 , inl_sat = Nothing }
619 ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
620
621 cvtPragmaD (SpecialiseInstP ty)
622 = do { ty' <- cvtType ty
623 ; returnJustL $ Hs.SigD $
624 SpecInstSig "{-# SPECIALISE" (mkLHsSigType ty') }
625
626 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
627 = do { let nm' = mkFastString nm
628 ; let act = cvtPhases phases AlwaysActive
629 ; bndrs' <- mapM cvtRuleBndr bndrs
630 ; lhs' <- cvtl lhs
631 ; rhs' <- cvtl rhs
632 ; returnJustL $ Hs.RuleD
633 $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc (nm,nm')) act bndrs'
634 lhs' placeHolderNames
635 rhs' placeHolderNames]
636 }
637
638 cvtPragmaD (AnnP target exp)
639 = do { exp' <- cvtl exp
640 ; target' <- case target of
641 ModuleAnnotation -> return ModuleAnnProvenance
642 TypeAnnotation n -> do
643 n' <- tconName n
644 return (TypeAnnProvenance (noLoc n'))
645 ValueAnnotation n -> do
646 n' <- vcName n
647 return (ValueAnnProvenance (noLoc n'))
648 ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp'
649 }
650
651 cvtPragmaD (LineP line file)
652 = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
653 ; return Nothing
654 }
655
656 dfltActivation :: TH.Inline -> Activation
657 dfltActivation TH.NoInline = NeverActive
658 dfltActivation _ = AlwaysActive
659
660 cvtInline :: TH.Inline -> Hs.InlineSpec
661 cvtInline TH.NoInline = Hs.NoInline
662 cvtInline TH.Inline = Hs.Inline
663 cvtInline TH.Inlinable = Hs.Inlinable
664
665 cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
666 cvtRuleMatch TH.ConLike = Hs.ConLike
667 cvtRuleMatch TH.FunLike = Hs.FunLike
668
669 cvtPhases :: TH.Phases -> Activation -> Activation
670 cvtPhases AllPhases dflt = dflt
671 cvtPhases (FromPhase i) _ = ActiveAfter i
672 cvtPhases (BeforePhase i) _ = ActiveBefore i
673
674 cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
675 cvtRuleBndr (RuleVar n)
676 = do { n' <- vNameL n
677 ; return $ noLoc $ Hs.RuleBndr n' }
678 cvtRuleBndr (TypedRuleVar n ty)
679 = do { n' <- vNameL n
680 ; ty' <- cvtType ty
681 ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }
682
683 ---------------------------------------------------
684 -- Declarations
685 ---------------------------------------------------
686
687 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
688 cvtLocalDecs doc ds
689 | null ds
690 = return EmptyLocalBinds
691 | otherwise
692 = do { ds' <- cvtDecs ds
693 ; let (binds, prob_sigs) = partitionWith is_bind ds'
694 ; let (sigs, bads) = partitionWith is_sig prob_sigs
695 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
696 ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
697
698 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
699 cvtClause (Clause ps body wheres)
700 = do { ps' <- cvtPats ps
701 ; g' <- cvtGuard body
702 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
703 ; returnL $ Hs.Match NonFunBindMatch ps' Nothing
704 (GRHSs g' (noLoc ds')) }
705
706
707 -------------------------------------------------------------------
708 -- Expressions
709 -------------------------------------------------------------------
710
711 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
712 cvtl e = wrapL (cvt e)
713 where
714 cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
715 cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') }
716 cvt (LitE l)
717 | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
718 | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
719
720 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
721 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
722 ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
723 cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
724 ; return $ HsLamCase placeHolderType
725 (mkMatchGroup FromSource ms')
726 }
727 cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
728 -- Note [Dropping constructors]
729 -- Singleton tuples treated like nothing (just parens)
730 cvt (TupE es) = do { es' <- mapM cvtl es
731 ; return $ ExplicitTuple (map (noLoc . Present) es')
732 Boxed }
733 cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
734 ; return $ ExplicitTuple
735 (map (noLoc . Present) es') Unboxed }
736 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
737 ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
738 cvt (MultiIfE alts)
739 | null alts = failWith (ptext (sLit "Multi-way if-expression with no alternatives"))
740 | otherwise = do { alts' <- mapM cvtpair alts
741 ; return $ HsMultiIf placeHolderType alts' }
742 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
743 ; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
744 cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
745 ; return $ HsCase e' (mkMatchGroup FromSource ms') }
746 cvt (DoE ss) = cvtHsDo DoExpr ss
747 cvt (CompE ss) = cvtHsDo ListComp ss
748 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
749 cvt (ListE xs)
750 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
751 -- Note [Converting strings]
752 | otherwise = do { xs' <- mapM cvtl xs
753 ; return $ ExplicitList placeHolderType Nothing xs'
754 }
755
756 -- Infix expressions
757 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
758 ; wrapParL HsPar $
759 OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
760 -- Parenthesise both arguments and result,
761 -- to ensure this operator application does
762 -- does not get re-associated
763 -- See Note [Operator association]
764 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
765 ; wrapParL HsPar $ SectionR s' y' }
766 -- See Note [Sections in HsSyn] in HsExpr
767 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
768 ; wrapParL HsPar $ SectionL x' s' }
769
770 cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
771 -- Can I indicate this is an infix thing?
772 -- Note [Dropping constructors]
773
774 cvt (UInfixE x s y) = do { x' <- cvtl x
775 ; let x'' = case x' of
776 L _ (OpApp {}) -> x'
777 _ -> mkLHsPar x'
778 ; cvtOpApp x'' s y } -- Note [Converting UInfix]
779
780 cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' }
781 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
782 ; return $ ExprWithTySig e' (mkLHsSigWcType t') }
783 cvt (RecConE c flds) = do { c' <- cNameL c
784 ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
785 ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
786 cvt (RecUpdE e flds) = do { e' <- cvtl e
787 ; flds'
788 <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
789 flds
790 ; return $ mkRdrRecordUpd e' flds' }
791 cvt (StaticE e) = fmap HsStatic $ cvtl e
792 cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
793
794 {- Note [Dropping constructors]
795 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
796 When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
797 we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
798 could meet @UInfix@ constructors containing the @TupE [e]@. For example:
799
800 UInfixE x * (TupE [UInfixE y + z])
801
802 If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
803 and the above expression would be reassociated to
804
805 OpApp (OpApp x * y) + z
806
807 which we don't want.
808 -}
809
810 cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) -> CvtM (LHsRecField' t (LHsExpr RdrName))
811 cvtFld f (v,e)
812 = do { v' <- vNameL v; e' <- cvtl e
813 ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
814 , hsRecFieldArg = e'
815 , hsRecPun = False}) }
816
817 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
818 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
819 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
820 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
821 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
822
823 {- Note [Operator assocation]
824 We must be quite careful about adding parens:
825 * Infix (UInfix ...) op arg Needs parens round the first arg
826 * Infix (Infix ...) op arg Needs parens round the first arg
827 * UInfix (UInfix ...) op arg No parens for first arg
828 * UInfix (Infix ...) op arg Needs parens round first arg
829
830
831 Note [Converting UInfix]
832 ~~~~~~~~~~~~~~~~~~~~~~~~
833 When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
834 the trees to reflect the fixities of the underlying operators:
835
836 UInfixE x * (UInfixE y + z) ---> (x * y) + z
837
838 This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
839 @mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
840 right-biased for types and left-biased for everything else. So we left-bias the
841 trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT.
842
843 Sample input:
844
845 UInfixE
846 (UInfixE x op1 y)
847 op2
848 (UInfixE z op3 w)
849
850 Sample output:
851
852 OpApp
853 (OpApp
854 (OpApp x op1 y)
855 op2
856 z)
857 op3
858 w
859
860 The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
861 biasing.
862 -}
863
864 {- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
865 The produced tree of infix expressions will be left-biased, provided @x@ is.
866
867 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
868 is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
869 this holds for both branches (of @cvtOpApp@), provided we assume it holds for
870 the recursive calls to @cvtOpApp@.
871
872 When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
873 since we have already run @cvtl@ on it.
874 -}
875 cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName)
876 cvtOpApp x op1 (UInfixE y op2 z)
877 = do { l <- wrapL $ cvtOpApp x op1 y
878 ; cvtOpApp l op2 z }
879 cvtOpApp x op y
880 = do { op' <- cvtl op
881 ; y' <- cvtl y
882 ; return (OpApp x op' undefined y') }
883
884 -------------------------------------
885 -- Do notation and statements
886 -------------------------------------
887
888 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
889 cvtHsDo do_or_lc stmts
890 | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
891 | otherwise
892 = do { stmts' <- cvtStmts stmts
893 ; let Just (stmts'', last') = snocView stmts'
894
895 ; last'' <- case last' of
896 L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
897 _ -> failWith (bad_last last')
898
899 ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }
900 where
901 bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
902 , nest 2 $ Outputable.ppr stmt
903 , ptext (sLit "(It should be an expression.)") ]
904
905 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]
906 cvtStmts = mapM cvtStmt
907
908 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
909 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
910 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
911 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
912 ; returnL $ LetStmt (noLoc ds') }
913 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
914 where
915 cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
916
917 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
918 cvtMatch (TH.Match p body decs)
919 = do { p' <- cvtPat p
920 ; g' <- cvtGuard body
921 ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
922 ; returnL $ Hs.Match NonFunBindMatch [p'] Nothing
923 (GRHSs g' (noLoc decs')) }
924
925 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
926 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
927 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
928
929 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))
930 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
931 ; g' <- returnL $ mkBodyStmt ge'
932 ; returnL $ GRHS [g'] rhs' }
933 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
934 ; returnL $ GRHS gs' rhs' }
935
936 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
937 cvtOverLit (IntegerL i)
938 = do { force i; return $ mkHsIntegral (show i) i placeHolderType}
939 cvtOverLit (RationalL r)
940 = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
941 cvtOverLit (StringL s)
942 = do { let { s' = mkFastString s }
943 ; force s'
944 ; return $ mkHsIsString s s' placeHolderType
945 }
946 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
947 -- An Integer is like an (overloaded) '3' in a Haskell source program
948 -- Similarly 3.5 for fractionals
949
950 {- Note [Converting strings]
951 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
952 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
953 a string literal for "xy". Of course, we might hope to get
954 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
955 if it isn't a literal string
956 -}
957
958 allCharLs :: [TH.Exp] -> Maybe String
959 -- Note [Converting strings]
960 -- NB: only fire up this setup for a non-empty list, else
961 -- there's a danger of returning "" for [] :: [Int]!
962 allCharLs xs
963 = case xs of
964 LitE (CharL c) : ys -> go [c] ys
965 _ -> Nothing
966 where
967 go cs [] = Just (reverse cs)
968 go cs (LitE (CharL c) : ys) = go (c:cs) ys
969 go _ _ = Nothing
970
971 cvtLit :: Lit -> CvtM HsLit
972 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim (show i) i }
973 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) w }
974 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
975 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
976 cvtLit (CharL c) = do { force c; return $ HsChar (show c) c }
977 cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim (show c) c }
978 cvtLit (StringL s) = do { let { s' = mkFastString s }
979 ; force s'
980 ; return $ HsString s s' }
981 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
982 ; force s'
983 ; return $ HsStringPrim (w8ToString s) s' }
984 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
985 -- cvtLit should not be called on IntegerL, RationalL
986 -- That precondition is established right here in
987 -- Convert.hs, hence panic
988
989 w8ToString :: [Word8] -> String
990 w8ToString ws = map (\w -> chr (fromIntegral w)) ws
991
992 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
993 cvtPats pats = mapM cvtPat pats
994
995 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
996 cvtPat pat = wrapL (cvtp pat)
997
998 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
999 cvtp (TH.LitP l)
1000 | overloadedLit l = do { l' <- cvtOverLit l
1001 ; return (mkNPat (noLoc l') Nothing) }
1002 -- Not right for negative patterns;
1003 -- need to think about that!
1004 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
1005 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
1006 cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
1007 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
1008 cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
1009 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
1010 ; return $ ConPatIn s' (PrefixCon ps') }
1011 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
1012 ; wrapParL ParPat $
1013 ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
1014 -- See Note [Operator association]
1015 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
1016 cvtp (ParensP p) = do { p' <- cvtPat p; return $ ParPat p' }
1017 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
1018 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
1019 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
1020 cvtp TH.WildP = return $ WildPat placeHolderType
1021 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
1022 ; return $ ConPatIn c'
1023 $ Hs.RecCon (HsRecFields fs' Nothing) }
1024 cvtp (ListP ps) = do { ps' <- cvtPats ps
1025 ; return $ ListPat ps' placeHolderType Nothing }
1026 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
1027 ; return $ SigPatIn p' (mkLHsSigWcType t') }
1028 cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
1029 ; return $ ViewPat e' p' placeHolderType }
1030
1031 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
1032 cvtPatFld (s,p)
1033 = do { L ls s' <- vNameL s; p' <- cvtPat p
1034 ; return (noLoc $ HsRecField { hsRecFieldLbl
1035 = L ls $ mkFieldOcc (L ls s')
1036 , hsRecFieldArg = p'
1037 , hsRecPun = False}) }
1038
1039 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
1040 The produced tree of infix patterns will be left-biased, provided @x@ is.
1041
1042 See the @cvtOpApp@ documentation for how this function works.
1043 -}
1044 cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName)
1045 cvtOpAppP x op1 (UInfixP y op2 z)
1046 = do { l <- wrapL $ cvtOpAppP x op1 y
1047 ; cvtOpAppP l op2 z }
1048 cvtOpAppP x op y
1049 = do { op' <- cNameL op
1050 ; y' <- cvtPat y
1051 ; return (ConPatIn op' (InfixCon x y')) }
1052
1053 -----------------------------------------------------------
1054 -- Types and type variables
1055
1056 cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName)
1057 cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
1058
1059 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
1060 cvt_tv (TH.PlainTV nm)
1061 = do { nm' <- tNameL nm
1062 ; returnL $ UserTyVar nm' }
1063 cvt_tv (TH.KindedTV nm ki)
1064 = do { nm' <- tNameL nm
1065 ; ki' <- cvtKind ki
1066 ; returnL $ KindedTyVar nm' ki' }
1067
1068 cvtRole :: TH.Role -> Maybe Coercion.Role
1069 cvtRole TH.NominalR = Just Coercion.Nominal
1070 cvtRole TH.RepresentationalR = Just Coercion.Representational
1071 cvtRole TH.PhantomR = Just Coercion.Phantom
1072 cvtRole TH.InferR = Nothing
1073
1074 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
1075 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
1076
1077 cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
1078 cvtPred = cvtType
1079
1080 cvtType :: TH.Type -> CvtM (LHsType RdrName)
1081 cvtType = cvtTypeKind "type"
1082
1083 cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName)
1084 cvtTypeKind ty_str ty
1085 = do { (head_ty, tys') <- split_ty_app ty
1086 ; case head_ty of
1087 TupleT n
1088 | length tys' == n -- Saturated
1089 -> if n==1 then return (head tys') -- Singleton tuples treated
1090 -- like nothing (ie just parens)
1091 else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
1092 | n == 1
1093 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
1094 | otherwise
1095 -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
1096 UnboxedTupleT n
1097 | length tys' == n -- Saturated
1098 -> if n==1 then return (head tys') -- Singleton tuples treated
1099 -- like nothing (ie just parens)
1100 else returnL (HsTupleTy HsUnboxedTuple tys')
1101 | otherwise
1102 -> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n))))
1103 tys'
1104 ArrowT
1105 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
1106 | otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys'
1107 ListT
1108 | [x'] <- tys' -> returnL (HsListTy x')
1109 | otherwise
1110 -> mk_apps (HsTyVar (noLoc (getRdrName listTyCon))) tys'
1111 VarT nm -> do { nm' <- tNameL nm
1112 ; mk_apps (HsTyVar nm') tys' }
1113 ConT nm -> do { nm' <- tconName nm
1114 ; mk_apps (HsTyVar (noLoc nm')) tys' }
1115
1116 ForallT tvs cxt ty
1117 | null tys'
1118 -> do { tvs' <- cvtTvs tvs
1119 ; cxt' <- cvtContext cxt
1120 ; ty' <- cvtType ty
1121 ; loc <- getL
1122 ; let hs_ty | null tvs = rho_ty
1123 | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
1124 , hst_body = rho_ty })
1125 rho_ty | null cxt = ty'
1126 | otherwise = L loc (HsQualTy { hst_ctxt = cxt'
1127 , hst_body = ty' })
1128
1129 ; return hs_ty }
1130
1131 SigT ty ki
1132 -> do { ty' <- cvtType ty
1133 ; ki' <- cvtKind ki
1134 ; mk_apps (HsKindSig ty' ki') tys'
1135 }
1136
1137 LitT lit
1138 -> returnL (HsTyLit (cvtTyLit lit))
1139
1140 WildCardT
1141 -> mk_apps mkAnonWildCardTy tys'
1142
1143 InfixT t1 s t2
1144 -> do { s' <- tconName s
1145 ; t1' <- cvtType t1
1146 ; t2' <- cvtType t2
1147 ; mk_apps (HsTyVar (noLoc s')) [t1', t2']
1148 }
1149
1150 UInfixT t1 s t2
1151 -> do { t1' <- cvtType t1
1152 ; t2' <- cvtType t2
1153 ; s' <- tconName s
1154 ; return $ cvtOpAppT t1' s' t2'
1155 } -- Note [Converting UInfix]
1156
1157 ParensT t
1158 -> do { t' <- cvtType t
1159 ; returnL $ HsParTy t'
1160 }
1161
1162 PromotedT nm -> do { nm' <- cName nm
1163 ; mk_apps (HsTyVar (noLoc nm')) tys' }
1164 -- Promoted data constructor; hence cName
1165
1166 PromotedTupleT n
1167 | n == 1
1168 -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
1169 | m == n -- Saturated
1170 -> do { let kis = replicate m placeHolderKind
1171 ; returnL (HsExplicitTupleTy kis tys')
1172 }
1173 where
1174 m = length tys'
1175
1176 PromotedNilT
1177 -> returnL (HsExplicitListTy placeHolderKind [])
1178
1179 PromotedConsT -- See Note [Representing concrete syntax in types]
1180 -- in Language.Haskell.TH.Syntax
1181 | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys'
1182 -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2))
1183 | otherwise
1184 -> mk_apps (HsTyVar (noLoc (getRdrName consDataCon))) tys'
1185
1186 StarT
1187 -> returnL (HsTyVar (noLoc (getRdrName liftedTypeKindTyCon)))
1188
1189 ConstraintT
1190 -> returnL (HsTyVar (noLoc (getRdrName constraintKindTyCon)))
1191
1192 EqualityT
1193 | [x',y'] <- tys' -> returnL (HsEqTy x' y')
1194 | otherwise
1195 -> mk_apps (HsTyVar (noLoc (getRdrName eqPrimTyCon))) tys'
1196
1197 _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
1198 }
1199
1200 -- | Constructs an application of a type to arguments passed in a list.
1201 mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
1202 mk_apps head_ty [] = returnL head_ty
1203 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
1204 ; mk_apps (HsAppTy head_ty' ty) tys }
1205
1206 -- | Constructs an arrow type with a specified return type
1207 mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName)
1208 mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
1209 where go :: LHsType RdrName -> HsType RdrName -> CvtM (HsType RdrName)
1210 go arg ret_ty = do { ret_ty_l <- returnL ret_ty
1211 ; return (HsFunTy arg ret_ty_l) }
1212
1213 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
1214 split_ty_app ty = go ty []
1215 where
1216 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
1217 go f as = return (f,as)
1218
1219 cvtTyLit :: TH.TyLit -> HsTyLit
1220 cvtTyLit (TH.NumTyLit i) = HsNumTy (show i) i
1221 cvtTyLit (TH.StrTyLit s) = HsStrTy s (fsLit s)
1222
1223 {- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy
1224 structure in them.
1225 -}
1226 cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName
1227 cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
1228 = L (combineSrcSpans loc1 loc2) $
1229 HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
1230 where
1231 t1' | L _ (HsAppsTy t1s) <- t1
1232 = t1s
1233 | otherwise
1234 = [noLoc $ HsAppPrefix t1]
1235
1236 t2' | L _ (HsAppsTy t2s) <- t2
1237 = t2s
1238 | otherwise
1239 = [noLoc $ HsAppPrefix t2]
1240
1241 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
1242 cvtKind = cvtTypeKind "kind"
1243
1244 -- | Convert Maybe Kind to a type family result signature. Used with data
1245 -- families where naming of the result is not possible (thus only kind or no
1246 -- signature is possible).
1247 cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
1248 -> CvtM (LFamilyResultSig RdrName)
1249 cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig
1250 cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
1251 ; returnL (Hs.KindSig ki') }
1252
1253 -- | Convert type family result signature. Used with both open and closed type
1254 -- families.
1255 cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig RdrName)
1256 cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig
1257 cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki
1258 ; returnL (Hs.KindSig ki') }
1259 cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
1260 ; returnL (Hs.TyVarSig tv) }
1261
1262 -- | Convert injectivity annotation of a type family.
1263 cvtInjectivityAnnotation :: TH.InjectivityAnn
1264 -> CvtM (Hs.LInjectivityAnn RdrName)
1265 cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
1266 = do { annLHS' <- tNameL annLHS
1267 ; annRHS' <- mapM tNameL annRHS
1268 ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
1269
1270 -----------------------------------------------------------
1271 cvtFixity :: TH.Fixity -> Hs.Fixity
1272 cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
1273 where
1274 cvt_dir TH.InfixL = Hs.InfixL
1275 cvt_dir TH.InfixR = Hs.InfixR
1276 cvt_dir TH.InfixN = Hs.InfixN
1277
1278 -----------------------------------------------------------
1279
1280
1281 -----------------------------------------------------------
1282 -- some useful things
1283
1284 overloadedLit :: Lit -> Bool
1285 -- True for literals that Haskell treats as overloaded
1286 overloadedLit (IntegerL _) = True
1287 overloadedLit (RationalL _) = True
1288 overloadedLit _ = False
1289
1290 cvtFractionalLit :: Rational -> FractionalLit
1291 cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
1292
1293 --------------------------------------------------------------------
1294 -- Turning Name back into RdrName
1295 --------------------------------------------------------------------
1296
1297 -- variable names
1298 vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
1299 vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName
1300
1301 -- Variable names
1302 vNameL n = wrapL (vName n)
1303 vName n = cvtName OccName.varName n
1304
1305 -- Constructor function names; this is Haskell source, hence srcDataName
1306 cNameL n = wrapL (cName n)
1307 cName n = cvtName OccName.dataName n
1308
1309 -- Variable *or* constructor names; check by looking at the first char
1310 vcNameL n = wrapL (vcName n)
1311 vcName n = if isVarName n then vName n else cName n
1312
1313 -- Type variable names
1314 tNameL n = wrapL (tName n)
1315 tName n = cvtName OccName.tvName n
1316
1317 -- Type Constructor names
1318 tconNameL n = wrapL (tconName n)
1319 tconName n = cvtName OccName.tcClsName n
1320
1321 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
1322 cvtName ctxt_ns (TH.Name occ flavour)
1323 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
1324 | otherwise
1325 = do { loc <- getL
1326 ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
1327 ; force rdr_name
1328 ; return rdr_name }
1329 where
1330 occ_str = TH.occString occ
1331
1332 okOcc :: OccName.NameSpace -> String -> Bool
1333 okOcc ns str
1334 | OccName.isVarNameSpace ns = okVarOcc str
1335 | OccName.isDataConNameSpace ns = okConOcc str
1336 | otherwise = okTcOcc str
1337
1338 -- Determine the name space of a name in a type
1339 --
1340 isVarName :: TH.Name -> Bool
1341 isVarName (TH.Name occ _)
1342 = case TH.occString occ of
1343 "" -> False
1344 (c:_) -> startsVarId c || startsVarSym c
1345
1346 badOcc :: OccName.NameSpace -> String -> SDoc
1347 badOcc ctxt_ns occ
1348 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
1349 <+> ptext (sLit "name:") <+> quotes (text occ)
1350
1351 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
1352 -- This turns a TH Name into a RdrName; used for both binders and occurrences
1353 -- See Note [Binders in Template Haskell]
1354 -- The passed-in name space tells what the context is expecting;
1355 -- use it unless the TH name knows what name-space it comes
1356 -- from, in which case use the latter
1357 --
1358 -- We pass in a SrcSpan (gotten from the monad) because this function
1359 -- is used for *binders* and if we make an Exact Name we want it
1360 -- to have a binding site inside it. (cf Trac #5434)
1361 --
1362 -- ToDo: we may generate silly RdrNames, by passing a name space
1363 -- that doesn't match the string, like VarName ":+",
1364 -- which will give confusing error messages later
1365 --
1366 -- The strict applications ensure that any buried exceptions get forced
1367 thRdrName loc ctxt_ns th_occ th_name
1368 = case th_name of
1369 TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
1370 TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ
1371 TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
1372 TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
1373 TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
1374 | otherwise -> mkRdrUnqual $! occ
1375 -- We check for built-in syntax here, because the TH
1376 -- user might have written a (NameS "(,,)"), for example
1377 where
1378 occ :: OccName.OccName
1379 occ = mk_occ ctxt_ns th_occ
1380
1381 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
1382 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
1383
1384 thRdrNameGuesses :: TH.Name -> [RdrName]
1385 thRdrNameGuesses (TH.Name occ flavour)
1386 -- This special case for NameG ensures that we don't generate duplicates in the output list
1387 | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
1388 | otherwise = [ thRdrName noSrcSpan gns occ_str flavour
1389 | gns <- guessed_nss]
1390 where
1391 -- guessed_ns are the name spaces guessed from looking at the TH name
1392 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
1393 | otherwise = [OccName.varName, OccName.tvName]
1394 occ_str = TH.occString occ
1395
1396 -- The packing and unpacking is rather turgid :-(
1397 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
1398 mk_occ ns occ = OccName.mkOccName ns occ
1399
1400 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
1401 mk_ghc_ns TH.DataName = OccName.dataName
1402 mk_ghc_ns TH.TcClsName = OccName.tcClsName
1403 mk_ghc_ns TH.VarName = OccName.varName
1404
1405 mk_mod :: TH.ModName -> ModuleName
1406 mk_mod mod = mkModuleName (TH.modString mod)
1407
1408 mk_pkg :: TH.PkgName -> UnitId
1409 mk_pkg pkg = stringToUnitId (TH.pkgString pkg)
1410
1411 mk_uniq :: Int -> Unique
1412 mk_uniq u = mkUniqueGrimily u
1413
1414 {-
1415 Note [Binders in Template Haskell]
1416 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1417 Consider this TH term construction:
1418 do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name
1419 ; x2 <- TH.newName "x" -- Builds a NameU
1420 ; x3 <- TH.newName "x"
1421
1422 ; let x = mkName "x" -- mkName :: String -> TH.Name
1423 -- Builds a NameS
1424
1425 ; return (LamE (..pattern [x1,x2]..) $
1426 LamE (VarPat x3) $
1427 ..tuple (x1,x2,x3,x)) }
1428
1429 It represents the term \[x1,x2]. \x3. (x1,x2,x3,x)
1430
1431 a) We don't want to complain about "x" being bound twice in
1432 the pattern [x1,x2]
1433 b) We don't want x3 to shadow the x1,x2
1434 c) We *do* want 'x' (dynamically bound with mkName) to bind
1435 to the innermost binding of "x", namely x3.
1436 d) When pretty printing, we want to print a unique with x1,x2
1437 etc, else they'll all print as "x" which isn't very helpful
1438
1439 When we convert all this to HsSyn, the TH.Names are converted with
1440 thRdrName. To achieve (b) we want the binders to be Exact RdrNames.
1441 Achieving (a) is a bit awkward, because
1442 - We must check for duplicate and shadowed names on Names,
1443 not RdrNames, *after* renaming.
1444 See Note [Collect binders only after renaming] in HsUtils
1445
1446 - But to achieve (a) we must distinguish between the Exact
1447 RdrNames arising from TH and the Unqual RdrNames that would
1448 come from a user writing \[x,x] -> blah
1449
1450 So in Convert.thRdrName we translate
1451 TH Name RdrName
1452 --------------------------------------------------------
1453 NameU (arising from newName) --> Exact (Name{ System })
1454 NameS (arising from mkName) --> Unqual
1455
1456 Notice that the NameUs generate *System* Names. Then, when
1457 figuring out shadowing and duplicates, we can filter out
1458 System Names.
1459
1460 This use of System Names fits with other uses of System Names, eg for
1461 temporary variables "a". Since there are lots of things called "a" we
1462 usually want to print the name with the unique, and that is indeed
1463 the way System Names are printed.
1464
1465 There's a small complication of course; see Note [Looking up Exact
1466 RdrNames] in RnEnv.
1467 -}