2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 This module converts Template Haskell syntax into HsSyn
9 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
10 convertToHsType, thRdrNameGuesses ) where
13 import qualified Class
18 import qualified OccName
24 import BasicTypes as Hs
34 import Control.Monad( unless )
36 import Language.Haskell.TH as TH hiding (sigP)
37 import Language.Haskell.TH.Syntax as TH
41 -------------------------------------------------------------------
42 -- The external interface
44 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
45 convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds)
47 cvt_dec d = wrapMsg "declaration" d (cvtDec d)
49 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
51 = initCvt loc $ wrapMsg "expression" e $ cvtl e
53 convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
55 = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
57 convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
59 = initCvt loc $ wrapMsg "type" t $ cvtType t
61 -------------------------------------------------------------------
62 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
63 -- Push down the source location;
64 -- Can fail, with a single error message
66 -- NB: If the conversion succeeds with (Right x), there should
67 -- be no exception values hiding in x
68 -- Reason: so a (head []) in TH code doesn't subsequently
69 -- make GHC crash when it tries to walk the generated tree
71 -- Use the loc everywhere, for lack of anything better
72 -- In particular, we want it on binding locations, so that variables bound in
73 -- the spliced-in declarations get a location that at least relates to the splice point
75 instance Monad CvtM where
76 return x = CvtM $ \_ -> Right x
77 (CvtM m) >>= k = CvtM $ \loc -> case m loc of
79 Right v -> unCvtM (k v) loc
81 initCvt :: SrcSpan -> CvtM a -> Either Message a
82 initCvt loc (CvtM m) = m loc
85 force a = a `seq` return ()
87 failWith :: Message -> CvtM a
88 failWith m = CvtM (\_ -> Left m)
90 returnL :: a -> CvtM (Located a)
91 returnL x = CvtM (\loc -> Right (L loc x))
93 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
94 -- E.g wrapMsg "declaration" dec thing
95 wrapMsg what item (CvtM m)
96 = CvtM (\loc -> case m loc of
97 Left err -> Left (err $$ getPprStyle msg)
100 -- Show the item in pretty syntax normally,
101 -- but with all its constructors if you say -dppr-debug
102 msg sty = hang (ptext (sLit "When splicing a TH") <+> text what <> colon)
104 then text (show item)
105 else text (pprint item))
107 wrapL :: CvtM a -> CvtM (Located a)
108 wrapL (CvtM m) = CvtM (\loc -> case m loc of
110 Right v -> Right (L loc v))
112 -------------------------------------------------------------------
113 cvtDec :: TH.Dec -> CvtM (LHsDecl RdrName)
114 cvtDec (TH.ValD pat body ds)
116 = do { s' <- vNameL s
117 ; cl' <- cvtClause (Clause [] body ds)
118 ; returnL $ Hs.ValD $ mkFunBind s' [cl'] }
121 = do { pat' <- cvtPat pat
122 ; body' <- cvtGuard body
123 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
124 ; returnL $ Hs.ValD $
125 PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
126 , pat_rhs_ty = void, bind_fvs = placeHolderNames } }
128 cvtDec (TH.FunD nm cls)
130 = failWith (ptext (sLit "Function binding for")
131 <+> quotes (text (TH.pprint nm))
132 <+> ptext (sLit "has no equations"))
134 = do { nm' <- vNameL nm
135 ; cls' <- mapM cvtClause cls
136 ; returnL $ Hs.ValD $ mkFunBind nm' cls' }
138 cvtDec (TH.SigD nm typ)
139 = do { nm' <- vNameL nm
141 ; returnL $ Hs.SigD (TypeSig nm' ty') }
143 cvtDec (PragmaD prag)
144 = do { prag' <- cvtPragmaD prag
145 ; returnL $ Hs.SigD prag' }
147 cvtDec (TySynD tc tvs rhs)
148 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
149 ; rhs' <- cvtType rhs
150 ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
152 cvtDec (DataD ctxt tc tvs constrs derivs)
153 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
154 ; cons' <- mapM cvtConstr constrs
155 ; derivs' <- cvtDerivs derivs
156 ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
157 , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
158 , tcdCons = cons', tcdDerivs = derivs' }) }
160 cvtDec (NewtypeD ctxt tc tvs constr derivs)
161 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
162 ; con' <- cvtConstr constr
163 ; derivs' <- cvtDerivs derivs
164 ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
165 , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
166 , tcdCons = [con'], tcdDerivs = derivs'}) }
168 cvtDec (ClassD ctxt cl tvs fds decs)
169 = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
170 ; fds' <- mapM cvt_fundep fds
171 ; (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
173 TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
174 , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
175 , tcdATs = ats', tcdDocs = [] }
179 cvtDec (InstanceD ctxt ty decs)
180 = do { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs
181 ; ctxt' <- cvtContext ctxt
182 ; L loc pred' <- cvtPredTy ty
183 ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc $ HsPredTy pred'
184 ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') }
186 cvtDec (ForeignD ford)
187 = do { ford' <- cvtForD ford
188 ; returnL $ ForD ford' }
190 cvtDec (FamilyD flav tc tvs kind)
191 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
192 ; let kind' = fmap cvtKind kind
193 ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') }
195 cvtFamFlavour TypeFam = TypeFamily
196 cvtFamFlavour DataFam = DataFamily
198 cvtDec (DataInstD ctxt tc tys constrs derivs)
199 = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
200 ; cons' <- mapM cvtConstr constrs
201 ; derivs' <- cvtDerivs derivs
202 ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
203 , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
204 , tcdCons = cons', tcdDerivs = derivs' }) }
206 cvtDec (NewtypeInstD ctxt tc tys constr derivs)
207 = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
208 ; con' <- cvtConstr constr
209 ; derivs' <- cvtDerivs derivs
210 ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
211 , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
212 , tcdCons = [con'], tcdDerivs = derivs' })
215 cvtDec (TySynInstD tc tys rhs)
216 = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
217 ; rhs' <- cvtType rhs
218 ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
221 cvt_ci_decs :: Message -> [TH.Dec]
222 -> CvtM (LHsBinds RdrName,
225 -- Convert the declarations inside a class or instance decl
226 -- ie signatures, bindings, and associated types
228 = do { decs' <- mapM cvtDec decs
229 ; let (ats', bind_sig_decs') = partitionWith is_tycl decs'
230 ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs'
231 ; let (binds', bads) = partitionWith is_bind prob_binds'
232 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
233 ; return (listToBag binds', sigs', ats') }
236 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
237 -> CvtM ( LHsContext RdrName
239 , [LHsTyVarBndr RdrName])
240 cvt_tycl_hdr cxt tc tvs
241 = do { cxt' <- cvtContext cxt
242 ; tc' <- tconNameL tc
244 ; return (cxt', tc', tvs')
247 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
248 -> CvtM ( LHsContext RdrName
250 , [LHsTyVarBndr RdrName]
251 , Maybe [LHsType RdrName])
252 cvt_tyinst_hdr cxt tc tys
253 = do { cxt' <- cvtContext cxt
254 ; tc' <- tconNameL tc
255 ; tvs <- concatMapM collect tys
257 ; tys' <- mapM cvtType tys
258 ; return (cxt', tc', tvs', Just tys')
261 collect (ForallT _ _ _)
262 = failWith $ text "Forall type not allowed as type parameter"
263 collect (VarT tv) = return [PlainTV tv]
264 collect (ConT _) = return []
265 collect (TupleT _) = return []
266 collect ArrowT = return []
267 collect ListT = return []
269 = do { tvs1 <- collect t1
271 ; return $ tvs1 ++ tvs2
273 collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
274 collect (SigT ty _) = collect ty
276 -------------------------------------------------------------------
277 -- Partitioning declarations
278 -------------------------------------------------------------------
280 is_tycl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
281 is_tycl (L loc (Hs.TyClD tcd)) = Left (L loc tcd)
282 is_tycl decl = Right decl
284 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
285 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
286 is_sig decl = Right decl
288 is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
289 is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
290 is_bind decl = Right decl
292 mkBadDecMsg :: Message -> [LHsDecl RdrName] -> Message
294 = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
295 , nest 2 (vcat (map Outputable.ppr bads)) ]
297 ---------------------------------------------------
299 -- Can't handle GADTs yet
300 ---------------------------------------------------
302 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
304 cvtConstr (NormalC c strtys)
305 = do { c' <- cNameL c
307 ; tys' <- mapM cvt_arg strtys
308 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
310 cvtConstr (RecC c varstrtys)
311 = do { c' <- cNameL c
313 ; args' <- mapM cvt_id_arg varstrtys
314 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
316 cvtConstr (InfixC st1 c st2)
317 = do { c' <- cNameL c
319 ; st1' <- cvt_arg st1
320 ; st2' <- cvt_arg st2
321 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
323 cvtConstr (ForallC tvs ctxt con)
324 = do { tvs' <- cvtTvs tvs
325 ; L loc ctxt' <- cvtContext ctxt
326 ; L _ con' <- cvtConstr con
327 ; returnL $ con' { con_qvars = tvs' ++ con_qvars con'
328 , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
330 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
331 cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
332 cvt_arg (NotStrict, ty) = cvtType ty
334 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
335 cvt_id_arg (i, str, ty)
336 = do { i' <- vNameL i
337 ; ty' <- cvt_arg (str,ty)
338 ; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) }
340 cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
341 cvtDerivs [] = return Nothing
342 cvtDerivs cs = do { cs' <- mapM cvt_one cs
343 ; return (Just cs') }
345 cvt_one c = do { c' <- tconName c
346 ; returnL $ HsPredTy $ HsClassP c' [] }
348 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
349 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
351 noExistentials :: [LHsTyVarBndr RdrName]
354 ------------------------------------------
355 -- Foreign declarations
356 ------------------------------------------
358 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
359 cvtForD (ImportF callconv safety from nm ty)
360 | Just impspec <- parseCImport (cvt_conv callconv) safety'
361 (mkFastString (TH.nameBase nm)) from
362 = do { nm' <- vNameL nm
364 ; return (ForeignImport nm' ty' impspec)
367 = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
369 safety' = case safety of
371 Safe -> PlaySafe False
372 Threadsafe -> PlaySafe True
374 cvtForD (ExportF callconv as nm ty)
375 = do { nm' <- vNameL nm
377 ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
378 ; return $ ForeignExport nm' ty' e }
380 cvt_conv :: TH.Callconv -> CCallConv
381 cvt_conv TH.CCall = CCallConv
382 cvt_conv TH.StdCall = StdCallConv
384 ------------------------------------------
386 ------------------------------------------
388 cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
389 cvtPragmaD (InlineP nm ispec)
390 = do { nm' <- vNameL nm
391 ; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) }
393 cvtPragmaD (SpecialiseP nm ty opt_ispec)
394 = do { nm' <- vNameL nm
396 ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) }
398 cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
399 cvtInlineSpec Nothing
400 = defaultInlinePragma
401 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
402 = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
403 , inl_inline = inline, inl_sat = Nothing }
405 matchinfo = cvtRuleMatchInfo conlike
406 opt_activation' = cvtActivation opt_activation
408 cvtRuleMatchInfo False = FunLike
409 cvtRuleMatchInfo True = ConLike
411 cvtActivation Nothing | inline = AlwaysActive
412 | otherwise = NeverActive
413 cvtActivation (Just (False, phase)) = ActiveBefore phase
414 cvtActivation (Just (True , phase)) = ActiveAfter phase
416 ---------------------------------------------------
418 ---------------------------------------------------
420 cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
423 = return EmptyLocalBinds
425 = do { ds' <- mapM cvtDec ds
426 ; let (binds, prob_sigs) = partitionWith is_bind ds'
427 ; let (sigs, bads) = partitionWith is_sig prob_sigs
428 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
429 ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
431 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
432 cvtClause (Clause ps body wheres)
433 = do { ps' <- cvtPats ps
434 ; g' <- cvtGuard body
435 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
436 ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
439 -------------------------------------------------------------------
441 -------------------------------------------------------------------
443 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
444 cvtl e = wrapL (cvt e)
446 cvt (VarE s) = do { s' <- vName s; return $ HsVar s' }
447 cvt (ConE s) = do { s' <- cName s; return $ HsVar s' }
449 | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
450 | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
452 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
453 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
454 ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
455 cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens)
456 cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
457 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
458 ; return $ HsIf x' y' z' }
459 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
460 ; e' <- cvtl e; return $ HsLet ds' e' }
462 | null ms = failWith (ptext (sLit "Case expression with no alternatives"))
463 | otherwise = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
464 ; return $ HsCase e' (mkMatchGroup ms') }
465 cvt (DoE ss) = cvtHsDo DoExpr ss
466 cvt (CompE ss) = cvtHsDo ListComp ss
467 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
469 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
470 -- Note [Converting strings]
471 | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
472 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
473 ; e' <- returnL $ OpApp x' s' undefined y'
474 ; return $ HsPar e' }
475 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
476 ; sec <- returnL $ SectionR s' y'
477 ; return $ HsPar sec }
478 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
479 ; sec <- returnL $ SectionL x' s'
480 ; return $ HsPar sec }
481 cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
483 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
484 ; return $ ExprWithTySig e' t' }
485 cvt (RecConE c flds) = do { c' <- cNameL c
486 ; flds' <- mapM cvtFld flds
487 ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
488 cvt (RecUpdE e flds) = do { e' <- cvtl e
489 ; flds' <- mapM cvtFld flds
490 ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
492 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
494 = do { v' <- vNameL v; e' <- cvtl e
495 ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
497 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
498 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
499 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
500 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
501 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
503 -------------------------------------
504 -- Do notation and statements
505 -------------------------------------
507 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
508 cvtHsDo do_or_lc stmts
509 | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
511 = do { stmts' <- cvtStmts stmts
512 ; body <- case last stmts' of
513 L _ (ExprStmt body _ _) -> return body
514 stmt' -> failWith (bad_last stmt')
515 ; return $ HsDo do_or_lc (init stmts') body void }
517 bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
518 , nest 2 $ Outputable.ppr stmt
519 , ptext (sLit "(It should be an expression.)") ]
521 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
522 cvtStmts = mapM cvtStmt
524 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
525 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
526 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
527 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
528 ; returnL $ LetStmt ds' }
529 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
531 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
533 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
534 cvtMatch (TH.Match p body decs)
535 = do { p' <- cvtPat p
536 ; g' <- cvtGuard body
537 ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
538 ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
540 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
541 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
542 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
544 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
545 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
546 ; g' <- returnL $ mkExprStmt ge'
547 ; returnL $ GRHS [g'] rhs' }
548 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
549 ; returnL $ GRHS gs' rhs' }
551 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
552 cvtOverLit (IntegerL i)
553 = do { force i; return $ mkHsIntegral i placeHolderType}
554 cvtOverLit (RationalL r)
555 = do { force r; return $ mkHsFractional r placeHolderType}
556 cvtOverLit (StringL s)
557 = do { let { s' = mkFastString s }
559 ; return $ mkHsIsString s' placeHolderType
561 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
562 -- An Integer is like an (overloaded) '3' in a Haskell source program
563 -- Similarly 3.5 for fractionals
565 {- Note [Converting strings]
566 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
567 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
568 a string literal for "xy". Of course, we might hope to get
569 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
570 if it isn't a literal string
573 allCharLs :: [TH.Exp] -> Maybe String
574 -- Note [Converting strings]
575 -- NB: only fire up this setup for a non-empty list, else
576 -- there's a danger of returning "" for [] :: [Int]!
579 LitE (CharL c) : ys -> go [c] ys
582 go cs [] = Just (reverse cs)
583 go cs (LitE (CharL c) : ys) = go (c:cs) ys
586 cvtLit :: Lit -> CvtM HsLit
587 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
588 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
589 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
590 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
591 cvtLit (CharL c) = do { force c; return $ HsChar c }
593 = do { let { s' = mkFastString s }
595 ; return $ HsString s'
597 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
598 -- cvtLit should not be called on IntegerL, RationalL
599 -- That precondition is established right here in
600 -- Convert.lhs, hence panic
602 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
603 cvtPats pats = mapM cvtPat pats
605 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
606 cvtPat pat = wrapL (cvtp pat)
608 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
610 | overloadedLit l = do { l' <- cvtOverLit l
611 ; return (mkNPat l' Nothing) }
612 -- Not right for negative patterns;
613 -- need to think about that!
614 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
615 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
616 cvtp (TupP [p]) = cvtp p
617 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
618 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
619 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
620 ; return $ ConPatIn s' (InfixCon p1' p2') }
621 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
622 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
623 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
624 cvtp TH.WildP = return $ WildPat void
625 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
626 ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
627 cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
628 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
630 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
632 = do { s' <- vNameL s; p' <- cvtPat p
633 ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
635 -----------------------------------------------------------
636 -- Types and type variables
638 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
639 cvtTvs tvs = mapM cvt_tv tvs
641 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
642 cvt_tv (TH.PlainTV nm)
643 = do { nm' <- tName nm
644 ; returnL $ UserTyVar nm' placeHolderKind
646 cvt_tv (TH.KindedTV nm ki)
647 = do { nm' <- tName nm
648 ; returnL $ KindedTyVar nm' (cvtKind ki)
651 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
652 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
654 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
655 cvtPred (TH.ClassP cla tys)
656 = do { cla' <- if isVarName cla then tName cla else tconName cla
657 ; tys' <- mapM cvtType tys
658 ; returnL $ HsClassP cla' tys'
660 cvtPred (TH.EqualP ty1 ty2)
661 = do { ty1' <- cvtType ty1
662 ; ty2' <- cvtType ty2
663 ; returnL $ HsEqualP ty1' ty2'
666 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
668 = do { (head, tys') <- split_ty_app ty
670 ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
671 VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' }
672 _ -> failWith (ptext (sLit "Malformed predicate") <+>
673 text (TH.pprint ty)) }
675 cvtType :: TH.Type -> CvtM (LHsType RdrName)
677 = do { (head_ty, tys') <- split_ty_app ty
680 | length tys' == n -- Saturated
681 -> if n==1 then return (head tys') -- Singleton tuples treated
682 -- like nothing (ie just parens)
683 else returnL (HsTupleTy Boxed tys')
685 -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
687 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
689 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
690 | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
692 | [x'] <- tys' -> returnL (HsListTy x')
693 | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
694 VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
695 ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
699 -> do { tvs' <- cvtTvs tvs
700 ; cxt' <- cvtContext cxt
702 ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
706 -> do { ty' <- cvtType ty
707 ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
710 _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
713 mk_apps head_ty [] = returnL head_ty
714 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
715 ; mk_apps (HsAppTy head_ty' ty) tys }
717 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
718 split_ty_app ty = go ty []
720 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
721 go f as = return (f,as)
723 cvtKind :: TH.Kind -> Type.Kind
724 cvtKind StarK = liftedTypeKind
725 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
727 -----------------------------------------------------------
730 -----------------------------------------------------------
731 -- some useful things
733 overloadedLit :: Lit -> Bool
734 -- True for literals that Haskell treats as overloaded
735 overloadedLit (IntegerL _) = True
736 overloadedLit (RationalL _) = True
737 overloadedLit _ = False
740 void = placeHolderType
742 --------------------------------------------------------------------
743 -- Turning Name back into RdrName
744 --------------------------------------------------------------------
747 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
748 vName, cName, tName, tconName :: TH.Name -> CvtM RdrName
750 vNameL n = wrapL (vName n)
751 vName n = cvtName OccName.varName n
753 -- Constructor function names; this is Haskell source, hence srcDataName
754 cNameL n = wrapL (cName n)
755 cName n = cvtName OccName.dataName n
757 -- Type variable names
758 tName n = cvtName OccName.tvName n
760 -- Type Constructor names
761 tconNameL n = wrapL (tconName n)
762 tconName n = cvtName OccName.tcClsName n
764 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
765 cvtName ctxt_ns (TH.Name occ flavour)
766 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
767 | otherwise = force rdr_name >> return rdr_name
769 occ_str = TH.occString occ
770 rdr_name = thRdrName ctxt_ns occ_str flavour
772 okOcc :: OccName.NameSpace -> String -> Bool
775 | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
776 | otherwise = startsConId c || startsConSym c || str == "[]"
778 -- Determine the name space of a name in a type
780 isVarName :: TH.Name -> Bool
781 isVarName (TH.Name occ _)
782 = case TH.occString occ of
784 (c:_) -> startsVarId c || startsVarSym c
786 badOcc :: OccName.NameSpace -> String -> SDoc
788 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
789 <+> ptext (sLit "name:") <+> quotes (text occ)
791 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
792 -- This turns a Name into a RdrName
793 -- The passed-in name space tells what the context is expecting;
794 -- use it unless the TH name knows what name-space it comes
795 -- from, in which case use the latter
797 -- ToDo: we may generate silly RdrNames, by passing a name space
798 -- that doesn't match the string, like VarName ":+",
799 -- which will give confusing error messages later
801 -- The strict applications ensure that any buried exceptions get forced
802 thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
803 thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
804 thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
805 thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
806 thRdrName ctxt_ns occ TH.NameS
807 | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name
808 | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ)
810 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
811 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
813 thRdrNameGuesses :: TH.Name -> [RdrName]
814 thRdrNameGuesses (TH.Name occ flavour)
815 -- This special case for NameG ensures that we don't generate duplicates in the output list
816 | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
817 | otherwise = [ thRdrName gns occ_str flavour
818 | gns <- guessed_nss]
820 -- guessed_ns are the name spaces guessed from looking at the TH name
821 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
822 | otherwise = [OccName.varName, OccName.tvName]
823 occ_str = TH.occString occ
825 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
826 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
827 -- We must generate an Exact name, just as the parser does
828 isBuiltInOcc ctxt_ns occ
830 ":" -> Just (Name.getName consDataCon)
831 "[]" -> Just (Name.getName nilDataCon)
832 "()" -> Just (tup_name 0)
833 '(' : ',' : rest -> go_tuple 2 rest
836 go_tuple n ")" = Just (tup_name n)
837 go_tuple n (',' : rest) = go_tuple (n+1) rest
838 go_tuple _ _ = Nothing
841 | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
842 | otherwise = Name.getName (tupleCon Boxed n)
844 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
845 mk_uniq_occ ns occ uniq
846 = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
847 -- See Note [Unique OccNames from Template Haskell]
849 -- The packing and unpacking is rather turgid :-(
850 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
851 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
853 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
854 mk_ghc_ns TH.DataName = OccName.dataName
855 mk_ghc_ns TH.TcClsName = OccName.tcClsName
856 mk_ghc_ns TH.VarName = OccName.varName
858 mk_mod :: TH.ModName -> ModuleName
859 mk_mod mod = mkModuleName (TH.modString mod)
861 mk_pkg :: TH.PkgName -> PackageId
862 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
864 mk_uniq :: Int# -> Unique
865 mk_uniq u = mkUniqueGrimily (I# u)
868 Note [Unique OccNames from Template Haskell]
869 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
870 The idea here is to make a name that
871 a) the user could not possibly write (it has a "["
872 and letters or digits from the unique)
873 b) cannot clash with another NameU
874 Previously I generated an Exact RdrName with mkInternalName. This
875 works fine for local binders, but does not work at all for top-level
876 binders, which must have External Names, since they are rapidly baked
877 into data constructors and the like. Baling out and generating an
878 unqualified RdrName here is the simple solution
880 See also Note [Suppressing uniques in OccNames] in OccName, which
881 suppresses the unique when opt_SuppressUniques is on.