10d7e0457248422ecf933b15f7f3aca13caacb3e
[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
719 {- Note [Dropping constructors]
720 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
721 When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
722 we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
723 could meet @UInfix@ constructors containing the @TupE [e]@. For example:
724
725 UInfixE x * (TupE [UInfixE y + z])
726
727 If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
728 and the above expression would be reassociated to
729
730 OpApp (OpApp x * y) + z
731
732 which we don't want.
733 -}
734
735 cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) -> CvtM (LHsRecField' t (LHsExpr RdrName))
736 cvtFld f (v,e)
737 = do { v' <- vNameL v; e' <- cvtl e
738 ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
739 , hsRecFieldArg = e'
740 , hsRecPun = False}) }
741
742 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
743 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
744 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
745 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
746 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
747
748 {- Note [Operator assocation]
749 We must be quite careful about adding parens:
750 * Infix (UInfix ...) op arg Needs parens round the first arg
751 * Infix (Infix ...) op arg Needs parens round the first arg
752 * UInfix (UInfix ...) op arg No parens for first arg
753 * UInfix (Infix ...) op arg Needs parens round first arg
754
755
756 Note [Converting UInfix]
757 ~~~~~~~~~~~~~~~~~~~~~~~~
758 When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
759 the trees to reflect the fixities of the underlying operators:
760
761 UInfixE x * (UInfixE y + z) ---> (x * y) + z
762
763 This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
764 @mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
765 right-biased for types and left-biased for everything else. So we left-bias the
766 trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
767
768 Sample input:
769
770 UInfixE
771 (UInfixE x op1 y)
772 op2
773 (UInfixE z op3 w)
774
775 Sample output:
776
777 OpApp
778 (OpApp
779 (OpApp x op1 y)
780 op2
781 z)
782 op3
783 w
784
785 The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
786 biasing.
787 -}
788
789 {- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
790 The produced tree of infix expressions will be left-biased, provided @x@ is.
791
792 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
793 is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
794 this holds for both branches (of @cvtOpApp@), provided we assume it holds for
795 the recursive calls to @cvtOpApp@.
796
797 When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
798 since we have already run @cvtl@ on it.
799 -}
800 cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName)
801 cvtOpApp x op1 (UInfixE y op2 z)
802 = do { l <- wrapL $ cvtOpApp x op1 y
803 ; cvtOpApp l op2 z }
804 cvtOpApp x op y
805 = do { op' <- cvtl op
806 ; y' <- cvtl y
807 ; return (OpApp x op' undefined y') }
808
809 -------------------------------------
810 -- Do notation and statements
811 -------------------------------------
812
813 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
814 cvtHsDo do_or_lc stmts
815 | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
816 | otherwise
817 = do { stmts' <- cvtStmts stmts
818 ; let Just (stmts'', last') = snocView stmts'
819
820 ; last'' <- case last' of
821 L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
822 _ -> failWith (bad_last last')
823
824 ; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType }
825 where
826 bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
827 , nest 2 $ Outputable.ppr stmt
828 , ptext (sLit "(It should be an expression.)") ]
829
830 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]
831 cvtStmts = mapM cvtStmt
832
833 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
834 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
835 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
836 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
837 ; returnL $ LetStmt ds' }
838 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
839 where
840 cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
841
842 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
843 cvtMatch (TH.Match p body decs)
844 = do { p' <- cvtPat p
845 ; g' <- cvtGuard body
846 ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
847 ; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') }
848
849 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
850 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
851 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
852
853 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))
854 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
855 ; g' <- returnL $ mkBodyStmt ge'
856 ; returnL $ GRHS [g'] rhs' }
857 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
858 ; returnL $ GRHS gs' rhs' }
859
860 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
861 cvtOverLit (IntegerL i)
862 = do { force i; return $ mkHsIntegral (show i) i placeHolderType}
863 cvtOverLit (RationalL r)
864 = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
865 cvtOverLit (StringL s)
866 = do { let { s' = mkFastString s }
867 ; force s'
868 ; return $ mkHsIsString s s' placeHolderType
869 }
870 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
871 -- An Integer is like an (overloaded) '3' in a Haskell source program
872 -- Similarly 3.5 for fractionals
873
874 {- Note [Converting strings]
875 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
876 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
877 a string literal for "xy". Of course, we might hope to get
878 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
879 if it isn't a literal string
880 -}
881
882 allCharLs :: [TH.Exp] -> Maybe String
883 -- Note [Converting strings]
884 -- NB: only fire up this setup for a non-empty list, else
885 -- there's a danger of returning "" for [] :: [Int]!
886 allCharLs xs
887 = case xs of
888 LitE (CharL c) : ys -> go [c] ys
889 _ -> Nothing
890 where
891 go cs [] = Just (reverse cs)
892 go cs (LitE (CharL c) : ys) = go (c:cs) ys
893 go _ _ = Nothing
894
895 cvtLit :: Lit -> CvtM HsLit
896 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim (show i) i }
897 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) w }
898 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
899 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
900 cvtLit (CharL c) = do { force c; return $ HsChar (show c) c }
901 cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim (show c) c }
902 cvtLit (StringL s) = do { let { s' = mkFastString s }
903 ; force s'
904 ; return $ HsString s s' }
905 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
906 ; force s'
907 ; return $ HsStringPrim (w8ToString s) s' }
908 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
909 -- cvtLit should not be called on IntegerL, RationalL
910 -- That precondition is established right here in
911 -- Convert.hs, hence panic
912
913 w8ToString :: [Word8] -> String
914 w8ToString ws = map (\w -> chr (fromIntegral w)) ws
915
916 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
917 cvtPats pats = mapM cvtPat pats
918
919 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
920 cvtPat pat = wrapL (cvtp pat)
921
922 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
923 cvtp (TH.LitP l)
924 | overloadedLit l = do { l' <- cvtOverLit l
925 ; return (mkNPat (noLoc l') Nothing) }
926 -- Not right for negative patterns;
927 -- need to think about that!
928 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
929 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
930 cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
931 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
932 cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
933 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
934 ; return $ ConPatIn s' (PrefixCon ps') }
935 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
936 ; wrapParL ParPat $
937 ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
938 -- See Note [Operator association]
939 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
940 cvtp (ParensP p) = do { p' <- cvtPat p; return $ ParPat p' }
941 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
942 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
943 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
944 cvtp TH.WildP = return $ WildPat placeHolderType
945 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
946 ; return $ ConPatIn c'
947 $ Hs.RecCon (HsRecFields fs' Nothing) }
948 cvtp (ListP ps) = do { ps' <- cvtPats ps
949 ; return $ ListPat ps' placeHolderType Nothing }
950 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
951 ; return $ SigPatIn p' (mkHsWithBndrs t') }
952 cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
953 ; return $ ViewPat e' p' placeHolderType }
954
955 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
956 cvtPatFld (s,p)
957 = do { s' <- vNameL s; p' <- cvtPat p
958 ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap mkFieldOcc s'
959 , hsRecFieldArg = p'
960 , hsRecPun = False}) }
961
962 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
963 The produced tree of infix patterns will be left-biased, provided @x@ is.
964
965 See the @cvtOpApp@ documentation for how this function works.
966 -}
967 cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName)
968 cvtOpAppP x op1 (UInfixP y op2 z)
969 = do { l <- wrapL $ cvtOpAppP x op1 y
970 ; cvtOpAppP l op2 z }
971 cvtOpAppP x op y
972 = do { op' <- cNameL op
973 ; y' <- cvtPat y
974 ; return (ConPatIn op' (InfixCon x y')) }
975
976 -----------------------------------------------------------
977 -- Types and type variables
978
979 cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName)
980 cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
981
982 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
983 cvt_tv (TH.PlainTV nm)
984 = do { nm' <- tName nm
985 ; returnL $ UserTyVar nm' }
986 cvt_tv (TH.KindedTV nm ki)
987 = do { nm' <- tName nm
988 ; ki' <- cvtKind ki
989 ; returnL $ KindedTyVar (noLoc nm') ki' }
990
991 cvtRole :: TH.Role -> Maybe Coercion.Role
992 cvtRole TH.NominalR = Just Coercion.Nominal
993 cvtRole TH.RepresentationalR = Just Coercion.Representational
994 cvtRole TH.PhantomR = Just Coercion.Phantom
995 cvtRole TH.InferR = Nothing
996
997 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
998 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
999
1000 cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
1001 cvtPred = cvtType
1002
1003 cvtType :: TH.Type -> CvtM (LHsType RdrName)
1004 cvtType = cvtTypeKind "type"
1005
1006 cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName)
1007 cvtTypeKind ty_str ty
1008 = do { (head_ty, tys') <- split_ty_app ty
1009 ; case head_ty of
1010 TupleT n
1011 | length tys' == n -- Saturated
1012 -> if n==1 then return (head tys') -- Singleton tuples treated
1013 -- like nothing (ie just parens)
1014 else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
1015 | n == 1
1016 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
1017 | otherwise
1018 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
1019 UnboxedTupleT n
1020 | length tys' == n -- Saturated
1021 -> if n==1 then return (head tys') -- Singleton tuples treated
1022 -- like nothing (ie just parens)
1023 else returnL (HsTupleTy HsUnboxedTuple tys')
1024 | otherwise
1025 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
1026 ArrowT
1027 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
1028 | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
1029 ListT
1030 | [x'] <- tys' -> returnL (HsListTy x')
1031 | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
1032 VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
1033 ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
1034
1035 ForallT tvs cxt ty
1036 | null tys'
1037 -> do { tvs' <- cvtTvs tvs
1038 ; cxt' <- cvtContext cxt
1039 ; ty' <- cvtType ty
1040 ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty'
1041 }
1042
1043 SigT ty ki
1044 -> do { ty' <- cvtType ty
1045 ; ki' <- cvtKind ki
1046 ; mk_apps (HsKindSig ty' ki') tys'
1047 }
1048
1049 LitT lit
1050 -> returnL (HsTyLit (cvtTyLit lit))
1051
1052 WildCardT Nothing
1053 -> mk_apps mkAnonWildCardTy tys'
1054
1055 WildCardT (Just nm)
1056 -> do { nm' <- tName nm; mk_apps (mkNamedWildCardTy nm') tys' }
1057
1058 InfixT t1 s t2
1059 -> do { s' <- tconName s
1060 ; t1' <- cvtType t1
1061 ; t2' <- cvtType t2
1062 ; mk_apps (HsTyVar s') [t1', t2']
1063 }
1064
1065 UInfixT t1 s t2
1066 -> do { t2' <- cvtType t2
1067 ; cvtOpAppT t1 s t2'
1068 } -- Note [Converting UInfix]
1069
1070 ParensT t
1071 -> do { t' <- cvtType t
1072 ; returnL $ HsParTy t'
1073 }
1074
1075 PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' }
1076 -- Promoted data constructor; hence cName
1077
1078 PromotedTupleT n
1079 | n == 1
1080 -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
1081 | m == n -- Saturated
1082 -> do { let kis = replicate m placeHolderKind
1083 ; returnL (HsExplicitTupleTy kis tys')
1084 }
1085 where
1086 m = length tys'
1087
1088 PromotedNilT
1089 -> returnL (HsExplicitListTy placeHolderKind [])
1090
1091 PromotedConsT -- See Note [Representing concrete syntax in types]
1092 -- in Language.Haskell.TH.Syntax
1093 | [ty1, L _ (HsExplicitListTy _ tys2)] <- tys'
1094 -> returnL (HsExplicitListTy placeHolderKind (ty1:tys2))
1095 | otherwise
1096 -> mk_apps (HsTyVar (getRdrName consDataCon)) tys'
1097
1098 StarT
1099 -> returnL (HsTyVar (getRdrName liftedTypeKindTyCon))
1100
1101 ConstraintT
1102 -> returnL (HsTyVar (getRdrName constraintKindTyCon))
1103
1104 EqualityT
1105 | [x',y'] <- tys' -> returnL (HsEqTy x' y')
1106 | otherwise -> mk_apps (HsTyVar (getRdrName eqPrimTyCon)) tys'
1107
1108 _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
1109 }
1110
1111 mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
1112 mk_apps head_ty [] = returnL head_ty
1113 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
1114 ; mk_apps (HsAppTy head_ty' ty) tys }
1115
1116 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
1117 split_ty_app ty = go ty []
1118 where
1119 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
1120 go f as = return (f,as)
1121
1122 cvtTyLit :: TH.TyLit -> HsTyLit
1123 cvtTyLit (NumTyLit i) = HsNumTy (show i) i
1124 cvtTyLit (StrTyLit s) = HsStrTy s (fsLit s)
1125
1126 {- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
1127 application @x `op` y@. The produced tree of infix types will be right-biased,
1128 provided @y@ is.
1129
1130 See the @cvtOpApp@ documentation for how this function works.
1131 -}
1132 cvtOpAppT :: TH.Type -> TH.Name -> LHsType RdrName -> CvtM (LHsType RdrName)
1133 cvtOpAppT (UInfixT x op2 y) op1 z
1134 = do { l <- cvtOpAppT y op1 z
1135 ; cvtOpAppT x op2 l }
1136 cvtOpAppT x op y
1137 = do { op' <- tconNameL op
1138 ; x' <- cvtType x
1139 ; returnL (mkHsOpTy x' op' y) }
1140
1141 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
1142 cvtKind = cvtTypeKind "kind"
1143
1144 -- | Convert Maybe Kind to a type family result signature. Used with data
1145 -- families where naming of the result is not possible (thus only kind or no
1146 -- signature is possible).
1147 cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
1148 -> CvtM (LFamilyResultSig RdrName)
1149 cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig
1150 cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
1151 ; returnL (Hs.KindSig ki') }
1152
1153 -- | Convert type family result signature. Used with both open and closed type
1154 -- families.
1155 cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig RdrName)
1156 cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig
1157 cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki
1158 ; returnL (Hs.KindSig ki') }
1159 cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
1160 ; returnL (Hs.TyVarSig tv) }
1161
1162 -- | Convert injectivity annotation of a type family.
1163 cvtInjectivityAnnotation :: TH.InjectivityAnn
1164 -> CvtM (Hs.LInjectivityAnn RdrName)
1165 cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
1166 = do { annLHS' <- tNameL annLHS
1167 ; annRHS' <- mapM tNameL annRHS
1168 ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
1169
1170 -----------------------------------------------------------
1171 cvtFixity :: TH.Fixity -> Hs.Fixity
1172 cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
1173 where
1174 cvt_dir TH.InfixL = Hs.InfixL
1175 cvt_dir TH.InfixR = Hs.InfixR
1176 cvt_dir TH.InfixN = Hs.InfixN
1177
1178 -----------------------------------------------------------
1179
1180
1181 -----------------------------------------------------------
1182 -- some useful things
1183
1184 overloadedLit :: Lit -> Bool
1185 -- True for literals that Haskell treats as overloaded
1186 overloadedLit (IntegerL _) = True
1187 overloadedLit (RationalL _) = True
1188 overloadedLit _ = False
1189
1190 cvtFractionalLit :: Rational -> FractionalLit
1191 cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
1192
1193 --------------------------------------------------------------------
1194 -- Turning Name back into RdrName
1195 --------------------------------------------------------------------
1196
1197 -- variable names
1198 vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
1199 vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName
1200
1201 -- Variable names
1202 vNameL n = wrapL (vName n)
1203 vName n = cvtName OccName.varName n
1204
1205 -- Constructor function names; this is Haskell source, hence srcDataName
1206 cNameL n = wrapL (cName n)
1207 cName n = cvtName OccName.dataName n
1208
1209 -- Variable *or* constructor names; check by looking at the first char
1210 vcNameL n = wrapL (vcName n)
1211 vcName n = if isVarName n then vName n else cName n
1212
1213 -- Type variable names
1214 tNameL n = wrapL (tName n)
1215 tName n = cvtName OccName.tvName n
1216
1217 -- Type Constructor names
1218 tconNameL n = wrapL (tconName n)
1219 tconName n = cvtName OccName.tcClsName n
1220
1221 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
1222 cvtName ctxt_ns (TH.Name occ flavour)
1223 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
1224 | otherwise
1225 = do { loc <- getL
1226 ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
1227 ; force rdr_name
1228 ; return rdr_name }
1229 where
1230 occ_str = TH.occString occ
1231
1232 okOcc :: OccName.NameSpace -> String -> Bool
1233 okOcc ns str
1234 | OccName.isVarNameSpace ns = okVarOcc str
1235 | OccName.isDataConNameSpace ns = okConOcc str
1236 | otherwise = okTcOcc str
1237
1238 -- Determine the name space of a name in a type
1239 --
1240 isVarName :: TH.Name -> Bool
1241 isVarName (TH.Name occ _)
1242 = case TH.occString occ of
1243 "" -> False
1244 (c:_) -> startsVarId c || startsVarSym c
1245
1246 badOcc :: OccName.NameSpace -> String -> SDoc
1247 badOcc ctxt_ns occ
1248 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
1249 <+> ptext (sLit "name:") <+> quotes (text occ)
1250
1251 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
1252 -- This turns a TH Name into a RdrName; used for both binders and occurrences
1253 -- See Note [Binders in Template Haskell]
1254 -- The passed-in name space tells what the context is expecting;
1255 -- use it unless the TH name knows what name-space it comes
1256 -- from, in which case use the latter
1257 --
1258 -- We pass in a SrcSpan (gotten from the monad) because this function
1259 -- is used for *binders* and if we make an Exact Name we want it
1260 -- to have a binding site inside it. (cf Trac #5434)
1261 --
1262 -- ToDo: we may generate silly RdrNames, by passing a name space
1263 -- that doesn't match the string, like VarName ":+",
1264 -- which will give confusing error messages later
1265 --
1266 -- The strict applications ensure that any buried exceptions get forced
1267 thRdrName loc ctxt_ns th_occ th_name
1268 = case th_name of
1269 TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
1270 TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ
1271 TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
1272 TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
1273 TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
1274 | otherwise -> mkRdrUnqual $! occ
1275 -- We check for built-in syntax here, because the TH
1276 -- user might have written a (NameS "(,,)"), for example
1277 where
1278 occ :: OccName.OccName
1279 occ = mk_occ ctxt_ns th_occ
1280
1281 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
1282 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
1283
1284 thRdrNameGuesses :: TH.Name -> [RdrName]
1285 thRdrNameGuesses (TH.Name occ flavour)
1286 -- This special case for NameG ensures that we don't generate duplicates in the output list
1287 | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
1288 | otherwise = [ thRdrName noSrcSpan gns occ_str flavour
1289 | gns <- guessed_nss]
1290 where
1291 -- guessed_ns are the name spaces guessed from looking at the TH name
1292 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
1293 | otherwise = [OccName.varName, OccName.tvName]
1294 occ_str = TH.occString occ
1295
1296 -- The packing and unpacking is rather turgid :-(
1297 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
1298 mk_occ ns occ = OccName.mkOccName ns occ
1299
1300 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
1301 mk_ghc_ns TH.DataName = OccName.dataName
1302 mk_ghc_ns TH.TcClsName = OccName.tcClsName
1303 mk_ghc_ns TH.VarName = OccName.varName
1304
1305 mk_mod :: TH.ModName -> ModuleName
1306 mk_mod mod = mkModuleName (TH.modString mod)
1307
1308 mk_pkg :: TH.PkgName -> UnitId
1309 mk_pkg pkg = stringToUnitId (TH.pkgString pkg)
1310
1311 mk_uniq :: Int -> Unique
1312 mk_uniq u = mkUniqueGrimily u
1313
1314 {-
1315 Note [Binders in Template Haskell]
1316 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1317 Consider this TH term construction:
1318 do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name
1319 ; x2 <- TH.newName "x" -- Builds a NameU
1320 ; x3 <- TH.newName "x"
1321
1322 ; let x = mkName "x" -- mkName :: String -> TH.Name
1323 -- Builds a NameS
1324
1325 ; return (LamE (..pattern [x1,x2]..) $
1326 LamE (VarPat x3) $
1327 ..tuple (x1,x2,x3,x)) }
1328
1329 It represents the term \[x1,x2]. \x3. (x1,x2,x3,x)
1330
1331 a) We don't want to complain about "x" being bound twice in
1332 the pattern [x1,x2]
1333 b) We don't want x3 to shadow the x1,x2
1334 c) We *do* want 'x' (dynamically bound with mkName) to bind
1335 to the innermost binding of "x", namely x3.
1336 d) When pretty printing, we want to print a unique with x1,x2
1337 etc, else they'll all print as "x" which isn't very helpful
1338
1339 When we convert all this to HsSyn, the TH.Names are converted with
1340 thRdrName. To achieve (b) we want the binders to be Exact RdrNames.
1341 Achieving (a) is a bit awkward, because
1342 - We must check for duplicate and shadowed names on Names,
1343 not RdrNames, *after* renaming.
1344 See Note [Collect binders only after renaming] in HsUtils
1345
1346 - But to achieve (a) we must distinguish between the Exact
1347 RdrNames arising from TH and the Unqual RdrNames that would
1348 come from a user writing \[x,x] -> blah
1349
1350 So in Convert.thRdrName we translate
1351 TH Name RdrName
1352 --------------------------------------------------------
1353 NameU (arising from newName) --> Exact (Name{ System })
1354 NameS (arising from mkName) --> Unqual
1355
1356 Notice that the NameUs generate *System* Names. Then, when
1357 figuring out shadowing and duplicates, we can filter out
1358 System Names.
1359
1360 This use of System Names fits with other uses of System Names, eg for
1361 temporary variables "a". Since there are lots of things called "a" we
1362 usually want to print the name with the unique, and that is indeed
1363 the way System Names are printed.
1364
1365 There's a small complication of course; see Note [Looking up Exact
1366 RdrNames] in RnEnv.
1367 -}