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