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