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