7113905bd90027e2cb7f0c26714e933a1b8c0263
[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 FlexibleContexts #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# LANGUAGE TypeFamilies #-}
12 {-# LANGUAGE ViewPatterns #-}
13
14 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
15 convertToHsType,
16 thRdrNameGuesses ) where
17
18 import GhcPrelude
19
20 import HsSyn as Hs
21 import PrelNames
22 import RdrName
23 import qualified Name
24 import Module
25 import RdrHsSyn
26 import OccName
27 import SrcLoc
28 import Type
29 import qualified Coercion ( Role(..) )
30 import TysWiredIn
31 import BasicTypes as Hs
32 import ForeignCall
33 import Unique
34 import ErrUtils
35 import Bag
36 import Lexeme
37 import Util
38 import FastString
39 import Outputable
40 import MonadUtils ( foldrM )
41
42 import qualified Data.ByteString as BS
43 import Control.Monad( unless, liftM, ap )
44
45 import Data.Maybe( catMaybes, isNothing )
46 import Language.Haskell.TH as TH hiding (sigP)
47 import Language.Haskell.TH.Syntax as TH
48 import Foreign.ForeignPtr
49 import Foreign.Ptr
50 import System.IO.Unsafe
51
52 -------------------------------------------------------------------
53 -- The external interface
54
55 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
56 convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
57 where
58 cvt_dec d = wrapMsg "declaration" d (cvtDec d)
59
60 convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
61 convertToHsExpr loc e
62 = initCvt loc $ wrapMsg "expression" e $ cvtl e
63
64 convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
65 convertToPat loc p
66 = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
67
68 convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
69 convertToHsType loc t
70 = initCvt loc $ wrapMsg "type" t $ cvtType t
71
72 -------------------------------------------------------------------
73 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
74 -- Push down the source location;
75 -- Can fail, with a single error message
76
77 -- NB: If the conversion succeeds with (Right x), there should
78 -- be no exception values hiding in x
79 -- Reason: so a (head []) in TH code doesn't subsequently
80 -- make GHC crash when it tries to walk the generated tree
81
82 -- Use the loc everywhere, for lack of anything better
83 -- In particular, we want it on binding locations, so that variables bound in
84 -- the spliced-in declarations get a location that at least relates to the splice point
85
86 instance Functor CvtM where
87 fmap = liftM
88
89 instance Applicative CvtM where
90 pure x = CvtM $ \loc -> Right (loc,x)
91 (<*>) = ap
92
93 instance Monad CvtM where
94 (CvtM m) >>= k = CvtM $ \loc -> case m loc of
95 Left err -> Left err
96 Right (loc',v) -> unCvtM (k v) loc'
97
98 initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
99 initCvt loc (CvtM m) = fmap snd (m loc)
100
101 force :: a -> CvtM ()
102 force a = a `seq` return ()
103
104 failWith :: MsgDoc -> CvtM a
105 failWith m = CvtM (\_ -> Left m)
106
107 getL :: CvtM SrcSpan
108 getL = CvtM (\loc -> Right (loc,loc))
109
110 setL :: SrcSpan -> CvtM ()
111 setL loc = CvtM (\_ -> Right (loc, ()))
112
113 returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
114 returnL x = CvtM (\loc -> Right (loc, cL loc x))
115
116 returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
117 returnJustL = fmap Just . returnL
118
119 wrapParL :: HasSrcSpan a =>
120 (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess a)
121 wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))
122
123 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
124 -- E.g wrapMsg "declaration" dec thing
125 wrapMsg what item (CvtM m)
126 = CvtM (\loc -> case m loc of
127 Left err -> Left (err $$ getPprStyle msg)
128 Right v -> Right v)
129 where
130 -- Show the item in pretty syntax normally,
131 -- but with all its constructors if you say -dppr-debug
132 msg sty = hang (text "When splicing a TH" <+> text what <> colon)
133 2 (if debugStyle sty
134 then text (show item)
135 else text (pprint item))
136
137 wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
138 wrapL (CvtM m) = CvtM (\loc -> case m loc of
139 Left err -> Left err
140 Right (loc',v) -> Right (loc',cL loc v))
141
142 -------------------------------------------------------------------
143 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
144 cvtDecs = fmap catMaybes . mapM cvtDec
145
146 cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
147 cvtDec (TH.ValD pat body ds)
148 | TH.VarP s <- pat
149 = do { s' <- vNameL s
150 ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
151 ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] }
152
153 | otherwise
154 = do { pat' <- cvtPat pat
155 ; body' <- cvtGuard body
156 ; ds' <- cvtLocalDecs (text "a where clause") ds
157 ; returnJustL $ Hs.ValD noExt $
158 PatBind { pat_lhs = pat'
159 , pat_rhs = GRHSs noExt body' (noLoc ds')
160 , pat_ext = noExt
161 , pat_ticks = ([],[]) } }
162
163 cvtDec (TH.FunD nm cls)
164 | null cls
165 = failWith (text "Function binding for"
166 <+> quotes (text (TH.pprint nm))
167 <+> text "has no equations")
168 | otherwise
169 = do { nm' <- vNameL nm
170 ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
171 ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' }
172
173 cvtDec (TH.SigD nm typ)
174 = do { nm' <- vNameL nm
175 ; ty' <- cvtType typ
176 ; returnJustL $ Hs.SigD noExt
177 (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }
178
179 cvtDec (TH.InfixD fx nm)
180 -- Fixity signatures are allowed for variables, constructors, and types
181 -- the renamer automatically looks for types during renaming, even when
182 -- the RdrName says it's a variable or a constructor. So, just assume
183 -- it's a variable or constructor and proceed.
184 = do { nm' <- vcNameL nm
185 ; returnJustL (Hs.SigD noExt (FixSig noExt
186 (FixitySig noExt [nm'] (cvtFixity fx)))) }
187
188 cvtDec (PragmaD prag)
189 = cvtPragmaD prag
190
191 cvtDec (TySynD tc tvs rhs)
192 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
193 ; rhs' <- cvtType rhs
194 ; returnJustL $ TyClD noExt $
195 SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs'
196 , tcdFixity = Prefix
197 , tcdRhs = rhs' } }
198
199 cvtDec (DataD ctxt tc tvs ksig constrs derivs)
200 = do { let isGadtCon (GadtC _ _ _) = True
201 isGadtCon (RecGadtC _ _ _) = True
202 isGadtCon (ForallC _ _ c) = isGadtCon c
203 isGadtCon _ = False
204 isGadtDecl = all isGadtCon constrs
205 isH98Decl = all (not . isGadtCon) constrs
206 ; unless (isGadtDecl || isH98Decl)
207 (failWith (text "Cannot mix GADT constructors with Haskell 98"
208 <+> text "constructors"))
209 ; unless (isNothing ksig || isGadtDecl)
210 (failWith (text "Kind signatures are only allowed on GADTs"))
211 ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
212 ; ksig' <- cvtKind `traverse` ksig
213 ; cons' <- mapM cvtConstr constrs
214 ; derivs' <- cvtDerivs derivs
215 ; let defn = HsDataDefn { dd_ext = noExt
216 , dd_ND = DataType, dd_cType = Nothing
217 , dd_ctxt = ctxt'
218 , dd_kindSig = ksig'
219 , dd_cons = cons', dd_derivs = derivs' }
220 ; returnJustL $ TyClD noExt (DataDecl
221 { tcdDExt = noExt
222 , tcdLName = tc', tcdTyVars = tvs'
223 , tcdFixity = Prefix
224 , tcdDataDefn = defn }) }
225
226 cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
227 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
228 ; ksig' <- cvtKind `traverse` ksig
229 ; con' <- cvtConstr constr
230 ; derivs' <- cvtDerivs derivs
231 ; let defn = HsDataDefn { dd_ext = noExt
232 , dd_ND = NewType, dd_cType = Nothing
233 , dd_ctxt = ctxt'
234 , dd_kindSig = ksig'
235 , dd_cons = [con']
236 , dd_derivs = derivs' }
237 ; returnJustL $ TyClD noExt (DataDecl
238 { tcdDExt = noExt
239 , tcdLName = tc', tcdTyVars = tvs'
240 , tcdFixity = Prefix
241 , tcdDataDefn = defn }) }
242
243 cvtDec (ClassD ctxt cl tvs fds decs)
244 = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
245 ; fds' <- mapM cvt_fundep fds
246 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
247 ; unless (null adts')
248 (failWith $ (text "Default data instance declarations"
249 <+> text "are not allowed:")
250 $$ (Outputable.ppr adts'))
251 ; at_defs <- mapM cvt_at_def ats'
252 ; returnJustL $ TyClD noExt $
253 ClassDecl { tcdCExt = noExt
254 , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
255 , tcdFixity = Prefix
256 , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
257 , tcdMeths = binds'
258 , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] }
259 -- no docs in TH ^^
260 }
261 where
262 cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
263 -- Very similar to what happens in RdrHsSyn.mkClassDecl
264 cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
265 Right (def, _) -> return def
266 Left (_, msg) -> failWith msg
267
268 cvtDec (InstanceD o ctxt ty decs)
269 = do { let doc = text "an instance declaration"
270 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
271 ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
272 ; ctxt' <- cvtContext ctxt
273 ; (dL->L loc ty') <- cvtType ty
274 ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'
275 ; returnJustL $ InstD noExt $ ClsInstD noExt $
276 ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty'
277 , cid_binds = binds'
278 , cid_sigs = Hs.mkClassOpSigs sigs'
279 , cid_tyfam_insts = ats', cid_datafam_insts = adts'
280 , cid_overlap_mode = fmap (cL loc . overlap) o } }
281 where
282 overlap pragma =
283 case pragma of
284 TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS")
285 TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE")
286 TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING")
287 TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT")
288
289
290
291
292 cvtDec (ForeignD ford)
293 = do { ford' <- cvtForD ford
294 ; returnJustL $ ForD noExt ford' }
295
296 cvtDec (DataFamilyD tc tvs kind)
297 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
298 ; result <- cvtMaybeKindToFamilyResultSig kind
299 ; returnJustL $ TyClD noExt $ FamDecl noExt $
300 FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
301
302 cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
303 = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
304 ; ksig' <- cvtKind `traverse` ksig
305 ; cons' <- mapM cvtConstr constrs
306 ; derivs' <- cvtDerivs derivs
307 ; let defn = HsDataDefn { dd_ext = noExt
308 , dd_ND = DataType, dd_cType = Nothing
309 , dd_ctxt = ctxt'
310 , dd_kindSig = ksig'
311 , dd_cons = cons', dd_derivs = derivs' }
312
313 ; returnJustL $ InstD noExt $ DataFamInstD
314 { dfid_ext = noExt
315 , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
316 FamEqn { feqn_ext = noExt
317 , feqn_tycon = tc'
318 , feqn_bndrs = bndrs'
319 , feqn_pats = typats'
320 , feqn_rhs = defn
321 , feqn_fixity = Prefix } }}}
322
323 cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
324 = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
325 ; ksig' <- cvtKind `traverse` ksig
326 ; con' <- cvtConstr constr
327 ; derivs' <- cvtDerivs derivs
328 ; let defn = HsDataDefn { dd_ext = noExt
329 , dd_ND = NewType, dd_cType = Nothing
330 , dd_ctxt = ctxt'
331 , dd_kindSig = ksig'
332 , dd_cons = [con'], dd_derivs = derivs' }
333 ; returnJustL $ InstD noExt $ DataFamInstD
334 { dfid_ext = noExt
335 , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
336 FamEqn { feqn_ext = noExt
337 , feqn_tycon = tc'
338 , feqn_bndrs = bndrs'
339 , feqn_pats = typats'
340 , feqn_rhs = defn
341 , feqn_fixity = Prefix } }}}
342
343 cvtDec (TySynInstD eqn)
344 = do { (dL->L _ eqn') <- cvtTySynEqn eqn
345 ; returnJustL $ InstD noExt $ TyFamInstD
346 { tfid_ext = noExt
347 , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
348
349 cvtDec (OpenTypeFamilyD head)
350 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
351 ; returnJustL $ TyClD noExt $ FamDecl noExt $
352 FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity'
353 }
354
355 cvtDec (ClosedTypeFamilyD head eqns)
356 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
357 ; eqns' <- mapM cvtTySynEqn eqns
358 ; returnJustL $ TyClD noExt $ FamDecl noExt $
359 FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix
360 result' injectivity' }
361
362 cvtDec (TH.RoleAnnotD tc roles)
363 = do { tc' <- tconNameL tc
364 ; let roles' = map (noLoc . cvtRole) roles
365 ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }
366
367 cvtDec (TH.StandaloneDerivD ds cxt ty)
368 = do { cxt' <- cvtContext cxt
369 ; ds' <- traverse cvtDerivStrategy ds
370 ; (dL->L loc ty') <- cvtType ty
371 ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
372 ; returnJustL $ DerivD noExt $
373 DerivDecl { deriv_ext =noExt
374 , deriv_strategy = ds'
375 , deriv_type = mkLHsSigWcType inst_ty'
376 , deriv_overlap_mode = Nothing } }
377
378 cvtDec (TH.DefaultSigD nm typ)
379 = do { nm' <- vNameL nm
380 ; ty' <- cvtType typ
381 ; returnJustL $ Hs.SigD noExt
382 $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}
383
384 cvtDec (TH.PatSynD nm args dir pat)
385 = do { nm' <- cNameL nm
386 ; args' <- cvtArgs args
387 ; dir' <- cvtDir nm' dir
388 ; pat' <- cvtPat pat
389 ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $
390 PSB noExt nm' args' pat' dir' }
391 where
392 cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
393 cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
394 cvtArgs (TH.RecordPatSyn sels)
395 = do { sels' <- mapM vNameL sels
396 ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
397 ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
398
399 cvtDir _ Unidir = return Unidirectional
400 cvtDir _ ImplBidir = return ImplicitBidirectional
401 cvtDir n (ExplBidir cls) =
402 do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
403 ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
404
405 cvtDec (TH.PatSynSigD nm ty)
406 = do { nm' <- cNameL nm
407 ; ty' <- cvtPatSynSigTy ty
408 ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}
409
410 -- Implicit parameter bindings are handled in cvtLocalDecs and
411 -- cvtImplicitParamBind. They are not allowed in any other scope, so
412 -- reaching this case indicates an error.
413 cvtDec (TH.ImplicitParamBindD _ _)
414 = failWith (text "Implicit parameter binding only allowed in let or where")
415
416 ----------------
417 cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
418 cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
419 = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
420 ; (head_ty, args) <- split_ty_app lhs
421 ; case head_ty of
422 ConT nm -> do { nm' <- tconNameL nm
423 ; rhs' <- cvtType rhs
424 ; let args' = map wrap_tyarg args
425 ; returnL $ mkHsImplicitBndrs
426 $ FamEqn { feqn_ext = noExt
427 , feqn_tycon = nm'
428 , feqn_bndrs = mb_bndrs'
429 , feqn_pats = args'
430 , feqn_fixity = Prefix
431 , feqn_rhs = rhs' } }
432 InfixT t1 nm t2 -> do { nm' <- tconNameL nm
433 ; args' <- mapM cvtType [t1,t2]
434 ; rhs' <- cvtType rhs
435 ; returnL $ mkHsImplicitBndrs
436 $ FamEqn { feqn_ext = noExt
437 , feqn_tycon = nm'
438 , feqn_bndrs = mb_bndrs'
439 , feqn_pats =
440 (map HsValArg args') ++ args
441 , feqn_fixity = Hs.Infix
442 , feqn_rhs = rhs' } }
443 _ -> failWith $ text "Invalid type family instance LHS:"
444 <+> text (show lhs)
445 }
446
447 ----------------
448 cvt_ci_decs :: MsgDoc -> [TH.Dec]
449 -> CvtM (LHsBinds GhcPs,
450 [LSig GhcPs],
451 [LFamilyDecl GhcPs],
452 [LTyFamInstDecl GhcPs],
453 [LDataFamInstDecl GhcPs])
454 -- Convert the declarations inside a class or instance decl
455 -- ie signatures, bindings, and associated types
456 cvt_ci_decs doc decs
457 = do { decs' <- cvtDecs decs
458 ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
459 ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs'
460 ; let (sigs', prob_binds') = partitionWith is_sig no_ats'
461 ; let (binds', prob_fams') = partitionWith is_bind prob_binds'
462 ; let (fams', bads) = partitionWith is_fam_decl prob_fams'
463 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
464 --We use FromSource as the origin of the bind
465 -- because the TH declaration is user-written
466 ; return (listToBag binds', sigs', fams', ats', adts') }
467
468 ----------------
469 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
470 -> CvtM ( LHsContext GhcPs
471 , Located RdrName
472 , LHsQTyVars GhcPs)
473 cvt_tycl_hdr cxt tc tvs
474 = do { cxt' <- cvtContext cxt
475 ; tc' <- tconNameL tc
476 ; tvs' <- cvtTvs tvs
477 ; return (cxt', tc', tvs')
478 }
479
480 cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type
481 -> CvtM ( LHsContext GhcPs
482 , Located RdrName
483 , Maybe [LHsTyVarBndr GhcPs]
484 , HsTyPats GhcPs)
485 cvt_datainst_hdr cxt bndrs tys
486 = do { cxt' <- cvtContext cxt
487 ; bndrs' <- traverse (mapM cvt_tv) bndrs
488 ; (head_ty, args) <- split_ty_app tys
489 ; case head_ty of
490 ConT nm -> do { nm' <- tconNameL nm
491 ; let args' = map wrap_tyarg args
492 ; return (cxt', nm', bndrs', args') }
493 InfixT t1 nm t2 -> do { nm' <- tconNameL nm
494 ; args' <- mapM cvtType [t1,t2]
495 ; return (cxt', nm', bndrs',
496 ((map HsValArg args') ++ args)) }
497 _ -> failWith $ text "Invalid type instance header:"
498 <+> text (show tys) }
499
500 ----------------
501 cvt_tyfam_head :: TypeFamilyHead
502 -> CvtM ( Located RdrName
503 , LHsQTyVars GhcPs
504 , Hs.LFamilyResultSig GhcPs
505 , Maybe (Hs.LInjectivityAnn GhcPs))
506
507 cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
508 = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
509 ; result' <- cvtFamilyResultSig result
510 ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
511 ; return (tc', tyvars', result', injectivity') }
512
513 -------------------------------------------------------------------
514 -- Partitioning declarations
515 -------------------------------------------------------------------
516
517 is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
518 is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)
519 is_fam_decl decl = Right decl
520
521 is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
522 is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
523 = Left (cL loc d)
524 is_tyfam_inst decl
525 = Right decl
526
527 is_datafam_inst :: LHsDecl GhcPs
528 -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
529 is_datafam_inst (dL->L loc (Hs.InstD _ (DataFamInstD { dfid_inst = d })))
530 = Left (cL loc d)
531 is_datafam_inst decl
532 = Right decl
533
534 is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
535 is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)
536 is_sig decl = Right decl
537
538 is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
539 is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)
540 is_bind decl = Right decl
541
542 is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
543 is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
544 is_ip_bind decl = Right decl
545
546 mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
547 mkBadDecMsg doc bads
548 = sep [ text "Illegal declaration(s) in" <+> doc <> colon
549 , nest 2 (vcat (map Outputable.ppr bads)) ]
550
551 ---------------------------------------------------
552 -- Data types
553 ---------------------------------------------------
554
555 cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
556
557 cvtConstr (NormalC c strtys)
558 = do { c' <- cNameL c
559 ; tys' <- mapM cvt_arg strtys
560 ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }
561
562 cvtConstr (RecC c varstrtys)
563 = do { c' <- cNameL c
564 ; args' <- mapM cvt_id_arg varstrtys
565 ; returnL $ mkConDeclH98 c' Nothing Nothing
566 (RecCon (noLoc args')) }
567
568 cvtConstr (InfixC st1 c st2)
569 = do { c' <- cNameL c
570 ; st1' <- cvt_arg st1
571 ; st2' <- cvt_arg st2
572 ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }
573
574 cvtConstr (ForallC tvs ctxt con)
575 = do { tvs' <- cvtTvs tvs
576 ; ctxt' <- cvtContext ctxt
577 ; (dL->L _ con') <- cvtConstr con
578 ; returnL $ add_forall tvs' ctxt' con' }
579 where
580 add_cxt lcxt Nothing = Just lcxt
581 add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))
582 = Just (cL loc (cxt1 ++ cxt2))
583
584 add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
585 = con { con_forall = noLoc $ not (null all_tvs)
586 , con_qvars = mkHsQTvs all_tvs
587 , con_mb_cxt = add_cxt cxt' cxt }
588 where
589 all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars
590
591 add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
592 = con { con_forall = noLoc $ not (null all_tvs)
593 , con_ex_tvs = all_tvs
594 , con_mb_cxt = add_cxt cxt' cxt }
595 where
596 all_tvs = hsQTvExplicit tvs' ++ ex_tvs
597
598 add_forall _ _ (XConDecl _) = panic "cvtConstr"
599
600 cvtConstr (GadtC c strtys ty)
601 = do { c' <- mapM cNameL c
602 ; args <- mapM cvt_arg strtys
603 ; (dL->L _ ty') <- cvtType ty
604 ; c_ty <- mk_arr_apps args ty'
605 ; returnL $ fst $ mkGadtDecl c' c_ty}
606
607 cvtConstr (RecGadtC c varstrtys ty)
608 = do { c' <- mapM cNameL c
609 ; ty' <- cvtType ty
610 ; rec_flds <- mapM cvt_id_arg varstrtys
611 ; let rec_ty = noLoc (HsFunTy noExt
612 (noLoc $ HsRecTy noExt rec_flds) ty')
613 ; returnL $ fst $ mkGadtDecl c' rec_ty }
614
615 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
616 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
617 cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack
618 cvtSrcUnpackedness SourceUnpack = SrcUnpack
619
620 cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
621 cvtSrcStrictness NoSourceStrictness = NoSrcStrict
622 cvtSrcStrictness SourceLazy = SrcLazy
623 cvtSrcStrictness SourceStrict = SrcStrict
624
625 cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
626 cvt_arg (Bang su ss, ty)
627 = do { ty'' <- cvtType ty
628 ; let ty' = parenthesizeHsType appPrec ty''
629 su' = cvtSrcUnpackedness su
630 ss' = cvtSrcStrictness ss
631 ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
632
633 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
634 cvt_id_arg (i, str, ty)
635 = do { (dL->L li i') <- vNameL i
636 ; ty' <- cvt_arg (str,ty)
637 ; return $ noLoc (ConDeclField
638 { cd_fld_ext = noExt
639 , cd_fld_names
640 = [cL li $ FieldOcc noExt (cL li i')]
641 , cd_fld_type = ty'
642 , cd_fld_doc = Nothing}) }
643
644 cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
645 cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
646 ; returnL cs' }
647
648 cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
649 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
650 ; ys' <- mapM tNameL ys
651 ; returnL (xs', ys') }
652
653
654 ------------------------------------------
655 -- Foreign declarations
656 ------------------------------------------
657
658 cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
659 cvtForD (ImportF callconv safety from nm ty)
660 -- the prim and javascript calling conventions do not support headers
661 -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
662 | callconv == TH.Prim || callconv == TH.JavaScript
663 = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
664 (CFunction (StaticTarget (SourceText from)
665 (mkFastString from) Nothing
666 True))
667 (noLoc $ quotedSourceText from))
668 | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
669 (mkFastString (TH.nameBase nm))
670 from (noLoc $ quotedSourceText from)
671 = mk_imp impspec
672 | otherwise
673 = failWith $ text (show from) <+> text "is not a valid ccall impent"
674 where
675 mk_imp impspec
676 = do { nm' <- vNameL nm
677 ; ty' <- cvtType ty
678 ; return (ForeignImport { fd_i_ext = noExt
679 , fd_name = nm'
680 , fd_sig_ty = mkLHsSigType ty'
681 , fd_fi = impspec })
682 }
683 safety' = case safety of
684 Unsafe -> PlayRisky
685 Safe -> PlaySafe
686 Interruptible -> PlayInterruptible
687
688 cvtForD (ExportF callconv as nm ty)
689 = do { nm' <- vNameL nm
690 ; ty' <- cvtType ty
691 ; let e = CExport (noLoc (CExportStatic (SourceText as)
692 (mkFastString as)
693 (cvt_conv callconv)))
694 (noLoc (SourceText as))
695 ; return $ ForeignExport { fd_e_ext = noExt
696 , fd_name = nm'
697 , fd_sig_ty = mkLHsSigType ty'
698 , fd_fe = e } }
699
700 cvt_conv :: TH.Callconv -> CCallConv
701 cvt_conv TH.CCall = CCallConv
702 cvt_conv TH.StdCall = StdCallConv
703 cvt_conv TH.CApi = CApiConv
704 cvt_conv TH.Prim = PrimCallConv
705 cvt_conv TH.JavaScript = JavaScriptCallConv
706
707 ------------------------------------------
708 -- Pragmas
709 ------------------------------------------
710
711 cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
712 cvtPragmaD (InlineP nm inline rm phases)
713 = do { nm' <- vNameL nm
714 ; let dflt = dfltActivation inline
715 ; let src TH.NoInline = "{-# NOINLINE"
716 src TH.Inline = "{-# INLINE"
717 src TH.Inlinable = "{-# INLINABLE"
718 ; let ip = InlinePragma { inl_src = SourceText $ src inline
719 , inl_inline = cvtInline inline
720 , inl_rule = cvtRuleMatch rm
721 , inl_act = cvtPhases phases dflt
722 , inl_sat = Nothing }
723 ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip }
724
725 cvtPragmaD (SpecialiseP nm ty inline phases)
726 = do { nm' <- vNameL nm
727 ; ty' <- cvtType ty
728 ; let src TH.NoInline = "{-# SPECIALISE NOINLINE"
729 src TH.Inline = "{-# SPECIALISE INLINE"
730 src TH.Inlinable = "{-# SPECIALISE INLINE"
731 ; let (inline', dflt,srcText) = case inline of
732 Just inline1 -> (cvtInline inline1, dfltActivation inline1,
733 src inline1)
734 Nothing -> (NoUserInline, AlwaysActive,
735 "{-# SPECIALISE")
736 ; let ip = InlinePragma { inl_src = SourceText srcText
737 , inl_inline = inline'
738 , inl_rule = Hs.FunLike
739 , inl_act = cvtPhases phases dflt
740 , inl_sat = Nothing }
741 ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip }
742
743 cvtPragmaD (SpecialiseInstP ty)
744 = do { ty' <- cvtType ty
745 ; returnJustL $ Hs.SigD noExt $
746 SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
747
748 cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
749 = do { let nm' = mkFastString nm
750 ; let act = cvtPhases phases AlwaysActive
751 ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs
752 ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
753 ; lhs' <- cvtl lhs
754 ; rhs' <- cvtl rhs
755 ; returnJustL $ Hs.RuleD noExt
756 $ HsRules { rds_ext = noExt
757 , rds_src = SourceText "{-# RULES"
758 , rds_rules = [noLoc $
759 HsRule { rd_ext = noExt
760 , rd_name = (noLoc (quotedSourceText nm,nm'))
761 , rd_act = act
762 , rd_tyvs = ty_bndrs'
763 , rd_tmvs = tm_bndrs'
764 , rd_lhs = lhs'
765 , rd_rhs = rhs' }] }
766
767 }
768
769 cvtPragmaD (AnnP target exp)
770 = do { exp' <- cvtl exp
771 ; target' <- case target of
772 ModuleAnnotation -> return ModuleAnnProvenance
773 TypeAnnotation n -> do
774 n' <- tconName n
775 return (TypeAnnProvenance (noLoc n'))
776 ValueAnnotation n -> do
777 n' <- vcName n
778 return (ValueAnnProvenance (noLoc n'))
779 ; returnJustL $ Hs.AnnD noExt
780 $ HsAnnotation noExt (SourceText "{-# ANN") target' exp'
781 }
782
783 cvtPragmaD (LineP line file)
784 = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
785 ; return Nothing
786 }
787 cvtPragmaD (CompleteP cls mty)
788 = do { cls' <- noLoc <$> mapM cNameL cls
789 ; mty' <- traverse tconNameL mty
790 ; returnJustL $ Hs.SigD noExt
791 $ CompleteMatchSig noExt NoSourceText cls' mty' }
792
793 dfltActivation :: TH.Inline -> Activation
794 dfltActivation TH.NoInline = NeverActive
795 dfltActivation _ = AlwaysActive
796
797 cvtInline :: TH.Inline -> Hs.InlineSpec
798 cvtInline TH.NoInline = Hs.NoInline
799 cvtInline TH.Inline = Hs.Inline
800 cvtInline TH.Inlinable = Hs.Inlinable
801
802 cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
803 cvtRuleMatch TH.ConLike = Hs.ConLike
804 cvtRuleMatch TH.FunLike = Hs.FunLike
805
806 cvtPhases :: TH.Phases -> Activation -> Activation
807 cvtPhases AllPhases dflt = dflt
808 cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i
809 cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i
810
811 cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
812 cvtRuleBndr (RuleVar n)
813 = do { n' <- vNameL n
814 ; return $ noLoc $ Hs.RuleBndr noExt n' }
815 cvtRuleBndr (TypedRuleVar n ty)
816 = do { n' <- vNameL n
817 ; ty' <- cvtType ty
818 ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' }
819
820 ---------------------------------------------------
821 -- Declarations
822 ---------------------------------------------------
823
824 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
825 cvtLocalDecs doc ds
826 = case partitionWith is_ip_bind ds of
827 ([], []) -> return (EmptyLocalBinds noExt)
828 ([], _) -> do
829 ds' <- cvtDecs ds
830 let (binds, prob_sigs) = partitionWith is_bind ds'
831 let (sigs, bads) = partitionWith is_sig prob_sigs
832 unless (null bads) (failWith (mkBadDecMsg doc bads))
833 return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))
834 (ip_binds, []) -> do
835 binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
836 return (HsIPBinds noExt (IPBinds noExt binds))
837 ((_:_), (_:_)) ->
838 failWith (text "Implicit parameters mixed with other bindings")
839
840 cvtClause :: HsMatchContext RdrName
841 -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
842 cvtClause ctxt (Clause ps body wheres)
843 = do { ps' <- cvtPats ps
844 ; let pps = map (parenthesizePat appPrec) ps'
845 ; g' <- cvtGuard body
846 ; ds' <- cvtLocalDecs (text "a where clause") wheres
847 ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }
848
849 cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
850 cvtImplicitParamBind n e = do
851 n' <- wrapL (ipName n)
852 e' <- cvtl e
853 returnL (IPBind noExt (Left n') e')
854
855 -------------------------------------------------------------------
856 -- Expressions
857 -------------------------------------------------------------------
858
859 cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
860 cvtl e = wrapL (cvt e)
861 where
862 cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
863 cvt (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
864 cvt (LitE l)
865 | overloadedLit l = go cvtOverLit (HsOverLit noExt)
866 (hsOverLitNeedsParens appPrec)
867 | otherwise = go cvtLit (HsLit noExt)
868 (hsLitNeedsParens appPrec)
869 where
870 go :: (Lit -> CvtM (l GhcPs))
871 -> (l GhcPs -> HsExpr GhcPs)
872 -> (l GhcPs -> Bool)
873 -> CvtM (HsExpr GhcPs)
874 go cvt_lit mk_expr is_compound_lit = do
875 l' <- cvt_lit l
876 let e' = mk_expr l'
877 return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'
878 cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
879 ; return $ HsApp noExt (mkLHsPar x')
880 (mkLHsPar y')}
881 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
882 ; return $ HsApp noExt (mkLHsPar x')
883 (mkLHsPar y')}
884 cvt (AppTypeE e t) = do { e' <- cvtl e
885 ; t' <- cvtType t
886 ; let tp = parenthesizeHsType appPrec t'
887 ; return $ HsAppType noExt e'
888 $ mkHsWildCardBndrs tp }
889 cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its
890 -- own expression to avoid pretty-printing
891 -- oddities that can result from zero-argument
892 -- lambda expressions. See #13856.
893 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
894 ; let pats = map (parenthesizePat appPrec) ps'
895 ; return $ HsLam noExt (mkMatchGroup FromSource
896 [mkSimpleMatch LambdaExpr
897 pats e'])}
898 cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch CaseAlt) ms
899 ; return $ HsLamCase noExt
900 (mkMatchGroup FromSource ms')
901 }
902 cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
903 -- Note [Dropping constructors]
904 -- Singleton tuples treated like nothing (just parens)
905 cvt (TupE es) = do { es' <- mapM cvtl es
906 ; return $ ExplicitTuple noExt
907 (map (noLoc . (Present noExt)) es')
908 Boxed }
909 cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
910 ; return $ ExplicitTuple noExt
911 (map (noLoc . (Present noExt)) es')
912 Unboxed }
913 cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
914 ; unboxedSumChecks alt arity
915 ; return $ ExplicitSum noExt
916 alt arity e'}
917 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
918 ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
919 cvt (MultiIfE alts)
920 | null alts = failWith (text "Multi-way if-expression with no alternatives")
921 | otherwise = do { alts' <- mapM cvtpair alts
922 ; return $ HsMultiIf noExt alts' }
923 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
924 ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
925 cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
926 ; return $ HsCase noExt e'
927 (mkMatchGroup FromSource ms') }
928 cvt (DoE ss) = cvtHsDo DoExpr ss
929 cvt (MDoE ss) = cvtHsDo MDoExpr ss
930 cvt (CompE ss) = cvtHsDo ListComp ss
931 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
932 ; return $ ArithSeq noExt Nothing dd' }
933 cvt (ListE xs)
934 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s)
935 ; return (HsLit noExt l') }
936 -- Note [Converting strings]
937 | otherwise = do { xs' <- mapM cvtl xs
938 ; return $ ExplicitList noExt Nothing xs'
939 }
940
941 -- Infix expressions
942 cvt (InfixE (Just x) s (Just y)) =
943 do { x' <- cvtl x
944 ; s' <- cvtl s
945 ; y' <- cvtl y
946 ; let px = parenthesizeHsExpr opPrec x'
947 py = parenthesizeHsExpr opPrec y'
948 ; wrapParL (HsPar noExt)
949 $ OpApp noExt px s' py }
950 -- Parenthesise both arguments and result,
951 -- to ensure this operator application does
952 -- does not get re-associated
953 -- See Note [Operator association]
954 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
955 ; wrapParL (HsPar noExt) $
956 SectionR noExt s' y' }
957 -- See Note [Sections in HsSyn] in HsExpr
958 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
959 ; wrapParL (HsPar noExt) $
960 SectionL noExt x' s' }
961
962 cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s
963 ; return $ HsPar noExt s' }
964 -- Can I indicate this is an infix thing?
965 -- Note [Dropping constructors]
966
967 cvt (UInfixE x s y) = do { x' <- cvtl x
968 ; let x'' = case unLoc x' of
969 OpApp {} -> x'
970 _ -> mkLHsPar x'
971 ; cvtOpApp x'' s y } -- Note [Converting UInfix]
972
973 cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' }
974 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
975 ; let pe = parenthesizeHsExpr sigPrec e'
976 ; return $ ExprWithTySig noExt pe (mkLHsSigWcType t') }
977 cvt (RecConE c flds) = do { c' <- cNameL c
978 ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
979 ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
980 cvt (RecUpdE e flds) = do { e' <- cvtl e
981 ; flds'
982 <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
983 flds
984 ; return $ mkRdrRecordUpd e' flds' }
985 cvt (StaticE e) = fmap (HsStatic noExt) $ cvtl e
986 cvt (UnboundVarE s) = do -- Use of 'vcName' here instead of 'vName' is
987 -- important, because UnboundVarE may contain
988 -- constructor names - see #14627.
989 { s' <- vcName s
990 ; return $ HsVar noExt (noLoc s') }
991 cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) }
992 cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }
993
994 {- Note [Dropping constructors]
995 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
996 When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
997 we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
998 could meet @UInfix@ constructors containing the @TupE [e]@. For example:
999
1000 UInfixE x * (TupE [UInfixE y + z])
1001
1002 If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
1003 and the above expression would be reassociated to
1004
1005 OpApp (OpApp x * y) + z
1006
1007 which we don't want.
1008 -}
1009
1010 cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)
1011 -> CvtM (LHsRecField' t (LHsExpr GhcPs))
1012 cvtFld f (v,e)
1013 = do { v' <- vNameL v; e' <- cvtl e
1014 ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
1015 , hsRecFieldArg = e'
1016 , hsRecPun = False}) }
1017
1018 cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
1019 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
1020 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
1021 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
1022 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
1023
1024 {- Note [Operator assocation]
1025 We must be quite careful about adding parens:
1026 * Infix (UInfix ...) op arg Needs parens round the first arg
1027 * Infix (Infix ...) op arg Needs parens round the first arg
1028 * UInfix (UInfix ...) op arg No parens for first arg
1029 * UInfix (Infix ...) op arg Needs parens round first arg
1030
1031
1032 Note [Converting UInfix]
1033 ~~~~~~~~~~~~~~~~~~~~~~~~
1034 When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
1035 the trees to reflect the fixities of the underlying operators:
1036
1037 UInfixE x * (UInfixE y + z) ---> (x * y) + z
1038
1039 This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
1040 @mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
1041 right-biased for types and left-biased for everything else. So we left-bias the
1042 trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
1043
1044 Sample input:
1045
1046 UInfixE
1047 (UInfixE x op1 y)
1048 op2
1049 (UInfixE z op3 w)
1050
1051 Sample output:
1052
1053 OpApp
1054 (OpApp
1055 (OpApp x op1 y)
1056 op2
1057 z)
1058 op3
1059 w
1060
1061 The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
1062 biasing.
1063 -}
1064
1065 {- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
1066 The produced tree of infix expressions will be left-biased, provided @x@ is.
1067
1068 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
1069 is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
1070 this holds for both branches (of @cvtOpApp@), provided we assume it holds for
1071 the recursive calls to @cvtOpApp@.
1072
1073 When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
1074 since we have already run @cvtl@ on it.
1075 -}
1076 cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
1077 cvtOpApp x op1 (UInfixE y op2 z)
1078 = do { l <- wrapL $ cvtOpApp x op1 y
1079 ; cvtOpApp l op2 z }
1080 cvtOpApp x op y
1081 = do { op' <- cvtl op
1082 ; y' <- cvtl y
1083 ; return (OpApp noExt x op' y') }
1084
1085 -------------------------------------
1086 -- Do notation and statements
1087 -------------------------------------
1088
1089 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
1090 cvtHsDo do_or_lc stmts
1091 | null stmts = failWith (text "Empty stmt list in do-block")
1092 | otherwise
1093 = do { stmts' <- cvtStmts stmts
1094 ; let Just (stmts'', last') = snocView stmts'
1095
1096 ; last'' <- case last' of
1097 (dL->L loc (BodyStmt _ body _ _))
1098 -> return (cL loc (mkLastStmt body))
1099 _ -> failWith (bad_last last')
1100
1101 ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
1102 where
1103 bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
1104 , nest 2 $ Outputable.ppr stmt
1105 , text "(It should be an expression.)" ]
1106
1107 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]
1108 cvtStmts = mapM cvtStmt
1109
1110 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
1111 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
1112 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
1113 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds
1114 ; returnL $ LetStmt noExt (noLoc ds') }
1115 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss
1116 ; returnL $ ParStmt noExt dss' noExpr noSyntaxExpr }
1117 where
1118 cvt_one ds = do { ds' <- cvtStmts ds
1119 ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
1120 cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }
1121
1122 cvtMatch :: HsMatchContext RdrName
1123 -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
1124 cvtMatch ctxt (TH.Match p body decs)
1125 = do { p' <- cvtPat p
1126 ; let lp = case p' of
1127 (dL->L loc SigPat{}) -> cL loc (ParPat NoExt p') -- #14875
1128 _ -> p'
1129 ; g' <- cvtGuard body
1130 ; decs' <- cvtLocalDecs (text "a where clause") decs
1131 ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }
1132
1133 cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
1134 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
1135 cvtGuard (NormalB e) = do { e' <- cvtl e
1136 ; g' <- returnL $ GRHS noExt [] e'; return [g'] }
1137
1138 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
1139 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
1140 ; g' <- returnL $ mkBodyStmt ge'
1141 ; returnL $ GRHS noExt [g'] rhs' }
1142 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
1143 ; returnL $ GRHS noExt gs' rhs' }
1144
1145 cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
1146 cvtOverLit (IntegerL i)
1147 = do { force i; return $ mkHsIntegral (mkIntegralLit i) }
1148 cvtOverLit (RationalL r)
1149 = do { force r; return $ mkHsFractional (mkFractionalLit r) }
1150 cvtOverLit (StringL s)
1151 = do { let { s' = mkFastString s }
1152 ; force s'
1153 ; return $ mkHsIsString (quotedSourceText s) s'
1154 }
1155 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
1156 -- An Integer is like an (overloaded) '3' in a Haskell source program
1157 -- Similarly 3.5 for fractionals
1158
1159 {- Note [Converting strings]
1160 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1161 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
1162 a string literal for "xy". Of course, we might hope to get
1163 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
1164 if it isn't a literal string
1165 -}
1166
1167 allCharLs :: [TH.Exp] -> Maybe String
1168 -- Note [Converting strings]
1169 -- NB: only fire up this setup for a non-empty list, else
1170 -- there's a danger of returning "" for [] :: [Int]!
1171 allCharLs xs
1172 = case xs of
1173 LitE (CharL c) : ys -> go [c] ys
1174 _ -> Nothing
1175 where
1176 go cs [] = Just (reverse cs)
1177 go cs (LitE (CharL c) : ys) = go (c:cs) ys
1178 go _ _ = Nothing
1179
1180 cvtLit :: Lit -> CvtM (HsLit GhcPs)
1181 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i }
1182 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w }
1183 cvtLit (FloatPrimL f)
1184 = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }
1185 cvtLit (DoublePrimL f)
1186 = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
1187 cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c }
1188 cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c }
1189 cvtLit (StringL s) = do { let { s' = mkFastString s }
1190 ; force s'
1191 ; return $ HsString (quotedSourceText s) s' }
1192 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
1193 ; force s'
1194 ; return $ HsStringPrim NoSourceText s' }
1195 cvtLit (BytesPrimL (Bytes fptr off sz)) = do
1196 let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr ->
1197 BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz)
1198 force bs
1199 return $ HsStringPrim NoSourceText bs
1200 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
1201 -- cvtLit should not be called on IntegerL, RationalL
1202 -- That precondition is established right here in
1203 -- Convert.hs, hence panic
1204
1205 quotedSourceText :: String -> SourceText
1206 quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
1207
1208 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
1209 cvtPats pats = mapM cvtPat pats
1210
1211 cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
1212 cvtPat pat = wrapL (cvtp pat)
1213
1214 cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
1215 cvtp (TH.LitP l)
1216 | overloadedLit l = do { l' <- cvtOverLit l
1217 ; return (mkNPat (noLoc l') Nothing) }
1218 -- Not right for negative patterns;
1219 -- need to think about that!
1220 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }
1221 cvtp (TH.VarP s) = do { s' <- vName s
1222 ; return $ Hs.VarPat noExt (noLoc s') }
1223 cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat noExt p' }
1224 -- Note [Dropping constructors]
1225 cvtp (TupP ps) = do { ps' <- cvtPats ps
1226 ; return $ TuplePat noExt ps' Boxed }
1227 cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps
1228 ; return $ TuplePat noExt ps' Unboxed }
1229 cvtp (UnboxedSumP p alt arity)
1230 = do { p' <- cvtPat p
1231 ; unboxedSumChecks alt arity
1232 ; return $ SumPat noExt p' alt arity }
1233 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
1234 ; let pps = map (parenthesizePat appPrec) ps'
1235 ; return $ ConPatIn s' (PrefixCon pps) }
1236 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
1237 ; wrapParL (ParPat noExt) $
1238 ConPatIn s' $
1239 InfixCon (parenthesizePat opPrec p1')
1240 (parenthesizePat opPrec p2') }
1241 -- See Note [Operator association]
1242 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
1243 cvtp (ParensP p) = do { p' <- cvtPat p;
1244 ; case unLoc p' of -- may be wrapped ConPatIn
1245 ParPat {} -> return $ unLoc p'
1246 _ -> return $ ParPat noExt p' }
1247 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat noExt p' }
1248 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat noExt p' }
1249 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p
1250 ; return $ AsPat noExt s' p' }
1251 cvtp TH.WildP = return $ WildPat noExt
1252 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
1253 ; return $ ConPatIn c'
1254 $ Hs.RecCon (HsRecFields fs' Nothing) }
1255 cvtp (ListP ps) = do { ps' <- cvtPats ps
1256 ; return
1257 $ ListPat noExt ps'}
1258 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
1259 ; return $ SigPat noExt p' (mkLHsSigWcType t') }
1260 cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
1261 ; return $ ViewPat noExt e' p'}
1262
1263 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
1264 cvtPatFld (s,p)
1265 = do { (dL->L ls s') <- vNameL s
1266 ; p' <- cvtPat p
1267 ; return (noLoc $ HsRecField { hsRecFieldLbl
1268 = cL ls $ mkFieldOcc (cL ls s')
1269 , hsRecFieldArg = p'
1270 , hsRecPun = False}) }
1271
1272 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
1273 The produced tree of infix patterns will be left-biased, provided @x@ is.
1274
1275 See the @cvtOpApp@ documentation for how this function works.
1276 -}
1277 cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)
1278 cvtOpAppP x op1 (UInfixP y op2 z)
1279 = do { l <- wrapL $ cvtOpAppP x op1 y
1280 ; cvtOpAppP l op2 z }
1281 cvtOpAppP x op y
1282 = do { op' <- cNameL op
1283 ; y' <- cvtPat y
1284 ; return (ConPatIn op' (InfixCon x y')) }
1285
1286 -----------------------------------------------------------
1287 -- Types and type variables
1288
1289 cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
1290 cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
1291
1292 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
1293 cvt_tv (TH.PlainTV nm)
1294 = do { nm' <- tNameL nm
1295 ; returnL $ UserTyVar noExt nm' }
1296 cvt_tv (TH.KindedTV nm ki)
1297 = do { nm' <- tNameL nm
1298 ; ki' <- cvtKind ki
1299 ; returnL $ KindedTyVar noExt nm' ki' }
1300
1301 cvtRole :: TH.Role -> Maybe Coercion.Role
1302 cvtRole TH.NominalR = Just Coercion.Nominal
1303 cvtRole TH.RepresentationalR = Just Coercion.Representational
1304 cvtRole TH.PhantomR = Just Coercion.Phantom
1305 cvtRole TH.InferR = Nothing
1306
1307 cvtContext :: TH.Cxt -> CvtM (LHsContext GhcPs)
1308 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
1309
1310 cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
1311 cvtPred = cvtType
1312
1313 cvtDerivClause :: TH.DerivClause
1314 -> CvtM (LHsDerivingClause GhcPs)
1315 cvtDerivClause (TH.DerivClause ds ctxt)
1316 = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext ctxt
1317 ; ds' <- traverse cvtDerivStrategy ds
1318 ; returnL $ HsDerivingClause noExt ds' ctxt' }
1319
1320 cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
1321 cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy
1322 cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy
1323 cvtDerivStrategy TH.NewtypeStrategy = returnL Hs.NewtypeStrategy
1324 cvtDerivStrategy (TH.ViaStrategy ty) = do
1325 ty' <- cvtType ty
1326 returnL $ Hs.ViaStrategy (mkLHsSigType ty')
1327
1328 cvtType :: TH.Type -> CvtM (LHsType GhcPs)
1329 cvtType = cvtTypeKind "type"
1330
1331 cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
1332 cvtTypeKind ty_str ty
1333 = do { (head_ty, tys') <- split_ty_app ty
1334 ; let m_normals = mapM extract_normal tys'
1335 where extract_normal (HsValArg ty) = Just ty
1336 extract_normal _ = Nothing
1337
1338 ; case head_ty of
1339 TupleT n
1340 | Just normals <- m_normals
1341 , normals `lengthIs` n -- Saturated
1342 -> if n==1 then return (head normals) -- Singleton tuples treated
1343 -- like nothing (ie just parens)
1344 else returnL (HsTupleTy noExt
1345 HsBoxedOrConstraintTuple normals)
1346 | n == 1
1347 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
1348 | otherwise
1349 -> mk_apps
1350 (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
1351 tys'
1352 UnboxedTupleT n
1353 | Just normals <- m_normals
1354 , normals `lengthIs` n -- Saturated
1355 -> returnL (HsTupleTy noExt HsUnboxedTuple normals)
1356 | otherwise
1357 -> mk_apps
1358 (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))
1359 tys'
1360 UnboxedSumT n
1361 | n < 2
1362 -> failWith $
1363 vcat [ text "Illegal sum arity:" <+> text (show n)
1364 , nest 2 $
1365 text "Sums must have an arity of at least 2" ]
1366 | Just normals <- m_normals
1367 , normals `lengthIs` n -- Saturated
1368 -> returnL (HsSumTy noExt normals)
1369 | otherwise
1370 -> mk_apps
1371 (HsTyVar noExt NotPromoted (noLoc (getRdrName (sumTyCon n))))
1372 tys'
1373 ArrowT
1374 | Just normals <- m_normals
1375 , [x',y'] <- normals -> do
1376 x'' <- case unLoc x' of
1377 HsFunTy{} -> returnL (HsParTy noExt x')
1378 HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646
1379 HsQualTy{} -> returnL (HsParTy noExt x') -- #15324
1380 _ -> return $
1381 parenthesizeHsType sigPrec x'
1382 let y'' = parenthesizeHsType sigPrec y'
1383 returnL (HsFunTy noExt x'' y'')
1384 | otherwise
1385 -> mk_apps
1386 (HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon)))
1387 tys'
1388 ListT
1389 | Just normals <- m_normals
1390 , [x'] <- normals -> do
1391 returnL (HsListTy noExt x')
1392 | otherwise
1393 -> mk_apps
1394 (HsTyVar noExt NotPromoted (noLoc (getRdrName listTyCon)))
1395 tys'
1396
1397 VarT nm -> do { nm' <- tNameL nm
1398 ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
1399 ConT nm -> do { nm' <- tconName nm
1400 ; -- ConT can contain both data constructor (i.e.,
1401 -- promoted) names and other (i.e, unpromoted)
1402 -- names, as opposed to PromotedT, which can only
1403 -- contain data constructor names. See #15572.
1404 let prom = if isRdrDataCon nm'
1405 then IsPromoted
1406 else NotPromoted
1407 ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}
1408
1409 ForallT tvs cxt ty
1410 | null tys'
1411 -> do { tvs' <- cvtTvs tvs
1412 ; cxt' <- cvtContext cxt
1413 ; let pcxt = parenthesizeHsContext funPrec cxt'
1414 ; ty' <- cvtType ty
1415 ; loc <- getL
1416 ; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty
1417 rho_ty = mkHsQualTy cxt loc pcxt ty'
1418
1419 ; return hs_ty }
1420
1421 ForallVisT tvs ty
1422 | null tys'
1423 -> do { tvs' <- cvtTvs tvs
1424 ; ty' <- cvtType ty
1425 ; loc <- getL
1426 ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' }
1427
1428 SigT ty ki
1429 -> do { ty' <- cvtType ty
1430 ; ki' <- cvtKind ki
1431 ; mk_apps (HsKindSig noExt ty' ki') tys'
1432 }
1433
1434 LitT lit
1435 -> mk_apps (HsTyLit noExt (cvtTyLit lit)) tys'
1436
1437 WildCardT
1438 -> mk_apps mkAnonWildCardTy tys'
1439
1440 InfixT t1 s t2
1441 -> do { s' <- tconName s
1442 ; t1' <- cvtType t1
1443 ; t2' <- cvtType t2
1444 ; mk_apps
1445 (HsTyVar noExt NotPromoted (noLoc s'))
1446 ([HsValArg t1', HsValArg t2'] ++ tys')
1447 }
1448
1449 UInfixT t1 s t2
1450 -> do { t2' <- cvtType t2
1451 ; t <- cvtOpAppT t1 s t2'
1452 ; mk_apps (unLoc t) tys'
1453 } -- Note [Converting UInfix]
1454
1455 ParensT t
1456 -> do { t' <- cvtType t
1457 ; mk_apps (HsParTy noExt t') tys'
1458 }
1459
1460 PromotedT nm -> do { nm' <- cName nm
1461 ; mk_apps (HsTyVar noExt IsPromoted (noLoc nm'))
1462 tys' }
1463 -- Promoted data constructor; hence cName
1464
1465 PromotedTupleT n
1466 | n == 1
1467 -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
1468 | Just normals <- m_normals
1469 , normals `lengthIs` n -- Saturated
1470 -> returnL (HsExplicitTupleTy noExt normals)
1471 | otherwise
1472 -> mk_apps
1473 (HsTyVar noExt IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))
1474 tys'
1475
1476 PromotedNilT
1477 -> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'
1478
1479 PromotedConsT -- See Note [Representing concrete syntax in types]
1480 -- in Language.Haskell.TH.Syntax
1481 | Just normals <- m_normals
1482 , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals
1483 -> do
1484 returnL (HsExplicitListTy noExt ip (ty1:tys2))
1485 | otherwise
1486 -> mk_apps
1487 (HsTyVar noExt IsPromoted (noLoc (getRdrName consDataCon)))
1488 tys'
1489
1490 StarT
1491 -> mk_apps
1492 (HsTyVar noExt NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))
1493 tys'
1494
1495 ConstraintT
1496 -> mk_apps
1497 (HsTyVar noExt NotPromoted (noLoc (getRdrName constraintKindTyCon)))
1498 tys'
1499
1500 EqualityT
1501 | Just normals <- m_normals
1502 , [x',y'] <- normals ->
1503 let px = parenthesizeHsType opPrec x'
1504 py = parenthesizeHsType opPrec y'
1505 in returnL (HsOpTy noExt px (noLoc eqTyCon_RDR) py)
1506 -- The long-term goal is to remove the above case entirely and
1507 -- subsume it under the case for InfixT. See #15815, comment:6,
1508 -- for more details.
1509
1510 | otherwise ->
1511 mk_apps (HsTyVar noExt NotPromoted
1512 (noLoc eqTyCon_RDR)) tys'
1513 ImplicitParamT n t
1514 -> do { n' <- wrapL $ ipName n
1515 ; t' <- cvtType t
1516 ; returnL (HsIParamTy noExt n' t')
1517 }
1518
1519 _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
1520 }
1521
1522 -- | Constructs an application of a type to arguments passed in a list.
1523 mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
1524 mk_apps head_ty type_args = do
1525 head_ty' <- returnL head_ty
1526 -- We must parenthesize the function type in case of an explicit
1527 -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there
1528 -- _must_ be parentheses around `Maybe :: Type -> Type`.
1529 let phead_ty :: LHsType GhcPs
1530 phead_ty = parenthesizeHsType sigPrec head_ty'
1531
1532 go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
1533 go [] = pure head_ty'
1534 go (arg:args) =
1535 case arg of
1536 HsValArg ty -> do p_ty <- add_parens ty
1537 mk_apps (HsAppTy noExt phead_ty p_ty) args
1538 HsTypeArg l ki -> do p_ki <- add_parens ki
1539 mk_apps (HsAppKindTy l phead_ty p_ki) args
1540 HsArgPar _ -> mk_apps (HsParTy noExt phead_ty) args
1541
1542 go type_args
1543 where
1544 -- See Note [Adding parens for splices]
1545 add_parens lt@(dL->L _ t)
1546 | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
1547 | otherwise = return lt
1548
1549 wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
1550 wrap_tyarg (HsValArg ty) = HsValArg $ parenthesizeHsType appPrec ty
1551 wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki
1552 wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized
1553
1554 -- ---------------------------------------------------------------------
1555 -- Note [Adding parens for splices]
1556 {-
1557 The hsSyn representation of parsed source explicitly contains all the original
1558 parens, as written in the source.
1559
1560 When a Template Haskell (TH) splice is evaluated, the original splice is first
1561 renamed and type checked and then finally converted to core in DsMeta. This core
1562 is then run in the TH engine, and the result comes back as a TH AST.
1563
1564 In the process, all parens are stripped out, as they are not needed.
1565
1566 This Convert module then converts the TH AST back to hsSyn AST.
1567
1568 In order to pretty-print this hsSyn AST, parens need to be adde back at certain
1569 points so that the code is readable with its original meaning.
1570
1571 So scattered through Convert.hs are various points where parens are added.
1572
1573 See (among other closed issued) https://ghc.haskell.org/trac/ghc/ticket/14289
1574 -}
1575 -- ---------------------------------------------------------------------
1576
1577 -- | Constructs an arrow type with a specified return type
1578 mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
1579 mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
1580 where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
1581 go arg ret_ty = do { ret_ty_l <- returnL ret_ty
1582 ; return (HsFunTy noExt arg ret_ty_l) }
1583
1584 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
1585 split_ty_app ty = go ty []
1586 where
1587 go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }
1588 go (AppKindT ty ki) as' = do { ki' <- cvtKind ki
1589 ; go ty (HsTypeArg noSrcSpan ki':as') }
1590 go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
1591 go f as = return (f,as)
1592
1593 cvtTyLit :: TH.TyLit -> HsTyLit
1594 cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
1595 cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
1596
1597 {- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
1598 application @x `op` y@. The produced tree of infix types will be right-biased,
1599 provided @y@ is.
1600
1601 See the @cvtOpApp@ documentation for how this function works.
1602 -}
1603 cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
1604 cvtOpAppT (UInfixT x op2 y) op1 z
1605 = do { l <- cvtOpAppT y op1 z
1606 ; cvtOpAppT x op2 l }
1607 cvtOpAppT x op y
1608 = do { op' <- tconNameL op
1609 ; x' <- cvtType x
1610 ; returnL (mkHsOpTy x' op' y) }
1611
1612 cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
1613 cvtKind = cvtTypeKind "kind"
1614
1615 -- | Convert Maybe Kind to a type family result signature. Used with data
1616 -- families where naming of the result is not possible (thus only kind or no
1617 -- signature is possible).
1618 cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
1619 -> CvtM (LFamilyResultSig GhcPs)
1620 cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExt)
1621 cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
1622 ; returnL (Hs.KindSig noExt ki') }
1623
1624 -- | Convert type family result signature. Used with both open and closed type
1625 -- families.
1626 cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
1627 cvtFamilyResultSig TH.NoSig = returnL (Hs.NoSig noExt)
1628 cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki
1629 ; returnL (Hs.KindSig noExt ki') }
1630 cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
1631 ; returnL (Hs.TyVarSig noExt tv) }
1632
1633 -- | Convert injectivity annotation of a type family.
1634 cvtInjectivityAnnotation :: TH.InjectivityAnn
1635 -> CvtM (Hs.LInjectivityAnn GhcPs)
1636 cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
1637 = do { annLHS' <- tNameL annLHS
1638 ; annRHS' <- mapM tNameL annRHS
1639 ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
1640
1641 cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)
1642 -- pattern synonym types are of peculiar shapes, which is why we treat
1643 -- them separately from regular types;
1644 -- see Note [Pattern synonym type signatures and Template Haskell]
1645 cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
1646 | null exis, null provs = cvtType (ForallT univs reqs ty)
1647 | null univs, null reqs = do { l <- getL
1648 ; ty' <- cvtType (ForallT exis provs ty)
1649 ; return $ cL l (HsQualTy { hst_ctxt = cL l []
1650 , hst_xqual = noExt
1651 , hst_body = ty' }) }
1652 | null reqs = do { l <- getL
1653 ; univs' <- hsQTvExplicit <$> cvtTvs univs
1654 ; ty' <- cvtType (ForallT exis provs ty)
1655 ; let forTy = HsForAllTy
1656 { hst_fvf = ForallInvis
1657 , hst_bndrs = univs'
1658 , hst_xforall = noExt
1659 , hst_body = cL l cxtTy }
1660 cxtTy = HsQualTy { hst_ctxt = cL l []
1661 , hst_xqual = noExt
1662 , hst_body = ty' }
1663 ; return $ cL l forTy }
1664 | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
1665 cvtPatSynSigTy ty = cvtType ty
1666
1667 -----------------------------------------------------------
1668 cvtFixity :: TH.Fixity -> Hs.Fixity
1669 cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)
1670 where
1671 cvt_dir TH.InfixL = Hs.InfixL
1672 cvt_dir TH.InfixR = Hs.InfixR
1673 cvt_dir TH.InfixN = Hs.InfixN
1674
1675 -----------------------------------------------------------
1676
1677
1678 -----------------------------------------------------------
1679 -- some useful things
1680
1681 overloadedLit :: Lit -> Bool
1682 -- True for literals that Haskell treats as overloaded
1683 overloadedLit (IntegerL _) = True
1684 overloadedLit (RationalL _) = True
1685 overloadedLit _ = False
1686
1687 -- Checks that are performed when converting unboxed sum expressions and
1688 -- patterns alike.
1689 unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
1690 unboxedSumChecks alt arity
1691 | alt > arity
1692 = failWith $ text "Sum alternative" <+> text (show alt)
1693 <+> text "exceeds its arity," <+> text (show arity)
1694 | alt <= 0
1695 = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)
1696 , nest 2 $ text "Sum alternatives must start from 1" ]
1697 | arity < 2
1698 = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)
1699 , nest 2 $ text "Sums must have an arity of at least 2" ]
1700 | otherwise
1701 = return ()
1702
1703 -- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the
1704 -- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
1705 -- using the provided 'LHsQTyVars' and 'LHsType'.
1706 mkHsForAllTy :: [TH.TyVarBndr]
1707 -- ^ The original Template Haskell type variable binders
1708 -> SrcSpan
1709 -- ^ The location of the returned 'LHsType' if it needs an
1710 -- explicit forall
1711 -> ForallVisFlag
1712 -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@)
1713 -- or invisible (e.g., @forall a.@)
1714 -> LHsQTyVars GhcPs
1715 -- ^ The converted type variable binders
1716 -> LHsType GhcPs
1717 -- ^ The converted rho type
1718 -> LHsType GhcPs
1719 -- ^ The complete type, quantified with a forall if necessary
1720 mkHsForAllTy tvs loc fvf tvs' rho_ty
1721 | null tvs = rho_ty
1722 | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf
1723 , hst_bndrs = hsQTvExplicit tvs'
1724 , hst_xforall = noExt
1725 , hst_body = rho_ty }
1726
1727 -- | If passed an empty 'TH.Cxt', this simply returns the third argument
1728 -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
1729 -- 'LHsContext' and 'LHsType'.
1730
1731 -- It's important that we don't build an HsQualTy if the context is empty,
1732 -- as the pretty-printer for HsType _always_ prints contexts, even if
1733 -- they're empty. See Trac #13183.
1734 mkHsQualTy :: TH.Cxt
1735 -- ^ The original Template Haskell context
1736 -> SrcSpan
1737 -- ^ The location of the returned 'LHsType' if it needs an
1738 -- explicit context
1739 -> LHsContext GhcPs
1740 -- ^ The converted context
1741 -> LHsType GhcPs
1742 -- ^ The converted tau type
1743 -> LHsType GhcPs
1744 -- ^ The complete type, qualified with a context if necessary
1745 mkHsQualTy ctxt loc ctxt' ty
1746 | null ctxt = ty
1747 | otherwise = cL loc $ HsQualTy { hst_xqual = noExt
1748 , hst_ctxt = ctxt'
1749 , hst_body = ty }
1750
1751 --------------------------------------------------------------------
1752 -- Turning Name back into RdrName
1753 --------------------------------------------------------------------
1754
1755 -- variable names
1756 vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
1757 vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName
1758
1759 -- Variable names
1760 vNameL n = wrapL (vName n)
1761 vName n = cvtName OccName.varName n
1762
1763 -- Constructor function names; this is Haskell source, hence srcDataName
1764 cNameL n = wrapL (cName n)
1765 cName n = cvtName OccName.dataName n
1766
1767 -- Variable *or* constructor names; check by looking at the first char
1768 vcNameL n = wrapL (vcName n)
1769 vcName n = if isVarName n then vName n else cName n
1770
1771 -- Type variable names
1772 tNameL n = wrapL (tName n)
1773 tName n = cvtName OccName.tvName n
1774
1775 -- Type Constructor names
1776 tconNameL n = wrapL (tconName n)
1777 tconName n = cvtName OccName.tcClsName n
1778
1779 ipName :: String -> CvtM HsIPName
1780 ipName n
1781 = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))
1782 ; return (HsIPName (fsLit n)) }
1783
1784 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
1785 cvtName ctxt_ns (TH.Name occ flavour)
1786 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
1787 | otherwise
1788 = do { loc <- getL
1789 ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
1790 ; force rdr_name
1791 ; return rdr_name }
1792 where
1793 occ_str = TH.occString occ
1794
1795 okOcc :: OccName.NameSpace -> String -> Bool
1796 okOcc ns str
1797 | OccName.isVarNameSpace ns = okVarOcc str
1798 | OccName.isDataConNameSpace ns = okConOcc str
1799 | otherwise = okTcOcc str
1800
1801 -- Determine the name space of a name in a type
1802 --
1803 isVarName :: TH.Name -> Bool
1804 isVarName (TH.Name occ _)
1805 = case TH.occString occ of
1806 "" -> False
1807 (c:_) -> startsVarId c || startsVarSym c
1808
1809 badOcc :: OccName.NameSpace -> String -> SDoc
1810 badOcc ctxt_ns occ
1811 = text "Illegal" <+> pprNameSpace ctxt_ns
1812 <+> text "name:" <+> quotes (text occ)
1813
1814 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
1815 -- This turns a TH Name into a RdrName; used for both binders and occurrences
1816 -- See Note [Binders in Template Haskell]
1817 -- The passed-in name space tells what the context is expecting;
1818 -- use it unless the TH name knows what name-space it comes
1819 -- from, in which case use the latter
1820 --
1821 -- We pass in a SrcSpan (gotten from the monad) because this function
1822 -- is used for *binders* and if we make an Exact Name we want it
1823 -- to have a binding site inside it. (cf Trac #5434)
1824 --
1825 -- ToDo: we may generate silly RdrNames, by passing a name space
1826 -- that doesn't match the string, like VarName ":+",
1827 -- which will give confusing error messages later
1828 --
1829 -- The strict applications ensure that any buried exceptions get forced
1830 thRdrName loc ctxt_ns th_occ th_name
1831 = case th_name of
1832 TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
1833 TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ
1834 TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
1835 TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
1836 TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
1837 | otherwise -> mkRdrUnqual $! occ
1838 -- We check for built-in syntax here, because the TH
1839 -- user might have written a (NameS "(,,)"), for example
1840 where
1841 occ :: OccName.OccName
1842 occ = mk_occ ctxt_ns th_occ
1843
1844 -- Return an unqualified exact RdrName if we're dealing with built-in syntax.
1845 -- See Trac #13776.
1846 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
1847 thOrigRdrName occ th_ns pkg mod =
1848 let occ' = mk_occ (mk_ghc_ns th_ns) occ
1849 in case isBuiltInOcc_maybe occ' of
1850 Just name -> nameRdrName name
1851 Nothing -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'
1852
1853 thRdrNameGuesses :: TH.Name -> [RdrName]
1854 thRdrNameGuesses (TH.Name occ flavour)
1855 -- This special case for NameG ensures that we don't generate duplicates in the output list
1856 | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
1857 | otherwise = [ thRdrName noSrcSpan gns occ_str flavour
1858 | gns <- guessed_nss]
1859 where
1860 -- guessed_ns are the name spaces guessed from looking at the TH name
1861 guessed_nss
1862 | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
1863 | otherwise = [OccName.varName, OccName.tvName]
1864 occ_str = TH.occString occ
1865
1866 -- The packing and unpacking is rather turgid :-(
1867 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
1868 mk_occ ns occ = OccName.mkOccName ns occ
1869
1870 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
1871 mk_ghc_ns TH.DataName = OccName.dataName
1872 mk_ghc_ns TH.TcClsName = OccName.tcClsName
1873 mk_ghc_ns TH.VarName = OccName.varName
1874
1875 mk_mod :: TH.ModName -> ModuleName
1876 mk_mod mod = mkModuleName (TH.modString mod)
1877
1878 mk_pkg :: TH.PkgName -> UnitId
1879 mk_pkg pkg = stringToUnitId (TH.pkgString pkg)
1880
1881 mk_uniq :: Int -> Unique
1882 mk_uniq u = mkUniqueGrimily u
1883
1884 {-
1885 Note [Binders in Template Haskell]
1886 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1887 Consider this TH term construction:
1888 do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name
1889 ; x2 <- TH.newName "x" -- Builds a NameU
1890 ; x3 <- TH.newName "x"
1891
1892 ; let x = mkName "x" -- mkName :: String -> TH.Name
1893 -- Builds a NameS
1894
1895 ; return (LamE (..pattern [x1,x2]..) $
1896 LamE (VarPat x3) $
1897 ..tuple (x1,x2,x3,x)) }
1898
1899 It represents the term \[x1,x2]. \x3. (x1,x2,x3,x)
1900
1901 a) We don't want to complain about "x" being bound twice in
1902 the pattern [x1,x2]
1903 b) We don't want x3 to shadow the x1,x2
1904 c) We *do* want 'x' (dynamically bound with mkName) to bind
1905 to the innermost binding of "x", namely x3.
1906 d) When pretty printing, we want to print a unique with x1,x2
1907 etc, else they'll all print as "x" which isn't very helpful
1908
1909 When we convert all this to HsSyn, the TH.Names are converted with
1910 thRdrName. To achieve (b) we want the binders to be Exact RdrNames.
1911 Achieving (a) is a bit awkward, because
1912 - We must check for duplicate and shadowed names on Names,
1913 not RdrNames, *after* renaming.
1914 See Note [Collect binders only after renaming] in HsUtils
1915
1916 - But to achieve (a) we must distinguish between the Exact
1917 RdrNames arising from TH and the Unqual RdrNames that would
1918 come from a user writing \[x,x] -> blah
1919
1920 So in Convert.thRdrName we translate
1921 TH Name RdrName
1922 --------------------------------------------------------
1923 NameU (arising from newName) --> Exact (Name{ System })
1924 NameS (arising from mkName) --> Unqual
1925
1926 Notice that the NameUs generate *System* Names. Then, when
1927 figuring out shadowing and duplicates, we can filter out
1928 System Names.
1929
1930 This use of System Names fits with other uses of System Names, eg for
1931 temporary variables "a". Since there are lots of things called "a" we
1932 usually want to print the name with the unique, and that is indeed
1933 the way System Names are printed.
1934
1935 There's a small complication of course; see Note [Looking up Exact
1936 RdrNames] in RnEnv.
1937 -}
1938
1939 {-
1940 Note [Pattern synonym type signatures and Template Haskell]
1941 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1942
1943 In general, the type signature of a pattern synonym
1944
1945 pattern P x1 x2 .. xn = <some-pattern>
1946
1947 is of the form
1948
1949 forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
1950
1951 with the following parts:
1952
1953 1) the (possibly empty lists of) universally quantified type
1954 variables `univs` and required constraints `reqs` on them.
1955 2) the (possibly empty lists of) existentially quantified type
1956 variables `exis` and the provided constraints `provs` on them.
1957 3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
1958 x2, .., xn, respectively
1959 4) the type `t` of <some-pattern>, mentioning only universals from `univs`.
1960
1961 Due to the two forall quantifiers and constraint contexts (either of
1962 which might be empty), pattern synonym type signatures are treated
1963 specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
1964 `typecheck/TcSplice.hs`:
1965
1966 (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
1967 `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:
1968
1969 ForallT univs reqs (ForallT exis provs ty)
1970 (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
1971
1972 (b) When converting pattern synonyms from TH.Dec to HsSyn in
1973 `hsSyn/Convert.hs`, we convert their TH type signatures back to an
1974 appropriate Haskell pattern synonym type of the form
1975
1976 forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
1977
1978 where initial empty `univs` type variables or an empty `reqs`
1979 constraint context are represented *explicitly* as `() =>`.
1980
1981 (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always
1982 return its *full* type, i.e.:
1983
1984 ForallT univs reqs (ForallT exis provs ty)
1985 (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
1986
1987 The key point is to always represent a pattern synonym's *full* type
1988 in cases (a) and (c) to make it clear which of the two forall
1989 quantifiers and/or constraint contexts are specified, and which are
1990 not. See GHC's user's guide on pattern synonyms for more information
1991 about pattern synonym type signatures.
1992
1993 -}