Support wild cards in TH splices
[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 CPP #-}
10
11 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
12 convertToHsType,
13 thRdrNameGuesses ) where
14
15 import HsSyn as Hs
16 import HsTypes ( mkHsForAllTy )
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
39 import qualified Data.ByteString as BS
40 import Control.Monad( unless, liftM, ap )
41 #if __GLASGOW_HASKELL__ < 709
42 import Control.Applicative (Applicative(..))
43 #endif
44
45 import Data.Char ( chr )
46 import Data.Word ( Word8 )
47 import Data.Maybe( catMaybes )
48 import Language.Haskell.TH as TH hiding (sigP)
49 import Language.Haskell.TH.Syntax as TH
50
51 -------------------------------------------------------------------
52 -- The external interface
53
54 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]
55 convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
56 where
57 cvt_dec d = wrapMsg "declaration" d (cvtDec d)
58
59 convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName)
60 convertToHsExpr loc e
61 = initCvt loc $ wrapMsg "expression" e $ cvtl e
62
63 convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName)
64 convertToPat loc p
65 = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
66
67 convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName)
68 convertToHsType loc t
69 = initCvt loc $ wrapMsg "type" t $ cvtType t
70
71 -------------------------------------------------------------------
72 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
73 -- Push down the source location;
74 -- Can fail, with a single error message
75
76 -- NB: If the conversion succeeds with (Right x), there should
77 -- be no exception values hiding in x
78 -- Reason: so a (head []) in TH code doesn't subsequently
79 -- make GHC crash when it tries to walk the generated tree
80
81 -- Use the loc everywhere, for lack of anything better
82 -- In particular, we want it on binding locations, so that variables bound in
83 -- the spliced-in declarations get a location that at least relates to the splice point
84
85 instance Functor CvtM where
86 fmap = liftM
87
88 instance Applicative CvtM where
89 pure = return
90 (<*>) = ap
91
92 instance Monad CvtM where
93 return x = CvtM $ \loc -> Right (loc,x)
94 (CvtM m) >>= k = CvtM $ \loc -> case m loc of
95 Left err -> Left err
96 Right (loc',v) -> unCvtM (k v) loc'
97
98 initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
99 initCvt loc (CvtM m) = fmap snd (m loc)
100
101 force :: a -> CvtM ()
102 force a = a `seq` return ()
103
104 failWith :: MsgDoc -> CvtM a
105 failWith m = CvtM (\_ -> Left m)
106
107 getL :: CvtM SrcSpan
108 getL = CvtM (\loc -> Right (loc,loc))
109
110 setL :: SrcSpan -> CvtM ()
111 setL loc = CvtM (\_ -> Right (loc, ()))
112
113 returnL :: a -> CvtM (Located a)
114 returnL x = CvtM (\loc -> Right (loc, L loc x))
115
116 returnJustL :: a -> CvtM (Maybe (Located a))
117 returnJustL = fmap Just . returnL
118
119 wrapParL :: (Located a -> a) -> a -> CvtM a
120 wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))
121
122 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
123 -- E.g wrapMsg "declaration" dec thing
124 wrapMsg what item (CvtM m)
125 = CvtM (\loc -> case m loc of
126 Left err -> Left (err $$ getPprStyle msg)
127 Right v -> Right v)
128 where
129 -- Show the item in pretty syntax normally,
130 -- but with all its constructors if you say -dppr-debug
131 msg sty = hang (ptext (sLit "When splicing a TH") <+> text what <> colon)
132 2 (if debugStyle sty
133 then text (show item)
134 else text (pprint item))
135
136 wrapL :: CvtM a -> CvtM (Located a)
137 wrapL (CvtM m) = CvtM (\loc -> case m loc of
138 Left err -> Left err
139 Right (loc',v) -> Right (loc',L loc v))
140
141 -------------------------------------------------------------------
142 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName]
143 cvtDecs = fmap catMaybes . mapM cvtDec
144
145 cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
146 cvtDec (TH.ValD pat body ds)
147 | TH.VarP s <- pat
148 = do { s' <- vNameL s
149 ; cl' <- cvtClause (Clause [] body ds)
150 ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
151
152 | otherwise
153 = do { pat' <- cvtPat pat
154 ; body' <- cvtGuard body
155 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
156 ; returnJustL $ Hs.ValD $
157 PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
158 , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
159 , pat_ticks = ([],[]) } }
160
161 cvtDec (TH.FunD nm cls)
162 | null cls
163 = failWith (ptext (sLit "Function binding for")
164 <+> quotes (text (TH.pprint nm))
165 <+> ptext (sLit "has no equations"))
166 | otherwise
167 = do { nm' <- vNameL nm
168 ; cls' <- mapM cvtClause cls
169 ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
170
171 cvtDec (TH.SigD nm typ)
172 = do { nm' <- vNameL nm
173 ; ty' <- cvtType typ
174 ; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder) }
175
176 cvtDec (TH.InfixD fx nm)
177 -- fixity signatures are allowed for variables, constructors, and types
178 -- the renamer automatically looks for types during renaming, even when
179 -- the RdrName says it's a variable or a constructor. So, just assume
180 -- it's a variable or constructor and proceed.
181 = do { nm' <- vcNameL nm
182 ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
183
184 cvtDec (PragmaD prag)
185 = cvtPragmaD prag
186
187 cvtDec (TySynD tc tvs rhs)
188 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
189 ; rhs' <- cvtType rhs
190 ; returnJustL $ TyClD $
191 SynDecl { tcdLName = tc'
192 , tcdTyVars = tvs', tcdFVs = placeHolderNames
193 , tcdRhs = rhs' } }
194
195 cvtDec (DataD ctxt tc tvs constrs derivs)
196 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
197 ; cons' <- mapM cvtConstr constrs
198 ; derivs' <- cvtDerivs derivs
199 ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
200 , dd_ctxt = ctxt'
201 , dd_kindSig = Nothing
202 , dd_cons = cons', dd_derivs = derivs' }
203 ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
204 , tcdDataDefn = defn
205 , tcdFVs = placeHolderNames }) }
206
207 cvtDec (NewtypeD ctxt tc tvs constr derivs)
208 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
209 ; con' <- cvtConstr constr
210 ; derivs' <- cvtDerivs derivs
211 ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
212 , dd_ctxt = ctxt'
213 , dd_kindSig = Nothing
214 , dd_cons = [con']
215 , dd_derivs = derivs' }
216 ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
217 , tcdDataDefn = defn
218 , tcdFVs = placeHolderNames }) }
219
220 cvtDec (ClassD ctxt cl tvs fds decs)
221 = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
222 ; fds' <- mapM cvt_fundep fds
223 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
224 ; unless (null adts')
225 (failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
226 $$ (Outputable.ppr adts'))
227 ; at_defs <- mapM cvt_at_def ats'
228 ; returnJustL $ TyClD $
229 ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
230 , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
231 , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
232 , tcdFVs = placeHolderNames }
233 -- no docs in TH ^^
234 }
235 where
236 cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName)
237 -- Very similar to what happens in RdrHsSyn.mkClassDecl
238 cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
239 Right def -> return def
240 Left (_, msg) -> failWith msg
241
242 cvtDec (InstanceD ctxt ty decs)
243 = do { let doc = ptext (sLit "an instance declaration")
244 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
245 ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
246 ; ctxt' <- cvtContext ctxt
247 ; L loc ty' <- cvtType ty
248 ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] ctxt' $ L loc ty'
249 ; returnJustL $ InstD $ ClsInstD $
250 ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing }
251
252 cvtDec (ForeignD ford)
253 = do { ford' <- cvtForD ford
254 ; returnJustL $ ForD ford' }
255
256 cvtDec (FamilyD flav tc tvs kind)
257 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
258 ; kind' <- cvtMaybeKind kind
259 ; returnJustL $ TyClD $ FamDecl $
260 FamilyDecl (cvtFamFlavour flav) tc' tvs' kind' }
261 where
262 cvtFamFlavour TypeFam = OpenTypeFamily
263 cvtFamFlavour DataFam = DataFamily
264
265 cvtDec (DataInstD ctxt tc tys constrs derivs)
266 = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
267 ; cons' <- mapM cvtConstr constrs
268 ; derivs' <- cvtDerivs derivs
269 ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
270 , dd_ctxt = ctxt'
271 , dd_kindSig = Nothing
272 , dd_cons = cons', dd_derivs = derivs' }
273
274 ; returnJustL $ InstD $ DataFamInstD
275 { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
276 , dfid_defn = defn
277 , dfid_fvs = placeHolderNames } }}
278
279 cvtDec (NewtypeInstD ctxt tc tys constr derivs)
280 = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
281 ; con' <- cvtConstr constr
282 ; derivs' <- cvtDerivs derivs
283 ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
284 , dd_ctxt = ctxt'
285 , dd_kindSig = Nothing
286 , dd_cons = [con'], dd_derivs = derivs' }
287 ; returnJustL $ InstD $ DataFamInstD
288 { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
289 , dfid_defn = defn
290 , dfid_fvs = placeHolderNames } }}
291
292 cvtDec (TySynInstD tc eqn)
293 = do { tc' <- tconNameL tc
294 ; eqn' <- cvtTySynEqn tc' eqn
295 ; returnJustL $ InstD $ TyFamInstD
296 { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
297 , tfid_fvs = placeHolderNames } } }
298
299 cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
300 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
301 ; mkind' <- cvtMaybeKind mkind
302 ; eqns' <- mapM (cvtTySynEqn tc') eqns
303 ; returnJustL $ TyClD $ FamDecl $
304 FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tvs' mkind' }
305
306 cvtDec (TH.RoleAnnotD tc roles)
307 = do { tc' <- tconNameL tc
308 ; let roles' = map (noLoc . cvtRole) roles
309 ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
310
311 cvtDec (TH.StandaloneDerivD cxt ty)
312 = do { cxt' <- cvtContext cxt
313 ; L loc ty' <- cvtType ty
314 ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] cxt' $ L loc ty'
315 ; returnJustL $ DerivD $
316 DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } }
317
318 cvtDec (TH.DefaultSigD nm typ)
319 = do { nm' <- vNameL nm
320 ; ty' <- cvtType typ
321 ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' }
322 ----------------
323 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
324 cvtTySynEqn tc (TySynEqn lhs rhs)
325 = do { lhs' <- mapM cvtType lhs
326 ; rhs' <- cvtType rhs
327 ; returnL $ TyFamEqn { tfe_tycon = tc
328 , tfe_pats = mkHsWithBndrs lhs'
329 , tfe_rhs = rhs' } }
330
331 ----------------
332 cvt_ci_decs :: MsgDoc -> [TH.Dec]
333 -> CvtM (LHsBinds RdrName,
334 [LSig RdrName],
335 [LFamilyDecl RdrName],
336 [LTyFamInstDecl RdrName],
337 [LDataFamInstDecl RdrName])
338 -- Convert the declarations inside a class or instance decl
339 -- ie signatures, bindings, and associated types
340 cvt_ci_decs doc decs
341 = do { decs' <- cvtDecs decs
342 ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
343 ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs'
344 ; let (sigs', prob_binds') = partitionWith is_sig no_ats'
345 ; let (binds', prob_fams') = partitionWith is_bind prob_binds'
346 ; let (fams', bads) = partitionWith is_fam_decl prob_fams'
347 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
348 --We use FromSource as the origin of the bind
349 -- because the TH declaration is user-written
350 ; return (listToBag binds', sigs', fams', ats', adts') }
351
352 ----------------
353 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
354 -> CvtM ( LHsContext RdrName
355 , Located RdrName
356 , LHsTyVarBndrs RdrName)
357 cvt_tycl_hdr cxt tc tvs
358 = do { cxt' <- cvtContext cxt
359 ; tc' <- tconNameL tc
360 ; tvs' <- cvtTvs tvs
361 ; return (cxt', tc', tvs')
362 }
363
364 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
365 -> CvtM ( LHsContext RdrName
366 , Located RdrName
367 , HsWithBndrs RdrName [LHsType RdrName])
368 cvt_tyinst_hdr cxt tc tys
369 = do { cxt' <- cvtContext cxt
370 ; tc' <- tconNameL tc
371 ; tys' <- mapM cvtType tys
372 ; return (cxt', tc', mkHsWithBndrs tys') }
373
374 -------------------------------------------------------------------
375 -- Partitioning declarations
376 -------------------------------------------------------------------
377
378 is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
379 is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
380 is_fam_decl decl = Right decl
381
382 is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName)
383 is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
384 is_tyfam_inst decl = Right decl
385
386 is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName)
387 is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
388 is_datafam_inst decl = Right decl
389
390 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
391 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
392 is_sig decl = Right decl
393
394 is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
395 is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
396 is_bind decl = Right decl
397
398 mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
399 mkBadDecMsg doc bads
400 = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
401 , nest 2 (vcat (map Outputable.ppr bads)) ]
402
403 ---------------------------------------------------
404 -- Data types
405 -- Can't handle GADTs yet
406 ---------------------------------------------------
407
408 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
409
410 cvtConstr (NormalC c strtys)
411 = do { c' <- cNameL c
412 ; cxt' <- returnL []
413 ; tys' <- mapM cvt_arg strtys
414 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
415
416 cvtConstr (RecC c varstrtys)
417 = do { c' <- cNameL c
418 ; cxt' <- returnL []
419 ; args' <- mapM cvt_id_arg varstrtys
420 ; returnL $ mkSimpleConDecl c' noExistentials cxt'
421 (RecCon (noLoc args')) }
422
423 cvtConstr (InfixC st1 c st2)
424 = do { c' <- cNameL c
425 ; cxt' <- returnL []
426 ; st1' <- cvt_arg st1
427 ; st2' <- cvt_arg st2
428 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
429
430 cvtConstr (ForallC tvs ctxt con)
431 = do { tvs' <- cvtTvs tvs
432 ; L loc ctxt' <- cvtContext ctxt
433 ; L _ con' <- cvtConstr con
434 ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
435 , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
436
437 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
438 cvt_arg (NotStrict, ty) = cvtType ty
439 cvt_arg (IsStrict, ty)
440 = do { ty' <- cvtType ty
441 ; returnL $ HsBangTy (HsSrcBang Nothing Nothing True) ty' }
442 cvt_arg (Unpacked, ty)
443 = do { ty' <- cvtType ty
444 ; returnL $ HsBangTy (HsSrcBang Nothing (Just True) True) ty' }
445
446 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
447 cvt_id_arg (i, str, ty)
448 = do { i' <- vNameL i
449 ; ty' <- cvt_arg (str,ty)
450 ; return $ noLoc (ConDeclField { cd_fld_names = [i']
451 , cd_fld_type = ty'
452 , cd_fld_doc = Nothing}) }
453
454 cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName]))
455 cvtDerivs [] = return Nothing
456 cvtDerivs cs = do { cs' <- mapM cvt_one cs
457 ; return (Just (noLoc cs')) }
458 where
459 cvt_one c = do { c' <- tconName c
460 ; returnL $ HsTyVar c' }
461
462 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
463 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs
464 ; ys' <- mapM tName ys
465 ; returnL (map noLoc xs', map noLoc ys') }
466
467 noExistentials :: [LHsTyVarBndr RdrName]
468 noExistentials = []
469
470 ------------------------------------------
471 -- Foreign declarations
472 ------------------------------------------
473
474 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
475 cvtForD (ImportF callconv safety from nm ty)
476 | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
477 (mkFastString (TH.nameBase nm))
478 from (noLoc from)
479 = do { nm' <- vNameL nm
480 ; ty' <- cvtType ty
481 ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
482 }
483 | otherwise
484 = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
485 where
486 safety' = case safety of
487 Unsafe -> PlayRisky
488 Safe -> PlaySafe
489 Interruptible -> PlayInterruptible
490
491 cvtForD (ExportF callconv as nm ty)
492 = do { nm' <- vNameL nm
493 ; ty' <- cvtType ty
494 ; let e = CExport (noLoc (CExportStatic as
495 (mkFastString as)
496 (cvt_conv callconv)))
497 (noLoc as)
498 ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
499
500 cvt_conv :: TH.Callconv -> CCallConv
501 cvt_conv TH.CCall = CCallConv
502 cvt_conv TH.StdCall = StdCallConv
503 cvt_conv TH.CApi = CApiConv
504 cvt_conv TH.Prim = PrimCallConv
505 cvt_conv TH.JavaScript = JavaScriptCallConv
506
507 ------------------------------------------
508 -- Pragmas
509 ------------------------------------------
510
511 cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
512 cvtPragmaD (InlineP nm inline rm phases)
513 = do { nm' <- vNameL nm
514 ; let dflt = dfltActivation inline
515 ; let ip = InlinePragma { inl_src = "{-# INLINE"
516 , inl_inline = cvtInline inline
517 , inl_rule = cvtRuleMatch rm
518 , inl_act = cvtPhases phases dflt
519 , inl_sat = Nothing }
520 ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
521
522 cvtPragmaD (SpecialiseP nm ty inline phases)
523 = do { nm' <- vNameL nm
524 ; ty' <- cvtType ty
525 ; let (inline', dflt) = case inline of
526 Just inline1 -> (cvtInline inline1, dfltActivation inline1)
527 Nothing -> (EmptyInlineSpec, AlwaysActive)
528 ; let ip = InlinePragma { inl_src = "{-# INLINE"
529 , inl_inline = inline'
530 , inl_rule = Hs.FunLike
531 , inl_act = cvtPhases phases dflt
532 , inl_sat = Nothing }
533 ; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip }
534
535 cvtPragmaD (SpecialiseInstP ty)
536 = do { ty' <- cvtType ty
537 ; returnJustL $ Hs.SigD $ SpecInstSig "{-# SPECIALISE" ty' }
538
539 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
540 = do { let nm' = mkFastString nm
541 ; let act = cvtPhases phases AlwaysActive
542 ; bndrs' <- mapM cvtRuleBndr bndrs
543 ; lhs' <- cvtl lhs
544 ; rhs' <- cvtl rhs
545 ; returnJustL $ Hs.RuleD
546 $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc (nm,nm')) act bndrs'
547 lhs' placeHolderNames
548 rhs' placeHolderNames]
549 }
550
551 cvtPragmaD (AnnP target exp)
552 = do { exp' <- cvtl exp
553 ; target' <- case target of
554 ModuleAnnotation -> return ModuleAnnProvenance
555 TypeAnnotation n -> do
556 n' <- tconName n
557 return (TypeAnnProvenance (noLoc n'))
558 ValueAnnotation n -> do
559 n' <- vcName n
560 return (ValueAnnProvenance (noLoc n'))
561 ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp'
562 }
563
564 cvtPragmaD (LineP line file)
565 = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
566 ; return Nothing
567 }
568
569 dfltActivation :: TH.Inline -> Activation
570 dfltActivation TH.NoInline = NeverActive
571 dfltActivation _ = AlwaysActive
572
573 cvtInline :: TH.Inline -> Hs.InlineSpec
574 cvtInline TH.NoInline = Hs.NoInline
575 cvtInline TH.Inline = Hs.Inline
576 cvtInline TH.Inlinable = Hs.Inlinable
577
578 cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
579 cvtRuleMatch TH.ConLike = Hs.ConLike
580 cvtRuleMatch TH.FunLike = Hs.FunLike
581
582 cvtPhases :: TH.Phases -> Activation -> Activation
583 cvtPhases AllPhases dflt = dflt
584 cvtPhases (FromPhase i) _ = ActiveAfter i
585 cvtPhases (BeforePhase i) _ = ActiveBefore i
586
587 cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
588 cvtRuleBndr (RuleVar n)
589 = do { n' <- vNameL n
590 ; return $ noLoc $ Hs.RuleBndr n' }
591 cvtRuleBndr (TypedRuleVar n ty)
592 = do { n' <- vNameL n
593 ; ty' <- cvtType ty
594 ; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
595
596 ---------------------------------------------------
597 -- Declarations
598 ---------------------------------------------------
599
600 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
601 cvtLocalDecs doc ds
602 | null ds
603 = return EmptyLocalBinds
604 | otherwise
605 = do { ds' <- cvtDecs ds
606 ; let (binds, prob_sigs) = partitionWith is_bind ds'
607 ; let (sigs, bads) = partitionWith is_sig prob_sigs
608 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
609 ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
610
611 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
612 cvtClause (Clause ps body wheres)
613 = do { ps' <- cvtPats ps
614 ; g' <- cvtGuard body
615 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
616 ; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') }
617
618
619 -------------------------------------------------------------------
620 -- Expressions
621 -------------------------------------------------------------------
622
623 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
624 cvtl e = wrapL (cvt e)
625 where
626 cvt (VarE s) = do { s' <- vName s; return $ HsVar s' }
627 cvt (ConE s) = do { s' <- cName s; return $ HsVar s' }
628 cvt (LitE l)
629 | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
630 | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
631
632 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
633 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
634 ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
635 cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
636 ; return $ HsLamCase placeHolderType
637 (mkMatchGroup FromSource ms')
638 }
639 cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
640 -- Note [Dropping constructors]
641 -- Singleton tuples treated like nothing (just parens)
642 cvt (TupE es) = do { es' <- mapM cvtl es
643 ; return $ ExplicitTuple (map (noLoc . Present) es')
644 Boxed }
645 cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
646 ; return $ ExplicitTuple
647 (map (noLoc . Present) es') Unboxed }
648 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
649 ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
650 cvt (MultiIfE alts)
651 | null alts = failWith (ptext (sLit "Multi-way if-expression with no alternatives"))
652 | otherwise = do { alts' <- mapM cvtpair alts
653 ; return $ HsMultiIf placeHolderType alts' }
654 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
655 ; e' <- cvtl e; return $ HsLet ds' e' }
656 cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
657 ; return $ HsCase e' (mkMatchGroup FromSource ms') }
658 cvt (DoE ss) = cvtHsDo DoExpr ss
659 cvt (CompE ss) = cvtHsDo ListComp ss
660 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
661 cvt (ListE xs)
662 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
663 -- Note [Converting strings]
664 | otherwise = do { xs' <- mapM cvtl xs
665 ; return $ ExplicitList placeHolderType Nothing xs'
666 }
667
668 -- Infix expressions
669 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
670 ; wrapParL HsPar $
671 OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
672 -- Parenthesise both arguments and result,
673 -- to ensure this operator application does
674 -- does not get re-associated
675 -- See Note [Operator association]
676 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
677 ; wrapParL HsPar $ SectionR s' y' }
678 -- See Note [Sections in HsSyn] in HsExpr
679 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
680 ; wrapParL HsPar $ SectionL x' s' }
681
682 cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
683 -- Can I indicate this is an infix thing?
684 -- Note [Dropping constructors]
685
686 cvt (UInfixE x s y) = do { x' <- cvtl x
687 ; let x'' = case x' of
688 L _ (OpApp {}) -> x'
689 _ -> mkLHsPar x'
690 ; cvtOpApp x'' s y } -- Note [Converting UInfix]
691
692 cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' }
693 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
694 ; return $ ExprWithTySig e' t' PlaceHolder }
695 cvt (RecConE c flds) = do { c' <- cNameL c
696 ; flds' <- mapM cvtFld flds
697 ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
698 cvt (RecUpdE e flds) = do { e' <- cvtl e
699 ; flds' <- mapM cvtFld flds
700 ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
701 cvt (StaticE e) = fmap HsStatic $ cvtl e
702
703 {- Note [Dropping constructors]
704 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
705 When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
706 we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
707 could meet @UInfix@ constructors containing the @TupE [e]@. For example:
708
709 UInfixE x * (TupE [UInfixE y + z])
710
711 If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
712 and the above expression would be reassociated to
713
714 OpApp (OpApp x * y) + z
715
716 which we don't want.
717 -}
718
719 cvtFld :: (TH.Name, TH.Exp) -> CvtM (LHsRecField RdrName (LHsExpr RdrName))
720 cvtFld (v,e)
721 = do { v' <- vNameL v; e' <- cvtl e
722 ; return (noLoc $ HsRecField { hsRecFieldId = v', hsRecFieldArg = e'
723 , hsRecPun = False}) }
724
725 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
726 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
727 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
728 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
729 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
730
731 {- Note [Operator assocation]
732 We must be quite careful about adding parens:
733 * Infix (UInfix ...) op arg Needs parens round the first arg
734 * Infix (Infix ...) op arg Needs parens round the first arg
735 * UInfix (UInfix ...) op arg No parens for first arg
736 * UInfix (Infix ...) op arg Needs parens round first arg
737
738
739 Note [Converting UInfix]
740 ~~~~~~~~~~~~~~~~~~~~~~~~
741 When converting @UInfixE@ and @UInfixP@ values, we want to readjust
742 the trees to reflect the fixities of the underlying operators:
743
744 UInfixE x * (UInfixE y + z) ---> (x * y) + z
745
746 This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in
747 RnTypes), which expects that the input will be completely left-biased.
748 So we left-bias the trees of @UInfixP@ and @UInfixE@ that we come across.
749
750 Sample input:
751
752 UInfixE
753 (UInfixE x op1 y)
754 op2
755 (UInfixE z op3 w)
756
757 Sample output:
758
759 OpApp
760 (OpApp
761 (OpApp x op1 y)
762 op2
763 z)
764 op3
765 w
766
767 The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this
768 left-biasing.
769 -}
770
771 {- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
772 The produced tree of infix expressions will be left-biased, provided @x@ is.
773
774 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
775 is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
776 this holds for both branches (of @cvtOpApp@), provided we assume it holds for
777 the recursive calls to @cvtOpApp@.
778
779 When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
780 since we have already run @cvtl@ on it.
781 -}
782 cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName)
783 cvtOpApp x op1 (UInfixE y op2 z)
784 = do { l <- wrapL $ cvtOpApp x op1 y
785 ; cvtOpApp l op2 z }
786 cvtOpApp x op y
787 = do { op' <- cvtl op
788 ; y' <- cvtl y
789 ; return (OpApp x op' undefined y') }
790
791 -------------------------------------
792 -- Do notation and statements
793 -------------------------------------
794
795 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
796 cvtHsDo do_or_lc stmts
797 | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
798 | otherwise
799 = do { stmts' <- cvtStmts stmts
800 ; let Just (stmts'', last') = snocView stmts'
801
802 ; last'' <- case last' of
803 L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
804 _ -> failWith (bad_last last')
805
806 ; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType }
807 where
808 bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
809 , nest 2 $ Outputable.ppr stmt
810 , ptext (sLit "(It should be an expression.)") ]
811
812 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]
813 cvtStmts = mapM cvtStmt
814
815 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
816 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
817 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
818 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
819 ; returnL $ LetStmt ds' }
820 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
821 where
822 cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
823
824 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
825 cvtMatch (TH.Match p body decs)
826 = do { p' <- cvtPat p
827 ; g' <- cvtGuard body
828 ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
829 ; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') }
830
831 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
832 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
833 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
834
835 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))
836 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
837 ; g' <- returnL $ mkBodyStmt ge'
838 ; returnL $ GRHS [g'] rhs' }
839 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
840 ; returnL $ GRHS gs' rhs' }
841
842 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
843 cvtOverLit (IntegerL i)
844 = do { force i; return $ mkHsIntegral (show i) i placeHolderType}
845 cvtOverLit (RationalL r)
846 = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
847 cvtOverLit (StringL s)
848 = do { let { s' = mkFastString s }
849 ; force s'
850 ; return $ mkHsIsString s s' placeHolderType
851 }
852 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
853 -- An Integer is like an (overloaded) '3' in a Haskell source program
854 -- Similarly 3.5 for fractionals
855
856 {- Note [Converting strings]
857 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
858 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
859 a string literal for "xy". Of course, we might hope to get
860 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
861 if it isn't a literal string
862 -}
863
864 allCharLs :: [TH.Exp] -> Maybe String
865 -- Note [Converting strings]
866 -- NB: only fire up this setup for a non-empty list, else
867 -- there's a danger of returning "" for [] :: [Int]!
868 allCharLs xs
869 = case xs of
870 LitE (CharL c) : ys -> go [c] ys
871 _ -> Nothing
872 where
873 go cs [] = Just (reverse cs)
874 go cs (LitE (CharL c) : ys) = go (c:cs) ys
875 go _ _ = Nothing
876
877 cvtLit :: Lit -> CvtM HsLit
878 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim (show i) i }
879 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) w }
880 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
881 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
882 cvtLit (CharL c) = do { force c; return $ HsChar (show c) c }
883 cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim (show c) c }
884 cvtLit (StringL s) = do { let { s' = mkFastString s }
885 ; force s'
886 ; return $ HsString s s' }
887 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
888 ; force s'
889 ; return $ HsStringPrim (w8ToString s) s' }
890 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
891 -- cvtLit should not be called on IntegerL, RationalL
892 -- That precondition is established right here in
893 -- Convert.hs, hence panic
894
895 w8ToString :: [Word8] -> String
896 w8ToString ws = map (\w -> chr (fromIntegral w)) ws
897
898 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
899 cvtPats pats = mapM cvtPat pats
900
901 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
902 cvtPat pat = wrapL (cvtp pat)
903
904 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
905 cvtp (TH.LitP l)
906 | overloadedLit l = do { l' <- cvtOverLit l
907 ; return (mkNPat (noLoc l') Nothing) }
908 -- Not right for negative patterns;
909 -- need to think about that!
910 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
911 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
912 cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
913 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
914 cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
915 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
916 ; return $ ConPatIn s' (PrefixCon ps') }
917 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
918 ; wrapParL ParPat $
919 ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
920 -- See Note [Operator association]
921 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
922 cvtp (ParensP p) = do { p' <- cvtPat p; return $ ParPat p' }
923 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
924 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
925 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
926 cvtp TH.WildP = return $ WildPat placeHolderType
927 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
928 ; return $ ConPatIn c'
929 $ Hs.RecCon (HsRecFields fs' Nothing) }
930 cvtp (ListP ps) = do { ps' <- cvtPats ps
931 ; return $ ListPat ps' placeHolderType Nothing }
932 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
933 ; return $ SigPatIn p' (mkHsWithBndrs t') }
934 cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
935 ; return $ ViewPat e' p' placeHolderType }
936
937 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
938 cvtPatFld (s,p)
939 = do { s' <- vNameL s; p' <- cvtPat p
940 ; return (noLoc $ HsRecField { hsRecFieldId = s', hsRecFieldArg = p'
941 , hsRecPun = False}) }
942
943 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
944 The produced tree of infix patterns will be left-biased, provided @x@ is.
945
946 See the @cvtOpApp@ documentation for how this function works.
947 -}
948 cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName)
949 cvtOpAppP x op1 (UInfixP y op2 z)
950 = do { l <- wrapL $ cvtOpAppP x op1 y
951 ; cvtOpAppP l op2 z }
952 cvtOpAppP x op y
953 = do { op' <- cNameL op
954 ; y' <- cvtPat y
955 ; return (ConPatIn op' (InfixCon x y')) }
956
957 -----------------------------------------------------------
958 -- Types and type variables
959
960 cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName)
961 cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
962
963 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
964 cvt_tv (TH.PlainTV nm)
965 = do { nm' <- tName nm
966 ; returnL $ UserTyVar nm' }
967 cvt_tv (TH.KindedTV nm ki)
968 = do { nm' <- tName nm
969 ; ki' <- cvtKind ki
970 ; returnL $ KindedTyVar (noLoc nm') ki' }
971
972 cvtRole :: TH.Role -> Maybe Coercion.Role
973 cvtRole TH.NominalR = Just Coercion.Nominal
974 cvtRole TH.RepresentationalR = Just Coercion.Representational
975 cvtRole TH.PhantomR = Just Coercion.Phantom
976 cvtRole TH.InferR = Nothing
977
978 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
979 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
980
981 cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
982 cvtPred = cvtType
983
984 cvtType :: TH.Type -> CvtM (LHsType RdrName)
985 cvtType = cvtTypeKind "type"
986
987 cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName)
988 cvtTypeKind ty_str ty
989 = do { (head_ty, tys') <- split_ty_app ty
990 ; case head_ty of
991 TupleT n
992 | length tys' == n -- Saturated
993 -> if n==1 then return (head tys') -- Singleton tuples treated
994 -- like nothing (ie just parens)
995 else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
996 | n == 1
997 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
998 | otherwise
999 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
1000 UnboxedTupleT n
1001 | length tys' == n -- Saturated
1002 -> if n==1 then return (head tys') -- Singleton tuples treated
1003 -- like nothing (ie just parens)
1004 else returnL (HsTupleTy HsUnboxedTuple tys')
1005 | otherwise
1006 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
1007 ArrowT
1008 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
1009 | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
1010 ListT
1011 | [x'] <- tys' -> returnL (HsListTy x')
1012 | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
1013 VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
1014 ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
1015
1016 ForallT tvs cxt ty
1017 | null tys'
1018 -> do { tvs' <- cvtTvs tvs
1019 ; cxt' <- cvtContext cxt
1020 ; ty' <- cvtType ty
1021 ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty'
1022 }
1023
1024 SigT ty ki
1025 -> do { ty' <- cvtType ty
1026 ; ki' <- cvtKind ki
1027 ; mk_apps (HsKindSig ty' ki') tys'
1028 }
1029
1030 LitT lit
1031 -> returnL (HsTyLit (cvtTyLit lit))
1032
1033 WildCardT Nothing
1034 -> mk_apps mkAnonWildCardTy tys'
1035
1036 WildCardT (Just nm)
1037 -> do { nm' <- tName nm; mk_apps (mkNamedWildCardTy nm') tys' }
1038
1039 PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' }
1040 -- Promoted data constructor; hence cName
1041
1042 PromotedTupleT n
1043 | n == 1
1044 -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
1045 | m == n -- Saturated
1046 -> do { let kis = replicate m placeHolderKind
1047 ; returnL (HsExplicitTupleTy kis tys')
1048 }
1049 where
1050 m = length tys'
1051
1052 PromotedNilT
1053 -> returnL (HsExplicitListTy placeHolderKind [])
1054
1055 PromotedConsT -- See Note [Representing concrete syntax in types]
1056 -- in Language.Haskell.TH.Syntax
1057 | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys'
1058 -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2))
1059 | otherwise
1060 -> mk_apps (HsTyVar (getRdrName consDataCon)) tys'
1061
1062 StarT
1063 -> returnL (HsTyVar (getRdrName liftedTypeKindTyCon))
1064
1065 ConstraintT
1066 -> returnL (HsTyVar (getRdrName constraintKindTyCon))
1067
1068 EqualityT
1069 | [x',y'] <- tys' -> returnL (HsEqTy x' y')
1070 | otherwise -> mk_apps (HsTyVar (getRdrName eqPrimTyCon)) tys'
1071
1072 _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
1073 }
1074
1075 mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
1076 mk_apps head_ty [] = returnL head_ty
1077 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
1078 ; mk_apps (HsAppTy head_ty' ty) tys }
1079
1080 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
1081 split_ty_app ty = go ty []
1082 where
1083 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
1084 go f as = return (f,as)
1085
1086 cvtTyLit :: TH.TyLit -> HsTyLit
1087 cvtTyLit (NumTyLit i) = HsNumTy (show i) i
1088 cvtTyLit (StrTyLit s) = HsStrTy s (fsLit s)
1089
1090 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
1091 cvtKind = cvtTypeKind "kind"
1092
1093 cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
1094 cvtMaybeKind Nothing = return Nothing
1095 cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
1096 ; return (Just ki') }
1097
1098 -----------------------------------------------------------
1099 cvtFixity :: TH.Fixity -> Hs.Fixity
1100 cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
1101 where
1102 cvt_dir TH.InfixL = Hs.InfixL
1103 cvt_dir TH.InfixR = Hs.InfixR
1104 cvt_dir TH.InfixN = Hs.InfixN
1105
1106 -----------------------------------------------------------
1107
1108
1109 -----------------------------------------------------------
1110 -- some useful things
1111
1112 overloadedLit :: Lit -> Bool
1113 -- True for literals that Haskell treats as overloaded
1114 overloadedLit (IntegerL _) = True
1115 overloadedLit (RationalL _) = True
1116 overloadedLit _ = False
1117
1118 cvtFractionalLit :: Rational -> FractionalLit
1119 cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
1120
1121 --------------------------------------------------------------------
1122 -- Turning Name back into RdrName
1123 --------------------------------------------------------------------
1124
1125 -- variable names
1126 vNameL, cNameL, vcNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
1127 vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName
1128
1129 -- Variable names
1130 vNameL n = wrapL (vName n)
1131 vName n = cvtName OccName.varName n
1132
1133 -- Constructor function names; this is Haskell source, hence srcDataName
1134 cNameL n = wrapL (cName n)
1135 cName n = cvtName OccName.dataName n
1136
1137 -- Variable *or* constructor names; check by looking at the first char
1138 vcNameL n = wrapL (vcName n)
1139 vcName n = if isVarName n then vName n else cName n
1140
1141 -- Type variable names
1142 tName n = cvtName OccName.tvName n
1143
1144 -- Type Constructor names
1145 tconNameL n = wrapL (tconName n)
1146 tconName n = cvtName OccName.tcClsName n
1147
1148 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
1149 cvtName ctxt_ns (TH.Name occ flavour)
1150 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
1151 | otherwise
1152 = do { loc <- getL
1153 ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
1154 ; force rdr_name
1155 ; return rdr_name }
1156 where
1157 occ_str = TH.occString occ
1158
1159 okOcc :: OccName.NameSpace -> String -> Bool
1160 okOcc ns str
1161 | OccName.isVarNameSpace ns = okVarOcc str
1162 | OccName.isDataConNameSpace ns = okConOcc str
1163 | otherwise = okTcOcc str
1164
1165 -- Determine the name space of a name in a type
1166 --
1167 isVarName :: TH.Name -> Bool
1168 isVarName (TH.Name occ _)
1169 = case TH.occString occ of
1170 "" -> False
1171 (c:_) -> startsVarId c || startsVarSym c
1172
1173 badOcc :: OccName.NameSpace -> String -> SDoc
1174 badOcc ctxt_ns occ
1175 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
1176 <+> ptext (sLit "name:") <+> quotes (text occ)
1177
1178 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
1179 -- This turns a TH Name into a RdrName; used for both binders and occurrences
1180 -- See Note [Binders in Template Haskell]
1181 -- The passed-in name space tells what the context is expecting;
1182 -- use it unless the TH name knows what name-space it comes
1183 -- from, in which case use the latter
1184 --
1185 -- We pass in a SrcSpan (gotten from the monad) because this function
1186 -- is used for *binders* and if we make an Exact Name we want it
1187 -- to have a binding site inside it. (cf Trac #5434)
1188 --
1189 -- ToDo: we may generate silly RdrNames, by passing a name space
1190 -- that doesn't match the string, like VarName ":+",
1191 -- which will give confusing error messages later
1192 --
1193 -- The strict applications ensure that any buried exceptions get forced
1194 thRdrName loc ctxt_ns th_occ th_name
1195 = case th_name of
1196 TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
1197 TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ
1198 TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
1199 TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
1200 TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
1201 | otherwise -> mkRdrUnqual $! occ
1202 -- We check for built-in syntax here, because the TH
1203 -- user might have written a (NameS "(,,)"), for example
1204 where
1205 occ :: OccName.OccName
1206 occ = mk_occ ctxt_ns th_occ
1207
1208 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
1209 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
1210
1211 thRdrNameGuesses :: TH.Name -> [RdrName]
1212 thRdrNameGuesses (TH.Name occ flavour)
1213 -- This special case for NameG ensures that we don't generate duplicates in the output list
1214 | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
1215 | otherwise = [ thRdrName noSrcSpan gns occ_str flavour
1216 | gns <- guessed_nss]
1217 where
1218 -- guessed_ns are the name spaces guessed from looking at the TH name
1219 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
1220 | otherwise = [OccName.varName, OccName.tvName]
1221 occ_str = TH.occString occ
1222
1223 -- The packing and unpacking is rather turgid :-(
1224 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
1225 mk_occ ns occ = OccName.mkOccName ns occ
1226
1227 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
1228 mk_ghc_ns TH.DataName = OccName.dataName
1229 mk_ghc_ns TH.TcClsName = OccName.tcClsName
1230 mk_ghc_ns TH.VarName = OccName.varName
1231
1232 mk_mod :: TH.ModName -> ModuleName
1233 mk_mod mod = mkModuleName (TH.modString mod)
1234
1235 mk_pkg :: TH.PkgName -> PackageKey
1236 mk_pkg pkg = stringToPackageKey (TH.pkgString pkg)
1237
1238 mk_uniq :: Int -> Unique
1239 mk_uniq u = mkUniqueGrimily u
1240
1241 {-
1242 Note [Binders in Template Haskell]
1243 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1244 Consider this TH term construction:
1245 do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name
1246 ; x2 <- TH.newName "x" -- Builds a NameU
1247 ; x3 <- TH.newName "x"
1248
1249 ; let x = mkName "x" -- mkName :: String -> TH.Name
1250 -- Builds a NameS
1251
1252 ; return (LamE (..pattern [x1,x2]..) $
1253 LamE (VarPat x3) $
1254 ..tuple (x1,x2,x3,x)) }
1255
1256 It represents the term \[x1,x2]. \x3. (x1,x2,x3,x)
1257
1258 a) We don't want to complain about "x" being bound twice in
1259 the pattern [x1,x2]
1260 b) We don't want x3 to shadow the x1,x2
1261 c) We *do* want 'x' (dynamically bound with mkName) to bind
1262 to the innermost binding of "x", namely x3.
1263 d) When pretty printing, we want to print a unique with x1,x2
1264 etc, else they'll all print as "x" which isn't very helpful
1265
1266 When we convert all this to HsSyn, the TH.Names are converted with
1267 thRdrName. To achieve (b) we want the binders to be Exact RdrNames.
1268 Achieving (a) is a bit awkward, because
1269 - We must check for duplicate and shadowed names on Names,
1270 not RdrNames, *after* renaming.
1271 See Note [Collect binders only after renaming] in HsUtils
1272
1273 - But to achieve (a) we must distinguish between the Exact
1274 RdrNames arising from TH and the Unqual RdrNames that would
1275 come from a user writing \[x,x] -> blah
1276
1277 So in Convert.thRdrName we translate
1278 TH Name RdrName
1279 --------------------------------------------------------
1280 NameU (arising from newName) --> Exact (Name{ System })
1281 NameS (arising from mkName) --> Unqual
1282
1283 Notice that the NameUs generate *System* Names. Then, when
1284 figuring out shadowing and duplicates, we can filter out
1285 System Names.
1286
1287 This use of System Names fits with other uses of System Names, eg for
1288 temporary variables "a". Since there are lots of things called "a" we
1289 usually want to print the name with the unique, and that is indeed
1290 the way System Names are printed.
1291
1292 There's a small complication of course; see Note [Looking up Exact
1293 RdrNames] in RnEnv.
1294 -}