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