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