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