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