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