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