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