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