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