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