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