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