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